From 54cde60d7e67872bb98b07ad03acd536cd7626d0 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 19 Apr 2018 11:30:26 +0100 Subject: Add anonymous record arms to unions (Preprocessed into a real record type with a fresh id and a reference to that generated record type.) --- src/parse_ast.ml | 1 + src/parser.mly | 2 ++ src/process_file.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++ src/rewrites.mli | 3 +++ src/type_check.ml | 1 + 5 files changed, 51 insertions(+) (limited to 'src') diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 826d8eb1..635caa9c 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -363,6 +363,7 @@ funcl_aux = (* Function clause *) type type_union_aux = (* Type union constructors *) Tu_ty_id of atyp * id + | Tu_ty_anon_rec of (atyp * id) list * id type diff --git a/src/parser.mly b/src/parser.mly index 0846d4bb..c0559719 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1168,6 +1168,8 @@ type_union: { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } | id Colon typ MinusGt typ { (fun s e -> Tu_aux (Tu_ty_id (mk_typ (ATyp_fn ($3, $5, mk_typ (ATyp_set []) s e)) s e, $1), loc s e)) $startpos $endpos } + | id Colon Lcurly struct_fields Rcurly + { Tu_aux (Tu_ty_anon_rec ($4, $1), loc $startpos $endpos) } type_unions: | type_union diff --git a/src/process_file.ml b/src/process_file.ml index a576c16e..681d7c68 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -112,6 +112,36 @@ let cond_pragma defs = in scan defs +let astid_to_string (Ast.Id_aux (id, _)) = + match id with + | Ast.Id x | Ast.DeIid x -> x + +let parseid_to_string (Parse_ast.Id_aux (id, _)) = + match id with + | Parse_ast.Id x | Parse_ast.DeIid x -> x + +let rec realise_union_anon_rec_types (Parse_ast.TD_variant (union_id, name_scm_opt, typq, _, flag) as orig_union) arms = + match arms with + | [] -> [] + | arm :: arms -> + match arm with + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id _), _)) -> (None, arm) :: realise_union_anon_rec_types orig_union arms + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_anon_rec (fields, id)), l)) -> + let open Parse_ast in + let ast_record_id = Rewrites.fresh_id ("__anon_rec_" ^ parseid_to_string union_id ^ "_") (Parse_ast.Generated l) in + let record_str = astid_to_string ast_record_id in + let record_id = Id_aux (Id record_str, Generated l) in + let new_arm = Parse_ast.Tu_aux + ((Parse_ast.Tu_ty_id ( + (Parse_ast.ATyp_aux (ATyp_id record_id, Generated l)), + id) + ), Parse_ast.Generated l) in + let new_rec_def = Parse_ast.DEF_type (Parse_ast.TD_aux ( + Parse_ast.TD_record (record_id, name_scm_opt, typq, fields, flag), + Generated l + )) in + (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) + let rec preprocess = function | [] -> [] | Parse_ast.DEF_pragma ("define", symbol, _) :: defs -> @@ -167,6 +197,20 @@ let rec preprocess = function | Parse_ast.DEF_pragma (p, arg, _) :: defs -> (Util.warn ("Bad pragma $" ^ p ^ " " ^ arg); preprocess defs) + (* realise any anonymous record arms of variants *) + | Parse_ast.DEF_type (Parse_ast.TD_aux + (Parse_ast.TD_variant (id, name_scm_opt, typq, arms, flag) as union, l) + ) :: defs -> + let records_and_arms = realise_union_anon_rec_types union arms in + let rec filter_records = function [] -> [] + | Some x :: xs -> x :: filter_records xs + | None :: xs -> filter_records xs + in + let generated_records = filter_records (List.map fst records_and_arms) in + let rewritten_arms = List.map snd records_and_arms in + let rewritten_union = Parse_ast.TD_variant (id, name_scm_opt, typq, rewritten_arms, flag) in + generated_records @ (Parse_ast.DEF_type (Parse_ast.TD_aux (rewritten_union, l))) :: preprocess defs + | (Parse_ast.DEF_default (Parse_ast.DT_aux (Parse_ast.DT_order (_, Parse_ast.ATyp_aux (atyp, _)), _)) as def) :: defs -> begin match atyp with | Parse_ast.ATyp_inc -> symbols := StringSet.add "_DEFAULT_INC" !symbols; def :: preprocess defs diff --git a/src/rewrites.mli b/src/rewrites.mli index 41a13ffa..70cb75af 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -51,6 +51,9 @@ open Ast open Type_check +(* Generate a fresh id with the given prefix *) +val fresh_id : string -> l -> id + (* Re-write undefined to functions created by -undefined_gen flag *) val rewrite_undefined : bool -> tannot defs -> tannot defs diff --git a/src/type_check.ml b/src/type_check.ml index 5c72983a..cd44fd58 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3675,6 +3675,7 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = env |> Env.add_union_id v (typq, typ') |> Env.add_val_spec v (typq, typ') + | Tu_ty_anon_rec _ -> typ_error l "Unrewritten Tu_ty_anon_rec seen by typechecker" (* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) let mk_synonym typq typ = -- cgit v1.2.3 From 60789530d9ea6bb6a6cf8a30e8584e45afda31e8 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 19 Apr 2018 11:43:44 +0100 Subject: fix warnings --- src/type_check.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index cd44fd58..5c72983a 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3675,7 +3675,6 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = env |> Env.add_union_id v (typq, typ') |> Env.add_val_spec v (typq, typ') - | Tu_ty_anon_rec _ -> typ_error l "Unrewritten Tu_ty_anon_rec seen by typechecker" (* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) let mk_synonym typq typ = -- cgit v1.2.3 From 26a532557c9e05d9b1b62b5d8d6223bcf44cadd7 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 19 Apr 2018 12:14:23 +0100 Subject: Use a naming scheme rather than random fresh ids for union anonymous records --- src/process_file.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/src/process_file.ml b/src/process_file.ml index 681d7c68..7f6e091b 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -128,8 +128,7 @@ let rec realise_union_anon_rec_types (Parse_ast.TD_variant (union_id, name_scm_o | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id _), _)) -> (None, arm) :: realise_union_anon_rec_types orig_union arms | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_anon_rec (fields, id)), l)) -> let open Parse_ast in - let ast_record_id = Rewrites.fresh_id ("__anon_rec_" ^ parseid_to_string union_id ^ "_") (Parse_ast.Generated l) in - let record_str = astid_to_string ast_record_id in + let record_str = "_" ^ parseid_to_string union_id ^ "_" ^ parseid_to_string id ^ "_record" in let record_id = Id_aux (Id record_str, Generated l) in let new_arm = Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id ( -- cgit v1.2.3 From 19954125d633caa84b6d419b7b1224077df0fcb5 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 19 Apr 2018 12:15:22 +0100 Subject: tidy --- src/process_file.ml | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/process_file.ml b/src/process_file.ml index 7f6e091b..7f9ef069 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -130,15 +130,8 @@ let rec realise_union_anon_rec_types (Parse_ast.TD_variant (union_id, name_scm_o let open Parse_ast in let record_str = "_" ^ parseid_to_string union_id ^ "_" ^ parseid_to_string id ^ "_record" in let record_id = Id_aux (Id record_str, Generated l) in - let new_arm = Parse_ast.Tu_aux - ((Parse_ast.Tu_ty_id ( - (Parse_ast.ATyp_aux (ATyp_id record_id, Generated l)), - id) - ), Parse_ast.Generated l) in - let new_rec_def = Parse_ast.DEF_type (Parse_ast.TD_aux ( - Parse_ast.TD_record (record_id, name_scm_opt, typq, fields, flag), - Generated l - )) in + let new_arm = Tu_aux ((Tu_ty_id ((ATyp_aux (ATyp_id record_id, Generated l)), id)), Generated l) in + let new_rec_def = DEF_type (TD_aux (TD_record (record_id, name_scm_opt, typq, fields, flag), Generated l)) in (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) let rec preprocess = function -- cgit v1.2.3 From 4c80d8b02c65bf39cfaf6cc2a3a595f3b47e27ae Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 20 Apr 2018 14:12:53 +0100 Subject: Type_check: factor rewrite_pexps_with_guards out of rewrite_defs_pat_lits --- src/rewrites.ml | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index cfeae1e3..6a8c21b0 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2768,28 +2768,14 @@ let rewrite_defs_internal_lets = ; rewrite_defs = rewrite_defs_base } -let rewrite_defs_pat_lits = +let rewrite_pexps_with_guards rewrite_pat = let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = let guards = ref [] in - let counter = ref 0 in - - let rewrite_pat = function - | P_lit lit, p_annot -> - let env = env_of_annot p_annot in - let typ = typ_of_annot p_annot in - let id = mk_id ("p" ^ string_of_int !counter ^ "#") in - let guard = mk_exp (E_app_infix (mk_exp (E_id id), mk_id "==", mk_exp (E_lit lit))) in - let guard = check_exp (Env.add_local id (Immutable, typ) env) guard bool_typ in - guards := guard :: !guards; - incr counter; - P_aux (P_id id, p_annot) - | p_aux, p_annot -> P_aux (p_aux, p_annot) - in match pexp_aux with | Pat_exp (pat, exp) -> begin - let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat } pat in + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in match !guards with | [] -> pexp | (g :: gs) -> @@ -2798,7 +2784,7 @@ let rewrite_defs_pat_lits = end | Pat_when (pat, guard, exp) -> begin - let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat } pat in + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in let guard_annot = (fst annot, Some (env_of exp, bool_typ, no_effect)) in Pat_aux (Pat_when (pat, List.fold_left (fun g g' -> E_aux (E_app (mk_id "and_bool", [g; g']), guard_annot)) guard !guards, exp), annot) end @@ -2808,6 +2794,22 @@ let rewrite_defs_pat_lits = rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } +let rewrite_defs_pat_lits = + let counter = ref 0 in + let rewrite_pat guards = function + | P_lit lit, p_annot -> + let env = env_of_annot p_annot in + let typ = typ_of_annot p_annot in + let id = mk_id ("p" ^ string_of_int !counter ^ "#") in + let guard = mk_exp (E_app_infix (mk_exp (E_id id), mk_id "==", mk_exp (E_lit lit))) in + let guard = check_exp (Env.add_local id (Immutable, typ) env) guard bool_typ in + guards := guard :: !guards; + incr counter; + P_aux (P_id id, p_annot) + | p_aux, p_annot -> P_aux (p_aux, p_annot) + in + rewrite_pexps_with_guards rewrite_pat + (* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, * internal let-expressions, or internal plet-expressions ended by a term that does not * access memory or registers and does not update variables *) -- cgit v1.2.3 From be9f73fe3bdf3a269e9f3e1b53032ab62091b3d9 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 23 Apr 2018 11:43:25 +0100 Subject: more refactoring of pexp rewriters --- src/rewrites.ml | 49 ++++++++++++++++++++++++++++--------------------- src/type_check.ml | 4 ++++ src/type_check.mli | 8 ++++++++ 3 files changed, 40 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 6a8c21b0..1ab2a9e0 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2768,28 +2768,35 @@ let rewrite_defs_internal_lets = ; rewrite_defs = rewrite_defs_base } -let rewrite_pexps_with_guards rewrite_pat = - let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = - let guards = ref [] in - match pexp_aux with - | Pat_exp (pat, exp) -> - begin - let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in - match !guards with - | [] -> pexp - | (g :: gs) -> - let guard_annot = (fst annot, Some (env_of exp, bool_typ, no_effect)) in - Pat_aux (Pat_when (pat, List.fold_left (fun g g' -> E_aux (E_app (mk_id "and_bool", [g; g']), guard_annot)) g gs, exp), annot) - end - | Pat_when (pat, guard, exp) -> - begin - let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in - let guard_annot = (fst annot, Some (env_of exp, bool_typ, no_effect)) in - Pat_aux (Pat_when (pat, List.fold_left (fun g g' -> E_aux (E_app (mk_id "and_bool", [g; g']), guard_annot)) guard !guards, exp), annot) - end - in +let fold_guards guards = + match guards with + | [] -> (mk_exp (E_lit (mk_lit L_true))) + | g :: gs -> List.fold_left (fun g g' -> mk_exp (E_app (mk_id "and_bool", [strip_exp g; strip_exp g']))) g gs + + +let rewrite_pexp_with_guards rewrite_pat (Pat_aux (pexp_aux, (annot: tannot annot)) as pexp) = + let guards = ref [] in + + match pexp_aux with + | Pat_exp (pat, exp) -> + begin + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in + match !guards with + | [] -> pexp + | gs -> + let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp gs |> fold_guards, strip_exp exp)) in + check_case (env_of_annot annot) (pat_typ_of pat) unchecked_pexp (typ_of_annot annot) + end + | Pat_when (pat, guard, exp) -> + begin + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in + let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp !guards |> fold_guards, strip_exp exp)) in + check_case (env_of_annot annot) (pat_typ_of pat) unchecked_pexp (typ_of_annot annot) + end + +let pexp_rewriters rewrite_pexp = let alg = { id_exp_alg with pat_aux = (fun (pexp_aux, annot) -> rewrite_pexp (Pat_aux (pexp_aux, annot))) } in rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } @@ -2808,7 +2815,7 @@ let rewrite_defs_pat_lits = P_aux (P_id id, p_annot) | p_aux, p_annot -> P_aux (p_aux, p_annot) in - rewrite_pexps_with_guards rewrite_pat + pexp_rewriters (rewrite_pexp_with_guards rewrite_pat) (* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, * internal let-expressions, or internal plet-expressions ended by a term that does not diff --git a/src/type_check.ml b/src/type_check.ml index 5c72983a..63fab70e 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1906,6 +1906,10 @@ let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot) let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) +let typ_of_pexp (Pat_aux (_, (l, tannot))) = typ_of_annot (l, tannot) + +let env_of_pexp (Pat_aux (_, (l, tannot))) = env_of_annot (l, tannot) + (* Flow typing *) let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with diff --git a/src/type_check.mli b/src/type_check.mli index a047db9c..c0359516 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -203,6 +203,9 @@ val strip_exp : 'a exp -> unit exp (** Strip the type annotations from a pattern *) val strip_pat : 'a pat -> unit pat +(** Strip the type annotations from a pattern-expression *) +val strip_pexp : 'a pexp -> unit pexp + (** Strip the type annotations from an l-expression *) val strip_lexp : 'a lexp -> unit lexp @@ -218,6 +221,8 @@ val check_exp : Env.t -> unit exp -> typ -> tannot exp val infer_exp : Env.t -> unit exp -> tannot exp +val check_case : Env.t -> typ -> unit pexp -> typ -> tannot pexp + val prove : Env.t -> n_constraint -> bool val solve : Env.t -> nexp -> Big_int.num option @@ -245,6 +250,9 @@ val typ_of_annot : Ast.l * tannot -> typ val pat_typ_of : tannot pat -> typ val pat_env_of : tannot pat -> Env.t +val typ_of_pexp : tannot pexp -> typ +val env_of_pexp : tannot pexp -> Env.t + val effect_of : tannot exp -> effect val effect_of_pat : tannot pat -> effect val effect_of_annot : tannot -> effect -- cgit v1.2.3 From 319c6c6e922965cc02de969f1ce9e1e4fd0ac1d5 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 23 Apr 2018 13:31:18 +0100 Subject: add { ~~fieldname } sugar to record patterns, expanding to { fieldname = fieldname }\n\nCan't use ~ for this to be exactly like OCaml, as is used for 'not' and explicitly allowed as an identifier --- src/lexer.mll | 1 + src/parser.mly | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/lexer.mll b/src/lexer.mll index 0b756d84..1fe2a849 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -215,6 +215,7 @@ rule token = parse | "2" ws "^" { TwoCaret } | "^" { (Caret(r"^")) } | "::" { ColonColon(r "::") } + | "~~" { TildeTilde(r "~~") } | ":" { Colon(r ":") } | "," { Comma } | ".." { DotDot } diff --git a/src/parser.mly b/src/parser.mly index c0559719..d126e253 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -177,7 +177,7 @@ let rec desugar_rchain chain s e = %token String Bin Hex Real %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token Colon ColonColon ExclEq +%token Colon ColonColon TildeTilde ExclEq %token GtEq %token LtEq @@ -1046,6 +1046,8 @@ atomic_exp: fexp_exp: | atomic_exp Eq exp { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TildeTilde id + { mk_exp (E_app_infix (mk_exp (E_id $2) $startpos($2) $endpos($2), mk_id (Id "=") $startpos $endpos, mk_exp (E_id $2) $startpos($2) $endpos($2))) $startpos $endpos } fexp_exp_list: | fexp_exp -- cgit v1.2.3 From a9c5ebc1c1c0943f48c31831f95dd4d1d61b8dc3 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 23 Apr 2018 16:01:40 +0100 Subject: fix refactored rewrite_pexp_with_guards (where type information is and is not...) --- src/rewrites.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 1ab2a9e0..591bc276 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2786,13 +2786,13 @@ let rewrite_pexp_with_guards rewrite_pat (Pat_aux (pexp_aux, (annot: tannot anno | [] -> pexp | gs -> let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp gs |> fold_guards, strip_exp exp)) in - check_case (env_of_annot annot) (pat_typ_of pat) unchecked_pexp (typ_of_annot annot) + check_case (pat_env_of pat) (pat_typ_of pat) unchecked_pexp (typ_of exp) end | Pat_when (pat, guard, exp) -> begin let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp !guards |> fold_guards, strip_exp exp)) in - check_case (env_of_annot annot) (pat_typ_of pat) unchecked_pexp (typ_of_annot annot) + check_case (pat_env_of pat) (pat_typ_of pat) unchecked_pexp (typ_of exp) end -- cgit v1.2.3 From 14510c80fa9d105ab61f0ecfb96ea89f7edf6587 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 23 Apr 2018 16:04:37 +0100 Subject: start of string pattern matching: currently only literals --- src/ast_util.ml | 2 + src/initial_check.ml | 1 + src/lexer.mll | 1 + src/parse_ast.ml | 1 + src/parser.mly | 4 +- src/pattern_completeness.ml | 7 +++ src/rewriter.ml | 5 ++ src/rewriter.mli | 1 + src/rewrites.ml | 109 ++++++++++++++++++++++++++++++++++++++++++++ src/sail_lib.ml | 6 +++ src/type_check.ml | 20 ++++++++ src/value.ml | 15 ++++++ 12 files changed, 171 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 2f2d27d8..0817e46c 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -438,6 +438,7 @@ and map_pat_annot_aux f = function | P_vector_concat pats -> P_vector_concat (List.map (map_pat_annot f) pats) | P_vector pats -> P_vector (List.map (map_pat_annot f) pats) | P_cons (pat1, pat2) -> P_cons (map_pat_annot f pat1, map_pat_annot f pat2) + | P_string_append (pat1, pat2) -> P_string_append (map_pat_annot f pat1, map_pat_annot f pat2) and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) and map_letbind_annot f (LB_aux (lb, annot)) = LB_aux (map_letbind_annot_aux f lb, f annot) and map_letbind_annot_aux f = function @@ -710,6 +711,7 @@ and string_of_pat (P_aux (pat, l)) = | P_vector_concat pats -> string_of_list " : " string_of_pat pats | P_vector pats -> "[" ^ string_of_list ", " string_of_pat pats ^ "]" | P_as (pat, id) -> string_of_pat pat ^ " as " ^ string_of_id id + | P_string_append (pat1, pat2) -> string_of_pat pat1 ^ " ^^ " ^ string_of_pat pat2 | _ -> "PAT" and string_of_lexp (LEXP_aux (lexp, _)) = match lexp with diff --git a/src/initial_check.ml b/src/initial_check.ml index 62c1af02..a294d70a 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -468,6 +468,7 @@ let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pa | 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) | Parse_ast.P_cons(pat1, pat2) -> P_cons (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) + | Parse_ast.P_string_append (pat1, pat2) -> P_string_append (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) ), (l,())) diff --git a/src/lexer.mll b/src/lexer.mll index 1fe2a849..f3d93d95 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -215,6 +215,7 @@ rule token = parse | "2" ws "^" { TwoCaret } | "^" { (Caret(r"^")) } | "::" { ColonColon(r "::") } + | "^^" { CaretCaret(r "^^") } | "~~" { TildeTilde(r "~~") } | ":" { Colon(r ":") } | "," { Comma } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 635caa9c..f71498be 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -251,6 +251,7 @@ pat_aux = (* Pattern *) | P_tup of (pat) list (* tuple pattern *) | P_list of (pat) list (* list pattern *) | P_cons of pat * pat (* cons pattern *) + | P_string_append of pat * pat (* string append pattern, x ^^ y *) and pat = P_aux of pat_aux * l diff --git a/src/parser.mly b/src/parser.mly index d126e253..cf2d50a7 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -177,7 +177,7 @@ let rec desugar_rchain chain s e = %token String Bin Hex Real %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token Colon ColonColon TildeTilde ExclEq +%token Colon ColonColon CaretCaret TildeTilde ExclEq %token GtEq %token LtEq @@ -651,6 +651,8 @@ pat1: { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_pat ColonColon pat1 { mk_pat (P_cons ($1, $3)) $startpos $endpos } + | atomic_pat CaretCaret pat1 + { mk_pat (P_string_append ($1, $3)) $startpos $endpos } pat_concat: | atomic_pat diff --git a/src/pattern_completeness.ml b/src/pattern_completeness.ml index c13452ff..3797354c 100644 --- a/src/pattern_completeness.ml +++ b/src/pattern_completeness.ml @@ -68,6 +68,7 @@ type gpat = | GP_cons of gpat * gpat | GP_app of (gpat Bindings.t) | GP_record of (gpat Bindings.t) + | GP_string_append of gpat * gpat let rec string_of_gpat = function | GP_lit lit -> string_of_lit lit @@ -80,12 +81,14 @@ let rec string_of_gpat = function | GP_app app -> Util.string_of_list "|" (fun (id, gpat) -> string_of_id id ^ string_of_gpat gpat) (Bindings.bindings app) | GP_record _ -> "GP RECORD" + | GP_string_append (gpat1, gpat2) -> string_of_gpat gpat1 ^ " ^^" ^ string_of_gpat gpat2 let is_wild = function | GP_wild -> true | _ -> false let rec generalize ctx (P_aux (p_aux, _) as pat) = + match p_aux with | P_lit lit -> GP_lit lit | P_wild -> GP_wild @@ -116,6 +119,10 @@ let rec generalize ctx (P_aux (p_aux, _) as pat) = let ghd_pat = generalize ctx hd_pat in let gtl_pat = generalize ctx tl_pat in if is_wild ghd_pat && is_wild gtl_pat then GP_wild else GP_cons (ghd_pat, gtl_pat) + | P_string_append (pat1, pat2) -> + let gpat1 = generalize ctx pat1 in + let gpat2 = generalize ctx pat2 in + if is_wild gpat1 && is_wild gpat2 then GP_wild else GP_string_append (gpat1, gpat2) | P_app (f, pats) -> let gpats = List.map (generalize ctx) pats in if List.for_all is_wild gpats then diff --git a/src/rewriter.ml b/src/rewriter.ml index 203e8a58..63a1c77f 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -304,6 +304,7 @@ let rewrite_pat rewriters (P_aux (pat,(l,annot)) as orig_pat) = | P_tup pats -> rewrap (P_tup (List.map rewrite pats)) | P_list pats -> rewrap (P_list (List.map rewrite pats)) | P_cons (pat1, pat2) -> rewrap (P_cons (rewrite pat1, rewrite pat2)) + | P_string_append (pat1, pat2) -> rewrap (P_string_append (rewrite pat1, rewrite pat2)) let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = let rewrap e = E_aux (e,(l,annot)) in @@ -452,6 +453,7 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux ; p_cons : 'pat * 'pat -> 'pat_aux + ; p_string_append : 'pat * 'pat -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux @@ -472,6 +474,7 @@ let rec fold_pat_aux (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat | P_tup ps -> alg.p_tup (List.map (fold_pat alg) ps) | P_list ps -> alg.p_list (List.map (fold_pat alg) ps) | P_cons (ph,pt) -> alg.p_cons (fold_pat alg ph, fold_pat alg pt) + | P_string_append (p1, p2) -> alg.p_string_append (fold_pat alg p1, fold_pat alg p2) and fold_pat (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat -> 'pat = function @@ -498,6 +501,7 @@ let id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg = ; p_tup = (fun ps -> P_tup ps) ; p_list = (fun ps -> P_list ps) ; p_cons = (fun (ph,pt) -> P_cons (ph,pt)) + ; p_string_append = (fun (p1,p2) -> P_string_append (p1,p2)) ; p_aux = (fun (pat,annot) -> P_aux (pat,annot)) ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) ; fP_Fpat = (fun (id,pat) -> FP_Fpat (id,pat)) @@ -744,6 +748,7 @@ let compute_pat_alg bot join = ; p_tup = split_join (fun ps -> P_tup ps) ; p_list = split_join (fun ps -> P_list ps) ; p_cons = (fun ((vh,ph),(vt,pt)) -> (join vh vt, P_cons (ph,pt))) + ; p_string_append = (fun ((v1,p1),(v2,p2)) -> (join v1 v2, P_string_append (p1,p2))) ; p_aux = (fun ((v,pat),annot) -> (v, P_aux (pat,annot))) ; fP_aux = (fun ((v,fpat),annot) -> (v, FP_aux (fpat,annot))) ; fP_Fpat = (fun (id,(v,pat)) -> (v, FP_Fpat (id,pat))) diff --git a/src/rewriter.mli b/src/rewriter.mli index f8982d69..70c894c4 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -95,6 +95,7 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux ; p_cons : 'pat * 'pat -> 'pat_aux + ; p_string_append : 'pat * 'pat -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux diff --git a/src/rewrites.ml b/src/rewrites.ml index 591bc276..3b5a1736 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -676,6 +676,7 @@ let remove_vector_concat_pat pat = ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_string_append = (fun (p1,p2) -> P_string_append (p1 false, p2 false)) ; p_aux = (fun (pat,((l,_) as annot)) contained_in_p_as -> match pat with @@ -819,6 +820,7 @@ let remove_vector_concat_pat pat = ; p_list = (fun ps -> let (ps,decls) = List.split ps in (P_list ps,List.flatten decls)) ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) + ; p_string_append = (fun ((p1,decls1),(p2,decls2)) -> (P_string_append (p1,p2), decls1 @ decls2)) ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) @@ -1072,6 +1074,8 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) = | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) + | P_string_append (p,ps) -> raise (Reporting_basic.err_unreachable l + "pat_to_exp not implemented for P_string_append") and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) @@ -1160,6 +1164,7 @@ let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with | P_app (_,pats) | P_tup pats | P_list pats -> List.exists contains_bitvector_pat pats | P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps +| P_string_append (p1,p2) -> contains_bitvector_pat p1 || contains_bitvector_pat p2 | P_record (fpats,_) -> List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats @@ -1188,6 +1193,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_string_append = (fun (p1,p2) -> P_string_append (p1 false, p2 false)) ; p_aux = (fun (pat,annot) contained_in_p_as -> let env = env_of_annot annot in @@ -1342,6 +1348,8 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = (P_list ps, flatten_guards_decls gdls)) ; p_cons = (fun ((p,gdls),(p',gdls')) -> (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) + ; p_string_append = (fun ((p1,gdls1),(p2,gdls2)) -> + (P_string_append (p1,p2), flatten_guards_decls [gdls1;gdls2])) ; p_aux = (fun ((pat,gdls),annot) -> let env = env_of_annot annot in let t = Env.base_typ_of env (typ_of_annot annot) in @@ -2801,6 +2809,103 @@ let pexp_rewriters rewrite_pexp = rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } +let stringappend_counter = ref 0 + +let rec rewrite_defs_pat_string_append = + let rec rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = + + (* utils *) + let (pat, _, _, _) = destruct_pexp pexp in + let env = pat_env_of pat in + let assert_false = mk_exp (E_assert (mk_exp (E_lit (mk_lit L_false)), mk_exp (E_lit (mk_lit (L_string "unreachable"))))) in + let construct_single_match match_on pattern maybe_expr = + let (true_exp, false_exp) = + match maybe_expr with + | Some expr -> expr, assert_false + | None -> (mk_exp (E_lit (mk_lit L_true))), (mk_exp (E_lit (mk_lit L_false))) + in + mk_exp (E_case (match_on, [mk_pexp (Pat_exp (pattern, true_exp)); + mk_pexp (Pat_exp (mk_pat P_wild, false_exp))])) + in + + (* merge cases of Pat_exp and Pat_when *) + let (P_aux (p_aux, p_annot), guards, expr) = + match pexp_aux with + | Pat_exp (pat, expr) -> (pat, [], expr) + | Pat_when (pat, guard, expr) -> (pat, [guard], expr) + in + + let (new_pat, new_guards, new_expr) = + match (p_aux, p_annot) with + (* + "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") + && match str_drop(s#, strlen("lit")) { + pat2 => true, _ => false + } + => match str_drop(s#, strlen("lit")) { + pat2 => expr + } + *) + | P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), p_annot -> + + (* common things *) + let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + let env = Env.add_local id (Immutable, string_typ) env in + + (* construct drop expression -- string_drop(s#, strlen("lit")) *) + let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id id); mk_exp (E_app (mk_id "string_length", [mk_exp (E_lit lit)]))])) in + + (* construct the two new guards *) + let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in + let guard2 = construct_single_match drop_exp (strip_pat pat2) None in + + (* recurse into pat2 *) + let new_pat2_pexp = mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) in + let new_pat2_pexp = check_case env (pat_typ_of pat2) new_pat2_pexp (typ_of expr) in + let new_pat2_pexp = rewrite_pexp new_pat2_pexp in + let new_pat2_pexp = strip_pexp new_pat2_pexp in + + (* construct new match expr *) + let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + + (* construct final result. TODO FIXME: *way* too much type-checking/stripping/rechecking *) + (mk_pat (P_id id)), guard1 :: guard2 :: (List.map strip_exp guards), new_expr + + (* + (builtin x) ^^ pat2 => expr ---> s# if match maybe_atoi s# { + Some (n#, len#) => + match string_drop(s#, len#) { + pat2 => true, _ => false + } + None => false + } + => let (x, len#) = match maybe_atoi s# { + Some (n#, len#) => (n#, len#) + } in + match string_drop(s#, len#) { + pat2 => expr + } + *) + | P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), p_annot -> + assert false + | P_string_append _, _ -> + failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat (P_aux (p_aux, p_annot))) + + | _ -> strip_pat (P_aux (p_aux, p_annot)), (List.map strip_exp guards), (strip_exp expr) + in + + (* un-merge Pat_exp and Pat_when cases *) + let new_pexp = match new_guards with + | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) + | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) + in + check_case env string_typ new_pexp (typ_of expr) + + in + pexp_rewriters rewrite_pexp + + let rewrite_defs_pat_lits = let counter = ref 0 in let rewrite_pat guards = function @@ -3213,6 +3318,7 @@ let rewrite_defs_lem = [ ("remove_vector_concat", rewrite_defs_remove_vector_concat); ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", rewrite_defs_remove_numeral_pats); + ("pat_string_append", rewrite_defs_pat_string_append); ("guarded_pats", rewrite_defs_guarded_pats); ("bitvector_exps", rewrite_bitvector_exps); (* ("register_ref_writes", rewrite_register_ref_writes); *) @@ -3241,6 +3347,7 @@ let rewrite_defs_lem = [ let rewrite_defs_ocaml = [ (* ("undefined", rewrite_undefined); *) ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("pat_string_append", rewrite_defs_pat_string_append); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3260,6 +3367,7 @@ let rewrite_defs_ocaml = [ let rewrite_defs_c = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("pat_string_append", rewrite_defs_pat_string_append); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3277,6 +3385,7 @@ let rewrite_defs_c = [ let rewrite_defs_interpreter = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("pat_string_append", rewrite_defs_pat_string_append); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 47acae88..34d34993 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -461,6 +461,12 @@ let debug (str1, n, str2, v) = prerr_endline (str1 ^ Big_int.to_string n ^ str2 let eq_string (str1, str2) = String.compare str1 str2 == 0 +let string_startswith (str1, str2) = String.compare (String.sub str1 0 (String.length str2)) str2 == 0 + +let string_drop (str, n) = let n = Big_int.to_int n in String.sub str n (String.length str - n) + +let string_length str = String.length str + let lt_int (x, y) = Big_int.less x y let set_slice (out_len, slice_len, out, n, slice) = diff --git a/src/type_check.ml b/src/type_check.ml index 63fab70e..523802cc 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2471,6 +2471,16 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) annot_pat (P_cons (hd_pat, tl_pat)) typ, env, hd_guards @ tl_guards | _ -> typ_error l "Cannot match cons pattern against non-list type" end + | P_string_append (pat1, pat2) -> + begin + let matcher = Env.expand_synonyms env typ in + match matcher with + | Typ_aux (Typ_id id, _) when Id.compare id (mk_id "string") = 0 -> + let pat1, env, guards1 = bind_pat env pat1 typ in + let pat2, env, guards2 = bind_pat env pat2 typ in + annot_pat (P_string_append (pat1, pat2)) typ, env, guards1 @ guards2 + | _ -> typ_error l "Cannot match string-append pattern against non-string type" + end | P_list pats -> begin match Env.expand_synonyms env typ with @@ -2600,6 +2610,12 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = in let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_pats)) in annot_pat (P_vector_concat inferred_pats) (dvector_typ env len vtyp), env, guards + | P_string_append (pat1, pat2) -> + let typed_pat1, env, guards1 = infer_pat env pat1 in + let typed_pat2, env, guards2 = infer_pat env pat2 in + typ_equality l env (pat_typ_of typed_pat1) (string_typ); + typ_equality l env (pat_typ_of typed_pat2) (string_typ); + annot_pat (P_string_append (typed_pat1, typed_pat2)) string_typ, env, guards1 @ guards2 | P_as (pat, id) -> let (typed_pat, env, guards) = infer_pat env pat in annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), @@ -3415,6 +3431,10 @@ and propagate_pat_effect_aux = function let p_pat1 = propagate_pat_effect pat1 in let p_pat2 = propagate_pat_effect pat2 in P_cons (p_pat1, p_pat2), union_effects (effect_of_pat p_pat1) (effect_of_pat p_pat2) + | P_string_append (pat1, pat2) -> + let p_pat1 = propagate_pat_effect pat1 in + let p_pat2 = propagate_pat_effect pat2 in + P_string_append (p_pat1, p_pat2), union_effects (effect_of_pat p_pat1) (effect_of_pat p_pat2) | P_as (pat, id) -> let p_pat = propagate_pat_effect pat in P_as (p_pat, id), effect_of_pat p_pat diff --git a/src/value.ml b/src/value.ml index 4b4f0865..4848721d 100644 --- a/src/value.ml +++ b/src/value.ml @@ -183,6 +183,18 @@ let value_eq_string = function | [v1; v2] -> V_bool (Sail_lib.eq_string (coerce_string v1, coerce_string v2)) | _ -> failwith "value eq_string" +let value_string_startswith = function + | [v1; v2] -> V_bool (Sail_lib.string_startswith (coerce_string v1, coerce_string v2)) + | _ -> failwith "value string_startswith" + +let value_string_drop = function + | [v1; v2] -> V_string (Sail_lib.string_drop (coerce_string v1, coerce_int v2)) + | _ -> failwith "value string_drop" + +let value_string_length = function + | [v] -> V_int (coerce_string v |> Sail_lib.string_length |> Big_int.of_int) + | _ -> failwith "value string_length" + let value_length = function | [v] -> V_int (coerce_gv v |> List.length |> Big_int.of_int) | _ -> failwith "value length" @@ -417,6 +429,9 @@ let primops = ("eq_list", value_eq_list); ("eq_bool", value_eq_bool); ("eq_string", value_eq_string); + ("string_startswith", value_string_startswith); + ("string_drop", value_string_drop); + ("string_length", value_string_length); ("eq_anything", value_eq_anything); ("length", value_length); ("subrange", value_subrange); -- cgit v1.2.3 From fca88463c50ec7d27dc2670972f13a6015905f64 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 23 Apr 2018 17:10:55 +0100 Subject: starting to also do integer support --- src/rewrites.ml | 106 ++++++++++++++++++++++++++++++++++++++++++++++++-------- src/sail_lib.ml | 2 +- src/value.ml | 2 +- 3 files changed, 93 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 3b5a1736..2b5a1f94 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2835,6 +2835,10 @@ let rec rewrite_defs_pat_string_append = | Pat_when (pat, guard, expr) -> (pat, [guard], expr) in + let builtins = [ + ("integer", ("maybe_atoi", int_typ)); + ] in + let (new_pat, new_guards, new_expr) = match (p_aux, p_annot) with (* @@ -2887,8 +2891,56 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), p_annot -> - assert false + | P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [x] ) , _), pat2), p_annot + when List.mem_assoc builtin_id builtins -> + + (* common things *) + let builtin_func, builtin_typ = List.assoc builtin_id builtins in + let s_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + let n_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + let len_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + let env = Env.add_local s_id (Immutable, string_typ) env in + let env = Env.add_local n_id (Immutable, builtin_typ) env in + let env = Env.add_local len_id (Immutable, nat_typ) env in + + (* construct drop expression -- string_drop(s#, len#) *) + let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in + (* construct func expression -- maybe_atoi s# *) + let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in + (* construct some pattern -- Some (n#, len#) *) + let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in + (* construct None pattern *) + let none_exp = mk_pat (P_app (mk_id "None", [])) in + + (* construct the new guard *) + let guard_inner_match = construct_single_match drop_exp (strip_pat pat2) None in + let new_guard = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, guard_inner_match)); + mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) + ])) in + + (* construct the new match *) + let new_match = mk_exp (E_case (drop_exp, [ + mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) + ])) in + + (* construct the new let *) + let new_binding = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ + mk_exp (E_id n_id); + mk_exp (E_id len_id) + ]))) + ])) in + let new_letbind = mk_letbind (mk_pat (P_tup [ + strip_pat x; mk_pat (P_id len_id) + ])) new_binding in + let new_let = mk_exp (E_let (new_letbind, new_match)) in + + (* construct final result *) + (mk_pat (P_id s_id)), new_guard :: (List.map strip_exp guards), new_let | P_string_append _, _ -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat (P_aux (p_aux, p_annot))) @@ -2907,20 +2959,44 @@ let rec rewrite_defs_pat_string_append = let rewrite_defs_pat_lits = - let counter = ref 0 in - let rewrite_pat guards = function - | P_lit lit, p_annot -> - let env = env_of_annot p_annot in - let typ = typ_of_annot p_annot in - let id = mk_id ("p" ^ string_of_int !counter ^ "#") in - let guard = mk_exp (E_app_infix (mk_exp (E_id id), mk_id "==", mk_exp (E_lit lit))) in - let guard = check_exp (Env.add_local id (Immutable, typ) env) guard bool_typ in - guards := guard :: !guards; - incr counter; - P_aux (P_id id, p_annot) - | p_aux, p_annot -> P_aux (p_aux, p_annot) + let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = + let guards = ref [] in + let counter = ref 0 in + + let rewrite_pat = function + | P_lit lit, p_annot -> + let env = env_of_annot p_annot in + let typ = typ_of_annot p_annot in + let id = mk_id ("p" ^ string_of_int !counter ^ "#") in + let guard = mk_exp (E_app_infix (mk_exp (E_id id), mk_id "==", mk_exp (E_lit lit))) in + let guard = check_exp (Env.add_local id (Immutable, typ) env) guard bool_typ in + guards := guard :: !guards; + incr counter; + P_aux (P_id id, p_annot) + | p_aux, p_annot -> P_aux (p_aux, p_annot) + in + + match pexp_aux with + | Pat_exp (pat, exp) -> + begin + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat } pat in + match !guards with + | [] -> pexp + | (g :: gs) -> + let guard_annot = (fst annot, Some (env_of exp, bool_typ, no_effect)) in + Pat_aux (Pat_when (pat, List.fold_left (fun g g' -> E_aux (E_app (mk_id "and_bool", [g; g']), guard_annot)) g gs, exp), annot) + end + | Pat_when (pat, guard, exp) -> + begin + let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat } pat in + let guard_annot = (fst annot, Some (env_of exp, bool_typ, no_effect)) in + Pat_aux (Pat_when (pat, List.fold_left (fun g g' -> E_aux (E_app (mk_id "and_bool", [g; g']), guard_annot)) guard !guards, exp), annot) + end in - pexp_rewriters (rewrite_pexp_with_guards rewrite_pat) + + let alg = { id_exp_alg with pat_aux = (fun (pexp_aux, annot) -> rewrite_pexp (Pat_aux (pexp_aux, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } + (* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, * internal let-expressions, or internal plet-expressions ended by a term that does not diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 34d34993..132af6f5 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -465,7 +465,7 @@ let string_startswith (str1, str2) = String.compare (String.sub str1 0 (String.l let string_drop (str, n) = let n = Big_int.to_int n in String.sub str n (String.length str - n) -let string_length str = String.length str +let string_length str = Big_int.of_int (String.length str) let lt_int (x, y) = Big_int.less x y diff --git a/src/value.ml b/src/value.ml index 4848721d..1365b835 100644 --- a/src/value.ml +++ b/src/value.ml @@ -192,7 +192,7 @@ let value_string_drop = function | _ -> failwith "value string_drop" let value_string_length = function - | [v] -> V_int (coerce_string v |> Sail_lib.string_length |> Big_int.of_int) + | [v] -> V_int (coerce_string v |> Sail_lib.string_length) | _ -> failwith "value string_length" let value_length = function -- cgit v1.2.3 From 8824edcaded764bb5817ee9e7a39a89f5f1627d7 Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 24 Apr 2018 10:21:24 +0100 Subject: starting to also do integer support --- src/lexer.mll | 1 + src/parser.mly | 2 ++ src/rewrites.ml | 3 ++- src/type_check.ml | 2 ++ 4 files changed, 7 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/lexer.mll b/src/lexer.mll index f3d93d95..616c42b4 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -128,6 +128,7 @@ let kw_table = ("forall", (fun _ -> Forall)); ("foreach", (fun _ -> Foreach)); ("function", (fun x -> Function_)); + ("mapping", (fun _ -> Mapping)); ("overload", (fun _ -> Overload)); ("throw", (fun _ -> Throw)); ("try", (fun _ -> Try)); diff --git a/src/parser.mly b/src/parser.mly index cf2d50a7..17bc56f1 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1250,6 +1250,8 @@ scattered_clause: def: | fun_def { DEF_fundef $1 } + | map_def + { DEF_mapdef $1 } | Fixity { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } | val_spec_def diff --git a/src/rewrites.ml b/src/rewrites.ml index 2b5a1f94..8a222431 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2836,7 +2836,8 @@ let rec rewrite_defs_pat_string_append = in let builtins = [ - ("integer", ("maybe_atoi", int_typ)); + ("int", ("maybe_int_of_prefix", int_typ)); + ("nat", ("maybe_nat_of_prefix", nat_typ)); ] in let (new_pat, new_guards, new_expr) = diff --git a/src/type_check.ml b/src/type_check.ml index 523802cc..29b1775f 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -377,6 +377,7 @@ end = struct union_ids : (typquant * typ) Bindings.t; registers : typ Bindings.t; variants : (typquant * type_union list) Bindings.t; + mappings : (typquant * typ) Bindings.t; typ_vars : base_kind_aux KBindings.t; typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; num_defs : nexp Bindings.t; @@ -403,6 +404,7 @@ end = struct union_ids = Bindings.empty; registers = Bindings.empty; variants = Bindings.empty; + mappings = Bindings.empty; typ_vars = KBindings.empty; typ_synonyms = Bindings.empty; num_defs = Bindings.empty; -- cgit v1.2.3 From a9c35efc8e37c1239f1c9dd7514e13e5e884943d Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 24 Apr 2018 13:03:33 +0100 Subject: re-indent Initial_check.to_ast_typ --- src/initial_check.ml | 112 +++++++++++++++++++++++++-------------------------- 1 file changed, 56 insertions(+), 56 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index a294d70a..3592560a 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -165,51 +165,51 @@ let to_ast_kind (k_env : kind Envmap.t) (Parse_ast.K_aux(Parse_ast.K_kind(klst), | _ -> typ_error l "Type constructor must have an -> kind ending in Type" None None None let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) : Ast.typ = -(* let _ = Printf.eprintf "to_ast_typ\n" in*) + (* let _ = Printf.eprintf "to_ast_typ\n" in*) match t with | Parse_ast.ATyp_aux(t,l) -> - Typ_aux( (match t with - | Parse_ast.ATyp_id(id) -> Typ_id (to_ast_id id) - | Parse_ast.ATyp_var(v) -> - let v = to_ast_var v in - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Typ -> Typ_var v - | K_infer -> k.k <- K_Typ; Typ_var v - | _ -> typ_error l "Required a variable with kind Type, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Parse_ast.ATyp_fn(arg,ret,efct) -> Typ_fn( (to_ast_typ k_env def_ord arg), - (to_ast_typ k_env def_ord ret), - (to_ast_effects k_env efct)) - | Parse_ast.ATyp_tup(typs) -> Typ_tup( List.map (to_ast_typ k_env def_ord) typs) - | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_tb",il), [ b; r; ord ; ti]) -> - let make_r bot top = - match bot,top with - | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant b,_),Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,l) -> - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.add (Big_int.sub t b) (Big_int.of_int 1)),l) - | bot,(Parse_ast.ATyp_aux(_,l) as top) -> - Parse_ast.ATyp_aux((Parse_ast.ATyp_sum - ((Parse_ast.ATyp_aux - (Parse_ast.ATyp_sum (top, - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.of_int 1),Parse_ast.Unknown)), - Parse_ast.Unknown)), - (Parse_ast.ATyp_aux ((Parse_ast.ATyp_neg bot),Parse_ast.Unknown)))), l) in - let base = to_ast_nexp k_env b in - let rise = match def_ord with - | Ord_aux(Ord_inc,dl) -> to_ast_nexp k_env (make_r b r) - | Ord_aux(Ord_dec,dl) -> to_ast_nexp k_env (make_r r b) - | _ -> raise (Reporting_basic.err_unreachable l "Default order not inc or dec") in - Typ_app(Id_aux(Id "vector",il), - [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_order def_ord,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_typ (to_ast_typ k_env def_ord ti), Parse_ast.Unknown);]) - | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_r",il), [b;r;ord;ti]) -> - let make_sub_one t = - match t with + Typ_aux( (match t with + | Parse_ast.ATyp_id(id) -> Typ_id (to_ast_id id) + | Parse_ast.ATyp_var(v) -> + let v = to_ast_var v in + let mk = Envmap.apply k_env (var_to_string v) in + (match mk with + | Some(k) -> (match k.k with + | K_Typ -> Typ_var v + | K_infer -> k.k <- K_Typ; Typ_var v + | _ -> typ_error l "Required a variable with kind Type, encountered " None (Some v) (Some k)) + | None -> typ_error l "Encountered an unbound variable" None (Some v) None) + | Parse_ast.ATyp_fn(arg,ret,efct) -> Typ_fn( (to_ast_typ k_env def_ord arg), + (to_ast_typ k_env def_ord ret), + (to_ast_effects k_env efct)) + | Parse_ast.ATyp_tup(typs) -> Typ_tup( List.map (to_ast_typ k_env def_ord) typs) + | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_tb",il), [ b; r; ord ; ti]) -> + let make_r bot top = + match bot,top with + | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant b,_),Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,l) -> + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.add (Big_int.sub t b) (Big_int.of_int 1)),l) + | bot,(Parse_ast.ATyp_aux(_,l) as top) -> + Parse_ast.ATyp_aux((Parse_ast.ATyp_sum + ((Parse_ast.ATyp_aux + (Parse_ast.ATyp_sum (top, + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.of_int 1),Parse_ast.Unknown)), + Parse_ast.Unknown)), + (Parse_ast.ATyp_aux ((Parse_ast.ATyp_neg bot),Parse_ast.Unknown)))), l) in + let base = to_ast_nexp k_env b in + let rise = match def_ord with + | Ord_aux(Ord_inc,dl) -> to_ast_nexp k_env (make_r b r) + | Ord_aux(Ord_dec,dl) -> to_ast_nexp k_env (make_r r b) + | _ -> raise (Reporting_basic.err_unreachable l "Default order not inc or dec") in + Typ_app(Id_aux(Id "vector",il), + [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); + Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); + Typ_arg_aux (Typ_arg_order def_ord,Parse_ast.Unknown); + Typ_arg_aux (Typ_arg_typ (to_ast_typ k_env def_ord ti), Parse_ast.Unknown);]) + | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_r",il), [b;r;ord;ti]) -> + let make_sub_one t = + match t with | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.sub t (Big_int.of_int 1)),l) - | t -> (Parse_ast.ATyp_aux + | t -> (Parse_ast.ATyp_aux (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.negate (Big_int.of_int 1)),Parse_ast.Unknown)), Parse_ast.Unknown)) in let (base,rise) = match def_ord with @@ -227,20 +227,20 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let id = to_ast_id pid in let k = Envmap.apply k_env (id_to_string id) in (match k with - | Some({k = K_Lam(args,t)}) -> - if ((List.length args) = (List.length typs)) - then - Typ_app(id,(List.map2 (fun k a -> (to_ast_typ_arg k_env def_ord k a)) args typs)) - else typ_error l "Type constructor given incorrect number of arguments" (Some id) None None - | None -> typ_error l "Required a type constructor, encountered an unbound identifier" (Some id) None None - | _ -> typ_error l "Required a type constructor, encountered a base kind variable" (Some id) None None) - | Parse_ast.ATyp_exist (kids, nc, atyp) -> - let kids = List.map to_ast_var kids in - let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in - let exist_typ = to_ast_typ k_env def_ord atyp in - Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) - | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None - ), l) + | Some({k = K_Lam(args,t)}) -> + if ((List.length args) = (List.length typs)) + then + Typ_app(id,(List.map2 (fun k a -> (to_ast_typ_arg k_env def_ord k a)) args typs)) + else typ_error l "Type constructor given incorrect number of arguments" (Some id) None None + | None -> typ_error l "Required a type constructor, encountered an unbound identifier" (Some id) None None + | _ -> typ_error l "Required a type constructor, encountered a base kind variable" (Some id) None None) + | Parse_ast.ATyp_exist (kids, nc, atyp) -> + let kids = List.map to_ast_var kids in + let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in + let exist_typ = to_ast_typ k_env def_ord atyp in + Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) + | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None + ), l) and to_ast_nexp (k_env : kind Envmap.t) (n: Parse_ast.atyp) : Ast.nexp = match n with -- cgit v1.2.3 From 414fe86dbf3f4606d9e1382f238001f58d691620 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 25 Apr 2018 08:45:43 +0100 Subject: add mpats to asts --- src/parse_ast.ml | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/parse_ast.ml b/src/parse_ast.ml index f71498be..d845265f 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -151,6 +151,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_default_ord (* default order for increasing or decreasing signficant bits *) | ATyp_set of (base_effect) list (* effect set *) | ATyp_fn of atyp * atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) + | ATyp_bidir of atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) | ATyp_wild | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) @@ -392,7 +393,6 @@ type funcl = FCL_aux of funcl_aux * l - type type_union = Tu_aux of type_union_aux * l @@ -420,6 +420,41 @@ default_typing_spec_aux = (* Default kinding or typing assumption, and default | DT_typ of typschm * id +type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only constructible parts *) + | MP_lit of lit + | MP_id of id + | MP_app of id * ( mpat) list + | MP_record of ( fpat) list * bool + | MP_vector of ( mpat) list + | MP_vector_concat of ( mpat) list + | MP_tup of ( mpat) list + | MP_list of ( mpat) list + | MP_cons of ( mpat) * ( mpat) + | MP_string_append of ( mpat) * ( mpat) + +and mpat = + | MP_aux of ( mpat_aux) * l + +type mpexp_aux = + | MPat_pat of ( mpat) + | MPat_when of ( mpat) * ( exp) + +type mpexp = + | MPat_aux of ( mpexp_aux) * l + +type mapcl_aux = (* mapping clause (bidirectional pattern-match) *) + | MCL_mapcl of ( mpexp) * ( mpexp) + +type mapcl = + | MCL_aux of ( mapcl_aux) * l + +type mapdef_aux = (* mapping definition (bidirectional pattern-match function) *) + | MD_mapping of id * ( mapcl) list + +type mapdef = + | MD_aux of ( mapdef_aux) * l + + type fundef_aux = (* Function definition *) FD_function of rec_opt * tannot_opt * effect_opt * (funcl) list @@ -502,6 +537,7 @@ def = (* Top-level definition *) DEF_kind of kind_def (* definition of named kind identifiers *) | DEF_type of type_def (* type definition *) | DEF_fundef of fundef (* function definition *) + | DEF_mapdef of mapdef (* mapping definition *) | DEF_val of letbind (* value definition *) | DEF_overload of id * id list (* operator overload specifications *) | DEF_fixity of prec * Big_int.num * id (* fixity declaration *) -- cgit v1.2.3 From 6ebde09c1167d55619a8757e1b57ff5a65351026 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 25 Apr 2018 09:07:57 +0100 Subject: add to parser --- src/ast_util.ml | 1 + src/lexer.mll | 1 + src/parser.mly | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 76 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 0817e46c..8b51edd3 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -571,6 +571,7 @@ and string_of_typ_aux = function | Typ_app (id, args) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | Typ_fn (typ_arg, typ_ret, eff) -> string_of_typ typ_arg ^ " -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff + | Typ_bidir (typ1, typ2) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 | Typ_exist (kids, nc, typ) -> "{" ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" and string_of_typ_arg = function diff --git a/src/lexer.mll b/src/lexer.mll index 616c42b4..a4ec4cc9 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -248,6 +248,7 @@ rule token = parse | "!=" { (ExclEq(r"!=")) } | ">=" { (GtEq(r">=")) } | "->" { MinusGt } + | "<->" { Bidir } | "=>" { EqGt(r "=>") } | "<=" { (LtEq(r"<=")) } | "/*!" { Doc (doc_comment (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) 0 lexbuf) } diff --git a/src/parser.mly b/src/parser.mly index 17bc56f1..adf99ede 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -103,6 +103,11 @@ let mk_vs v n m = VS_aux (v, loc n m) let mk_reg_dec d n m = DEC_aux (d, loc n m) let mk_default d n m = DT_aux (d, loc n m) +let mk_mpexp mpexp n m = MPat_aux (mpexp, loc n m) +let mk_mpat mpat n m = MP_aux (mpat, loc n m) +let mk_mapcl mpexp1 mpexp2 n m = MCL_aux (MCL_mapcl (mpexp1, mpexp2), loc n m) +let mk_map id mapcls n m = MD_aux (MD_mapping (id, mapcls), loc n m) + let doc_vs doc (VS_aux (v, l)) = VS_aux (v, Documented (doc, l)) let qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) @@ -157,7 +162,7 @@ let rec desugar_rchain chain s e = /*Terminals with no content*/ %token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op -%token Enum Else False Forall Foreach Overload Function_ If_ In Inc Let_ Int Order Cast +%token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Cast %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape @@ -168,7 +173,7 @@ let rec desugar_rchain chain s e = %token Bar Comma Dot Eof Minus Semi Under DotDot %token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar -%token MinusGt +%token MinusGt Bidir /*Terminals with content*/ @@ -639,6 +644,10 @@ typschm: { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, $5)) s e) s e) $startpos $endpos } | Forall typquant Dot typ MinusGt typ Effect effect_set { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } + | typ Bidir typ + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ Bidir typ + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6)) s e) s e) $startpos $endpos } typschm_eof: | typschm Eof @@ -1193,6 +1202,69 @@ fun_def_list: | fun_def fun_def_list { $1 :: $2 } +mpat: + | atomic_mpat + { $1 } + | atomic_mpat At mpat_concat + { mk_mpat (MP_vector_concat ($1 :: $3)) $startpos $endpos } + | atomic_mpat ColonColon mpat + { mk_mpat (MP_cons ($1, $3)) $startpos $endpos } + | atomic_mpat CaretCaret mpat + { mk_mpat (MP_string_append ($1, $3)) $startpos $endpos } + +mpat_concat: + | atomic_mpat + { [$1] } + | atomic_mpat At mpat_concat + { $1 :: $3 } + +mpat_list: + | mpat + { [$1] } + | mpat Comma mpat_list + { $1 :: $3 } + +atomic_mpat: + | lit + { mk_mpat (MP_lit $1) $startpos $endpos } + | id + { mk_mpat (MP_id $1) $startpos $endpos } + | id Lparen mpat_list Rparen + { mk_mpat (MP_app ($1, $3)) $startpos $endpos } + | Lparen mpat Rparen + { $2 } + | Lparen mpat Comma mpat_list Rparen + { mk_mpat (MP_tup ($2 :: $4)) $startpos $endpos } + | Lsquare mpat_list Rsquare + { mk_mpat (MP_vector $2) $startpos $endpos } + | LsquareBar RsquareBar + { mk_mpat (MP_list []) $startpos $endpos } + | LsquareBar mpat_list RsquareBar + { mk_mpat (MP_list $2) $startpos $endpos } + + +mpexp: + | mpat + { mk_mpexp (MPat_pat $1) $startpos $endpos } + | mpat If_ exp + { mk_mpexp (MPat_when ($1, $3)) $startpos $endpos } + +mapcl: + | mpexp Bidir mpexp + { mk_mapcl $1 $3 $startpos $endpos } + +mapcl_list: + | mapcl + { [$1] } + | mapcl Comma mapcl_list + { $1 :: $3 } + +map_def: + | Mapping id Eq Lcurly mapcl_list Rcurly + { mk_map $2 $5 $startpos $endpos } + (* | Mapping id Colon typschm Eq Lcurly mapcl_list Rcurly + * { mk_map $2 $4 $7 $startpos $endpos } *) + let_def: | Let_ letbind { $2 } -- cgit v1.2.3 From 7ae7f56127e6cc96e7715e052fa4a69e793cafe4 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 25 Apr 2018 09:19:51 +0100 Subject: conversion from parse_ast to ast --- src/initial_check.ml | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index 3592560a..793d6657 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -182,6 +182,8 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) | Parse_ast.ATyp_fn(arg,ret,efct) -> Typ_fn( (to_ast_typ k_env def_ord arg), (to_ast_typ k_env def_ord ret), (to_ast_effects k_env efct)) + | Parse_ast.ATyp_bidir (typ1, typ2) -> Typ_bidir ( (to_ast_typ k_env def_ord typ1), + (to_ast_typ k_env def_ord typ2)) | Parse_ast.ATyp_tup(typs) -> Typ_tup( List.map (to_ast_typ k_env def_ord) typs) | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_tb",il), [ b; r; ord ; ti]) -> let make_r bot top = @@ -760,6 +762,43 @@ let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.funde 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,())), (names,k_env,def_ord) +let rec to_ast_mpat k_env def_ord (Parse_ast.MP_aux(mpat,l)) = + MP_aux( + (match mpat with + | Parse_ast.MP_lit(lit) -> MP_lit(to_ast_lit lit) + | Parse_ast.MP_id(id) -> MP_id(to_ast_id id) + | Parse_ast.MP_app(id,mpats) -> + if mpats = [] + then MP_id (to_ast_id id) + else MP_app(to_ast_id id, List.map (to_ast_mpat k_env def_ord) mpats) + | Parse_ast.MP_record(fpats,_) -> + MP_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,()))) + fpats, false) + | Parse_ast.MP_vector(mpats) -> MP_vector(List.map (to_ast_mpat k_env def_ord) mpats) + | Parse_ast.MP_vector_concat(mpats) -> MP_vector_concat(List.map (to_ast_mpat k_env def_ord) mpats) + | Parse_ast.MP_tup(mpats) -> MP_tup(List.map (to_ast_mpat k_env def_ord) mpats) + | Parse_ast.MP_list(mpats) -> MP_list(List.map (to_ast_mpat k_env def_ord) mpats) + | Parse_ast.MP_cons(pat1, pat2) -> MP_cons (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) + | Parse_ast.MP_string_append (pat1, pat2) -> MP_string_append (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) + ), (l,())) + + +let to_ast_mpexp (names,k_env,def_ord) (Parse_ast.MPat_aux(mpexp, l)) = + match mpexp with + | Parse_ast.MPat_pat mpat -> MPat_aux (MPat_pat (to_ast_mpat k_env def_ord mpat), (l, ())) + | Parse_ast.MPat_when (mpat, exp) -> MPat_aux (MPat_when (to_ast_mpat k_env def_ord mpat, to_ast_exp k_env def_ord exp), (l, ())) + +let to_ast_mapcl (names,k_env,def_ord) (Parse_ast.MCL_aux(mapcl, l)) = + match mapcl with + | Parse_ast.MCL_mapcl (mpexp1, mpexp2) -> MCL_aux (MCL_mapcl (to_ast_mpexp (names,k_env,def_ord) mpexp1, to_ast_mpexp (names,k_env,def_ord) mpexp2), (l, ())) + +let to_ast_mapdef (names,k_env,def_ord) (Parse_ast.MD_aux(md,l):Parse_ast.mapdef) : (unit mapdef) envs_out = + match md with + | Parse_ast.MD_mapping(id, mapcls) -> + MD_aux(MD_mapping(to_ast_id id, List.map (to_ast_mapcl (names,k_env,def_ord)) mapcls), (l,())), (names,k_env,def_ord) + type def_progress = No_def | Def_place_holder of id * Parse_ast.l @@ -823,6 +862,9 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_fundef(f_def) -> let fd,envs = to_ast_fundef envs f_def in ((Finished(DEF_fundef(fd))),envs),partial_defs + | Parse_ast.DEF_mapdef(m_def) -> + let md, envs = to_ast_mapdef envs m_def in + ((Finished(DEF_mapdef(md))),envs),partial_defs | Parse_ast.DEF_val(lbind) -> let lb = to_ast_letbind k_env def_ord lbind in ((Finished(DEF_val(lb))),envs),partial_defs -- cgit v1.2.3 From 6056295b2b7c829fe4e8843dbd7f52b5bba9facf Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 25 Apr 2018 09:30:38 +0100 Subject: utils mapping over mpats/mpexps --- src/ast_util.ml | 19 +++++++++++++++++++ src/ast_util.mli | 2 ++ 2 files changed, 21 insertions(+) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 8b51edd3..955c147f 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -439,6 +439,25 @@ and map_pat_annot_aux f = function | P_vector pats -> P_vector (List.map (map_pat_annot f) pats) | P_cons (pat1, pat2) -> P_cons (map_pat_annot f pat1, map_pat_annot f pat2) | P_string_append (pat1, pat2) -> P_string_append (map_pat_annot f pat1, map_pat_annot f pat2) + +and map_mpexp_annot f (MPat_aux (mpexp, annot)) = MPat_aux (map_mpexp_annot_aux f mpexp, f annot) +and map_mpexp_annot_aux f = function + | MPat_pat mpat -> MPat_pat (map_mpat_annot f mpat) + | MPat_when (mpat, guard) -> MPat_when (map_mpat_annot f mpat, map_exp_annot f guard) + +and map_mpat_annot f (MP_aux (mpat, annot)) = MP_aux (map_mpat_annot_aux f mpat, f annot) +and map_mpat_annot_aux f = function + | MP_lit lit -> MP_lit lit + | MP_id id -> MP_id id + | MP_app (id, mpats) -> MP_app (id, List.map (map_mpat_annot f) mpats) + | MP_record (fmpats, b) -> MP_record (List.map (map_fpat_annot f) fmpats, b) + | MP_tup mpats -> MP_tup (List.map (map_mpat_annot f) mpats) + | MP_list mpats -> MP_list (List.map (map_mpat_annot f) mpats) + | MP_vector_concat mpats -> MP_vector_concat (List.map (map_mpat_annot f) mpats) + | MP_vector mpats -> MP_vector (List.map (map_mpat_annot f) mpats) + | MP_cons (mpat1, mpat2) -> MP_cons (map_mpat_annot f mpat1, map_mpat_annot f mpat2) + | MP_string_append (mpat1, mpat2) -> MP_string_append (map_mpat_annot f mpat1, map_mpat_annot f mpat2) + and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) and map_letbind_annot f (LB_aux (lb, annot)) = LB_aux (map_letbind_annot_aux f lb, f annot) and map_letbind_annot_aux f = function diff --git a/src/ast_util.mli b/src/ast_util.mli index c07732bf..f9f42e10 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -174,6 +174,8 @@ val map_pat_annot : ('a annot -> 'b annot) -> 'a pat -> 'b pat val map_pexp_annot : ('a annot -> 'b annot) -> 'a pexp -> 'b pexp val map_lexp_annot : ('a annot -> 'b annot) -> 'a lexp -> 'b lexp val map_letbind_annot : ('a annot -> 'b annot) -> 'a letbind -> 'b letbind +val map_mpat_annot : ('a annot -> 'b annot) -> 'a mpat -> 'b mpat +val map_mpexp_annot : ('a annot -> 'b annot) -> 'a mpexp -> 'b mpexp (* Extract locations from identifiers *) val id_loc : id -> Parse_ast.l -- cgit v1.2.3 From 1c5517d9f91d1fa2fbe8345d246c6736f23fb6d8 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 25 Apr 2018 14:41:43 +0100 Subject: mostly added mappings to type-checker and pretty-printer --- src/ast_util.ml | 28 ++++ src/ast_util.mli | 7 + src/pretty_print_sail.ml | 33 +++++ src/rewriter.ml | 2 +- src/type_check.ml | 374 ++++++++++++++++++++++++++++++++++++++++++++++- src/type_check.mli | 6 + 6 files changed, 447 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 955c147f..69fe63cb 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -85,6 +85,9 @@ let untyp_pat = function let mk_pexp pexp_aux = Pat_aux (pexp_aux, no_annot) +let mk_mpat mpat_aux = MP_aux (mpat_aux, no_annot) +let mk_mpexp mpexp_aux = MPat_aux (mpexp_aux, no_annot) + let mk_lexp lexp_aux = LEXP_aux (lexp_aux, no_annot) let mk_typ_pat tpat_aux = TP_aux (tpat_aux, Parse_ast.Unknown) @@ -733,6 +736,20 @@ and string_of_pat (P_aux (pat, l)) = | P_as (pat, id) -> string_of_pat pat ^ " as " ^ string_of_id id | P_string_append (pat1, pat2) -> string_of_pat pat1 ^ " ^^ " ^ string_of_pat pat2 | _ -> "PAT" + +and string_of_mpat (MP_aux (pat, l)) = + match pat with + | MP_lit lit -> string_of_lit lit + | MP_id v -> string_of_id v + | MP_tup pats -> "(" ^ string_of_list ", " string_of_mpat pats ^ ")" + | MP_app (f, pats) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_mpat pats ^ ")" + | MP_cons (pat1, pat2) -> string_of_mpat pat1 ^ " :: " ^ string_of_mpat pat2 + | MP_list pats -> "[||" ^ string_of_list "," string_of_mpat pats ^ "||]" + | MP_vector_concat pats -> string_of_list " : " string_of_mpat pats + | MP_vector pats -> "[" ^ string_of_list ", " string_of_mpat pats ^ "]" + | MP_string_append (pat1, pat2) -> string_of_mpat pat1 ^ " ^^ " ^ string_of_mpat pat2 + | _ -> "PAT" + and string_of_lexp (LEXP_aux (lexp, _)) = match lexp with | LEXP_id v -> string_of_id v @@ -1013,6 +1030,17 @@ let construct_pexp (pat,guard,exp,ann) = | None -> Pat_aux (Pat_exp (pat,exp),ann) | Some guard -> Pat_aux (Pat_when (pat,guard,exp),ann) +let destruct_mpexp (MPat_aux (mpexp,ann)) = + match mpexp with + | MPat_pat mpat -> mpat,None,ann + | MPat_when (mpat,guard) -> mpat,Some guard,ann + +let construct_mpexp (mpat,guard,ann) = + match guard with + | None -> MPat_aux (MPat_pat mpat,ann) + | Some guard -> MPat_aux (MPat_when (mpat,guard),ann) + + let is_valspec id = function | DEF_spec (VS_aux (VS_val_spec (_, id', _, _), _)) when Id.compare id id' = 0 -> true | _ -> false diff --git a/src/ast_util.mli b/src/ast_util.mli index f9f42e10..7ac5058f 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -70,7 +70,9 @@ val mk_nc : n_constraint_aux -> n_constraint val mk_nexp : nexp_aux -> nexp val mk_exp : unit exp_aux -> unit exp val mk_pat : unit pat_aux -> unit pat +val mk_mpat : unit mpat_aux -> unit mpat val mk_pexp : unit pexp_aux -> unit pexp +val mk_mpexp : unit mpexp_aux -> unit mpexp val mk_lexp : unit lexp_aux -> unit lexp val mk_lit : lit_aux -> lit val mk_lit_exp : lit_aux -> unit exp @@ -211,6 +213,7 @@ val string_of_exp : 'a exp -> string val string_of_pexp : 'a pexp -> string val string_of_lexp : 'a lexp -> string val string_of_pat : 'a pat -> string +val string_of_mpat : 'a mpat -> string val string_of_letbind : 'a letbind -> string val string_of_index_range : index_range -> string @@ -309,6 +312,10 @@ val undefined_of_typ : bool -> Ast.l -> (typ -> 'annot) -> typ -> 'annot exp val destruct_pexp : 'a pexp -> 'a pat * ('a exp) option * 'a exp * (Ast.l * 'a) val construct_pexp : 'a pat * ('a exp) option * 'a exp * (Ast.l * 'a) -> 'a pexp +val destruct_mpexp : 'a mpexp -> 'a mpat * ('a exp) option * (Ast.l * 'a) +val construct_mpexp : 'a mpat * ('a exp) option * (Ast.l * 'a) -> 'a mpexp + + val is_valspec : id -> 'a def -> bool val is_fundef : id -> 'a def -> bool diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index c0658a83..a59db812 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -159,6 +159,8 @@ let rec doc_typ (Typ_aux (typ_aux, _)) = | Typ_fn (typ1, typ2, Effect_aux (Effect_set effs, _)) -> let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in separate space [doc_typ typ1; string "->"; doc_typ typ2; string "effect"; ocaml_eff] + | Typ_bidir (typ1, typ2) -> + separate space [doc_typ typ1; string "<->"; doc_typ typ2] and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = match ta_aux with | Typ_arg_typ typ -> doc_typ typ @@ -451,6 +453,36 @@ let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = let clauses = separate_map sep doc_funcl funcls in string "function" ^^ space ^^ clauses +let rec doc_mpat (MP_aux (mp_aux, _) as mpat) = + match mp_aux with + | MP_id id -> doc_id id + | MP_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_mpat pats ^^ rparen + | MP_lit lit -> doc_lit lit + | MP_vector pats -> brackets (separate_map (comma ^^ space) doc_mpat pats) + | MP_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_mpat pats + | MP_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_mpat pats) + | MP_list pats -> string "[|" ^^ separate_map (comma ^^ space) doc_mpat pats ^^ string "|]" + | _ -> string (string_of_mpat mpat) + + +let doc_mpexp (MPat_aux (mpexp, _)) = + match mpexp with + | MPat_pat mpat -> doc_mpat mpat + | MPat_when (mpat, guard) -> doc_mpat mpat ^^ space ^^ string "if" ^^ space ^^ doc_exp guard + +let doc_mapcl (MCL_aux (MCL_mapcl (mpexp1, mpexp2), _)) = + let left = doc_mpexp mpexp1 in + let right = doc_mpexp mpexp2 in + left ^^ space ^^ string "<->" ^^ space ^^ right + +let doc_mapdef (MD_aux (MD_mapping (id, mapcls), _)) = + match mapcls with + | [] -> failwith "Empty mapping" + | _ -> + let sep = string "," ^^ hardline in + let clauses = separate_map sep doc_mapcl mapcls in + string "mapping" ^^ space ^^ doc_id id ^^ space ^^ string "=" ^^ (surround 2 0 lbrace clauses rbrace) + let doc_dec (DEC_aux (reg,_)) = match reg with | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] @@ -527,6 +559,7 @@ let rec doc_def def = group (match def with | DEF_type t_def -> doc_typdef t_def | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def + | DEF_mapdef m_def -> doc_mapdef m_def | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind | DEF_internal_mutrec fundefs -> (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) diff --git a/src/rewriter.ml b/src/rewriter.ml index 63a1c77f..74d9f40d 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -393,7 +393,7 @@ let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) let rewrite_def rewriters d = match d with - | DEF_type _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_comm _ | DEF_overload _ | DEF_fixity _ -> d + | DEF_type _ | DEF_mapdef _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_comm _ | DEF_overload _ | DEF_fixity _ -> d | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef) | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) diff --git a/src/type_check.ml b/src/type_check.ml index 29b1775f..f7668f21 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -217,6 +217,7 @@ and typ_subst_nexp_aux sv subst = function | 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_bidir (typ1, typ2) -> Typ_bidir (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2) | 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) | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) @@ -232,6 +233,7 @@ and typ_subst_typ_aux sv subst = function | 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_bidir (typ1, typ2) -> Typ_bidir (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2) | 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) | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_typ sv subst typ) @@ -253,6 +255,7 @@ and typ_subst_order_aux sv subst = function | 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_bidir (typ1, typ2) -> Typ_bidir (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2) | 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) | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_order sv subst typ) @@ -267,6 +270,7 @@ and typ_subst_kid_aux sv subst = function | 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_bidir (typ1, typ2) -> Typ_bidir (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2) | 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) | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) @@ -303,6 +307,7 @@ module Env : sig val define_val_spec : id -> t -> t val get_val_spec : id -> t -> typquant * typ val is_union_constructor : id -> t -> bool + val is_mapping : id -> t -> bool val add_record : id -> typquant -> (typ * id) list -> t -> t val is_record : id -> t -> bool val get_accessor_fn : id -> id -> t -> typquant * typ @@ -310,6 +315,7 @@ module Env : sig val add_local : id -> mut * typ -> t -> t val get_locals : t -> (mut * typ) Bindings.t val add_variant : id -> typquant * type_union list -> t -> t + val add_mapping : id -> typquant * typ * typ -> 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 @@ -377,7 +383,7 @@ end = struct union_ids : (typquant * typ) Bindings.t; registers : typ Bindings.t; variants : (typquant * type_union list) Bindings.t; - mappings : (typquant * typ) Bindings.t; + mappings : (typquant * typ * typ) Bindings.t; typ_vars : base_kind_aux KBindings.t; typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; num_defs : nexp Bindings.t; @@ -455,6 +461,13 @@ end = struct ("itself", [BK_int]) ] + let builtin_mappings = + List.fold_left (fun m (name, typ) -> Bindings.add (mk_id name) typ m) Bindings.empty + [ + ("int", Typ_bidir(int_typ, string_typ)); + ("nat", Typ_bidir(nat_typ, string_typ)); + ] + let bound_typ_id env id = Bindings.mem id env.typ_synonyms || Bindings.mem id env.variants @@ -524,6 +537,7 @@ end = struct 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_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l) | Typ_app (id, args) -> begin try @@ -644,6 +658,7 @@ end = struct | Typ_var kid when KBindings.mem kid env.typ_vars -> () | Typ_var kid -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) | Typ_fn (typ_arg, typ_ret, effs) -> wf_typ ~exs:exs env typ_arg; wf_typ ~exs:exs env typ_ret + | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2 | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs | Typ_app (id, args) when bound_typ_id env id -> List.iter (wf_typ_arg ~exs:exs env) args; @@ -754,6 +769,8 @@ end = struct let type_unions = List.concat (List.map (fun (_, (_, tus)) -> tus) (Bindings.bindings env.variants)) in List.exists (is_ctor id) type_unions + let is_mapping id env = Bindings.mem id env.mappings + 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") @@ -840,6 +857,12 @@ end = struct { env with variants = Bindings.add id variant env.variants } end + let add_mapping id mapping env = + begin + typ_print ("Adding mapping " ^ string_of_id id); + { env with mappings = Bindings.add id mapping env.mappings } + end + let add_union_id id bind env = begin typ_print (lazy ("Adding union identifier binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind)); @@ -1126,6 +1149,7 @@ let rec is_typ_monomorphic (Typ_aux (typ, _)) = | Typ_tup typs -> List.for_all is_typ_monomorphic typs | Typ_app (id, args) -> List.for_all is_typ_arg_monomorphic args | Typ_fn (typ1, typ2, _) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 + | Typ_bidir (typ1, typ2) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 | Typ_exist _ | Typ_var _ -> false and is_typ_arg_monomorphic (Typ_arg_aux (arg, _)) = match arg with @@ -1286,6 +1310,8 @@ let rec typ_nexps (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_nexps typ | Typ_fn (typ1, typ2, _) -> typ_nexps typ1 @ typ_nexps typ2 + | Typ_bidir (typ1, typ2) -> + typ_nexps typ1 @ typ_nexps typ2 and typ_arg_nexps (Typ_arg_aux (typ_arg_aux, l)) = match typ_arg_aux with | Typ_arg_nexp n -> [n] @@ -1301,6 +1327,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args) | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ | Typ_fn (typ1, typ2, _) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2) + | Typ_bidir (typ1, typ2) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2) and typ_arg_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = match typ_arg_aux with | Typ_arg_nexp n -> nexp_frees ~exs:exs n @@ -1662,7 +1689,7 @@ let rec kid_order kids (Typ_aux (aux, l) as typ) = List.fold_left (fun (ord, kids) typ -> let (ord', kids) = kid_order kids typ in (ord @ ord', kids)) ([], kids) typs | Typ_app (_, args) -> List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kids) args - | Typ_fn _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) + | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) and kid_order_arg kids (Typ_arg_aux (aux, l) as arg) = match aux with | Typ_arg_typ typ -> kid_order kids typ @@ -1678,6 +1705,7 @@ let rec alpha_equivalent env typ1 typ2 = match aux with | Typ_id _ | Typ_var _ -> aux | Typ_fn (typ1, typ2, eff) -> Typ_fn (relabel typ1, relabel typ2, eff) + | Typ_bidir (typ1, typ2) -> Typ_bidir (relabel typ1, relabel typ2) | Typ_tup typs -> Typ_tup (List.map relabel typs) | Typ_exist (kids, nc, typ) -> let (kids, _) = kid_order (KidSet.of_list kids) typ in @@ -1912,6 +1940,15 @@ let typ_of_pexp (Pat_aux (_, (l, tannot))) = typ_of_annot (l, tannot) let env_of_pexp (Pat_aux (_, (l, tannot))) = env_of_annot (l, tannot) +let typ_of_mpat (MP_aux (_, (l, tannot))) = typ_of_annot (l, tannot) + +let env_of_mpat (MP_aux (_, (l, tannot))) = env_of_annot (l, tannot) + +let typ_of_mpexp (MPat_aux (_, (l, tannot))) = typ_of_annot (l, tannot) + +let env_of_mpexp (MPat_aux (_, (l, tannot))) = env_of_annot (l, tannot) + + (* Flow typing *) let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with @@ -2117,6 +2154,9 @@ let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) - let strip_pexp : 'a pexp -> unit pexp = function pexp -> map_pexp_annot (fun (l, _) -> (l, ())) pexp let strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, _) -> (l, ())) lexp +let strip_mpat : 'a mpat -> unit mpat = function mpat -> map_mpat_annot (fun (l, _) -> (l, ())) mpat +let strip_mpexp : 'a mpexp -> unit mpexp = function mpexp -> map_mpexp_annot (fun (l, _) -> (l, ())) mpexp + let fresh_var = let counter = ref 0 in fun () -> let n = !counter in @@ -2357,6 +2397,29 @@ and check_case env pat_typ pexp typ = check_case env pat_typ (Pat_aux (Pat_when (mk_pat (P_id (mk_id "p#")), guard, case), annot)) typ | _ -> raise typ_exn +and check_mpexp env mpexp typ = + let mpat,guard,((l,_) as annot) = destruct_mpexp mpexp in + match bind_mpat env mpat typ with + | checked_mpat, env, guards -> + let guard = match guard, guards with + | None, h::t -> Some (h,t) + | Some x, l -> Some (x,l) + | None, [] -> None + in + let guard = match guard with + | Some (h,t) -> + Some (List.fold_left (fun acc guard -> mk_exp (E_app_infix (acc, mk_id "&", guard))) h t) + | None -> None + in + let checked_guard, env' = match guard with + | None -> None, env + | Some guard -> + let checked_guard = check_exp env guard bool_typ in + let flows, constrs = infer_flow env checked_guard in + Some checked_guard, add_constraints constrs (add_flows true flows env) + in + construct_mpexp (checked_mpat, checked_guard, (l, None)) + (* 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 @@ -3222,6 +3285,212 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = typ_debug (lazy ("RETURNING AFTER COERCION " ^ string_of_typ (typ_of exp))); exp, !all_unifiers +and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = + let (Typ_aux (typ_aux, _) as typ), env = bind_existential typ env in + typ_print ("Binding " ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ); + let annot_mpat mpat typ = MP_aux (mpat, (l, Some (env, typ, no_effect))) in + let switch_typ mpat typ = match mpat with + | MP_aux (pat_aux, (l, Some (env, _, eff))) -> MP_aux (pat_aux, (l, Some (env, typ, eff))) + | _ -> typ_error l "Cannot switch type for unannotated mapping-pattern" + in + let bind_tuple_mpat (tpats, env, guards) mpat typ = + let tpat, env, guards' = bind_mpat env mpat typ in tpat :: tpats, env, guards' @ guards + in + match mpat_aux with + | MP_id v -> + begin + (* If the identifier we're matching on is also a constructor of + a union, that's probably a mistake, so warn about it. *) + if Env.is_union_constructor v env then + Util.warn (Printf.sprintf "Identifier %s found in mapping-pattern is also a union constructor at %s\n" + (string_of_id v) + (Reporting_basic.loc_to_string l)) + else (); + match Env.lookup_id v env with + | Local (Immutable, _) | Unbound -> annot_mpat (MP_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 mapping-pattern " ^ string_of_mpat mpat) + | Enum enum -> subtyp l env enum typ; annot_mpat (MP_id v) typ, env, [] + end + | MP_cons (hd_mpat, tl_mpat) -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + let hd_mpat, env, hd_guards = bind_mpat env hd_mpat ltyp in + let tl_mpat, env, tl_guards = bind_mpat env tl_mpat typ in + annot_mpat (MP_cons (hd_mpat, tl_mpat)) typ, env, hd_guards @ tl_guards + | _ -> typ_error l "Cannot match cons mapping-pattern against non-list type" + end + | MP_string_append (mpat1, mpat2) -> + begin + let matcher = Env.expand_synonyms env typ in + match matcher with + | Typ_aux (Typ_id id, _) when Id.compare id (mk_id "string") = 0 -> + let mpat1, env, guards1 = bind_mpat env mpat1 typ in + let mpat2, env, guards2 = bind_mpat env mpat2 typ in + annot_mpat (MP_string_append (mpat1, mpat2)) typ, env, guards1 @ guards2 + | _ -> typ_error l "Cannot match string-append mapping-pattern against non-string type" + end + | MP_list mpats -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + let rec process_mpats env = function + | [] -> [], env, [] + | (pat :: mpats) -> + let mpat', env, guards = bind_mpat env mpat ltyp in + let mpats', env, guards' = process_mpats env mpats in + mpat' :: mpats', env, guards @ guards' + in + let mpats, env, guards = process_mpats env mpats in + annot_mpat (MP_list mpats) typ, env, guards + | _ -> typ_error l ("Cannot match list mapping-pattern " ^ string_of_mpat mpat ^ " against non-list type " ^ string_of_typ typ) + end + | MP_tup [] -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" -> + annot_mpat (MP_tup []) typ, env, [] + | _ -> typ_error l "Cannot match unit mapping-pattern against non-unit type" + end + | MP_tup mpats -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (Typ_tup typs, _) -> + let tpats, env, guards = + try List.fold_left2 bind_tuple_mpat ([], env, []) mpats typs with + | Invalid_argument _ -> typ_error l "Tuple mapping-pattern and tuple type have different length" + in + annot_mpat (MP_tup (List.rev tpats)) typ, env, guards + | _ -> typ_error l "Cannot bind tuple mapping-pattern against non tuple type" + end + | MP_app (f, mpats) 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 mapping-pattern " ^ string_of_typ typ); + let unifiers, _, _ (* FIXME! *) = 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 mapping-pattern " ^ string_of_mpat mpat) + else (); + let ret_typ' = subst_unifiers unifiers ret_typ in + let tpats, env, guards = + try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Union constructor mapping-pattern arguments have incorrect length" + in + annot_mpat (MP_app (f, List.rev tpats)) typ, env, guards + with + | Unification_error (l, m) -> typ_error l ("Unification error when mapping-pattern matching against union constructor: " ^ m) + end + | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + end + | MP_app (other, mpats) when Env.is_mapping other env -> + begin + let (typq, ctor_typ) = Env.get_val_spec other 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_bidir (typ1, typ2), _) -> + begin + try + typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ); + let unifiers, _, _ (* FIXME! *) = unify l env typ2 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 typ1 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 mapping-pattern " ^ string_of_mpat mpat) + else (); + let ret_typ' = subst_unifiers unifiers typ2 in + let tpats, env, guards = + try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Union constructor mapping-pattern arguments have incorrect length" + in + annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards + with + | Unification_error (l, m) -> typ_error l ("Unification error when mapping-pattern matching against union constructor: " ^ m) + end + | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id other) + end + | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env)-> + typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) + (* This is a special case for flow typing when we match a constant numeric literal. *) + | MP_lit (L_aux (L_num n, _) as lit) when is_atom typ -> + let nexp = match destruct_atom_nexp env typ with Some n -> n | None -> assert false in + annot_mpat (MP_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, [] + | _ -> + let (inferred_mpat, env, guards) = infer_mpat env mpat in + match subtyp l env typ (typ_of_mpat inferred_mpat) with + | () -> switch_typ inferred_mpat (typ_of_mpat inferred_mpat), env, guards + | exception (Type_error _ as typ_exn) -> + match mpat_aux with + | MP_lit lit -> + let var = fresh_var () in + let guard = mk_exp (E_app_infix (mk_exp (E_id var), mk_id "==", mk_exp (E_lit lit))) in + let (typed_mpat, env, guards) = bind_mpat env (mk_mpat (MP_id var)) typ in + typed_mpat, env, guard::guards + | _ -> raise typ_exn +and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = + let annot_mpat mpat typ = MP_aux (mpat, (l, Some (env, typ, no_effect))) in + match mpat_aux with + | MP_id v -> + begin + match Env.lookup_id v env with + | Local (Immutable, _) | Unbound -> + typ_error l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation") + | Local (Mutable, _) | Register _ -> + typ_error l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat) + | Enum enum -> annot_mpat (MP_id v) enum, env, [] + end + | MP_lit lit -> + annot_mpat (MP_lit lit) (infer_lit env lit), env, [] + | MP_vector (mpat :: mpats) -> + let fold_mpats (mpats, env, guards) mpat = + let typed_mpat, env, guards' = bind_mpat env mpat bit_typ in + mpats @ [typed_mpat], env, guards' @ guards + in + let mpats, env, guards = List.fold_left fold_mpats ([], env, []) (mpat :: mpats) in + let len = nexp_simp (nint (List.length mpats)) in + let etyp = typ_of_mpat (List.hd mpats) in + List.iter (fun mpat -> typ_equality l env etyp (typ_of_mpat mpat)) mpats; + annot_mpat (MP_vector mpats) (dvector_typ env len etyp), env, guards + | MP_vector_concat (mpat :: mpats) -> + let fold_mpats (mpats, env, guards) mpat = + let inferred_mpat, env, guards' = infer_mpat env mpat in + mpats @ [inferred_mpat], env, guards' @ guards + in + let inferred_mpats, env, guards = + List.fold_left fold_mpats ([], env, []) (mpat :: mpats) in + let (len, _, vtyp) = destruct_vec_typ l env (typ_of_mpat (List.hd inferred_mpats)) in + let fold_len len mpat = + let (len', _, vtyp') = destruct_vec_typ l env (typ_of_mpat mpat) in + typ_equality l env vtyp vtyp'; + nsum len len' + in + let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_mpats)) in + annot_mpat (MP_vector_concat inferred_mpats) (dvector_typ env len vtyp), env, guards + | MP_string_append (mpat1, mpat2) -> + let typed_mpat1, env, guards1 = infer_mpat env mpat1 in + let typed_mpat2, env, guards2 = infer_mpat env mpat2 in + typ_equality l env (typ_of_mpat typed_mpat1) (string_typ); + typ_equality l env (typ_of_mpat typed_mpat2) (string_typ); + annot_mpat (MP_string_append (typed_mpat1, typed_mpat2)) string_typ, env, guards1 @ guards2 + | _ -> typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) + (**************************************************************************) (* 6. Effect system *) (**************************************************************************) @@ -3245,15 +3514,20 @@ let add_effect_lexp (LEXP_aux (lexp, (l, annot))) eff = LEXP_aux (lexp, (l, add_effect_annot annot eff)) let effect_of_pat (P_aux (exp, (l, annot))) = effect_of_annot annot +let effect_of_mpat (MP_aux (exp, (l, annot))) = effect_of_annot annot let add_effect_pat (P_aux (pat, (l, annot))) eff = P_aux (pat, (l, add_effect_annot annot eff)) +let add_effect_mpat (MP_aux (mpat, (l, annot))) eff = + MP_aux (mpat, (l, add_effect_annot annot eff)) + 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) +let collect_effects_mpat xs = List.fold_left union_effects no_effect (List.map effect_of_mpat xs) (* Traversal that propagates effects upwards through expressions *) @@ -3423,6 +3697,30 @@ and propagate_pexp_effect = function | None -> Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, None)), p_eff end +and propagate_mpexp_effect = function + | MPat_aux (MPat_pat mpat, (l, annot)) -> + begin + let p_mpat = propagate_mpat_effect mpat in + let p_eff = effect_of_mpat p_mpat in + match annot with + | Some (typq, typ, eff) -> + MPat_aux (MPat_pat p_mpat, (l, Some (typq, typ, union_effects eff p_eff))), + union_effects eff p_eff + | None -> MPat_aux (MPat_pat p_mpat, (l, None)), p_eff + end + | MPat_aux (MPat_when (mpat, guard), (l, annot)) -> + begin + let p_mpat = propagate_mpat_effect mpat in + let p_guard = propagate_exp_effect guard in + let p_eff = union_effects (effect_of_mpat p_mpat) (effect_of p_guard) + in + match annot with + | Some (typq, typ, eff) -> + MPat_aux (MPat_when (p_mpat, p_guard), (l, Some (typq, typ, union_effects eff p_eff))), + union_effects eff p_eff + | None -> MPat_aux (MPat_when (p_mpat, p_guard), (l, None)), p_eff + end + and propagate_pat_effect (P_aux (pat, annot)) = let p_pat, eff = propagate_pat_effect_aux pat in add_effect_pat (P_aux (p_pat, annot)) eff @@ -3464,6 +3762,38 @@ and propagate_pat_effect_aux = function P_vector p_pats, collect_effects_pat p_pats | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat" +and propagate_mpat_effect (MP_aux (mpat, annot)) = + let p_mpat, eff = propagate_mpat_effect_aux mpat in + add_effect_mpat (MP_aux (p_mpat, annot)) eff +and propagate_mpat_effect_aux = function + | MP_lit lit -> MP_lit lit, no_effect + | MP_cons (mpat1, mpat2) -> + let p_mpat1 = propagate_mpat_effect mpat1 in + let p_mpat2 = propagate_mpat_effect mpat2 in + MP_cons (p_mpat1, p_mpat2), union_effects (effect_of_mpat p_mpat1) (effect_of_mpat p_mpat2) + | MP_string_append (mpat1, mpat2) -> + let p_mpat1 = propagate_mpat_effect mpat1 in + let p_mpat2 = propagate_mpat_effect mpat2 in + MP_string_append (p_mpat1, p_mpat2), union_effects (effect_of_mpat p_mpat1) (effect_of_mpat p_mpat2) + | MP_id id -> MP_id id, no_effect + | MP_app (id, mpats) -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_app (id, p_mpats), collect_effects_mpat p_mpats + | MP_tup mpats -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_tup p_mpats, collect_effects_mpat p_mpats + | MP_list mpats -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_list p_mpats, collect_effects_mpat p_mpats + | MP_vector_concat mpats -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_vector_concat p_mpats, collect_effects_mpat p_mpats + | MP_vector mpats -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_vector p_mpats, collect_effects_mpat p_mpats + | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in mpat" + + and propagate_letbind_effect (LB_aux (lb, (l, annot))) = let p_lb, eff = propagate_letbind_effect_aux lb in match annot with @@ -3550,11 +3880,30 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = end | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") + +let check_mapcl env (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, _))) typ = + match typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> + begin + let typed_mpexp1, prop_eff1 = propagate_mpexp_effect (check_mpexp env (strip_mpexp mpexp1) typ1) in + let typed_mpexp2, prop_eff2 = propagate_mpexp_effect (check_mpexp env (strip_mpexp mpexp2) typ2) in + MCL_aux (MCL_mapcl (typed_mpexp1, typed_mpexp2), (l, Some (env, typ, union_effects prop_eff1 prop_eff2))) + 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_pexp), (l, annot))) = match annot with | Some (_, _, eff) -> eff | None -> no_effect (* Maybe could be assert false. This should never happen *) + +let mapcl_effect (MCL_aux (MCL_mapcl _, (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), _) -> @@ -3633,6 +3982,24 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) 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") + +let check_mapdef env (MD_aux (MD_mapping (id, mapcls), (l, _)) as md_aux) = + typ_print ("\nChecking mapping " ^ string_of_id id); + let quant, typ = Env.get_val_spec id env in + let vtyp1, vtyp2, vl = match typ with + | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl + | _ -> typ_error l "Mapping val spec was not a mapping type" + in + typ_debug ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)); + let mapcl_env = add_typquant quant env in + let mapcls = List.map (fun mapcl -> check_mapcl mapcl_env mapcl typ) mapcls in + let eff = List.fold_left union_effects no_effect (List.map mapcl_effect mapcls) in + if equal_effects eff no_effect then + [DEF_mapdef (MD_aux (MD_mapping (id, mapcls), (l, None)))], env + else + typ_error l ("Mapping not pure:" ^ 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. *) @@ -3778,6 +4145,7 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = | DEF_type tdef -> check_typedef env tdef | DEF_fixity (prec, n, op) -> [DEF_fixity (prec, n, op)], env | DEF_fundef fdef -> check_fundef env fdef + | DEF_mapdef mdef -> check_mapdef env mdef | DEF_internal_mutrec fdefs -> let defs = List.concat (List.map (fun fdef -> fst (check_fundef env fdef)) fdefs) in let split_fundef (defs, fdefs) def = match def with @@ -3821,6 +4189,8 @@ let initial_env = (* Internal functions for Monomorphise.AtomToItself *) + |> Env.add_mapping (mk_id "int") (TypQ_aux (TypQ_no_forall, Parse_ast.Unknown), int_typ, string_typ) + |> Env.add_extern (mk_id "size_itself_int") (fun _ -> Some "size_itself_int") |> Env.add_val_spec (mk_id "size_itself_int") (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), diff --git a/src/type_check.mli b/src/type_check.mli index c0359516..9507302d 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -253,6 +253,12 @@ val pat_env_of : tannot pat -> Env.t val typ_of_pexp : tannot pexp -> typ val env_of_pexp : tannot pexp -> Env.t +val typ_of_mpat : tannot mpat -> typ +val env_of_mpat : tannot mpat -> Env.t + +val typ_of_mpexp : tannot mpexp -> typ +val env_of_mpexp : tannot mpexp -> Env.t + val effect_of : tannot exp -> effect val effect_of_pat : tannot pat -> effect val effect_of_annot : tannot -> effect -- cgit v1.2.3 From bf3a38a69fb895db274769b4d543976b07095d2f Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 26 Apr 2018 13:15:16 +0100 Subject: fv funcs for bidir types --- src/spec_analysis.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 97b634da..7bb82719 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -88,7 +88,9 @@ let rec free_type_names_t consider_var (Typ_aux (t, _)) = match t with | Typ_var name -> if consider_var then Nameset.add (string_of_kid name) mt else mt | Typ_id name -> Nameset.add (string_of_id name) mt | Typ_fn (t1,t2,_) -> Nameset.union (free_type_names_t consider_var t1) - (free_type_names_t consider_var t2) + (free_type_names_t consider_var t2) + | Typ_bidir (t1, t2) -> Nameset.union (free_type_names_t consider_var t1) + (free_type_names_t consider_var t2) | Typ_tup ts -> free_type_names_ts consider_var ts | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs) | Typ_exist (kids,_,t') -> List.fold_left (fun s kid -> Nameset.remove (string_of_kid kid) s) (free_type_names_t consider_var t') kids @@ -116,6 +118,7 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,_)) : Nameset.t = else used | Typ_id id -> conditional_add_typ bound used id | Typ_fn(arg,ret,_) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used arg) ret + | Typ_bidir(t1, t2) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used t1) t2 (* TODO FIXME? *) | Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used | Typ_app(id,targs) -> List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) @@ -451,6 +454,7 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_kind kdef -> fv_of_kind_def consider_var kdef | DEF_type tdef -> fv_of_type_def consider_var tdef | DEF_fundef fdef -> fv_of_fun consider_var fdef + | DEF_mapdef mdef -> mt,mt (* fv_of_map consider_var mdef *) | DEF_val lebind -> ((fun (b,u,_) -> (b,u)) (fv_of_let consider_var mt mt mt lebind)) | DEF_spec vspec -> fv_of_vspec consider_var vspec | DEF_fixity _ -> mt,mt -- cgit v1.2.3 From b94549367c2536b3df6fba8586efa1a2a4bca7b8 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 27 Apr 2018 13:19:24 +0100 Subject: further progress --- src/ast_util.ml | 9 ++++- src/ast_util.mli | 2 + src/initial_check.ml | 8 ++-- src/parse_ast.ml | 8 +++- src/rewrites.ml | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/type_check.ml | 5 ++- src/type_check.mli | 10 +++++ 7 files changed, 140 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 69fe63cb..d571c916 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -448,12 +448,15 @@ and map_mpexp_annot_aux f = function | MPat_pat mpat -> MPat_pat (map_mpat_annot f mpat) | MPat_when (mpat, guard) -> MPat_when (map_mpat_annot f mpat, map_exp_annot f guard) +and map_mapcl_annot f (MCL_aux (MCL_mapcl (mpexp1, mpexp2), annot)) = + MCL_aux (MCL_mapcl (map_mpexp_annot f mpexp1, map_mpexp_annot f mpexp2), f annot) + and map_mpat_annot f (MP_aux (mpat, annot)) = MP_aux (map_mpat_annot_aux f mpat, f annot) and map_mpat_annot_aux f = function | MP_lit lit -> MP_lit lit | MP_id id -> MP_id id | MP_app (id, mpats) -> MP_app (id, List.map (map_mpat_annot f) mpats) - | MP_record (fmpats, b) -> MP_record (List.map (map_fpat_annot f) fmpats, b) + | MP_record (fmpats, b) -> MP_record (List.map (map_mfpat_annot f) fmpats, b) | MP_tup mpats -> MP_tup (List.map (map_mpat_annot f) mpats) | MP_list mpats -> MP_list (List.map (map_mpat_annot f) mpats) | MP_vector_concat mpats -> MP_vector_concat (List.map (map_mpat_annot f) mpats) @@ -462,6 +465,7 @@ and map_mpat_annot_aux f = function | MP_string_append (mpat1, mpat2) -> MP_string_append (map_mpat_annot f mpat1, map_mpat_annot f mpat2) and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) +and map_mfpat_annot f (MFP_aux (MFP_mpat (id, mpat), annot)) = MFP_aux (MFP_mpat (id, map_mpat_annot f mpat), f annot) and map_letbind_annot f (LB_aux (lb, annot)) = LB_aux (map_letbind_annot_aux f lb, f annot) and map_letbind_annot_aux f = function | LB_val (pat, exp) -> LB_val (map_pat_annot f pat, map_exp_annot f exp) @@ -784,6 +788,9 @@ let rec pat_ids (P_aux (pat_aux, _)) = IdSet.union (pat_ids pat1) (pat_ids pat2) | P_record (fpats, _) -> List.fold_right IdSet.union (List.map fpat_ids fpats) IdSet.empty + | P_string_append (pat1, pat2) -> + IdSet.union (pat_ids pat1) (pat_ids pat2) + and fpat_ids (FP_aux (FP_Fpat (_, pat), _)) = pat_ids pat let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = diff --git a/src/ast_util.mli b/src/ast_util.mli index 7ac5058f..6fb1c576 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -177,7 +177,9 @@ val map_pexp_annot : ('a annot -> 'b annot) -> 'a pexp -> 'b pexp val map_lexp_annot : ('a annot -> 'b annot) -> 'a lexp -> 'b lexp val map_letbind_annot : ('a annot -> 'b annot) -> 'a letbind -> 'b letbind val map_mpat_annot : ('a annot -> 'b annot) -> 'a mpat -> 'b mpat +val map_mfpat_annot : ('a annot -> 'b annot) -> 'a mfpat -> 'b mfpat val map_mpexp_annot : ('a annot -> 'b annot) -> 'a mpexp -> 'b mpexp +val map_mapcl_annot : ('a annot -> 'b annot) -> 'a mapcl -> 'b mapcl (* Extract locations from identifiers *) val id_loc : id -> Parse_ast.l diff --git a/src/initial_check.ml b/src/initial_check.ml index 793d6657..b766daa1 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -771,11 +771,11 @@ let rec to_ast_mpat k_env def_ord (Parse_ast.MP_aux(mpat,l)) = if mpats = [] then MP_id (to_ast_id id) else MP_app(to_ast_id id, List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_record(fpats,_) -> + | Parse_ast.MP_record(mfpats,_) -> MP_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,()))) - fpats, false) + (fun (Parse_ast.MFP_aux(Parse_ast.MFP_mpat(id,mfp),l)) -> + MFP_aux(MFP_mpat(to_ast_id id, to_ast_mpat k_env def_ord mfp),(l,()))) + mfpats, false) | Parse_ast.MP_vector(mpats) -> MP_vector(List.map (to_ast_mpat k_env def_ord) mpats) | Parse_ast.MP_vector_concat(mpats) -> MP_vector_concat(List.map (to_ast_mpat k_env def_ord) mpats) | Parse_ast.MP_tup(mpats) -> MP_tup(List.map (to_ast_mpat k_env def_ord) mpats) diff --git a/src/parse_ast.ml b/src/parse_ast.ml index d845265f..3969663a 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -424,7 +424,7 @@ type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only | MP_lit of lit | MP_id of id | MP_app of id * ( mpat) list - | MP_record of ( fpat) list * bool + | MP_record of ( mfpat) list * bool | MP_vector of ( mpat) list | MP_vector_concat of ( mpat) list | MP_tup of ( mpat) list @@ -435,6 +435,12 @@ type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only and mpat = | MP_aux of ( mpat_aux) * l +and mfpat_aux = (* Mapping field pattern, why does this have to exist *) + | MFP_mpat of id * mpat + +and mfpat = + | MFP_aux of mfpat_aux * l + type mpexp_aux = | MPat_pat of ( mpat) | MPat_when of ( mpat) * ( exp) diff --git a/src/rewrites.ml b/src/rewrites.ml index 8a222431..c1d5f1cb 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3386,9 +3386,112 @@ let merge_funcls (Defs defs) = | d -> d in Defs (List.map merge_in_def defs) + +let rec exp_of_mpat (MP_aux (mpat, annot)) = + let empty_vec = E_aux (E_vector [], annot) in + let concat_vectors annot vec1 vec2 = (* TODO FIXME, this should be OK for typing but doesn't attach location information properly *) + E_aux (E_vector_append (vec1, vec2), annot) + in + match mpat with + | MP_lit lit -> E_aux (E_lit lit, annot) + | MP_id id -> E_aux (E_id id, annot) + | MP_app (id, args) -> E_aux (E_app (id, (List.map exp_of_mpat args)), annot) + | MP_record (mfpats, flag) -> E_aux (E_record (fexps_of_mfpats mfpats flag annot), annot) + | MP_vector mpats -> E_aux (E_vector (List.map exp_of_mpat mpats), annot) + | MP_vector_concat mpats -> List.fold_right (concat_vectors annot) (List.map exp_of_mpat mpats) empty_vec + | MP_tup mpats -> E_aux (E_tuple (List.map exp_of_mpat mpats), annot) + | MP_list mpats -> E_aux (E_list (List.map exp_of_mpat mpats), annot) + | MP_cons (mpat1, mpat2) -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), annot) + | MP_string_append (mpat1, mpat2) -> E_aux (E_app (mk_id "string_append", [exp_of_mpat mpat1; exp_of_mpat mpat2]), annot) + +and fexps_of_mfpats mfpats flag annot = + let fexp_of_mfpat (MFP_aux (MFP_mpat (id, mpat), annot)) = + FE_aux (FE_Fexp (id, exp_of_mpat mpat), annot) + in + FES_aux (FES_Fexps (List.map fexp_of_mfpat mfpats, flag), annot) + +let rec pat_of_mpat (MP_aux (mpat, annot)) = + match mpat with + | MP_lit lit -> P_aux (P_lit lit, annot) + | MP_id id -> P_aux (P_id id, annot) + | MP_app (id, args) -> P_aux (P_app (id, (List.map pat_of_mpat args)), annot) + | MP_record (mfpats, flag) -> P_aux (P_record ((fpats_of_mfpats mfpats), flag), annot) + | MP_vector mpats -> P_aux (P_vector (List.map pat_of_mpat mpats), annot) + | MP_vector_concat mpats -> P_aux (P_vector_concat (List.map pat_of_mpat mpats), annot) + | MP_tup mpats -> P_aux (P_tup (List.map pat_of_mpat mpats), annot) + | MP_list mpats -> P_aux (P_list (List.map pat_of_mpat mpats), annot) + | MP_cons (mpat1, mpat2) -> P_aux ((P_cons (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) + | MP_string_append (mpat1, mpat2) -> P_aux ((P_string_append (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) + +and fpats_of_mfpats mfpats = + let fpat_of_mfpat (MFP_aux (MFP_mpat (id, mpat), annot)) = + FP_aux (FP_Fpat (id, pat_of_mpat mpat), annot) + in + List.map fpat_of_mfpat mfpats + +let rewrite_defs_realise_mappings (Defs defs) = + let realise_mpexps forwards mpexp1 mpexp2 = + let mpexp_pat, mpexp_exp = + if forwards then mpexp1, mpexp2 + else mpexp2, mpexp1 + in + let exp = + match mpexp_exp with + | MPat_aux ((MPat_pat mpat), _) -> exp_of_mpat mpat + | MPat_aux ((MPat_when (mpat, _), _)) -> exp_of_mpat mpat + in + match mpexp_pat with + | MPat_aux (MPat_pat mpat, annot) -> Pat_aux (Pat_exp (pat_of_mpat mpat, exp), annot) + | MPat_aux (MPat_when (mpat, guard), annot) -> Pat_aux (Pat_when (pat_of_mpat mpat, guard, exp), annot) + in + let realise_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = + let pexp = realise_mpexps forwards mpexp1 mpexp2 in + FCL_aux (FCL_Funcl (id, pexp), (l, ())) + in + let realise_mapdef (MD_aux (MD_mapping (id, mapcls), ((l, (tannot:tannot)) as annot))) = + let forwards_id = mk_id (string_of_id id ^ "_forwards#") in + let backwards_id = mk_id (string_of_id id ^ "_backwards#") in + let non_rec = (Rec_aux (Rec_nonrec, Parse_ast.Unknown)) in + let effect_pure = (Effect_opt_aux (Effect_opt_pure, Parse_ast.Unknown)) in + let env = match mapcls with + | MCL_aux (_, mapcl_annot) :: _ -> env_of_annot mapcl_annot + | _ -> Type_check.typ_error l "mapping with no clauses?" + in + let (typq, bidir_typ) = Env.get_val_spec id env in + let forwards_typ = match bidir_typ with + | Typ_aux (Typ_bidir (typ1, typ2), l) -> Typ_aux (Typ_fn (typ1, typ2, no_effect), l) + | _ -> Type_check.typ_error l "non-bidir type of mapping?" + in + let backwards_typ = match bidir_typ with + | Typ_aux (Typ_bidir (typ1, typ2), l) -> Typ_aux (Typ_fn (typ2, typ1, no_effect), l) + | _ -> Type_check.typ_error l "non-bidir type of mapping?" + in + (* let env = Env.update_val_spec forwards_id (typq, forwards_typ) env in + * let env = Env.update_val_spec backwards_id (typq, backwards_typ) env in *) + let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let forwards_spec, env = Type_check.check_val_spec env forwards_spec in + let backwards_spec, env = Type_check.check_val_spec env backwards_spec in + let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in + let forwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls)), (l, ()))) in + let backwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl false backwards_id) mapcls)), (l, ()))) in + Printf.printf "%s\n%!" (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string); + Printf.printf "%s\n%!" (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string); + let forwards_fun, _ = Type_check.check_fundef env forwards_fun in + let backwards_fun, _ = Type_check.check_fundef env backwards_fun in + forwards_spec @ forwards_fun @ backwards_spec @ backwards_fun + in + let rewrite_def def = + match def with + | DEF_mapdef mdef -> realise_mapdef mdef + | d -> [d] + in + Defs (List.map rewrite_def defs |> List.flatten) + let recheck_defs defs = fst (check initial_env defs) let rewrite_defs_lem = [ + ("realise_mappings", rewrite_defs_realise_mappings); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); @@ -3424,6 +3527,7 @@ let rewrite_defs_lem = [ let rewrite_defs_ocaml = [ (* ("undefined", rewrite_undefined); *) ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); @@ -3444,6 +3548,7 @@ let rewrite_defs_ocaml = [ let rewrite_defs_c = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); @@ -3462,6 +3567,7 @@ let rewrite_defs_c = [ let rewrite_defs_interpreter = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); + ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); diff --git a/src/type_check.ml b/src/type_check.ml index f7668f21..0eaec4f8 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2156,6 +2156,7 @@ let strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, let strip_mpat : 'a mpat -> unit mpat = function mpat -> map_mpat_annot (fun (l, _) -> (l, ())) mpat let strip_mpexp : 'a mpexp -> unit mpexp = function mpexp -> map_mpexp_annot (fun (l, _) -> (l, ())) mpexp +let strip_mapcl : 'a mapcl -> unit mapcl = function mapcl -> map_mapcl_annot (fun (l, _) -> (l, ())) mapcl let fresh_var = let counter = ref 0 in @@ -2610,8 +2611,8 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) 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) + | P_app (f, _) when (not (Env.is_union_constructor f env) && not (Env.is_mapping f env)) -> + typ_error l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat) | P_as (pat, id) -> let (typed_pat, env, guards) = bind_pat env pat typ in annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) env, guards diff --git a/src/type_check.mli b/src/type_check.mli index 9507302d..d74e9562 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -209,6 +209,9 @@ val strip_pexp : 'a pexp -> unit pexp (** Strip the type annotations from an l-expression *) val strip_lexp : 'a lexp -> unit lexp +val strip_mpexp : 'a mpexp -> unit mpexp +val strip_mapcl : 'a mapcl -> unit mapcl + (** {2 Checking expressions and patterns} *) (** Check an expression has some type. Returns a fully annotated @@ -223,6 +226,10 @@ val infer_exp : Env.t -> unit exp -> tannot exp val check_case : Env.t -> typ -> unit pexp -> typ -> tannot pexp +val check_fundef : Env.t -> 'a fundef -> tannot def list * Env.t + +val check_val_spec : Env.t -> 'a val_spec -> tannot def list * Env.t + val prove : Env.t -> n_constraint -> bool val solve : Env.t -> nexp -> Big_int.num option @@ -236,6 +243,8 @@ val bind_pat : Env.t -> unit pat -> typ -> tannot pat * Env.t * unit Ast.exp lis on patterns that have previously been type checked. *) val bind_pat_no_guard : Env.t -> unit pat -> typ -> tannot pat * Env.t +val typ_error : Ast.l -> string -> 'a + (** {2 Destructuring type annotations} 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 @@ -247,6 +256,7 @@ val env_of_annot : Ast.l * tannot -> Env.t val typ_of : tannot exp -> typ val typ_of_annot : Ast.l * tannot -> typ + val pat_typ_of : tannot pat -> typ val pat_env_of : tannot pat -> Env.t -- cgit v1.2.3 From 296c6cdf5b4b3bf0814b9000bf61597ac00e9165 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 27 Apr 2018 14:46:44 +0100 Subject: create a single funcl with a match, rather than converting mapcls to funcls, because OCaml among others doesn't allow top-level guards --- src/rewrites.ml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index c1d5f1cb..e2b99c78 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3446,7 +3446,8 @@ let rewrite_defs_realise_mappings (Defs defs) = in let realise_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = let pexp = realise_mpexps forwards mpexp1 mpexp2 in - FCL_aux (FCL_Funcl (id, pexp), (l, ())) + pexp + (* FCL_aux (FCL_Funcl (id, pexp), (l, ())) *) in let realise_mapdef (MD_aux (MD_mapping (id, mapcls), ((l, (tannot:tannot)) as annot))) = let forwards_id = mk_id (string_of_id id ^ "_forwards#") in @@ -3466,17 +3467,19 @@ let rewrite_defs_realise_mappings (Defs defs) = | Typ_aux (Typ_bidir (typ1, typ2), l) -> Typ_aux (Typ_fn (typ2, typ1, no_effect), l) | _ -> Type_check.typ_error l "non-bidir type of mapping?" in - (* let env = Env.update_val_spec forwards_id (typq, forwards_typ) env in - * let env = Env.update_val_spec backwards_id (typq, backwards_typ) env in *) let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let forwards_spec, env = Type_check.check_val_spec env forwards_spec in let backwards_spec, env = Type_check.check_val_spec env backwards_spec in let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in - let forwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls)), (l, ()))) in - let backwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl false backwards_id) mapcls)), (l, ()))) in - Printf.printf "%s\n%!" (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string); - Printf.printf "%s\n%!" (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string); + let arg_exp = (mk_exp (E_id (mk_id "arg#"))) in + let arg_pat = mk_pat (P_id (mk_id "arg#")) in + let forwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls))) in + let backwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl false backwards_id) mapcls))) in + let forwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl forwards_id arg_pat forwards_match]), (l, ()))) in + let backwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl backwards_id arg_pat backwards_match]), (l, ()))) in + Printf.printf "forwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string); + Printf.printf "backwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string); let forwards_fun, _ = Type_check.check_fundef env forwards_fun in let backwards_fun, _ = Type_check.check_fundef env backwards_fun in forwards_spec @ forwards_fun @ backwards_spec @ backwards_fun -- cgit v1.2.3 From 5352660a3c171318f819ed2abf23e603c2be07b4 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 30 Apr 2018 11:16:15 +0100 Subject: oops, not every pattern is in fact string_typ, remember to pass through the original type in rewrite_defs_pat_string_append when not doing anything --- src/rewrites.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index e2b99c78..b3e60423 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2840,7 +2840,7 @@ let rec rewrite_defs_pat_string_append = ("nat", ("maybe_nat_of_prefix", nat_typ)); ] in - let (new_pat, new_guards, new_expr) = + let (new_pat, new_pat_typ, new_guards, new_expr) = match (p_aux, p_annot) with (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") @@ -2875,7 +2875,7 @@ let rec rewrite_defs_pat_string_append = let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in (* construct final result. TODO FIXME: *way* too much type-checking/stripping/rechecking *) - (mk_pat (P_id id)), guard1 :: guard2 :: (List.map strip_exp guards), new_expr + (mk_pat (P_id id)), string_typ, guard1 :: guard2 :: (List.map strip_exp guards), new_expr (* (builtin x) ^^ pat2 => expr ---> s# if match maybe_atoi s# { @@ -2941,11 +2941,11 @@ let rec rewrite_defs_pat_string_append = let new_let = mk_exp (E_let (new_letbind, new_match)) in (* construct final result *) - (mk_pat (P_id s_id)), new_guard :: (List.map strip_exp guards), new_let + (mk_pat (P_id s_id)), string_typ, new_guard :: (List.map strip_exp guards), new_let | P_string_append _, _ -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat (P_aux (p_aux, p_annot))) - | _ -> strip_pat (P_aux (p_aux, p_annot)), (List.map strip_exp guards), (strip_exp expr) + | _ -> strip_pat (P_aux (p_aux, p_annot)), typ_of_annot p_annot, (List.map strip_exp guards), (strip_exp expr) in (* un-merge Pat_exp and Pat_when cases *) @@ -2953,7 +2953,7 @@ let rec rewrite_defs_pat_string_append = | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) in - check_case env string_typ new_pexp (typ_of expr) + check_case env new_pat_typ new_pexp (typ_of expr) in pexp_rewriters rewrite_pexp -- cgit v1.2.3 From 274204a6f36d7c62a2030ed72f47d07f60c23a34 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 30 Apr 2018 13:13:17 +0100 Subject: progress on debugging string pattern matching --- src/rewrites.ml | 57 ++++++++++++++++++++++++++++++++++++++++--------------- src/sail_lib.ml | 2 ++ src/type_check.ml | 51 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 95 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index b3e60423..9067b22c 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2818,14 +2818,18 @@ let rec rewrite_defs_pat_string_append = let (pat, _, _, _) = destruct_pexp pexp in let env = pat_env_of pat in let assert_false = mk_exp (E_assert (mk_exp (E_lit (mk_lit L_false)), mk_exp (E_lit (mk_lit (L_string "unreachable"))))) in - let construct_single_match match_on pattern maybe_expr = - let (true_exp, false_exp) = - match maybe_expr with - | Some expr -> expr, assert_false - | None -> (mk_exp (E_lit (mk_lit L_true))), (mk_exp (E_lit (mk_lit L_false))) + let construct_bool_match match_on pexp = + let true_exp = (mk_exp (E_lit (mk_lit L_true))) in + let false_exp = (mk_exp (E_lit (mk_lit L_false))) in + let true_pexp = + match pexp with + | Pat_aux (Pat_exp (pat, exp), _) -> + mk_pexp (Pat_exp (pat, true_exp)) + | Pat_aux (Pat_when (pat, guards, exp), _) -> + mk_pexp (Pat_when (pat, guards, true_exp)) in - mk_exp (E_case (match_on, [mk_pexp (Pat_exp (pattern, true_exp)); - mk_pexp (Pat_exp (mk_pat P_wild, false_exp))])) + let false_pexp = mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) in + mk_exp (E_case (match_on, [true_pexp; false_pexp])) in (* merge cases of Pat_exp and Pat_when *) @@ -2842,6 +2846,21 @@ let rec rewrite_defs_pat_string_append = let (new_pat, new_pat_typ, new_guards, new_expr) = match (p_aux, p_annot) with + (* (pat1 ^^ pat2) ^^ pat3 => expr ---> pat1 ^^ (pat2 ^^ pat3) => expr and recurse*) + | P_string_append (P_aux (P_string_append (pat1, pat2), _), pat3), annot -> + let new_pat = P_aux (P_string_append (pat1, P_aux (P_string_append (pat2, pat3), p_annot)), annot) in + let new_pexp = match guards with + | [] -> Pat_aux (Pat_exp (new_pat, expr), p_annot) + | [g] -> Pat_aux (Pat_when (new_pat, g, expr), p_annot) + | gs -> assert false + in + Printf.printf "PEXP BEFORE RECURSE IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); + let rewritten = rewrite_pexp new_pexp in + Printf.printf "PEXP AFTER RECURSE IS %s\n%!" (Pretty_print_sail.doc_pexp rewritten |> Pretty_print_sail.to_string); + begin match rewritten with + | Pat_aux (Pat_exp (pat, exp), _) -> strip_pat pat, pat_typ_of pat, [], strip_exp exp + | Pat_aux (Pat_when (pat, guard, exp), _) -> strip_pat pat, pat_typ_of pat, [strip_exp guard], strip_exp exp + end (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") && match str_drop(s#, strlen("lit")) { @@ -2861,16 +2880,16 @@ let rec rewrite_defs_pat_string_append = (* construct drop expression -- string_drop(s#, strlen("lit")) *) let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id id); mk_exp (E_app (mk_id "string_length", [mk_exp (E_lit lit)]))])) in - (* construct the two new guards *) - let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in - let guard2 = construct_single_match drop_exp (strip_pat pat2) None in - (* recurse into pat2 *) let new_pat2_pexp = mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) in let new_pat2_pexp = check_case env (pat_typ_of pat2) new_pat2_pexp (typ_of expr) in let new_pat2_pexp = rewrite_pexp new_pat2_pexp in let new_pat2_pexp = strip_pexp new_pat2_pexp in + (* construct the two new guards *) + let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in + let guard2 = construct_bool_match drop_exp new_pat2_pexp in + (* construct new match expr *) let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in @@ -2916,17 +2935,22 @@ let rec rewrite_defs_pat_string_append = (* construct None pattern *) let none_exp = mk_pat (P_app (mk_id "None", [])) in + (* recurse into pat2 *) + let new_pat2_pexp = mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) in + Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pat2_pexp |> Pretty_print_sail.to_string); + let new_pat2_pexp = check_case env (pat_typ_of pat2) new_pat2_pexp (typ_of expr) in + let new_pat2_pexp = rewrite_pexp new_pat2_pexp in + let new_pat2_pexp = strip_pexp new_pat2_pexp in + (* construct the new guard *) - let guard_inner_match = construct_single_match drop_exp (strip_pat pat2) None in + let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in let new_guard = mk_exp (E_case (func_exp, [ mk_pexp (Pat_exp (some_exp, guard_inner_match)); mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) ])) in (* construct the new match *) - let new_match = mk_exp (E_case (drop_exp, [ - mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) - ])) in + let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in (* construct the new let *) let new_binding = mk_exp (E_case (func_exp, [ @@ -2953,11 +2977,14 @@ let rec rewrite_defs_pat_string_append = | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) in + Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); check_case env new_pat_typ new_pexp (typ_of expr) in pexp_rewriters rewrite_pexp +(* let rewrite_defs_mapping_builtins = + * let rewrite_pexp *) let rewrite_defs_pat_lits = let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 132af6f5..188a0703 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -467,6 +467,8 @@ let string_drop (str, n) = let n = Big_int.to_int n in String.sub str n (String. let string_length str = Big_int.of_int (String.length str) +let string_append (s1, s2) = s1 ^ s2 + let lt_int (x, y) = Big_int.less x y let set_slice (out_len, slice_len, out, n, slice) = diff --git a/src/type_check.ml b/src/type_check.ml index 0eaec4f8..cda624fc 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2611,6 +2611,57 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) end | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) end + + | P_app (f, pats) when Env.is_mapping f env -> + begin + let (typq, mapping_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 mapping_typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> + begin + try + typ_debug ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ); + let unifiers, _, _ (* FIXME! *) = unify l env typ2 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 typ1 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 typ2 in + let tpats, env, guards = + try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + in + annot_pat (P_app (f, List.rev tpats)) typ, env, guards + with + | Unification_error (l, m) -> + try + typ_debug "Unifying mapping forwards failed, trying backwards."; + typ_debug ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ); + let unifiers, _, _ (* FIXME! *) = unify l env typ1 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 typ2 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 typ1 in + let tpats, env, guards = + try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + in + annot_pat (P_app (f, List.rev tpats)) typ, env, guards + with + | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m) + end + | _ -> typ_error l ("Mal-formed mapping " ^ string_of_id f) + end + | P_app (f, _) when (not (Env.is_union_constructor f env) && not (Env.is_mapping f env)) -> typ_error l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat) | P_as (pat, id) -> -- cgit v1.2.3 From f8abc90f5e7ae8e25f2750a186eee2ef30021cf5 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 30 Apr 2018 15:18:56 +0100 Subject: further progress but confounds the type checker? --- src/rewrites.ml | 249 +++++++++++++++++++++++++++----------------------------- src/sail_lib.ml | 9 ++ 2 files changed, 129 insertions(+), 129 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 9067b22c..c45e4820 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2811,57 +2811,42 @@ let pexp_rewriters rewrite_pexp = let stringappend_counter = ref 0 + let rec rewrite_defs_pat_string_append = - let rec rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = - (* utils *) - let (pat, _, _, _) = destruct_pexp pexp in - let env = pat_env_of pat in - let assert_false = mk_exp (E_assert (mk_exp (E_lit (mk_lit L_false)), mk_exp (E_lit (mk_lit (L_string "unreachable"))))) in - let construct_bool_match match_on pexp = - let true_exp = (mk_exp (E_lit (mk_lit L_true))) in - let false_exp = (mk_exp (E_lit (mk_lit L_false))) in - let true_pexp = - match pexp with - | Pat_aux (Pat_exp (pat, exp), _) -> - mk_pexp (Pat_exp (pat, true_exp)) - | Pat_aux (Pat_when (pat, guards, exp), _) -> - mk_pexp (Pat_when (pat, guards, true_exp)) - in - let false_pexp = mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) in - mk_exp (E_case (match_on, [true_pexp; false_pexp])) - in + let builtins = [ + ("int", ("maybe_int_of_prefix", int_typ)); + ("nat", ("maybe_nat_of_prefix", nat_typ)); + ] + in - (* merge cases of Pat_exp and Pat_when *) - let (P_aux (p_aux, p_annot), guards, expr) = - match pexp_aux with - | Pat_exp (pat, expr) -> (pat, [], expr) - | Pat_when (pat, guard, expr) -> (pat, [guard], expr) + let fresh_stringappend_id () = + let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + id + in + + let construct_bool_match match_on pexp = + let true_exp = (mk_exp (E_lit (mk_lit L_true))) in + let false_exp = (mk_exp (E_lit (mk_lit L_false))) in + let true_pexp = + match pexp with + | Pat_aux (Pat_exp (pat, exp), _) -> + mk_pexp (Pat_exp (pat, true_exp)) + | Pat_aux (Pat_when (pat, guards, exp), _) -> + mk_pexp (Pat_when (pat, guards, true_exp)) in + let false_pexp = mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) in + mk_exp (E_case (match_on, [true_pexp; false_pexp])) + in - let builtins = [ - ("int", ("maybe_int_of_prefix", int_typ)); - ("nat", ("maybe_nat_of_prefix", nat_typ)); - ] in - - let (new_pat, new_pat_typ, new_guards, new_expr) = - match (p_aux, p_annot) with - (* (pat1 ^^ pat2) ^^ pat3 => expr ---> pat1 ^^ (pat2 ^^ pat3) => expr and recurse*) - | P_string_append (P_aux (P_string_append (pat1, pat2), _), pat3), annot -> - let new_pat = P_aux (P_string_append (pat1, P_aux (P_string_append (pat2, pat3), p_annot)), annot) in - let new_pexp = match guards with - | [] -> Pat_aux (Pat_exp (new_pat, expr), p_annot) - | [g] -> Pat_aux (Pat_when (new_pat, g, expr), p_annot) - | gs -> assert false - in - Printf.printf "PEXP BEFORE RECURSE IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); - let rewritten = rewrite_pexp new_pexp in - Printf.printf "PEXP AFTER RECURSE IS %s\n%!" (Pretty_print_sail.doc_pexp rewritten |> Pretty_print_sail.to_string); - begin match rewritten with - | Pat_aux (Pat_exp (pat, exp), _) -> strip_pat pat, pat_typ_of pat, [], strip_exp exp - | Pat_aux (Pat_when (pat, guard, exp), _) -> strip_pat pat, pat_typ_of pat, [strip_exp guard], strip_exp exp - end - (* + let rec rewrite_pat (pat, guards, expr) = + match pat with + (* (pat1 ^^ pat2) ^^ pat3 => expr ---> pat1 ^^ (pat2 ^^ pat3) => expr and recurse *) + | P_aux (P_string_append (P_aux (P_string_append (pat1, pat2), _), pat3), _) -> + let new_pat = mk_pat (P_string_append (pat1, mk_pat (P_string_append (pat2, pat3)))) in + rewrite_pat (new_pat, guards, expr) + (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") && match str_drop(s#, strlen("lit")) { pat2 => true, _ => false @@ -2869,34 +2854,33 @@ let rec rewrite_defs_pat_string_append = => match str_drop(s#, strlen("lit")) { pat2 => expr } - *) - | P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), p_annot -> + *) + | P_aux (P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), _) -> - (* common things *) - let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in - stringappend_counter := !stringappend_counter + 1; - let env = Env.add_local id (Immutable, string_typ) env in + let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; - (* construct drop expression -- string_drop(s#, strlen("lit")) *) - let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id id); mk_exp (E_app (mk_id "string_length", [mk_exp (E_lit lit)]))])) in + (* construct drop expression -- string_drop(s#, strlen("lit")) *) + let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id id); mk_exp (E_app (mk_id "string_length", [mk_exp (E_lit lit)]))])) in - (* recurse into pat2 *) - let new_pat2_pexp = mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) in - let new_pat2_pexp = check_case env (pat_typ_of pat2) new_pat2_pexp (typ_of expr) in - let new_pat2_pexp = rewrite_pexp new_pat2_pexp in - let new_pat2_pexp = strip_pexp new_pat2_pexp in + (* recurse into pat2 *) + let new_pat2_pexp = + match rewrite_pat (pat2, guards, expr) with + | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) + | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) + in - (* construct the two new guards *) - let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in - let guard2 = construct_bool_match drop_exp new_pat2_pexp in + (* construct the two new guards *) + let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in + let guard2 = construct_bool_match drop_exp new_pat2_pexp in - (* construct new match expr *) - let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + (* construct new match expr *) + let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in - (* construct final result. TODO FIXME: *way* too much type-checking/stripping/rechecking *) - (mk_pat (P_id id)), string_typ, guard1 :: guard2 :: (List.map strip_exp guards), new_expr + (* construct final result *) + mk_pat (P_id id), guard1 :: guard2 :: guards, new_expr - (* + (* (builtin x) ^^ pat2 => expr ---> s# if match maybe_atoi s# { Some (n#, len#) => match string_drop(s#, len#) { @@ -2904,72 +2888,81 @@ let rec rewrite_defs_pat_string_append = } None => false } - => let (x, len#) = match maybe_atoi s# { + => let (x, len#) = match maybe_int_of_prefix s# { Some (n#, len#) => (n#, len#) } in match string_drop(s#, len#) { pat2 => expr } - *) - | P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [x] ) , _), pat2), p_annot - when List.mem_assoc builtin_id builtins -> - - (* common things *) - let builtin_func, builtin_typ = List.assoc builtin_id builtins in - let s_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in - stringappend_counter := !stringappend_counter + 1; - let n_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in - stringappend_counter := !stringappend_counter + 1; - let len_id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in - stringappend_counter := !stringappend_counter + 1; - let env = Env.add_local s_id (Immutable, string_typ) env in - let env = Env.add_local n_id (Immutable, builtin_typ) env in - let env = Env.add_local len_id (Immutable, nat_typ) env in - - (* construct drop expression -- string_drop(s#, len#) *) - let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in - (* construct func expression -- maybe_atoi s# *) - let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in - (* construct some pattern -- Some (n#, len#) *) - let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in - (* construct None pattern *) - let none_exp = mk_pat (P_app (mk_id "None", [])) in - - (* recurse into pat2 *) - let new_pat2_pexp = mk_pexp (Pat_exp (strip_pat pat2, strip_exp expr)) in - Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pat2_pexp |> Pretty_print_sail.to_string); - let new_pat2_pexp = check_case env (pat_typ_of pat2) new_pat2_pexp (typ_of expr) in - let new_pat2_pexp = rewrite_pexp new_pat2_pexp in - let new_pat2_pexp = strip_pexp new_pat2_pexp in - - (* construct the new guard *) - let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in - let new_guard = mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, guard_inner_match)); - mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) + *) + | P_aux (P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _), pat2), _) + when List.mem_assoc builtin_id builtins -> + + (* common things *) + let builtin_func, _ = List.assoc builtin_id builtins in + let s_id = fresh_stringappend_id () in + let n_id = fresh_stringappend_id () in + let len_id = fresh_stringappend_id () in + + (* construct drop expression -- string_drop(s#, len#) *) + let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in + (* construct func expression -- maybe_atoi s# *) + let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in + (* construct some pattern -- Some (n#, len#) *) + let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in + (* construct None pattern *) + let none_exp = mk_pat (P_app (mk_id "None", [mk_pat (P_lit (mk_lit L_unit))])) in + + (* recurse into pat2 *) + let new_pat2_pexp = + match rewrite_pat (pat2, guards, expr) with + | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) + | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) + in + + (* construct the new guard *) + let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in + let new_guard = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, guard_inner_match)); + mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) + ])) in + + (* construct the new match *) + let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + + (* construct the new let *) + let new_binding = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ + mk_exp (E_id n_id); + mk_exp (E_id len_id) + ]))) ])) in + let new_letbind = mk_letbind (mk_pat (P_tup [ + mk_pat (P_id (mk_id var_id)); mk_pat (P_id len_id) + ])) new_binding in + let new_let = mk_exp (E_let (new_letbind, new_match)) in + + (* construct final result *) + mk_pat (P_id s_id), new_guard :: guards, new_let + | P_aux (P_string_append _, _) -> + failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat pat) + + | _ -> pat, guards, expr + in + + let rec rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = + + let (pat, _, _, _) = destruct_pexp pexp in + + (* merge cases of Pat_exp and Pat_when *) + let (P_aux (p_aux, p_annot), guards, expr) = + match pexp_aux with + | Pat_exp (pat, expr) -> (pat, [], expr) + | Pat_when (pat, guard, expr) -> (pat, [guard], expr) + in - (* construct the new match *) - let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in - - (* construct the new let *) - let new_binding = mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ - mk_exp (E_id n_id); - mk_exp (E_id len_id) - ]))) - ])) in - let new_letbind = mk_letbind (mk_pat (P_tup [ - strip_pat x; mk_pat (P_id len_id) - ])) new_binding in - let new_let = mk_exp (E_let (new_letbind, new_match)) in - - (* construct final result *) - (mk_pat (P_id s_id)), string_typ, new_guard :: (List.map strip_exp guards), new_let - | P_string_append _, _ -> - failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat (P_aux (p_aux, p_annot))) - - | _ -> strip_pat (P_aux (p_aux, p_annot)), typ_of_annot p_annot, (List.map strip_exp guards), (strip_exp expr) + let (new_pat, new_guards, new_expr) = + rewrite_pat (strip_pat pat, List.map strip_exp guards, strip_exp expr) in (* un-merge Pat_exp and Pat_when cases *) @@ -2978,13 +2971,11 @@ let rec rewrite_defs_pat_string_append = | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) in Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); - check_case env new_pat_typ new_pexp (typ_of expr) + check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) in pexp_rewriters rewrite_pexp -(* let rewrite_defs_mapping_builtins = - * let rewrite_pexp *) let rewrite_defs_pat_lits = let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 188a0703..e1a3c81f 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -469,6 +469,15 @@ let string_length str = Big_int.of_int (String.length str) let string_append (s1, s2) = s1 ^ s2 +(* highly inefficient recursive implementation *) +let rec maybe_int_of_prefix = function + | "" -> None + | str -> + let len = String.length str in + match int_of_string_opt str with + | Some n -> Some (Big_int.of_int n, Big_int.of_int len) + | None -> maybe_int_of_prefix (String.sub str 0 (len - 1)) + let lt_int (x, y) = Big_int.less x y let set_slice (out_len, slice_len, out, n, slice) = -- cgit v1.2.3 From 66047739ae2c5b4e84084930754d78bc21927b8e Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 10:35:07 +0100 Subject: rewriting of builtin mappings e.g. int --- src/rewrites.ml | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++------ src/sail_lib.ml | 12 +++++-- 2 files changed, 107 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index c45e4820..fdfd949a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2811,21 +2811,20 @@ let pexp_rewriters rewrite_pexp = let stringappend_counter = ref 0 +let fresh_stringappend_id () = + let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in + stringappend_counter := !stringappend_counter + 1; + id + let rec rewrite_defs_pat_string_append = let builtins = [ - ("int", ("maybe_int_of_prefix", int_typ)); - ("nat", ("maybe_nat_of_prefix", nat_typ)); + (* ("int", ("maybe_int_of_prefix", app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [int_typ; nat_typ]), Parse_ast.Unknown)] )); *) + ("int", ("maybe_int_of_prefix", tuple_typ [int_typ; nat_typ] )); ] in - let fresh_stringappend_id () = - let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in - stringappend_counter := !stringappend_counter + 1; - id - in - let construct_bool_match match_on pexp = let true_exp = (mk_exp (E_lit (mk_lit L_true))) in let false_exp = (mk_exp (E_lit (mk_lit L_false))) in @@ -2899,7 +2898,7 @@ let rec rewrite_defs_pat_string_append = when List.mem_assoc builtin_id builtins -> (* common things *) - let builtin_func, _ = List.assoc builtin_id builtins in + let builtin_func, builtin_inner_typ = List.assoc builtin_id builtins in let s_id = fresh_stringappend_id () in let n_id = fresh_stringappend_id () in let len_id = fresh_stringappend_id () in @@ -2931,12 +2930,12 @@ let rec rewrite_defs_pat_string_append = let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in (* construct the new let *) - let new_binding = mk_exp (E_case (func_exp, [ + let new_binding = mk_exp (E_cast (builtin_inner_typ, mk_exp (E_case (func_exp, [ mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ mk_exp (E_id n_id); mk_exp (E_id len_id) ]))) - ])) in + ])))) in let new_letbind = mk_letbind (mk_pat (P_tup [ mk_pat (P_id (mk_id var_id)); mk_pat (P_id len_id) ])) new_binding in @@ -2977,6 +2976,90 @@ let rec rewrite_defs_pat_string_append = pexp_rewriters rewrite_pexp +let mappingbuiltins_counter = ref 0 + +let fresh_mappingbuiltins_id () = + let id = mk_id ("_mappingbuiltins_" ^ (string_of_int !mappingbuiltins_counter) ^ "#") in + mappingbuiltins_counter := !mappingbuiltins_counter + 1; + id + + +let rewrite_defs_mapping_builtins = + + let builtins = [ + ("int", ("maybe_int_of_string", int_typ)); + ("nat", ("maybe_nat_of_string", nat_typ)); + ] + in + + let rec rewrite_pat (P_aux (p_aux, _) as pat, guards, expr) = + let new_pat, new_guards, new_expr = match p_aux with + | P_as (pat2, id) -> + let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in + mk_pat (P_as (new_pat2, id)), new_guards, new_expr + | P_typ (typ, pat2) -> + let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in + mk_pat (P_typ (typ, pat2)), new_guards, new_expr + | P_var (pat2, typ_pat) -> + let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in + mk_pat (P_var (pat2, typ_pat)), new_guards, new_expr + | P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)]) when List.mem_assoc builtin_id builtins -> + (* + builtin(x) => expr ---> s# if match builtin_fun(s#) { + Some x# => true + _ => false + } + => let x = match builtin_fun(s#) { Some x# => x# } in + expr + *) + let builtin_func, builtin_typ = List.assoc builtin_id builtins in + let s_id = fresh_mappingbuiltins_id () in + let x_id = fresh_mappingbuiltins_id () in + let true_exp = mk_exp (E_lit (mk_lit (L_true))) in + let false_exp = mk_exp (E_lit (mk_lit (L_false))) in + let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in + let new_pat = mk_pat (P_id s_id) in + let new_guard = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (mk_pat (P_app (mk_id "Some", [mk_pat (P_id x_id)])), true_exp)); + mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) + ])) in + let new_binding = mk_exp (E_cast (builtin_typ, mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (mk_pat (P_app (mk_id "Some", [mk_pat (P_id x_id)])), mk_exp (E_id x_id))) + ])))) in + let new_letbind = mk_letbind (mk_pat (P_id (mk_id var_id))) new_binding in + let new_expr = mk_exp (E_let (new_letbind, expr)) in + new_pat, new_guard :: guards, new_expr + | _ -> pat, guards, expr + in + new_pat, new_guards, new_expr + in + let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = + + let (pat, _, _, _) = destruct_pexp pexp in + + (* merge cases of Pat_exp and Pat_when *) + let (P_aux (p_aux, p_annot), guards, expr) = + match pexp_aux with + | Pat_exp (pat, expr) -> (pat, [], expr) + | Pat_when (pat, guard, expr) -> (pat, [guard], expr) + in + + let (new_pat, new_guards, new_expr) = + rewrite_pat (strip_pat pat, List.map strip_exp guards, strip_exp expr) + in + + (* un-merge Pat_exp and Pat_when cases *) + let new_pexp = match new_guards with + | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) + | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) + in + Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); + check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) + + in + pexp_rewriters rewrite_pexp + + let rewrite_defs_pat_lits = let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = let guards = ref [] in @@ -3520,6 +3603,7 @@ let rewrite_defs_lem = [ ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", rewrite_defs_remove_numeral_pats); ("pat_string_append", rewrite_defs_pat_string_append); + ("mapping_builtins", rewrite_defs_mapping_builtins); ("guarded_pats", rewrite_defs_guarded_pats); ("bitvector_exps", rewrite_bitvector_exps); (* ("register_ref_writes", rewrite_register_ref_writes); *) @@ -3550,6 +3634,7 @@ let rewrite_defs_ocaml = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); + ("mapping_builtins", rewrite_defs_mapping_builtins); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3571,6 +3656,7 @@ let rewrite_defs_c = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); + ("mapping_builtins", rewrite_defs_mapping_builtins); ("pat_lits", rewrite_defs_pat_lits); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3590,6 +3676,7 @@ let rewrite_defs_interpreter = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); + ("mapping_builtins", rewrite_defs_mapping_builtins); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); diff --git a/src/sail_lib.ml b/src/sail_lib.ml index e1a3c81f..c83359f3 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -1,6 +1,7 @@ module Big_int = Nat_big_num type 'a return = { return : 'b . 'a -> 'b } +type 'za zoption = | ZNone of unit | ZSome of 'za;; let opt_trace = ref false @@ -467,17 +468,22 @@ let string_drop (str, n) = let n = Big_int.to_int n in String.sub str n (String. let string_length str = Big_int.of_int (String.length str) -let string_append (s1, s2) = s1 ^ s2 +let string_append (s1, s2) = s1 ^ s2 (* highly inefficient recursive implementation *) let rec maybe_int_of_prefix = function - | "" -> None + | "" -> ZNone () | str -> let len = String.length str in match int_of_string_opt str with - | Some n -> Some (Big_int.of_int n, Big_int.of_int len) + | Some n -> ZSome (Big_int.of_int n, Big_int.of_int len) | None -> maybe_int_of_prefix (String.sub str 0 (len - 1)) +let maybe_int_of_string str = + match int_of_string_opt str with + | None -> ZNone () + | Some n -> ZSome (Big_int.of_int n) + let lt_int (x, y) = Big_int.less x y let set_slice (out_len, slice_len, out, n, slice) = -- cgit v1.2.3 From 471bbe0bb6f05034033566990b87e6d2f3853afe Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 10:36:01 +0100 Subject: type-checking of calls to mappings, by synthing val-specs for the realised functions early and then mimicing the overload machinery --- src/type_check.ml | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index cda624fc..bf42076c 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -857,10 +857,16 @@ end = struct { env with variants = Bindings.add id variant env.variants } end - let add_mapping id mapping env = + let add_mapping id (typq, typ1, typ2) env = begin typ_print ("Adding mapping " ^ string_of_id id); - { env with mappings = Bindings.add id mapping env.mappings } + let forwards_id = mk_id (string_of_id id ^ "_forwards#") in + let backwards_id = mk_id (string_of_id id ^ "_backwards#") in + let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), Parse_ast.Unknown) in + let backwards_typ = Typ_aux (Typ_fn (typ2, typ1, no_effect), Parse_ast.Unknown) in + { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } + |> add_val_spec forwards_id (typq, forwards_typ) + |> add_val_spec backwards_id (typq, backwards_typ) end let add_union_id id bind env = @@ -2284,7 +2290,21 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ print_endline ("Solved " ^ string_of_nexp nexp ^ " = " ^ Big_int.to_string n); annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ end - | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> + | E_app (mapping, xs), _ when Env.is_mapping mapping env -> + let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in + let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in + typ_print ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + begin try crule check_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) typ with + | Type_error (_, err1) -> + typ_print ("Error in forwards direction: " ^ string_of_type_error err1); + typ_print ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + begin try crule check_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) typ with + | Type_error (_, err2) -> + typ_print ("Error in backwards direction: " ^ string_of_type_error err2); + typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) + end + end + | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> let rec try_overload = function | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) | (errs, (f :: fs)) -> begin -- cgit v1.2.3 From 4bd44da95c363640d6e5b2886193d80109caba6d Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 11:09:32 +0100 Subject: inferring is also required --- src/type_check.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index bf42076c..d2cbcf7a 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3083,6 +3083,20 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as 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) -> infer_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) + | E_app (mapping, xs) when Env.is_mapping mapping env -> + let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in + let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in + typ_print ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + begin try irule infer_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) with + | Type_error (_, err1) -> + typ_print ("Error in forwards direction: " ^ string_of_type_error err1); + typ_print ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + begin try irule infer_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) with + | Type_error (_, err2) -> + typ_print ("Error in backwards direction: " ^ string_of_type_error err2); + typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) + end + end | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 -> let rec try_overload = function | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) -- cgit v1.2.3 From 1dc9f51dc547fc2a5f72095a49f49c540b96a71b Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 13:10:59 +0100 Subject: it works --- src/sail_lib.ml | 2 + src/type_check.ml | 129 ++++++++++++++++++++++++++++++++++++++++++++--------- src/type_check.mli | 13 ++++++ 3 files changed, 124 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index c83359f3..2f5d1d15 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -3,6 +3,8 @@ module Big_int = Nat_big_num type 'a return = { return : 'b . 'a -> 'b } type 'za zoption = | ZNone of unit | ZSome of 'za;; +let zint_forwardsz3 _ = assert false + let opt_trace = ref false let trace_depth = ref 0 diff --git a/src/type_check.ml b/src/type_check.ml index d2cbcf7a..a0888aa7 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -176,6 +176,85 @@ let is_atom (Typ_aux (typ_aux, _)) = | Typ_app (f, [_]) when string_of_id f = "atom" -> true | _ -> false + + +let rec strip_id = function + | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown) + | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown) +and strip_kid = function + | Kid_aux (Var x, _) -> Kid_aux (Var x, Parse_ast.Unknown) +and strip_base_effect = function + | BE_aux (eff, _) -> BE_aux (eff, Parse_ast.Unknown) +and strip_effect = function + | Effect_aux (Effect_set effects, _) -> Effect_aux (Effect_set (List.map strip_base_effect effects), Parse_ast.Unknown) +and strip_nexp_aux = function + | Nexp_id id -> Nexp_id (strip_id id) + | Nexp_var kid -> Nexp_var (strip_kid kid) + | Nexp_constant n -> Nexp_constant n + | Nexp_app (id, nexps) -> Nexp_app (id, List.map strip_nexp nexps) + | Nexp_times (nexp1, nexp2) -> Nexp_times (strip_nexp nexp1, strip_nexp nexp2) + | Nexp_sum (nexp1, nexp2) -> Nexp_sum (strip_nexp nexp1, strip_nexp nexp2) + | Nexp_minus (nexp1, nexp2) -> Nexp_minus (strip_nexp nexp1, strip_nexp nexp2) + | Nexp_exp nexp -> Nexp_exp (strip_nexp nexp) + | Nexp_neg nexp -> Nexp_neg (strip_nexp nexp) +and strip_nexp = function + | Nexp_aux (nexp_aux, _) -> Nexp_aux (strip_nexp_aux nexp_aux, Parse_ast.Unknown) +and strip_n_constraint_aux = function + | NC_equal (nexp1, nexp2) -> NC_equal (strip_nexp nexp1, strip_nexp nexp2) + | NC_bounded_ge (nexp1, nexp2) -> NC_bounded_ge (strip_nexp nexp1, strip_nexp nexp2) + | NC_bounded_le (nexp1, nexp2) -> NC_bounded_le (strip_nexp nexp1, strip_nexp nexp2) + | NC_not_equal (nexp1, nexp2) -> NC_not_equal (strip_nexp nexp1, strip_nexp nexp2) + | NC_set (kid, nums) -> NC_set (strip_kid kid, nums) + | NC_or (nc1, nc2) -> NC_or (strip_n_constraint nc1, strip_n_constraint nc2) + | NC_and (nc1, nc2) -> NC_and (strip_n_constraint nc1, strip_n_constraint nc2) + | NC_true -> NC_true + | NC_false -> NC_false +and strip_n_constraint = function + | NC_aux (nc_aux, _) -> NC_aux (strip_n_constraint_aux nc_aux, Parse_ast.Unknown) +and strip_typ_arg = function + | Typ_arg_aux (typ_arg_aux, _) -> Typ_arg_aux (strip_typ_arg_aux typ_arg_aux, Parse_ast.Unknown) +and strip_typ_arg_aux = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (strip_nexp nexp) + | Typ_arg_typ typ -> Typ_arg_typ (strip_typ typ) + | Typ_arg_order ord -> Typ_arg_order (strip_order ord) +and strip_order = function + | Ord_aux (ord_aux, _) -> Ord_aux (strip_order_aux ord_aux, Parse_ast.Unknown) +and strip_order_aux = function + | Ord_var kid -> Ord_var (strip_kid kid) + | Ord_inc -> Ord_inc + | Ord_dec -> Ord_dec +and strip_typ_aux : typ_aux -> typ_aux = function + | Typ_id id -> Typ_id (strip_id id) + | Typ_var kid -> Typ_var (strip_kid kid) + | Typ_fn (typ1, typ2, effect) -> Typ_fn (strip_typ typ1, strip_typ typ2, strip_effect effect) + | Typ_bidir (typ1, typ2) -> Typ_bidir (strip_typ typ1, strip_typ typ2) + | Typ_tup typs -> Typ_tup (List.map strip_typ typs) + | Typ_exist (kids, constr, typ) -> Typ_exist ((List.map strip_kid kids), strip_n_constraint constr, strip_typ typ) + | Typ_app (id, args) -> Typ_app (strip_id id, List.map strip_typ_arg args) +and strip_typ : typ -> typ = function + | Typ_aux (typ_aux, _) -> Typ_aux (strip_typ_aux typ_aux, Parse_ast.Unknown) +and strip_typq = function TypQ_aux (typq_aux, l) -> TypQ_aux (strip_typq_aux typq_aux, Parse_ast.Unknown) +and strip_typq_aux = function + | TypQ_no_forall -> TypQ_no_forall + | TypQ_tq quants -> TypQ_tq (List.map strip_quant_item quants) +and strip_quant_item = function + | QI_aux (qi_aux, _) -> QI_aux (strip_qi_aux qi_aux, Parse_ast.Unknown) +and strip_qi_aux = function + | QI_id kinded_id -> QI_id (strip_kinded_id kinded_id) + | QI_const constr -> QI_const (strip_n_constraint constr) +and strip_kinded_id = function + | KOpt_aux (kinded_id_aux, _) -> KOpt_aux (strip_kinded_id_aux kinded_id_aux, Parse_ast.Unknown) +and strip_kinded_id_aux = function + | KOpt_none kid -> KOpt_none (strip_kid kid) + | KOpt_kind (kind, kid) -> KOpt_kind (strip_kind kind, strip_kid kid) +and strip_kind = function + | K_aux (k_aux, _) -> K_aux (strip_kind_aux k_aux, Parse_ast.Unknown) +and strip_kind_aux = function + | K_kind base_kinds -> K_kind (List.map strip_base_kind base_kinds) +and strip_base_kind = function + | BK_aux (bk_aux, _) -> BK_aux (bk_aux, Parse_ast.Unknown) + + (**************************************************************************) (* 1. Substitutions *) (**************************************************************************) @@ -744,17 +823,38 @@ end = struct with | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) - let update_val_spec id (typq, typ) env = + let rec update_val_spec id (typq, typ) env = begin let typ = expand_synonyms env typ in typ_print (lazy ("Adding val spec binding " ^ string_of_id id ^ " :: " ^ string_of_bind (typq, typ))); + let env = match typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> add_mapping id (typq, typ1, typ2) env + | _ -> env + in { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } end - - 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 update_val_spec id bind env + and add_val_spec id (bind_typq, bind_typ) env = + if not (Bindings.mem id env.top_val_specs) + then update_val_spec id (bind_typq, bind_typ) env + else + let (existing_typq, existing_typ) = Bindings.find id env.top_val_specs in + let existing_cmp = (strip_typq existing_typq, strip_typ existing_typ) in + let bind_cmp = (strip_typq bind_typq, strip_typ bind_typ) in + if existing_cmp <> bind_cmp then + typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound as " ^ string_of_bind (existing_typq, existing_typ) ^ ", cannot rebind as " ^ string_of_bind (bind_typq, bind_typ)) + else + env + and add_mapping id (typq, typ1, typ2) env = + begin + typ_print ("Adding mapping " ^ string_of_id id); + let forwards_id = mk_id (string_of_id id ^ "_forwards#") in + let backwards_id = mk_id (string_of_id id ^ "_backwards#") in + let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), Parse_ast.Unknown) in + let backwards_typ = Typ_aux (Typ_fn (typ2, typ1, no_effect), Parse_ast.Unknown) in + { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } + |> add_val_spec forwards_id (typq, forwards_typ) + |> add_val_spec backwards_id (typq, backwards_typ) + end let define_val_spec id env = if IdSet.mem id env.defined_val_specs @@ -857,18 +957,6 @@ end = struct { env with variants = Bindings.add id variant env.variants } end - let add_mapping id (typq, typ1, typ2) env = - begin - typ_print ("Adding mapping " ^ string_of_id id); - let forwards_id = mk_id (string_of_id id ^ "_forwards#") in - let backwards_id = mk_id (string_of_id id ^ "_backwards#") in - let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), Parse_ast.Unknown) in - let backwards_typ = Typ_aux (Typ_fn (typ2, typ1, no_effect), Parse_ast.Unknown) in - { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } - |> add_val_spec forwards_id (typq, forwards_typ) - |> add_val_spec backwards_id (typq, backwards_typ) - end - let add_union_id id bind env = begin typ_print (lazy ("Adding union identifier binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind)); @@ -2304,7 +2392,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) end end - | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> + | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> let rec try_overload = function | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) | (errs, (f :: fs)) -> begin @@ -4275,7 +4363,8 @@ let initial_env = (* Internal functions for Monomorphise.AtomToItself *) - |> Env.add_mapping (mk_id "int") (TypQ_aux (TypQ_no_forall, Parse_ast.Unknown), int_typ, string_typ) + (* |> Env.add_val_spec (mk_id "int") + * (TypQ_aux (TypQ_no_forall, Parse_ast.Unknown), Typ_aux (Typ_bidir (int_typ, string_typ), Parse_ast.Unknown)) *) |> Env.add_extern (mk_id "size_itself_int") (fun _ -> Some "size_itself_int") |> Env.add_val_spec (mk_id "size_itself_int") diff --git a/src/type_check.mli b/src/type_check.mli index d74e9562..03a0c384 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -212,6 +212,19 @@ val strip_lexp : 'a lexp -> unit lexp val strip_mpexp : 'a mpexp -> unit mpexp val strip_mapcl : 'a mapcl -> unit mapcl +(* Strip location information from types for comparison purposes *) +val strip_typ : typ -> typ +val strip_typq : typquant -> typquant +val strip_id : id -> id +val strip_kid : kid -> kid +val strip_base_effect : base_effect -> base_effect +val strip_effect : effect -> effect +val strip_nexp_aux : nexp_aux -> nexp_aux +val strip_nexp : nexp -> nexp +val strip_n_constraint_aux : n_constraint_aux -> n_constraint_aux +val strip_n_constraint : n_constraint -> n_constraint +val strip_typ_aux : typ_aux -> typ_aux + (** {2 Checking expressions and patterns} *) (** Check an expression has some type. Returns a fully annotated -- cgit v1.2.3 From 92bdfb613b35a913aee7e954b7f7a2d62b39d302 Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 16:54:05 +0100 Subject: add type annotation patterns to mpats --- src/ast_util.ml | 8 ++++++-- src/initial_check.ml | 1 + src/parse_ast.ml | 1 + src/parser.mly | 3 +++ src/rewrites.ml | 2 ++ src/type_check.ml | 7 +++++++ 6 files changed, 20 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index d571c916..a766b846 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -463,6 +463,7 @@ and map_mpat_annot_aux f = function | MP_vector mpats -> MP_vector (List.map (map_mpat_annot f) mpats) | MP_cons (mpat1, mpat2) -> MP_cons (map_mpat_annot f mpat1, map_mpat_annot f mpat2) | MP_string_append (mpat1, mpat2) -> MP_string_append (map_mpat_annot f mpat1, map_mpat_annot f mpat2) + | MP_typ (mpat, typ) -> MP_typ (map_mpat_annot f mpat, typ) and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) and map_mfpat_annot f (MFP_aux (MFP_mpat (id, mpat), annot)) = MFP_aux (MFP_mpat (id, map_mpat_annot f mpat), f annot) @@ -499,6 +500,7 @@ let def_loc = function | DEF_kind (KD_aux (_, (l, _))) | DEF_type (TD_aux (_, (l, _))) | DEF_fundef (FD_aux (_, (l, _))) + | DEF_mapdef (MD_aux (_, (l, _))) | DEF_val (LB_aux (_, (l, _))) | DEF_spec (VS_aux (_, (l, _))) | DEF_default (DT_aux (_, l)) @@ -752,7 +754,8 @@ and string_of_mpat (MP_aux (pat, l)) = | MP_vector_concat pats -> string_of_list " : " string_of_mpat pats | MP_vector pats -> "[" ^ string_of_list ", " string_of_mpat pats ^ "]" | MP_string_append (pat1, pat2) -> string_of_mpat pat1 ^ " ^^ " ^ string_of_mpat pat2 - | _ -> "PAT" + | MP_typ (mpat, typ) -> "(" ^ string_of_mpat mpat ^ " : " ^ string_of_typ typ ^ ")" + | _ -> "MPAT" and string_of_lexp (LEXP_aux (lexp, _)) = match lexp with @@ -976,6 +979,7 @@ let rec tyvars_of_typ (Typ_aux (t,_)) = | Typ_id _ -> KidSet.empty | Typ_var kid -> KidSet.singleton kid | Typ_fn (t1,t2,_) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) + | Typ_bidir (t1, t2) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) | Typ_tup ts -> List.fold_left (fun s t -> KidSet.union s (tyvars_of_typ t)) KidSet.empty ts @@ -1020,7 +1024,7 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = initial_check.ml. i.e. the rewriter should only encounter this case when re-writing those functions. *) wrap (E_id (prepend_id "typ_" (id_of_kid kid))) typ - | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) + | Typ_bidir _ | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) and undefined_of_typ_args mwords l annot (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with | Typ_arg_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] diff --git a/src/initial_check.ml b/src/initial_check.ml index b766daa1..3f7a7052 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -782,6 +782,7 @@ let rec to_ast_mpat k_env def_ord (Parse_ast.MP_aux(mpat,l)) = | Parse_ast.MP_list(mpats) -> MP_list(List.map (to_ast_mpat k_env def_ord) mpats) | Parse_ast.MP_cons(pat1, pat2) -> MP_cons (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) | Parse_ast.MP_string_append (pat1, pat2) -> MP_string_append (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) + | Parse_ast.MP_typ (mpat, typ) -> MP_typ (to_ast_mpat k_env def_ord mpat, to_ast_typ k_env def_ord typ) ), (l,())) diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 3969663a..e59dd356 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -431,6 +431,7 @@ type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only | MP_list of ( mpat) list | MP_cons of ( mpat) * ( mpat) | MP_string_append of ( mpat) * ( mpat) + | MP_typ of mpat * atyp and mpat = | MP_aux of ( mpat_aux) * l diff --git a/src/parser.mly b/src/parser.mly index adf99ede..d41964b7 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1241,6 +1241,9 @@ atomic_mpat: { mk_mpat (MP_list []) $startpos $endpos } | LsquareBar mpat_list RsquareBar { mk_mpat (MP_list $2) $startpos $endpos } + | atomic_mpat Colon typ + { mk_mpat (MP_typ ($1, $3)) $startpos $endpos } + mpexp: diff --git a/src/rewrites.ml b/src/rewrites.ml index fdfd949a..ac36dffa 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3504,6 +3504,7 @@ let rec exp_of_mpat (MP_aux (mpat, annot)) = | MP_list mpats -> E_aux (E_list (List.map exp_of_mpat mpats), annot) | MP_cons (mpat1, mpat2) -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), annot) | MP_string_append (mpat1, mpat2) -> E_aux (E_app (mk_id "string_append", [exp_of_mpat mpat1; exp_of_mpat mpat2]), annot) + | MP_typ (mpat, typ) -> E_aux (E_cast (typ, exp_of_mpat mpat), annot) and fexps_of_mfpats mfpats flag annot = let fexp_of_mfpat (MFP_aux (MFP_mpat (id, mpat), annot)) = @@ -3523,6 +3524,7 @@ let rec pat_of_mpat (MP_aux (mpat, annot)) = | MP_list mpats -> P_aux (P_list (List.map pat_of_mpat mpats), annot) | MP_cons (mpat1, mpat2) -> P_aux ((P_cons (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) | MP_string_append (mpat1, mpat2) -> P_aux ((P_string_append (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) + | MP_typ (mpat, typ) -> P_aux (P_typ (typ, pat_of_mpat mpat), annot) and fpats_of_mfpats mfpats = let fpat_of_mfpat (MFP_aux (MFP_mpat (id, mpat), annot)) = diff --git a/src/type_check.ml b/src/type_check.ml index a0888aa7..c96c2c3f 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3632,6 +3632,10 @@ and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = end | MP_lit lit -> annot_mpat (MP_lit lit) (infer_lit env lit), env, [] + | MP_typ (mpat, typ_annot) -> + Env.wf_typ env typ_annot; + let (typed_mpat, env, guards) = bind_mpat env mpat typ_annot in + annot_mpat (MP_typ (typed_mpat, typ_annot)) typ_annot, env, guards | MP_vector (mpat :: mpats) -> let fold_mpats (mpats, env, guards) mpat = let typed_mpat, env, guards' = bind_mpat env mpat bit_typ in @@ -3965,6 +3969,9 @@ and propagate_mpat_effect_aux = function | MP_vector mpats -> let p_mpats = List.map propagate_mpat_effect mpats in MP_vector p_mpats, collect_effects_mpat p_mpats + | MP_typ (mpat, typ) -> + let p_mpat = propagate_mpat_effect mpat in + MP_typ (p_mpat, typ), effect_of_mpat mpat | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in mpat" -- cgit v1.2.3 From 274b7517f07076be19eedc1bdade6db2c649a8bc Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 1 May 2018 17:03:06 +0100 Subject: update for lazy evaluation of typechecker debugging after rebase --- src/type_check.ml | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index c96c2c3f..f683feee 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -846,7 +846,7 @@ end = struct env and add_mapping id (typq, typ1, typ2) env = begin - typ_print ("Adding mapping " ^ string_of_id id); + typ_print (lazy ("Adding mapping " ^ string_of_id id)); let forwards_id = mk_id (string_of_id id ^ "_forwards#") in let backwards_id = mk_id (string_of_id id ^ "_backwards#") in let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), Parse_ast.Unknown) in @@ -2381,14 +2381,14 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_app (mapping, xs), _ when Env.is_mapping mapping env -> let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in - typ_print ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + typ_print (lazy("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try crule check_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) typ with | Type_error (_, err1) -> - typ_print ("Error in forwards direction: " ^ string_of_type_error err1); - typ_print ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); + typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try crule check_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) typ with | Type_error (_, err2) -> - typ_print ("Error in backwards direction: " ^ string_of_type_error err2); + typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) end end @@ -2732,9 +2732,9 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin try - typ_debug ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in - typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ1 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) @@ -2749,10 +2749,10 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) with | Unification_error (l, m) -> try - typ_debug "Unifying mapping forwards failed, trying backwards."; - typ_debug ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ); + typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ1 typ in - typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ2 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) @@ -3174,14 +3174,14 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_app (mapping, xs) when Env.is_mapping mapping env -> let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in - typ_print ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + typ_print (lazy ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try irule infer_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) with | Type_error (_, err1) -> - typ_print ("Error in forwards direction: " ^ string_of_type_error err1); - typ_print ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); + typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try irule infer_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) with | Type_error (_, err2) -> - typ_print ("Error in backwards direction: " ^ string_of_type_error err2); + typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) end end @@ -3461,7 +3461,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = let (Typ_aux (typ_aux, _) as typ), env = bind_existential typ env in - typ_print ("Binding " ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ); + typ_print (lazy ("Binding " ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ)); let annot_mpat mpat typ = MP_aux (mpat, (l, Some (env, typ, no_effect))) in let switch_typ mpat typ = match mpat with | MP_aux (pat_aux, (l, Some (env, _, eff))) -> MP_aux (pat_aux, (l, Some (env, typ, eff))) @@ -3550,9 +3550,9 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> begin try - typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = 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)); + typ_debug (lazy (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) @@ -3581,9 +3581,9 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin try - typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in - typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ1 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) @@ -4165,13 +4165,13 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) let check_mapdef env (MD_aux (MD_mapping (id, mapcls), (l, _)) as md_aux) = - typ_print ("\nChecking mapping " ^ string_of_id id); + typ_print (lazy ("\nChecking mapping " ^ string_of_id id)); let quant, typ = Env.get_val_spec id env in let vtyp1, vtyp2, vl = match typ with | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl | _ -> typ_error l "Mapping val spec was not a mapping type" in - typ_debug ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)); + typ_debug (lazy ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); let mapcl_env = add_typquant quant env in let mapcls = List.map (fun mapcl -> check_mapcl mapcl_env mapcl typ) mapcls in let eff = List.fold_left union_effects no_effect (List.map mapcl_effect mapcls) in -- cgit v1.2.3 From 0c062d51d850c77d01fc3e78a73778e6f5aa7a59 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 2 May 2018 12:00:07 +0100 Subject: refactor string append pattern ast to be based on lists rather than pairs --- src/ast_util.ml | 12 +++---- src/initial_check.ml | 4 +-- src/parse_ast.ml | 4 +-- src/parser.mly | 20 ++++++++--- src/pattern_completeness.ml | 11 +++--- src/rewriter.ml | 10 +++--- src/rewriter.mli | 2 +- src/rewrites.ml | 37 ++++++++++---------- src/sail_lib.ml | 2 +- src/type_check.ml | 83 +++++++++++++++++++++++++++------------------ 10 files changed, 108 insertions(+), 77 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index a766b846..98fc6bde 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -441,7 +441,7 @@ and map_pat_annot_aux f = function | P_vector_concat pats -> P_vector_concat (List.map (map_pat_annot f) pats) | P_vector pats -> P_vector (List.map (map_pat_annot f) pats) | P_cons (pat1, pat2) -> P_cons (map_pat_annot f pat1, map_pat_annot f pat2) - | P_string_append (pat1, pat2) -> P_string_append (map_pat_annot f pat1, map_pat_annot f pat2) + | P_string_append pats -> P_string_append (List.map (map_pat_annot f) pats) and map_mpexp_annot f (MPat_aux (mpexp, annot)) = MPat_aux (map_mpexp_annot_aux f mpexp, f annot) and map_mpexp_annot_aux f = function @@ -462,7 +462,7 @@ and map_mpat_annot_aux f = function | MP_vector_concat mpats -> MP_vector_concat (List.map (map_mpat_annot f) mpats) | MP_vector mpats -> MP_vector (List.map (map_mpat_annot f) mpats) | MP_cons (mpat1, mpat2) -> MP_cons (map_mpat_annot f mpat1, map_mpat_annot f mpat2) - | MP_string_append (mpat1, mpat2) -> MP_string_append (map_mpat_annot f mpat1, map_mpat_annot f mpat2) + | MP_string_append mpats -> MP_string_append (List.map (map_mpat_annot f) mpats) | MP_typ (mpat, typ) -> MP_typ (map_mpat_annot f mpat, typ) and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) @@ -740,7 +740,7 @@ and string_of_pat (P_aux (pat, l)) = | P_vector_concat pats -> string_of_list " : " string_of_pat pats | P_vector pats -> "[" ^ string_of_list ", " string_of_pat pats ^ "]" | P_as (pat, id) -> string_of_pat pat ^ " as " ^ string_of_id id - | P_string_append (pat1, pat2) -> string_of_pat pat1 ^ " ^^ " ^ string_of_pat pat2 + | P_string_append pats -> string_of_list " ^^ " string_of_pat pats | _ -> "PAT" and string_of_mpat (MP_aux (pat, l)) = @@ -753,7 +753,7 @@ and string_of_mpat (MP_aux (pat, l)) = | MP_list pats -> "[||" ^ string_of_list "," string_of_mpat pats ^ "||]" | MP_vector_concat pats -> string_of_list " : " string_of_mpat pats | MP_vector pats -> "[" ^ string_of_list ", " string_of_mpat pats ^ "]" - | MP_string_append (pat1, pat2) -> string_of_mpat pat1 ^ " ^^ " ^ string_of_mpat pat2 + | MP_string_append pats -> string_of_list " ^^ " string_of_mpat pats | MP_typ (mpat, typ) -> "(" ^ string_of_mpat mpat ^ " : " ^ string_of_typ typ ^ ")" | _ -> "MPAT" @@ -791,8 +791,8 @@ let rec pat_ids (P_aux (pat_aux, _)) = IdSet.union (pat_ids pat1) (pat_ids pat2) | P_record (fpats, _) -> List.fold_right IdSet.union (List.map fpat_ids fpats) IdSet.empty - | P_string_append (pat1, pat2) -> - IdSet.union (pat_ids pat1) (pat_ids pat2) + | P_string_append pats -> + List.fold_right IdSet.union (List.map pat_ids pats) IdSet.empty and fpat_ids (FP_aux (FP_Fpat (_, pat), _)) = pat_ids pat diff --git a/src/initial_check.ml b/src/initial_check.ml index 3f7a7052..5df6b825 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -470,7 +470,7 @@ let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pa | 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) | Parse_ast.P_cons(pat1, pat2) -> P_cons (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) - | Parse_ast.P_string_append (pat1, pat2) -> P_string_append (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) + | Parse_ast.P_string_append pats -> P_string_append (List.map (to_ast_pat k_env def_ord) pats) ), (l,())) @@ -781,7 +781,7 @@ let rec to_ast_mpat k_env def_ord (Parse_ast.MP_aux(mpat,l)) = | Parse_ast.MP_tup(mpats) -> MP_tup(List.map (to_ast_mpat k_env def_ord) mpats) | Parse_ast.MP_list(mpats) -> MP_list(List.map (to_ast_mpat k_env def_ord) mpats) | Parse_ast.MP_cons(pat1, pat2) -> MP_cons (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) - | Parse_ast.MP_string_append (pat1, pat2) -> MP_string_append (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) + | Parse_ast.MP_string_append pats -> MP_string_append (List.map (to_ast_mpat k_env def_ord) pats) | Parse_ast.MP_typ (mpat, typ) -> MP_typ (to_ast_mpat k_env def_ord mpat, to_ast_typ k_env def_ord typ) ), (l,())) diff --git a/src/parse_ast.ml b/src/parse_ast.ml index e59dd356..b34ba1d2 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -252,7 +252,7 @@ pat_aux = (* Pattern *) | P_tup of (pat) list (* tuple pattern *) | P_list of (pat) list (* list pattern *) | P_cons of pat * pat (* cons pattern *) - | P_string_append of pat * pat (* string append pattern, x ^^ y *) + | P_string_append of pat list (* string append pattern, x ^^ y *) and pat = P_aux of pat_aux * l @@ -430,7 +430,7 @@ type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only | MP_tup of ( mpat) list | MP_list of ( mpat) list | MP_cons of ( mpat) * ( mpat) - | MP_string_append of ( mpat) * ( mpat) + | MP_string_append of mpat list | MP_typ of mpat * atyp and mpat = diff --git a/src/parser.mly b/src/parser.mly index d41964b7..e1c6bd12 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -653,6 +653,12 @@ typschm_eof: | typschm Eof { $1 } +pat_string_append: + | atomic_pat + { [$1] } + | atomic_pat CaretCaret pat_string_append + { $1 :: $3 } + pat1: | atomic_pat { $1 } @@ -660,8 +666,8 @@ pat1: { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_pat ColonColon pat1 { mk_pat (P_cons ($1, $3)) $startpos $endpos } - | atomic_pat CaretCaret pat1 - { mk_pat (P_string_append ($1, $3)) $startpos $endpos } + | atomic_pat CaretCaret pat_string_append + { mk_pat (P_string_append ($1 :: $3)) $startpos $endpos } pat_concat: | atomic_pat @@ -1202,6 +1208,12 @@ fun_def_list: | fun_def fun_def_list { $1 :: $2 } +mpat_string_append: + | atomic_mpat + { [$1] } + | atomic_mpat CaretCaret mpat_string_append + { $1 :: $3 } + mpat: | atomic_mpat { $1 } @@ -1209,8 +1221,8 @@ mpat: { mk_mpat (MP_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_mpat ColonColon mpat { mk_mpat (MP_cons ($1, $3)) $startpos $endpos } - | atomic_mpat CaretCaret mpat - { mk_mpat (MP_string_append ($1, $3)) $startpos $endpos } + | atomic_mpat CaretCaret mpat_string_append + { mk_mpat (MP_string_append ($1 :: $3)) $startpos $endpos } mpat_concat: | atomic_mpat diff --git a/src/pattern_completeness.ml b/src/pattern_completeness.ml index 3797354c..2372ea82 100644 --- a/src/pattern_completeness.ml +++ b/src/pattern_completeness.ml @@ -68,7 +68,7 @@ type gpat = | GP_cons of gpat * gpat | GP_app of (gpat Bindings.t) | GP_record of (gpat Bindings.t) - | GP_string_append of gpat * gpat + | GP_string_append of gpat list let rec string_of_gpat = function | GP_lit lit -> string_of_lit lit @@ -81,7 +81,7 @@ let rec string_of_gpat = function | GP_app app -> Util.string_of_list "|" (fun (id, gpat) -> string_of_id id ^ string_of_gpat gpat) (Bindings.bindings app) | GP_record _ -> "GP RECORD" - | GP_string_append (gpat1, gpat2) -> string_of_gpat gpat1 ^ " ^^" ^ string_of_gpat gpat2 + | GP_string_append gpats -> Util.string_of_list " ^^ " string_of_gpat gpats let is_wild = function | GP_wild -> true @@ -119,10 +119,9 @@ let rec generalize ctx (P_aux (p_aux, _) as pat) = let ghd_pat = generalize ctx hd_pat in let gtl_pat = generalize ctx tl_pat in if is_wild ghd_pat && is_wild gtl_pat then GP_wild else GP_cons (ghd_pat, gtl_pat) - | P_string_append (pat1, pat2) -> - let gpat1 = generalize ctx pat1 in - let gpat2 = generalize ctx pat2 in - if is_wild gpat1 && is_wild gpat2 then GP_wild else GP_string_append (gpat1, gpat2) + | P_string_append pats -> + let gpats = List.map (generalize ctx) pats in + if List.for_all is_wild gpats then GP_wild else GP_string_append gpats | P_app (f, pats) -> let gpats = List.map (generalize ctx) pats in if List.for_all is_wild gpats then diff --git a/src/rewriter.ml b/src/rewriter.ml index 74d9f40d..08c90803 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -304,7 +304,7 @@ let rewrite_pat rewriters (P_aux (pat,(l,annot)) as orig_pat) = | P_tup pats -> rewrap (P_tup (List.map rewrite pats)) | P_list pats -> rewrap (P_list (List.map rewrite pats)) | P_cons (pat1, pat2) -> rewrap (P_cons (rewrite pat1, rewrite pat2)) - | P_string_append (pat1, pat2) -> rewrap (P_string_append (rewrite pat1, rewrite pat2)) + | P_string_append pats -> rewrap (P_string_append (List.map rewrite pats)) let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = let rewrap e = E_aux (e,(l,annot)) in @@ -453,7 +453,7 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux ; p_cons : 'pat * 'pat -> 'pat_aux - ; p_string_append : 'pat * 'pat -> 'pat_aux + ; p_string_append : 'pat list -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux @@ -474,7 +474,7 @@ let rec fold_pat_aux (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat | P_tup ps -> alg.p_tup (List.map (fold_pat alg) ps) | P_list ps -> alg.p_list (List.map (fold_pat alg) ps) | P_cons (ph,pt) -> alg.p_cons (fold_pat alg ph, fold_pat alg pt) - | P_string_append (p1, p2) -> alg.p_string_append (fold_pat alg p1, fold_pat alg p2) + | P_string_append ps -> alg.p_string_append (List.map (fold_pat alg) ps) and fold_pat (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat -> 'pat = function @@ -501,7 +501,7 @@ let id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg = ; p_tup = (fun ps -> P_tup ps) ; p_list = (fun ps -> P_list ps) ; p_cons = (fun (ph,pt) -> P_cons (ph,pt)) - ; p_string_append = (fun (p1,p2) -> P_string_append (p1,p2)) + ; p_string_append = (fun (ps) -> P_string_append (ps)) ; p_aux = (fun (pat,annot) -> P_aux (pat,annot)) ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) ; fP_Fpat = (fun (id,pat) -> FP_Fpat (id,pat)) @@ -748,7 +748,7 @@ let compute_pat_alg bot join = ; p_tup = split_join (fun ps -> P_tup ps) ; p_list = split_join (fun ps -> P_list ps) ; p_cons = (fun ((vh,ph),(vt,pt)) -> (join vh vt, P_cons (ph,pt))) - ; p_string_append = (fun ((v1,p1),(v2,p2)) -> (join v1 v2, P_string_append (p1,p2))) + ; p_string_append = split_join (fun ps -> P_string_append ps) ; p_aux = (fun ((v,pat),annot) -> (v, P_aux (pat,annot))) ; fP_aux = (fun ((v,fpat),annot) -> (v, FP_aux (fpat,annot))) ; fP_Fpat = (fun (id,(v,pat)) -> (v, FP_Fpat (id,pat))) diff --git a/src/rewriter.mli b/src/rewriter.mli index 70c894c4..90c15b16 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -95,7 +95,7 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux ; p_cons : 'pat * 'pat -> 'pat_aux - ; p_string_append : 'pat * 'pat -> 'pat_aux + ; p_string_append : 'pat list -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux diff --git a/src/rewrites.ml b/src/rewrites.ml index ac36dffa..e9afd415 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -676,7 +676,7 @@ let remove_vector_concat_pat pat = ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_string_append = (fun (p1,p2) -> P_string_append (p1 false, p2 false)) + ; p_string_append = (fun (ps) -> P_string_append (List.map (fun p -> p false) ps)) ; p_aux = (fun (pat,((l,_) as annot)) contained_in_p_as -> match pat with @@ -819,8 +819,9 @@ let remove_vector_concat_pat pat = (P_tup ps,List.flatten decls)) ; p_list = (fun ps -> let (ps,decls) = List.split ps in (P_list ps,List.flatten decls)) + ; p_string_append = (fun ps -> let (ps,decls) = List.split ps in + (P_string_append ps,List.flatten decls)) ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) - ; p_string_append = (fun ((p1,decls1),(p2,decls2)) -> (P_string_append (p1,p2), decls1 @ decls2)) ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) @@ -1074,7 +1075,7 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) = | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) - | P_string_append (p,ps) -> raise (Reporting_basic.err_unreachable l + | P_string_append (ps) -> raise (Reporting_basic.err_unreachable l "pat_to_exp not implemented for P_string_append") and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) @@ -1164,7 +1165,7 @@ let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with | P_app (_,pats) | P_tup pats | P_list pats -> List.exists contains_bitvector_pat pats | P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps -| P_string_append (p1,p2) -> contains_bitvector_pat p1 || contains_bitvector_pat p2 +| P_string_append (ps) -> List.exists contains_bitvector_pat ps | P_record (fpats,_) -> List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats @@ -1190,10 +1191,10 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = ; p_record = (fun (fpats,b) -> P_record (fpats, b)) ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_string_append = (fun ps -> P_string_append (List.map (fun p -> p false) ps)) ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_string_append = (fun (p1,p2) -> P_string_append (p1 false, p2 false)) ; p_aux = (fun (pat,annot) contained_in_p_as -> let env = env_of_annot annot in @@ -1342,14 +1343,14 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = (P_vector ps, flatten_guards_decls gdls)) ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in (P_vector_concat ps, flatten_guards_decls gdls)) + ; p_string_append = (fun ps -> let (ps,gdls) = List.split ps in + (P_string_append ps, flatten_guards_decls gdls)) ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in (P_tup ps, flatten_guards_decls gdls)) ; p_list = (fun ps -> let (ps,gdls) = List.split ps in (P_list ps, flatten_guards_decls gdls)) ; p_cons = (fun ((p,gdls),(p',gdls')) -> (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) - ; p_string_append = (fun ((p1,gdls1),(p2,gdls2)) -> - (P_string_append (p1,p2), flatten_guards_decls [gdls1;gdls2])) ; p_aux = (fun ((pat,gdls),annot) -> let env = env_of_annot annot in let t = Env.base_typ_of env (typ_of_annot annot) in @@ -2841,10 +2842,6 @@ let rec rewrite_defs_pat_string_append = let rec rewrite_pat (pat, guards, expr) = match pat with - (* (pat1 ^^ pat2) ^^ pat3 => expr ---> pat1 ^^ (pat2 ^^ pat3) => expr and recurse *) - | P_aux (P_string_append (P_aux (P_string_append (pat1, pat2), _), pat3), _) -> - let new_pat = mk_pat (P_string_append (pat1, mk_pat (P_string_append (pat2, pat3)))) in - rewrite_pat (new_pat, guards, expr) (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") && match str_drop(s#, strlen("lit")) { @@ -2854,7 +2851,7 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_aux (P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _), pat2), _) -> + | P_aux (P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _) :: pats), psa_annot) -> let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in stringappend_counter := !stringappend_counter + 1; @@ -2864,7 +2861,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (pat2, guards, expr) with + match rewrite_pat (P_aux (P_string_append (pats), psa_annot), guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -2894,7 +2891,7 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_aux (P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _), pat2), _) + | P_aux (P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) :: pats), psa_annot) when List.mem_assoc builtin_id builtins -> (* common things *) @@ -2914,7 +2911,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (pat2, guards, expr) with + match rewrite_pat (P_aux (P_string_append (pats), psa_annot), guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -2943,6 +2940,8 @@ let rec rewrite_defs_pat_string_append = (* construct final result *) mk_pat (P_id s_id), new_guard :: guards, new_let + | P_aux (P_string_append [], _) -> + mk_pat (P_lit (mk_lit (L_string ""))), guards, expr | P_aux (P_string_append _, _) -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat pat) @@ -3493,6 +3492,10 @@ let rec exp_of_mpat (MP_aux (mpat, annot)) = let concat_vectors annot vec1 vec2 = (* TODO FIXME, this should be OK for typing but doesn't attach location information properly *) E_aux (E_vector_append (vec1, vec2), annot) in + let empty_string = E_aux (E_lit (L_aux (L_string "", Parse_ast.Unknown)), annot) in + let string_append annot str1 str2 = + E_aux (E_app (mk_id "string_append", [str1; str2]), annot) + in match mpat with | MP_lit lit -> E_aux (E_lit lit, annot) | MP_id id -> E_aux (E_id id, annot) @@ -3503,7 +3506,7 @@ let rec exp_of_mpat (MP_aux (mpat, annot)) = | MP_tup mpats -> E_aux (E_tuple (List.map exp_of_mpat mpats), annot) | MP_list mpats -> E_aux (E_list (List.map exp_of_mpat mpats), annot) | MP_cons (mpat1, mpat2) -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), annot) - | MP_string_append (mpat1, mpat2) -> E_aux (E_app (mk_id "string_append", [exp_of_mpat mpat1; exp_of_mpat mpat2]), annot) + | MP_string_append mpats -> List.fold_right (string_append annot) (List.map exp_of_mpat mpats) empty_string | MP_typ (mpat, typ) -> E_aux (E_cast (typ, exp_of_mpat mpat), annot) and fexps_of_mfpats mfpats flag annot = @@ -3523,7 +3526,7 @@ let rec pat_of_mpat (MP_aux (mpat, annot)) = | MP_tup mpats -> P_aux (P_tup (List.map pat_of_mpat mpats), annot) | MP_list mpats -> P_aux (P_list (List.map pat_of_mpat mpats), annot) | MP_cons (mpat1, mpat2) -> P_aux ((P_cons (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) - | MP_string_append (mpat1, mpat2) -> P_aux ((P_string_append (pat_of_mpat mpat1, pat_of_mpat mpat2), annot)) + | MP_string_append (mpats) -> P_aux ((P_string_append (List.map pat_of_mpat mpats), annot)) | MP_typ (mpat, typ) -> P_aux (P_typ (typ, pat_of_mpat mpat), annot) and fpats_of_mfpats mfpats = diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 2f5d1d15..134a3e77 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -3,7 +3,7 @@ module Big_int = Nat_big_num type 'a return = { return : 'b . 'a -> 'b } type 'za zoption = | ZNone of unit | ZSome of 'za;; -let zint_forwardsz3 _ = assert false +let zint_forwardsz3 i = string_of_int (Big_int.to_int i) let opt_trace = ref false diff --git a/src/type_check.ml b/src/type_check.ml index f683feee..07aa199a 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2645,14 +2645,19 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) annot_pat (P_cons (hd_pat, tl_pat)) typ, env, hd_guards @ tl_guards | _ -> typ_error l "Cannot match cons pattern against non-list type" end - | P_string_append (pat1, pat2) -> + | P_string_append pats -> begin - let matcher = Env.expand_synonyms env typ in - match matcher with + match Env.expand_synonyms env typ with | Typ_aux (Typ_id id, _) when Id.compare id (mk_id "string") = 0 -> - let pat1, env, guards1 = bind_pat env pat1 typ in - let pat2, env, guards2 = bind_pat env pat2 typ in - annot_pat (P_string_append (pat1, pat2)) typ, env, guards1 @ guards2 + let rec process_pats env = function + | [] -> [], env, [] + | pat :: pats -> + let pat', env, guards = bind_pat env pat typ in + let pats', env, guards' = process_pats env pats in + pat' :: pats', env, guards @ guards' + in + let pats, env, guards = process_pats env pats in + annot_pat (P_string_append pats) typ, env, guards | _ -> typ_error l "Cannot match string-append pattern against non-string type" end | P_list pats -> @@ -2835,12 +2840,16 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = in let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_pats)) in annot_pat (P_vector_concat inferred_pats) (dvector_typ env len vtyp), env, guards - | P_string_append (pat1, pat2) -> - let typed_pat1, env, guards1 = infer_pat env pat1 in - let typed_pat2, env, guards2 = infer_pat env pat2 in - typ_equality l env (pat_typ_of typed_pat1) (string_typ); - typ_equality l env (pat_typ_of typed_pat2) (string_typ); - annot_pat (P_string_append (typed_pat1, typed_pat2)) string_typ, env, guards1 @ guards2 + | P_string_append pats -> + let fold_pats (pats, env, guards) pat = + let inferred_pat, env, guards' = infer_pat env pat in + typ_equality l env (pat_typ_of inferred_pat) string_typ; + pats @ [inferred_pat], env, guards' @ guards + in + let typed_pats, env, guards = + List.fold_left fold_pats ([], env, []) pats + in + annot_pat (P_string_append typed_pats) string_typ, env, guards | P_as (pat, id) -> let (typed_pat, env, guards) = infer_pat env pat in annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), @@ -3495,15 +3504,20 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as annot_mpat (MP_cons (hd_mpat, tl_mpat)) typ, env, hd_guards @ tl_guards | _ -> typ_error l "Cannot match cons mapping-pattern against non-list type" end - | MP_string_append (mpat1, mpat2) -> + | MP_string_append mpats -> begin - let matcher = Env.expand_synonyms env typ in - match matcher with + match Env.expand_synonyms env typ with | Typ_aux (Typ_id id, _) when Id.compare id (mk_id "string") = 0 -> - let mpat1, env, guards1 = bind_mpat env mpat1 typ in - let mpat2, env, guards2 = bind_mpat env mpat2 typ in - annot_mpat (MP_string_append (mpat1, mpat2)) typ, env, guards1 @ guards2 - | _ -> typ_error l "Cannot match string-append mapping-pattern against non-string type" + let rec process_mpats env = function + | [] -> [], env, [] + | pat :: pats -> + let pat', env, guards = bind_mpat env pat typ in + let pats', env, guards' = process_mpats env pats in + pat' :: pats', env, guards @ guards' + in + let pats, env, guards = process_mpats env mpats in + annot_mpat (MP_string_append pats) typ, env, guards + | _ -> typ_error l "Cannot match string-append pattern against non-string type" end | MP_list mpats -> begin @@ -3661,12 +3675,17 @@ and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = in let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_mpats)) in annot_mpat (MP_vector_concat inferred_mpats) (dvector_typ env len vtyp), env, guards - | MP_string_append (mpat1, mpat2) -> - let typed_mpat1, env, guards1 = infer_mpat env mpat1 in - let typed_mpat2, env, guards2 = infer_mpat env mpat2 in - typ_equality l env (typ_of_mpat typed_mpat1) (string_typ); - typ_equality l env (typ_of_mpat typed_mpat2) (string_typ); - annot_mpat (MP_string_append (typed_mpat1, typed_mpat2)) string_typ, env, guards1 @ guards2 + | MP_string_append mpats -> + let fold_pats (pats, env, guards) pat = + let inferred_pat, env, guards' = infer_mpat env pat in + typ_equality l env (typ_of_mpat inferred_pat) string_typ; + pats @ [inferred_pat], env, guards' @ guards + in + let typed_mpats, env, guards = + List.fold_left fold_pats ([], env, []) mpats + in + annot_mpat (MP_string_append typed_mpats) string_typ, env, guards + | _ -> typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) (**************************************************************************) @@ -3909,10 +3928,9 @@ and propagate_pat_effect_aux = function let p_pat1 = propagate_pat_effect pat1 in let p_pat2 = propagate_pat_effect pat2 in P_cons (p_pat1, p_pat2), union_effects (effect_of_pat p_pat1) (effect_of_pat p_pat2) - | P_string_append (pat1, pat2) -> - let p_pat1 = propagate_pat_effect pat1 in - let p_pat2 = propagate_pat_effect pat2 in - P_string_append (p_pat1, p_pat2), union_effects (effect_of_pat p_pat1) (effect_of_pat p_pat2) + | P_string_append pats -> + let p_pats = List.map propagate_pat_effect pats in + P_string_append p_pats, collect_effects_pat p_pats | P_as (pat, id) -> let p_pat = propagate_pat_effect pat in P_as (p_pat, id), effect_of_pat p_pat @@ -3949,10 +3967,9 @@ and propagate_mpat_effect_aux = function let p_mpat1 = propagate_mpat_effect mpat1 in let p_mpat2 = propagate_mpat_effect mpat2 in MP_cons (p_mpat1, p_mpat2), union_effects (effect_of_mpat p_mpat1) (effect_of_mpat p_mpat2) - | MP_string_append (mpat1, mpat2) -> - let p_mpat1 = propagate_mpat_effect mpat1 in - let p_mpat2 = propagate_mpat_effect mpat2 in - MP_string_append (p_mpat1, p_mpat2), union_effects (effect_of_mpat p_mpat1) (effect_of_mpat p_mpat2) + | MP_string_append mpats -> + let p_mpats = List.map propagate_mpat_effect mpats in + MP_string_append p_mpats, collect_effects_mpat p_mpats | MP_id id -> MP_id id, no_effect | MP_app (id, mpats) -> let p_mpats = List.map propagate_mpat_effect mpats in -- cgit v1.2.3 From 9a7ecdf30403c78f1719582aa3113a5916017880 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 2 May 2018 12:14:09 +0100 Subject: re-indent to_ast_def --- src/initial_check.ml | 160 +++++++++++++++++++++++++-------------------------- 1 file changed, 80 insertions(+), 80 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index 5df6b825..6f131e63 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -855,99 +855,99 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_fixity (prec, n, op) -> ((Finished(DEF_fixity (to_ast_prec prec, n, to_ast_id op)),envs),partial_defs) | Parse_ast.DEF_kind(k_def) -> - let kd,envs = to_ast_kdef envs k_def in - ((Finished(DEF_kind(kd))),envs),partial_defs + let kd,envs = to_ast_kdef envs k_def in + ((Finished(DEF_kind(kd))),envs),partial_defs | Parse_ast.DEF_type(t_def) -> - let td,envs = to_ast_typedef envs t_def in - ((Finished(DEF_type(td))),envs),partial_defs + let td,envs = to_ast_typedef envs t_def in + ((Finished(DEF_type(td))),envs),partial_defs | Parse_ast.DEF_fundef(f_def) -> - let fd,envs = to_ast_fundef envs f_def in - ((Finished(DEF_fundef(fd))),envs),partial_defs + let fd,envs = to_ast_fundef envs f_def in + ((Finished(DEF_fundef(fd))),envs),partial_defs | Parse_ast.DEF_mapdef(m_def) -> - let md, envs = to_ast_mapdef envs m_def in - ((Finished(DEF_mapdef(md))),envs),partial_defs + let md, envs = to_ast_mapdef envs m_def in + ((Finished(DEF_mapdef(md))),envs),partial_defs | Parse_ast.DEF_val(lbind) -> - let lb = to_ast_letbind k_env def_ord lbind in - ((Finished(DEF_val(lb))),envs),partial_defs + let lb = to_ast_letbind k_env def_ord lbind in + ((Finished(DEF_val(lb))),envs),partial_defs | Parse_ast.DEF_spec(val_spec) -> - let vs,envs = to_ast_spec envs val_spec in - ((Finished(DEF_spec(vs))),envs),partial_defs + let vs,envs = to_ast_spec envs val_spec in + ((Finished(DEF_spec(vs))),envs),partial_defs | Parse_ast.DEF_default(typ_spec) -> - let default,envs = to_ast_default envs typ_spec in - ((Finished(DEF_default(default))),envs),partial_defs + let default,envs = to_ast_default envs typ_spec in + ((Finished(DEF_default(default))),envs),partial_defs | Parse_ast.DEF_reg_dec(dec) -> - let d = to_ast_dec envs dec in - ((Finished(DEF_reg_dec(d))),envs),partial_defs + let d = to_ast_dec envs dec in + ((Finished(DEF_reg_dec(d))),envs),partial_defs | Parse_ast.DEF_pragma (_, _, l) -> typ_error l "Encountered preprocessor directive in initial check" None None None | Parse_ast.DEF_internal_mutrec _ -> (* Should never occur because of remove_mutrec *) typ_error Parse_ast.Unknown "Internal mutual block found when processing scattered defs" None None None | Parse_ast.DEF_scattered(Parse_ast.SD_aux(sd,l)) -> - (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 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,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) -> - (match funcl with - | Parse_ast.FCL_aux(Parse_ast.FCL_Funcl(id,_),_) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered function definition clause does not match any existing function definition headers" (Some id) None None - | Some(d,k) -> - (* let _ = Printf.eprintf "SD_scattered_funcl processing\n" in - let _ = Envmap.iter (fun v' k -> Printf.eprintf "%s -> %s\n" v' (kind_to_string k)) k in - let _ = Envmap.iter (fun v' k -> Printf.eprintf "%s -> %s\n" v' (kind_to_string k) ) (Envmap.union k k_env) in *) - (match !d with - | DEF_fundef(FD_aux(FD_function(r,t,e,fcls),fl)),false -> - let (FCL_aux (funcl_aux, _)) = to_ast_funcl (names,Envmap.union k k_env,def_ord) funcl in - d:= DEF_fundef(FD_aux(FD_function(r,t,e,fcls@[FCL_aux (funcl_aux, (l, ()))]),fl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered function definition clauses extends ended definition" (Some id) None None - | _ -> typ_error l "Scattered function definition clause matches an existing scattered type definition header" (Some id) None None))) - | Parse_ast.SD_scattered_variant(id,naming_scheme_opt,typquant) -> - let id = to_ast_id id in - let name = to_ast_namescm naming_scheme_opt in - let typq, k_env',_ = to_ast_typquant k_env typquant in - let kind = (match (typquant_to_quantkinds k_env' typq) with - | [ ] -> {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,())))),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) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered type definition clause does not match any existing type definition headers" (Some id) None None - | Some(d,k) -> - (match !d with - | DEF_type(TD_aux(TD_variant(id,name,typq,arms,false),tl)), false -> - d:= DEF_type(TD_aux(TD_variant(id,name,typq,arms@[to_ast_type_union k def_ord tu],false),tl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered type definition clause extends ended definition" (Some id) None None - | _ -> typ_error l "Scattered type definition clause matches an existing scattered function definition header" (Some id) None None)) - | Parse_ast.SD_scattered_end(id) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered definition end does not match any open scattered definitions" (Some id) None None - | Some(d,k) -> - (match !d with - | (DEF_type(_) as def),false -> - d:= (def,true); - (No_def,envs),partial_defs - | (DEF_fundef(_) as def),false -> - d:= (def,true); - ((Finished def), envs),partial_defs - | _, true -> - typ_error l "Scattered definition ended multiple times" (Some id) None None - | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) + (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 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,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) -> + (match funcl with + | Parse_ast.FCL_aux(Parse_ast.FCL_Funcl(id,_),_) -> + let id = to_ast_id id in + (match (def_in_progress id partial_defs) with + | None -> typ_error l "Scattered function definition clause does not match any existing function definition headers" (Some id) None None + | Some(d,k) -> + (* let _ = Printf.eprintf "SD_scattered_funcl processing\n" in + let _ = Envmap.iter (fun v' k -> P rintf.eprintf "%s -> %s\n" v' (kind_to_string k)) k in + let _ = Envmap.iter (fun v' k -> Prin tf.eprintf "%s -> %s\n" v' (kind_to_string k) ) (Envmap.union k k_env) in *) + (match !d with + | DEF_fundef(FD_aux(FD_function(r,t,e,fcls),fl)),false -> + let (FCL_aux (funcl_aux, _)) = to_ast_funcl (names,Envmap.union k k_env,def_ord) funcl in + d:= DEF_fundef(FD_aux(FD_function(r,t,e,fcls@[FCL_aux (funcl_aux, (l, ()))]),fl)),false; + (No_def,envs),partial_defs + | _,true -> typ_error l "Scattered function definition clauses extends ended definition" (Some id) None None + | _ -> typ_error l "Scattered function definition clause matches an existing scattered type definition header" (Some id) None None))) + | Parse_ast.SD_scattered_variant(id,naming_scheme_opt,typquant) -> + let id = to_ast_id id in + let name = to_ast_namescm naming_scheme_opt in + let typq, k_env',_ = to_ast_typquant k_env typquant in + let kind = (match (typquant_to_quantkinds k_env' typq) with + | [ ] -> {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,())))),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) -> + let id = to_ast_id id in + (match (def_in_progress id partial_defs) with + | None -> typ_error l "Scattered type definition clause does not match any existing type definition headers" (Some id) None None + | Some(d,k) -> + (match !d with + | DEF_type(TD_aux(TD_variant(id,name,typq,arms,false),tl)), false -> + d:= DEF_type(TD_aux(TD_variant(id,name,typq,arms@[to_ast_type_union k def_ord tu],false),tl)),false; + (No_def,envs),partial_defs + | _,true -> typ_error l "Scattered type definition clause extends ended definition" (Some id) None None + | _ -> typ_error l "Scattered type definition clause matches an existing scattered function definition header" (Some id) None None)) + | Parse_ast.SD_scattered_end(id) -> + let id = to_ast_id id in + (match (def_in_progress id partial_defs) with + | None -> typ_error l "Scattered definition end does not match any open scattered definitions" (Some id) None None + | Some(d,k) -> + (match !d with + | (DEF_type(_) as def),false -> + d:= (def,true); + (No_def,envs),partial_defs + | (DEF_fundef(_) as def),false -> + d:= (def,true); + ((Finished def), envs),partial_defs + | _, true -> + typ_error l "Scattered definition ended multiple times" (Some id) None None + | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) let rec to_ast_defs_helper envs partial_defs = function | [] -> ([],envs,partial_defs) -- cgit v1.2.3 From c881247cfc2af299e76064f28f1198e64029ea57 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 2 May 2018 12:31:19 +0100 Subject: scattered mappings --- src/initial_check.ml | 24 ++++++++++++++++++++++++ src/parse_ast.ml | 2 ++ src/parser.mly | 5 +++++ src/rewrites.ml | 10 ++++++++-- 4 files changed, 39 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index 6f131e63..51820b29 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -894,6 +894,27 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | 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_mapping id -> + let id = to_ast_id id in + let _,_,k_local = to_ast_tannot_opt k_env def_ord (Parse_ast.Typ_annot_opt_aux (Parse_ast.Typ_annot_opt_none, Parse_ast.Unknown)) in + (match (def_in_progress id partial_defs) with + | None -> let partial_def = ref ((DEF_mapdef(MD_aux(MD_mapping(id, []), (l, ())))), false) in + (No_def,envs),((id,(partial_def,k_local))::partial_defs) + | Some(d,k) -> typ_error l "Scattered mapping definition header name already in use by scattered definition" (Some id) None None) + + | Parse_ast.SD_scattered_mapcl (id, mapcl) -> + let id = to_ast_id id in + (match (def_in_progress id partial_defs) with + | None -> typ_error l "Scattered mapping definition clause does not match any existing mapping definition headers" (Some id) None None + | Some (d, k) -> + (match !d with + | DEF_mapdef(MD_aux(MD_mapping(_,mcls),ml)),false -> + let (MCL_aux (mapcl_aux, _)) = to_ast_mapcl (names,k_env,def_ord) mapcl in + d := DEF_mapdef(MD_aux(MD_mapping(id, mcls @ [MCL_aux (mapcl_aux, (l, ()))]), ml)), false; + (No_def,envs),partial_defs + | _, true -> typ_error l "Scattered mapping definition clause extends ended definition" (Some id) None None + | _ -> typ_error l "Scattered mapping definition doesn't match existing definition header" (Some id) None None)) + | Parse_ast.SD_scattered_funcl(funcl) -> (match funcl with | Parse_ast.FCL_aux(Parse_ast.FCL_Funcl(id,_),_) -> @@ -945,6 +966,9 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | (DEF_fundef(_) as def),false -> d:= (def,true); ((Finished def), envs),partial_defs + | (DEF_mapdef(_) as def),false -> + d := (def,true); + ((Finished def), envs),partial_defs | _, true -> typ_error l "Scattered definition ended multiple times" (Some id) None None | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) diff --git a/src/parse_ast.ml b/src/parse_ast.ml index b34ba1d2..a6b519e5 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -498,6 +498,8 @@ scattered_def_aux = (* Function and type union definitions that can be spread a | SD_scattered_funcl of funcl (* scattered function definition clause *) | SD_scattered_variant of id * name_scm_opt * typquant (* scattered union definition header *) | SD_scattered_unioncl of id * type_union (* scattered union definition member *) + | SD_scattered_mapping of id + | SD_scattered_mapcl of id * mapcl | SD_scattered_end of id (* scattered definition end *) diff --git a/src/parser.mly b/src/parser.mly index e1c6bd12..23516068 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1327,6 +1327,8 @@ scattered_def: { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } | Function_ id { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } + | Mapping id + { mk_sd (SD_scattered_mapping $2) $startpos $endpos } scattered_clause: | Doc Function_ Clause funcl @@ -1334,6 +1336,7 @@ scattered_clause: | Function_ Clause funcl { mk_sd (SD_scattered_funcl $3) $startpos $endpos } + def: | fun_def { DEF_fundef $1 } @@ -1359,6 +1362,8 @@ def: { DEF_scattered $1 } | Union Clause id Eq type_union { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } + | Mapping Clause id Eq mapcl + { DEF_scattered (mk_sd (SD_scattered_mapcl ($3, $5)) $startpos $endpos) } | End id { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } | default_def diff --git a/src/rewrites.ml b/src/rewrites.ml index e9afd415..69d35da6 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2851,7 +2851,10 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_aux (P_string_append (P_aux (P_lit (L_aux (L_string s, _) as lit), _) :: pats), psa_annot) -> + | P_aux (P_string_append ( + P_aux (P_lit (L_aux (L_string s, _) as lit), _) + :: pats + ), psa_annot) -> let id = mk_id ("_stringappend_" ^ (string_of_int !stringappend_counter) ^ "#") in stringappend_counter := !stringappend_counter + 1; @@ -2891,7 +2894,10 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_aux (P_string_append (P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) :: pats), psa_annot) + | P_aux (P_string_append ( + P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) + :: pats + ), psa_annot) when List.mem_assoc builtin_id builtins -> (* common things *) -- cgit v1.2.3 From 53601042801863c2fe856563380714d2fec57f93 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 3 May 2018 14:47:34 +0100 Subject: synthesise string-prefix-check functions for mappings where either side is string (kind of hacky but there you go) --- src/rewrites.ml | 104 +++++++++++++++++++++++++++++++++++++++++++++-------- src/type_check.ml | 2 ++ src/type_check.mli | 2 ++ 3 files changed, 94 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 69d35da6..68c4002d 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3557,13 +3557,34 @@ let rewrite_defs_realise_mappings (Defs defs) = | MPat_aux (MPat_when (mpat, guard), annot) -> Pat_aux (Pat_when (pat_of_mpat mpat, guard, exp), annot) in let realise_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = - let pexp = realise_mpexps forwards mpexp1 mpexp2 in - pexp - (* FCL_aux (FCL_Funcl (id, pexp), (l, ())) *) + realise_mpexps forwards mpexp1 mpexp2 + in + let realise_bool_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = + let mpexp = if forwards then mpexp1 else mpexp2 in + realise_mpexps true mpexp (mk_mpexp (MPat_pat (mk_mpat (MP_lit (mk_lit L_true))))) + in + let placeholder_id = mk_id "s#" in + let append_placeholder = function + | MPat_aux (MPat_pat (MP_aux (MP_string_append mpats, p_annot)), aux_annot) -> + MPat_aux (MPat_pat (MP_aux (MP_string_append (mpats @ [mk_mpat (MP_id placeholder_id)]), p_annot)), aux_annot) + | MPat_aux (MPat_when (MP_aux (MP_string_append mpats, p_annot), guard), aux_annot) -> + MPat_aux (MPat_when (MP_aux (MP_string_append (mpats @ [mk_mpat (MP_id placeholder_id)]), p_annot), guard), aux_annot) + | MPat_aux (MPat_pat mpat, aux_annot) -> + MPat_aux (MPat_pat (mk_mpat (MP_string_append [mpat; mk_mpat (MP_id placeholder_id)])), aux_annot) + | MPat_aux (MPat_when (mpat, guard), aux_annot) -> + MPat_aux (MPat_when (mk_mpat (MP_string_append [mpat; mk_mpat (MP_id placeholder_id)]), guard), aux_annot) + in + let realise_prefix_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = + let mpexp = if forwards then mpexp1 else mpexp2 in + let strlen = (mk_mpat (MP_app ( mk_id "string_length" , [mk_mpat (MP_id placeholder_id)]))) in + realise_mpexps true (append_placeholder mpexp) (mk_mpexp (MPat_pat (mk_mpat (MP_app ((mk_id "Some"), [strlen]))))) in let realise_mapdef (MD_aux (MD_mapping (id, mapcls), ((l, (tannot:tannot)) as annot))) = - let forwards_id = mk_id (string_of_id id ^ "_forwards#") in - let backwards_id = mk_id (string_of_id id ^ "_backwards#") in + let forwards_id = mk_id (string_of_id id ^ "_forwards") in + let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in + let backwards_id = mk_id (string_of_id id ^ "_backwards") in + let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in + let non_rec = (Rec_aux (Rec_nonrec, Parse_ast.Unknown)) in let effect_pure = (Effect_opt_aux (Effect_opt_pure, Parse_ast.Unknown)) in let env = match mapcls with @@ -3571,30 +3592,85 @@ let rewrite_defs_realise_mappings (Defs defs) = | _ -> Type_check.typ_error l "mapping with no clauses?" in let (typq, bidir_typ) = Env.get_val_spec id env in - let forwards_typ = match bidir_typ with - | Typ_aux (Typ_bidir (typ1, typ2), l) -> Typ_aux (Typ_fn (typ1, typ2, no_effect), l) - | _ -> Type_check.typ_error l "non-bidir type of mapping?" - in - let backwards_typ = match bidir_typ with - | Typ_aux (Typ_bidir (typ1, typ2), l) -> Typ_aux (Typ_fn (typ2, typ1, no_effect), l) + let (typ1, typ2, l) = match bidir_typ with + | Typ_aux (Typ_bidir (typ1, typ2), l) -> typ1, typ2, l | _ -> Type_check.typ_error l "non-bidir type of mapping?" in + let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), l) in + let forwards_matches_typ = Typ_aux (Typ_fn (typ1, bool_typ, no_effect), l) in + let backwards_typ = Typ_aux (Typ_fn (typ2, typ1, no_effect), l) in + let backwards_matches_typ = Typ_aux (Typ_fn (typ2, bool_typ, no_effect), l) in + let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let forwards_spec, env = Type_check.check_val_spec env forwards_spec in let backwards_spec, env = Type_check.check_val_spec env backwards_spec in + let forwards_matches_spec, env = Type_check.check_val_spec env forwards_matches_spec in + let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in + let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in let arg_exp = (mk_exp (E_id (mk_id "arg#"))) in let arg_pat = mk_pat (P_id (mk_id "arg#")) in let forwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls))) in let backwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl false backwards_id) mapcls))) in - let forwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl forwards_id arg_pat forwards_match]), (l, ()))) in - let backwards_fun : unit fundef = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl backwards_id arg_pat backwards_match]), (l, ()))) in + + let wildcard = mk_pexp (Pat_exp (mk_pat P_wild, mk_exp (E_lit (mk_lit L_false)))) in + let forwards_matches_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_bool_mapcl true forwards_matches_id) mapcls) @ [wildcard])) in + let backwards_matches_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_bool_mapcl false backwards_matches_id) mapcls) @ [wildcard])) in + + let forwards_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl forwards_id arg_pat forwards_match]), (l, ()))) in + let backwards_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl backwards_id arg_pat backwards_match]), (l, ()))) in + let forwards_matches_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl forwards_matches_id arg_pat forwards_matches_match]), (l, ()))) in + let backwards_matches_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl backwards_matches_id arg_pat backwards_matches_match]), (l, ()))) in + Printf.printf "forwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string); Printf.printf "backwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string); + Printf.printf "forwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_matches_fun |> Pretty_print_sail.to_string); + Printf.printf "backwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_matches_fun |> Pretty_print_sail.to_string); let forwards_fun, _ = Type_check.check_fundef env forwards_fun in let backwards_fun, _ = Type_check.check_fundef env backwards_fun in - forwards_spec @ forwards_fun @ backwards_spec @ backwards_fun + let forwards_matches_fun, _ = Type_check.check_fundef env forwards_matches_fun in + let backwards_matches_fun, _ = Type_check.check_fundef env backwards_matches_fun in + + let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in + let prefix_wildcard = mk_pexp (Pat_exp (mk_pat P_wild, mk_exp (E_app (mk_id "None", [mk_exp (E_lit (mk_lit L_unit))])))) in + let string_defs = + begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then + let forwards_prefix_typ = Typ_aux (Typ_fn (typ1, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (nat_typ), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in + let forwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) @ [prefix_wildcard])) in + let forwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl prefix_id arg_pat forwards_prefix_match]), (l, ()))) in + Printf.printf "forwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_prefix_fun |> Pretty_print_sail.to_string); + let forwards_prefix_fun, _ = Type_check.check_fundef env forwards_prefix_fun in + forwards_prefix_spec @ forwards_prefix_fun + else + if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then + let backwards_prefix_typ = Typ_aux (Typ_fn (typ2, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (nat_typ), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in + let backwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) @ [prefix_wildcard])) in + let backwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl prefix_id arg_pat backwards_prefix_match]), (l, ()))) in + Printf.printf "backwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_prefix_fun |> Pretty_print_sail.to_string); + let backwards_prefix_fun, _ = Type_check.check_fundef env backwards_prefix_fun in + backwards_prefix_spec @ backwards_prefix_fun + else + [] + end + in + + forwards_spec + @ forwards_fun + @ backwards_spec + @ backwards_fun + @ forwards_matches_spec + @ forwards_matches_fun + @ backwards_matches_spec + @ backwards_matches_fun + @ string_defs in let rewrite_def def = match def with diff --git a/src/type_check.ml b/src/type_check.ml index 07aa199a..47f15a74 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -737,6 +737,8 @@ end = struct | Typ_var kid when KBindings.mem kid env.typ_vars -> () | Typ_var kid -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) | Typ_fn (typ_arg, typ_ret, effs) -> wf_typ ~exs:exs env typ_arg; wf_typ ~exs:exs env typ_ret + | Typ_bidir (typ1, typ2) when strip_typ typ1 = strip_typ typ2 -> + typ_error l "Bidirectional types cannot be the same on both sides" | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2 | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs | Typ_app (id, args) when bound_typ_id env id -> diff --git a/src/type_check.mli b/src/type_check.mli index 03a0c384..39594b7d 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -148,6 +148,8 @@ module Env : sig val is_union_constructor : id -> t -> bool + val is_mapping : id -> t -> bool + val is_register : id -> t -> bool (** Return a fresh kind identifier that doesn't exist in the -- cgit v1.2.3 From 6fd0b4d4caf0103e383df2ad2401c4e7e614c450 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 3 May 2018 15:43:20 +0100 Subject: support sub-mappings in string-append-patterns --- src/rewrites.ml | 88 +++++++++++++++++++++++++++++++++++++++++++++++++------ src/sail_lib.ml | 2 +- src/type_check.ml | 36 +++++++++++++++++------ 3 files changed, 107 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 68c4002d..cf9b9705 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2840,7 +2840,7 @@ let rec rewrite_defs_pat_string_append = mk_exp (E_case (match_on, [true_pexp; false_pexp])) in - let rec rewrite_pat (pat, guards, expr) = + let rec rewrite_pat (pat, env, guards, expr) = match pat with (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") @@ -2864,7 +2864,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (P_aux (P_string_append (pats), psa_annot), guards, expr) with + match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -2917,7 +2917,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (P_aux (P_string_append (pats), psa_annot), guards, expr) with + match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -2946,8 +2946,76 @@ let rec rewrite_defs_pat_string_append = (* construct final result *) mk_pat (P_id s_id), new_guard :: guards, new_let + + | P_aux (P_string_append ( + P_aux (P_app (mapping_id, [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) + :: pats + ), psa_annot) + when Env.is_mapping mapping_id env -> + + (* common things *) + let mapping_prefix_func = + match mapping_id with + | Id_aux (Id id, _) + | Id_aux (DeIid id, _) -> id ^ "_matches_prefix" + in + let mapping_inner_typ = + match Env.get_val_spec (mk_id mapping_prefix_func) env with + | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [Typ_arg_aux (Typ_arg_typ typ, _)]), _), _), _)) -> typ + | _ -> typ_error Parse_ast.Unknown "mapping prefix func without correct function type?" + in + + let s_id = fresh_stringappend_id () in + let n_id = fresh_stringappend_id () in + let len_id = fresh_stringappend_id () in + + (* construct drop expression -- string_drop(s#, len#) *) + let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in + (* construct func expression -- maybe_atoi s# *) + let func_exp = mk_exp (E_app (mk_id mapping_prefix_func, [mk_exp (E_id s_id)])) in + (* construct some pattern -- Some (n#, len#) *) + let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in + (* construct None pattern *) + let none_exp = mk_pat (P_app (mk_id "None", [mk_pat (P_lit (mk_lit L_unit))])) in + + (* recurse into pat2 *) + let new_pat2_pexp = + match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with + | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) + | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) + in + + (* construct the new guard *) + let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in + let new_guard = mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, guard_inner_match)); + mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) + ])) in + + (* construct the new match *) + let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + + (* construct the new let *) + let new_binding = mk_exp (E_cast (mapping_inner_typ, mk_exp (E_case (func_exp, [ + mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ + mk_exp (E_id n_id); + mk_exp (E_id len_id) + ]))) + ])))) in + let new_letbind = mk_letbind (mk_pat (P_tup [ + mk_pat (P_id (mk_id var_id)); mk_pat (P_id len_id) + ])) new_binding in + let new_let = mk_exp (E_let (new_letbind, new_match)) in + + (* construct final result *) + mk_pat (P_id s_id), new_guard :: guards, new_let + + | P_aux (P_string_append [pat], _) -> + pat, guards, expr + | P_aux (P_string_append [], _) -> mk_pat (P_lit (mk_lit (L_string ""))), guards, expr + | P_aux (P_string_append _, _) -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat pat) @@ -2966,7 +3034,7 @@ let rec rewrite_defs_pat_string_append = in let (new_pat, new_guards, new_expr) = - rewrite_pat (strip_pat pat, List.map strip_exp guards, strip_exp expr) + rewrite_pat (strip_pat pat, env_of_annot p_annot, List.map strip_exp guards, strip_exp expr) in (* un-merge Pat_exp and Pat_when cases *) @@ -2974,7 +3042,6 @@ let rec rewrite_defs_pat_string_append = | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) in - Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) in @@ -3058,7 +3125,6 @@ let rewrite_defs_mapping_builtins = | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) in - Printf.printf "PEXP BEFORE TYPECHECK IS %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) in @@ -3576,8 +3642,12 @@ let rewrite_defs_realise_mappings (Defs defs) = in let realise_prefix_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = let mpexp = if forwards then mpexp1 else mpexp2 in + let other = if forwards then mpexp2 else mpexp1 in let strlen = (mk_mpat (MP_app ( mk_id "string_length" , [mk_mpat (MP_id placeholder_id)]))) in - realise_mpexps true (append_placeholder mpexp) (mk_mpexp (MPat_pat (mk_mpat (MP_app ((mk_id "Some"), [strlen]))))) + match other with + | MPat_aux (MPat_pat mpat2, _) + | MPat_aux (MPat_when (mpat2, _), _)-> + realise_mpexps true (append_placeholder mpexp) (mk_mpexp (MPat_pat (mk_mpat (MP_app ((mk_id "Some"), [ mk_mpat (MP_tup [mpat2; strlen]) ]))))) in let realise_mapdef (MD_aux (MD_mapping (id, mapcls), ((l, (tannot:tannot)) as annot))) = let forwards_id = mk_id (string_of_id id ^ "_forwards") in @@ -3639,7 +3709,7 @@ let rewrite_defs_realise_mappings (Defs defs) = let prefix_wildcard = mk_pexp (Pat_exp (mk_pat P_wild, mk_exp (E_app (mk_id "None", [mk_exp (E_lit (mk_lit L_unit))])))) in let string_defs = begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then - let forwards_prefix_typ = Typ_aux (Typ_fn (typ1, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (nat_typ), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_typ = Typ_aux (Typ_fn (typ1, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in let forwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) @ [prefix_wildcard])) in @@ -3649,7 +3719,7 @@ let rewrite_defs_realise_mappings (Defs defs) = forwards_prefix_spec @ forwards_prefix_fun else if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then - let backwards_prefix_typ = Typ_aux (Typ_fn (typ2, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (nat_typ), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_typ = Typ_aux (Typ_fn (typ2, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in let backwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) @ [prefix_wildcard])) in diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 134a3e77..1f3d0bba 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -3,7 +3,7 @@ module Big_int = Nat_big_num type 'a return = { return : 'b . 'a -> 'b } type 'za zoption = | ZNone of unit | ZSome of 'za;; -let zint_forwardsz3 i = string_of_int (Big_int.to_int i) +let zint_forwards i = string_of_int (Big_int.to_int i) let opt_trace = ref false diff --git a/src/type_check.ml b/src/type_check.ml index 47f15a74..b204b30b 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -849,13 +849,31 @@ end = struct and add_mapping id (typq, typ1, typ2) env = begin typ_print (lazy ("Adding mapping " ^ string_of_id id)); - let forwards_id = mk_id (string_of_id id ^ "_forwards#") in - let backwards_id = mk_id (string_of_id id ^ "_backwards#") in + let forwards_id = mk_id (string_of_id id ^ "_forwards") in + let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in + let backwards_id = mk_id (string_of_id id ^ "_backwards") in + let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in let forwards_typ = Typ_aux (Typ_fn (typ1, typ2, no_effect), Parse_ast.Unknown) in + let forwards_matches_typ = Typ_aux (Typ_fn (typ1, bool_typ, no_effect), Parse_ast.Unknown) in let backwards_typ = Typ_aux (Typ_fn (typ2, typ1, no_effect), Parse_ast.Unknown) in - { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } - |> add_val_spec forwards_id (typq, forwards_typ) - |> add_val_spec backwards_id (typq, backwards_typ) + let backwards_matches_typ = Typ_aux (Typ_fn (typ2, bool_typ, no_effect), Parse_ast.Unknown) in + let env = + { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } + |> add_val_spec forwards_id (typq, forwards_typ) + |> add_val_spec backwards_id (typq, backwards_typ) + |> add_val_spec forwards_matches_id (typq, forwards_matches_typ) + |> add_val_spec backwards_matches_id (typq, backwards_matches_typ) + in + let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in + begin if strip_typ typ1 = string_typ then + let forwards_prefix_typ = Typ_aux (Typ_fn (typ1, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + add_val_spec prefix_id (typq, forwards_prefix_typ) env + else if strip_typ typ2 = string_typ then + let backwards_prefix_typ = Typ_aux (Typ_fn (typ2, app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + add_val_spec prefix_id (typq, backwards_prefix_typ) env + else + env + end end let define_val_spec id env = @@ -2381,8 +2399,8 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ end | E_app (mapping, xs), _ when Env.is_mapping mapping env -> - let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in - let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in + let forwards_id = mk_id (string_of_id mapping ^ "_forwards") in + let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in typ_print (lazy("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try crule check_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) typ with | Type_error (_, err1) -> @@ -3183,8 +3201,8 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = annot_exp (E_cast (typ, checked_exp)) typ | E_app_infix (x, op, y) -> infer_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) | E_app (mapping, xs) when Env.is_mapping mapping env -> - let forwards_id = mk_id (string_of_id mapping ^ "_forwards#") in - let backwards_id = mk_id (string_of_id mapping ^ "_backwards#") in + let forwards_id = mk_id (string_of_id mapping ^ "_forwards") in + let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in typ_print (lazy ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try irule infer_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) with | Type_error (_, err1) -> -- cgit v1.2.3 From 54d4716c42bf3c8f35d0537385bceb09c3b348b1 Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 8 May 2018 17:16:09 +0100 Subject: fixed sub-mappings --- src/rewrites.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index cf9b9705..f2a8a28f 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3629,6 +3629,9 @@ let rewrite_defs_realise_mappings (Defs defs) = let mpexp = if forwards then mpexp1 else mpexp2 in realise_mpexps true mpexp (mk_mpexp (MPat_pat (mk_mpat (MP_lit (mk_lit L_true))))) in + let arg_id = mk_id "arg#" in + let arg_exp = (mk_exp (E_id arg_id)) in + let arg_pat = mk_pat (P_id arg_id) in let placeholder_id = mk_id "s#" in let append_placeholder = function | MPat_aux (MPat_pat (MP_aux (MP_string_append mpats, p_annot)), aux_annot) -> @@ -3643,7 +3646,14 @@ let rewrite_defs_realise_mappings (Defs defs) = let realise_prefix_mapcl forwards id (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, ()))) = let mpexp = if forwards then mpexp1 else mpexp2 in let other = if forwards then mpexp2 else mpexp1 in - let strlen = (mk_mpat (MP_app ( mk_id "string_length" , [mk_mpat (MP_id placeholder_id)]))) in + let strlen = ( + mk_mpat (MP_app ( mk_id "sub_nat", + [ + mk_mpat (MP_app ( mk_id "string_length" , [mk_mpat (MP_id arg_id )])); + mk_mpat (MP_app ( mk_id "string_length" , [mk_mpat (MP_id placeholder_id)])); + ] + )) + ) in match other with | MPat_aux (MPat_pat mpat2, _) | MPat_aux (MPat_when (mpat2, _), _)-> @@ -3682,8 +3692,6 @@ let rewrite_defs_realise_mappings (Defs defs) = let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in - let arg_exp = (mk_exp (E_id (mk_id "arg#"))) in - let arg_pat = mk_pat (P_id (mk_id "arg#")) in let forwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls))) in let backwards_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl false backwards_id) mapcls))) in -- cgit v1.2.3 From b6b21038c2f287a54a8bb29ec555cc42bb809100 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 9 May 2018 14:07:36 +0100 Subject: allow empty brackets to pass unit to sub-mpats --- src/parser.mly | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/parser.mly b/src/parser.mly index 23516068..cccd4a4a 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1241,6 +1241,8 @@ atomic_mpat: { mk_mpat (MP_lit $1) $startpos $endpos } | id { mk_mpat (MP_id $1) $startpos $endpos } + | id Unit + { mk_mpat (MP_app ($1, [mk_mpat (MP_lit (mk_lit L_unit $startpos($2) $endpos($2))) $startpos($2) $endpos($2)])) $startpos $endpos } | id Lparen mpat_list Rparen { mk_mpat (MP_app ($1, $3)) $startpos $endpos } | Lparen mpat Rparen -- cgit v1.2.3 From d72cd585d7fe71c98a83f7c863167d79f2520159 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 10 May 2018 11:19:08 +0100 Subject: generalise string pattern matching to arbitrary arguments rather than just an id; also remove builtin special-casing as it's not needed! --- src/rewrites.ml | 63 +++++++-------------------------------------------------- 1 file changed, 7 insertions(+), 56 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index f2a8a28f..3f6f95f4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2894,61 +2894,9 @@ let rec rewrite_defs_pat_string_append = pat2 => expr } *) - | P_aux (P_string_append ( - P_aux (P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) - :: pats - ), psa_annot) - when List.mem_assoc builtin_id builtins -> - - (* common things *) - let builtin_func, builtin_inner_typ = List.assoc builtin_id builtins in - let s_id = fresh_stringappend_id () in - let n_id = fresh_stringappend_id () in - let len_id = fresh_stringappend_id () in - - (* construct drop expression -- string_drop(s#, len#) *) - let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in - (* construct func expression -- maybe_atoi s# *) - let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in - (* construct some pattern -- Some (n#, len#) *) - let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in - (* construct None pattern *) - let none_exp = mk_pat (P_app (mk_id "None", [mk_pat (P_lit (mk_lit L_unit))])) in - - (* recurse into pat2 *) - let new_pat2_pexp = - match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with - | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) - | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) - in - - (* construct the new guard *) - let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in - let new_guard = mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, guard_inner_match)); - mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) - ])) in - - (* construct the new match *) - let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in - - (* construct the new let *) - let new_binding = mk_exp (E_cast (builtin_inner_typ, mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ - mk_exp (E_id n_id); - mk_exp (E_id len_id) - ]))) - ])))) in - let new_letbind = mk_letbind (mk_pat (P_tup [ - mk_pat (P_id (mk_id var_id)); mk_pat (P_id len_id) - ])) new_binding in - let new_let = mk_exp (E_let (new_letbind, new_match)) in - - (* construct final result *) - mk_pat (P_id s_id), new_guard :: guards, new_let | P_aux (P_string_append ( - P_aux (P_app (mapping_id, [P_aux (P_id (Id_aux (Id var_id, _)), _)] ) , _) + P_aux (P_app (mapping_id, arg_pats) , _) :: pats ), psa_annot) when Env.is_mapping mapping_id env -> @@ -3002,9 +2950,12 @@ let rec rewrite_defs_pat_string_append = mk_exp (E_id len_id) ]))) ])))) in - let new_letbind = mk_letbind (mk_pat (P_tup [ - mk_pat (P_id (mk_id var_id)); mk_pat (P_id len_id) - ])) new_binding in + let new_letbind = + match arg_pats with + | [] -> assert false + | [arg_pat] -> mk_letbind (mk_pat (P_tup [arg_pat; mk_pat (P_id len_id)])) new_binding + | arg_pats -> mk_letbind (mk_pat (P_tup [mk_pat (P_tup arg_pats); mk_pat (P_id len_id)])) new_binding + in let new_let = mk_exp (E_let (new_letbind, new_match)) in (* construct final result *) -- cgit v1.2.3 From a67ad9ca27c5e2909c852a61f34b18a3414efc46 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 10 May 2018 11:19:41 +0100 Subject: add space handling mappings to riscv prelude and sail_lib.ml --- src/sail_lib.ml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 1f3d0bba..b4c5a8aa 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -622,3 +622,25 @@ let speculate_conditional_success () = true (* Return nanoseconds since epoch. Truncates to ocaml int but will be OK for next 100 years or so... *) let get_time_ns () = Big_int.of_int (int_of_float (1e9 *. Unix.gettimeofday ())) +let rec n_leading_spaces s = + match String.length s with + | 0 -> 0 + | 1 -> begin match s with + | " " -> 1 + | _ -> 0 + end + | len -> begin match String.get s 0 with + | ' ' -> 1 + (n_leading_spaces (String.sub s 1 (len - 1))) + | _ -> 0 + end + + +let opt_spaces_matches_prefix s = + ZSome ((), n_leading_spaces s |> Big_int.of_int) + +let spaces_matches_prefix s = + let n = n_leading_spaces s in + match n with + | 0 -> ZNone () + | n -> ZSome ((), Big_int.of_int n) + -- cgit v1.2.3 From b7307bd33a1c0fe7190fc4b34a9d3eca9beda565 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 10 May 2018 13:05:43 +0100 Subject: hacky monomorphic bits-string-parser for now --- src/sail_lib.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index b4c5a8aa..415fc9fd 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -644,3 +644,13 @@ let spaces_matches_prefix s = | 0 -> ZNone () | n -> ZSome ((), Big_int.of_int n) + +let hex_bits_12_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 4096 then + ZSome ((bits_of_int 2048 n, len)) + else + ZNone () -- cgit v1.2.3 From 99a22fbf21a2a6cf0a556daf9f781b91c513e5b7 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 10 May 2018 15:46:15 +0100 Subject: Type_check: special case appending an empty vector --- src/type_check.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 268183fe..58bd0d17 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3272,6 +3272,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) | E_vector_update_subrange (v, n, m, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update_subrange", [v; n; m; exp]), (l, ()))) + | E_vector_append (v1, E_aux (E_vector [], _)) -> infer_exp env v1 | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "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" -- cgit v1.2.3 From 86cad118fe98594921ff8e3a4046f72a8d6024d8 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 10 May 2018 15:46:31 +0100 Subject: more mapping --- src/sail_lib.ml | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 415fc9fd..bab4000b 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -654,3 +654,23 @@ let hex_bits_12_matches_prefix s = ZSome ((bits_of_int 2048 n, len)) else ZNone () + +let hex_bits_20_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 1048576 then + ZSome ((bits_of_int 524288 n, len)) + else + ZNone () + +let hex_bits_21_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 2097152 then + ZSome ((bits_of_int 1048576 n, len)) + else + ZNone () -- cgit v1.2.3 From 3b57f110103bda40398f752950248c50d834670e Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 11 May 2018 17:07:55 +0100 Subject: support for mapping-patterns inside (should be) all other pattern types --- src/rewrites.ml | 242 ++++++++++++++++++++++++++++++++++++----------------- src/type_check.ml | 33 ++++++-- src/type_check.mli | 2 + 3 files changed, 191 insertions(+), 86 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index b7ebd073..a6a1f2b0 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -715,6 +715,7 @@ let remove_vector_concat_pat pat = | P_as (p,id) -> P_aux (P_as (p,id),a) | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) | P_wild -> P_aux (P_wild,a) + | P_app (id, pats) when Env.is_mapping id (env_of_annot a) -> P_aux (P_app (id, List.map aux pats), a) | _ -> raise (Reporting_basic.err_unreachable @@ -805,6 +806,9 @@ let remove_vector_concat_pat pat = let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) + (* | P_app (cname, pats) if Env.is_mapping cname (en) -> + * let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + * (pos', pat_acc @ [P_aux (P_app (cname,pats),cannot)], decl_acc @ [((lb,decl),info)]) *) (* normal vector patterns are fine *) | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc)) in let pats_tagged = tag_last pats in @@ -2818,6 +2822,11 @@ let fold_guards guards = | [] -> (mk_exp (E_lit (mk_lit L_true))) | g :: gs -> List.fold_left (fun g g' -> mk_exp (E_app (mk_id "and_bool", [strip_exp g; strip_exp g']))) g gs +let fold_typed_guards env guards = + match guards with + | [] -> annot_exp (E_lit (mk_lit L_true)) Parse_ast.Unknown env bool_typ + | g :: gs -> List.fold_left (fun g g' -> annot_exp (E_app (mk_id "and_bool", [g; g'])) Parse_ast.Unknown env bool_typ) g gs + let rewrite_pexp_with_guards rewrite_pat (Pat_aux (pexp_aux, (annot: tannot annot)) as pexp) = let guards = ref [] in @@ -2852,16 +2861,7 @@ let fresh_stringappend_id () = stringappend_counter := !stringappend_counter + 1; id - -let rec rewrite_defs_pat_string_append = - - let builtins = [ - (* ("int", ("maybe_int_of_prefix", app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [int_typ; nat_typ]), Parse_ast.Unknown)] )); *) - ("int", ("maybe_int_of_prefix", tuple_typ [int_typ; nat_typ] )); - ] - in - - let construct_bool_match match_on pexp = +let construct_bool_match match_on pexp = let true_exp = (mk_exp (E_lit (mk_lit L_true))) in let false_exp = (mk_exp (E_lit (mk_lit L_false))) in let true_pexp = @@ -2873,9 +2873,18 @@ let rec rewrite_defs_pat_string_append = in let false_pexp = mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) in mk_exp (E_case (match_on, [true_pexp; false_pexp])) - in - let rec rewrite_pat (pat, env, guards, expr) = + +let rec rewrite_defs_pat_string_append = + let rec rewrite_pat env (pat, guards, expr) = + let guards_ref = ref guards in + let expr_ref = ref expr in + let folder p = + let p, g, e = rewrite_pat env (p, !guards_ref, !expr_ref) in + guards_ref := g; + expr_ref := e; + p + in match pat with (* "lit" ^^ pat2 => expr ---> s# if startswith(s#, "lit") @@ -2899,7 +2908,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with + match rewrite_pat env (P_aux (P_string_append (pats), psa_annot), guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -2963,7 +2972,7 @@ let rec rewrite_defs_pat_string_append = (* recurse into pat2 *) let new_pat2_pexp = - match rewrite_pat (P_aux (P_string_append (pats), psa_annot), env, guards, expr) with + match rewrite_pat env (P_aux (P_string_append (pats), psa_annot), guards, expr) with | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) in @@ -3005,7 +3014,39 @@ let rec rewrite_defs_pat_string_append = | P_aux (P_string_append _, _) -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat pat) - | _ -> pat, guards, expr + | P_aux (P_as (inner_pat, inner_id), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_as (inner_pat, inner_id), p_annot), guards, expr + | P_aux (P_typ (inner_typ, inner_pat), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_typ (inner_typ, inner_pat), p_annot), guards, expr + | P_aux (P_var (inner_pat, typ_pat), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_var (inner_pat, typ_pat), p_annot), guards, expr + | P_aux (P_record _, p_annot) -> + failwith "record patterns not yet implemented" + | P_aux (P_vector pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_vector pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_vector_concat pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_vector_concat pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_tup pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_tup pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_list pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_list pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_app (f, pats), p_annot) -> + let pats = List.map folder pats in + P_aux (P_app (f, pats), p_annot), !guards_ref, !expr_ref + | P_aux (P_cons (pat1, pat2), p_annot) -> + let pat1, guards, expr = rewrite_pat env (pat1, guards, expr) in + let pat2, guards, expr = rewrite_pat env (pat2, guards, expr) in + P_aux (P_cons (pat1, pat2), p_annot), guards, expr + | P_aux (P_id _, _) + | P_aux (P_lit _, _) + | P_aux (P_wild, _) -> pat, guards, expr in let rec rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = @@ -3020,7 +3061,7 @@ let rec rewrite_defs_pat_string_append = in let (new_pat, new_guards, new_expr) = - rewrite_pat (strip_pat pat, env_of_annot p_annot, List.map strip_exp guards, strip_exp expr) + rewrite_pat (env_of_annot p_annot) (strip_pat pat, List.map strip_exp guards, strip_exp expr) in (* un-merge Pat_exp and Pat_when cases *) @@ -3034,84 +3075,129 @@ let rec rewrite_defs_pat_string_append = pexp_rewriters rewrite_pexp -let mappingbuiltins_counter = ref 0 +let mappingpatterns_counter = ref 0 -let fresh_mappingbuiltins_id () = - let id = mk_id ("_mappingbuiltins_" ^ (string_of_int !mappingbuiltins_counter) ^ "#") in - mappingbuiltins_counter := !mappingbuiltins_counter + 1; +let fresh_mappingpatterns_id () = + let id = mk_id ("_mappingpatterns_" ^ (string_of_int !mappingpatterns_counter) ^ "#") in + mappingpatterns_counter := !mappingpatterns_counter + 1; id +let rewrite_defs_mapping_patterns = + let rec rewrite_pat env (pat, guards, expr) = + let guards_ref = ref guards in + let expr_ref = ref expr in + let folder p = + let p, g, e = rewrite_pat env (p, !guards_ref, !expr_ref) in + guards_ref := g; + expr_ref := e; + p + in + let env = pat_env_of pat in + match pat with + (* + mapping(args) => expr ----> s# if mapping_matches(s#) => let args = mapping(s#) in expr -let rewrite_defs_mapping_builtins = + (plus 'infer the mapping type' shenanigans) + *) + | P_aux (P_app (mapping_id, arg_pats), p_annot) when Env.is_mapping mapping_id env -> + + let mapping_in_typ = typ_of_annot p_annot in - let builtins = [ - ("int", ("maybe_int_of_string", int_typ)); - ("nat", ("maybe_nat_of_string", nat_typ)); - ] - in + let x = Env.get_val_spec mapping_id env in + let (_, Typ_aux(Typ_bidir(typ1, typ2), _)) = x in - let rec rewrite_pat (P_aux (p_aux, _) as pat, guards, expr) = - let new_pat, new_guards, new_expr = match p_aux with - | P_as (pat2, id) -> - let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in - mk_pat (P_as (new_pat2, id)), new_guards, new_expr - | P_typ (typ, pat2) -> - let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in - mk_pat (P_typ (typ, pat2)), new_guards, new_expr - | P_var (pat2, typ_pat) -> - let new_pat2, new_guards, new_expr = rewrite_pat (pat2, guards, expr) in - mk_pat (P_var (pat2, typ_pat)), new_guards, new_expr - | P_app (Id_aux (Id builtin_id, _), [P_aux (P_id (Id_aux (Id var_id, _)), _)]) when List.mem_assoc builtin_id builtins -> - (* - builtin(x) => expr ---> s# if match builtin_fun(s#) { - Some x# => true - _ => false - } - => let x = match builtin_fun(s#) { Some x# => x# } in - expr - *) - let builtin_func, builtin_typ = List.assoc builtin_id builtins in - let s_id = fresh_mappingbuiltins_id () in - let x_id = fresh_mappingbuiltins_id () in - let true_exp = mk_exp (E_lit (mk_lit (L_true))) in - let false_exp = mk_exp (E_lit (mk_lit (L_false))) in - let func_exp = mk_exp (E_app (mk_id builtin_func, [mk_exp (E_id s_id)])) in - let new_pat = mk_pat (P_id s_id) in - let new_guard = mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (mk_pat (P_app (mk_id "Some", [mk_pat (P_id x_id)])), true_exp)); - mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) - ])) in - let new_binding = mk_exp (E_cast (builtin_typ, mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (mk_pat (P_app (mk_id "Some", [mk_pat (P_id x_id)])), mk_exp (E_id x_id))) - ])))) in - let new_letbind = mk_letbind (mk_pat (P_id (mk_id var_id))) new_binding in - let new_expr = mk_exp (E_let (new_letbind, expr)) in - new_pat, new_guard :: guards, new_expr - | _ -> pat, guards, expr - in - new_pat, new_guards, new_expr - in - let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = + let mapping_direction = + if mapping_in_typ = typ1 then + "forwards" + else + "backwards" + in - let (pat, _, _, _) = destruct_pexp pexp in + let mapping_name = + match mapping_id with + | Id_aux (Id id, _) + | Id_aux (DeIid id, _) -> id + in + + let mapping_matches_id = mk_id (mapping_name ^ "_" ^ mapping_direction ^ "_matches") in + let mapping_perform_id = mk_id (mapping_name ^ "_" ^ mapping_direction) in + let s_id = fresh_mappingpatterns_id () in + + let s_exp = annot_exp (E_id s_id) Parse_ast.Unknown env mapping_in_typ in + let new_guard = annot_exp (E_app (mapping_matches_id, [s_exp])) Parse_ast.Unknown env bool_typ in + let new_binding = annot_exp (E_app (mapping_perform_id, [s_exp])) Parse_ast.Unknown env typ2 in + let new_letbind = match arg_pats with + | [] -> assert false + | [arg_pat] -> LB_aux (LB_val (arg_pat, new_binding), (Parse_ast.Unknown, None)) + | arg_pats -> + let (checked_tup, new_env, []) = infer_pat env (mk_pat (P_tup (List.map strip_pat arg_pats))) in + LB_aux (LB_val (checked_tup, new_binding), (Parse_ast.Unknown, None)) + in + + let new_let = annot_exp (E_let (new_letbind, expr)) Parse_ast.Unknown env (typ_of expr) in + + annot_pat (P_id s_id) Parse_ast.Unknown env mapping_in_typ, new_guard :: guards, new_let + + | P_aux (P_as (inner_pat, inner_id), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_as (inner_pat, inner_id), p_annot), guards, expr + | P_aux (P_typ (inner_typ, inner_pat), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_typ (inner_typ, inner_pat), p_annot), guards, expr + | P_aux (P_var (inner_pat, typ_pat), p_annot) -> + let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in + P_aux (P_var (inner_pat, typ_pat), p_annot), guards, expr + | P_aux (P_record _, p_annot) -> + failwith "record patterns not yet implemented" + | P_aux (P_vector pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_vector pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_vector_concat pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_vector_concat pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_tup pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_tup pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_list pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_list pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_app (f, pats), p_annot) -> + let pats = List.map folder pats in + P_aux (P_app (f, pats), p_annot), !guards_ref, !expr_ref + | P_aux (P_string_append pats, p_annot) -> + let pats = List.map folder pats in + P_aux (P_string_append pats, p_annot), !guards_ref, !expr_ref + | P_aux (P_cons (pat1, pat2), p_annot) -> + let pat1, guards, expr = rewrite_pat env (pat1, guards, expr) in + let pat2, guards, expr = rewrite_pat env (pat2, guards, expr) in + P_aux (P_cons (pat1, pat2), p_annot), guards, expr + | P_aux (P_id _, _) + | P_aux (P_lit _, _) + | P_aux (P_wild, _) -> pat, guards, expr + in + + let rec rewrite_pexp (Pat_aux (pexp_aux, pexp_annot) as pexp) = (* merge cases of Pat_exp and Pat_when *) - let (P_aux (p_aux, p_annot), guards, expr) = + let (P_aux (p_aux, p_annot) as pat, guards, expr) = match pexp_aux with | Pat_exp (pat, expr) -> (pat, [], expr) | Pat_when (pat, guard, expr) -> (pat, [guard], expr) in + let env = env_of_annot p_annot in + let (new_pat, new_guards, new_expr) = - rewrite_pat (strip_pat pat, List.map strip_exp guards, strip_exp expr) + rewrite_pat env (pat, guards, expr) in (* un-merge Pat_exp and Pat_when cases *) let new_pexp = match new_guards with - | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) - | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) + | [] -> Pat_aux (Pat_exp (new_pat, new_expr), pexp_annot) + | gs -> Pat_aux (Pat_when (new_pat, fold_typed_guards env gs, new_expr), pexp_annot) in - check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) + Printf.printf "rewritten pexp: %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); + new_pexp in pexp_rewriters rewrite_pexp @@ -3781,7 +3867,7 @@ let rewrite_defs_lem = [ ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", rewrite_defs_remove_numeral_pats); ("pat_string_append", rewrite_defs_pat_string_append); - ("mapping_builtins", rewrite_defs_mapping_builtins); + ("mapping_builtins", rewrite_defs_mapping_patterns); ("guarded_pats", rewrite_defs_guarded_pats); ("bitvector_exps", rewrite_bitvector_exps); (* ("register_ref_writes", rewrite_register_ref_writes); *) @@ -3812,7 +3898,7 @@ let rewrite_defs_ocaml = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); - ("mapping_builtins", rewrite_defs_mapping_builtins); + ("mapping_builtins", rewrite_defs_mapping_patterns); ("pat_lits", rewrite_defs_pat_lits); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3834,7 +3920,7 @@ let rewrite_defs_c = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); - ("mapping_builtins", rewrite_defs_mapping_builtins); + ("mapping_builtins", rewrite_defs_mapping_patterns); ("pat_lits", rewrite_defs_pat_lits); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -3854,7 +3940,7 @@ let rewrite_defs_interpreter = [ ("no_effect_check", (fun defs -> opt_no_effects := true; defs)); ("realise_mappings", rewrite_defs_realise_mappings); ("pat_string_append", rewrite_defs_pat_string_append); - ("mapping_builtins", rewrite_defs_mapping_builtins); + ("mapping_builtins", rewrite_defs_mapping_patterns); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); diff --git a/src/type_check.ml b/src/type_check.ml index 58bd0d17..09b8a9c7 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2818,7 +2818,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) in annot_pat (P_app (f, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m) + | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m) end | _ -> typ_error l ("Mal-formed mapping " ^ string_of_id f) end @@ -3615,34 +3615,51 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as end | MP_app (other, mpats) when Env.is_mapping other env -> begin - let (typq, ctor_typ) = Env.get_val_spec other env in + let (typq, mapping_typ) = Env.get_val_spec other 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 + match Env.expand_synonyms env mapping_typ with | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin try - typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ1 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 mapping-pattern " ^ string_of_mpat mpat) + then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers typ2 in let tpats, env, guards = try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Union constructor mapping-pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" in annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when mapping-pattern matching against union constructor: " ^ m) + | Unification_error (l, m) -> + try + typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); + let unifiers, _, _ (* FIXME! *) = unify l env typ1 typ in + typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let arg_typ' = subst_unifiers unifiers typ2 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_mpat mpat) + else (); + let ret_typ' = subst_unifiers unifiers typ1 in + let tpats, env, guards = + try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + in + annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards + with + | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m) end - | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id other) end | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env)-> typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) diff --git a/src/type_check.mli b/src/type_check.mli index 7251f50c..5cc6892c 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -249,6 +249,8 @@ val check_exp : Env.t -> unit exp -> typ -> tannot exp val infer_exp : Env.t -> unit exp -> tannot exp +val infer_pat : Env.t -> unit pat -> tannot pat * Env.t * unit exp list + val check_case : Env.t -> typ -> unit pexp -> typ -> tannot pexp val check_fundef : Env.t -> 'a fundef -> tannot def list * Env.t -- cgit v1.2.3 From 0e7a57c63b0430b4d5b126a3ddce26eacf1f272c Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 11 May 2018 17:18:37 +0100 Subject: further riscv mapping --- src/sail_lib.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index bab4000b..81685bec 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -655,6 +655,16 @@ let hex_bits_12_matches_prefix s = else ZNone () +let hex_bits_13_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 8192 then + ZSome ((bits_of_int 4096 n, len)) + else + ZNone () + let hex_bits_20_matches_prefix s = match maybe_int_of_prefix s with | ZNone () -> ZNone () -- cgit v1.2.3 From 5be6481a1681225d72ca26f509506489fdc4e374 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 14 May 2018 15:44:13 +0100 Subject: make debug printing of realised mappings both optional and lazy --- src/rewrites.ml | 14 +++++++------- src/type_check.mli | 3 +++ 2 files changed, 10 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index a6a1f2b0..bba14651 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3196,7 +3196,7 @@ let rewrite_defs_mapping_patterns = | [] -> Pat_aux (Pat_exp (new_pat, new_expr), pexp_annot) | gs -> Pat_aux (Pat_when (new_pat, fold_typed_guards env gs, new_expr), pexp_annot) in - Printf.printf "rewritten pexp: %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string); + typ_debug (lazy (Printf.sprintf "rewritten pexp: %s\n%!" (Pretty_print_sail.doc_pexp new_pexp |> Pretty_print_sail.to_string))); new_pexp in @@ -3803,10 +3803,10 @@ let rewrite_defs_realise_mappings (Defs defs) = let forwards_matches_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl forwards_matches_id arg_pat forwards_matches_match]), (l, ()))) in let backwards_matches_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl backwards_matches_id arg_pat backwards_matches_match]), (l, ()))) in - Printf.printf "forwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string); - Printf.printf "backwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string); - Printf.printf "forwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_matches_fun |> Pretty_print_sail.to_string); - Printf.printf "backwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_matches_fun |> Pretty_print_sail.to_string); + typ_debug (lazy (Printf.sprintf "forwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_fun |> Pretty_print_sail.to_string))); + typ_debug (lazy (Printf.sprintf "backwards for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_fun |> Pretty_print_sail.to_string))); + typ_debug (lazy (Printf.sprintf "forwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_matches_fun |> Pretty_print_sail.to_string))); + typ_debug (lazy (Printf.sprintf "backwards matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_matches_fun |> Pretty_print_sail.to_string))); let forwards_fun, _ = Type_check.check_fundef env forwards_fun in let backwards_fun, _ = Type_check.check_fundef env backwards_fun in let forwards_matches_fun, _ = Type_check.check_fundef env forwards_matches_fun in @@ -3821,7 +3821,7 @@ let rewrite_defs_realise_mappings (Defs defs) = let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in let forwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) @ [prefix_wildcard])) in let forwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl prefix_id arg_pat forwards_prefix_match]), (l, ()))) in - Printf.printf "forwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_prefix_fun |> Pretty_print_sail.to_string); + typ_debug (lazy (Printf.sprintf "forwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_prefix_fun |> Pretty_print_sail.to_string))); let forwards_prefix_fun, _ = Type_check.check_fundef env forwards_prefix_fun in forwards_prefix_spec @ forwards_prefix_fun else @@ -3831,7 +3831,7 @@ let rewrite_defs_realise_mappings (Defs defs) = let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in let backwards_prefix_match = mk_exp (E_case (arg_exp, (List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) @ [prefix_wildcard])) in let backwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_pure, [mk_funcl prefix_id arg_pat backwards_prefix_match]), (l, ()))) in - Printf.printf "backwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_prefix_fun |> Pretty_print_sail.to_string); + typ_debug (lazy (Printf.sprintf "backwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_prefix_fun |> Pretty_print_sail.to_string))); let backwards_prefix_fun, _ = Type_check.check_fundef env backwards_prefix_fun in backwards_prefix_spec @ backwards_prefix_fun else diff --git a/src/type_check.mli b/src/type_check.mli index 5cc6892c..f1ce967e 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -81,6 +81,9 @@ exception Type_error of l * type_error;; val string_of_type_error : type_error -> string +val typ_debug : string Lazy.t -> unit +val typ_print : string Lazy.t -> unit + (** {2 Environments} *) (** The env module defines the internal type checking environment, and -- cgit v1.2.3 From 11ac94c4b270bf8bc1c0d1aa1a852f36f0790b9b Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 15 May 2018 17:46:10 +0100 Subject: rewrite_defs_guarded_pats: guards deserve rewriting too --- src/rewrites.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index bba14651..b23af46a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -1501,7 +1501,7 @@ let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = | Pat_aux (Pat_exp (pat, body), annot) -> (pat, None, rewrite_rec body, annot) | Pat_aux (Pat_when (pat, guard, body), annot) -> - (pat, Some guard, rewrite_rec body, annot) in + (pat, Some (rewrite_rec guard), rewrite_rec body, annot) in let clauses = rewrite_guarded_clauses l (List.map clause ps) in if (effectful e) then let e = rewrite_rec e in -- cgit v1.2.3 From ed3bb9702bd1f76041a3798f453714b0636a1b6b Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 15 May 2018 17:46:32 +0100 Subject: reorder lem rewrite passes and explicitly remove mapping valspecs; string stuff now compiles to Lem --- src/rewrites.ml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index b23af46a..e41318dd 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3858,16 +3858,27 @@ let rewrite_defs_realise_mappings (Defs defs) = let recheck_defs defs = fst (check initial_env defs) +let remove_mapping_valspecs (Defs defs) = + let allowed_def def = + match def with + | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (_, Typ_aux (Typ_bidir _, _)), _), _, _, _), _)) -> false + | _ -> true + in + Defs (List.filter allowed_def defs) + + let rewrite_defs_lem = [ ("realise_mappings", rewrite_defs_realise_mappings); + ("remove_mapping_valspecs", remove_mapping_valspecs); + ("pat_string_append", rewrite_defs_pat_string_append); + ("mapping_builtins", rewrite_defs_mapping_patterns); + ("pat_lits", rewrite_defs_pat_lits); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); ("remove_vector_concat", rewrite_defs_remove_vector_concat); ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", rewrite_defs_remove_numeral_pats); - ("pat_string_append", rewrite_defs_pat_string_append); - ("mapping_builtins", rewrite_defs_mapping_patterns); ("guarded_pats", rewrite_defs_guarded_pats); ("bitvector_exps", rewrite_bitvector_exps); (* ("register_ref_writes", rewrite_register_ref_writes); *) -- cgit v1.2.3 From a7563156f1ea9ca71c2d4cd0de4bad67f0f99b30 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 16 May 2018 15:44:19 +0100 Subject: Add support for inline val-spec declaration for mappings This means that a mapping which formerly had to be pre-declared like val name : a <-> b ... mapping name { x <-> y, ... } can now be shortened to mapping name : a <-> b { x <-> y, ... } --- src/initial_check.ml | 24 +++++++++++++++++------- src/parse_ast.ml | 12 ++++++++++-- src/parser.mly | 22 +++++++++++++++++----- src/pretty_print_sail.ml | 2 +- src/rewrites.ml | 2 +- src/type_check.ml | 37 +++++++++++++++++++++++++++++++++---- 6 files changed, 79 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index e1dd906b..9545ce44 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -754,6 +754,15 @@ let to_ast_tannot_opt (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.Typ_annot let typq,k_env,k_local = to_ast_typquant k_env tq in Typ_annot_opt_aux(Typ_annot_opt_some(typq,to_ast_typ k_env def_ord typ),l),k_env,k_local +let to_ast_typschm_opt (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.TypSchm_opt_aux(aux,l)) : tannot_opt * kind Envmap.t * kind Envmap.t = + match aux with + | Parse_ast.TypSchm_opt_none -> + Typ_annot_opt_aux (Typ_annot_opt_none, l), k_env, Envmap.empty + | Parse_ast.TypSchm_opt_some (Parse_ast.TypSchm_aux (Parse_ast.TypSchm_ts (tq, typ), l)) -> + let typq, k_env, k_local = to_ast_typquant k_env tq in + Typ_annot_opt_aux (Typ_annot_opt_some (typq, to_ast_typ k_env def_ord typ), l), k_env, k_local + + let to_ast_effects_opt (k_env : kind Envmap.t) (Parse_ast.Effect_opt_aux(e,l)) : effect_opt = match e with | Parse_ast.Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l) @@ -807,8 +816,9 @@ let to_ast_mapcl (names,k_env,def_ord) (Parse_ast.MCL_aux(mapcl, l)) = let to_ast_mapdef (names,k_env,def_ord) (Parse_ast.MD_aux(md,l):Parse_ast.mapdef) : (unit mapdef) envs_out = match md with - | Parse_ast.MD_mapping(id, mapcls) -> - MD_aux(MD_mapping(to_ast_id id, List.map (to_ast_mapcl (names,k_env,def_ord)) mapcls), (l,())), (names,k_env,def_ord) + | Parse_ast.MD_mapping(id, typschm_opt, mapcls) -> + let tannot_opt, k_env, _ = to_ast_typschm_opt k_env def_ord typschm_opt in + MD_aux(MD_mapping(to_ast_id id, tannot_opt, List.map (to_ast_mapcl (names,k_env,def_ord)) mapcls), (l,())), (names,k_env,def_ord) type def_progress = No_def @@ -904,11 +914,11 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | 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_mapping id -> + | Parse_ast.SD_scattered_mapping (id, tannot_opt) -> let id = to_ast_id id in - let _,_,k_local = to_ast_tannot_opt k_env def_ord (Parse_ast.Typ_annot_opt_aux (Parse_ast.Typ_annot_opt_none, Parse_ast.Unknown)) in + let unit, k_env ,k_local = to_ast_tannot_opt k_env def_ord tannot_opt in (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_mapdef(MD_aux(MD_mapping(id, []), (l, ())))), false) in + | None -> let partial_def = ref ((DEF_mapdef(MD_aux(MD_mapping(id, unit, []), (l, ())))), false) in (No_def,envs),((id,(partial_def,k_local))::partial_defs) | Some(d,k) -> typ_error l "Scattered mapping definition header name already in use by scattered definition" (Some id) None None) @@ -918,9 +928,9 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | None -> typ_error l "Scattered mapping definition clause does not match any existing mapping definition headers" (Some id) None None | Some (d, k) -> (match !d with - | DEF_mapdef(MD_aux(MD_mapping(_,mcls),ml)),false -> + | DEF_mapdef(MD_aux(MD_mapping(_,tannot_opt, mcls),ml)),false -> let (MCL_aux (mapcl_aux, _)) = to_ast_mapcl (names,k_env,def_ord) mapcl in - d := DEF_mapdef(MD_aux(MD_mapping(id, mcls @ [MCL_aux (mapcl_aux, (l, ()))]), ml)), false; + d := DEF_mapdef(MD_aux(MD_mapping(id, tannot_opt, mcls @ [MCL_aux (mapcl_aux, (l, ()))]), ml)), false; (No_def,envs),partial_defs | _, true -> typ_error l "Scattered mapping definition clause extends ended definition" (Some id) None None | _ -> typ_error l "Scattered mapping definition doesn't match existing definition header" (Some id) None None)) diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 607285c7..c31d548c 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -344,6 +344,14 @@ tannot_opt_aux = (* Optional type annotation for functions *) Typ_annot_opt_none | Typ_annot_opt_some of typquant * atyp +type +typschm_opt_aux = + TypSchm_opt_none +| TypSchm_opt_some of typschm + +type +typschm_opt = + TypSchm_opt_aux of typschm_opt_aux * l type effect_opt_aux = (* Optional effect annotation for functions *) @@ -456,7 +464,7 @@ type mapcl = | MCL_aux of ( mapcl_aux) * l type mapdef_aux = (* mapping definition (bidirectional pattern-match function) *) - | MD_mapping of id * ( mapcl) list + | MD_mapping of id * typschm_opt * ( mapcl) list type mapdef = | MD_aux of ( mapdef_aux) * l @@ -498,7 +506,7 @@ scattered_def_aux = (* Function and type union definitions that can be spread a | SD_scattered_funcl of funcl (* scattered function definition clause *) | SD_scattered_variant of id * name_scm_opt * typquant (* scattered union definition header *) | SD_scattered_unioncl of id * type_union (* scattered union definition member *) - | SD_scattered_mapping of id + | SD_scattered_mapping of id * tannot_opt | SD_scattered_mapcl of id * mapcl | SD_scattered_end of id (* scattered definition end *) diff --git a/src/parser.mly b/src/parser.mly index a46defd6..5c513e5b 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -93,6 +93,16 @@ let mk_exp e n m = E_aux (e, loc n m) let mk_lit l n m = L_aux (l, loc n m) let mk_lit_exp l n m = mk_exp (E_lit (mk_lit l n m)) n m let mk_typschm tq t n m = TypSchm_aux (TypSchm_ts (tq, t), loc n m) + +let mk_typschm_opt ts n m = TypSchm_opt_aux ( + TypSchm_opt_some ( + ts + ), + loc n m + ) + +let mk_typschm_opt_none = TypSchm_opt_aux (TypSchm_opt_none, Unknown) + let mk_nc nc n m = NC_aux (nc, loc n m) let mk_sd s n m = SD_aux (s, loc n m) let mk_sd_doc s str n m = SD_aux (s, Documented (str, loc n m)) @@ -108,7 +118,7 @@ let mk_default d n m = DT_aux (d, loc n m) let mk_mpexp mpexp n m = MPat_aux (mpexp, loc n m) let mk_mpat mpat n m = MP_aux (mpat, loc n m) let mk_mapcl mpexp1 mpexp2 n m = MCL_aux (MCL_mapcl (mpexp1, mpexp2), loc n m) -let mk_map id mapcls n m = MD_aux (MD_mapping (id, mapcls), loc n m) +let mk_map id tannot mapcls n m = MD_aux (MD_mapping (id, tannot, mapcls), loc n m) let doc_vs doc (VS_aux (v, l)) = VS_aux (v, Documented (doc, l)) @@ -1280,9 +1290,9 @@ mapcl_list: map_def: | Mapping id Eq Lcurly mapcl_list Rcurly - { mk_map $2 $5 $startpos $endpos } - (* | Mapping id Colon typschm Eq Lcurly mapcl_list Rcurly - * { mk_map $2 $4 $7 $startpos $endpos } *) + { mk_map $2 mk_typschm_opt_none $5 $startpos $endpos } + | Mapping id Colon typschm Eq Lcurly mapcl_list Rcurly + { mk_map $2 (mk_typschm_opt $4 $startpos($4) $endpos($4)) $7 $startpos $endpos } let_def: | Let_ letbind @@ -1334,7 +1344,9 @@ scattered_def: | Function_ id { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } | Mapping id - { mk_sd (SD_scattered_mapping $2) $startpos $endpos } + { mk_sd (SD_scattered_mapping ($2, mk_tannotn)) $startpos $endpos } + | Mapping id Colon funcl_typ + { mk_sd (SD_scattered_mapping ($2, $4)) $startpos $endpos } scattered_clause: | Doc Function_ Clause funcl diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 6ea669f9..4b9fa6a9 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -476,7 +476,7 @@ let doc_mapcl (MCL_aux (MCL_mapcl (mpexp1, mpexp2), _)) = let right = doc_mpexp mpexp2 in left ^^ space ^^ string "<->" ^^ space ^^ right -let doc_mapdef (MD_aux (MD_mapping (id, mapcls), _)) = +let doc_mapdef (MD_aux (MD_mapping (id, typa, mapcls), _)) = match mapcls with | [] -> failwith "Empty mapping" | _ -> diff --git a/src/rewrites.ml b/src/rewrites.ml index e41318dd..58ff885f 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3758,7 +3758,7 @@ let rewrite_defs_realise_mappings (Defs defs) = | MPat_aux (MPat_when (mpat2, _), _)-> realise_mpexps true (append_placeholder mpexp) (mk_mpexp (MPat_pat (mk_mpat (MP_app ((mk_id "Some"), [ mk_mpat (MP_tup [mpat2; strlen]) ]))))) in - let realise_mapdef (MD_aux (MD_mapping (id, mapcls), ((l, (tannot:tannot)) as annot))) = + let realise_mapdef (MD_aux (MD_mapping (id, _, mapcls), ((l, (tannot:tannot)) as annot))) = let forwards_id = mk_id (string_of_id id ^ "_forwards") in let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in let backwards_id = mk_id (string_of_id id ^ "_backwards") in diff --git a/src/type_check.ml b/src/type_check.ml index 09b8a9c7..fbec5111 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -674,6 +674,7 @@ end = struct match typ_aux with | Typ_id _ | Typ_var _ -> typ | Typ_fn (arg_typ, ret_typ, effect) -> Typ_aux (Typ_fn (map_nexps f arg_typ, map_nexps f ret_typ, effect), l) + | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2), l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (map_nexps f) typs), l) | Typ_exist (kids, nc, typ) -> Typ_aux (Typ_exist (kids, nc, map_nexps f typ), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map (map_nexps_arg f) args), l) @@ -1507,6 +1508,13 @@ let typ_identical env typ1 typ2 = match typ1, typ2 with | Typ_id v1, Typ_id v2 -> Id.compare v1 v2 = 0 | Typ_var kid1, Typ_var kid2 -> Kid.compare kid1 kid2 = 0 + | Typ_fn (arg_typ1, ret_typ1, eff1), Typ_fn (arg_typ2, ret_typ2, eff2) -> + typ_identical' arg_typ1 arg_typ2 + && typ_identical' ret_typ1 ret_typ2 + && strip_effect eff1 = strip_effect eff2 + | Typ_bidir (typ1, typ2), Typ_bidir (typ3, typ4) -> + typ_identical' typ1 typ3 + && typ_identical' typ2 typ4 | Typ_tup typs1, Typ_tup typs2 -> begin try List.for_all2 typ_identical' typs1 typs2 with @@ -4231,21 +4239,42 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found") -let check_mapdef env (MD_aux (MD_mapping (id, mapcls), (l, _)) as md_aux) = +let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md_aux) = typ_print (lazy ("\nChecking mapping " ^ string_of_id id)); - let quant, typ = Env.get_val_spec id env in + let have_val_spec, (quant, typ), env = + try true, Env.get_val_spec id env, env with + | Type_error (l, _) as err -> + match tannot_opt with + | Typ_annot_opt_aux (Typ_annot_opt_some (quant, typ), _) -> + false, (quant, typ), env + | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> + raise err + in let vtyp1, vtyp2, vl = match typ with | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl | _ -> typ_error l "Mapping val spec was not a mapping type" in + begin match tannot_opt with + | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> () + | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_typ), l) -> + if typ_identical env typ annot_typ then () + else typ_error l (string_of_bind (quant, typ) ^ " and " ^ string_of_bind (annot_typq, annot_typ) ^ " do not match between mapping and val spec") + end; typ_debug (lazy ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); + let vs_def, env = + if not have_val_spec then + [mk_val_spec env quant typ id], Env.add_val_spec id (quant, typ) env + else + [], env + in let mapcl_env = add_typquant quant env in let mapcls = List.map (fun mapcl -> check_mapcl mapcl_env mapcl typ) mapcls in let eff = List.fold_left union_effects no_effect (List.map mapcl_effect mapcls) in + let env = Env.define_val_spec id env in if equal_effects eff no_effect then - [DEF_mapdef (MD_aux (MD_mapping (id, mapcls), (l, None)))], env + vs_def @ [DEF_mapdef (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, None)))], env else - typ_error l ("Mapping not pure:" ^ string_of_effect eff ^ " found") + typ_error l ("Mapping not pure: " ^ string_of_effect eff ^ " found") (* Checking a val spec simply adds the type as a binding in the -- cgit v1.2.3 From 466c3936bcef6518503a216bcb583f89e8979643 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 16 May 2018 16:28:31 +0100 Subject: fix a couple warnings in type_check.ml --- src/type_check.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index fbec5111..3bdf9953 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -725,7 +725,7 @@ end = struct let typ_aux = match typ_aux with | Typ_tup _ | Typ_app _ -> Typ_exist (existentials, List.fold_left nc_and (List.hd constrs) (List.tl constrs), typ) | Typ_exist (kids, nc, typ) -> Typ_exist (kids @ existentials, List.fold_left nc_and nc constrs, typ) - | Typ_fn _ | Typ_id _ | Typ_var _ -> assert false (* These must be simple *) + | Typ_fn _ | Typ_bidir _ | Typ_id _ | Typ_var _ -> assert false (* These must be simple *) in Typ_aux (typ_aux, l) @@ -3668,6 +3668,8 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as with | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m) end + | Typ_aux (typ, _) -> + typ_error l ("unifying mapping type, expanded synonyms to non-mapping type??") end | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env)-> typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) -- cgit v1.2.3 From 7e023f153a647bd4ac3f9fc6d1da5056cde7752a Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 17 May 2018 14:46:27 +0100 Subject: fix bug in rewrite_defs_pat_string_append -- make it pass types through correctly --- src/rewrites.ml | 128 ++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 78 insertions(+), 50 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 58ff885f..34cb327a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2861,22 +2861,25 @@ let fresh_stringappend_id () = stringappend_counter := !stringappend_counter + 1; id -let construct_bool_match match_on pexp = - let true_exp = (mk_exp (E_lit (mk_lit L_true))) in - let false_exp = (mk_exp (E_lit (mk_lit L_false))) in +let unk = Parse_ast.Unknown +let unkt = (Parse_ast.Unknown, None) + +let construct_bool_match env (match_on : tannot exp) (pexp : tannot pexp) : tannot exp = + let true_exp = annot_exp (E_lit (mk_lit L_true)) unk env bool_typ in + let false_exp = annot_exp (E_lit (mk_lit L_false)) unk env bool_typ in let true_pexp = match pexp with - | Pat_aux (Pat_exp (pat, exp), _) -> - mk_pexp (Pat_exp (pat, true_exp)) - | Pat_aux (Pat_when (pat, guards, exp), _) -> - mk_pexp (Pat_when (pat, guards, true_exp)) + | Pat_aux (Pat_exp (pat, exp), annot) -> + Pat_aux (Pat_exp (pat, true_exp), unkt) + | Pat_aux (Pat_when (pat, guards, exp), annot) -> + Pat_aux (Pat_when (pat, guards, true_exp), unkt) in - let false_pexp = mk_pexp (Pat_exp (mk_pat P_wild, false_exp)) in - mk_exp (E_case (match_on, [true_pexp; false_pexp])) + let false_pexp = Pat_aux (Pat_exp (annot_pat P_wild unk env (typ_of match_on), false_exp), unkt) in + annot_exp (E_case (match_on, [true_pexp; false_pexp])) unk env bool_typ let rec rewrite_defs_pat_string_append = - let rec rewrite_pat env (pat, guards, expr) = + let rec rewrite_pat env ((pat : tannot pat), (guards : tannot exp list), (expr : tannot exp)) = let guards_ref = ref guards in let expr_ref = ref expr in let folder p = @@ -2904,24 +2907,27 @@ let rec rewrite_defs_pat_string_append = stringappend_counter := !stringappend_counter + 1; (* construct drop expression -- string_drop(s#, strlen("lit")) *) - let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id id); mk_exp (E_app (mk_id "string_length", [mk_exp (E_lit lit)]))])) in + let drop_exp = annot_exp (E_app (mk_id "string_drop", [annot_exp (E_id id) unk env string_typ; annot_exp (E_app (mk_id "string_length", [annot_exp (E_lit lit) unk env string_typ])) unk env nat_typ])) unk env string_typ in (* recurse into pat2 *) let new_pat2_pexp = match rewrite_pat env (P_aux (P_string_append (pats), psa_annot), guards, expr) with - | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) - | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) + | pat, [], expr -> Pat_aux (Pat_exp (pat, expr), unkt) + | pat, gs, expr -> Pat_aux (Pat_when (pat, fold_typed_guards env gs, expr), unkt) in (* construct the two new guards *) - let guard1 = mk_exp (E_app (mk_id "string_startswith", [mk_exp (E_id id); mk_exp (E_lit lit)])) in - let guard2 = construct_bool_match drop_exp new_pat2_pexp in + let guard1 = annot_exp (E_app (mk_id "string_startswith", + [annot_exp (E_id id) unk env string_typ; + annot_exp (E_lit lit) unk env string_typ] + )) unk env bool_typ in + let guard2 = construct_bool_match env drop_exp new_pat2_pexp in (* construct new match expr *) - let new_expr = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + let new_expr = annot_exp (E_case (drop_exp, [new_pat2_pexp])) unk env (typ_of expr) in (* construct final result *) - mk_pat (P_id id), guard1 :: guard2 :: guards, new_expr + annot_pat (P_id id) unk env string_typ, guard1 :: guard2 :: guards, new_expr (* (builtin x) ^^ pat2 => expr ---> s# if match maybe_atoi s# { @@ -2962,54 +2968,76 @@ let rec rewrite_defs_pat_string_append = let len_id = fresh_stringappend_id () in (* construct drop expression -- string_drop(s#, len#) *) - let drop_exp = mk_exp (E_app (mk_id "string_drop", [mk_exp (E_id s_id); mk_exp (E_id len_id)])) in + let drop_exp = annot_exp (E_app (mk_id "string_drop", + [annot_exp (E_id s_id) unk env string_typ; + annot_exp (E_id len_id) unk env nat_typ])) + unk env string_typ in (* construct func expression -- maybe_atoi s# *) - let func_exp = mk_exp (E_app (mk_id mapping_prefix_func, [mk_exp (E_id s_id)])) in + let func_exp = annot_exp (E_app (mk_id mapping_prefix_func, + [annot_exp (E_id s_id) unk env string_typ])) + unk env mapping_inner_typ in (* construct some pattern -- Some (n#, len#) *) - let some_exp = mk_pat (P_app (mk_id "Some", [mk_pat (P_id n_id); mk_pat (P_id len_id)])) in + let opt_typ = app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [mapping_inner_typ; nat_typ]), unk)] in + let some_pat = annot_pat (P_app (mk_id "Some", + [annot_pat (P_id n_id) unk env mapping_inner_typ; + annot_pat (P_id len_id) unk env nat_typ])) + unk env opt_typ in (* construct None pattern *) - let none_exp = mk_pat (P_app (mk_id "None", [mk_pat (P_lit (mk_lit L_unit))])) in + let none_pat = annot_pat (P_app (mk_id "None", [annot_pat (P_lit (mk_lit L_unit)) unk env unit_typ])) unk env opt_typ in (* recurse into pat2 *) let new_pat2_pexp = match rewrite_pat env (P_aux (P_string_append (pats), psa_annot), guards, expr) with - | pat, [], expr -> mk_pexp (Pat_exp (pat, expr)) - | pat, gs, expr -> mk_pexp (Pat_when (pat, fold_guards gs, expr)) + | pat, [], expr -> Pat_aux (Pat_exp (pat, expr), unkt) + | pat, gs, expr -> Pat_aux (Pat_when (pat, fold_typed_guards env gs, expr), unkt) in (* construct the new guard *) - let guard_inner_match = construct_bool_match drop_exp new_pat2_pexp in - let new_guard = mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, guard_inner_match)); - mk_pexp (Pat_exp (none_exp, mk_exp (E_lit (mk_lit (L_false))))) - ])) in + let guard_inner_match = construct_bool_match env drop_exp new_pat2_pexp in + let new_guard = annot_exp (E_case (func_exp, [ + Pat_aux (Pat_exp (some_pat, guard_inner_match), unkt); + Pat_aux (Pat_exp (none_pat, annot_exp (E_lit (mk_lit (L_false))) unk env bool_typ), unkt) + ])) unk env bool_typ in (* construct the new match *) - let new_match = mk_exp (E_case (drop_exp, [new_pat2_pexp])) in + let new_match = annot_exp (E_case (drop_exp, [new_pat2_pexp])) unk env (typ_of expr) in (* construct the new let *) - let new_binding = mk_exp (E_cast (mapping_inner_typ, mk_exp (E_case (func_exp, [ - mk_pexp (Pat_exp (some_exp, mk_exp (E_tuple [ - mk_exp (E_id n_id); - mk_exp (E_id len_id) - ]))) - ])))) in + let new_binding = annot_exp (E_cast (mapping_inner_typ, + annot_exp (E_case (func_exp, [ + Pat_aux (Pat_exp (some_pat, + annot_exp (E_tuple [ + annot_exp (E_id n_id) unk env mapping_inner_typ; + annot_exp (E_id len_id) unk env nat_typ + ]) unk env (tuple_typ [mapping_inner_typ; nat_typ]) + ), unkt) + ])) unk env (tuple_typ [mapping_inner_typ; nat_typ]) + )) unk env mapping_inner_typ in let new_letbind = match arg_pats with | [] -> assert false - | [arg_pat] -> mk_letbind (mk_pat (P_tup [arg_pat; mk_pat (P_id len_id)])) new_binding - | arg_pats -> mk_letbind (mk_pat (P_tup [mk_pat (P_tup arg_pats); mk_pat (P_id len_id)])) new_binding + | [arg_pat] -> annot_letbind + (P_tup [arg_pat; annot_pat (P_id len_id) unk env nat_typ], new_binding) + unk env (tuple_typ [pat_typ_of arg_pat; nat_typ]) + | arg_pats -> annot_letbind + (P_tup + [annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map pat_typ_of arg_pats)); + annot_pat (P_id len_id) unk env nat_typ], + new_binding) + unk env (tuple_typ [tuple_typ (List.map pat_typ_of arg_pats); nat_typ]) in - let new_let = mk_exp (E_let (new_letbind, new_match)) in + let new_let = annot_exp (E_let (new_letbind, new_match)) unk env (typ_of expr) in (* construct final result *) - mk_pat (P_id s_id), new_guard :: guards, new_let + annot_pat (P_id s_id) unk env string_typ, + new_guard :: guards, + new_let | P_aux (P_string_append [pat], _) -> pat, guards, expr - | P_aux (P_string_append [], _) -> - mk_pat (P_lit (mk_lit (L_string ""))), guards, expr + | P_aux (P_string_append [], (l, _)) -> + annot_pat (P_lit (L_aux (L_string "", l))) l env string_typ, guards, expr | P_aux (P_string_append _, _) -> failwith ("encountered a variety of string append pattern that is not yet implemented: " ^ string_of_pat pat) @@ -3049,27 +3077,27 @@ let rec rewrite_defs_pat_string_append = | P_aux (P_wild, _) -> pat, guards, expr in - let rec rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) = - - let (pat, _, _, _) = destruct_pexp pexp in + let rec rewrite_pexp (Pat_aux (pexp_aux, pexp_annot) as pexp) = (* merge cases of Pat_exp and Pat_when *) - let (P_aux (p_aux, p_annot), guards, expr) = + let (P_aux (p_aux, p_annot) as pat, guards, expr) = match pexp_aux with | Pat_exp (pat, expr) -> (pat, [], expr) | Pat_when (pat, guard, expr) -> (pat, [guard], expr) in + let env = env_of_annot p_annot in + let (new_pat, new_guards, new_expr) = - rewrite_pat (env_of_annot p_annot) (strip_pat pat, List.map strip_exp guards, strip_exp expr) + rewrite_pat env (pat, guards, expr) in (* un-merge Pat_exp and Pat_when cases *) let new_pexp = match new_guards with - | [] -> mk_pexp (Pat_exp (new_pat, new_expr)) - | gs -> mk_pexp (Pat_when (new_pat, fold_guards gs, new_expr)) + | [] -> Pat_aux (Pat_exp (new_pat, new_expr), pexp_annot) + | gs -> Pat_aux (Pat_when (new_pat, fold_typed_guards env gs, new_expr), pexp_annot) in - check_case (pat_env_of pat) (pat_typ_of pat) new_pexp (typ_of expr) + new_pexp in pexp_rewriters rewrite_pexp @@ -3872,7 +3900,7 @@ let rewrite_defs_lem = [ ("remove_mapping_valspecs", remove_mapping_valspecs); ("pat_string_append", rewrite_defs_pat_string_append); ("mapping_builtins", rewrite_defs_mapping_patterns); - ("pat_lits", rewrite_defs_pat_lits); + (* ("pat_lits", rewrite_defs_pat_lits); *) ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); -- cgit v1.2.3 From 60c205b66a2b884e12c6b766a4c18320e89394b9 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 18 May 2018 13:43:20 +0100 Subject: more riscv mappings; riscv now builds successfully to lem which builds to isabelle (but isabelle almost certainly broken) --- src/gen_lib/sail_string.lem | 129 ++++++++++++++++++++++++++++++++++++++++++++ src/process_file.ml | 1 + src/rewrites.ml | 3 +- src/sail_lib.ml | 9 ++++ 4 files changed, 141 insertions(+), 1 deletion(-) create mode 100644 src/gen_lib/sail_string.lem (limited to 'src') diff --git a/src/gen_lib/sail_string.lem b/src/gen_lib/sail_string.lem new file mode 100644 index 00000000..f31e612b --- /dev/null +++ b/src/gen_lib/sail_string.lem @@ -0,0 +1,129 @@ +open import Pervasives +open import List +open import List_extra +open import String +open import String_extra + +open import Sail_operators_mwords +open import Sail_values + +val string_sub : string -> ii -> ii -> string +let string_sub str start len = + toString (take (natFromInteger len) (drop (natFromInteger start) (toCharList str))) + +val string_startswith : string -> string -> bool +let string_startswith str1 str2 = + let prefix = string_sub str1 0 (integerFromNat (stringLength str2)) in + (prefix = str2) + +val string_drop : string -> ii -> string +let string_drop str n = + toString (drop (natFromInteger n) (toCharList str)) + +val string_length : string -> ii +let string_length s = integerFromNat (stringLength s) + +let string_append = stringAppend + +(*********************************************** + * Begin stuff that should be in Lem Num_extra * + ***********************************************) + +val maybeIntegerOfString : string -> maybe integer + +declare ocaml target_rep function maybeIntegerOfString = `(fun s -> match int_of_string_opt s with None -> None | Some i -> Nat_big_num.of_int i)` +declare isabelle target_rep function maybeIntegerOfString = `maybeIntegerOfString` (* TODO FIXME *) +declare hol target_rep function maybeIntegerOfString = `maybeIntegerOfString` (* TODO FIXME *) + +(*********************************************** + * end stuff that should be in Lem Num_extra * + ***********************************************) + +let rec maybe_int_of_prefix s = + match s with + | "" -> Nothing + | str -> + let len = string_length str in + match maybeIntegerOfString str with + | Just n -> Just (n, len) + | Nothing -> maybe_int_of_prefix (string_sub str 0 (len - 1)) + end + end + +let maybe_int_of_string = maybeIntegerOfString + +val n_leading_spaces : string -> ii +let rec n_leading_spaces s = + match string_length s with + | 0 -> 0 + | 1 -> match s with + | " " -> 1 + | _ -> 0 + end + | len -> match nth s 0 with + | #' ' -> 1 + (n_leading_spaces (string_sub s 1 (len - 1))) + | _ -> 0 + end + end + +let opt_spaces_matches_prefix s = + Just ((), n_leading_spaces s) + +let spaces_matches_prefix s = + let n = n_leading_spaces s in + match n with + | 0 -> Nothing + | n -> Just ((), n) + end + +let hex_bits_6_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 64 then + Just ((of_int 6 n, len)) + else + Nothing + end + +let hex_bits_12_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 4096 then + Just ((of_int 12 n, len)) + else + Nothing + end + +let hex_bits_13_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 8192 then + Just ((of_int 13 n, len)) + else + Nothing + end + +let hex_bits_20_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 1048576 then + Just ((of_int 20 n, len)) + else + Nothing + end + +let hex_bits_21_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 2097152 then + Just ((of_int 21 n, len)) + else + Nothing + end + +let string_of_bits = string_of_vec diff --git a/src/process_file.ml b/src/process_file.ml index 1bf8eee9..7cab1266 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -295,6 +295,7 @@ let output_lem filename libs defs = "Pervasives_extra"; "Sail_instr_kinds"; "Sail_values"; + "Sail_string"; operators_module ] @ monad_modules in diff --git a/src/rewrites.ml b/src/rewrites.ml index 34cb327a..6772d78c 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -711,6 +711,7 @@ let remove_vector_concat_pat pat = let p_vector_concat pats = let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) + | P_lit _ -> P_aux (P_as (pat, fresh_id_v l), a) | P_id id -> P_aux (P_id id,a) | P_as (p,id) -> P_aux (P_as (p,id),a) | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) @@ -3900,7 +3901,7 @@ let rewrite_defs_lem = [ ("remove_mapping_valspecs", remove_mapping_valspecs); ("pat_string_append", rewrite_defs_pat_string_append); ("mapping_builtins", rewrite_defs_mapping_patterns); - (* ("pat_lits", rewrite_defs_pat_lits); *) + ("pat_lits", rewrite_defs_pat_lits); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 81685bec..6e2deff7 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -644,6 +644,15 @@ let spaces_matches_prefix s = | 0 -> ZNone () | n -> ZSome ((), Big_int.of_int n) +let hex_bits_6_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 64 then + ZSome ((bits_of_int 32 n, len)) + else + ZNone () let hex_bits_12_matches_prefix s = match maybe_int_of_prefix s with -- cgit v1.2.3 From d229327f6e4214604e39b1ae6292cd0146a6093f Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 18 May 2018 13:48:43 +0100 Subject: temporary HACK for aarch64: make rewrite_defs_pat_lits ignore strings --- src/rewrites.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 6772d78c..2e59436c 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3238,6 +3238,8 @@ let rewrite_defs_pat_lits = let counter = ref 0 in let rewrite_pat = function + (* HACK: ignore strings for now *) + | P_lit (L_aux (L_string _, _)) as p_aux, p_annot -> P_aux (p_aux, p_annot) | P_lit lit, p_annot -> let env = env_of_annot p_annot in let typ = typ_of_annot p_annot in -- cgit v1.2.3 From 9ef6c50df79066c3604e2775cbbaf7eeae5e5bc1 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 21 May 2018 14:11:46 +0100 Subject: fix bug in rewrite_defs_mapping_patterns where pattern-uses of mappings with multiple arguments weren't type-checking correctly --- src/rewrites.ml | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 2e59436c..5fe54f84 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3129,7 +3129,7 @@ let rewrite_defs_mapping_patterns = (plus 'infer the mapping type' shenanigans) *) | P_aux (P_app (mapping_id, arg_pats), p_annot) when Env.is_mapping mapping_id env -> - + let mapping_in_typ = typ_of_annot p_annot in let x = Env.get_val_spec mapping_id env in @@ -3142,6 +3142,13 @@ let rewrite_defs_mapping_patterns = "backwards" in + let mapping_out_typ = + if mapping_in_typ = typ2 then + typ2 + else + typ1 + in + let mapping_name = match mapping_id with | Id_aux (Id id, _) @@ -3152,21 +3159,21 @@ let rewrite_defs_mapping_patterns = let mapping_perform_id = mk_id (mapping_name ^ "_" ^ mapping_direction) in let s_id = fresh_mappingpatterns_id () in - let s_exp = annot_exp (E_id s_id) Parse_ast.Unknown env mapping_in_typ in - let new_guard = annot_exp (E_app (mapping_matches_id, [s_exp])) Parse_ast.Unknown env bool_typ in - let new_binding = annot_exp (E_app (mapping_perform_id, [s_exp])) Parse_ast.Unknown env typ2 in + let s_exp = annot_exp (E_id s_id) unk env mapping_in_typ in + let new_guard = annot_exp (E_app (mapping_matches_id, [s_exp])) unk env bool_typ in + let new_binding = annot_exp (E_app (mapping_perform_id, [s_exp])) unk env typ2 in let new_letbind = match arg_pats with | [] -> assert false - | [arg_pat] -> LB_aux (LB_val (arg_pat, new_binding), (Parse_ast.Unknown, None)) + | [arg_pat] -> LB_aux (LB_val (arg_pat, new_binding), unkt) | arg_pats -> - let (checked_tup, new_env, []) = infer_pat env (mk_pat (P_tup (List.map strip_pat arg_pats))) in - LB_aux (LB_val (checked_tup, new_binding), (Parse_ast.Unknown, None)) + let checked_tup = annot_pat (P_tup arg_pats) unk env mapping_out_typ in + LB_aux (LB_val (checked_tup, new_binding), unkt) in - let new_let = annot_exp (E_let (new_letbind, expr)) Parse_ast.Unknown env (typ_of expr) in + let new_let = annot_exp (E_let (new_letbind, expr)) unk env (typ_of expr) in + + annot_pat (P_id s_id) unk env mapping_in_typ, new_guard :: guards, new_let - annot_pat (P_id s_id) Parse_ast.Unknown env mapping_in_typ, new_guard :: guards, new_let - | P_aux (P_as (inner_pat, inner_id), p_annot) -> let inner_pat, guards, expr = rewrite_pat env (inner_pat, guards, expr) in P_aux (P_as (inner_pat, inner_id), p_annot), guards, expr -- cgit v1.2.3 From e65dca0c66e3a58c1b295bc0029f519a3eda333d Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 21 May 2018 15:20:59 +0100 Subject: further RISCV mapping: all extant non-compressed instructions done --- src/gen_lib/sail_string.lem | 10 ++++++++++ src/sail_lib.ml | 10 ++++++++++ 2 files changed, 20 insertions(+) (limited to 'src') diff --git a/src/gen_lib/sail_string.lem b/src/gen_lib/sail_string.lem index f31e612b..b1f0fbe3 100644 --- a/src/gen_lib/sail_string.lem +++ b/src/gen_lib/sail_string.lem @@ -76,6 +76,16 @@ let spaces_matches_prefix s = | n -> Just ((), n) end +let hex_bits_5_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 32 then + Just ((of_int 5 n, len)) + else + Nothing + end + let hex_bits_6_matches_prefix s = match maybe_int_of_prefix s with | Nothing -> Nothing diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 6e2deff7..3e304796 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -644,6 +644,16 @@ let spaces_matches_prefix s = | 0 -> ZNone () | n -> ZSome ((), Big_int.of_int n) +let hex_bits_5_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 32 then + ZSome ((bits_of_int 16 n, len)) + else + ZNone () + let hex_bits_6_matches_prefix s = match maybe_int_of_prefix s with | ZNone () -> ZNone () -- cgit v1.2.3 From ac26bb0a957288d2024204046ccf3717c36df870 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 23 May 2018 16:51:00 +0100 Subject: fix typo in error message in type_check.ml --- src/type_check.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 3bdf9953..6351e7d8 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3633,13 +3633,13 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin try - typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ1 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_mpat mpat) + then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers typ2 in let tpats, env, guards = @@ -3651,13 +3651,13 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | Unification_error (l, m) -> try typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); - typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); + typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); let unifiers, _, _ (* FIXME! *) = unify l env typ1 typ in typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); let arg_typ' = subst_unifiers unifiers typ2 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_mpat mpat) + then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers typ1 in let tpats, env, guards = -- cgit v1.2.3 From fd706bc10a21577861d1c909ceeeed523d43dc63 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 23 May 2018 16:51:31 +0100 Subject: riscv decode now uses mapping-decode and passes tests --- src/gen_lib/sail_string.lem | 15 +++++++++++++-- src/sail_lib.ml | 14 ++++++++++++-- 2 files changed, 25 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail_string.lem b/src/gen_lib/sail_string.lem index b1f0fbe3..07b39ddc 100644 --- a/src/gen_lib/sail_string.lem +++ b/src/gen_lib/sail_string.lem @@ -66,10 +66,10 @@ let rec n_leading_spaces s = end end -let opt_spaces_matches_prefix s = +let opt_spc_matches_prefix s = Just ((), n_leading_spaces s) -let spaces_matches_prefix s = +let spc_matches_prefix s = let n = n_leading_spaces s in match n with | 0 -> Nothing @@ -136,4 +136,15 @@ let hex_bits_21_matches_prefix s = Nothing end +let hex_bits_32_matches_prefix s = + match maybe_int_of_prefix s with + | Nothing -> Nothing + | Just (n, len) -> + if 0 <= n && n < 4294967296 then + Just ((of_int 2147483648 n, len)) + else + Nothing + end + + let string_of_bits = string_of_vec diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 3e304796..665ff3af 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -635,10 +635,10 @@ let rec n_leading_spaces s = end -let opt_spaces_matches_prefix s = +let opt_spc_matches_prefix s = ZSome ((), n_leading_spaces s |> Big_int.of_int) -let spaces_matches_prefix s = +let spc_matches_prefix s = let n = n_leading_spaces s in match n with | 0 -> ZNone () @@ -703,3 +703,13 @@ let hex_bits_21_matches_prefix s = ZSome ((bits_of_int 1048576 n, len)) else ZNone () + +let hex_bits_32_matches_prefix s = + match maybe_int_of_prefix s with + | ZNone () -> ZNone () + | ZSome (n, len) -> + let n = Big_int.to_int n in + if 0 <= n && n < 4294967296 then + ZSome ((bits_of_int 2147483648 n, len)) + else + ZNone () -- cgit v1.2.3 From 08227192a8068ac34b618cc218982e02b353127e Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 8 Jun 2018 16:35:31 +0100 Subject: type checking mappings: allow inferring based on the other side's id inferences --- src/ast_util.ml | 5 ++- src/ast_util.mli | 1 + src/type_check.ml | 117 ++++++++++++++++++++++++++++++++++++------------------ 3 files changed, 84 insertions(+), 39 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 82e39022..2b275f35 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -273,6 +273,7 @@ let mk_id_typ id = Typ_aux (Typ_id id, Parse_ast.Unknown) let mk_ord ord_aux = Ord_aux (ord_aux, Parse_ast.Unknown) +let unknown_typ = mk_typ Typ_internal_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") @@ -601,6 +602,7 @@ and string_of_nexp_aux = function let rec string_of_typ = function | Typ_aux (typ, l) -> string_of_typ_aux typ and string_of_typ_aux = function + | Typ_internal_unknown -> "" | Typ_id id -> string_of_id id | Typ_var kid -> string_of_kid kid | Typ_tup typs -> "(" ^ string_of_list ", " string_of_typ typs ^ ")" @@ -986,6 +988,7 @@ let rec tyvars_of_nc (NC_aux (nc, _)) = let rec tyvars_of_typ (Typ_aux (t,_)) = match t with + | Typ_internal_unknown -> KidSet.empty | Typ_id _ -> KidSet.empty | Typ_var kid -> KidSet.singleton kid | Typ_fn (t1,t2,_) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) @@ -1034,7 +1037,7 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = initial_check.ml. i.e. the rewriter should only encounter this case when re-writing those functions. *) wrap (E_id (prepend_id "typ_" (id_of_kid kid))) typ - | Typ_bidir _ | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) + | Typ_internal_unknown | Typ_bidir _ | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) and undefined_of_typ_args mwords l annot (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with | Typ_arg_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] diff --git a/src/ast_util.mli b/src/ast_util.mli index 6fb1c576..d23d56da 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -113,6 +113,7 @@ val mk_typ_arg : typ_arg_aux -> typ_arg val mk_id_typ : id -> typ (* Sail builtin types. *) +val unknown_typ : typ val int_typ : typ val nat_typ : typ val atom_typ : nexp -> typ diff --git a/src/type_check.ml b/src/type_check.ml index 6351e7d8..814672f1 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -160,6 +160,10 @@ let is_list (Typ_aux (typ_aux, _)) = when string_of_id f = "list" -> Some typ | _ -> None +let is_unknown_type = function + | (Typ_aux (Typ_internal_unknown, _)) -> true + | _ -> false + (* 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 @@ -228,6 +232,7 @@ and strip_order_aux = function | Ord_inc -> Ord_inc | Ord_dec -> Ord_dec and strip_typ_aux : typ_aux -> typ_aux = function + | Typ_internal_unknown -> Typ_internal_unknown | Typ_id id -> Typ_id (strip_id id) | Typ_var kid -> Typ_var (strip_kid kid) | Typ_fn (typ1, typ2, effect) -> Typ_fn (strip_typ typ1, strip_typ typ2, strip_effect effect) @@ -297,6 +302,7 @@ and nc_subst_nexp_aux l sv subst = function 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_internal_unknown -> Typ_internal_unknown | 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) @@ -313,6 +319,7 @@ and typ_subst_arg_nexp_aux sv subst = function 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_internal_unknown -> Typ_internal_unknown | 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) @@ -335,6 +342,7 @@ let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst 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_internal_unknown -> Typ_internal_unknown | 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) @@ -350,6 +358,7 @@ and typ_subst_arg_order_aux sv subst = function 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_internal_unknown -> Typ_internal_unknown | 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) @@ -425,6 +434,7 @@ module Env : sig val add_extern : id -> (string -> string option) -> t -> t val get_extern : id -> t -> string -> string val get_default_order : t -> order + val set_default_order : order_aux -> t -> t val set_default_order_inc : t -> t val set_default_order_dec : t -> t val add_enum : id -> id list -> t -> t @@ -444,6 +454,8 @@ module Env : sig val add_smt_op : id -> string -> t -> t val get_smt_op : id -> t -> string val have_smt_op : id -> t -> bool + val allow_unknowns : t -> bool + val set_allow_unknowns : bool -> t -> t (* Well formedness-checks *) val wf_typ : ?exs:KidSet.t -> t -> typ -> unit val wf_nexp : ?exs:KidSet.t -> t -> nexp -> unit @@ -486,6 +498,7 @@ end = struct ret_typ : typ option; poly_undefineds : bool; prove : t -> n_constraint -> bool; + allow_unknowns : bool; } let empty = @@ -513,10 +526,14 @@ end = struct ret_typ = None; poly_undefineds = false; prove = (fun _ _ -> false); + allow_unknowns = false; } let add_prover f env = { env with prove = f } + let allow_unknowns env = env.allow_unknowns + let set_allow_unknowns b env = { env with allow_unknowns = b } + 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) @@ -620,6 +637,7 @@ end = struct let rec expand_synonyms env (Typ_aux (typ, l) as t) = (* typ_debug (lazy ("Expanding synonyms for " ^ string_of_typ t)); *) match typ with + | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | 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_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l) @@ -672,6 +690,7 @@ end = struct (** Map over all nexps in a type - excluding those in existential constraints **) let rec map_nexps f (Typ_aux (typ_aux, l) as typ) = match typ_aux with + | Typ_internal_unknown | Typ_id _ | Typ_var _ -> typ | Typ_fn (arg_typ, ret_typ, effect) -> Typ_aux (Typ_fn (map_nexps f arg_typ, map_nexps f ret_typ, effect), l) | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2), l) @@ -1437,6 +1456,7 @@ let order_frees (Ord_aux (ord_aux, l)) = let rec typ_nexps (Typ_aux (typ_aux, l)) = match typ_aux with + | Typ_internal_unknown -> [] | Typ_id v -> [] | Typ_var kid -> [] | Typ_tup typs -> List.concat (List.map typ_nexps typs) @@ -1454,6 +1474,7 @@ and typ_arg_nexps (Typ_arg_aux (typ_arg_aux, l)) = let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = match typ_aux with + | Typ_internal_unknown -> KidSet.empty | Typ_id v -> KidSet.empty | Typ_var kid when KidSet.mem kid exs -> KidSet.empty | Typ_var kid -> KidSet.singleton kid @@ -1696,6 +1717,8 @@ let rec unify l env typ1 typ2 = let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) = typ_debug (lazy ("UNIFYING TYPES " ^ string_of_typ typ1 ^ " AND " ^ string_of_typ typ2)); match typ1_aux, typ2_aux with + | Typ_internal_unknown, _ + | _, Typ_internal_unknown when Env.allow_unknowns env -> 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) @@ -1844,6 +1867,7 @@ let rec alpha_equivalent env typ1 typ2 = let rec relabel (Typ_aux (aux, l) as typ) = let relabelled_aux = match aux with + | Typ_internal_unknown -> Typ_internal_unknown | Typ_id _ | Typ_var _ -> aux | Typ_fn (typ1, typ2, eff) -> Typ_fn (relabel typ1, relabel typ2, eff) | Typ_bidir (typ1, typ2) -> Typ_bidir (relabel typ1, relabel typ2) @@ -2301,9 +2325,9 @@ let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) - let strip_pexp : 'a pexp -> unit pexp = function pexp -> map_pexp_annot (fun (l, _) -> (l, ())) pexp let strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, _) -> (l, ())) lexp -let strip_mpat : 'a mpat -> unit mpat = function mpat -> map_mpat_annot (fun (l, _) -> (l, ())) mpat -let strip_mpexp : 'a mpexp -> unit mpexp = function mpexp -> map_mpexp_annot (fun (l, _) -> (l, ())) mpexp -let strip_mapcl : 'a mapcl -> unit mapcl = function mapcl -> map_mapcl_annot (fun (l, _) -> (l, ())) mapcl +let strip_mpat : 'a. 'a mpat -> unit mpat = function mpat -> map_mpat_annot (fun (l, _) -> (l, ())) mpat +let strip_mpexp : 'a. 'a mpexp -> unit mpexp = function mpexp -> map_mpexp_annot (fun (l, _) -> (l, ())) mpexp +let strip_mapcl : 'a. 'a mapcl -> unit mapcl = function mapcl -> map_mapcl_annot (fun (l, _) -> (l, ())) mapcl let fresh_var = let counter = ref 0 in @@ -2562,9 +2586,9 @@ and check_case env pat_typ pexp typ = check_case env pat_typ (Pat_aux (Pat_when (mk_pat (P_id (mk_id "p#")), guard, case), annot)) typ | _ -> raise typ_exn -and check_mpexp env mpexp typ = +and check_mpexp other_env env mpexp typ = let mpat,guard,((l,_) as annot) = destruct_mpexp mpexp in - match bind_mpat env mpat typ with + match bind_mpat false other_env env mpat typ with | checked_mpat, env, guards -> let guard = match guard, guards with | None, h::t -> Some (h,t) @@ -3506,7 +3530,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = typ_debug (lazy ("RETURNING AFTER COERCION " ^ string_of_typ (typ_of exp))); exp, !all_unifiers -and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = +and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = let (Typ_aux (typ_aux, _) as typ), env = bind_existential typ env in typ_print (lazy ("Binding " ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ)); let annot_mpat mpat typ = MP_aux (mpat, (l, Some (env, typ, no_effect))) in @@ -3515,7 +3539,7 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | _ -> typ_error l "Cannot switch type for unannotated mapping-pattern" in let bind_tuple_mpat (tpats, env, guards) mpat typ = - let tpat, env, guards' = bind_mpat env mpat typ in tpat :: tpats, env, guards' @ guards + let tpat, env, guards' = bind_mpat allow_unknown other_env env mpat typ in tpat :: tpats, env, guards' @ guards in match mpat_aux with | MP_id v -> @@ -3537,8 +3561,8 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as begin match Env.expand_synonyms env typ with | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> - let hd_mpat, env, hd_guards = bind_mpat env hd_mpat ltyp in - let tl_mpat, env, tl_guards = bind_mpat env tl_mpat typ in + let hd_mpat, env, hd_guards = bind_mpat allow_unknown other_env env hd_mpat ltyp in + let tl_mpat, env, tl_guards = bind_mpat allow_unknown other_env env tl_mpat typ in annot_mpat (MP_cons (hd_mpat, tl_mpat)) typ, env, hd_guards @ tl_guards | _ -> typ_error l "Cannot match cons mapping-pattern against non-list type" end @@ -3549,7 +3573,7 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as let rec process_mpats env = function | [] -> [], env, [] | pat :: pats -> - let pat', env, guards = bind_mpat env pat typ in + let pat', env, guards = bind_mpat allow_unknown other_env env pat typ in let pats', env, guards' = process_mpats env pats in pat' :: pats', env, guards @ guards' in @@ -3564,7 +3588,7 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as let rec process_mpats env = function | [] -> [], env, [] | (pat :: mpats) -> - let mpat', env, guards = bind_mpat env mpat ltyp in + let mpat', env, guards = bind_mpat allow_unknown other_env env mpat ltyp in let mpats', env, guards' = process_mpats env mpats in mpat' :: mpats', env, guards @ guards' in @@ -3671,14 +3695,14 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | Typ_aux (typ, _) -> typ_error l ("unifying mapping type, expanded synonyms to non-mapping type??") end - | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env)-> + | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env) -> typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) (* This is a special case for flow typing when we match a constant numeric literal. *) | MP_lit (L_aux (L_num n, _) as lit) when is_atom typ -> let nexp = match destruct_atom_nexp env typ with Some n -> n | None -> assert false in annot_mpat (MP_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, [] | _ -> - let (inferred_mpat, env, guards) = infer_mpat env mpat in + let (inferred_mpat, env, guards) = infer_mpat allow_unknown other_env env mpat in match subtyp l env typ (typ_of_mpat inferred_mpat) with | () -> switch_typ inferred_mpat (typ_of_mpat inferred_mpat), env, guards | exception (Type_error _ as typ_exn) -> @@ -3686,17 +3710,23 @@ and bind_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as | MP_lit lit -> let var = fresh_var () in let guard = mk_exp (E_app_infix (mk_exp (E_id var), mk_id "==", mk_exp (E_lit lit))) in - let (typed_mpat, env, guards) = bind_mpat env (mk_mpat (MP_id var)) typ in + let (typed_mpat, env, guards) = bind_mpat allow_unknown other_env env (mk_mpat (MP_id var)) typ in typed_mpat, env, guard::guards | _ -> raise typ_exn -and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = +and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) = let annot_mpat mpat typ = MP_aux (mpat, (l, Some (env, typ, no_effect))) in match mpat_aux with | MP_id v -> begin match Env.lookup_id v env with | Local (Immutable, _) | Unbound -> - typ_error l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation") + begin match Env.lookup_id v other_env with + | Local (Immutable, typ) -> annot_mpat (MP_typ (annot_mpat (MP_id v) typ, typ)) typ, env, [] + | Unbound -> + if allow_unknown then annot_mpat (MP_id v) unknown_typ, env, [] else + typ_error l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation") + | _ -> assert false + end | Local (Mutable, _) | Register _ -> typ_error l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat) | Enum enum -> annot_mpat (MP_id v) enum, env, [] @@ -3705,11 +3735,11 @@ and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = annot_mpat (MP_lit lit) (infer_lit env lit), env, [] | MP_typ (mpat, typ_annot) -> Env.wf_typ env typ_annot; - let (typed_mpat, env, guards) = bind_mpat env mpat typ_annot in + let (typed_mpat, env, guards) = bind_mpat allow_unknown other_env env mpat typ_annot in annot_mpat (MP_typ (typed_mpat, typ_annot)) typ_annot, env, guards | MP_vector (mpat :: mpats) -> let fold_mpats (mpats, env, guards) mpat = - let typed_mpat, env, guards' = bind_mpat env mpat bit_typ in + let typed_mpat, env, guards' = bind_mpat allow_unknown other_env env mpat bit_typ in mpats @ [typed_mpat], env, guards' @ guards in let mpats, env, guards = List.fold_left fold_mpats ([], env, []) (mpat :: mpats) in @@ -3719,22 +3749,25 @@ and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = annot_mpat (MP_vector mpats) (dvector_typ env len etyp), env, guards | MP_vector_concat (mpat :: mpats) -> let fold_mpats (mpats, env, guards) mpat = - let inferred_mpat, env, guards' = infer_mpat env mpat in + let inferred_mpat, env, guards' = infer_mpat allow_unknown other_env env mpat in mpats @ [inferred_mpat], env, guards' @ guards in let inferred_mpats, env, guards = List.fold_left fold_mpats ([], env, []) (mpat :: mpats) in - let (len, _, vtyp) = destruct_vec_typ l env (typ_of_mpat (List.hd inferred_mpats)) in - let fold_len len mpat = - let (len', _, vtyp') = destruct_vec_typ l env (typ_of_mpat mpat) in - typ_equality l env vtyp vtyp'; - nsum len len' - in - let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_mpats)) in - annot_mpat (MP_vector_concat inferred_mpats) (dvector_typ env len vtyp), env, guards + if allow_unknown && List.exists (fun mpat -> is_unknown_type (typ_of_mpat mpat)) inferred_mpats then + annot_mpat (MP_vector_concat inferred_mpats) unknown_typ, env, guards (* hack *) + else + let (len, _, vtyp) = destruct_vec_typ l env (typ_of_mpat (List.hd inferred_mpats)) in + let fold_len len mpat = + let (len', _, vtyp') = destruct_vec_typ l env (typ_of_mpat mpat) in + typ_equality l env vtyp vtyp'; + nsum len len' + in + let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_mpats)) in + annot_mpat (MP_vector_concat inferred_mpats) (dvector_typ env len vtyp), env, guards | MP_string_append mpats -> let fold_pats (pats, env, guards) pat = - let inferred_pat, env, guards' = infer_mpat env pat in + let inferred_pat, env, guards' = infer_mpat allow_unknown other_env env pat in typ_equality l env (typ_of_mpat inferred_pat) string_typ; pats @ [inferred_pat], env, guards' @ guards in @@ -3743,7 +3776,8 @@ and infer_mpat env (MP_aux (mpat_aux, (l, ())) as mpat) = in annot_mpat (MP_string_append typed_mpats) string_typ, env, guards - | _ -> typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) + | _ -> + typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) (**************************************************************************) (* 6. Effect system *) @@ -4139,15 +4173,22 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") -let check_mapcl env (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, _))) typ = - match typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> - begin - let typed_mpexp1, prop_eff1 = propagate_mpexp_effect (check_mpexp env (strip_mpexp mpexp1) typ1) in - let typed_mpexp2, prop_eff2 = propagate_mpexp_effect (check_mpexp env (strip_mpexp mpexp2) typ2) in - MCL_aux (MCL_mapcl (typed_mpexp1, typed_mpexp2), (l, Some (env, typ, union_effects prop_eff1 prop_eff2))) - end - | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") +let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = + fun env (MCL_aux (MCL_mapcl (mpexp1, mpexp2), (l, _))) typ -> + match typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> + begin + let testing_env = Env.set_allow_unknowns true env in + let left_mpat, _, _ = destruct_mpexp mpexp1 in + let _, left_id_env, _ = bind_mpat true Env.empty testing_env (strip_mpat left_mpat) typ1 in + let right_mpat, _, _ = destruct_mpexp mpexp2 in + let _, right_id_env, _ = bind_mpat true Env.empty testing_env (strip_mpat right_mpat) typ2 in + + let typed_mpexp1, prop_eff1 = propagate_mpexp_effect (check_mpexp right_id_env env (strip_mpexp mpexp1) typ1) in + let typed_mpexp2, prop_eff2 = propagate_mpexp_effect (check_mpexp left_id_env env (strip_mpexp mpexp2) typ2) in + MCL_aux (MCL_mapcl (typed_mpexp1, typed_mpexp2), (l, Some (env, typ, union_effects prop_eff1 prop_eff2))) + 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_pexp), (l, annot))) = -- cgit v1.2.3 From 0415ae13efc2e46887d45716913e30443df7517d Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 11 Jun 2018 10:26:06 +0100 Subject: better type inference of union-constructors and mappings --- src/type_check.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 814672f1..5c062b57 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2889,6 +2889,28 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = 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_app (f, mpats) when Env.is_union_constructor f env -> + begin + let (typq, ctor_typ) = Env.get_val_spec f env in + match Env.expand_synonyms env ctor_typ with + | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> + bind_pat env pat ret_typ + | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + end + | P_app (f, mpats) when Env.is_mapping f env -> + begin + let (typq, mapping_typ) = Env.get_val_spec f env in + match Env.expand_synonyms env mapping_typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> + begin + try + bind_pat env pat typ2 + with + | Type_error _ -> + bind_pat env pat typ1 + end + | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f) + end | P_typ (typ_annot, pat) -> Env.wf_typ env typ_annot; let (typed_pat, env, guards) = bind_pat env pat typ_annot in @@ -3731,6 +3753,28 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) typ_error l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat) | Enum enum -> annot_mpat (MP_id v) enum, env, [] end + | MP_app (f, mpats) when Env.is_union_constructor f env -> + begin + let (typq, ctor_typ) = Env.get_val_spec f env in + match Env.expand_synonyms env ctor_typ with + | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> + bind_mpat allow_unknown other_env env mpat ret_typ + | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + end + | MP_app (f, mpats) when Env.is_mapping f env -> + begin + let (typq, mapping_typ) = Env.get_val_spec f env in + match Env.expand_synonyms env mapping_typ with + | Typ_aux (Typ_bidir (typ1, typ2), _) -> + begin + try + bind_mpat allow_unknown other_env env mpat typ2 + with + | Type_error _ -> + bind_mpat allow_unknown other_env env mpat typ1 + end + | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f) + end | MP_lit lit -> annot_mpat (MP_lit lit) (infer_lit env lit), env, [] | MP_typ (mpat, typ_annot) -> -- cgit v1.2.3 From 5717bb3d0cef5932cb2b33bc66b3b2f0c0552164 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 11 Jun 2018 13:56:45 +0100 Subject: change double-caret for string-append-pattern to single caret, since that wouldn't be legal in a pattern anyway --- src/lexer.mll | 2 +- src/parser.mly | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/lexer.mll b/src/lexer.mll index a4ec4cc9..621a1a44 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -216,7 +216,7 @@ rule token = parse | "2" ws "^" { TwoCaret } | "^" { (Caret(r"^")) } | "::" { ColonColon(r "::") } - | "^^" { CaretCaret(r "^^") } + (* | "^^" { CaretCaret(r "^^") } *) | "~~" { TildeTilde(r "~~") } | ":" { Colon(r ":") } | "," { Comma } diff --git a/src/parser.mly b/src/parser.mly index 5c513e5b..375eb7d1 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -194,7 +194,7 @@ let rec desugar_rchain chain s e = %token String Bin Hex Real %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token Colon ColonColon CaretCaret TildeTilde ExclEq +%token Colon ColonColon (* CaretCaret *) TildeTilde ExclEq %token GtEq %token LtEq @@ -668,7 +668,7 @@ typschm_eof: pat_string_append: | atomic_pat { [$1] } - | atomic_pat CaretCaret pat_string_append + | atomic_pat Caret pat_string_append { $1 :: $3 } pat1: @@ -678,7 +678,7 @@ pat1: { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_pat ColonColon pat1 { mk_pat (P_cons ($1, $3)) $startpos $endpos } - | atomic_pat CaretCaret pat_string_append + | atomic_pat Caret pat_string_append { mk_pat (P_string_append ($1 :: $3)) $startpos $endpos } pat_concat: @@ -1223,7 +1223,7 @@ fun_def_list: mpat_string_append: | atomic_mpat { [$1] } - | atomic_mpat CaretCaret mpat_string_append + | atomic_mpat Caret mpat_string_append { $1 :: $3 } mpat: @@ -1233,7 +1233,7 @@ mpat: { mk_mpat (MP_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_mpat ColonColon mpat { mk_mpat (MP_cons ($1, $3)) $startpos $endpos } - | atomic_mpat CaretCaret mpat_string_append + | atomic_mpat Caret mpat_string_append { mk_mpat (MP_string_append ($1 :: $3)) $startpos $endpos } mpat_concat: -- cgit v1.2.3