From 68c6f25cc2e5a6be1d05b6ada36d020cc23387bd Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 23 Aug 2018 16:30:57 +0100 Subject: pat_to_exp support for vector and string concat patterns; fix typing in exp_of_mpat --- src/rewrites.ml | 67 +++++++++++++++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 7bc35681..895fa65a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -1159,8 +1159,10 @@ let subst_id_pat pat (id1,id2) = let subst_id_exp exp (id1,id2) = Ast_util.subst (Id_aux (id1,Parse_ast.Unknown)) (E_aux (E_id (Id_aux (id2,Parse_ast.Unknown)),(Parse_ast.Unknown,empty_tannot))) exp -let rec pat_to_exp (P_aux (pat,(l,annot))) = +let rec pat_to_exp ((P_aux (pat,(l,annot))) as p_aux) = let rewrap e = E_aux (e,(l,annot)) in + let env = pat_env_of p_aux in + let typ = pat_typ_of p_aux in match pat with | P_lit lit -> rewrap (E_lit lit) | P_wild -> raise (Reporting_basic.err_unreachable l @@ -1175,15 +1177,24 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) = | P_record (fpats,b) -> rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) - | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l - "pat_to_exp not implemented for P_vector_concat") - (* We assume that vector concatenation patterns have been transformed - away already *) + | P_vector_concat pats -> begin + let empty_vec = E_aux (E_vector [], (l,())) in + let concat_vectors vec1 vec2 = + E_aux (E_vector_append (vec1, vec2), (l, ())) + in + check_exp env (List.fold_right concat_vectors (List.map (fun p -> strip_exp (pat_to_exp p)) pats) empty_vec) typ + end | 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 (ps) -> raise (Reporting_basic.err_unreachable l - "pat_to_exp not implemented for P_string_append") + | P_string_append (pats) -> begin + let empty_string = E_aux (E_lit (L_aux (L_string "", l)), (l, ())) in + let string_append str1 str2 = + E_aux (E_app (mk_id "string_append", [str1; str2]), (l, ())) + in + check_exp env (List.fold_right string_append (List.map (fun p -> strip_exp (pat_to_exp p)) pats) empty_string) typ + end + and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) @@ -3899,30 +3910,30 @@ let merge_funcls (Defs defs) = 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) +let rec exp_of_mpat ((MP_aux (mpat, (l,annot))) as mp_aux) = + let empty_vec = E_aux (E_vector [], (l,())) in + let concat_vectors vec1 vec2 = + E_aux (E_vector_append (vec1, vec2), (l,())) 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) + let empty_string = E_aux (E_lit (L_aux (L_string "", Parse_ast.Unknown)), (l,())) in + let string_append str1 str2 = + E_aux (E_app (mk_id "string_append", [str1; str2]), (l,())) 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 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) - | MP_as (mpat, id) -> E_aux (E_case (E_aux (E_id id, annot), [ - Pat_aux (Pat_exp (pat_of_mpat mpat, exp_of_mpat mpat), annot) - ]), annot) (* TODO FIXME ditto *) + | MP_lit lit -> E_aux (E_lit lit, (l,annot)) + | MP_id id -> E_aux (E_id id, (l,annot)) + | MP_app (id, args) -> E_aux (E_app (id, (List.map exp_of_mpat args)), (l,annot)) + | MP_record (mfpats, flag) -> E_aux (E_record (fexps_of_mfpats mfpats flag (l,annot)), (l,annot)) + | MP_vector mpats -> E_aux (E_vector (List.map exp_of_mpat mpats), (l,annot)) + | MP_vector_concat mpats -> List.fold_right concat_vectors (List.map (fun m -> strip_exp (exp_of_mpat m)) mpats) empty_vec + | MP_tup mpats -> E_aux (E_tuple (List.map exp_of_mpat mpats), (l,annot)) + | MP_list mpats -> E_aux (E_list (List.map exp_of_mpat mpats), (l,annot)) + | MP_cons (mpat1, mpat2) -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), (l,annot)) + | MP_string_append mpats -> List.fold_right string_append (List.map (fun m -> strip_exp (exp_of_mpat m)) mpats) empty_string + | MP_typ (mpat, typ) -> E_aux (E_cast (typ, exp_of_mpat mpat), (l,annot)) + | MP_as (mpat, id) -> E_aux (E_case (E_aux (E_id id, (l,annot)), [ + Pat_aux (Pat_exp (pat_of_mpat mpat, exp_of_mpat mpat), (l,annot)) + ]), (l,annot)) (* TODO FIXME location information? *) and fexps_of_mfpats mfpats flag annot = -- cgit v1.2.3