diff options
Diffstat (limited to 'src')
46 files changed, 4246 insertions, 4974 deletions
diff --git a/src/LICENCE b/src/LICENCE index 6b6dcc4f..c777e037 100644 --- a/src/LICENCE +++ b/src/LICENCE @@ -20,8 +20,9 @@ Copyright (c) 2013-2017 All rights reserved. This software was developed by the University of Cambridge Computer -Laboratory as part of the Rigorous Engineering of Mainstream Systems -(REMS) project, funded by EPSRC grant EP/K008528/1. +Laboratory and the University of Edinburgh as part of the Rigorous +Engineering of Mainstream Systems (REMS) project, funded by EPSRC +grant EP/K008528/1. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions diff --git a/src/Makefile b/src/Makefile index abf03c4f..a39067b6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -57,14 +57,21 @@ all: sail lib doc full: sail lib power doc test -ast.ml: ../language/l2.ott - ott -sort false -generate_aux_rules true -o ast.ml -picky_multiple_parses true ../language/l2.ott +ast.lem: ../language/l2.ott + ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/l2.ott + +ast.ml: ast.lem + lem -ocaml ast.lem + sed -i -f ast.sed ast.ml lem_interp/interp_ast.lem: ../language/l2.ott ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott sail: ast.ml - ocamlbuild sail.native + ocamlbuild -use-ocamlfind sail.native + +isail: ast.ml + ocamlbuild -use-ocamlfind isail.native sail.native: sail @@ -84,7 +91,7 @@ SAIL_DIR:=$(realpath $(dir $(THIS_MAKEFILE))..) BITBUCKET_ROOT=$(realpath $(dir $(THIS_MAKEFILE))../..) LEM = $(BITBUCKET_ROOT)/lem/lem -LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib +LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib/_build_zarith ELFDIR= $(BITBUCKET_ROOT)/linksem ZARITH_DIR=$(LEMLIBOCAML)/dependencies/zarith ZARITH_LIB=$(ZARITH_DIR)/zarith.cma @@ -257,6 +264,7 @@ clean: -rm -rf lem lib -rm -rf sail.docdir -rm -f ast.ml + -rm -f ast.lem doc: ocamlbuild sail.docdir/index.html @@ -1,12 +1,16 @@ true: -traverse, debug, use_menhir <**/*.ml>: bin_annot, annot -<lem_interp> or <test>: include -<sail.{byte,native}>: use_pprint, use_nums, use_unix, use_str +# <lem_interp> or <test>: include +<sail.{byte,native}>: package(zarith), package(linksem), package(lem), use_pprint +<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), use_pprint +<isail.ml>: package(linenoise) +<elf_loader.ml>: package(linksem) <pprint> or <pprint/src>: include +<*.m{l,li}>: package(lem) # see http://caml.inria.fr/mantis/view.php?id=4943 -<lem_interp/*> and not <lem_interp/*.cmxa>: use_nums, use_lem -<test/*> and not <test/*.cmxa>: use_nums, use_lem, use_str +<lem_interp/*> and not <lem_interp/*.cmxa>: use_nums, package(lem) +<test/*> and not <test/*.cmxa>: use_nums, package(lem), use_str # disable partial match and unused variable warnings <**/*.ml>: warn_y diff --git a/src/ast.sed b/src/ast.sed new file mode 100644 index 00000000..39c58a50 --- /dev/null +++ b/src/ast.sed @@ -0,0 +1,2 @@ +s/type l = | Unknown/type l = Parse_ast.l/ +s/type value = | Val/open Value/ diff --git a/src/ast_util.ml b/src/ast_util.ml index 4ceb3e7f..206515c5 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -50,7 +50,7 @@ open Ast open Util -open Big_int +module Big_int = Nat_big_num let no_annot = (Parse_ast.Unknown, ()) @@ -141,7 +141,16 @@ module Nexp = struct match nexp1, nexp2 with | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 - | Nexp_constant c1, Nexp_constant c2 -> compare_big_int c1 c2 + | Nexp_constant c1, Nexp_constant c2 -> Big_int.compare c1 c2 + | Nexp_app (op1, args1), Nexp_app (op2, args2) -> + let lex1 = Id.compare op1 op2 in + let lex2 = List.length args1 - List.length args2 in + let lex3 = + if lex2 = 0 then + List.fold_left2 (fun l n1 n2 -> if compare n1 n2 = 0 then 0 else compare n1 n2) 0 args1 args2 + else 0 + in + lex_ord (lex1, lex_ord (lex2, lex3)) | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> @@ -172,6 +181,7 @@ let rec is_nexp_constant (Nexp_aux (nexp, _)) = match nexp with | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) -> is_nexp_constant n1 && is_nexp_constant n2 | Nexp_exp n | Nexp_neg n -> is_nexp_constant n + | Nexp_app (_, nexps) -> List.for_all is_nexp_constant nexps let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l) and nexp_simp_aux = function @@ -186,7 +196,7 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (add_big_int c1 c2) + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.add c1 c2) | _, Nexp_neg n2 -> Nexp_minus (n1, n2) | _, _ -> Nexp_sum (n1, n2) end @@ -195,9 +205,9 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c, _ when eq_big_int c unit_big_int -> n2_simp - | _, Nexp_constant c when eq_big_int c unit_big_int -> n1_simp - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (mult_big_int c1 c2) + | Nexp_constant c, _ when Big_int.equal c (Big_int.of_int 1) -> n2_simp + | _, Nexp_constant c when Big_int.equal c (Big_int.of_int 1) -> n1_simp + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.mul c1 c2) | _, _ -> Nexp_times (n1, n2) end | Nexp_minus (n1, n2) -> @@ -205,10 +215,10 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (sub_big_int c1 c2) + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.sub c1 c2) (* A vector range x['n-1 .. 0] can result in the size "('n-1) - -1" *) | Nexp_minus (Nexp_aux (n,_), Nexp_aux (Nexp_constant c1,_)), Nexp_constant c2 - when eq_big_int c1 (minus_big_int c2) -> n + when Big_int.equal c1 (Big_int.negate c2) -> n | _, _ -> Nexp_minus (n1, n2) end | nexp -> nexp @@ -228,6 +238,8 @@ let unit_typ = mk_id_typ (mk_id "unit") let bit_typ = mk_id_typ (mk_id "bit") let real_typ = mk_id_typ (mk_id "real") let app_typ id args = mk_typ (Typ_app (id, args)) +let ref_typ typ = mk_typ (Typ_app (mk_id "ref", [mk_typ_arg (Typ_arg_typ typ)])) +let register_typ typ = mk_typ (Typ_app (mk_id "register", [mk_typ_arg (Typ_arg_typ typ)])) let atom_typ nexp = mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp (nexp_simp nexp))])) let range_typ nexp1 nexp2 = @@ -239,17 +251,16 @@ let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (Typ_arg_typ typ)] let tuple_typ typs = mk_typ (Typ_tup typs) let function_typ typ1 typ2 eff = mk_typ (Typ_fn (typ1, typ2, eff)) -let vector_typ n m ord typ = +let vector_typ n ord typ = mk_typ (Typ_app (mk_id "vector", [mk_typ_arg (Typ_arg_nexp (nexp_simp n)); - mk_typ_arg (Typ_arg_nexp (nexp_simp m)); mk_typ_arg (Typ_arg_order ord); mk_typ_arg (Typ_arg_typ typ)])) let exc_typ = mk_id_typ (mk_id "exception") let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown) -let nint i = nconstant (big_int_of_int i) +let nint i = nconstant (Big_int.of_int i) let nminus n1 n2 = Nexp_aux (Nexp_minus (n1, n2), Parse_ast.Unknown) let nsum n1 n2 = Nexp_aux (Nexp_sum (n1, n2), Parse_ast.Unknown) let ntimes n1 n2 = Nexp_aux (Nexp_times (n1, n2), Parse_ast.Unknown) @@ -258,7 +269,7 @@ let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown) let nid id = Nexp_aux (Nexp_id id, Parse_ast.Unknown) let nc_set kid nums = mk_nc (NC_set (kid, nums)) -let nc_int_set kid ints = mk_nc (NC_set (kid, List.map big_int_of_int ints)) +let nc_int_set kid ints = mk_nc (NC_set (kid, List.map Big_int.of_int ints)) let nc_eq n1 n2 = mk_nc (NC_equal (n1, n2)) let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2)) let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown) @@ -329,6 +340,7 @@ and map_exp_annot_aux f = function | E_block xs -> E_block (List.map (map_exp_annot f) xs) | E_nondet xs -> E_nondet (List.map (map_exp_annot f) xs) | E_id id -> E_id id + | E_ref id -> E_ref id | E_lit lit -> E_lit lit | E_cast (typ, exp) -> E_cast (typ, map_exp_annot f exp) | E_app (id, xs) -> E_app (id, List.map (map_exp_annot f) xs) @@ -365,7 +377,8 @@ and map_exp_annot_aux f = function | E_internal_exp_user (annot1, annot2) -> E_internal_exp_user (f annot1, f annot2) | E_comment str -> E_comment str | E_comment_struc exp -> E_comment_struc (map_exp_annot f exp) - | E_internal_let (lexp, exp1, exp2) -> E_internal_let (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) + | E_internal_value v -> E_internal_value v + | E_var (lexp, exp1, exp2) -> E_var (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (map_pat_annot f pat, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_return exp -> E_internal_return (map_exp_annot f exp) and map_opt_default_annot f (Def_val_aux (df, annot)) = Def_val_aux (map_opt_default_annot_aux f df, f annot) @@ -400,6 +413,7 @@ and map_letbind_annot_aux f = function and map_lexp_annot f (LEXP_aux (lexp, annot)) = LEXP_aux (map_lexp_annot_aux f lexp, f annot) and map_lexp_annot_aux f = function | LEXP_id id -> LEXP_id id + | LEXP_deref exp -> LEXP_deref (map_exp_annot f exp) | LEXP_memory (id, exps) -> LEXP_memory (id, List.map (map_exp_annot f) exps) | LEXP_cast (typ, id) -> LEXP_cast (typ, id) | LEXP_tup lexps -> LEXP_tup (List.map (map_lexp_annot f) lexps) @@ -479,8 +493,6 @@ let string_of_base_effect = function | BE_aux (beff, _) -> string_of_base_effect_aux beff let string_of_effect = function - | Effect_aux (Effect_var kid, _) -> - string_of_kid kid | Effect_aux (Effect_set [], _) -> "pure" | Effect_aux (Effect_set beffs, _) -> "{" ^ string_of_list ", " string_of_base_effect beffs ^ "}" @@ -495,7 +507,7 @@ let rec string_of_nexp = function and string_of_nexp_aux = function | Nexp_id id -> string_of_id id | Nexp_var kid -> string_of_kid kid - | Nexp_constant c -> string_of_big_int c + | Nexp_constant c -> Big_int.to_string c | Nexp_times (n1, n2) -> "(" ^ string_of_nexp n1 ^ " * " ^ string_of_nexp n2 ^ ")" | Nexp_sum (n1, n2) -> "(" ^ string_of_nexp n1 ^ " + " ^ string_of_nexp n2 ^ ")" | Nexp_minus (n1, n2) -> "(" ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2 ^ ")" @@ -530,7 +542,7 @@ and string_of_n_constraint = function | NC_aux (NC_and (nc1, nc2), _) -> "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> - string_of_kid kid ^ " IN {" ^ string_of_list ", " string_of_big_int ns ^ "}" + string_of_kid kid ^ " IN {" ^ string_of_list ", " Big_int.to_string ns ^ "}" | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" @@ -563,7 +575,7 @@ let string_of_lit (L_aux (lit, _)) = | L_one -> "bitone" | L_true -> "true" | L_false -> "false" - | L_num n -> string_of_big_int n + | L_num n -> Big_int.to_string n | L_hex n -> "0x" ^ n | L_bin n -> "0b" ^ n | L_undef -> "undefined" @@ -574,6 +586,7 @@ let rec string_of_exp (E_aux (exp, _)) = match exp with | E_block exps -> "{ " ^ string_of_list "; " string_of_exp exps ^ " }" | E_id v -> string_of_id v + | E_ref id -> "ref " ^ string_of_id id | E_sizeof nexp -> "sizeof " ^ string_of_nexp nexp | E_constraint nc -> "constraint(" ^ string_of_n_constraint nc ^ ")" | E_lit lit -> string_of_lit lit @@ -620,7 +633,7 @@ let rec string_of_exp (E_aux (exp, _)) = | E_internal_exp_user _ -> "INTERNAL EXP USER" | E_comment _ -> "INTERNAL COMMENT" | E_comment_struc _ -> "INTERNAL COMMENT STRUC" - | E_internal_let _ -> "INTERNAL LET" + | E_var _ -> "INTERNAL LET" | E_internal_return exp -> "internal_return (" ^ string_of_exp exp ^ ")" | E_internal_plet (pat, exp, body) -> "internal_plet " ^ string_of_pat pat ^ " = " ^ string_of_exp exp ^ " in " ^ string_of_exp body | _ -> "INTERNAL" @@ -648,6 +661,7 @@ and string_of_pat (P_aux (pat, l)) = and string_of_lexp (LEXP_aux (lexp, _)) = match lexp with | LEXP_id v -> string_of_id v + | LEXP_deref exp -> "*(" ^ string_of_exp exp ^ ")" | LEXP_cast (typ, v) -> "(" ^ string_of_typ typ ^ ") " ^ string_of_id v | LEXP_tup lexps -> "(" ^ string_of_list ", " string_of_lexp lexps ^ ")" | LEXP_vector (lexp, exp) -> string_of_lexp lexp ^ "[" ^ string_of_exp exp ^ "]" @@ -655,15 +669,14 @@ and string_of_lexp (LEXP_aux (lexp, _)) = string_of_lexp lexp ^ "[" ^ string_of_exp exp1 ^ ".." ^ string_of_exp exp2 ^ "]" | LEXP_field (lexp, id) -> string_of_lexp lexp ^ "." ^ string_of_id id | LEXP_memory (f, xs) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")" - | _ -> "LEXP" and string_of_letbind (LB_aux (lb, l)) = match lb with | LB_val (pat, exp) -> string_of_pat pat ^ " = " ^ string_of_exp exp let rec string_of_index_range (BF_aux (ir, _)) = match ir with - | BF_single n -> string_of_big_int n - | BF_range (n, m) -> string_of_big_int n ^ " .. " ^ string_of_big_int m + | BF_single n -> Big_int.to_string n + | BF_range (n, m) -> Big_int.to_string n ^ " .. " ^ Big_int.to_string m | BF_concat (ir1, ir2) -> "(" ^ string_of_index_range ir1 ^ ") : (" ^ string_of_index_range ir2 ^ ")" let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = @@ -684,7 +697,7 @@ let id_of_type_def_aux = function | TD_record (id, _, _, _, _) | TD_variant (id, _, _, _, _) | TD_enum (id, _, _, _) - | TD_register (id, _, _, _) -> id + | TD_bitfield (id, _, _) -> id let id_of_type_def (TD_aux (td_aux, _)) = id_of_type_def_aux td_aux module BE = struct @@ -704,6 +717,7 @@ let rec nexp_frees (Nexp_aux (nexp, l)) = | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) | Nexp_exp n -> nexp_frees n | Nexp_neg n -> nexp_frees n + | Nexp_app (_, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map nexp_frees nexps) let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = let rewrap e_aux = E_aux (e_aux, annot) in @@ -720,6 +734,7 @@ let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = | LEXP_vector_range (lexp, e1, e2) -> rewrap (E_vector_subrange (lexp_to_exp lexp, e1, e2)) | LEXP_field (lexp, id) -> rewrap (E_field (lexp_to_exp lexp, id)) | LEXP_memory (id, exps) -> rewrap (E_app (id, exps)) + | LEXP_deref exp -> rewrap (E_app (mk_id "reg_deref", [exp])) let destruct_range (Typ_aux (typ_aux, _)) = match typ_aux with @@ -743,7 +758,7 @@ let is_reftyp (Typ_aux (typ_aux, _)) = match typ_aux with | _ -> false let rec is_vector_typ = function - | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_;_]), _) -> true + | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_]), _) -> true | Typ_aux (Typ_app (Id_aux (Id "register",_), [Typ_arg_aux (Typ_arg_typ rtyp,_)]), _) -> is_vector_typ rtyp | _ -> false @@ -756,8 +771,13 @@ let typ_app_args_of = function ("typ_app_args_of called on non-app type " ^ string_of_typ typ)) let rec vector_typ_args_of typ = match typ_app_args_of typ with - | ("vector", [Typ_arg_nexp start; Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], _) -> - (nexp_simp start, nexp_simp len, ord, etyp) + | ("vector", [Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], l) -> + begin + match ord with + | Ord_aux (Ord_inc, _) -> (nint 0, nexp_simp len, ord, etyp) + | Ord_aux (Ord_dec, _) -> (nexp_simp (nminus len (nint 1)), nexp_simp len, ord, etyp) (* FIXME to return 3 arguments *) + | _ -> raise (Reporting_basic.err_typ l "Can't calculate start index without order") + end | ("register", [Typ_arg_typ rtyp], _) -> vector_typ_args_of rtyp | (_, _, l) -> raise (Reporting_basic.err_typ l @@ -782,9 +802,6 @@ let is_bitvector_typ typ = let has_effect (Effect_aux (eff,_)) searched_for = match eff with | Effect_set effs -> List.exists (fun (BE_aux (be,_)) -> be = searched_for) effs - | Effect_var _ -> - raise (Reporting_basic.err_unreachable Parse_ast.Unknown - "has_effect called on effect variable") let effect_set (Effect_aux (eff,_)) = match eff with | Effect_set effs -> BESet.of_list effs @@ -796,13 +813,11 @@ let union_effects e1 e2 = | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> let base_effs3 = BESet.elements (BESet.of_list (base_effs1 @ base_effs2)) in Effect_aux (Effect_set base_effs3, Parse_ast.Unknown) - | _, _ -> assert false (* We don't do Effect variables *) let equal_effects e1 e2 = match e1, e2 with | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0 - | _, _ -> assert false (* We don't do Effect variables *) let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = match nexp with @@ -814,6 +829,7 @@ let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = | Nexp_minus (n1,n2) -> KidSet.union (tyvars_of_nexp n1) (tyvars_of_nexp n2) | Nexp_exp n | Nexp_neg n -> tyvars_of_nexp n + | Nexp_app (_, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_nexp nexps) let rec tyvars_of_typ (Typ_aux (t,_)) = match t with @@ -848,7 +864,9 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = wrap (E_sizeof i) typ | Typ_app (id, args) -> wrap (E_app (prepend_id "undefined_" id, - List.concat (List.map (undefined_of_typ_args mwords l annot) args))) typ + List.concat (List.map (undefined_of_typ_args mwords l annot) args))) typ + | Typ_tup typs -> + wrap (E_tuple (List.map (undefined_of_typ mwords l annot) typs)) typ | Typ_var kid -> (* Undefined monomorphism restriction in the type checker should guarantee that the typ_(kid) parameter was always one created @@ -856,7 +874,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 _ -> assert false + | 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 68955387..69bd5a52 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -49,7 +49,7 @@ (**************************************************************************) open Ast -open Big_int +module Big_int = Nat_big_num val no_annot : unit annot val gen_loc : Parse_ast.l -> Parse_ast.l @@ -103,10 +103,12 @@ val range_typ : nexp -> nexp -> typ val bit_typ : typ val bool_typ : typ val app_typ : id -> typ_arg list -> typ +val ref_typ : typ -> typ +val register_typ : typ -> typ val unit_typ : typ val string_typ : typ val real_typ : typ -val vector_typ : nexp -> nexp -> order -> typ -> typ +val vector_typ : nexp -> order -> typ -> typ val list_typ : typ -> typ val exc_typ : typ val tuple_typ : typ list -> typ @@ -118,7 +120,7 @@ val mk_effect : base_effect_aux list -> effect val nexp_simp : nexp -> nexp (* Utilities for building n-expressions *) -val nconstant : big_int -> nexp +val nconstant : Big_int.num -> nexp val nint : int -> nexp val nminus : nexp -> nexp -> nexp val nsum : nexp -> nexp -> nexp @@ -138,7 +140,7 @@ val nc_and : n_constraint -> n_constraint -> n_constraint val nc_or : n_constraint -> n_constraint -> n_constraint val nc_true : n_constraint val nc_false : n_constraint -val nc_set : kid -> big_int list -> n_constraint +val nc_set : kid -> Big_int.num list -> n_constraint val nc_int_set : kid -> int list -> n_constraint (* Negate a n_constraint. Note that there's no NC_not constructor, so diff --git a/src/bitfield.ml b/src/bitfield.ml new file mode 100644 index 00000000..db3411b1 --- /dev/null +++ b/src/bitfield.ml @@ -0,0 +1,130 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +module Big_int = Nat_big_num + +open Initial_check +open Ast +open Ast_util + +let bitvec size order = + Printf.sprintf "vector(%i, %s, bit)" size (string_of_order order) + +let rec combine = function + | [] -> Defs [] + | (Defs defs) :: ast -> + let (Defs defs') = combine ast in + Defs (defs @ defs') + +let newtype name size order = + let nt = Printf.sprintf "newtype %s = Mk_%s : %s" name name (bitvec size order) in + ast_of_def_string order nt + +(* These functions define the getter and setter for all the bits in the field. *) +let full_getter name size order = + let fg_val = Printf.sprintf "val _get_%s : %s -> %s" name name (bitvec size order) in + let fg_function = Printf.sprintf "function _get_%s Mk_%s(v) = v" name name in + combine [ast_of_def_string order fg_val; ast_of_def_string order fg_function] + +let full_setter name size order = + let fs_val = Printf.sprintf "val _set_%s : (register(%s), %s) -> unit effect {wreg}" name name (bitvec size order) in + let fs_function = String.concat "\n" + [ Printf.sprintf "function _set_%s (r_ref, v) = {" name; + " r = _reg_deref(r_ref);"; + Printf.sprintf " r = Mk_%s(v);" name; + " (*r_ref) = r"; + "}" + ] + in + combine [ast_of_def_string order fs_val; ast_of_def_string order fs_function] + +let full_overload name order = + ast_of_def_string order (Printf.sprintf "overload _mod_bits = {_get_%s, _set_%s}" name name) + +let full_accessor name size order = + combine [full_getter name size order; full_setter name size order; full_overload name order] + +(* For every index range, create a getter and setter *) +let index_range_getter' name field order start stop = + let size = if start > stop then start - (stop - 1) else stop - (start - 1) in + let irg_val = Printf.sprintf "val _get_%s : %s -> %s" field name (bitvec size order) in + let irg_function = Printf.sprintf "function _get_%s Mk_%s(v) = v[%i .. %i]" field name start stop in + combine [ast_of_def_string order irg_val; ast_of_def_string order irg_function] + +let index_range_setter' name field order start stop = + let size = if start > stop then start - (stop - 1) else stop - (start - 1) in + let irs_val = Printf.sprintf "val _set_%s : (register(%s), %s) -> unit effect {wreg}" field name (bitvec size order) in + let irs_function = String.concat "\n" + [ Printf.sprintf "function _set_%s (r_ref, v) = {" field; + Printf.sprintf " r = _get_%s(_reg_deref(r_ref));" name; + Printf.sprintf " r[%i .. %i] = v;" start stop; + Printf.sprintf " (*r_ref) = Mk_%s(r)" name; + "}" + ] + in + combine [ast_of_def_string order irs_val; ast_of_def_string order irs_function] + +let index_range_overload field order = + ast_of_def_string order (Printf.sprintf "overload _mod_%s = {_get_%s, _set_%s}" field field field) + +let index_range_accessor name field order (BF_aux (bf_aux, l)) = + let getter n m = index_range_getter' name field order (Big_int.to_int n) (Big_int.to_int m) in + let setter n m = index_range_setter' name field order (Big_int.to_int n) (Big_int.to_int m) in + let overload = index_range_overload field order in + match bf_aux with + | BF_single n -> combine [getter n n; setter n n; overload] + | BF_range (n, m) -> combine [getter n m; setter n m; overload] + | BF_concat _ -> failwith "Unimplemented" + +let field_accessor name order (id, ir) = index_range_accessor name (string_of_id id) order ir + +let macro id size order ranges = + let name = string_of_id id in + combine ([newtype name size order; full_accessor name size order] @ List.map (field_accessor name order) ranges) diff --git a/src/constraint.ml b/src/constraint.ml index 3d5a3689..ae72d956 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Util (* ===== Integer Constraints ===== *) @@ -58,13 +58,13 @@ type nexp_op = string type nexp = | NFun of (nexp_op * nexp list) | N2n of nexp - | NConstant of big_int + | NConstant of Big_int.num | NVar of int -let big_int_op : nexp_op -> (big_int -> big_int -> big_int) option = function - | "+" -> Some add_big_int - | "-" -> Some sub_big_int - | "*" -> Some mult_big_int +let big_int_op : nexp_op -> (Big_int.num -> Big_int.num -> Big_int.num) option = function + | "+" -> Some Big_int.add + | "-" -> Some Big_int.sub + | "*" -> Some Big_int.mul | _ -> None let rec arith constr = @@ -80,7 +80,7 @@ let rec arith constr = | Some op -> NConstant (op x y) | None -> c end - | N2n (NConstant x) -> NConstant (power_int_positive_big_int 2 x) + | N2n (NConstant x) -> NConstant (Big_int.pow_int_positive 2 (Big_int.to_int x)) | c -> c (* ===== Boolean Constraints ===== *) @@ -157,7 +157,7 @@ let cop_sexpr op x y = let rec sexpr_of_nexp = function | NFun (op, xs) -> sfun op (List.map sexpr_of_nexp xs) | N2n x -> sfun "^" [Atom "2"; sexpr_of_nexp x] - | NConstant c -> Atom (string_of_big_int c) (* CHECK: do we do negative constants right? *) + | NConstant c -> Atom (Big_int.to_string c) (* CHECK: do we do negative constants right? *) | NVar var -> Atom ("v" ^ string_of_int var) let rec sexpr_of_constraint = function @@ -303,6 +303,6 @@ let mult x y : nexp = NFun ("*", [x; y]) let app f xs : nexp = NFun (f, xs) -let constant (x : big_int) : nexp = NConstant x +let constant (x : Big_int.num) : nexp = NConstant x let variable (v : int) : nexp = NVar v diff --git a/src/constraint.mli b/src/constraint.mli index 89f2c625..2111a4e3 100644 --- a/src/constraint.mli +++ b/src/constraint.mli @@ -48,6 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) +module Big_int = Nat_big_num + type nexp type t @@ -80,5 +82,5 @@ val sub : nexp -> nexp -> nexp val mult : nexp -> nexp -> nexp val app : string -> nexp list -> nexp -val constant : Big_int.big_int -> nexp +val constant : Big_int.num -> nexp val variable : int -> nexp diff --git a/src/gen_lib/prompt.lem b/src/gen_lib/prompt.lem index 77a39096..744b6f7f 100644 --- a/src/gen_lib/prompt.lem +++ b/src/gen_lib/prompt.lem @@ -25,7 +25,6 @@ let rec bind m f = match m with | Internal descr o_s -> Internal descr (let (o,opt) = o_s in (bind o f ,opt)) end - let inline (>>=) = bind val (>>) : forall 'b 'e. M unit 'e -> M 'b 'e -> M 'b 'e let inline (>>) m n = m >>= fun (_ : unit) -> n diff --git a/src/initial_check.ml b/src/initial_check.ml index 689df577..5f3930b6 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -51,7 +51,7 @@ open Ast open Util open Ast_util -open Big_int +module Big_int = Nat_big_num let opt_undefined_gen = ref false let opt_magic_hash = ref false @@ -131,7 +131,7 @@ let string_of_parse_id_aux = function | Parse_ast.DeIid v -> v let string_contains str char = - try (String.index str char; true) with + try (ignore (String.index str char); true) with | Not_found -> false let to_ast_id (Parse_ast.Id_aux(id, l)) = @@ -185,12 +185,12 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) 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 (add_big_int (sub_big_int t b) unit_big_int),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 unit_big_int,Parse_ast.Unknown)), + 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 @@ -206,9 +206,9 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) | 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 (sub_big_int t unit_big_int),l) + | 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 - (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (minus_big_int unit_big_int),Parse_ast.Unknown)), + (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 | Ord_aux(Ord_inc,dl) -> (to_ast_nexp k_env b), (to_ast_nexp k_env r) @@ -291,10 +291,7 @@ and to_ast_effects (k_env : kind Envmap.t) (e : Parse_ast.atyp) : Ast.effect = 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_Efct -> Effect_var v - | K_infer -> k.k <- K_Efct; Effect_var v - | _ -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k)) + | Some k -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k) | None -> typ_error l "Encountered an unbound variable" None (Some v) None) | Parse_ast.ATyp_set(effects) -> Effect_set( List.map @@ -475,6 +472,7 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | None -> E_block(List.map (to_ast_exp k_env def_ord) exps)) | Parse_ast.E_nondet(exps) -> E_nondet(List.map (to_ast_exp k_env def_ord) exps) | Parse_ast.E_id(id) -> E_id(to_ast_id id) + | Parse_ast.E_ref(id) -> E_ref(to_ast_id id) | Parse_ast.E_lit(lit) -> E_lit(to_ast_lit lit) | Parse_ast.E_cast(typ,exp) -> E_cast(to_ast_typ k_env def_ord typ, to_ast_exp k_env def_ord exp) | Parse_ast.E_app(f,args) -> @@ -516,18 +514,21 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_try (exp, pexps) -> E_try (to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) | Parse_ast.E_let(leb,exp) -> E_let(to_ast_letbind k_env def_ord leb, to_ast_exp k_env def_ord exp) | Parse_ast.E_assign(lexp,exp) -> E_assign(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp) + | Parse_ast.E_var(lexp,exp1,exp2) -> E_var(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) | Parse_ast.E_sizeof(nexp) -> E_sizeof(to_ast_nexp k_env nexp) | Parse_ast.E_constraint nc -> E_constraint (to_ast_nexp_constraint k_env nc) | Parse_ast.E_exit exp -> E_exit(to_ast_exp k_env def_ord exp) | Parse_ast.E_throw exp -> E_throw (to_ast_exp k_env def_ord exp) | Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp) | Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg) + | _ -> raise (Reporting_basic.err_unreachable l "Unparsable construct in to_ast_exp") ), (l,())) and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp = LEXP_aux( (match exp with | Parse_ast.E_id(id) -> LEXP_id(to_ast_id id) + | Parse_ast.E_deref(exp) -> LEXP_deref(to_ast_exp k_env def_ord exp) | Parse_ast.E_cast(typ,Parse_ast.E_aux(Parse_ast.E_id(id),l')) -> LEXP_cast(to_ast_typ k_env def_ord typ, to_ast_id id) | Parse_ast.E_tuple(tups) -> @@ -535,7 +536,7 @@ and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l let is_ok_in_tup (LEXP_aux (le,(l,_))) = match le with | LEXP_id _ | LEXP_cast _ | LEXP_vector _ | LEXP_field _ | LEXP_vector_range _ | LEXP_tup _ -> () - | LEXP_memory _ -> + | LEXP_memory _ | LEXP_deref _ -> typ_error l "only identifiers, fields, and vectors may be set in a tuple" None None None in List.iter is_ok_in_tup ltups; LEXP_tup(ltups) @@ -690,13 +691,12 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_de let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *) let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in td_enum, (names,k_env,def_ord) - | Parse_ast.TD_register(id,t1,t2,ranges) -> + | Parse_ast.TD_bitfield(id,typ,ranges) -> let id = to_ast_id id in let key = id_to_string id in - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in - TD_aux(TD_register(id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) + let typ = to_ast_typ k_env def_ord typ in + let ranges = List.map (fun (id, range) -> (to_ast_id id, to_ast_range range)) ranges in + TD_aux(TD_bitfield(id,typ,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (unit kind_def) envs_out = match td with @@ -750,7 +750,7 @@ let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.funde (*let _ = Printf.eprintf "to_ast_fundef\n" in*) let tannot_opt, k_env,_ = to_ast_tannot_opt k_env def_ord tannot_opt in FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,())), (names,k_env,def_ord) - + type def_progress = No_def | Def_place_holder of id * Parse_ast.l @@ -826,6 +826,9 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_reg_dec(dec) -> let d = to_ast_dec envs dec in ((Finished(DEF_reg_dec(d))),envs),partial_defs + | 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) -> @@ -890,8 +893,8 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out ((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")))) - + | _ -> 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) | d::ds -> let ((d', envs), partial_defs) = to_ast_def envs partial_defs d in @@ -943,20 +946,26 @@ let initial_kind_env = ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})}); ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); + ("ref", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) }); - ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); + ("vector", {k = K_Lam( [{k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) }); ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} ); ("itself", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); ] +let exp_of_string order str = + let exp = Parser.exp_eof Lexer.token (Lexing.from_string str) in + to_ast_exp initial_kind_env order exp + let typschm_of_string order str = - let typschm = Parser2.typschm_eof Lexer2.token (Lexing.from_string str) in + let typschm = Parser.typschm_eof Lexer.token (Lexing.from_string str) in let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in typschm -let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) +let extern_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) +let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> None), false)) let val_spec_ids (Defs defs) = let val_spec_id (VS_aux (vs_aux, _)) = @@ -991,28 +1000,39 @@ let undefined_typschm id typq = let ret_typ = app_typ id (List.concat (List.map quant_item_arg qis)) in mk_typschm typq (mk_typ (Typ_fn (arg_typ, ret_typ, mk_effect [BE_undef]))) +let have_undefined_builtins = ref false + let generate_undefineds vs_ids (Defs defs) = let gen_vs id str = - if (IdSet.mem id vs_ids) then [] else [val_spec_of_string dec_ord id str] + if (IdSet.mem id vs_ids) then [] else [extern_of_string dec_ord id str] in - let undefined_builtins = List.concat - [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; - gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; - gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; - gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; - gen_vs (mk_id "undefined_nat") "unit -> nat effect {undef}"; - gen_vs (mk_id "undefined_real") "unit -> real effect {undef}"; - gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; - gen_vs (mk_id "undefined_list") "forall ('a:Type). 'a -> list('a) effect {undef}"; - gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; - (* FIXME: How to handle inc/dec order correctly? *) - gen_vs (mk_id "undefined_vector") "forall 'n 'm ('a:Type). (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}"; - (* Only used with lem_mwords *) - gen_vs (mk_id "undefined_bitvector") "forall 'n 'm. (atom('n), atom('m)) -> vector('n, 'm, dec,bit) effect {undef}"; - gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] + let undefined_builtins = + if !have_undefined_builtins then + [] + else + begin + have_undefined_builtins := true; + List.concat + [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; + gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; + gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; + gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; + gen_vs (mk_id "undefined_nat") "unit -> nat effect {undef}"; + gen_vs (mk_id "undefined_real") "unit -> real effect {undef}"; + gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; + gen_vs (mk_id "undefined_list") "forall ('a:Type). 'a -> list('a) effect {undef}"; + gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; + (* FIXME: How to handle inc/dec order correctly? *) + gen_vs (mk_id "undefined_vector") "forall 'n ('a:Type) ('ord : Order). (atom('n), 'a) -> vector('n, 'ord,'a) effect {undef}"; + (* Only used with lem_mwords *) + gen_vs (mk_id "undefined_bitvector") "forall 'n. atom('n) -> vector('n, dec, bit) effect {undef}"; + gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] + end in let undefined_tu = function | Tu_aux (Tu_id id, _) -> mk_exp (E_id id) + | Tu_aux (Tu_ty_id (Typ_aux (Typ_tup typs, _), id), _) -> + mk_exp (E_app (id, List.map (fun _ -> mk_lit_exp L_undef) typs)) | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef])) in let undefined_td = function @@ -1077,3 +1097,7 @@ let process_ast order defs = let ast = generate_undefineds vs_ids ast in generate_initialize_registers vs_ids ast end + +let ast_of_def_string order str = + let def = Parser.def_eof Lexer.token (Lexing.from_string str) in + process_ast order (Parse_ast.Defs [def]) diff --git a/src/initial_check.mli b/src/initial_check.mli index 01cf3bec..9d1e0d30 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -54,8 +54,11 @@ open Ast_util val opt_undefined_gen : bool ref val opt_magic_hash : bool ref +val ast_of_def_string : order -> string -> unit defs val process_ast : order -> Parse_ast.defs -> unit defs val val_spec_ids : 'a defs -> IdSet.t val val_spec_of_string : order -> id -> string -> unit def + +val exp_of_string : order -> string -> unit exp diff --git a/src/interpreter.ml b/src/interpreter.ml new file mode 100644 index 00000000..a0482f27 --- /dev/null +++ b/src/interpreter.ml @@ -0,0 +1,671 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Value + +type gstate = + { registers : value Bindings.t; + letbinds : (Type_check.tannot letbind) list; + } + +type lstate = + { locals : value Bindings.t } + +type state = lstate * gstate + +let rec ast_letbinds (Defs defs) = + match defs with + | [] -> [] + | DEF_val lb :: defs -> lb :: ast_letbinds (Defs defs) + | _ :: defs -> ast_letbinds (Defs defs) + +let initial_gstate ast = + { registers = Bindings.empty; + letbinds = ast_letbinds ast; + } + +let initial_lstate = + { locals = Bindings.empty } + +let initial_state ast = initial_lstate, initial_gstate ast + +let value_of_lit (L_aux (l_aux, _)) = + match l_aux with + | L_unit -> V_unit + | L_zero -> V_bit Sail_lib.B0 + | L_one -> V_bit Sail_lib.B1 + | L_true -> V_bool true + | L_false -> V_bool false + | L_string str -> V_string str + | L_num n -> V_int n + | L_hex str -> + Util.string_to_list str + |> List.map (fun c -> List.map (fun b -> V_bit b) (Sail_lib.hex_char c)) + |> List.concat + |> (fun v -> V_vector v) + | _ -> failwith "Unimplemented value_of_lit" (* TODO *) + +let is_value = function + | (E_aux (E_internal_value _, _)) -> true + | _ -> false + +let is_true = function + | (E_aux (E_internal_value (V_bool b), _)) -> b == true + | _ -> false + +let is_false = function + | (E_aux (E_internal_value (V_bool b), _)) -> b == false + | _ -> false + +let exp_of_value v = (E_aux (E_internal_value v, (Parse_ast.Unknown, None))) +let value_of_exp = function + | (E_aux (E_internal_value v, _)) -> v + | _ -> failwith "value_of_exp coerction failed" + +(**************************************************************************) +(* 1. Interpreter Monad *) +(**************************************************************************) + +type 'a response = + | Early_return of value + | Exception of value + | Assertion_failed of string + | Call of id * value list * (value -> 'a) + | Gets of (state -> 'a) + | Puts of state * (unit -> 'a) + +and 'a monad = + | Pure of 'a + | Yield of ('a monad response) + +let map_response f = function + | Early_return v -> Early_return v + | Exception v -> Exception v + | Assertion_failed str -> Assertion_failed str + | Gets g -> Gets (fun s -> f (g s)) + | Puts (s, cont) -> Puts (s, fun () -> f (cont ())) + | Call (id, vals, cont) -> Call (id, vals, fun v -> f (cont v)) + +let rec liftM f = function + | Pure x -> Pure (f x) + | Yield g -> Yield (map_response (liftM f) g) + +let return x = Pure x + +let rec bind m f = + match m with + | Pure x -> f x + | Yield m -> Yield (map_response (fun m -> bind m f) m) + +let ( >>= ) m f = bind m f + +let ( >> ) m1 m2 = bind m1 (function () -> m2) + +type ('a, 'b) either = + | Left of 'a + | Right of 'b + +(* Support for interpreting exceptions *) + +let catch m = + match m with + | Pure x -> Pure (Right x) + | Yield (Exception v) -> Pure (Left v) + | Yield resp -> Yield (map_response (fun m -> liftM (fun r -> Right r) m) resp) + +let call (f : id) (args : value list) : value monad = + Yield (Call (f, args, fun v -> Pure v)) + +let throw v = Yield (Exception v) + +let gets : state monad = + Yield (Gets (fun s -> Pure s)) + +let puts (s : state) : unit monad = + Yield (Puts (s, fun () -> Pure ())) + +let early_return v = Yield (Early_return v) + +let assertion_failed msg = Yield (Assertion_failed msg) + +let liftM2 f m1 m2 = m1 >>= fun x -> m2 >>= fun y -> return (f x y) + +let rec pat_ids (P_aux (pat_aux, _)) = + match pat_aux with + | P_lit _ | P_wild -> IdSet.empty + | P_id id -> IdSet.singleton id + | P_as (pat, id) -> IdSet.add id (pat_ids pat) + | P_var (pat, _) | P_typ (_, pat) -> pat_ids pat + | P_app (_, pats) | P_tup pats | P_vector pats | P_vector_concat pats | P_list pats -> + List.fold_right IdSet.union (List.map pat_ids pats) IdSet.empty + | P_cons (pat1, pat2) -> + IdSet.union (pat_ids pat1) (pat_ids pat2) + | P_record (fpats, _) -> + List.fold_right IdSet.union (List.map fpat_ids fpats) IdSet.empty +and fpat_ids (FP_aux (FP_Fpat (_, pat), _)) = pat_ids pat + +let letbind_pat_ids (LB_aux (LB_val (pat, _), _)) = pat_ids pat + +let rec subst id value (E_aux (e_aux, annot) as exp) = + let wrap e_aux = E_aux (e_aux, annot) in + let e_aux = match e_aux with + | E_block exps -> E_block (List.map (subst id value) exps) + | E_nondet exps -> E_nondet (List.map (subst id value) exps) + | E_id id' -> if Id.compare id id' = 0 then unaux_exp (exp_of_value value) else E_id id' + | E_lit lit -> E_lit lit + | E_cast (typ, exp) -> E_cast (typ, subst id value exp) + + | E_app (fn, exps) -> E_app (fn, List.map (subst id value) exps) + | E_app_infix (exp1, op, exp2) -> E_app_infix (subst id value exp1, op, subst id value exp2) + + | E_tuple exps -> E_tuple (List.map (subst id value) exps) + + | E_if (cond, then_exp, else_exp) -> + E_if (subst id value cond, subst id value then_exp, subst id value else_exp) + + | E_loop (loop, cond, body) -> + E_loop (loop, subst id value cond, subst id value body) + | E_for (id', exp1, exp2, exp3, order, body) when Id.compare id id' = 0 -> + E_for (id', exp1, exp2, exp3, order, body) + | E_for (id', exp1, exp2, exp3, order, body) -> + E_for (id', subst id value exp1, subst id value exp2, subst id value exp3, order, subst id value body) + + | E_vector exps -> E_vector (List.map (subst id value) exps) + | E_vector_access (exp1, exp2) -> E_vector_access (subst id value exp1, subst id value exp2) + | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (subst id value exp1, subst id value exp2, subst id value exp3) + | E_vector_update (exp1, exp2, exp3) -> E_vector_update (subst id value exp1, subst id value exp2, subst id value exp3) + | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> + E_vector_update_subrange (subst id value exp1, subst id value exp2, subst id value exp3, subst id value exp4) + | E_vector_append (exp1, exp2) -> E_vector_append (subst id value exp1, subst id value exp2) + + | E_list exps -> E_list (List.map (subst id value) exps) + | E_cons (exp1, exp2) -> E_cons (subst id value exp1, subst id value exp2) + + | E_record fexps -> E_record (subst_fexps id value fexps) + | E_record_update (exp, fexps) -> E_record_update (subst id value exp, subst_fexps id value fexps) + | E_field (exp, id') -> E_field (subst id value exp, id') + + | E_case (exp, pexps) -> + E_case (subst id value exp, List.map (subst_pexp id value) pexps) + + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) -> + E_let (LB_aux (LB_val (pat, subst id value bind), lb_annot), + if IdSet.mem id (pat_ids pat) then body else subst id value body) + + | E_assign (lexp, exp) -> E_assign (subst_lexp id value lexp, subst id value exp) (* Shadowing... *) + + (* Should be re-written *) + | E_sizeof nexp -> E_sizeof nexp + | E_constraint nc -> E_constraint nc + + | E_return exp -> E_return (subst id value exp) + | E_exit exp -> E_exit (subst id value exp) + (* Not sure about this, but id should always be immutable while id' must be mutable so should be ok. *) + | E_ref id' -> E_ref id' + | E_throw exp -> E_throw (subst id value exp) + + | E_try (exp, pexps) -> + E_try (subst id value exp, List.map (subst_pexp id value) pexps) + + | E_assert (exp1, exp2) -> E_assert (subst id value exp1, subst id value exp2) + + | E_internal_value v -> E_internal_value v + | _ -> failwith ("subst " ^ string_of_exp exp) + in + wrap e_aux + +and subst_pexp id value (Pat_aux (pexp_aux, annot)) = + let pexp_aux = match pexp_aux with + | Pat_exp (pat, exp) when IdSet.mem id (pat_ids pat) -> Pat_exp (pat, exp) + | Pat_exp (pat, exp) -> Pat_exp (pat, subst id value exp) + | Pat_when (pat, guard, exp) when IdSet.mem id (pat_ids pat) -> Pat_when (pat, guard, exp) + | Pat_when (pat, guard, exp) -> Pat_when (pat, subst id value guard, subst id value exp) + in + Pat_aux (pexp_aux, annot) + + +and subst_fexps id value (FES_aux (FES_Fexps (fexps, flag), annot)) = + FES_aux (FES_Fexps (List.map (subst_fexp id value) fexps, flag), annot) + +and subst_fexp id value (FE_aux (FE_Fexp (id', exp), annot)) = + FE_aux (FE_Fexp (id', subst id value exp), annot) + +and subst_lexp id value (LEXP_aux (lexp_aux, annot) as lexp) = + let wrap lexp_aux = LEXP_aux (lexp_aux, annot) in + let lexp_aux = match lexp_aux with + | LEXP_deref exp -> LEXP_deref (subst id value exp) + | LEXP_id id' -> LEXP_id id' + | LEXP_memory (f, exps) -> LEXP_memory (f, List.map (subst id value) exps) + | LEXP_cast (typ, id') -> LEXP_cast (typ, id') + | LEXP_tup lexps -> LEXP_tup (List.map (subst_lexp id value) lexps) + | LEXP_vector (lexp, exp) -> LEXP_vector (subst_lexp id value lexp, subst id value exp) + | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (subst_lexp id value lexp, subst id value exp1, subst id value exp2) + | LEXP_field (lexp, id') -> LEXP_field (subst_lexp id value lexp, id') + in + wrap lexp_aux + +(**************************************************************************) +(* 2. Expression Evaluation *) +(**************************************************************************) + +let unit_exp = E_lit (L_aux (L_unit, Parse_ast.Unknown)) + +let is_value_fexp (FE_aux (FE_Fexp (id, exp), _)) = is_value exp +let value_of_fexp (FE_aux (FE_Fexp (id, exp), _)) = (string_of_id id, value_of_exp exp) + +let rec build_letchain id lbs (E_aux (_, annot) as exp) = + (* print_endline ("LETCHAIN " ^ string_of_exp exp); *) + match lbs with + | [] -> exp + | lb :: lbs when IdSet.mem id (letbind_pat_ids lb)-> + let exp = E_aux (E_let (lb, exp), annot) in + build_letchain id lbs exp + | _ :: lbs -> build_letchain id lbs exp + +let rec step (E_aux (e_aux, annot) as orig_exp) = + let wrap e_aux' = return (E_aux (e_aux', annot)) in + match e_aux with + | E_block [] -> wrap (E_lit (L_aux (L_unit, Parse_ast.Unknown))) + | E_block [exp] when is_value exp -> return exp + | E_block (exp :: exps) when is_value exp -> wrap (E_block exps) + | E_block (exp :: exps) -> + step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) + + | E_lit lit -> return (exp_of_value (value_of_lit lit)) + + | E_if (exp, then_exp, else_exp) when is_true exp -> return then_exp + | E_if (exp, then_exp, else_exp) when is_false exp -> return else_exp + | E_if (exp, then_exp, else_exp) -> + step exp >>= fun exp' -> wrap (E_if (exp', then_exp, else_exp)) + + | E_loop (While, exp, body) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_loop (While, exp', body)) + | E_loop (While, exp, body) when is_true exp -> wrap (E_block [body; orig_exp]) + | E_loop (While, exp, body) when is_false exp -> wrap unit_exp + | E_loop _ -> assert false (* Impossible *) + + | E_assert (exp, msg) when is_true exp -> wrap unit_exp + | E_assert (exp, msg) when is_false exp -> assertion_failed "FIXME" + | E_assert (exp, msg) -> + step exp >>= fun exp' -> wrap (E_assert (exp', msg)) + + | E_vector exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_vector (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (V_vector (List.map value_of_exp evaluated))) + end + + | E_list exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_list (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (V_list (List.map value_of_exp evaluated))) + end + + (* Special rules for short circuting boolean operators *) + | E_app (id, [x; y]) when (string_of_id id = "and_bool" || string_of_id id = "or_bool") && not (is_value x) -> + step x >>= fun x' -> wrap (E_app (id, [x'; y])) + | E_app (id, [x; y]) when string_of_id id = "and_bool" && is_false x -> + return (exp_of_value (V_bool false)) + | E_app (id, [x; y]) when string_of_id id = "or_bool" && is_true x -> + return (exp_of_value (V_bool true)) + + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) when not (is_value bind) -> + step bind >>= fun bind' -> wrap (E_let (LB_aux (LB_val (pat, bind'), lb_annot), body)) + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) -> + let matched, bindings = pattern_match (Type_check.env_of orig_exp) pat (value_of_exp bind) in + if matched then + return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) + else + failwith "Match failure" + + | E_vector_update (vec, n, x) -> + wrap (E_app (mk_id "vector_update", [vec; n; x])) + + (* otherwise left-to-right evaluation order for function applications *) + | E_app (id, exps) -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + let open Type_check in + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_app (id, evaluated @ exp' :: exps)) + | [] when Env.is_union_constructor id (env_of_annot annot) -> + return (exp_of_value (V_ctor (string_of_id id, List.map value_of_exp evaluated))) + | [] when Env.is_extern id (env_of_annot annot) "interpreter" -> + begin + let extern = Env.get_extern id (env_of_annot annot) "interpreter" in + if extern = "reg_deref" then + let regname = List.hd evaluated |> value_of_exp |> coerce_ref in + gets >>= fun (_, gstate) -> + return (exp_of_value (Bindings.find (mk_id regname) gstate.registers)) + else + let primop = try StringMap.find extern primops with Not_found -> failwith ("No primop " ^ extern) in + return (exp_of_value (primop (List.map value_of_exp evaluated))) + end + | [] -> liftM exp_of_value (call id (List.map value_of_exp evaluated)) + end + | E_app_infix (x, id, y) when is_value x && is_value y -> + liftM exp_of_value (call id [value_of_exp x; value_of_exp y]) + | E_app_infix (x, id, y) when is_value x -> + step y >>= fun y' -> wrap (E_app_infix (x, id, y')) + | E_app_infix (x, id, y) -> + step x >>= fun x' -> wrap (E_app_infix (x', id, y)) + + | E_return exp when is_value exp -> early_return (value_of_exp exp) + | E_return exp -> step exp >>= fun exp' -> wrap (E_return exp') + + | E_tuple exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_tuple (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (tuple_value (List.map value_of_exp exps))) + end + + | E_case (exp, pexps) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_case (exp', pexps)) + | E_case (_, []) -> failwith "Pattern matching failed" + | E_case (exp, Pat_aux (Pat_exp (pat, body), _) :: pexps) -> + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) + else + wrap (E_case (exp, pexps)) + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when not (is_value guard) -> + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + let guard = List.fold_left (fun guard (id, v) -> subst id v guard) guard (Bindings.bindings bindings) in + let body = List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings) in + step guard >>= fun guard' -> + wrap (E_case (exp, Pat_aux (Pat_when (pat, guard', body), pat_annot) :: pexps)) + else + wrap (E_case (exp, pexps)) + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_true guard -> return body + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_false guard -> wrap (E_case (exp, pexps)) + + | E_cast (typ, exp) -> return exp + + | E_throw exp when is_value exp -> throw (value_of_exp exp) + | E_throw exp -> step exp >>= fun exp' -> wrap (E_throw exp') + | E_exit exp when is_value exp -> throw (V_ctor ("Exit", [value_of_exp exp])) + | E_exit exp -> step exp >>= fun exp' -> wrap (E_exit exp') + + | E_ref id -> return (exp_of_value (V_ref (string_of_id id))) + | E_id id -> + begin + let open Type_check in + gets >>= fun (lstate, gstate) -> + match Env.lookup_id id (env_of_annot annot) with + | Register _ -> + let exp = + try exp_of_value (Bindings.find id gstate.registers) with + | Not_found -> + let exp = mk_exp (E_app (mk_id ("undefined_" ^ string_of_typ (typ_of orig_exp)), [mk_exp (E_lit (mk_lit (L_unit)))])) in + Type_check.check_exp (env_of_annot annot) exp (typ_of orig_exp) + in + return exp + | Local (Mutable, _) -> return (exp_of_value (Bindings.find id lstate.locals)) + | Local (Immutable, _) -> + let chain = build_letchain id gstate.letbinds orig_exp in + return chain + | Enum _ -> + return (exp_of_value (V_ctor (string_of_id id, []))) + | _ -> failwith "id" + end + + | E_record (FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in + begin + match unevaluated with + | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> + step exp >>= fun exp' -> + wrap (E_record (FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + | [] -> + List.map value_of_fexp fexps + |> List.fold_left (fun record (field, v) -> StringMap.add field v record) StringMap.empty + |> (fun record -> V_record record) + |> exp_of_value + |> return + end + + | E_record_update (exp, fexps) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_record_update (exp', fexps)) + | E_record_update (record, FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in + begin + match unevaluated with + | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> + step exp >>= fun exp' -> + wrap (E_record_update (record, FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + | [] -> + List.map value_of_fexp fexps + |> List.fold_left (fun record (field, v) -> StringMap.add field v record) (coerce_record (value_of_exp record)) + |> (fun record -> V_record record) + |> exp_of_value + |> return + end + + | E_field (exp, id) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_field (exp', id)) + | E_field (exp, id) -> + let record = coerce_record (value_of_exp exp) in + return (exp_of_value (StringMap.find (string_of_id id) record)) + + | E_assign (lexp, exp) when not (is_value exp) -> step exp >>= fun exp' -> wrap (E_assign (lexp, exp')) + | E_assign (LEXP_aux (LEXP_memory (id, args), _), exp) -> wrap (E_app (id, args @ [exp])) + | E_assign (LEXP_aux (LEXP_field (lexp, id), ul), exp) -> + let open Type_check in + let lexp_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp lexp)) in + let exp' = E_aux (E_record_update (lexp_exp, FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), ul)], false), ul)), ul) in + wrap (E_assign (lexp, exp')) + | E_assign (LEXP_aux (LEXP_vector (vec, n), lexp_annot), exp) -> + let open Type_check in + let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in + let exp' = E_aux (E_vector_update (vec_exp, n, exp), lexp_annot) in + wrap (E_assign (vec, exp')) + | E_assign (LEXP_aux (LEXP_id id, _), exp) | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> + begin + let open Type_check in + gets >>= fun (lstate, gstate) -> + match Env.lookup_id id (env_of_annot annot) with + | Register _ -> + puts (lstate, { gstate with registers = Bindings.add id (value_of_exp exp) gstate.registers }) >> wrap unit_exp + | Local (Mutable, _) | Unbound -> + puts ({ locals = Bindings.add id (value_of_exp exp) lstate.locals }, gstate) >> wrap unit_exp + | _ -> failwith "Assign" + end + | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) when not (is_value reference) -> + step reference >>= fun reference' -> wrap (E_assign (LEXP_aux (LEXP_deref reference', annot), exp)) + | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) -> + let id = Id_aux (Id (coerce_ref (value_of_exp reference)), Parse_ast.Unknown) in + gets >>= fun (lstate, gstate) -> + puts (lstate, { gstate with registers = Bindings.add id (value_of_exp exp) gstate.registers }) >> wrap unit_exp + | E_assign (LEXP_aux (LEXP_tup lexps, annot), exp) -> failwith "Tuple assignment" + (* + let values = coerce_tuple (value_of_exp exp) in + wrap (E_block (List.map2 (fun lexp v -> E_aux (E_assign (lexp, exp_of_value v), (Parse_ast.Unknown, None))) lexps values)) + *) + | E_assign _ -> failwith (string_of_exp orig_exp); + + | E_try (exp, pexps) when is_value exp -> return exp + | E_try (exp, pexps) -> + begin + catch (step exp) >>= fun exp' -> + match exp' with + | Left exn -> wrap (E_case (exp_of_value exn, pexps)) + | Right exp' -> wrap (E_try (exp', pexps)) + end + + | E_sizeof _ | E_constraint _ -> assert false (* Must be re-written before interpreting *) + + | _ -> failwith ("Unimplemented " ^ string_of_exp orig_exp) + +and combine _ v1 v2 = + match (v1, v2) with + | None, None -> None + | Some v1, None -> Some v1 + | None, Some v2 -> Some v2 + | Some v1, Some v2 -> failwith "Pattern binds same identifier twice!" + +and exp_of_lexp (LEXP_aux (lexp_aux, _) as lexp) = + match lexp_aux with + | LEXP_id id -> mk_exp (E_id id) + | LEXP_memory (f, args) -> mk_exp (E_app (f, args)) + | LEXP_cast (typ, id) -> mk_exp (E_cast (typ, mk_exp (E_id id))) + | LEXP_deref exp -> mk_exp (E_app (mk_id "_reg_deref", [exp])) + | LEXP_tup lexps -> mk_exp (E_tuple (List.map exp_of_lexp lexps)) + | LEXP_vector (lexp, exp) -> mk_exp (E_vector_access (exp_of_lexp lexp, exp)) + | LEXP_vector_range (lexp, exp1, exp2) -> mk_exp (E_vector_subrange (exp_of_lexp lexp, exp1, exp2)) + | LEXP_field (lexp, id) -> mk_exp (E_field (exp_of_lexp lexp, id)) + +and pattern_match env (P_aux (p_aux, _) as pat) value = + (* print_endline ("Matching: " ^ string_of_pat pat ^ " with " ^ string_of_value value |> Util.yellow |> Util.clear); *) + match p_aux with + | P_lit lit -> eq_value (value_of_lit lit) value, Bindings.empty + | P_wild -> true, Bindings.empty + | P_as (pat, id) -> + let matched, bindings = pattern_match env pat value in + matched, Bindings.add id value bindings + | P_typ (_, pat) -> pattern_match env pat value + | P_id id -> + let open Type_check in + begin + match Env.lookup_id id env with + | Enum _ | Union _ -> + if is_ctor value && string_of_id id = fst (coerce_ctor value) + then true, Bindings.empty + else false, Bindings.empty + | _ -> true, Bindings.singleton id value + end + | P_var (pat, _) -> pattern_match env pat value + | P_app (id, pats) -> + let (ctor, vals) = coerce_ctor value in + if Id.compare id (mk_id ctor) = 0 then + let matches = List.map2 (pattern_match env) pats vals in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + else + false, Bindings.empty + | P_record _ -> assert false (* TODO *) + | P_vector pats -> + let matches = List.map2 (pattern_match env) pats (coerce_gv value) in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + | P_vector_concat _ -> assert false (* TODO *) + | P_tup pats | P_list pats -> + let matches = List.map2 (pattern_match env) pats (coerce_listlike value) in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + | P_cons _ -> assert false (* TODO *) + +let exp_of_fundef (FD_aux (FD_function (_, _, _, funcls), annot)) value = + let pexp_of_funcl (FCL_aux (FCL_Funcl (_, pexp), _)) = pexp in + E_aux (E_case (exp_of_value value, List.map pexp_of_funcl funcls), annot) + +let rec get_fundef id (Defs defs) = + match defs with + | [] -> failwith (string_of_id id ^ " definition not found") + | (DEF_fundef fdef) :: _ when Id.compare id (id_of_fundef fdef) = 0 -> fdef + | _ :: defs -> get_fundef id (Defs defs) + +let stack_cont (_, _, cont) = cont +let stack_string (str, _, _) = str +let stack_state (_, lstate, _) = lstate + +type frame = + | Done of state * value + | Step of string * state * (Type_check.tannot exp) monad * (string * lstate * (value -> (Type_check.tannot exp) monad)) list + | Break of frame + +let rec eval_frame' ast = function + | Done (state, v) -> Done (state, v) + | Break frame -> Break frame + | Step (out, state, m, stack) -> + match (m, stack) with + | Pure v, [] when is_value v -> Done (state, value_of_exp v) + | Pure v, (head :: stack') when is_value v -> + (* print_endline ("Returning value: " ^ string_of_value (value_of_exp v) |> Util.cyan |> Util.clear); *) + Step (stack_string head, (stack_state head, snd state), stack_cont head (value_of_exp v), stack') + | Pure exp', _ -> + let out' = Pretty_print_sail.to_string (Pretty_print_sail.doc_exp exp') in + Step (out', state, step exp', stack) + | Yield (Call(id, vals, cont)), _ when string_of_id id = "break" -> + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + let body = exp_of_fundef (get_fundef id ast) arg in + Break (Step ("", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack)) + | Yield (Call(id, vals, cont)), _ -> + (* print_endline ("Calling " ^ string_of_id id |> Util.cyan |> Util.clear); *) + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + let body = exp_of_fundef (get_fundef id ast) arg in + Step ("", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack) + | Yield (Gets cont), _ -> + eval_frame' ast (Step (out, state, cont state, stack)) + | Yield (Puts (state', cont)), _ -> + eval_frame' ast (Step (out, state', cont (), stack)) + | Yield (Early_return v), [] -> Done (state, v) + | Yield (Early_return v), (head :: stack') -> + (* print_endline ("Returning value: " ^ string_of_value v |> Util.cyan |> Util.clear); *) + Step (stack_string head, (stack_state head, snd state), stack_cont head v, stack') + | Yield (Assertion_failed msg), _ -> + failwith msg + | Yield (Exception v), _ -> + print_endline ("Uncaught Exception" |> Util.cyan |> Util.clear); + Done (state, v) + +let eval_frame ast frame = + try eval_frame' ast frame with + | Type_check.Type_error (l, err) -> + raise (Reporting_basic.err_typ l (Type_check.string_of_type_error err)) diff --git a/src/isail.ml b/src/isail.ml new file mode 100644 index 00000000..d8aa55c1 --- /dev/null +++ b/src/isail.ml @@ -0,0 +1,244 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Sail + +open Ast +open Ast_util +open Interpreter +open Pretty_print_sail + +type mode = + | Evaluation of frame + | Normal + +let current_mode = ref Normal + +let prompt () = + match !current_mode with + | Normal -> "sail> " + | Evaluation _ -> "eval> " + +let mode_clear () = + match !current_mode with + | Normal -> () + | Evaluation _ -> LNoise.clear_screen () + +let rec user_input callback = + match LNoise.linenoise (prompt ()) with + | None -> () + | Some v -> + mode_clear (); + begin + try callback v with + | Reporting_basic.Fatal_error e -> Reporting_basic.report_error e + end; + user_input callback + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" +let bold str = termcode 1 ^ str +let red str = termcode 91 ^ str +let clear str = str ^ termcode 0 + +let sail_logo = + let banner str = str |> bold |> red |> clear in + [ {| ___ ___ ___ ___ |}; + {| /\ \ /\ \ /\ \ /\__\|}; + {| /::\ \ /::\ \ _\:\ \ /:/ /|}; + {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |}; + {| \:\:\/__/ \/\::/ / \::/\/__/ \:\ \ |}; + {| \::/ / /:/ / \:\__\ \:\__\|}; + {| \/__/ \/__/ \/__/ \/__/|}; + "" + ] + |> List.map banner + +let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast) + +let print_program () = + match !current_mode with + | Normal -> () + | Evaluation (Step (out, _, _, stack)) -> + let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear in + List.map stack_string stack |> List.rev |> List.iter (fun code -> print_endline code; print_endline sep); + print_endline out + | Evaluation _ -> () + +let interactive_state = ref (initial_state !interactive_ast) + +let rec run () = + match !current_mode with + | Normal -> () + | Evaluation frame -> + begin + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + current_mode := Evaluation (eval_frame !interactive_ast frame); + run () + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let rec run_steps n = + match !current_mode with + | _ when n <= 0 -> () + | Normal -> () + | Evaluation frame -> + begin + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + current_mode := Evaluation (eval_frame !interactive_ast frame); + run_steps (n - 1) + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let handle_input input = + LNoise.history_add input |> ignore; + match !current_mode with + | Normal -> + begin + if input <> "" && input.[0] = ':' then + let n = try String.index input ' ' with Not_found -> String.length input in + let cmd = Str.string_before input n in + let arg = String.trim (Str.string_after input n) in + match cmd with + | ":t" | ":type" -> + let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !interactive_env in + pretty_sail stdout (doc_binding (typq, typ)); + print_newline (); + | ":elf" -> + Elf_loader.load_elf arg + | ":q" | ":quit" -> exit 0 + | ":i" | ":infer" -> + let exp = Initial_check.exp_of_string dec_ord arg in + let exp = Type_check.infer_exp !interactive_env exp in + pretty_sail stdout (doc_typ (Type_check.typ_of exp)); + print_newline () + | ":v" | ":verbose" -> + Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3; + print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug) + + | _ -> print_endline ("Unrecognised command " ^ input) + else if input <> "" then + let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string Ast_util.dec_ord input) in + current_mode := Evaluation (eval_frame !interactive_ast (Step ("", !interactive_state, return exp, []))); + print_program () + else () + end + | Evaluation frame -> + begin + if input <> "" && input.[0] = ':' then + let n = try String.index input ' ' with Not_found -> String.length input in + let cmd = Str.string_before input n in + let arg = String.trim (Str.string_after input n) in + match cmd with + | ":r" | ":run" -> + run () + | ":s" | ":step" -> + run_steps (int_of_string arg) + | ":q" | ":quit" -> exit 0 + | _ -> print_endline ("Unrecognised command " ^ input) + else + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + interactive_state := state; + current_mode := Evaluation (eval_frame !interactive_ast frame); + print_program () + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let () = + (* Auto complete function names based on val specs *) + LNoise.set_completion_callback + begin + fun line_so_far ln_completions -> + let line_so_far, last_id = + try + let p = Str.search_backward (Str.regexp "[^a-zA-Z0-9_]") line_so_far (String.length line_so_far - 1) in + Str.string_before line_so_far (p + 1), Str.string_after line_so_far (p + 1) + with + | Not_found -> "", line_so_far + | Invalid_argument _ -> line_so_far, "" + in + if last_id <> "" then + IdSet.elements !vs_ids + |> List.map string_of_id + |> List.filter (fun id -> Str.string_match (Str.regexp_string last_id) id 0) + |> List.map (fun completion -> line_so_far ^ completion) + |> List.iter (LNoise.add_completion ln_completions) + else () + end; + + LNoise.history_load ~filename:"sail_history" |> ignore; + LNoise.history_set ~max_length:100 |> ignore; + + if !opt_interactive then + begin + List.iter print_endline sail_logo; + user_input handle_input + end + else () diff --git a/src/lexer.mll b/src/lexer.mll index 35ab6627..ccbe12a5 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -50,7 +50,8 @@ { open Parser -open Big_int +module Big_int = Nat_big_num +open Parse_ast module M = Map.Make(String) exception LexError of string * Lexing.position @@ -58,81 +59,103 @@ let r = fun s -> s (* Ulib.Text.of_latin1 *) (* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) +let mk_operator prec n op = + match prec, n with + | Infix, 0 -> Op0 op + | Infix, 1 -> Op1 op + | Infix, 2 -> Op2 op + | Infix, 3 -> Op3 op + | Infix, 4 -> Op4 op + | Infix, 5 -> Op5 op + | Infix, 6 -> Op6 op + | Infix, 7 -> Op7 op + | Infix, 8 -> Op8 op + | Infix, 9 -> Op9 op + | InfixL, 0 -> Op0l op + | InfixL, 1 -> Op1l op + | InfixL, 2 -> Op2l op + | InfixL, 3 -> Op3l op + | InfixL, 4 -> Op4l op + | InfixL, 5 -> Op5l op + | InfixL, 6 -> Op6l op + | InfixL, 7 -> Op7l op + | InfixL, 8 -> Op8l op + | InfixL, 9 -> Op9l op + | InfixR, 0 -> Op0r op + | InfixR, 1 -> Op1r op + | InfixR, 2 -> Op2r op + | InfixR, 3 -> Op3r op + | InfixR, 4 -> Op4r op + | InfixR, 5 -> Op5r op + | InfixR, 6 -> Op6r op + | InfixR, 7 -> Op7r op + | InfixR, 8 -> Op8r op + | InfixR, 9 -> Op9r op + | _, _ -> assert false + +let operators = ref M.empty + let kw_table = List.fold_left (fun r (x,y) -> M.add x y r) M.empty [ ("and", (fun _ -> And)); - ("alias", (fun _ -> Alias)); ("as", (fun _ -> As)); ("assert", (fun _ -> Assert)); ("bitzero", (fun _ -> Bitzero)); ("bitone", (fun _ -> Bitone)); - ("bits", (fun _ -> Bits)); ("by", (fun _ -> By)); - ("case", (fun _ -> Case)); + ("match", (fun _ -> Match)); ("clause", (fun _ -> Clause)); - ("const", (fun _ -> Const)); ("dec", (fun _ -> Dec)); - ("def", (fun _ -> Def)); + ("operator", (fun _ -> Op)); ("default", (fun _ -> Default)); - ("deinfix", (fun _ -> Deinfix)); ("effect", (fun _ -> Effect)); - ("Effect", (fun _ -> EFFECT)); ("end", (fun _ -> End)); - ("enumerate", (fun _ -> Enumerate)); + ("enum", (fun _ -> Enum)); ("else", (fun _ -> Else)); ("exit", (fun _ -> Exit)); - ("extern", (fun _ -> Extern)); ("cast", (fun _ -> Cast)); ("false", (fun _ -> False)); - ("try", (fun _ -> Try)); - ("catch", (fun _ -> Catch)); - ("throw", (fun _ -> Throw)); ("forall", (fun _ -> Forall)); - ("exist", (fun _ -> Exist)); ("foreach", (fun _ -> Foreach)); ("function", (fun x -> Function_)); ("overload", (fun _ -> Overload)); + ("throw", (fun _ -> Throw)); + ("try", (fun _ -> Try)); + ("catch", (fun _ -> Catch)); ("if", (fun x -> If_)); ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); - ("IN", (fun x -> IN)); ("let", (fun x -> Let_)); - ("member", (fun x -> Member)); - ("Nat", (fun x -> Nat)); - ("Num", (fun x -> NatNum)); + ("var", (fun _ -> Var)); + ("ref", (fun _ -> Ref)); + ("record", (fun _ -> Record)); + ("Int", (fun x -> Int)); ("Order", (fun x -> Order)); ("pure", (fun x -> Pure)); - ("rec", (fun x -> Rec)); ("register", (fun x -> Register)); ("return", (fun x -> Return)); ("scattered", (fun x -> Scattered)); ("sizeof", (fun x -> Sizeof)); ("constraint", (fun x -> Constraint)); ("struct", (fun x -> Struct)); - ("switch", (fun x -> Switch)); ("then", (fun x -> Then)); ("true", (fun x -> True)); ("Type", (fun x -> TYPE)); - ("typedef", (fun x -> Typedef)); + ("type", (fun x -> Typedef)); ("undefined", (fun x -> Undefined)); ("union", (fun x -> Union)); + ("newtype", (fun x -> Newtype)); ("with", (fun x -> With)); - ("when", (fun x -> When)); - ("repeat", (fun x -> Repeat)); - ("until", (fun x -> Until)); - ("while", (fun x -> While)); - ("do", (fun x -> Do)); ("val", (fun x -> Val)); - - ("div", (fun x -> Div_)); - ("mod", (fun x -> Mod)); - ("mod_s", (fun x -> ModUnderS)); - ("quot", (fun x -> Quot)); - ("quot_s", (fun x -> QuotUnderS)); - ("rem", (fun x -> Rem)); + ("repeat", (fun _ -> Repeat)); + ("until", (fun _ -> Until)); + ("while", (fun _ -> While)); + ("do", (fun _ -> Do)); + ("mutual", (fun _ -> Mutual)); + ("bitfield", (fun _ -> Bitfield)); ("barr", (fun x -> Barr)); ("depend", (fun x -> Depend)); @@ -149,17 +172,14 @@ let kw_table = ("unspec", (fun x -> Unspec)); ("nondet", (fun x -> Nondet)); ("escape", (fun x -> Escape)); + ] -] -let default_type_names = ["bool";"unit";"vector";"range";"list";"bit";"nat"; "int"; "real"; - "uint8";"uint16";"uint32";"uint64";"atom";"implicit";"string";"option"] -let custom_type_names : string list ref = ref [] } let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z'] +let letter = ['a'-'z''A'-'Z''?'] let digit = ['0'-'9'] let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] @@ -167,7 +187,8 @@ let alphanum = letter|digit let startident = letter|'_' let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] +let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] +let operator = (oper_char+ ('_' ident)?) let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) rule token = parse @@ -176,162 +197,69 @@ rule token = parse | "\n" { Lexing.new_line lexbuf; token lexbuf } - | "&" { (Amp(r"&")) } - | "@" { (At(r"@")) } - | "|" { Bar } - | "^" { (Carrot(r"^")) } + | "@" { (At "@") } + | "2" ws "^" { TwoCaret } + | "^" { (Caret(r"^")) } | ":" { Colon(r ":") } | "," { Comma } + | ".." { DotDot } | "." { Dot } + | "==" as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } | "=" { (Eq(r"=")) } - | "!" { (Excl(r"!")) } | ">" { (Gt(r">")) } | "-" { Minus } | "<" { (Lt(r"<")) } | "+" { (Plus(r"+")) } | ";" { Semi } | "*" { (Star(r"*")) } - | "~" { (Tilde(r"~")) } | "_" { Under } + | "[|" { LsquareBar } + | "|]" { RsquareBar } + | "{|" { LcurlyBar } + | "|}" { RcurlyBar } + | "|" { Bar } | "{" { Lcurly } | "}" { Rcurly } + | "()" { Unit(r"()") } | "(" { Lparen } | ")" { Rparen } | "[" { Lsquare } | "]" { Rsquare } - | "&&" as i { (AmpAmp(r i)) } - | "||" { BarBar } - | "||]" { BarBarSquare } - | "|]" { BarSquare } - | "^^" { (CarrotCarrot(r"^^")) } - | "::" as i { (ColonColon(r i)) } - | ":=" { ColonEq } - | ":>" { ColonGt } - | ":]" { ColonSquare } - | ".." { DotDot } - | "==" { (EqEq(r"==")) } | "!=" { (ExclEq(r"!=")) } - | "!!" { (ExclExcl(r"!!")) } | ">=" { (GtEq(r">=")) } - | ">=+" { (GtEqPlus(r">=+")) } - | ">>" { (GtGt(r">>")) } - | ">>>" { (GtGtGt(r">>>")) } - | ">+" { (GtPlus(r">+")) } - | "#>>" { (HashGtGt(r"#>>")) } - | "#<<" { (HashLtLt(r"#<<")) } | "->" { MinusGt } - | "<:" { LtColon } + | "=>" { EqGt(r "=>") } | "<=" { (LtEq(r"<=")) } - | "<=+" { (LtEqPlus(r"<=+")) } - | "<>" { (LtGt(r"<>")) } - | "<<" { (LtLt(r"<<")) } - | "<<<" { (LtLtLt(r"<<<")) } - | "<+" { (LtPlus(r"<+")) } - | "**" { (StarStar(r"**")) } - | "[|" { SquareBar } - | "[||" { SquareBarBar } - | "[:" { SquareColon } - | "~^" { (TildeCarrot(r"~^")) } - - | "+_s" { (PlusUnderS(r"+_s")) } - | "-_s" { (MinusUnderS(r"-_s")) } - | ">=_s" { (GtEqUnderS(r">=_s")) } - | ">=_si" { (GtEqUnderSi(r">=_si")) } - | ">=_u" { (GtEqUnderU(r">=_u")) } - | ">=_ui" { (GtEqUnderUi(r">=_ui")) } - | ">>_u" { (GtGtUnderU(r">>_u")) } - | ">_s" { (GtUnderS(r">_s")) } - | ">_si" { (GtUnderSi(r">_si")) } - | ">_u" { (GtUnderU(r">_u")) } - | ">_ui" { (GtUnderUi(r">_ui")) } - | "<=_s" { (LtEqUnderS(r"<=_s")) } - | "<=_si" { (LtEqUnderSi(r"<=_si")) } - | "<=_u" { (LtEqUnderU(r"<=_u")) } - | "<=_ui" { (LtEqUnderUi(r"<=_ui")) } - | "<_s" { (LtUnderS(r"<_s")) } - | "<_si" { (LtUnderSi(r"<_si")) } - | "<_u" { (LtUnderU(r"<_u")) } - | "<_ui" { (LtUnderUi(r"<_ui")) } - | "*_s" { (StarUnderS(r"*_s")) } - | "**_s" { (StarStarUnderS(r"**_s")) } - | "**_si" { (StarStarUnderSi(r"**_si")) } - | "*_u" { (StarUnderU(r"*_u")) } - | "*_ui" { (StarUnderUi(r"*_ui")) } - | "2^" { (TwoCarrot(r"2^")) } - | "2**" { TwoStarStar } - - - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - + | "/*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } + | "*/" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } + | "infix" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator Infix (int_of_string (Char.escaped p)) op) !operators; + Fixity (Infix, Big_int.of_string (Char.escaped p), op) } + | "infixl" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixL (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixL, Big_int.of_string (Char.escaped p), op) } + | "infixr" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixR (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixR, Big_int.of_string (Char.escaped p), op) } + | operator as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } | tyvar_start startident ident* as i { TyVar(r i) } + | "~" { Id(r"~") } | startident ident* as i { if M.mem i kw_table then (M.find i kw_table) () - else if + (* else if List.mem i default_type_names || List.mem i !custom_type_names then - TyId(r i) - else Id(r i) } - | "&" oper_char+ as i { (AmpI(r i)) } - | "@" oper_char+ as i { (AtI(r i)) } - | "^" oper_char+ as i { (CarrotI(r i)) } - | "/" oper_char+ as i { (DivI(r i)) } - | "=" oper_char+ as i { (EqI(r i)) } - | "!" oper_char+ as i { (ExclI(r i)) } - | ">" oper_char+ as i { (GtI(r i)) } - | "<" oper_char+ as i { (LtI(r i)) } - | "+" oper_char+ as i { (PlusI(r i)) } - | "*" oper_char+ as i { (StarI(r i)) } - | "~" oper_char+ as i { (TildeI(r i)) } - | "&&" oper_char+ as i { (AmpAmpI(r i)) } - | "^^" oper_char+ as i { (CarrotCarrotI(r i)) } - | "::" oper_char+ as i { (ColonColonI(r i)) } - | "==" oper_char+ as i { (EqEqI(r i)) } - | "!=" oper_char+ as i { (ExclEqI(r i)) } - | "!!" oper_char+ as i { (ExclExclI(r i)) } - | ">=" oper_char+ as i { (GtEqI(r i)) } - | ">=+" oper_char+ as i { (GtEqPlusI(r i)) } - | ">>" oper_char+ as i { (GtGtI(r i)) } - | ">>>" oper_char+ as i { (GtGtGtI(r i)) } - | ">+" oper_char+ as i { (GtPlusI(r i)) } - | "#>>" oper_char+ as i { (HashGtGt(r i)) } - | "#<<" oper_char+ as i { (HashLtLt(r i)) } - | "<=" oper_char+ as i { (LtEqI(r i)) } - | "<=+" oper_char+ as i { (LtEqPlusI(r i)) } - | "<<" oper_char+ as i { (LtLtI(r i)) } - | "<<<" oper_char+ as i { (LtLtLtI(r i)) } - | "<+" oper_char+ as i { (LtPlusI(r i)) } - | "**" oper_char+ as i { (StarStarI(r i)) } - | "~^" oper_char+ as i { (TildeCarrot(r i)) } - - | ">=_s" oper_char+ as i { (GtEqUnderSI(r i)) } - | ">=_si" oper_char+ as i { (GtEqUnderSiI(r i)) } - | ">=_u" oper_char+ as i { (GtEqUnderUI(r i)) } - | ">=_ui" oper_char+ as i { (GtEqUnderUiI(r i)) } - | ">>_u" oper_char+ as i { (GtGtUnderUI(r i)) } - | ">_s" oper_char+ as i { (GtUnderSI(r i)) } - | ">_si" oper_char+ as i { (GtUnderSiI(r i)) } - | ">_u" oper_char+ as i { (GtUnderUI(r i)) } - | ">_ui" oper_char+ as i { (GtUnderUiI(r i)) } - | "<=_s" oper_char+ as i { (LtEqUnderSI(r i)) } - | "<=_si" oper_char+ as i { (LtEqUnderSiI(r i)) } - | "<=_u" oper_char+ as i { (LtEqUnderUI(r i)) } - | "<=_ui" oper_char+ as i { (LtEqUnderUiI(r i)) } - | "<_s" oper_char+ as i { (LtUnderSI(r i)) } - | "<_si" oper_char+ as i { (LtUnderSiI(r i)) } - | "<_u" oper_char+ as i { (LtUnderUI(r i)) } - | "<_ui" oper_char+ as i { (LtUnderUiI(r i)) } - | "**_s" oper_char+ as i { (StarStarUnderSI(r i)) } - | "**_si" oper_char+ as i { (StarStarUnderSiI(r i)) } - | "*_u" oper_char+ as i { (StarUnderUI(r i)) } - | "*_ui" oper_char+ as i { (StarUnderUiI(r i)) } - | "2^" oper_char+ as i { (TwoCarrotI(r i)) } - + TyId(r i) *) + else Id(r i) } | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } - | digit+ as i { (Num(big_int_of_string i)) } - | "-" digit+ as i { (Num(big_int_of_string i)) } + | digit+ as i { (Num(Big_int.of_string i)) } + | "-" digit+ as i { (Num(Big_int.of_string i)) } | "0b" (binarydigit+ as i) { (Bin(i)) } | "0x" (hexdigit+ as i) { (Hex(i)) } | '"' { (String( @@ -343,8 +271,8 @@ rule token = parse and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () + | "/*" { comment pos (depth+1) lexbuf } + | "*/" { if depth = 0 then () else if depth > 0 then comment pos (depth-1) lexbuf else assert false } | "\n" { Lexing.new_line lexbuf; diff --git a/src/lexer2.mll b/src/lexer2.mll deleted file mode 100644 index e43bd3e1..00000000 --- a/src/lexer2.mll +++ /dev/null @@ -1,294 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -{ -open Parser2 -open Big_int -open Parse_ast -module M = Map.Make(String) -exception LexError of string * Lexing.position - -let r = fun s -> s (* Ulib.Text.of_latin1 *) -(* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) -let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) - -let mk_operator prec n op = - match prec, n with - | Infix, 0 -> Op0 op - | Infix, 1 -> Op1 op - | Infix, 2 -> Op2 op - | Infix, 3 -> Op3 op - | Infix, 4 -> Op4 op - | Infix, 5 -> Op5 op - | Infix, 6 -> Op6 op - | Infix, 7 -> Op7 op - | Infix, 8 -> Op8 op - | Infix, 9 -> Op9 op - | InfixL, 0 -> Op0l op - | InfixL, 1 -> Op1l op - | InfixL, 2 -> Op2l op - | InfixL, 3 -> Op3l op - | InfixL, 4 -> Op4l op - | InfixL, 5 -> Op5l op - | InfixL, 6 -> Op6l op - | InfixL, 7 -> Op7l op - | InfixL, 8 -> Op8l op - | InfixL, 9 -> Op9l op - | InfixR, 0 -> Op0r op - | InfixR, 1 -> Op1r op - | InfixR, 2 -> Op2r op - | InfixR, 3 -> Op3r op - | InfixR, 4 -> Op4r op - | InfixR, 5 -> Op5r op - | InfixR, 6 -> Op6r op - | InfixR, 7 -> Op7r op - | InfixR, 8 -> Op8r op - | InfixR, 9 -> Op9r op - | _, _ -> assert false - -let operators = ref M.empty - -let kw_table = - List.fold_left - (fun r (x,y) -> M.add x y r) - M.empty - [ - ("and", (fun _ -> And)); - ("as", (fun _ -> As)); - ("assert", (fun _ -> Assert)); - ("bitzero", (fun _ -> Bitzero)); - ("bitone", (fun _ -> Bitone)); - ("by", (fun _ -> By)); - ("match", (fun _ -> Match)); - ("clause", (fun _ -> Clause)); - ("dec", (fun _ -> Dec)); - ("operator", (fun _ -> Op)); - ("default", (fun _ -> Default)); - ("effect", (fun _ -> Effect)); - ("end", (fun _ -> End)); - ("enum", (fun _ -> Enum)); - ("else", (fun _ -> Else)); - ("exit", (fun _ -> Exit)); - ("cast", (fun _ -> Cast)); - ("false", (fun _ -> False)); - ("forall", (fun _ -> Forall)); - ("foreach", (fun _ -> Foreach)); - ("function", (fun x -> Function_)); - ("overload", (fun _ -> Overload)); - ("throw", (fun _ -> Throw)); - ("try", (fun _ -> Try)); - ("catch", (fun _ -> Catch)); - ("if", (fun x -> If_)); - ("in", (fun x -> In)); - ("inc", (fun _ -> Inc)); - ("let", (fun x -> Let_)); - ("record", (fun _ -> Record)); - ("Int", (fun x -> Int)); - ("Order", (fun x -> Order)); - ("pure", (fun x -> Pure)); - ("register", (fun x -> Register)); - ("return", (fun x -> Return)); - ("scattered", (fun x -> Scattered)); - ("sizeof", (fun x -> Sizeof)); - ("constraint", (fun x -> Constraint)); - ("struct", (fun x -> Struct)); - ("then", (fun x -> Then)); - ("true", (fun x -> True)); - ("Type", (fun x -> TYPE)); - ("type", (fun x -> Typedef)); - ("undefined", (fun x -> Undefined)); - ("union", (fun x -> Union)); - ("with", (fun x -> With)); - ("val", (fun x -> Val)); - ("repeat", (fun _ -> Repeat)); - ("until", (fun _ -> Until)); - ("while", (fun _ -> While)); - ("do", (fun _ -> Do)); - ("mutual", (fun _ -> Mutual)); - - ("barr", (fun x -> Barr)); - ("depend", (fun x -> Depend)); - ("rreg", (fun x -> Rreg)); - ("wreg", (fun x -> Wreg)); - ("rmem", (fun x -> Rmem)); - ("rmemt", (fun x -> Rmemt)); - ("wmem", (fun x -> Wmem)); - ("wmv", (fun x -> Wmv)); - ("wmvt", (fun x -> Wmvt)); - ("eamem", (fun x -> Eamem)); - ("exmem", (fun x -> Exmem)); - ("undef", (fun x -> Undef)); - ("unspec", (fun x -> Unspec)); - ("nondet", (fun x -> Nondet)); - ("escape", (fun x -> Escape)); - ] - -} - -let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z''?'] -let digit = ['0'-'9'] -let binarydigit = ['0'-'1'] -let hexdigit = ['0'-'9''A'-'F''a'-'f'] -let alphanum = letter|digit -let startident = letter|'_' -let ident = alphanum|['_''\'''#'] -let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] -let operator = (oper_char+ ('_' ident)?) -let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) - -rule token = parse - | ws - { token lexbuf } - | "\n" - { Lexing.new_line lexbuf; - token lexbuf } - | "&" { (Amp(r"&")) } - | "@" { (At "@") } - | "2" ws "^" { TwoCaret } - | "^" { (Caret(r"^")) } - | ":" { Colon(r ":") } - | "," { Comma } - | ".." { DotDot } - | "." { Dot } - | "==" as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } - | "=" { (Eq(r"=")) } - | ">" { (Gt(r">")) } - | "-" { Minus } - | "<" { (Lt(r"<")) } - | "+" { (Plus(r"+")) } - | ";" { Semi } - | "*" { (Star(r"*")) } - | "_" { Under } - | "[|" { LsquareBar } - | "|]" { RsquareBar } - | "{|" { LcurlyBar } - | "|}" { RcurlyBar } - | "|" { Bar } - | "{" { Lcurly } - | "}" { Rcurly } - | "()" { Unit(r"()") } - | "(" { Lparen } - | ")" { Rparen } - | "[" { Lsquare } - | "]" { Rsquare } - | "!=" { (ExclEq(r"!=")) } - | ">=" { (GtEq(r">=")) } - | "->" { MinusGt } - | "=>" { EqGt(r "=>") } - | "<=" { (LtEq(r"<=")) } - | "infix" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator Infix (int_of_string (Char.escaped p)) op) !operators; - Fixity (Infix, big_int_of_string (Char.escaped p), op) } - | "infixl" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator InfixL (int_of_string (Char.escaped p)) op) !operators; - Fixity (InfixL, big_int_of_string (Char.escaped p), op) } - | "infixr" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator InfixR (int_of_string (Char.escaped p)) op) !operators; - Fixity (InfixR, big_int_of_string (Char.escaped p), op) } - | operator as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - | tyvar_start startident ident* as i { TyVar(r i) } - | "~" { Id(r"~") } - | startident ident* as i { if M.mem i kw_table then - (M.find i kw_table) () - (* else if - List.mem i default_type_names || - List.mem i !custom_type_names then - TyId(r i) *) - else Id(r i) } - | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } - | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } - | digit+ as i { (Num(big_int_of_string i)) } - | "-" digit+ as i { (Num(big_int_of_string i)) } - | "0b" (binarydigit+ as i) { (Bin(i)) } - | "0x" (hexdigit+ as i) { (Hex(i)) } - | '"' { (String( - string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf)) } - | eof { Eof } - | _ as c { raise (LexError( - Printf.sprintf "Unexpected character: %c" c, - Lexing.lexeme_start_p lexbuf)) } - - -and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () - else if depth > 0 then comment pos (depth-1) lexbuf - else assert false } - | "\n" { Lexing.new_line lexbuf; - comment pos depth lexbuf } - | '"' { ignore(string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf); - comment pos depth lexbuf } - | _ { comment pos depth lexbuf } - | eof { raise (LexError("Unbalanced comment", pos)) } - -and string pos b = parse - | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; - Buffer.add_string b i; - string pos b lexbuf } - | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } - | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } - | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } - | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "illegal backslash escape in string"*) } - | '"' { let s = unescaped(Buffer.contents b) in - (*try Ulib.UTF8.validate s; s - with Ulib.UTF8.Malformed_code -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal is not valid utf8"))) *) s } - | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal not terminated")))*) } diff --git a/src/monomorphise.ml b/src/monomorphise.ml index dd0edd64..4fa5d1d6 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -51,7 +51,7 @@ open Parse_ast open Ast open Ast_util -open Big_int +module Big_int = Nat_big_num open Type_check let size_set_limit = 8 @@ -102,7 +102,7 @@ let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = begin match KBindings.find kid substs with | Nexp_aux (Nexp_constant i,_) -> - if List.exists (fun j -> Big_int.eq_big_int i j) is then re NC_true else re NC_false + if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false | nexp -> raise (Reporting_basic.err_general l ("Unable to substitute " ^ string_of_nexp nexp ^ @@ -138,18 +138,18 @@ let subst_src_typ substs t = in s_styp substs t let make_vector_lit sz i = - let f j = if eq_big_int (mod_big_int (shift_right_big_int i (sz-j-1)) (big_int_of_int 2)) zero_big_int then '0' else '1' in + let f j = if Big_int.equal (Big_int.modulus (Big_int.shift_right i (sz-j-1)) (Big_int.of_int 2)) Big_int.zero then '0' else '1' in let s = String.init sz f in L_aux (L_bin s,Generated Unknown) let tabulate f n = let rec aux acc n = let acc' = f n::acc in - if eq_big_int n zero_big_int then acc' else aux acc' (sub_big_int n unit_big_int) - in if eq_big_int n zero_big_int then [] else aux [] (sub_big_int n unit_big_int) + if Big_int.equal n Big_int.zero then acc' else aux acc' (Big_int.sub n (Big_int.of_int 1)) + in if Big_int.equal n Big_int.zero then [] else aux [] (Big_int.sub n (Big_int.of_int 1)) let make_vectors sz = - tabulate (make_vector_lit sz) (shift_left_big_int unit_big_int sz) + tabulate (make_vector_lit sz) (Big_int.shift_left (Big_int.of_int 1) sz) let pat_id_is_variable env id = match Env.lookup_id id env with @@ -414,7 +414,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) = in let name_seg = function | (_,None) -> "" - | (k,Some i) -> string_of_kid k ^ string_of_big_int i + | (k,Some i) -> string_of_kid k ^ Big_int.to_string i in let name l i = String.concat "_" (i::(List.map name_seg l)) in Some (List.map (fun (l,ty) -> (l, wrap (name l),ty)) variants) @@ -423,11 +423,11 @@ let reduce_nexp subst ne = let rec eval (Nexp_aux (ne,_) as nexp) = match ne with | Nexp_constant i -> i - | Nexp_sum (n1,n2) -> add_big_int (eval n1) (eval n2) - | Nexp_minus (n1,n2) -> sub_big_int (eval n1) (eval n2) - | Nexp_times (n1,n2) -> mult_big_int (eval n1) (eval n2) - | Nexp_exp n -> shift_left_big_int (eval n) 1 - | Nexp_neg n -> minus_big_int (eval n) + | Nexp_sum (n1,n2) -> Big_int.add (eval n1) (eval n2) + | Nexp_minus (n1,n2) -> Big_int.sub (eval n1) (eval n2) + | Nexp_times (n1,n2) -> Big_int.mul (eval n1) (eval n2) + | Nexp_exp n -> Big_int.shift_left (eval n) 1 + | Nexp_neg n -> Big_int.negate (eval n) | _ -> raise (Reporting_basic.err_general Unknown ("Couldn't turn nexp " ^ string_of_nexp nexp ^ " into concrete value")) @@ -467,7 +467,7 @@ let refine_constructor refinements l env id args = (fun v (_,w) -> match v,w with | _,None -> true - | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> eq_big_int n m + | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> Big_int.equal n m | _,_ -> false) bindings mapping in match List.find matches_refinement irefinements with @@ -553,7 +553,7 @@ let nexp_subst_fns substs = | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2)) | E_internal_cast ((l,ann),e) -> re (E_internal_cast ((l,s_tannot ann),s_exp e)) | E_comment_struc e -> re (E_comment_struc e) - | E_internal_let (le,e1,e2) -> re (E_internal_let (s_lexp le, s_exp e1, s_exp e2)) + | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2)) | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2)) | E_internal_return e -> re (E_internal_return (s_exp e)) | E_throw e -> re (E_throw (s_exp e)) @@ -619,7 +619,7 @@ let remove_bound env pat = let lit_match = function | (L_zero | L_false), (L_zero | L_false) -> true | (L_one | L_true ), (L_one | L_true ) -> true - | L_num i1, L_num i2 -> eq_big_int i1 i2 + | L_num i1, L_num i2 -> Big_int.equal i1 i2 | l1,l2 -> l1 = l2 (* There's no undefined nexp, so replace undefined sizes with a plausible size. @@ -685,7 +685,7 @@ let reduce_cast typ exp l annot = if prove nc_env nc then exp else raise (Reporting_basic.err_unreachable l - ("Constant propagation error: literal " ^ string_of_big_int n ^ + ("Constant propagation error: literal " ^ Big_int.to_string n ^ " does not satisfy constraint " ^ string_of_n_constraint nc)) | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> let nexp = fabricate_nexp_exist env Unknown typ [kid] nc typ'' in @@ -713,8 +713,8 @@ let rec drop_casts = function | exp -> exp let int_of_str_lit = function - | L_hex hex -> big_int_of_string ("0x" ^ hex) - | L_bin bin -> big_int_of_string ("0b" ^ bin) + | L_hex hex -> Big_int.of_string ("0x" ^ hex) + | L_bin bin -> Big_int.of_string ("0b" ^ bin) | _ -> assert false let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = @@ -723,9 +723,9 @@ let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = | (L_one |L_true ), (L_one |L_true) -> Some true | (L_hex _| L_bin _), (L_hex _|L_bin _) - -> Some (eq_big_int (int_of_str_lit l1) (int_of_str_lit l2)) + -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2)) | L_undef, _ | _, L_undef -> None - | L_num i1, L_num i2 -> Some (eq_big_int i1 i2) + | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2) | _ -> Some (l1 = l2) let try_app (l,ann) (id,args) = @@ -757,12 +757,12 @@ let try_app (l,ann) (id,args) = else if is_id "shl_int" then match args with | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (shift_left_big_int i (int_of_big_int j)),new_l)),(l,ann))) + Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann))) | _ -> None else if is_id "mult_int" then match args with | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (mult_big_int i j),new_l)),(l,ann))) + Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann))) | _ -> None else if is_id "ex_int" then match args with @@ -775,8 +775,8 @@ let try_app (l,ann) (id,args) = | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_); E_aux (E_lit L_aux (L_num i,_),_)] -> let v = int_of_str_lit lit in - let b = and_big_int (shift_right_big_int v (int_of_big_int i)) unit_big_int in - let lit' = if eq_big_int b unit_big_int then L_one else L_zero in + let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in + let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann))) | _ -> None else None @@ -1105,7 +1105,7 @@ let split_defs continue_anyway splits defs = | E_comment_struc e -> re (E_comment_struc e) assigns | E_app_infix _ - | E_internal_let _ + | E_var _ | E_internal_plet _ | E_internal_return _ -> raise (Reporting_basic.err_unreachable l @@ -1316,13 +1316,13 @@ let split_defs continue_anyway splits defs = | Typ_app (Id_aux (Id "vector",_), [_;Typ_arg_aux (Typ_arg_nexp len,_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> (match len with | Nexp_aux (Nexp_constant sz,_) -> - if int_of_big_int sz <= vector_split_limit then - let lits = make_vectors (int_of_big_int sz) in + if Big_int.to_int sz <= vector_split_limit then + let lits = make_vectors (Big_int.to_int sz) in List.map (fun lit -> P_aux (P_lit lit,(l,annot)), [var,E_aux (E_lit lit,(new_l,annot))]) lits else - cannot ("Refusing to split vector type of length " ^ string_of_big_int sz ^ + cannot ("Refusing to split vector type of length " ^ Big_int.to_string sz ^ " (above limit " ^ string_of_int vector_split_limit ^ ")") | _ -> cannot ("length not constant, " ^ string_of_nexp len) @@ -1543,7 +1543,7 @@ let split_defs continue_anyway splits defs = | E_assert (e1,e2) -> re (E_assert (map_exp e1,map_exp e2)) | E_internal_cast (ann,e) -> re (E_internal_cast (ann,map_exp e)) | E_comment_struc e -> re (E_comment_struc e) - | E_internal_let (le,e1,e2) -> re (E_internal_let (map_lexp le, map_exp e1, map_exp e2)) + | E_var (le,e1,e2) -> re (E_var (map_lexp le, map_exp e1, map_exp e2)) | E_internal_plet (p,e1,e2) -> re (E_internal_plet (check_single_pat p, map_exp e1, map_exp e2)) | E_internal_return e -> re (E_internal_return (map_exp e)) and map_opt_default ((Def_val_aux (ed,annot)) as eda) = @@ -2325,7 +2325,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = -> raise (Reporting_basic.err_unreachable l ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> (* Really we ought to remove the assignment after e2 *) let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in let assigns,r' = analyse_lexp fn_id env assigns d1 lexp in @@ -2573,7 +2573,7 @@ let is_constant = function let is_constant_vec_typ env typ = let typ = Env.base_typ_of env typ in match destruct_vector env typ with - | Some (_,size,_,_) -> + | Some (size,_,_) -> (match nexp_simp size with | Nexp_aux (Nexp_constant _,_) -> true | _ -> false) @@ -2607,11 +2607,7 @@ let rewrite_app env typ (id,args) = let (start,size,order,bittyp) = vector_typ_args_of (Env.base_typ_of env typ) in let (_,size1,_,_) = vector_typ_args_of (Env.base_typ_of env (typ_of e1)) in let midsize = nminus size size1 in - let midstart = - if is_order_inc order - then nconstant zero_big_int - else nminus midsize (nconstant unit_big_int) in - let midtyp = vector_typ midstart midsize order bittyp in + let midtyp = vector_typ midsize order bittyp in E_app (append, [e1; E_aux (E_cast (midtyp, @@ -2630,11 +2626,7 @@ let rewrite_app env typ (id,args) = let (start,size,order,bittyp) = vector_typ_args_of (Env.base_typ_of env typ) in let (_,size1,_,_) = vector_typ_args_of (Env.base_typ_of env (typ_of e1)) in let midsize = nminus size size1 in - let midstart = - if is_order_inc order - then nconstant zero_big_int - else nminus midsize (nconstant unit_big_int) in - let midtyp = vector_typ midstart midsize order bittyp in + let midtyp = vector_typ midsize order bittyp in E_app (append, [e1; E_aux (E_cast (midtyp, @@ -2675,11 +2667,7 @@ let rewrite_app env typ (id,args) = let (start,size,order,bittyp) = vector_typ_args_of (Env.base_typ_of env typ) in let (_,size1,_,_) = vector_typ_args_of (Env.base_typ_of env (typ_of e1)) in let midsize = nminus size size1 in - let midstart = - if is_order_inc order - then nconstant zero_big_int - else nminus midsize (nconstant unit_big_int) in - let midtyp = vector_typ midstart midsize order bittyp in + let midtyp = vector_typ midsize order bittyp in E_cast (typ, E_aux (E_app (mk_id "append", [e1; diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index a437e7e6..ae58f7b2 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -69,8 +69,6 @@ let split ch s = let lem_dir = try Sys.getenv "LEM_DIR" (* LEM_DIR must contain an absolute path *) with Not_found -> "../../../lem" ;; -let lem_libdir = lem_dir / "ocaml-lib" ;; -let lem_lib = lem_libdir / "extract" ;; let lem = lem_dir / "lem" ;; (* All -wl ignores should be removed if you want to see the pattern compilation, exhaustive, and unused var warnings *) @@ -80,14 +78,13 @@ let lem_opts = [A "-lib"; P "../lem_interp"; A "-wl_pat_fail"; P "ign"; A "-wl_unused_vars"; P "ign"; (* A "-suppress_renaming";*) -] ;; + ] ;; dispatch begin function | After_rules -> (* ocaml_lib "lem_interp/interp"; *) - ocaml_lib ~extern:true ~dir:lem_libdir ~tag_name:"use_lem" lem_lib; ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib"; - + rule "lem -> ml" ~prod: "%.ml" ~dep: "%.lem" @@ -109,11 +106,5 @@ dispatch begin function mv (basename (env "%.lem")) (dirname (env "%.lem")) ]); - rule "old parser" - ~insert:(`top) - ~prods: ["parser.ml"; "parser.mli"] - ~dep: "parser.mly" - (fun env builder -> Cmd(S[V"OCAMLYACC"; T(tags_of_pathname "parser.mly"++"ocaml"++"parser"++"ocamlyacc"); Px "parser.mly"])); - | _ -> () end ;; diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index ac6f6ef3..55695114 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -53,6 +53,8 @@ open Ast_util open PPrint open Type_check +module Big_int = Nat_big_num + (* Option to turn tracing features on or off *) let opt_trace_ocaml = ref false @@ -144,6 +146,7 @@ let ocaml_typ_id ctx = function | id when Id.compare id (mk_id "real") = 0 -> string "Num.num" | id when Id.compare id (mk_id "exception") = 0 -> string "exn" | id when Id.compare id (mk_id "register") = 0 -> string "ref" + | id when Id.compare id (mk_id "ref") = 0 -> string "ref" | id -> zencode ctx id let rec ocaml_typ ctx (Typ_aux (typ_aux, _)) = @@ -179,7 +182,7 @@ let ocaml_lit (L_aux (lit_aux, _)) = | L_one -> string "B1" | L_true -> string "true" | L_false -> string "false" - | L_num n -> parens (string "big_int_of_string" ^^ space ^^ string ("\"" ^ Big_int.string_of_big_int n ^ "\"")) + | L_num n -> parens (string "big_int_of_string" ^^ space ^^ string ("\"" ^ Big_int.to_string n ^ "\"")) | L_undef -> failwith "undefined should have been re-written prior to ocaml backend" | L_string str -> string_lit str | L_real str -> parens (string "real_of_string" ^^ space ^^ dquotes (string (String.escaped str))) @@ -252,7 +255,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = | E_let (lb, exp) -> separate space [string "let"; ocaml_letbind ctx lb; string "in"] ^/^ ocaml_exp ctx exp - | E_internal_let (lexp, exp1, exp2) -> + | E_var (lexp, exp1, exp2) -> separate space [string "let"; ocaml_atomic_lexp ctx lexp; equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewrites.simple_typ (typ_of exp1))); string "in"] ^/^ ocaml_exp ctx exp2 @@ -276,18 +279,20 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = (string "let rec loop () =" ^//^ loop_body) ^/^ string "in" ^/^ string "loop ()" - | E_lit _ | E_list _ | E_id _ | E_tuple _ -> ocaml_atomic_exp ctx exp + | E_lit _ | E_list _ | E_id _ | E_tuple _ | E_ref _ -> ocaml_atomic_exp ctx exp | E_for (id, exp_from, exp_to, exp_step, ord, exp_body) -> let loop_var = separate space [string "let"; zencode ctx id; equals; string "ref"; ocaml_atomic_exp ctx exp_from; string "in"] in let loop_mod = match ord with | Ord_aux (Ord_inc, _) -> string "add_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step | Ord_aux (Ord_dec, _) -> string "sub_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step + | Ord_aux (Ord_var _, _) -> failwith "Cannot have variable loop order!" in let loop_compare = match ord with | Ord_aux (Ord_inc, _) -> string "le_big_int" | Ord_aux (Ord_dec, _) -> string "gt_big_int" + | Ord_aux (Ord_var _, _) -> failwith "Cannot have variable loop order!" in let loop_body = separate space [string "if"; loop_compare; zencode ctx id; ocaml_atomic_exp ctx exp_to] @@ -322,6 +327,7 @@ and ocaml_fexp ctx (FE_aux (FE_Fexp (id, exp), _)) = and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) = match exp_aux with | E_lit lit -> ocaml_lit lit + | E_ref id -> zencode ctx id | E_id id -> begin match Env.lookup_id id (env_of exp) with @@ -358,10 +364,13 @@ and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = separate space [zencode ctx id; string ":="; traced_exp] | _ -> separate space [zencode ctx id; string ":="; ocaml_exp ctx exp] end + | LEXP_deref ref_exp -> + separate space [ocaml_atomic_exp ctx ref_exp; string ":="; ocaml_exp ctx exp] | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") and ocaml_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = match lexp_aux with | LEXP_cast _ | LEXP_id _ -> ocaml_atomic_lexp ctx lexp + | LEXP_deref exp -> ocaml_exp ctx exp | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") and ocaml_atomic_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = match lexp_aux with @@ -440,7 +449,11 @@ let ocaml_funcls ctx = function | [] -> failwith "Ocaml: empty function" | [FCL_aux (FCL_Funcl (id, pexp),_)] -> - let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in let pat_sym = gensym () in let pat, exp = match pexp with @@ -464,7 +477,11 @@ let ocaml_funcls ctx = ocaml_funcl call string_of_arg string_of_ret | funcls -> let id = funcls_id funcls in - let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in let pat_sym = gensym () in let call_header = function_header () in let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in @@ -538,6 +555,9 @@ let ocaml_string_of_abbrev ctx id typq typ = separate space [string "let"; ocaml_string_of id; parens (arg ^^ space ^^ colon ^^ space ^^ zencode ctx id); equals] ^//^ ocaml_string_typ typ arg +let ocaml_string_of_variant ctx id typq cases = + separate space [string "let"; ocaml_string_of id; string "_"; equals; string "\"VARIANT\""] + let ocaml_typedef ctx (TD_aux (td_aux, _)) = match td_aux with | TD_record (id, _, typq, fields, _) -> @@ -549,8 +569,10 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = | TD_variant (id, _, _, cases, _) when string_of_id id = "exception" -> ocaml_exceptions ctx cases | TD_variant (id, _, typq, cases, _) -> - separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] - ^//^ ocaml_cases ctx cases + (separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] + ^//^ ocaml_cases ctx cases) + ^^ ocaml_def_end + ^^ ocaml_string_of_variant ctx id typq cases | TD_enum (id, _, ids, _) -> (separate space [string "type"; zencode ctx id; equals] ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) @@ -597,7 +619,7 @@ let val_spec_typs (Defs defs) = | _ :: defs -> vs_typs defs | [] -> [] in - vs_typs defs; + ignore (vs_typs defs); !typs let ocaml_defs (Defs defs) = @@ -625,7 +647,7 @@ let ocaml_main spec = ^//^ (string "Random.self_init ();" ^/^ string "load_elf ();" ^/^ string (if !opt_trace_ocaml then "Sail_lib.opt_trace := true;" else "Sail_lib.opt_trace := false;") - ^/^ string "initialize_registers ();" + ^/^ string "zinitializze_registers ();" ^/^ string "Printexc.record_backtrace true;" ^/^ string "zmain ()") ] diff --git a/src/parse_ast.ml b/src/parse_ast.ml index b684725f..362333f3 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -50,7 +50,7 @@ (* generated by Ott 0.25 from: l2_parse.ott *) -open Big_int +module Big_int = Nat_big_num type text = string @@ -139,7 +139,7 @@ type atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders, and effects after parsing *) ATyp_id of id (* identifier *) | ATyp_var of kid (* ticked variable *) - | ATyp_constant of big_int (* constant *) + | ATyp_constant of Big_int.num (* constant *) | ATyp_times of atyp * atyp (* product *) | ATyp_sum of atyp * atyp (* sum *) | ATyp_minus of atyp * atyp (* subtraction *) @@ -170,7 +170,7 @@ n_constraint_aux = (* constraint over kind $_$ *) | NC_bounded_ge of atyp * atyp | NC_bounded_le of atyp * atyp | NC_not_equal of atyp * atyp - | NC_set of kid * (big_int) list + | NC_set of kid * (Big_int.num) list | NC_or of n_constraint * n_constraint | NC_and of n_constraint * n_constraint | NC_true @@ -213,7 +213,7 @@ lit_aux = (* Literal constant *) | L_one (* $_ : _$ *) | L_true (* $_ : _$ *) | L_false (* $_ : _$ *) - | L_num of big_int (* natural number constant *) + | L_num of Big_int.num (* natural number constant *) | L_hex of string (* bit vector constant, C-style *) | L_bin of string (* bit vector constant, C-style *) | L_undef (* undefined value *) @@ -267,6 +267,8 @@ exp_aux = (* Expression *) E_block of (exp) list (* block (parsing conflict with structs?) *) | E_nondet of (exp) list (* block that can evaluate the contained expressions in any ordering *) | E_id of id (* identifier *) + | E_ref of id + | E_deref of exp | E_lit of lit (* literal constant *) | E_cast of atyp * exp (* cast *) | E_app of id * (exp) list (* function application *) @@ -296,7 +298,7 @@ exp_aux = (* Expression *) | E_try of exp * pexp list | E_return of exp | E_assert of exp * exp - | E_internal_let of exp * exp * exp + | E_var of exp * exp * exp and exp = E_aux of exp_aux * l @@ -396,8 +398,8 @@ type_union = type index_range_aux = (* index specification, for bitfields in register types *) - BF_single of big_int (* single index *) - | BF_range of big_int * big_int (* index range *) + BF_single of Big_int.num (* single index *) + | BF_range of Big_int.num * Big_int.num (* index range *) | BF_concat of index_range * index_range (* concatenation of index ranges *) and index_range = @@ -427,8 +429,7 @@ type_def_aux = (* Type definition body *) | TD_record of id * name_scm_opt * typquant * ((atyp * id)) list * bool (* struct type definition *) | TD_variant of id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) | TD_enum of id * name_scm_opt * (id) list * bool (* enumeration type definition *) - | TD_register of id * atyp * atyp * ((index_range * id)) list (* register mutable bitfield type definition *) - + | TD_bitfield of id * atyp * (id * index_range) list (* register mutable bitfield type definition *) type val_spec_aux = (* Value type specification *) @@ -492,7 +493,7 @@ scattered_def = type prec = Infix | InfixL | InfixR -type fixity_token = (prec * big_int * string) +type fixity_token = (prec * Big_int.num * string) type def = (* Top-level definition *) @@ -501,7 +502,7 @@ def = (* Top-level definition *) | DEF_fundef of fundef (* function definition *) | DEF_val of letbind (* value definition *) | DEF_overload of id * id list (* operator overload specifications *) - | DEF_fixity of prec * big_int * id (* fixity declaration *) + | DEF_fixity of prec * Big_int.num * id (* fixity declaration *) | DEF_spec of val_spec (* top-level type constraint *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) diff --git a/src/parser.mly b/src/parser.mly index 5e4a2cad..7af70687 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -52,314 +52,561 @@ let r = fun x -> x (* Ulib.Text.of_latin1 *) -open Big_int +module Big_int = Nat_big_num open Parse_ast -let loc () = Range(Parsing.symbol_start_pos(),Parsing.symbol_end_pos()) -let locn m n = Range(Parsing.rhs_start_pos m,Parsing.rhs_end_pos n) +let loc n m = Range (n, m) -let id_of_kid = function - | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) +let default_opt x = function + | None -> x + | Some y -> y -let idl i = Id_aux(i, loc()) +let assoc_opt key assocs = + try Some (List.assoc key assocs) with + | Not_found -> None let string_of_id = function | Id_aux (Id str, _) -> str | Id_aux (DeIid str, _) -> str -let efl e = BE_aux(e, loc()) - -let ploc p = P_aux(p,loc ()) -let eloc e = E_aux(e,loc ()) -let peloc pe = Pat_aux(pe,loc ()) -let lbloc lb = LB_aux(lb,loc ()) - -let bkloc k = BK_aux(k,loc ()) -let kloc k = K_aux(k,loc ()) -let kiloc ki = KOpt_aux(ki,loc ()) -let tloc t = ATyp_aux(t,loc ()) -let tlocl t l1 l2 = ATyp_aux(t,locn l1 l2) -let lloc l = L_aux(l,loc ()) -let ploc p = P_aux(p,loc ()) -let fploc p = FP_aux(p,loc ()) - -let funclloc f = FCL_aux(f,loc ()) -let typql t = TypQ_aux(t, loc()) -let irloc r = BF_aux(r, loc()) -let defloc df = DT_aux(df, loc()) - -let tdloc td = TD_aux(td, loc()) -let kdloc kd = KD_aux(kd, loc()) -let funloc fn = FD_aux(fn, loc()) -let vloc v = VS_aux(v, loc ()) -let sdloc sd = SD_aux(sd, loc ()) -let dloc d = d - -let mk_typschm tq t s e = TypSchm_aux((TypSchm_ts(tq,t)),(locn s e)) -let mk_rec i = (Rec_aux((Rec_rec), locn i i)) -let mk_recn _ = (Rec_aux((Rec_nonrec), Unknown)) -let mk_typqn _ = (TypQ_aux(TypQ_no_forall,Unknown)) -let mk_tannot tq t s e = Typ_annot_opt_aux(Typ_annot_opt_some(tq,t),(locn s e)) -let mk_tannotn _ = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) -let mk_eannot e i = Effect_opt_aux((Effect_opt_effect(e)),(locn i i)) -let mk_eannotn _ = Effect_opt_aux(Effect_opt_pure,Unknown) -let mk_namesectn _ = Name_sect_aux(Name_sect_none,Unknown) - -let make_range_sugar_bounded typ1 typ2 = - ATyp_app(Id_aux(Id("range"),Unknown),[typ1; typ2;]) -let make_range_sugar typ1 = - make_range_sugar_bounded (ATyp_aux(ATyp_constant(zero_big_int), Unknown)) typ1 -let make_atom_sugar typ1 = - ATyp_app(Id_aux(Id("atom"),Unknown),[typ1]) - -let make_r bot top = - match bot,top with - | ATyp_aux(ATyp_constant b,_),ATyp_aux(ATyp_constant t,l) -> - ATyp_aux(ATyp_constant (add_big_int (sub_big_int t b) unit_big_int),l) - | bot,(ATyp_aux(_,l) as top) -> - ATyp_aux((ATyp_sum ((ATyp_aux (ATyp_sum (top, ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), - (ATyp_aux ((ATyp_neg bot),Unknown)))), l) - -let make_vector_sugar_bounded order_set is_inc name typ typ1 typ2 = - let (rise,ord,name) = - if order_set - then if is_inc - then (make_r typ1 typ2,ATyp_inc,name) - else (make_r typ2 typ1,ATyp_dec,name) - else if name = "vector" - then (typ2, ATyp_default_ord,"vector_sugar_tb") (* rise not calculated, but top and bottom came from specification *) - else (typ2, ATyp_default_ord,"vector_sugar_r") (* rise and base not calculated, rise only from specification *) in - ATyp_app(Id_aux(Id(name),Unknown),[typ1;rise;ATyp_aux(ord,Unknown);typ]) -let make_vector_sugar order_set is_inc typ typ1 = - let zero = (ATyp_aux(ATyp_constant zero_big_int,Unknown)) in - let (typ1,typ2) = match (order_set,is_inc,typ1) with - | (true,true,ATyp_aux(ATyp_constant t,l)) -> zero,ATyp_aux(ATyp_constant (sub_big_int t unit_big_int),l) - | (true,true,ATyp_aux(_, l)) -> zero,ATyp_aux (ATyp_sum (typ1, - ATyp_aux(ATyp_neg(ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), l) - | (true,false,_) -> typ1,zero - | (false,_,_) -> zero,typ1 in - make_vector_sugar_bounded order_set is_inc "vector_sugar_r" typ typ1 typ2 +let prepend_id str1 = function + | Id_aux (Id str2, loc) -> Id_aux (Id (str1 ^ str2), loc) + | _ -> assert false + +let mk_id i n m = Id_aux (i, loc n m) +let mk_kid str n m = Kid_aux (Var str, loc n m) + +let id_of_kid = function + | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) + +let deinfix = function + | (Id_aux (Id v, l)) -> Id_aux (DeIid v, l) + | (Id_aux (DeIid v, l)) -> Id_aux (Id v, l) + +let mk_effect e n m = BE_aux (e, loc n m) +let mk_typ t n m = ATyp_aux (t, loc n m) +let mk_pat p n m = P_aux (p, loc n m) +let mk_pexp p n m = Pat_aux (p, loc n m) +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_nc nc n m = NC_aux (nc, loc n m) +let mk_sd s n m = SD_aux (s, loc n m) +let mk_ir r n m = BF_aux (r, loc n m) + +let mk_funcl f n m = FCL_aux (f, loc n m) +let mk_fun fn n m = FD_aux (fn, loc n m) +let mk_td t n m = TD_aux (t, loc n m) +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 qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) + +let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) +let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) +let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) +let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) +let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) + +type lchain = + LC_lt +| LC_lteq +| LC_nexp of atyp + +let rec desugar_lchain chain s e = + match chain with + | [LC_nexp n1; LC_lteq; LC_nexp n2] -> + mk_nc (NC_bounded_le (n1, n2)) s e + | [LC_nexp n1; LC_lt; LC_nexp n2] -> + mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e + | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | _ -> assert false + +type rchain = + RC_gt +| RC_gteq +| RC_nexp of atyp + +let rec desugar_rchain chain s e = + match chain with + | [RC_nexp n1; RC_gteq; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, n2)) s e + | [RC_nexp n1; RC_gt; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e + | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | _ -> assert false %} /*Terminals with no content*/ -%token And Alias As Assert Bitzero Bitone Bits By Case Clause Const Dec Def Default Deinfix Effect EFFECT End -%token Enumerate Else Exit Extern False Forall Exist Foreach Overload Function_ If_ In IN Inc Let_ Member Nat NatNum Order Cast -%token Pure Rec Register Return Scattered Sizeof Struct Switch Then True TwoStarStar Type TYPE Typedef -%token Undefined Union With When Val Constraint Try Catch Throw +%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 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 -%token While Do Repeat Until +%token Repeat Until While Do Record Mutual Var Ref - -/* Avoid shift/reduce conflict - see right_atomic_exp rule */ %nonassoc Then %nonassoc Else -%token Div_ Mod ModUnderS Quot Rem QuotUnderS - -%token Bar Comma Dot Eof Minus Semi Under -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare -%token BarBar BarSquare BarBarSquare ColonEq ColonGt ColonSquare DotDot -%token MinusGt LtBar LtColon SquareBar SquareBarBar SquareColon +%token Bar Comma Dot Eof Minus Semi Under DotDot +%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar +%token MinusGt /*Terminals with content*/ -%token <string> Id TyVar TyId -%token <Big_int.big_int> Num +%token <string> Id TyVar +%token <Nat_big_num.num> Num %token <string> String Bin Hex Real -%token <string> Amp At Carrot Div Eq Excl Gt Lt Plus Star Tilde -%token <string> AmpAmp CarrotCarrot Colon ColonColon EqEq ExclEq ExclExcl -%token <string> GtEq GtEqPlus GtGt GtGtGt GtPlus HashGtGt HashLtLt -%token <string> LtEq LtEqPlus LtGt LtLt LtLtLt LtPlus StarStar TildeCarrot - -%token <string> GtEqUnderS GtEqUnderSi GtEqUnderU GtEqUnderUi GtGtUnderU GtUnderS -%token <string> GtUnderSi GtUnderU GtUnderUi LtEqUnderS LtEqUnderSi LtEqUnderU -%token <string> LtEqUnderUi LtUnderS LtUnderSi LtUnderU LtUnderUi StarStarUnderS StarStarUnderSi StarUnderS -%token <string> StarUnderSi StarUnderU StarUnderUi TwoCarrot PlusUnderS MinusUnderS - -%token <string> AmpI AtI CarrotI DivI EqI ExclI GtI LtI PlusI StarI TildeI -%token <string> AmpAmpI CarrotCarrotI ColonColonI EqEqI ExclEqI ExclExclI -%token <string> GtEqI GtEqPlusI GtGtI GtGtGtI GtPlusI HashGtGtI HashLtLtI -%token <string> LtEqI LtEqPlusI LtGtI LtLtI LtLtLtI LtPlusI StarStarI TildeCarrotI - -%token <string> GtEqUnderSI GtEqUnderSiI GtEqUnderUI GtEqUnderUiI GtGtUnderUI GtUnderSI -%token <string> GtUnderSiI GtUnderUI GtUnderUiI LtEqUnderSI LtEqUnderSiI LtEqUnderUI -%token <string> LtEqUnderUiI LtUnderSI LtUnderSiI LtUnderUI LtUnderUiI StarStarUnderSI StarStarUnderSiI StarUnderSI -%token <string> StarUnderSiI StarUnderUI StarUnderUiI TwoCarrotI - - -%start file nonempty_exp_list -%type <Parse_ast.defs> defs -%type <Parse_ast.atyp> typ -%type <Parse_ast.pat> pat -%type <Parse_ast.exp> exp -%type <Parse_ast.exp list> nonempty_exp_list -%type <Parse_ast.defs> file +%token <string> Amp At Caret Eq Gt Lt Plus Star EqGt Unit +%token <string> Colon ExclEq +%token <string> GtEq +%token <string> LtEq + +%token <string> Op0 Op1 Op2 Op3 Op4 Op5 Op6 Op7 Op8 Op9 +%token <string> Op0l Op1l Op2l Op3l Op4l Op5l Op6l Op7l Op8l Op9l +%token <string> Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r +%token <Parse_ast.fixity_token> Fixity + +%start file +%start typschm_eof +%start exp_eof +%start def_eof +%type <Parse_ast.typschm> typschm_eof +%type <Parse_ast.exp> exp_eof +%type <Parse_ast.def> def_eof +%type <Parse_ast.defs> file %% id: - | Id - { idl (Id($1)) } - | Tilde - { idl (Id($1)) } - | Lparen Deinfix Amp Rparen - { idl (DeIid($3)) } - | Lparen Deinfix At Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Carrot Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Div Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Quot Rparen - { idl (DeIid("quot")) } - | Lparen Deinfix QuotUnderS Rparen - { idl (DeIid("quot_s")) } - | Lparen Deinfix Eq Rparen - { Id_aux(DeIid($3),loc ()) } - | Lparen Deinfix Excl Lparen - { idl (DeIid($3)) } - | Lparen Deinfix Gt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Lt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Minus Rparen - { idl (DeIid("-")) } - | Lparen Deinfix MinusUnderS Rparen - { idl (DeIid("-_s")) } - | Lparen Deinfix Mod Rparen - { idl (DeIid("mod")) } - | Lparen Deinfix Plus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix PlusUnderS Rparen - { idl (DeIid("+_s")) } - | Lparen Deinfix Star Rparen - { idl (DeIid($3)) } - | Lparen Deinfix StarUnderS Rparen - { idl (DeIid("*_s")) } - | Lparen Deinfix AmpAmp Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Bar Rparen - { idl (DeIid("|")) } - | Lparen Deinfix BarBar Rparen - { idl (DeIid("||")) } - | Lparen Deinfix CarrotCarrot Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Colon Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ColonColon Rparen - { idl (DeIid($3)) } - | Lparen Deinfix EqEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ExclEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ExclExcl Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEqUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEqPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtGtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix HashGtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix HashLtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtEqUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtLtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix StarStar Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Tilde Rparen - { idl (DeIid($3)) } - | Lparen Deinfix TildeCarrot Rparen - { idl (DeIid($3)) } - -tid: - | TyId - { (idl (Id($1))) } - -tyvar: + | Id { mk_id (Id $1) $startpos $endpos } + + | Op Op0 { mk_id (DeIid $2) $startpos $endpos } + | Op Op1 { mk_id (DeIid $2) $startpos $endpos } + | Op Op2 { mk_id (DeIid $2) $startpos $endpos } + | Op Op3 { mk_id (DeIid $2) $startpos $endpos } + | Op Op4 { mk_id (DeIid $2) $startpos $endpos } + | Op Op5 { mk_id (DeIid $2) $startpos $endpos } + | Op Op6 { mk_id (DeIid $2) $startpos $endpos } + | Op Op7 { mk_id (DeIid $2) $startpos $endpos } + | Op Op8 { mk_id (DeIid $2) $startpos $endpos } + | Op Op9 { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0l { mk_id (DeIid $2) $startpos $endpos } + | Op Op1l { mk_id (DeIid $2) $startpos $endpos } + | Op Op2l { mk_id (DeIid $2) $startpos $endpos } + | Op Op3l { mk_id (DeIid $2) $startpos $endpos } + | Op Op4l { mk_id (DeIid $2) $startpos $endpos } + | Op Op5l { mk_id (DeIid $2) $startpos $endpos } + | Op Op6l { mk_id (DeIid $2) $startpos $endpos } + | Op Op7l { mk_id (DeIid $2) $startpos $endpos } + | Op Op8l { mk_id (DeIid $2) $startpos $endpos } + | Op Op9l { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0r { mk_id (DeIid $2) $startpos $endpos } + | Op Op1r { mk_id (DeIid $2) $startpos $endpos } + | Op Op2r { mk_id (DeIid $2) $startpos $endpos } + | Op Op3r { mk_id (DeIid $2) $startpos $endpos } + | Op Op4r { mk_id (DeIid $2) $startpos $endpos } + | Op Op5r { mk_id (DeIid $2) $startpos $endpos } + | Op Op6r { mk_id (DeIid $2) $startpos $endpos } + | Op Op7r { mk_id (DeIid $2) $startpos $endpos } + | Op Op8r { mk_id (DeIid $2) $startpos $endpos } + | Op Op9r { mk_id (DeIid $2) $startpos $endpos } + + | Op Plus { mk_id (DeIid "+") $startpos $endpos } + | Op Minus { mk_id (DeIid "-") $startpos $endpos } + | Op Star { mk_id (DeIid "*") $startpos $endpos } + | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } + | Op Lt { mk_id (DeIid "<") $startpos $endpos } + | Op Gt { mk_id (DeIid ">") $startpos $endpos } + | Op LtEq { mk_id (DeIid "<=") $startpos $endpos } + | Op GtEq { mk_id (DeIid ">=") $startpos $endpos } + | Op Amp { mk_id (DeIid "&") $startpos $endpos } + | Op Bar { mk_id (DeIid "|") $startpos $endpos } + | Op Caret { mk_id (DeIid "^") $startpos $endpos } + +op0: Op0 { mk_id (Id $1) $startpos $endpos } +op1: Op1 { mk_id (Id $1) $startpos $endpos } +op2: Op2 { mk_id (Id $1) $startpos $endpos } +op3: Op3 { mk_id (Id $1) $startpos $endpos } +op4: Op4 { mk_id (Id $1) $startpos $endpos } +op5: Op5 { mk_id (Id $1) $startpos $endpos } +op6: Op6 { mk_id (Id $1) $startpos $endpos } +op7: Op7 { mk_id (Id $1) $startpos $endpos } +op8: Op8 { mk_id (Id $1) $startpos $endpos } +op9: Op9 { mk_id (Id $1) $startpos $endpos } + +op0l: Op0l { mk_id (Id $1) $startpos $endpos } +op1l: Op1l { mk_id (Id $1) $startpos $endpos } +op2l: Op2l { mk_id (Id $1) $startpos $endpos } +op3l: Op3l { mk_id (Id $1) $startpos $endpos } +op4l: Op4l { mk_id (Id $1) $startpos $endpos } +op5l: Op5l { mk_id (Id $1) $startpos $endpos } +op6l: Op6l { mk_id (Id $1) $startpos $endpos } +op7l: Op7l { mk_id (Id $1) $startpos $endpos } +op8l: Op8l { mk_id (Id $1) $startpos $endpos } +op9l: Op9l { mk_id (Id $1) $startpos $endpos } + +op0r: Op0r { mk_id (Id $1) $startpos $endpos } +op1r: Op1r { mk_id (Id $1) $startpos $endpos } +op2r: Op2r { mk_id (Id $1) $startpos $endpos } +op3r: Op3r { mk_id (Id $1) $startpos $endpos } +op4r: Op4r { mk_id (Id $1) $startpos $endpos } +op5r: Op5r { mk_id (Id $1) $startpos $endpos } +op6r: Op6r { mk_id (Id $1) $startpos $endpos } +op7r: Op7r { mk_id (Id $1) $startpos $endpos } +op8r: Op8r { mk_id (Id $1) $startpos $endpos } +op9r: Op9r { mk_id (Id $1) $startpos $endpos } + +id_list: + | id + { [$1] } + | id Comma id_list + { $1 :: $3 } + +kid: | TyVar - { (Kid_aux((Var($1)),loc ())) } + { mk_kid $1 $startpos $endpos } -tyvars: - | tyvar +kid_list: + | kid { [$1] } - | tyvar tyvars + | kid kid_list { $1 :: $2 } -atomic_kind: +nc: + | nc Bar nc_and + { mk_nc (NC_or ($1, $3)) $startpos $endpos } + | nc_and + { $1 } + +nc_and: + | nc_and Amp atomic_nc + { mk_nc (NC_and ($1, $3)) $startpos $endpos } + | atomic_nc + { $1 } + +atomic_nc: + | True + { mk_nc NC_true $startpos $endpos } + | False + { mk_nc NC_false $startpos $endpos } + | typ Eq typ + { mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ ExclEq typ + { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } + | nc_lchain + { desugar_lchain $1 $startpos $endpos } + | nc_rchain + { desugar_rchain $1 $startpos $endpos } + | Lparen nc Rparen + { $2 } + | kid In Lcurly num_list Rcurly + { mk_nc (NC_set ($1, $4)) $startpos $endpos } + +num_list: + | Num + { [$1] } + | Num Comma num_list + { $1 :: $3 } + +nc_lchain: + | typ LtEq typ + { [LC_nexp $1; LC_lteq; LC_nexp $3] } + | typ Lt typ + { [LC_nexp $1; LC_lt; LC_nexp $3] } + | typ LtEq nc_lchain + { LC_nexp $1 :: LC_lteq :: $3 } + | typ Lt nc_lchain + { LC_nexp $1 :: LC_lt :: $3 } + +nc_rchain: + | typ GtEq typ + { [RC_nexp $1; RC_gteq; RC_nexp $3] } + | typ Gt typ + { [RC_nexp $1; RC_gt; RC_nexp $3] } + | typ GtEq nc_rchain + { RC_nexp $1 :: RC_gteq :: $3 } + | typ Gt nc_rchain + { RC_nexp $1 :: RC_gt :: $3 } + +typ: + | typ0 + { $1 } + +/* The following implements all nine levels of user-defined precedence for +operators in types, with both left, right and non-associative operators */ + +typ0: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0l: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0r: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } + +typ1: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1l: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1r: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } + +typ2: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2l: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2r: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } + +typ3: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3l: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3r: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } + +typ4: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4l: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4r: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } + +typ5: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5l: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5r: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } + +typ6: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6l: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6r: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 { $1 } + +typ7: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7l: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7r: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 { $1 } + +typ8: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8l: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8r: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } + +typ9: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9l: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9r: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } + +atomic_typ: + | id + { mk_typ (ATyp_id $1) $startpos $endpos } + | kid + { mk_typ (ATyp_var $1) $startpos $endpos } + | Num + { mk_typ (ATyp_constant $1) $startpos $endpos } + | Dec + { mk_typ ATyp_dec $startpos $endpos } + | Inc + { mk_typ ATyp_inc $startpos $endpos } + | id Lparen typ_list Rparen + { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } + | Register Lparen typ Rparen + { let register_id = mk_id (Id "register") $startpos($1) $endpos($1) in + mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } + | Ref Lparen typ Rparen + { let ref_id = mk_id (Id "ref") $startpos($1) $endpos($1) in + mk_typ (ATyp_app (ref_id, [$3])) $startpos $endpos } + | Lparen typ Rparen + { $2 } + | Lparen typ Comma typ_list Rparen + { mk_typ (ATyp_tup ($2 :: $4)) $startpos $endpos } + | LcurlyBar num_list RcurlyBar + { let v = mk_kid "n" $startpos $endpos in + let atom_id = mk_id (Id "atom") $startpos $endpos in + let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in + mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } + | Lcurly kid_list Dot typ Rcurly + { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } + | Lcurly kid_list Comma nc Dot typ Rcurly + { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } + +typ_list: + | typ + { [$1] } + | typ Comma typ_list + { $1 :: $3 } + +base_kind: + | Int + { BK_aux (BK_nat, loc $startpos $endpos) } | TYPE - { bkloc BK_type } - | Nat - { bkloc BK_nat } - | NatNum - { bkloc BK_nat } + { BK_aux (BK_type, loc $startpos $endpos) } | Order - { bkloc BK_order } - -kind_help: - | atomic_kind - { [ $1 ] } - | atomic_kind MinusGt kind_help - { $1::$3 } + { BK_aux (BK_order, loc $startpos $endpos) } kind: - | kind_help - { K_aux(K_kind($1), loc ()) } + | base_kind + { K_aux (K_kind [$1], loc $startpos $endpos) } + +kopt: + | Lparen kid Colon kind Rparen + { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } + | kid + { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } + +kopt_list: + | kopt + { [$1] } + | kopt kopt_list + { $1 :: $2 } + +typquant: + | kopt_list Comma nc + { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in + TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } + | kopt_list + { TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1), loc $startpos $endpos) } effect: | Barr - { efl BE_barr } + { mk_effect BE_barr $startpos $endpos } | Depend - { efl BE_depend } - | Rreg - { efl BE_rreg } + { mk_effect BE_depend $startpos $endpos } + | Rreg + { mk_effect BE_rreg $startpos $endpos } | Wreg - { efl BE_wreg } + { mk_effect BE_wreg $startpos $endpos } | Rmem - { efl BE_rmem } + { mk_effect BE_rmem $startpos $endpos } | Rmemt - { efl BE_rmemt } + { mk_effect BE_rmemt $startpos $endpos } | Wmem - { efl BE_wmem } + { mk_effect BE_wmem $startpos $endpos } | Wmv - { efl BE_wmv } + { mk_effect BE_wmv $startpos $endpos } | Wmvt - { efl BE_wmvt } + { mk_effect BE_wmvt $startpos $endpos } | Eamem - { efl BE_eamem } + { mk_effect BE_eamem $startpos $endpos } | Exmem - { efl BE_exmem } + { mk_effect BE_exmem $startpos $endpos } | Undef - { efl BE_undef } + { mk_effect BE_undef $startpos $endpos } | Unspec - { efl BE_unspec } + { mk_effect BE_unspec $startpos $endpos } | Nondet - { efl BE_nondet } + { mk_effect BE_nondet $startpos $endpos } | Escape - { efl BE_escape } + { mk_effect BE_escape $startpos $endpos } effect_list: | effect @@ -367,994 +614,620 @@ effect_list: | effect Comma effect_list { $1::$3 } -effect_typ: +effect_set: | Lcurly effect_list Rcurly - { tloc (ATyp_set($2)) } + { mk_typ (ATyp_set $2) $startpos $endpos } | Pure - { tloc (ATyp_set([])) } - -vec_typ: - | tid Lsquare nexp_typ Rsquare - { tloc (make_vector_sugar false false (ATyp_aux ((ATyp_id $1), locn 1 1)) $3) } - | tid Lsquare nexp_typ Colon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded false false "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tid Lsquare nexp_typ LtColon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true true "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tid Lsquare nexp_typ ColonGt nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true false "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ Rsquare - { tloc (make_vector_sugar false false (ATyp_aux ((ATyp_var $1), locn 1 1)) $3) } - | tyvar Lsquare nexp_typ Colon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded false false "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ LtColon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true true "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ ColonGt nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true false "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - -app_typs: - | atomic_typ - { [$1] } - | atomic_typ Comma app_typs - { $1::$3 } - -atomic_typ: - | vec_typ - { $1 } - | range_typ - { $1 } - | nexp_typ - { $1 } - | Inc - { tloc (ATyp_inc) } - | Dec - { tloc (ATyp_dec) } - | tid Lt app_typs Gt - { tloc (ATyp_app($1,$3)) } - | Register Lt app_typs Gt - { tloc (ATyp_app(Id_aux(Id "register", locn 1 1),$3)) } - -range_typ: - | SquareBar nexp_typ BarSquare - { tloc (make_range_sugar $2) } - | SquareBar nexp_typ Colon nexp_typ BarSquare - { tloc (make_range_sugar_bounded $2 $4) } - | SquareColon nexp_typ ColonSquare - { tloc (make_atom_sugar $2) } - -nexp_typ: - | nexp_typ Plus nexp_typ2 - { tloc (ATyp_sum ($1, $3)) } - | nexp_typ Minus nexp_typ2 - { tloc (ATyp_minus ($1, $3)) } - | Minus nexp_typ2 - { tloc (ATyp_neg $2) } - | nexp_typ2 + { mk_typ (ATyp_set []) $startpos $endpos } + +typschm: + | typ MinusGt typ + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ MinusGt typ + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | typ MinusGt typ Effect effect_set + { (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 } + +typschm_eof: + | typschm Eof { $1 } -nexp_typ2: - | nexp_typ2 Star nexp_typ3 - { tloc (ATyp_times ($1, $3)) } - | nexp_typ3 +pat1: + | atomic_pat { $1 } + | atomic_pat At pat_concat + { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } -nexp_typ3: - | TwoStarStar nexp_typ4 - { tloc (ATyp_exp $2) } - | nexp_typ4 - { $1 } - -nexp_typ4: - | Num - { tlocl (ATyp_constant $1) 1 1 } - | tid - { tloc (ATyp_id $1) } - | Lcurly id Rcurly - { tloc (ATyp_id $2) } - | tyvar - { tloc (ATyp_var $1) } - | Lparen exist_typ Rparen - { $2 } +pat_concat: + | atomic_pat + { [$1] } + | atomic_pat At pat_concat + { $1 :: $3 } -tup_typ_list: - | atomic_typ Comma atomic_typ - { [$1;$3] } - | atomic_typ Comma tup_typ_list - { $1::$3 } - -tup_typ: - | atomic_typ - { $1 } - | Lparen tup_typ_list Rparen - { tloc (ATyp_tup $2) } - -exist_typ: - | Exist tyvars Comma nexp_constraint Dot tup_typ - { tloc (ATyp_exist ($2, $4, $6)) } - | Exist tyvars Dot tup_typ - { tloc (ATyp_exist ($2, NC_aux (NC_true, loc ()), $4)) } - | tup_typ +pat: + | pat1 { $1 } + | pat1 As id + { mk_pat (P_as ($1, $3)) $startpos $endpos } + | pat1 As kid + { mk_pat (P_var ($1, $3)) $startpos $endpos } -typ: - | exist_typ - { $1 } - | tup_typ MinusGt exist_typ Effect effect_typ - { tloc (ATyp_fn($1,$3,$5)) } +pat_list: + | pat + { [$1] } + | pat Comma pat_list + { $1 :: $3 } + +atomic_pat: + | Under + { mk_pat (P_wild) $startpos $endpos } + | lit + { mk_pat (P_lit $1) $startpos $endpos } + | id + { mk_pat (P_id $1) $startpos $endpos } + | kid + { mk_pat (P_var (mk_pat (P_id (id_of_kid $1)) $startpos $endpos, $1)) $startpos $endpos } + | id Lparen pat_list Rparen + { mk_pat (P_app ($1, $3)) $startpos $endpos } + | atomic_pat Colon typ + { mk_pat (P_typ ($3, $1)) $startpos $endpos } + | Lparen pat Rparen + { $2 } + | Lparen pat Comma pat_list Rparen + { mk_pat (P_tup ($2 :: $4)) $startpos $endpos } + | Lsquare pat_list Rsquare + { mk_pat (P_vector $2) $startpos $endpos } lit: | True - { lloc L_true } + { mk_lit L_true $startpos $endpos } | False - { lloc L_false } + { mk_lit L_false $startpos $endpos } + | Unit + { mk_lit L_unit $startpos $endpos } | Num - { lloc (L_num $1) } - | String - { lloc (L_string $1) } - | Lparen Rparen - { lloc L_unit } - | Bin - { lloc (L_bin $1) } - | Hex - { lloc (L_hex $1) } - | Real - { lloc (L_real $1) } + { mk_lit (L_num $1) $startpos $endpos } | Undefined - { lloc L_undef } + { mk_lit L_undef $startpos $endpos } | Bitzero - { lloc L_zero } + { mk_lit L_zero $startpos $endpos } | Bitone - { lloc L_one } - -atomic_pat: - | lit - { ploc (P_lit $1) } - | Under - { ploc P_wild } - | Lparen pat As id Rparen - { ploc (P_as($2,$4)) } - | Lparen exist_typ Rparen atomic_pat - { ploc (P_typ($2,$4)) } - | id - { ploc (P_app($1,[])) } - | tyvar - { ploc (P_var (ploc (P_id (id_of_kid $1)), $1)) } - | Lcurly fpats Rcurly - { ploc (P_record((fst $2, snd $2))) } - | Lsquare comma_pats Rsquare - { ploc (P_vector($2)) } - | Lsquare pat Rsquare - { ploc (P_vector([$2])) } - | Lsquare Rsquare - { ploc (P_vector []) } - | Lparen comma_pats Rparen - { ploc (P_tup($2)) } - | SquareBarBar BarBarSquare - { ploc (P_list([])) } - | SquareBarBar pat BarBarSquare - { ploc (P_list([$2])) } - | SquareBarBar semi_pats BarBarSquare - { ploc (P_list($2)) } - | atomic_pat ColonColon pat - { ploc (P_cons ($1, $3)) } - | Lparen pat Rparen - { $2 } - -app_pat: - | atomic_pat - { $1 } - | id Lparen comma_pats Rparen - { ploc (P_app($1,$3)) } - | id Lparen pat Rparen - { ploc (P_app($1,[$3])) } - -pat_colons: - | atomic_pat Colon atomic_pat - { ([$1;$3]) } - | atomic_pat Colon pat_colons - { ($1::$3) } - -pat: - | app_pat - { $1 } - | pat_colons - { ploc (P_vector_concat($1)) } - -comma_pats: - | atomic_pat Comma atomic_pat - { [$1;$3] } - | atomic_pat Comma comma_pats - { $1::$3 } - -semi_pats: - | atomic_pat Semi atomic_pat - { [$1;$3] } - | atomic_pat Semi semi_pats - { $1::$3 } - -fpat: - | id Eq pat - { fploc (FP_Fpat($1,$3)) } - -fpats: - | fpat - { ([$1], false) } - | fpat Semi - { ([$1], true) } - | fpat Semi fpats - { ($1::fst $3, snd $3) } - -npat: - | Num Eq pat - { ($1,$3) } - -npats: - | npat - { [$1] } - | npat Comma npats - { ($1::$3) } - -atomic_exp: - | Lcurly semi_exps Rcurly - { eloc (E_block $2) } - | Nondet Lcurly semi_exps Rcurly - { eloc (E_nondet $3) } - | id - { eloc (E_id($1)) } - | lit - { eloc (E_lit($1)) } - | Lparen exp Rparen - { $2 } - | Lparen exist_typ Rparen atomic_exp - { eloc (E_cast($2,$4)) } - | Lparen comma_exps Rparen - { eloc (E_tuple($2)) } - | Lcurly exp With semi_exps Rcurly - { eloc (E_record_update($2,$4)) } - | Lsquare Rsquare - { eloc (E_vector([])) } - | Lsquare exp Rsquare - { eloc (E_vector([$2])) } - | Lsquare comma_exps Rsquare - { eloc (E_vector($2)) } - | Lsquare exp With atomic_exp Eq exp Rsquare - { eloc (E_vector_update($2,$4,$6)) } - | Lsquare exp With atomic_exp Colon atomic_exp Eq exp Rsquare - { eloc (E_vector_update_subrange($2,$4,$6,$8)) } - | SquareBarBar BarBarSquare - { eloc (E_list []) } - | SquareBarBar exp BarBarSquare - { eloc (E_list [$2]) } - | SquareBarBar comma_exps BarBarSquare - { eloc (E_list($2)) } - | Switch exp Lcurly case_exps Rcurly - { eloc (E_case($2,$4)) } - | Try exp Catch Lcurly case_exps Rcurly - { eloc (E_try ($2, $5)) } - | Sizeof atomic_typ - { eloc (E_sizeof($2)) } - | Constraint Lparen nexp_constraint Rparen - { eloc (E_constraint $3) } - | Throw atomic_exp - { eloc (E_throw $2) } - | Exit atomic_exp - { eloc (E_exit $2) } - | Return atomic_exp - { eloc (E_return $2) } - | Assert Lparen exp Comma exp Rparen - { eloc (E_assert ($3,$5)) } - -field_exp: - | atomic_exp - { $1 } - | atomic_exp Dot id - { eloc (E_field($1,$3)) } + { mk_lit L_one $startpos $endpos } + | Bin + { mk_lit (L_bin $1) $startpos $endpos } + | Hex + { mk_lit (L_hex $1) $startpos $endpos } + | String + { mk_lit (L_string $1) $startpos $endpos } + | Real + { mk_lit (L_real $1) $startpos $endpos } -vaccess_exp: - | field_exp +exp_eof: + | exp Eof { $1 } - | atomic_exp Lsquare exp Rsquare - { eloc (E_vector_access($1,$3)) } - | atomic_exp Lsquare exp DotDot exp Rsquare - { eloc (E_vector_subrange($1,$3,$5)) } -app_exp: - | vaccess_exp +exp: + | exp0 { $1 } - | id Lparen Rparen - { eloc (E_app($1, [eloc (E_lit (lloc L_unit))])) } - /* we wrap into a tuple here, but this is unwrapped in initial_check.ml */ - | id Lparen exp Rparen - { eloc (E_app($1,[ E_aux((E_tuple [$3]),locn 3 3)])) } - | id Lparen comma_exps Rparen - { eloc (E_app($1,[E_aux (E_tuple $3,locn 3 3)])) } - -right_atomic_exp: + | atomic_exp Eq exp + { mk_exp (E_assign ($1, $3)) $startpos $endpos } + | Let_ letbind In exp + { mk_exp (E_let ($2, $4)) $startpos $endpos } + | Var atomic_exp Eq exp In exp + { mk_exp (E_var ($2, $4, $6)) $startpos $endpos } + | Star atomic_exp + { mk_exp (E_deref $2) $startpos $endpos } + | Lcurly block Rcurly + { mk_exp (E_block $2) $startpos $endpos } + | Return exp + { mk_exp (E_return $2) $startpos $endpos } + | Throw exp + { mk_exp (E_throw $2) $startpos $endpos } | If_ exp Then exp Else exp - { eloc (E_if($2,$4,$6)) } + { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } | If_ exp Then exp - { eloc (E_if($2,$4, eloc (E_lit(lloc L_unit)))) } + { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } + | Match exp Lcurly case_list Rcurly + { mk_exp (E_case ($2, $4)) $startpos $endpos } + | Try exp Catch Lcurly case_list Rcurly + { mk_exp (E_try ($2, $5)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp In typ Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" in foreach loop")); - eloc (E_for($3,$5,$7,$9,$11,$13)) } + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" in foreach loop")); + mk_exp (E_for ($3, $5, $7, $9, $11, $13)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" or \"downto\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); let order = if $6 = "to" - then ATyp_aux(ATyp_inc,(locn 6 6)) - else ATyp_aux(ATyp_dec,(locn 6 6)) in - eloc (E_for($3,$5,$7,$9,order,$11)) } + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, $9, order, $11)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" or \"downto\" in foreach loop")); - let step = eloc (E_lit(lloc (L_num unit_big_int))) in + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); + let step = mk_lit_exp (L_num (Big_int.of_int 1)) $startpos $endpos in let ord = if $6 = "to" - then ATyp_aux(ATyp_inc,(locn 6 6)) - else ATyp_aux(ATyp_dec,(locn 6 6)) in - eloc (E_for($3,$5,$7,step,ord,$9)) } + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } + | Repeat exp Until exp + { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } | While exp Do exp - { eloc (E_loop (While, $2, $4)) } - | letbind In exp - { eloc (E_let($1,$3)) } - -starstar_exp: - | app_exp - { $1 } - | starstar_exp StarStar app_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -/* this is where we diverge from the non-right_atomic path; - here we go directly to right_atomic whereas the other one - goes through app_exp, vaccess_exp and field_exp too. */ -starstar_right_atomic_exp: - | right_atomic_exp - { $1 } - | starstar_exp StarStar right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -star_exp: - | starstar_exp - { $1 } - | star_exp Star starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div_ starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("div"), locn 2 2), $3)) } - | star_exp Quot starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("quot"), locn 2 2), $3)) } - | star_exp QuotUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("quot_s"), locn 2 2), $3)) } - | star_exp Rem starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("rem"), locn 2 2), $3)) } - | star_exp Mod starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("mod"), locn 2 2), $3)) } - | star_exp ModUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("mod_s"), locn 2 2), $3)) } - | star_exp StarUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderSi starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderU starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderUi starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -star_right_atomic_exp: - | starstar_right_atomic_exp - { $1 } - | star_exp Star starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div_ starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("div"), locn 2 2), $3)) } - | star_exp Quot starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("quot"), locn 2 2), $3)) } - | star_exp QuotUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("quot_s"), locn 2 2), $3)) } - | star_exp Rem starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("rem"), locn 2 2), $3)) } - | star_exp Mod starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("mod"), locn 2 2), $3)) } - | star_exp ModUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("mod_s"), locn 2 2), $3)) } - | star_exp StarUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderSi starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderU starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderUi starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -plus_exp: - | star_exp - { $1 } - | plus_exp Plus star_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp PlusUnderS star_exp - { eloc (E_app_infix($1, Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp Minus star_exp - { eloc (E_app_infix($1,Id_aux(Id("-"), locn 2 2), $3)) } - | plus_exp MinusUnderS star_exp - { eloc (E_app_infix($1,Id_aux(Id("-_s"),locn 2 2), $3)) } - -plus_right_atomic_exp: - | star_right_atomic_exp - { $1 } - | plus_exp Plus star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp Minus star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("-"), locn 2 2), $3)) } - | plus_exp PlusUnderS star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp MinusUnderS star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("-_s"), locn 2 2), $3)) } - -shift_exp: - | plus_exp - { $1 } - | shift_exp GtGt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp GtGtGt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLtLt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -shift_right_atomic_exp: - | plus_right_atomic_exp - { $1 } - | shift_exp GtGt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp GtGtGt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLtLt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - - -cons_exp: - | shift_exp - { $1 } - | shift_exp ColonColon cons_exp - { eloc (E_cons($1,$3)) } - | shift_exp Colon cons_exp - { eloc (E_vector_append($1, $3)) } - -cons_right_atomic_exp: - | shift_right_atomic_exp - { $1 } - | shift_exp ColonColon cons_right_atomic_exp - { eloc (E_cons($1,$3)) } - | shift_exp Colon cons_right_atomic_exp - { eloc (E_vector_append($1, $3)) } - -at_exp: - | cons_exp - { $1 } - | cons_exp At at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp CarrotCarrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp Carrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp TildeCarrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -at_right_atomic_exp: - | cons_right_atomic_exp - { $1 } - | cons_exp At at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp CarrotCarrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp Carrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp TildeCarrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -eq_exp: - | at_exp - { $1 } - /* XXX check for consistency */ - | eq_exp Eq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp EqEq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ExclEq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEq at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Gt at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEq at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEqUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Lt at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderS at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderSi at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - /* XXX assignement should not have the same precedence as equal, - otherwise a := b > c requires extra parens... */ - | eq_exp ColonEq at_exp - { eloc (E_assign($1,$3)) } - -eq_right_atomic_exp: - | at_right_atomic_exp - { $1 } - | eq_exp Eq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp EqEq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ExclEq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEq at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Gt at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEq at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEqUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Lt at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderS at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderSi at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ColonEq at_right_atomic_exp - { eloc (E_assign($1,$3)) } - -and_exp: - | eq_exp - { $1 } - | eq_exp Amp and_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp AmpAmp and_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -and_right_atomic_exp: - | eq_right_atomic_exp - { $1 } - | eq_exp Amp and_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp AmpAmp and_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -or_exp: - | and_exp - { $1 } - | and_exp Bar or_exp - { eloc (E_app_infix($1,Id_aux(Id("|"), locn 2 2), $3)) } - | and_exp BarBar or_exp - { eloc (E_app_infix($1,Id_aux(Id("||"), locn 2 2), $3)) } - -or_right_atomic_exp: - | and_right_atomic_exp - { $1 } - | and_exp Bar or_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("|"), locn 2 2), $3)) } - | and_exp BarBar or_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("||"), locn 2 2), $3)) } - -exp: - | or_exp - { $1 } - | or_right_atomic_exp - { $1 } - -comma_exps: - | exp Comma exp - { [$1;$3] } - | exp Comma comma_exps - { $1::$3 } + { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } + +/* The following implements all nine levels of user-defined precedence for +operators in expressions, with both left, right and non-associative operators */ + +exp0: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0l: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0r: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } + +exp1: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1l: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1r: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } + +exp2: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } +exp2l: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 { $1 } +exp2r: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } + +exp3: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } +exp3l: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 { $1 } +exp3r: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } + +exp4: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 Lt exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 Gt exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4l: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4r: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } + +exp5: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } +exp5l: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 { $1 } +exp5r: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } + +exp6: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6l: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6r: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 { $1 } + +exp7: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7l: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7r: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 { $1 } + +exp8: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8l: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8r: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } + +exp9: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9l: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9r: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } + +case: + | pat EqGt exp + { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } + | pat If_ exp EqGt exp + { mk_pexp (Pat_when ($1, $3, $5)) $startpos $endpos } + +case_list: + | case + { [$1] } + | case Comma case_list + { $1 :: $3 } -semi_exps_help: +block: | exp { [$1] } - | exp Semi + | Let_ letbind Semi block + { [mk_exp (E_let ($2, mk_exp (E_block $4) $startpos($4) $endpos)) $startpos $endpos] } + | Var atomic_exp Eq exp Semi block + { [mk_exp (E_var ($2, $4, mk_exp (E_block $6) $startpos($6) $endpos)) $startpos $endpos] } + | exp Semi /* Allow trailing semicolon in block */ { [$1] } - | exp Semi semi_exps_help - { $1::$3 } + | exp Semi block + { $1 :: $3 } -semi_exps: - | - { [] } - | semi_exps_help - { $1 } +%inline letbind: + | pat Eq exp + { LB_aux (LB_val ($1, $3), loc $startpos $endpos) } -case_exp: - | Case patsexp +atomic_exp: + | atomic_exp Colon atomic_typ + { mk_exp (E_cast ($3, $1)) $startpos $endpos } + | lit + { mk_exp (E_lit $1) $startpos $endpos } + | id MinusGt id Unit + { mk_exp (E_app (prepend_id "_mod_" $3, [mk_exp (E_ref $1) $startpos($1) $endpos($1)])) $startpos $endpos } + | id MinusGt id Lparen exp_list Rparen + { mk_exp (E_app (prepend_id "_mod_" $3, mk_exp (E_ref $1) $startpos($1) $endpos($1) :: $5)) $startpos $endpos } + | atomic_exp Dot id Unit + { mk_exp (E_app (prepend_id "_mod_" $3, [$1])) $startpos $endpos } + | atomic_exp Dot id Lparen exp_list Rparen + { mk_exp (E_app (prepend_id "_mod_" $3, $1 :: $5)) $startpos $endpos } + | atomic_exp Dot id + { mk_exp (E_field ($1, $3)) $startpos $endpos } + | id + { mk_exp (E_id $1) $startpos $endpos } + | kid + { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } + | Ref id + { mk_exp (E_ref $2) $startpos $endpos } + | id Unit + { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } + | id Lparen exp_list Rparen + { mk_exp (E_app ($1, $3)) $startpos $endpos } + | Exit Lparen exp Rparen + { mk_exp (E_exit $3) $startpos $endpos } + | Sizeof Lparen typ Rparen + { mk_exp (E_sizeof $3) $startpos $endpos } + | Constraint Lparen nc Rparen + { mk_exp (E_constraint $3) $startpos $endpos } + | Assert Lparen exp Rparen + { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } + | Assert Lparen exp Comma exp Rparen + { mk_exp (E_assert ($3, $5)) $startpos $endpos } + | atomic_exp Lsquare exp Rsquare + { mk_exp (E_vector_access ($1, $3)) $startpos $endpos } + | atomic_exp Lsquare exp DotDot exp Rsquare + { mk_exp (E_vector_subrange ($1, $3, $5)) $startpos $endpos } + | Record Lcurly fexp_exp_list Rcurly + { mk_exp (E_record $3) $startpos $endpos } + | Lcurly exp With fexp_exp_list Rcurly + { mk_exp (E_record_update ($2, $4)) $startpos $endpos } + | Lsquare exp_list Rsquare + { mk_exp (E_vector $2) $startpos $endpos } + | Lsquare exp With atomic_exp Eq exp Rsquare + { mk_exp (E_vector_update ($2, $4, $6)) $startpos $endpos } + | Lsquare exp With atomic_exp DotDot atomic_exp Eq exp Rsquare + { mk_exp (E_vector_update_subrange ($2, $4, $6, $8)) $startpos $endpos } + | LsquareBar exp_list RsquareBar + { mk_exp (E_list $2) $startpos $endpos } + | Lparen exp Rparen { $2 } + | Lparen exp Comma exp_list Rparen + { mk_exp (E_tuple ($2 :: $4)) $startpos $endpos } -case_exps: - | case_exp - { [$1] } - | case_exp case_exps - { $1::$2 } +fexp_exp: + | atomic_exp Eq exp + { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } -patsexp: - | atomic_pat MinusGt exp - { peloc (Pat_exp($1,$3)) } - | atomic_pat When exp MinusGt exp - { peloc (Pat_when ($1, $3, $5)) } +fexp_exp_list: + | fexp_exp + { [$1] } + | fexp_exp Comma fexp_exp_list + { $1 :: $3 } -letbind: - | Let_ atomic_pat Eq exp - { lbloc (LB_val($2,$4)) } +exp_list: + | exp + { [$1] } + | exp Comma exp_list + { $1 :: $3 } -patsexp_funcl: - | atomic_pat Eq exp - { peloc (Pat_exp($1,$3)) } - | Lparen atomic_pat When exp Rparen Eq exp - { peloc (Pat_when ($2, $4, $7)) } +funcl_patexp: + | pat Eq exp + { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } + | Lparen pat If_ exp Rparen Eq exp + { mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos } funcl: - | id patsexp_funcl - { funclloc (FCL_Funcl($1,$2)) } + | id funcl_patexp + { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos } -funcl_ands: - | funcl - { [$1] } - | funcl And funcl_ands - { $1::$3 } - -/* This causes ambiguity because without a type quantifier it's unclear whether the first id is a function name or a type name for the optional types.*/ -fun_def: - | Function_ Rec typquant typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannot $6 6, $7)) } - | Function_ Rec typquant typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannotn (), $5)) } - | Function_ Rec typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot (mk_typqn ()) $3 3 3, mk_eannot $5 5, $6)) } - | Function_ Rec Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2,mk_tannotn (), mk_eannot $4 4, $5)) } - | Function_ Rec typ funcl_ands - { funloc (FD_function(mk_rec 2,mk_tannot (mk_typqn ()) $3 3 3, mk_eannotn (), $4)) } - | Function_ Rec funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannotn (), mk_eannotn (), $3)) } - | Function_ typquant typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot $2 $3 2 3, mk_eannot $5 5, $6)) } - | Function_ typquant typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot $2 $3 2 2, mk_eannotn (), $4)) } - | Function_ typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannot $4 4, $5)) } - | Function_ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (),mk_tannotn (), mk_eannot $3 3, $4)) } - | Function_ typ funcl_ands - { funloc (FD_function(mk_recn (),mk_tannot (mk_typqn ()) $2 2 2, mk_eannotn (), $3)) } - | Function_ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannotn (), mk_eannotn (), $2)) } - - -val_spec: - | Val typquant typ id - { vloc (VS_val_spec(mk_typschm $2 $3 2 3,$4, (fun _ -> None), false)) } - | Val typ id - { vloc (VS_val_spec(mk_typschm (mk_typqn ()) $2 2 2,$3, (fun _ -> None), false)) } - | Val Cast typquant typ id - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> None), true)) } - | Val Cast typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> None), true)) } - | Val Extern typquant typ id - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some (string_of_id $5)), false)) } - | Val Extern typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> Some (string_of_id $4)), false)) } - | Val Extern typquant typ id Eq String - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some $7), false)) } - | Val Extern typ id Eq String - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3,$4, (fun _ -> Some $6), false)) } - | Val Cast Extern typquant typ id - { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some (string_of_id $6)), true)) } - | Val Cast Extern typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4, $5, (fun _ -> Some (string_of_id $5)), true)) } - | Val Cast Extern typquant typ id Eq String - { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some $8), true)) } - | Val Cast Extern typ id Eq String - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4,$5, (fun _ -> Some $7), true)) } - -kinded_id: - | tyvar - { kiloc (KOpt_none $1) } - | kind tyvar - { kiloc (KOpt_kind($1,$2))} - -/*kinded_ids: - | kinded_id - { [$1] } - | kinded_id kinded_ids - { $1::$2 }*/ +funcls: + | id funcl_patexp + { [mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos] } + | id funcl_patexp And funcls + { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos :: $4 } -nums: +index_range: | Num - { [$1] } - | Num Comma nums - { $1::$3 } - -nexp_constraint: - | nexp_constraint1 - { $1 } - | nexp_constraint1 Bar nexp_constraint - { NC_aux (NC_or ($1, $3), loc ()) } - -nexp_constraint1: - | nexp_constraint2 - { $1 } - | nexp_constraint2 Amp nexp_constraint1 - { NC_aux (NC_and ($1, $3), loc ()) } - -nexp_constraint2: - | nexp_typ Eq nexp_typ - { NC_aux(NC_equal($1,$3), loc () ) } - | nexp_typ ExclEq nexp_typ - { NC_aux (NC_not_equal ($1, $3), loc ()) } - | nexp_typ GtEq nexp_typ - { NC_aux(NC_bounded_ge($1,$3), loc () ) } - | nexp_typ LtEq nexp_typ - { NC_aux(NC_bounded_le($1,$3), loc () ) } - | tyvar In Lcurly nums Rcurly - { NC_aux(NC_set($1,$4), loc ()) } - | tyvar IN Lcurly nums Rcurly - { NC_aux(NC_set($1,$4), loc ()) } - | True - { NC_aux (NC_true, loc ()) } - | False - { NC_aux (NC_false, loc ()) } - | Lparen nexp_constraint Rparen - { $2 } + { mk_ir (BF_single $1) $startpos $endpos } + | Num DotDot Num + { mk_ir (BF_range ($1, $3)) $startpos $endpos } -id_constraint: - | nexp_constraint - { QI_aux((QI_const $1), loc())} - | kinded_id - { QI_aux((QI_id $1), loc()) } +r_id_def: + | id Colon index_range + { $1, $3 } -id_constraints: - | id_constraint - { [$1] } - | id_constraint Comma id_constraints - { $1::$3 } +r_def_body: + | r_id_def + { [$1] } + | r_id_def Comma + { [$1] } + | r_id_def Comma r_def_body + { $1 :: $3 } -typquant: - | Forall id_constraints Dot - { typql(TypQ_tq($2)) } - -name_sect: - | Lsquare Id Eq String Rsquare - { - if $2 <> "name" then - raise (Parse_error_locn ((loc ()),"Unexpected id \""^$2^"\" in name_sect (should be \"name\")")); - Name_sect_aux(Name_sect_some($4), loc ()) } - -c_def_body: - | typ id - { [($1,$2)],false } - | typ id Semi - { [($1,$2)],true } - | typ id Semi c_def_body - { ($1,$2)::(fst $4), snd $4 } - -union_body: +type_def: + | Typedef id typquant Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } + | Typedef id Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } + | Struct id Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } + | Struct id typquant Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + | Enum id Eq enum_bar + { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } + | Enum id Eq Lcurly enum Rcurly + { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } + | Newtype id Eq type_union + { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos } + | Newtype id typquant Eq type_union + { mk_td (TD_variant ($2, mk_namesectn, $3, [$5], false)) $startpos $endpos } + | Union id Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } + | Union id typquant Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + | Bitfield id Colon typ Eq Lcurly r_def_body Rcurly + { mk_td (TD_bitfield ($2, $4, $7)) $startpos $endpos } + +enum_bar: | id - { [Tu_aux( Tu_id $1, loc())],false } - | typ id - { [Tu_aux( Tu_ty_id ($1,$2), loc())],false } - | id Semi - { [Tu_aux( Tu_id $1, loc())],true } - | typ id Semi - { [Tu_aux( Tu_ty_id ($1,$2),loc())],true } - | id Semi union_body - { (Tu_aux( Tu_id $1, loc()))::(fst $3), snd $3 } - | typ id Semi union_body - { (Tu_aux(Tu_ty_id($1,$2),loc()))::(fst $4), snd $4 } - -index_range_atomic: - | Num - { irloc (BF_single($1)) } - | Num DotDot Num - { irloc (BF_range($1,$3)) } - | Lparen index_range Rparen - { $2 } + { [$1] } + | id Bar enum_bar + { $1 :: $3 } -enum_body: +enum: | id - { [$1] } - | id Semi - { [$1] } - | id Semi enum_body - { $1::$3 } + { [$1] } + | id Comma enum + { $1 :: $3 } -index_range: - | index_range_atomic - { $1 } - | index_range_atomic Comma index_range - { irloc(BF_concat($1,$3)) } +struct_field: + | id Colon typ + { ($3, $1) } -r_id_def: - | index_range Colon id - { $1,$3 } +struct_fields: + | struct_field + { [$1] } + | struct_field Comma + { [$1] } + | struct_field Comma struct_fields + { $1 :: $3 } -r_def_body: - | r_id_def +type_union: + | id Colon typ + { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } + | id + { Tu_aux (Tu_id $1, loc $startpos $endpos) } + +type_unions: + | type_union { [$1] } - | r_id_def Semi + | type_union Comma { [$1] } - | r_id_def Semi r_def_body - { $1::$3 } + | type_union Comma type_unions + { $1 :: $3 } -type_def: - | Typedef tid name_sect Eq typquant typ - { tdloc (TD_abbrev($2,$3,mk_typschm $5 $6 5 6)) } - | Typedef tid name_sect Eq typ - { tdloc (TD_abbrev($2,$3,mk_typschm (mk_typqn ()) $5 5 5)) } - | Typedef tid Eq typquant typ - { tdloc (TD_abbrev($2,mk_namesectn (), mk_typschm $4 $5 4 5))} - | Typedef tid Eq typ - { tdloc (TD_abbrev($2,mk_namesectn (),mk_typschm (mk_typqn ()) $4 4 4)) } - /* The below adds 4 shift/reduce conflicts. Due to c_def_body and confusions in id id and parens */ - | Typedef tid name_sect Eq Const Struct typquant Lcurly c_def_body Rcurly - { tdloc (TD_record($2,$3,$7,fst $9, snd $9)) } - | Typedef tid name_sect Eq Const Struct Lcurly c_def_body Rcurly - { tdloc (TD_record($2,$3,(mk_typqn ()), fst $8, snd $8)) } - | Typedef tid Eq Const Struct typquant Lcurly c_def_body Rcurly - { tdloc (TD_record($2,mk_namesectn (), $6, fst $8, snd $8)) } - | Typedef tid Eq Const Struct Lcurly c_def_body Rcurly - { tdloc (TD_record($2, mk_namesectn (), mk_typqn (), fst $7, snd $7)) } - | Typedef tid name_sect Eq Const Union typquant Lcurly union_body Rcurly - { tdloc (TD_variant($2,$3, $7, fst $9, snd $9)) } - | Typedef tid Eq Const Union typquant Lcurly union_body Rcurly - { tdloc (TD_variant($2,mk_namesectn (), $6, fst $8, snd $8)) } - | Typedef tid name_sect Eq Const Union Lcurly union_body Rcurly - { tdloc (TD_variant($2, $3, mk_typqn (), fst $8, snd $8)) } - | Typedef tid Eq Const Union Lcurly union_body Rcurly - { tdloc (TD_variant($2, mk_namesectn (), mk_typqn (), fst $7, snd $7)) } - | Typedef tid Eq Enumerate Lcurly enum_body Rcurly - { tdloc (TD_enum($2, mk_namesectn (), $6,false)) } - | Typedef tid name_sect Eq Enumerate Lcurly enum_body Rcurly - { tdloc (TD_enum($2,$3,$7,false)) } - | Typedef tid Eq Register Bits Lsquare nexp_typ Colon nexp_typ Rsquare Lcurly r_def_body Rcurly - { tdloc (TD_register($2, $7, $9, $12)) } - -default_typ: - | Default atomic_kind tyvar - { defloc (DT_kind($2,$3)) } - | Default atomic_kind Inc - { defloc (DT_order($2, tloc (ATyp_inc))) } - | Default atomic_kind Dec - { defloc (DT_order($2, tloc (ATyp_dec))) } - | Default typquant typ id - { defloc (DT_typ((mk_typschm $2 $3 2 3),$4)) } - | Default typ id - { defloc (DT_typ((mk_typschm (mk_typqn ()) $2 2 2),$3)) } +fun_def: + | Function_ funcls + { mk_fun (FD_function (mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } + +fun_def_list: + | fun_def + { [$1] } + | fun_def fun_def_list + { $1 :: $2 } + +let_def: + | Let_ letbind + { $2 } + +externs: + | id Colon String + { [(string_of_id $1, $3)] } + | id Colon String Comma externs + { (string_of_id $1, $3) :: $5 } + +val_spec_def: + | Val id Colon typschm + { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } + | Val Cast id Colon typschm + { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } + | Val id Eq String Colon typschm + { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } + | Val Cast id Eq String Colon typschm + { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } + | Val String Colon typschm + { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } + | Val Cast String Colon typschm + { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } + | Val id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } + | Val Cast id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } + +register_def: + | Register id Colon typ + { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } + +default_def: + | Default base_kind Inc + { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } + | Default base_kind Dec + { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } scattered_def: - | Function_ Rec typquant typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannot $6 6, $7)) } - | Function_ Rec typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot (mk_typqn ()) $3 3 3, mk_eannot $5 5, $6)) } - | Function_ Rec typquant typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannotn (), $5)) } - | Function_ Rec Effect effect_typ id - { sdloc (SD_scattered_function (mk_rec 2, mk_tannotn (), mk_eannot $4 4, $5)) } - | Function_ Rec typ id - { sdloc (SD_scattered_function(mk_rec 2,mk_tannot (mk_typqn ()) $3 3 3, mk_eannotn (), $4)) } - | Function_ Rec id - { sdloc (SD_scattered_function(mk_rec 2,mk_tannotn (), mk_eannotn (),$3)) } - | Function_ typquant typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (),mk_tannot $2 $3 2 3, mk_eannot $5 5, $6)) } - | Function_ typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannot $4 4, $5)) } - | Function_ typquant typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot $2 $3 2 3, mk_eannotn (), $4)) } - | Function_ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannotn (), mk_eannot $3 3, $4)) } - | Function_ typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannotn (), $3)) } + | Union id typquant + { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } + | Union id + { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } | Function_ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannotn (), mk_eannotn (), $2)) } - | Typedef tid name_sect Eq Const Union typquant - { sdloc (SD_scattered_variant($2,$3,$7)) } - | Typedef tid Eq Const Union typquant - { sdloc (SD_scattered_variant($2,(mk_namesectn ()),$6)) } - | Typedef tid name_sect Eq Const Union - { sdloc (SD_scattered_variant($2,$3,mk_typqn ())) } - | Typedef tid Eq Const Union - { sdloc (SD_scattered_variant($2,mk_namesectn (),mk_typqn ())) } - -ktype_def: - | Def kind tid name_sect Eq typquant typ - { kdloc (KD_abbrev($2,$3,$4,mk_typschm $6 $7 6 7)) } - | Def kind tid name_sect Eq typ - { kdloc (KD_abbrev($2,$3,$4,mk_typschm (mk_typqn ()) $6 6 6)) } - | Def kind tid Eq typquant typ - { kdloc (KD_abbrev($2,$3,mk_namesectn (), mk_typschm $5 $6 5 6)) } - | Def kind tid Eq typ - { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) $5 5 5)) } - | Def kind tid Eq Num - { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) (tlocl (ATyp_constant $5) 5 5) 5 5)) } + { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } def: - | type_def - { dloc (DEF_type($1)) } - | ktype_def - { dloc (DEF_kind($1)) } | fun_def - { dloc (DEF_fundef($1)) } - | letbind - { dloc (DEF_val($1)) } - | val_spec - { dloc (DEF_spec($1)) } - | default_typ - { dloc (DEF_default($1)) } - | Overload id Lsquare enum_body Rsquare - { dloc (DEF_overload($2,$4)) } - | Register typ id - { dloc (DEF_reg_dec(DEC_aux(DEC_reg($2,$3),loc ()))) } - | Register Alias id Eq exp - { dloc (DEF_reg_dec(DEC_aux(DEC_alias($3,$5),loc ()))) } - | Register Alias typ id Eq exp - { dloc (DEF_reg_dec(DEC_aux(DEC_typ_alias($3,$4,$6), loc ()))) } + { DEF_fundef $1 } + | Fixity + { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } + | val_spec_def + { DEF_spec $1 } + | type_def + { DEF_type $1 } + | let_def + { DEF_val $1 } + | register_def + { DEF_reg_dec $1 } + | Overload id Eq Lcurly id_list Rcurly + { DEF_overload ($2, $5) } + | Overload id Eq enum_bar + { DEF_overload ($2, $4) } | Scattered scattered_def - { dloc (DEF_scattered $2) } + { DEF_scattered $2 } | Function_ Clause funcl - { dloc (DEF_scattered (sdloc (SD_scattered_funcl($3)))) } - | Union tid Member typ id - { dloc (DEF_scattered (sdloc (SD_scattered_unioncl($2,Tu_aux(Tu_ty_id($4,$5), locn 4 5))))) } - | Union tid Member id - { dloc (DEF_scattered (sdloc (SD_scattered_unioncl($2,Tu_aux(Tu_id($4), locn 4 4))))) } + { DEF_scattered (mk_sd (SD_scattered_funcl $3) $startpos $endpos) } + | Union Clause id Eq type_union + { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } | End id - { dloc (DEF_scattered (sdloc (SD_scattered_end($2)))) } - | End tid - { dloc (DEF_scattered (sdloc (SD_scattered_end($2)))) } + { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } + | default_def + { DEF_default $1 } + | Mutual Lcurly fun_def_list Rcurly + { DEF_internal_mutrec $3 } -defs_help: +defs_list: | def { [$1] } - | def defs_help + | def defs_list { $1::$2 } +def_eof: + | def Eof + { $1 } + defs: - | defs_help + | defs_list { (Defs $1) } file: | defs Eof { $1 } - -nonempty_exp_list: - | semi_exps_help Eof { $1 } diff --git a/src/parser2.mly b/src/parser2.mly deleted file mode 100644 index 59c7f1c4..00000000 --- a/src/parser2.mly +++ /dev/null @@ -1,1171 +0,0 @@ -/**************************************************************************/ -/* Sail */ -/* */ -/* Copyright (c) 2013-2017 */ -/* Kathyrn Gray */ -/* Shaked Flur */ -/* Stephen Kell */ -/* Gabriel Kerneis */ -/* Robert Norton-Wright */ -/* Christopher Pulte */ -/* Peter Sewell */ -/* Alasdair Armstrong */ -/* Brian Campbell */ -/* Thomas Bauereiss */ -/* Anthony Fox */ -/* Jon French */ -/* Dominic Mulligan */ -/* Stephen Kell */ -/* Mark Wassell */ -/* */ -/* All rights reserved. */ -/* */ -/* This software was developed by the University of Cambridge Computer */ -/* Laboratory as part of the Rigorous Engineering of Mainstream Systems */ -/* (REMS) project, funded by EPSRC grant EP/K008528/1. */ -/* */ -/* Redistribution and use in source and binary forms, with or without */ -/* modification, are permitted provided that the following conditions */ -/* are met: */ -/* 1. Redistributions of source code must retain the above copyright */ -/* notice, this list of conditions and the following disclaimer. */ -/* 2. Redistributions in binary form must reproduce the above copyright */ -/* notice, this list of conditions and the following disclaimer in */ -/* the documentation and/or other materials provided with the */ -/* distribution. */ -/* */ -/* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' */ -/* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED */ -/* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A */ -/* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR */ -/* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, */ -/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT */ -/* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF */ -/* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND */ -/* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, */ -/* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ -/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF */ -/* SUCH DAMAGE. */ -/**************************************************************************/ - -%{ - -let r = fun x -> x (* Ulib.Text.of_latin1 *) - -open Big_int -open Parse_ast - -let loc n m = Range (n, m) - -let default_opt x = function - | None -> x - | Some y -> y - -let assoc_opt key assocs = - try Some (List.assoc key assocs) with - | Not_found -> None - -let string_of_id = function - | Id_aux (Id str, _) -> str - | Id_aux (DeIid str, _) -> str - -let mk_id i n m = Id_aux (i, loc n m) -let mk_kid str n m = Kid_aux (Var str, loc n m) - -let id_of_kid = function - | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) - -let deinfix (Id_aux (Id v, l)) = Id_aux (DeIid v, l) - -let mk_effect e n m = BE_aux (e, loc n m) -let mk_typ t n m = ATyp_aux (t, loc n m) -let mk_pat p n m = P_aux (p, loc n m) -let mk_pexp p n m = Pat_aux (p, loc n m) -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_nc nc n m = NC_aux (nc, loc n m) -let mk_sd s n m = SD_aux (s, loc n m) - -let mk_funcl f n m = FCL_aux (f, loc n m) -let mk_fun fn n m = FD_aux (fn, loc n m) -let mk_td t n m = TD_aux (t, loc n m) -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 qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) - -let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) -let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) -let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) -let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) -let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) - -type lchain = - LC_lt -| LC_lteq -| LC_nexp of atyp - -let rec desugar_lchain chain s e = - match chain with - | [LC_nexp n1; LC_lteq; LC_nexp n2] -> - mk_nc (NC_bounded_le (n1, n2)) s e - | [LC_nexp n1; LC_lt; LC_nexp n2] -> - mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e - | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e - | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e - | _ -> assert false - -type rchain = - RC_gt -| RC_gteq -| RC_nexp of atyp - -let rec desugar_rchain chain s e = - match chain with - | [RC_nexp n1; RC_gteq; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, n2)) s e - | [RC_nexp n1; RC_gt; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e - | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e - | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e - | _ -> assert false - -%} - -/*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 Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef -%token Undefined Union With Val Constraint Throw Try Catch Exit -%token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape -%token Repeat Until While Do Record Mutual - -%nonassoc Then -%nonassoc Else - -%token Bar Comma Dot Eof Minus Semi Under DotDot -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar -%token MinusGt - -/*Terminals with content*/ - -%token <string> Id TyVar -%token <Big_int.big_int> Num -%token <string> String Bin Hex Real - -%token <string> Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token <string> Colon ExclEq -%token <string> GtEq -%token <string> LtEq - -%token <string> Op0 Op1 Op2 Op3 Op4 Op5 Op6 Op7 Op8 Op9 -%token <string> Op0l Op1l Op2l Op3l Op4l Op5l Op6l Op7l Op8l Op9l -%token <string> Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r - -%token <Parse_ast.fixity_token> Fixity - -%start file -%start typschm_eof -%type <Parse_ast.typschm> typschm_eof -%type <Parse_ast.defs> file - -%% - -id: - | Id { mk_id (Id $1) $startpos $endpos } - - | Op Op0 { mk_id (DeIid $2) $startpos $endpos } - | Op Op1 { mk_id (DeIid $2) $startpos $endpos } - | Op Op2 { mk_id (DeIid $2) $startpos $endpos } - | Op Op3 { mk_id (DeIid $2) $startpos $endpos } - | Op Op4 { mk_id (DeIid $2) $startpos $endpos } - | Op Op5 { mk_id (DeIid $2) $startpos $endpos } - | Op Op6 { mk_id (DeIid $2) $startpos $endpos } - | Op Op7 { mk_id (DeIid $2) $startpos $endpos } - | Op Op8 { mk_id (DeIid $2) $startpos $endpos } - | Op Op9 { mk_id (DeIid $2) $startpos $endpos } - - | Op Op0l { mk_id (DeIid $2) $startpos $endpos } - | Op Op1l { mk_id (DeIid $2) $startpos $endpos } - | Op Op2l { mk_id (DeIid $2) $startpos $endpos } - | Op Op3l { mk_id (DeIid $2) $startpos $endpos } - | Op Op4l { mk_id (DeIid $2) $startpos $endpos } - | Op Op5l { mk_id (DeIid $2) $startpos $endpos } - | Op Op6l { mk_id (DeIid $2) $startpos $endpos } - | Op Op7l { mk_id (DeIid $2) $startpos $endpos } - | Op Op8l { mk_id (DeIid $2) $startpos $endpos } - | Op Op9l { mk_id (DeIid $2) $startpos $endpos } - - | Op Op0r { mk_id (DeIid $2) $startpos $endpos } - | Op Op1r { mk_id (DeIid $2) $startpos $endpos } - | Op Op2r { mk_id (DeIid $2) $startpos $endpos } - | Op Op3r { mk_id (DeIid $2) $startpos $endpos } - | Op Op4r { mk_id (DeIid $2) $startpos $endpos } - | Op Op5r { mk_id (DeIid $2) $startpos $endpos } - | Op Op6r { mk_id (DeIid $2) $startpos $endpos } - | Op Op7r { mk_id (DeIid $2) $startpos $endpos } - | Op Op8r { mk_id (DeIid $2) $startpos $endpos } - | Op Op9r { mk_id (DeIid $2) $startpos $endpos } - - | Op Plus { mk_id (DeIid "+") $startpos $endpos } - | Op Minus { mk_id (DeIid "-") $startpos $endpos } - | Op Star { mk_id (DeIid "*") $startpos $endpos } - | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } - | Op Lt { mk_id (DeIid "<") $startpos $endpos } - | Op Gt { mk_id (DeIid ">") $startpos $endpos } - | Op LtEq { mk_id (DeIid "<=") $startpos $endpos } - | Op GtEq { mk_id (DeIid ">=") $startpos $endpos } - | Op Amp { mk_id (DeIid "&") $startpos $endpos } - | Op Bar { mk_id (DeIid "|") $startpos $endpos } - | Op Caret { mk_id (DeIid "^") $startpos $endpos } - -op0: Op0 { mk_id (Id $1) $startpos $endpos } -op1: Op1 { mk_id (Id $1) $startpos $endpos } -op2: Op2 { mk_id (Id $1) $startpos $endpos } -op3: Op3 { mk_id (Id $1) $startpos $endpos } -op4: Op4 { mk_id (Id $1) $startpos $endpos } -op5: Op5 { mk_id (Id $1) $startpos $endpos } -op6: Op6 { mk_id (Id $1) $startpos $endpos } -op7: Op7 { mk_id (Id $1) $startpos $endpos } -op8: Op8 { mk_id (Id $1) $startpos $endpos } -op9: Op9 { mk_id (Id $1) $startpos $endpos } - -op0l: Op0l { mk_id (Id $1) $startpos $endpos } -op1l: Op1l { mk_id (Id $1) $startpos $endpos } -op2l: Op2l { mk_id (Id $1) $startpos $endpos } -op3l: Op3l { mk_id (Id $1) $startpos $endpos } -op4l: Op4l { mk_id (Id $1) $startpos $endpos } -op5l: Op5l { mk_id (Id $1) $startpos $endpos } -op6l: Op6l { mk_id (Id $1) $startpos $endpos } -op7l: Op7l { mk_id (Id $1) $startpos $endpos } -op8l: Op8l { mk_id (Id $1) $startpos $endpos } -op9l: Op9l { mk_id (Id $1) $startpos $endpos } - -op0r: Op0r { mk_id (Id $1) $startpos $endpos } -op1r: Op1r { mk_id (Id $1) $startpos $endpos } -op2r: Op2r { mk_id (Id $1) $startpos $endpos } -op3r: Op3r { mk_id (Id $1) $startpos $endpos } -op4r: Op4r { mk_id (Id $1) $startpos $endpos } -op5r: Op5r { mk_id (Id $1) $startpos $endpos } -op6r: Op6r { mk_id (Id $1) $startpos $endpos } -op7r: Op7r { mk_id (Id $1) $startpos $endpos } -op8r: Op8r { mk_id (Id $1) $startpos $endpos } -op9r: Op9r { mk_id (Id $1) $startpos $endpos } - -id_list: - | id - { [$1] } - | id Comma id_list - { $1 :: $3 } - -kid: - | TyVar - { mk_kid $1 $startpos $endpos } - -kid_list: - | kid - { [$1] } - | kid kid_list - { $1 :: $2 } - -nc: - | nc Bar nc_and - { mk_nc (NC_or ($1, $3)) $startpos $endpos } - | nc_and - { $1 } - -nc_and: - | nc_and Amp atomic_nc - { mk_nc (NC_and ($1, $3)) $startpos $endpos } - | atomic_nc - { $1 } - -atomic_nc: - | True - { mk_nc NC_true $startpos $endpos } - | False - { mk_nc NC_false $startpos $endpos } - | typ Eq typ - { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ ExclEq typ - { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } - | nc_lchain - { desugar_lchain $1 $startpos $endpos } - | nc_rchain - { desugar_rchain $1 $startpos $endpos } - | Lparen nc Rparen - { $2 } - | kid In Lcurly num_list Rcurly - { mk_nc (NC_set ($1, $4)) $startpos $endpos } - -num_list: - | Num - { [$1] } - | Num Comma num_list - { $1 :: $3 } - -nc_lchain: - | typ LtEq typ - { [LC_nexp $1; LC_lteq; LC_nexp $3] } - | typ Lt typ - { [LC_nexp $1; LC_lt; LC_nexp $3] } - | typ LtEq nc_lchain - { LC_nexp $1 :: LC_lteq :: $3 } - | typ Lt nc_lchain - { LC_nexp $1 :: LC_lt :: $3 } - -nc_rchain: - | typ GtEq typ - { [RC_nexp $1; RC_gteq; RC_nexp $3] } - | typ Gt typ - { [RC_nexp $1; RC_gt; RC_nexp $3] } - | typ GtEq nc_rchain - { RC_nexp $1 :: RC_gteq :: $3 } - | typ Gt nc_rchain - { RC_nexp $1 :: RC_gt :: $3 } - -typ: - | typ0 - { $1 } - -/* The following implements all nine levels of user-defined precedence for -operators in types, with both left, right and non-associative operators */ - -typ0: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } -typ0l: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } -typ0r: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } - -typ1: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } -typ1l: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } -typ1r: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } - -typ2: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } -typ2l: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } -typ2r: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } - -typ3: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } -typ3l: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } -typ3r: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } - -typ4: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } -typ4l: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } -typ4r: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } - -typ5: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 op5r typ5r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } -typ5l: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } -typ5r: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 op5r typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } - -typ6: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } - | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } - | typ7 { $1 } -typ6l: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } - | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } - | typ7 { $1 } -typ6r: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 { $1 } - -typ7: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } - | typ8 { $1 } -typ7l: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } - | typ8 { $1 } -typ7r: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 { $1 } - -typ8: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } -typ8l: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } -typ8r: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } - -typ9: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } -typ9l: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } -typ9r: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } - -atomic_typ: - | id - { mk_typ (ATyp_id $1) $startpos $endpos } - | kid - { mk_typ (ATyp_var $1) $startpos $endpos } - | Num - { mk_typ (ATyp_constant $1) $startpos $endpos } - | Dec - { mk_typ ATyp_dec $startpos $endpos } - | Inc - { mk_typ ATyp_inc $startpos $endpos } - | id Lparen typ_list Rparen - { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } - | Register Lparen typ Rparen - { let register_id = mk_id (Id "register") $startpos $endpos in - mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } - | Lparen typ Rparen - { $2 } - | Lparen typ Comma typ_list Rparen - { mk_typ (ATyp_tup ($2 :: $4)) $startpos $endpos } - | LcurlyBar num_list RcurlyBar - { let v = mk_kid "n" $startpos $endpos in - let atom_id = mk_id (Id "atom") $startpos $endpos in - let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in - mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } - | Lcurly kid_list Dot typ Rcurly - { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } - | Lcurly kid_list Comma nc Dot typ Rcurly - { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } - -typ_list: - | typ - { [$1] } - | typ Comma typ_list - { $1 :: $3 } - -base_kind: - | Int - { BK_aux (BK_nat, loc $startpos $endpos) } - | TYPE - { BK_aux (BK_type, loc $startpos $endpos) } - | Order - { BK_aux (BK_order, loc $startpos $endpos) } - -kind: - | base_kind - { K_aux (K_kind [$1], loc $startpos $endpos) } - -kopt: - | Lparen kid Colon kind Rparen - { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } - | kid - { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } - -kopt_list: - | kopt - { [$1] } - | kopt kopt_list - { $1 :: $2 } - -typquant: - | kopt_list Comma nc - { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in - TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } - | kopt_list - { TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1), loc $startpos $endpos) } - -effect: - | Barr - { mk_effect BE_barr $startpos $endpos } - | Depend - { mk_effect BE_depend $startpos $endpos } - | Rreg - { mk_effect BE_rreg $startpos $endpos } - | Wreg - { mk_effect BE_wreg $startpos $endpos } - | Rmem - { mk_effect BE_rmem $startpos $endpos } - | Rmemt - { mk_effect BE_rmemt $startpos $endpos } - | Wmem - { mk_effect BE_wmem $startpos $endpos } - | Wmv - { mk_effect BE_wmv $startpos $endpos } - | Wmvt - { mk_effect BE_wmvt $startpos $endpos } - | Eamem - { mk_effect BE_eamem $startpos $endpos } - | Exmem - { mk_effect BE_exmem $startpos $endpos } - | Undef - { mk_effect BE_undef $startpos $endpos } - | Unspec - { mk_effect BE_unspec $startpos $endpos } - | Nondet - { mk_effect BE_nondet $startpos $endpos } - | Escape - { mk_effect BE_escape $startpos $endpos } - -effect_list: - | effect - { [$1] } - | effect Comma effect_list - { $1::$3 } - -effect_set: - | Lcurly effect_list Rcurly - { mk_typ (ATyp_set $2) $startpos $endpos } - | Pure - { mk_typ (ATyp_set []) $startpos $endpos } - -typschm: - | typ MinusGt typ - { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } - | Forall typquant Dot typ MinusGt typ - { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } - | typ MinusGt typ Effect effect_set - { (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 } - -typschm_eof: - | typschm Eof - { $1 } - -pat1: - | atomic_pat - { $1 } - | atomic_pat At pat_concat - { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } - -pat_concat: - | atomic_pat - { [$1] } - | atomic_pat At pat_concat - { $1 :: $3 } - -pat: - | pat1 - { $1 } - | pat1 As id - { mk_pat (P_as ($1, $3)) $startpos $endpos } - | pat1 As kid - { mk_pat (P_var ($1, $3)) $startpos $endpos } - -pat_list: - | pat - { [$1] } - | pat Comma pat_list - { $1 :: $3 } - -atomic_pat: - | Under - { mk_pat (P_wild) $startpos $endpos } - | lit - { mk_pat (P_lit $1) $startpos $endpos } - | id - { mk_pat (P_id $1) $startpos $endpos } - | kid - { mk_pat (P_var (mk_pat (P_id (id_of_kid $1)) $startpos $endpos, $1)) $startpos $endpos } - | id Lparen pat_list Rparen - { mk_pat (P_app ($1, $3)) $startpos $endpos } - | atomic_pat Colon typ - { mk_pat (P_typ ($3, $1)) $startpos $endpos } - | Lparen pat Rparen - { $2 } - | Lparen pat Comma pat_list Rparen - { mk_pat (P_tup ($2 :: $4)) $startpos $endpos } - | Lsquare pat_list Rsquare - { mk_pat (P_vector $2) $startpos $endpos } - -lit: - | True - { mk_lit L_true $startpos $endpos } - | False - { mk_lit L_false $startpos $endpos } - | Unit - { mk_lit L_unit $startpos $endpos } - | Num - { mk_lit (L_num $1) $startpos $endpos } - | Undefined - { mk_lit L_undef $startpos $endpos } - | Bitzero - { mk_lit L_zero $startpos $endpos } - | Bitone - { mk_lit L_one $startpos $endpos } - | Bin - { mk_lit (L_bin $1) $startpos $endpos } - | Hex - { mk_lit (L_hex $1) $startpos $endpos } - | String - { mk_lit (L_string $1) $startpos $endpos } - | Real - { mk_lit (L_real $1) $startpos $endpos } - -exp: - | exp0 - { $1 } - | atomic_exp Eq exp - { mk_exp (E_assign ($1, $3)) $startpos $endpos } - | Let_ letbind In exp - { mk_exp (E_let ($2, $4)) $startpos $endpos } - | Lcurly block Rcurly - { mk_exp (E_block $2) $startpos $endpos } - | Return exp - { mk_exp (E_return $2) $startpos $endpos } - | Throw exp - { mk_exp (E_throw $2) $startpos $endpos } - | If_ exp Then exp Else exp - { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } - | If_ exp Then exp - { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } - | Match exp Lcurly case_list Rcurly - { mk_exp (E_case ($2, $4)) $startpos $endpos } - | Try exp Catch Lcurly case_list Rcurly - { mk_exp (E_try ($2, $5)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp In typ Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" in foreach loop")); - mk_exp (E_for ($3, $5, $7, $9, $11, $13)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); - let order = - if $6 = "to" - then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) - else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) - in - mk_exp (E_for ($3, $5, $7, $9, order, $11)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); - let step = mk_lit_exp (L_num unit_big_int) $startpos $endpos in - let ord = - if $6 = "to" - then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) - else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) - in - mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } - | Repeat exp Until exp - { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } - | While exp Do exp - { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } - -/* The following implements all nine levels of user-defined precedence for -operators in expressions, with both left, right and non-associative operators */ - -exp0: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } -exp0l: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } -exp0r: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } - -exp1: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } -exp1l: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } -exp1r: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } - -exp2: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp3 { $1 } -exp2l: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 { $1 } -exp2r: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp3 { $1 } - -exp3: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4 { $1 } -exp3l: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 { $1 } -exp3r: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4 { $1 } - -exp4: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 Lt exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 Gt exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } -exp4l: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } -exp4r: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } - -exp5: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } - | exp6 { $1 } -exp5l: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 { $1 } -exp5r: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } - | exp6 { $1 } - -exp6: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp7 { $1 } -exp6l: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp7 { $1 } -exp6r: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 { $1 } - -exp7: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp8 { $1 } -exp7l: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp8 { $1 } -exp7r: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 { $1 } - -exp8: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } -exp8l: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } -exp8r: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } - -exp9: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } -exp9l: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } -exp9r: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } - -case: - | pat EqGt exp - { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } - | pat If_ exp EqGt exp - { mk_pexp (Pat_when ($1, $3, $5)) $startpos $endpos } - -case_list: - | case - { [$1] } - | case Comma case_list - { $1 :: $3 } - -block: - | exp - { [$1] } - | Let_ letbind Semi block - { [mk_exp (E_let ($2, mk_exp (E_block $4) $startpos($4) $endpos)) $startpos $endpos] } - | exp Semi /* Allow trailing semicolon in block */ - { [$1] } - | exp Semi block - { $1 :: $3 } - -%inline letbind: - | pat Eq exp - { LB_aux (LB_val ($1, $3), loc $startpos $endpos) } - -atomic_exp: - | atomic_exp Colon atomic_typ - { mk_exp (E_cast ($3, $1)) $startpos $endpos } - | lit - { mk_exp (E_lit $1) $startpos $endpos } - | atomic_exp Dot id - { mk_exp (E_field ($1, $3)) $startpos $endpos } - | id - { mk_exp (E_id $1) $startpos $endpos } - | kid - { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } - | id Unit - { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } - | id Lparen exp_list Rparen - { mk_exp (E_app ($1, $3)) $startpos $endpos } - | Exit Lparen exp Rparen - { mk_exp (E_exit $3) $startpos $endpos } - | Sizeof Lparen typ Rparen - { mk_exp (E_sizeof $3) $startpos $endpos } - | Constraint Lparen nc Rparen - { mk_exp (E_constraint $3) $startpos $endpos } - | Assert Lparen exp Rparen - { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } - | Assert Lparen exp Comma exp Rparen - { mk_exp (E_assert ($3, $5)) $startpos $endpos } - | atomic_exp Lsquare exp Rsquare - { mk_exp (E_vector_access ($1, $3)) $startpos $endpos } - | atomic_exp Lsquare exp DotDot exp Rsquare - { mk_exp (E_vector_subrange ($1, $3, $5)) $startpos $endpos } - | Record Lcurly fexp_exp_list Rcurly - { mk_exp (E_record $3) $startpos $endpos } - | Lcurly exp With fexp_exp_list Rcurly - { mk_exp (E_record_update ($2, $4)) $startpos $endpos } - | Lsquare exp_list Rsquare - { mk_exp (E_vector $2) $startpos $endpos } - | Lsquare exp With atomic_exp Eq exp Rsquare - { mk_exp (E_vector_update ($2, $4, $6)) $startpos $endpos } - | Lsquare exp With atomic_exp DotDot atomic_exp Eq exp Rsquare - { mk_exp (E_vector_update_subrange ($2, $4, $6, $8)) $startpos $endpos } - | LsquareBar exp_list RsquareBar - { mk_exp (E_list $2) $startpos $endpos } - | Lparen exp Rparen - { $2 } - | Lparen exp Comma exp_list Rparen - { mk_exp (E_tuple ($2 :: $4)) $startpos $endpos } - -fexp_exp: - | atomic_exp Eq exp - { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - -fexp_exp_list: - | fexp_exp - { [$1] } - | fexp_exp Comma fexp_exp_list - { $1 :: $3 } - -exp_list: - | exp - { [$1] } - | exp Comma exp_list - { $1 :: $3 } - -funcl_patexp: - | pat Eq exp - { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } - | Lparen pat If_ exp Rparen Eq exp - { mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos } - -funcl: - | id funcl_patexp - { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos } - -funcls: - | id funcl_patexp - { [mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos] } - | id funcl_patexp And funcls - { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos :: $4 } - -type_def: - | Typedef id typquant Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } - | Typedef id Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } - | Struct id Eq Lcurly struct_fields Rcurly - { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Struct id typquant Eq Lcurly struct_fields Rcurly - { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } - | Enum id Eq enum_bar - { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } - | Enum id Eq Lcurly enum Rcurly - { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } - | Union id Eq Lcurly type_unions Rcurly - { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Union id typquant Eq Lcurly type_unions Rcurly - { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } - -enum_bar: - | id - { [$1] } - | id Bar enum_bar - { $1 :: $3 } - -enum: - | id - { [$1] } - | id Comma enum - { $1 :: $3 } - -struct_field: - | id Colon typ - { ($3, $1) } - -struct_fields: - | struct_field - { [$1] } - | struct_field Comma - { [$1] } - | struct_field Comma struct_fields - { $1 :: $3 } - -type_union: - | id Colon typ - { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } - | id - { Tu_aux (Tu_id $1, loc $startpos $endpos) } - -type_unions: - | type_union - { [$1] } - | type_union Comma - { [$1] } - | type_union Comma type_unions - { $1 :: $3 } - -fun_def: - | Function_ funcls - { mk_fun (FD_function (mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } - -fun_def_list: - | fun_def - { [$1] } - | fun_def fun_def_list - { $1 :: $2 } - -let_def: - | Let_ letbind - { $2 } - -externs: - | id Colon String - { [(string_of_id $1, $3)] } - | id Colon String Comma externs - { (string_of_id $1, $3) :: $5 } - -val_spec_def: - | Val id Colon typschm - { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } - | Val Cast id Colon typschm - { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } - | Val id Eq String Colon typschm - { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } - | Val Cast id Eq String Colon typschm - { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } - | Val String Colon typschm - { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } - | Val Cast String Colon typschm - { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } - | Val id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } - | Val Cast id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } - -register_def: - | Register id Colon typ - { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } - -default_def: - | Default base_kind Inc - { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } - | Default base_kind Dec - { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } - -scattered_def: - | Union id typquant - { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } - | Union id - { 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 } - -def: - | fun_def - { DEF_fundef $1 } - | Fixity - { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } - | val_spec_def - { DEF_spec $1 } - | type_def - { DEF_type $1 } - | let_def - { DEF_val $1 } - | register_def - { DEF_reg_dec $1 } - | Overload id Eq Lcurly id_list Rcurly - { DEF_overload ($2, $5) } - | Overload id Eq enum_bar - { DEF_overload ($2, $4) } - | Scattered scattered_def - { DEF_scattered $2 } - | Function_ Clause funcl - { DEF_scattered (mk_sd (SD_scattered_funcl $3) $startpos $endpos) } - | Union Clause id Eq type_union - { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } - | End id - { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } - | default_def - { DEF_default $1 } - | Mutual Lcurly fun_def_list Rcurly - { DEF_internal_mutrec $3 } - -defs_list: - | def - { [$1] } - | def defs_list - { $1::$2 } - -defs: - | defs_list - { (Defs $1) } - -file: - | defs Eof - { $1 } diff --git a/src/pre_lexer.mll b/src/pre_lexer.mll deleted file mode 100644 index 3c308b99..00000000 --- a/src/pre_lexer.mll +++ /dev/null @@ -1,205 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -{ -open Pre_parser -module M = Map.Make(String) -exception LexError of string * Lexing.position - -let r = fun s -> s (* Ulib.Text.of_latin1 *) -(* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) -let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) - -let kw_table = - List.fold_left - (fun r (x,y) -> M.add x y r) - M.empty - [ - ("and", (fun _ -> Other)); - ("as", (fun _ -> Other)); - ("bits", (fun _ -> Other)); - ("by", (fun _ -> Other)); - ("case", (fun _ -> Other)); - ("clause", (fun _ -> Other)); - ("const", (fun _ -> Other)); - ("dec", (fun _ -> Other)); - ("default", (fun _ -> Other)); - ("deinfix", (fun _ -> Other)); - ("effect", (fun _ -> Other)); - ("Effects", (fun _ -> Other)); - ("end", (fun _ -> Other)); - ("enumerate", (fun _ -> Other)); - ("else", (fun _ -> Other)); - ("extern", (fun _ -> Other)); - ("false", (fun _ -> Other)); - ("forall", (fun _ -> Other)); - ("foreach", (fun _ -> Other)); - ("function", (fun x -> Other)); - ("if", (fun x -> Other)); - ("in", (fun x -> Other)); - ("IN", (fun x -> Other)); - ("Inc", (fun x -> Other)); - ("let", (fun x -> Other)); - ("member", (fun x -> Other)); - ("Nat", (fun x -> Other)); - ("Order", (fun x -> Other)); - ("pure", (fun x -> Other)); - ("rec", (fun x -> Other)); - ("register", (fun x -> Other)); - ("return", (fun x -> Other)); - ("scattered", (fun x -> Other)); - ("struct", (fun x -> Other)); - ("sizeof", (fun x -> Other)); - ("switch", (fun x -> Other)); - ("then", (fun x -> Other)); - ("true", (fun x -> Other)); - ("Type", (fun x -> Other)); - ("typedef", (fun x -> Typedef)); - ("def", (fun x -> Def)); - ("undefined", (fun x -> Other)); - ("union", (fun x -> Other)); - ("with", (fun x -> Other)); - ("val", (fun x -> Other)); - - ("AND", (fun x -> Other)); - ("div", (fun x -> Other)); - ("EOR", (fun x -> Other)); - ("mod", (fun x -> Other)); - ("OR", (fun x -> Other)); - ("quot", (fun x -> Other)); - ("rem", (fun x -> Other)); -] - -} - -let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z'] -let digit = ['0'-'9'] -let binarydigit = ['0'-'1'] -let hexdigit = ['0'-'9''A'-'F''a'-'f'] -let alphanum = letter|digit -let startident = letter|'_' -let ident = alphanum|['_''\'''#'] -let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] -let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) - -rule token = parse - | ws - { token lexbuf } - | "\n" - { Lexing.new_line lexbuf; - token lexbuf } - - | "2**" | "&" | "@" | "|" | "^" | ":" | "," | "." | "/" | "=" | "!" | ">" | "-" | "<" | - "+" | ";" | "*" | "~" | "_" | "{" | "}" | "(" | ")" | "[" | "]" | "&&" | "||" | "|]" | "||]" | - "^^" | "::" | ":>" | ":=" | ".." | "=/=" | "==" | "!=" | "!!" | ">=" | ">=+" | ">>" | ">>>" | ">+" | - "#>>" | "#<<" | "->" | "<:" | "<=" | "<=+" | "<>" | "<<" | "<<<" | "<+" | "**" | "~^" | ">=_s" | - ">=_si" | ">=_u" | ">=_ui" | ">>_u" | ">_s" | ">_si" | ">_u" | ">_ui" | "<=_s" | "<=_si" | - "<=_u" | "<=_ui" | "<_s" | "<_si" | "<_u" | "<_ui" | "**_s" | "**_si" | "*_u" | "*_ui"| "2^" { Other } - - - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - - | startident ident* as i { if M.mem i kw_table then - (M.find i kw_table) () - else - Id(r i) } - | tyvar_start startident ident* { Other } - | "&" oper_char+ | "@" oper_char+ | "^" oper_char+ | "/" oper_char+ | "=" oper_char+ | - "!" oper_char+ | ">" oper_char+ | "<" oper_char+ | "+" oper_char+ | "*" oper_char+ | - "~" oper_char+ | "&&" oper_char+ | "^^" oper_char+| "::" oper_char+| "=/=" oper_char+ | - "==" oper_char+ | "!=" oper_char+ | "!!" oper_char+ | ">=" oper_char+ | ">=+" oper_char+ | - ">>" oper_char+ | ">>>" oper_char+ | ">+" oper_char+ | "#>>" oper_char+ | "#<<" oper_char+ | - "<=" oper_char+ | "<=+" oper_char+ | "<<" oper_char+ | "<<<" oper_char+ | "<+" oper_char+ | - "**" oper_char+ | "~^" oper_char+ | ">=_s" oper_char+ | ">=_si" oper_char+ | ">=_u" oper_char+ | - ">=_ui" oper_char+ | ">>_u" oper_char+ | ">_s" oper_char+ | ">_si" oper_char+| ">_u" oper_char+ | - ">_ui" oper_char+ | "<=_s" oper_char+ | "<=_si" oper_char+ | "<=_u" oper_char+ | "<=_ui" oper_char+ | - "<_s" oper_char+ | "<_si" oper_char+ | "<_u" oper_char+ | "<_ui" oper_char+ | "**_s" oper_char+ | - "**_si" oper_char+ | "*_u" oper_char+ | "*_ui" oper_char+ | "2^" oper_char+ { Other } - | digit+ { Other } - | "0b" (binarydigit+) { Other } - | "0x" (hexdigit+) { Other } - | '"' { let _ = string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf in Other } - | eof { Eof } - | _ as c { raise (LexError( - Printf.sprintf "Unexpected character: %c" c, - Lexing.lexeme_start_p lexbuf)) } - - -and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () - else if depth > 0 then comment pos (depth-1) lexbuf - else assert false } - | "\n" { Lexing.new_line lexbuf; - comment pos depth lexbuf } - | '"' { ignore(string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf); - comment pos depth lexbuf } - | _ { comment pos depth lexbuf } - | eof { raise (LexError("Unbalanced comment", pos)) } - -and string pos b = parse - | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; - Buffer.add_string b i; - string pos b lexbuf } - | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } - | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } - | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } - | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "illegal backslash escape in string"*) } - | '"' { let s = unescaped(Buffer.contents b) in - (*try Ulib.UTF8.validate s; s - with Ulib.UTF8.Malformed_code -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal is not valid utf8"))) *) s } - | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal not terminated")))*) } diff --git a/src/pre_parser.mly b/src/pre_parser.mly deleted file mode 100644 index 0b4833a1..00000000 --- a/src/pre_parser.mly +++ /dev/null @@ -1,94 +0,0 @@ -/**************************************************************************/ -/* Sail */ -/* */ -/* Copyright (c) 2013-2017 */ -/* Kathyrn Gray */ -/* Shaked Flur */ -/* Stephen Kell */ -/* Gabriel Kerneis */ -/* Robert Norton-Wright */ -/* Christopher Pulte */ -/* Peter Sewell */ -/* Alasdair Armstrong */ -/* Brian Campbell */ -/* Thomas Bauereiss */ -/* Anthony Fox */ -/* Jon French */ -/* Dominic Mulligan */ -/* Stephen Kell */ -/* Mark Wassell */ -/* */ -/* All rights reserved. */ -/* */ -/* This software was developed by the University of Cambridge Computer */ -/* Laboratory as part of the Rigorous Engineering of Mainstream Systems */ -/* (REMS) project, funded by EPSRC grant EP/K008528/1. */ -/* */ -/* Redistribution and use in source and binary forms, with or without */ -/* modification, are permitted provided that the following conditions */ -/* are met: */ -/* 1. Redistributions of source code must retain the above copyright */ -/* notice, this list of conditions and the following disclaimer. */ -/* 2. Redistributions in binary form must reproduce the above copyright */ -/* notice, this list of conditions and the following disclaimer in */ -/* the documentation and/or other materials provided with the */ -/* distribution. */ -/* */ -/* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' */ -/* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED */ -/* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A */ -/* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR */ -/* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, */ -/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT */ -/* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF */ -/* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND */ -/* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, */ -/* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ -/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF */ -/* SUCH DAMAGE. */ -/**************************************************************************/ - -%{ - -let r = fun x -> x (* Ulib.Text.of_latin1 *) - -%} - -/*Terminals with no content*/ - -%token Scattered Typedef Def Other Eof - -%token <string> Id -%start file -%type <string list> file - -%% - -id_found: - | Typedef Id - { $2 } - | Def Other Id - { $3 } - -skip: - | Scattered - { () } - | Id - { () } - | Other - { () } - -scan_file: - | id_found Eof - { [$1] } - | skip Eof - { [] } - | id_found scan_file - { $1::$2 } - | skip scan_file - { $2 } - -file: - | scan_file - { $1 } - diff --git a/src/pretty_print.ml b/src/pretty_print.ml index 8047ff32..8f0c0386 100644 --- a/src/pretty_print.ml +++ b/src/pretty_print.ml @@ -49,5 +49,4 @@ (**************************************************************************) include Pretty_print_lem_ast -include Pretty_print_sail include Pretty_print_lem diff --git a/src/pretty_print.mli b/src/pretty_print.mli index c01e0b93..b459926b 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -51,11 +51,6 @@ open Ast open Type_check -(* Prints the defs following source syntax *) -val pp_defs : out_channel -> 'a defs -> unit -val pp_exp : Buffer.t -> 'a exp -> unit -val pat_to_string : 'a pat -> string - (* Prints on formatter the defs as Lem Ast nodes *) val pp_lem_defs : Format.formatter -> tannot defs -> unit val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index bad03034..254af4d7 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -49,7 +49,7 @@ (**************************************************************************) open Ast -open Big_int +module Big_int = Nat_big_num open PPrint let pipe = string "|" @@ -76,7 +76,7 @@ let comma_sp = comma ^^ space let colon_sp = spaces colon let doc_var (Kid_aux(Var v,_)) = string v -let doc_int i = string (string_of_big_int i) +let doc_int i = string (Big_int.to_string i) let doc_op symb a b = infix 2 1 symb a b let doc_unop symb a = prefix 2 1 symb a @@ -102,6 +102,8 @@ let doc_effect (BE_aux (e,_)) = | BE_wmem -> "wmem" | BE_wmv -> "wmv" | BE_wmvt -> "wmvt" + | BE_lset -> "lset" + | BE_lret -> "lret" | BE_eamem -> "eamem" | BE_exmem -> "exmem" | BE_barr -> "barr" @@ -112,7 +114,6 @@ let doc_effect (BE_aux (e,_)) = | BE_nondet -> "nondet") let doc_effects (Effect_aux(e,_)) = match e with - | Effect_var v -> doc_var v | Effect_set [] -> string "pure" | Effect_set s -> braces (separate_map comma_sp doc_effect s) @@ -134,51 +135,12 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = | Typ_tup typs -> parens (separate_map comma_sp app_typ typs) | _ -> app_typ ty and app_typ ((Typ_aux (t, _)) as ty) = match t with - (*TODO Need to un bid-endian-ify this here, since both can transform to the shorthand, especially with <: and :> *) - (* Special case simple vectors to improve legibility - * XXX we assume big-endian here, as usual *) -(* - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_inc, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = 0 then doc_int m else doc_op colon (doc_int n) (doc_int (n+m-1)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = m-1 then doc_int m else doc_op colon (doc_int n) (doc_int (m+1 -n)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_minus (Nexp_aux(Nexp_constant n, _), - Nexp_aux(Nexp_constant 1, _)),_)),_); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = m then doc_int m else doc_op colon (doc_int m) (doc_int (n-1)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_minus (n', Nexp_aux((Nexp_constant 1), _)),_) as n_n),_); - Typ_arg_aux(Typ_arg_nexp m_nexp, _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n' = m_nexp then nexp m_nexp else doc_op colon (nexp m_nexp) (nexp n_n))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_sum (n', Nexp_aux((Nexp_constant -1), _)),_) as n_n),_); - Typ_arg_aux(Typ_arg_nexp m_nexp, _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n' = m_nexp then nexp m_nexp else doc_op colon (nexp m_nexp) (nexp n_n))) - *) | Typ_app(Id_aux (Id "range", _), [ Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); Typ_arg_aux(Typ_arg_nexp m, _);]) -> - (squarebars (if eq_big_int n zero_big_int then nexp m else doc_op colon (doc_int n) (nexp m))) + (squarebars (if Big_int.equal n Big_int.zero then nexp m else doc_op colon (doc_int n) (nexp m))) | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> - (squarecolons (nexp n)) + (squarecolons (nexp n)) | Typ_app(id,args) -> (* trailing space to avoid >> token in case of nested app types *) (doc_id id) ^^ (angles (separate_map comma_sp doc_typ_arg args)) ^^ space @@ -186,7 +148,7 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = and atomic_typ ((Typ_aux (t, _)) as ty) = match t with | Typ_id id -> doc_id id | Typ_var v -> doc_var v - | Typ_app _ | Typ_tup _ | Typ_fn _ -> + | Typ_app _ | Typ_tup _ | Typ_fn _ | Typ_exist _ -> (* exhaustiveness matters here to avoid infinite loops * if we add a new Typ constructor *) group (parens (typ ty)) @@ -220,7 +182,8 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = and atomic_nexp_typ ((Nexp_aux(n,_)) as ne) = match n with | Nexp_var v -> doc_var v | Nexp_id i -> braces (doc_id i) - | Nexp_constant i -> if lt_big_int i zero_big_int then parens(doc_int i) else doc_int i + | Nexp_app (op, args) -> doc_id op ^^ parens (separate_map (comma ^^ space) nexp args) + | Nexp_constant i -> if Big_int.less i Big_int.zero then parens(doc_int i) else doc_int i | Nexp_neg _ | Nexp_exp _ | Nexp_times _ | Nexp_sum _ | Nexp_minus _-> group (parens (nexp ne)) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 6a3d1293..0002f8cc 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -52,7 +52,6 @@ open Type_check open Ast open Ast_util open Rewriter -open Big_int open PPrint open Pretty_print_common @@ -152,27 +151,23 @@ let effectful_set = | BE_escape -> true | _ -> false) -let effectful (Effect_aux (eff,_)) = - match eff with - | Effect_var _ -> failwith "effectful: Effect_var not supported" - | Effect_set effs -> effectful_set effs +let effectful (Effect_aux (Effect_set effs, _)) = effectful_set effs let is_regtyp (Typ_aux (typ, _)) env = match typ with | Typ_app(id, _) when string_of_id id = "register" -> true - | Typ_id(id) when Env.is_regtyp id env -> true | _ -> false let doc_nexp_lem nexp = let (Nexp_aux (nexp, l) as full_nexp) = nexp_simp nexp in match nexp with - | Nexp_constant i -> string ("ty" ^ string_of_big_int i) + | Nexp_constant i -> string ("ty" ^ Big_int.to_string i) | Nexp_var v -> string (string_of_kid (orig_kid v)) | _ -> let rec mangle_nexp (Nexp_aux (nexp, _)) = begin match nexp with | Nexp_id id -> string_of_id id | Nexp_var kid -> string_of_id (id_of_kid (orig_kid kid)) - | Nexp_constant i -> Pretty_print_lem_ast.lemnum string_of_big_int i + | Nexp_constant i -> Pretty_print_lem_ast.lemnum Big_int.to_string i | Nexp_times (n1, n2) -> mangle_nexp n1 ^ "_times_" ^ mangle_nexp n2 | Nexp_sum (n1, n2) -> mangle_nexp n1 ^ "_plus_" ^ mangle_nexp n2 | Nexp_minus (n1, n2) -> mangle_nexp n1 ^ "_minus_" ^ mangle_nexp n2 @@ -369,10 +364,10 @@ let doc_lit_lem in_pat (L_aux(lit,l)) a = | L_false -> utf8string "false" | L_true -> utf8string "true" | L_num i -> - let ipp = string_of_big_int i in + let ipp = Big_int.to_string i in utf8string ( if in_pat then "("^ipp^":nn)" - else if lt_big_int i zero_big_int then "((0"^ipp^"):ii)" + else if Big_int.less i Big_int.zero then "((0"^ipp^"):ii)" else "("^ipp^":ii)") | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) @@ -398,14 +393,14 @@ let doc_lit_lem in_pat (L_aux(lit,l)) a = using this would require adding a dependency on ZArith to Sail. *) let parts = Util.split_on_char '.' s in let (num, denom) = match parts with - | [i] -> (big_int_of_string i, unit_big_int) + | [i] -> (Big_int.of_string i, Big_int.of_int 1) | [i;f] -> - let denom = power_int_positive_int 10 (String.length f) in - (add_big_int (mult_big_int (big_int_of_string i) denom) (big_int_of_string f), denom) + let denom = Big_int.pow_int_positive 10 (String.length f) in + (Big_int.add (Big_int.mul (Big_int.of_string i) denom) (Big_int.of_string f), denom) | _ -> raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, "could not parse real literal"))) in - separate space (List.map string ["realFromFrac"; string_of_big_int num; string_of_big_int denom]) + separate space (List.map string ["realFromFrac"; Big_int.to_string num; Big_int.to_string denom]) (* typ_doc is the doc for the type being quantified *) let doc_quant_item vars_included (QI_aux (qi, _)) = match qi with @@ -735,18 +730,6 @@ let doc_exp_lem, doc_let_lem = | E_field((E_aux(_,(l,fannot)) as fexp),id) -> let ft = typ_of_annot (l,fannot) in (match fannot with - | Some(env, (Typ_aux (Typ_id tid, _)), _) - | Some(env, (Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]), _)), _) - when Env.is_regtyp tid env -> - let t = (* Env.base_typ_of (env_of full_exp) *) (typ_of full_exp) in - let eff = effect_of full_exp in - let field_f = doc_id_lem tid ^^ underscore ^^ doc_id_lem id ^^ dot ^^ string "get_field" in - let (ta,aexp_needed) = - if typ_needs_printed t - then (doc_tannot_lem (effectful eff) t, true) - else (empty, aexp_needed) in - let epp = field_f ^^ space ^^ (expY fexp) in - if aexp_needed then parens (align epp ^^ ta) else (epp ^^ ta) | Some(env, (Typ_aux (Typ_id tid, _)), _) when Env.is_record tid env -> let fname = if prefix_recordtype @@ -802,7 +785,7 @@ let doc_exp_lem, doc_let_lem = "E_vector of non-vector type") in let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in let start = match nexp_simp start with - | Nexp_aux (Nexp_constant i, _) -> string_of_big_int i + | Nexp_aux (Nexp_constant i, _) -> Big_int.to_string i | _ -> if dir then "0" else string_of_int (List.length exps) in let expspp = match exps with @@ -875,8 +858,8 @@ let doc_exp_lem, doc_let_lem = | E_app_infix (e1,id,e2) -> raise (Reporting_basic.err_unreachable l "E_app_infix should have been rewritten before pretty-printing") - | E_internal_let(lexp, eq_exp, in_exp) -> - raise (report l "E_internal_lets should have been removed before pretty-printing") + | E_var(lexp, eq_exp, in_exp) -> + raise (report l "E_vars should have been removed before pretty-printing") | E_internal_plet (pat,e1,e2) -> let epp = let b = match e1 with E_aux (E_if _,_) -> true | _ -> false in @@ -997,12 +980,12 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with - | _ -> (zero_big_int, true) in + | _ -> (Big_int.zero, true) in doc_op equals (concat [string "let "; parens (concat [doc_id_lem id; underscore; doc_id_lem fid; rfannot])]) (anglebars (concat [space; doc_op equals (string "field_name") (string_lit (doc_id_lem fid)); semi_sp; - doc_op equals (string "field_start") (string (string_of_big_int start)); semi_sp; + doc_op equals (string "field_start") (string (Big_int.to_string start)); semi_sp; doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp; doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp; doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in @@ -1191,36 +1174,6 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with fromInterpValuePP ^^ hardline ^^ hardline ^^ fromToInterpValuePP ^^ hardline else empty) - | TD_register(id,n1,n2,rs) -> - match n1, n2 with - | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> - let dir_b = i1 < i2 in - let dir = (if dir_b then "true" else "false") in - let dir_suffix = (if dir_b then "_inc" else "_dec") in - let ord = Ord_aux ((if dir_b then Ord_inc else Ord_dec), Parse_ast.Unknown) in - let size = if dir_b then add_big_int (sub_big_int i2 i1) unit_big_int else add_big_int (sub_big_int i1 i2) unit_big_int in - let vtyp = vector_typ (nconstant i1) (nconstant size) ord bit_typ in - let tannot = doc_tannot_lem false vtyp in - let doc_rid (r,id) = parens (separate comma_sp [string_lit (doc_id_lem id); - doc_range_lem r;]) in - let doc_rids = group (separate_map (semi ^^ (break 1)) doc_rid rs) in - doc_op equals - (concat [string "type";space;doc_id_lem id]) - (doc_typ_lem vtyp) - ^^ hardline ^^ - doc_op equals - (concat [string "let";space;string "cast_";doc_id_lem id;space;string "reg"]) - (string "reg") - ^^ hardline ^^ - doc_op equals - (concat [string "let";space;string "cast_to_";doc_id_lem id;space;string "reg"]) - (string "reg") - ^^ hardline ^^ - doc_op equals - (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) - (string "Register" ^^ space ^^ - align (separate space [string "regname"; doc_int size; doc_int i1; string dir; - break 0 ^^ brackets (align doc_rids)])) | _ -> raise (Reporting_basic.err_unreachable l "register with non-constant indices") let args_of_typ l env typ = @@ -1377,29 +1330,22 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) = if !opt_sequential then empty else let env = env_of_annot annot in - (match typ with - | Typ_aux (Typ_id idt, _) when Env.is_regtyp idt env -> - separate space [string "let";doc_id_lem id;equals; - string "build_" ^^ string (string_of_id idt);string_lit (doc_id_lem id)] ^/^ hardline - | _ -> - let rt = Env.base_typ_of env typ in - if is_vector_typ rt then - let (start, size, order, etyp) = vector_typ_args_of rt in - if is_bit_typ etyp && is_nexp_constant start && is_nexp_constant size then - let o = if is_order_inc order then "true" else "false" in - (doc_op equals) - (string "let" ^^ space ^^ doc_id_lem id) - (string "Register" ^^ space ^^ - align (separate space [string_lit(doc_id_lem id); - doc_nexp (size); - doc_nexp (start); - string o; - string "[]"])) - ^/^ hardline - else raise (Reporting_basic.err_unreachable l - ("can't deal with register type " ^ string_of_typ typ)) - else raise (Reporting_basic.err_unreachable l - ("can't deal with register type " ^ string_of_typ typ))) + let rt = Env.base_typ_of env typ in + if is_vector_typ rt then + let (start, size, order, etyp) = vector_typ_args_of rt in + if is_bit_typ etyp && is_nexp_constant start && is_nexp_constant size then + let o = if is_order_inc order then "true" else "false" in + (doc_op equals) + (string "let" ^^ space ^^ doc_id_lem id) + (string "Register" ^^ space ^^ + align (separate space [string_lit(doc_id_lem id); + doc_nexp (size); + doc_nexp (start); + string o; + string "[]"])) + ^/^ hardline + else raise (Reporting_basic.err_unreachable l ("can't deal with register type " ^ string_of_typ typ)) + else raise (Reporting_basic.err_unreachable l ("can't deal with register type " ^ string_of_typ typ)) | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty @@ -1412,15 +1358,6 @@ let doc_spec_lem (VS_aux (valspec,annot)) = (* | VS_val_spec (_,_,Some _,_) -> empty *) | _ -> empty -let find_regtypes defs = - List.fold_left - (fun acc def -> - match def with - | DEF_type (TD_aux(TD_register (Id_aux (Id tname, _), n1, n2, fields),_)) -> - (tname, (n1, n2, fields)) :: acc - | _ -> acc - ) [] defs - let is_field_accessor regtypes fdef = let is_field_of regtyp field = List.exists (fun (tname, (_, _, fields)) -> tname = regtyp && @@ -1443,11 +1380,11 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = | BF_aux (BF_range (i, j), _) -> (i, j) | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in - let fsize = succ_big_int (abs_big_int (sub_big_int i j)) in + let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in (* TODO Assumes normalised, decreasing bitvector slices; however, since start indices or indexing order do not appear in Lem type annotations, this does not matter. *) - let ftyp = vector_typ (nconstant (pred_big_int fsize)) (nconstant fsize) dec_ord bit_typ in + let ftyp = vector_typ (nconstant fsize) dec_ord bit_typ in let reftyp = mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), [mk_typ_arg (Typ_arg_typ (mk_id_typ (mk_id tname))); @@ -1457,7 +1394,7 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = (concat [string "let "; parens (concat [string tname; underscore; doc_id_lem fid; rfannot])]) (concat [ space; langlebar; string " field_name = \"" ^^ doc_id_lem fid ^^ string "\";"; hardline; - space; space; space; string (" field_start = " ^ string_of_big_int i ^ ";"); hardline; + space; space; space; string (" field_start = " ^ Big_int.to_string i ^ ";"); hardline; space; space; space; string (" field_is_inc = " ^ dir ^ ";"); hardline; space; space; space; string (" get_field = get_" ^ tname ^ "_" ^ string_of_id fid ^ ";"); hardline; space; space; space; string (" set_field = set_" ^ tname ^ "_" ^ string_of_id fid ^ " "); ranglebar]) @@ -1491,7 +1428,7 @@ let rec doc_def_lem regtypes def = let doc_defs_lem (Defs defs) = - let regtypes = find_regtypes defs in + let regtypes = [] in let field_refs = separate_map hardline doc_regtype_fields regtypes in let (typdefs,valdefs) = List.split (List.map (doc_def_lem regtypes) defs) in (separate empty typdefs ^^ field_refs, separate empty valdefs) @@ -1564,10 +1501,10 @@ let doc_register_refs_lem registers = raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with - | _ -> (zero_big_int, true) in + | _ -> (Big_int.zero, true) in concat [string "let "; idd; string " = <|"; hardline; string " reg_name = \""; idd; string "\";"; hardline; - string " reg_start = "; string (string_of_big_int start); string ";"; hardline; + string " reg_start = "; string (Big_int.to_string start); string ";"; hardline; string " reg_is_inc = "; string (if is_inc then "true" else "false"); string ";"; hardline; string " read_from = (fun s -> s."; field; string ");"; hardline; string " write_to = (fun s v -> (<| s with "; field; string " = v |>)) |>"] in diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 3b7a7345..21001f55 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -51,7 +51,6 @@ open Type_check open Ast open Format -open Big_int open Pretty_print_common (**************************************************************************** @@ -78,11 +77,11 @@ let base ppf s = fprintf ppf "%s" s let quot_string ppf s = fprintf ppf "\"%s\"" s let lemnum default n = - if le_big_int zero_big_int n && le_big_int n (big_int_of_int 128) then - "int" ^ string_of_big_int n - else if ge_big_int n zero_big_int then + if Big_int.less_equal Big_int.zero n && Big_int.less_equal n (Big_int.of_int 128) then + "int" ^ Big_int.to_string n + else if Big_int.greater_equal n Big_int.zero then default n - else ("(int0 - " ^ (default (abs_big_int n)) ^ ")") + else ("(int0 - " ^ (default (Big_int.abs n)) ^ ")") let pp_format_id (Id_aux(i,_)) = match i with @@ -151,7 +150,8 @@ and pp_format_nexp_lem (Nexp_aux(n,l)) = (match n with | Nexp_id(i) -> "(Nexp_id " ^ pp_format_id_lem i ^ ")" | Nexp_var(v) -> "(Nexp_var " ^ pp_format_var_lem v ^ ")" - | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum string_of_big_int i) ^ ")" + | Nexp_app(op,args) -> "(Nexp_app [" ^ Util.string_of_list ", " pp_format_nexp_lem args ^ "])" + | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum Big_int.to_string i) ^ ")" | Nexp_sum(n1,n2) -> "(Nexp_sum " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_minus(n1,n2) -> "(Nexp_minus " ^ (pp_format_nexp_lem n1)^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_times(n1,n2) -> "(Nexp_times " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" @@ -189,7 +189,6 @@ and pp_format_base_effect_lem (BE_aux(e,l)) = and pp_format_effects_lem (Effect_aux(e,l)) = "(Effect_aux " ^ (match e with - | Effect_var(v) -> "(Effect_var " ^ pp_format_var v ^ ")" | Effect_set(efcts) -> "(Effect_set [" ^ (list_format "; " pp_format_base_effect_lem efcts) ^ " ])") ^ " " ^ @@ -215,7 +214,7 @@ and pp_format_nexp_constraint_lem (NC_aux(nc,l)) = | NC_set(id,bounds) -> "(NC_set " ^ pp_format_var_lem id ^ " [" ^ - list_format "; " string_of_big_int bounds ^ + list_format "; " Big_int.to_string bounds ^ "])") ^ " " ^ (pp_format_l_lem l) ^ ")" @@ -278,7 +277,7 @@ let pp_format_lit_lem (L_aux(lit,l)) = | L_one -> "L_one" | L_true -> "L_true" | L_false -> "L_false" - | L_num(i) -> "(L_num " ^ (lemnum string_of_big_int i) ^ ")" + | L_num(i) -> "(L_num " ^ (lemnum Big_int.to_string i) ^ ")" | L_hex(n) -> "(L_hex \"" ^ n ^ "\")" | L_bin(n) -> "(L_bin \"" ^ n ^ "\")" | L_undef -> "L_undef" @@ -356,6 +355,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = (list_pp pp_semi_lem_exp pp_lem_exp) exps kwd ")" pp_lem_l l pp_annot annot | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l (pp_annot_tag (tag_id id env)) annot + | E_ref(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_ref" pp_lem_id id pp_lem_l l (pp_annot_tag (tag_id id env)) annot | E_lit(lit) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_lit" pp_lem_lit lit pp_lem_l l pp_annot annot | E_cast(typ,exp) -> fprintf ppf "@[<0>(E_aux (E_cast %a %a) (%a, %a))@]" pp_lem_typ typ pp_lem_exp exp pp_lem_l l pp_annot annot @@ -408,6 +408,9 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = | E_case(exp,pexps) -> fprintf ppf "@[<0>(E_aux (E_case %a [%a]) (%a, %a))@]" pp_lem_exp exp (list_pp pp_semi_lem_case pp_lem_case) pexps pp_lem_l l pp_annot annot + | E_try(exp,pexps) -> + fprintf ppf "@[<0>(E_aux (E_try %a [%a]) (%a, %a))@]" + pp_lem_exp exp (list_pp pp_semi_lem_case pp_lem_case) pexps pp_lem_l l pp_annot annot | E_let(leb,exp) -> fprintf ppf "@[<0>(E_aux (E_let %a %a) (%a, %a))@]" pp_lem_let leb pp_lem_exp exp pp_lem_l l pp_annot annot | E_assign(lexp,exp) -> fprintf ppf "@[<0>(E_aux (E_assign %a %a) (%a, %a))@]" @@ -418,38 +421,20 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = fprintf ppf "@[<0>(E_aux (E_constraint %a) (%a, %a))@]" pp_lem_nexp_constraint nc pp_lem_l l pp_annot annot | E_exit exp -> fprintf ppf "@[<0>(E_aux (E_exit %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot + | E_throw exp -> + fprintf ppf "@[<0>(E_aux (E_throw %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_return exp -> fprintf ppf "@[<0>(E_aux (E_return %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_assert(c,msg) -> fprintf ppf "@[<0>(E_aux (E_assert %a %a) (%a, %a))@]" pp_lem_exp c pp_lem_exp msg pp_lem_l l pp_annot annot - (* - | E_internal_exp ((l, Base((_,t),_,_,_,_,bindings))) -> - (*TODO use bindings where appropriate*) - (match t.t with - | Tapp("register",[TA_typ {t=Tapp("vector",[TA_nexp _;TA_nexp r;_;_])}]) - | Tapp("vector",[TA_nexp _;TA_nexp r;_;_]) -> - (match r.nexp with - | Nconst bi -> fprintf ppf "@[<0>(E_aux (E_lit (L_aux (L_num %a) %a)) (%a, %a))@]" - kwd (lemnum string_of_int (int_of_big_int bi)) pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | Nvar v -> fprintf ppf "@[<0>(E_aux (E_id (Id_aux (Id \"%a\") %a)) (%a,%a))@]" - kwd v pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given vector without known length")) - | Tapp("implicit",[TA_nexp r]) -> - (match r.nexp with - | Nconst bi -> fprintf ppf "@[<0>(E_aux (E_lit (L_aux (L_num %a) %a)) (%a, %a))@]" - kwd (lemnum string_of_int (int_of_big_int bi)) pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | Nvar v -> fprintf ppf "@[<0>(E_aux (E_id (Id_aux (Id \"%a\") %a)) (%a,%a))@]" - kwd v pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | _ -> raise (Reporting_basic.err_unreachable l "Internal_exp given implicit without variable or const")) - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given non-vector or implicit")*) | E_comment _ | E_comment_struc _ -> fprintf ppf "@[(E_aux (E_lit (L_aux L_unit %a)) (%a,%a))@]" pp_lem_l l pp_lem_l l pp_annot annot | E_internal_cast _ | E_internal_exp _ -> raise (Reporting_basic.err_unreachable l "Found internal cast or exp") | E_internal_exp_user _ -> (raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_exp_user")) | E_sizeof_internal _ -> (raise (Reporting_basic.err_unreachable l "Internal sizeof not removed")) - | E_internal_let (lexp,exp1,exp2) -> - fprintf ppf "@[<0>(E_aux (E_internal_let %a %a %a) (%a, %a))@]" + | E_var (lexp,exp1,exp2) -> + fprintf ppf "@[<0>(E_aux (E_var %a %a %a) (%a, %a))@]" pp_lem_lexp lexp pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot | E_internal_return exp -> fprintf ppf "@[<0>(E_aux (E_internal_return %a) (%a, %a))@]" @@ -457,6 +442,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = | E_internal_plet (pat,exp1,exp2) -> fprintf ppf "@[<0>(E_aux (E_internal_plet %a %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot + | E_internal_value _ -> raise (Reporting_basic.err_unreachable l "Found internal_value") in print_e ppf e @@ -476,15 +462,17 @@ and pp_semi_lem_case ppf case = fprintf ppf "@[<1>%a %a@]" pp_lem_case case kwd and pp_lem_lexp ppf (LEXP_aux(lexp,(l,annot))) = let print_le ppf lexp = match lexp with - | LEXP_id(id) -> fprintf ppf "(%a %a)" kwd "LEXP_id" pp_lem_id id - | LEXP_memory(id,args) -> - fprintf ppf "(LEXP_memory %a [%a])" pp_lem_id id (list_pp pp_semi_lem_exp pp_lem_exp) args - | LEXP_cast(typ,id) -> fprintf ppf "(LEXP_cast %a %a)" pp_lem_typ typ pp_lem_id id - | LEXP_tup tups -> fprintf ppf "(LEXP_tup [%a])" (list_pp pp_semi_lem_lexp pp_lem_lexp) tups - | LEXP_vector(v,exp) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_vector" pp_lem_lexp v pp_lem_exp exp - | LEXP_vector_range(v,e1,e2) -> - fprintf ppf "@[(%a %a %a %a)@]" kwd "LEXP_vector_range" pp_lem_lexp v pp_lem_exp e1 pp_lem_exp e2 - | LEXP_field(v,id) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_field" pp_lem_lexp v pp_lem_id id + | LEXP_id(id) -> fprintf ppf "(%a %a)" kwd "LEXP_id" pp_lem_id id + | LEXP_deref exp -> + fprintf ppf "(LEXP_deref %a)" pp_lem_exp exp + | LEXP_memory(id,args) -> + fprintf ppf "(LEXP_memory %a [%a])" pp_lem_id id (list_pp pp_semi_lem_exp pp_lem_exp) args + | LEXP_cast(typ,id) -> fprintf ppf "(LEXP_cast %a %a)" pp_lem_typ typ pp_lem_id id + | LEXP_tup tups -> fprintf ppf "(LEXP_tup [%a])" (list_pp pp_semi_lem_lexp pp_lem_lexp) tups + | LEXP_vector(v,exp) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_vector" pp_lem_lexp v pp_lem_exp exp + | LEXP_vector_range(v,e1,e2) -> + fprintf ppf "@[(%a %a %a %a)@]" kwd "LEXP_vector_range" pp_lem_lexp v pp_lem_exp e1 pp_lem_exp e2 + | LEXP_field(v,id) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_field" pp_lem_lexp v pp_lem_id id in fprintf ppf "@[(LEXP_aux %a (%a, %a))@]" print_le lexp pp_lem_l l pp_annot annot and pp_semi_lem_lexp ppf le = fprintf ppf "@[<1>%a%a@]" pp_lem_lexp le kwd ";" @@ -502,12 +490,8 @@ let pp_lem_default ppf (DT_aux(df,l)) = (* FIXME *) let pp_lem_spec ppf (VS_aux(v,(l,annot))) = - let print_spec ppf v = - match v with - | VS_val_spec(ts,id,ext_opt,is_cast) -> - (* FIXME: None *) - fprintf ppf "@[<0>(%a %a %a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id (pp_option_lem quot_string) None pp_bool_lem is_cast - | _ -> failwith "Invalid valspec" + let print_spec ppf (VS_val_spec(ts, id, ext_opt, is_cast)) = + fprintf ppf "@[<0>(%a %a %a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id (pp_option_lem quot_string) None pp_bool_lem is_cast in fprintf ppf "@[<0>(VS_aux %a (%a, %a))@]" print_spec v pp_lem_l l pp_annot annot @@ -518,8 +502,8 @@ let pp_lem_namescm ppf (Name_sect_aux(ns,l)) = let rec pp_lem_range ppf (BF_aux(r,l)) = match r with - | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" (int_of_big_int i) pp_lem_l l - | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" (int_of_big_int i1) (int_of_big_int i2) pp_lem_l l + | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" (Big_int.to_int i) pp_lem_l l + | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" (Big_int.to_int i1) (Big_int.to_int i2) pp_lem_l l | BF_concat(ir1,ir2) -> fprintf ppf "(BF_aux (BF_concat %a %a) %a)" pp_lem_range ir1 pp_lem_range ir2 pp_lem_l l let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = @@ -545,11 +529,11 @@ let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = let pp_id_semi ppf id = fprintf ppf "%a%a " pp_lem_id id kwd ";" in fprintf ppf "@[<0>(%a %a %a [%a] false)@]" kwd "TD_enum" pp_lem_id id pp_lem_namescm ns (list_pp pp_id_semi pp_lem_id) enums - | TD_register(id,n1,n2,rs) -> - let pp_rid ppf (r,id) = fprintf ppf "(%a, %a)%a " pp_lem_range r pp_lem_id id kwd ";" in + | TD_bitfield(id,typ,rs) -> + let pp_rid ppf (id, r) = fprintf ppf "(%a, %a)%a " pp_lem_range r pp_lem_id id kwd ";" in let pp_rids = (list_pp pp_rid pp_rid) in - fprintf ppf "@[<0>(%a %a %a %a [%a])@]" - kwd "TD_register" pp_lem_id id pp_lem_nexp n1 pp_lem_nexp n2 pp_rids rs + fprintf ppf "@[<0>(%a %a %a [%a])@]" + kwd "TD_bitfield" pp_lem_id id pp_lem_typ typ pp_rids rs in fprintf ppf "@[<0>(TD_aux %a (%a, %a))@]" print_td td pp_lem_l l pp_annot annot @@ -626,7 +610,7 @@ let rec pp_lem_def ppf d = | DEF_val(lbind) -> fprintf ppf "(DEF_val %a);@\n" pp_lem_let lbind | DEF_reg_dec(dec) -> fprintf ppf "(DEF_reg_dec %a);@\n" pp_lem_dec dec | DEF_comm d -> fprintf ppf "" - | DEF_fixity (prec, n, id) -> fprintf ppf "(DEF_fixity %a %s %a);@\n" pp_lem_prec prec (lemnum string_of_big_int n) pp_lem_id id + | DEF_fixity (prec, n, id) -> fprintf ppf "(DEF_fixity %a %s %a);@\n" pp_lem_prec prec (lemnum Big_int.to_string n) pp_lem_id id | DEF_internal_mutrec f_defs -> List.iter (fun f_def -> pp_lem_def ppf (DEF_fundef f_def)) f_defs | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "initial_check didn't remove all scattered Defs") diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 3868502b..930da39c 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -50,45 +50,146 @@ open Ast open Ast_util -open Big_int open PPrint -open Pretty_print_common - -(**************************************************************************** - * PPrint-based source-to-source pretty printer -****************************************************************************) - -let doc_bkind (BK_aux(k,_)) = - string (match k with - | BK_type -> "Type" - | BK_nat -> "Nat" - | BK_order -> "Order") - -let doc_kind (K_aux(K_kind(klst),_)) = - separate_map (spaces arrow) doc_bkind klst - -let doc_qi (QI_aux(qi,_)) = match qi with - | QI_const n_const -> doc_nexp_constraint n_const - | QI_id(KOpt_aux(ki,_)) -> - match ki with - | KOpt_none v -> doc_var v - | KOpt_kind(k,v) -> separate space [doc_kind k; doc_var v] - -(* typ_doc is the doc for the type being quantified *) -let doc_typquant (TypQ_aux(tq,_)) typ_doc = match tq with - | TypQ_no_forall -> typ_doc - | TypQ_tq [] -> typ_doc - | TypQ_tq qlist -> - (* include trailing break because the caller doesn't know if tq is empty *) - doc_op dot - (separate space [string "forall"; separate_map comma_sp doc_qi qlist]) - typ_doc - -let doc_typscm (TypSchm_aux(TypSchm_ts(tq,t),_)) = - (doc_typquant tq (doc_typ t)) - -let doc_typscm_atomic (TypSchm_aux(TypSchm_ts(tq,t),_)) = - (doc_typquant tq (doc_atomic_typ t)) + +module Big_int = Nat_big_num + +let doc_op symb a b = infix 2 1 symb a b + +let doc_id (Id_aux (id_aux, _)) = + string (match id_aux with + | Id v -> v + | DeIid op -> "operator " ^ op) + +let doc_kid kid = string (Ast_util.string_of_kid kid) + +let doc_int n = string (Big_int.to_string n) + +let doc_ord (Ord_aux(o,_)) = match o with + | Ord_var v -> doc_kid v + | Ord_inc -> string "inc" + | Ord_dec -> string "dec" + +let rec doc_nexp = + let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_constant c -> string (Big_int.to_string c) + | Nexp_id id -> doc_id id + | Nexp_var kid -> doc_kid kid + | _ -> parens (nexp0 nexp) + and nexp0 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_sum (n1, Nexp_aux (Nexp_neg n2, _)) | Nexp_minus (n1, n2) -> + separate space [nexp0 n1; string "-"; nexp1 n2] + | Nexp_sum (n1, Nexp_aux (Nexp_constant c, _)) when Big_int.less c Big_int.zero -> + separate space [nexp0 n1; string "-"; doc_int (Big_int.abs c)] + | Nexp_sum (n1, n2) -> separate space [nexp0 n1; string "+"; nexp1 n2] + | _ -> nexp1 nexp + and nexp1 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_times (n1, n2) -> separate space [nexp1 n1; string "*"; nexp2 n2] + | _ -> nexp2 nexp + and nexp2 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_neg n -> separate space [string "-"; atomic_nexp n] + | Nexp_exp n -> separate space [string "2"; string "^"; atomic_nexp n] + | _ -> atomic_nexp nexp + in + nexp0 + +let doc_nc = + let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in + let rec atomic_nc (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_true -> string "true" + | NC_false -> string "false" + | NC_equal (n1, n2) -> nc_op "=" n1 n2 + | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 + | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 + | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 + | NC_set (kid, ints) -> + separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] + | _ -> parens (nc0 nc) + and nc0 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] + | _ -> nc1 nc + and nc1 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] + | _ -> atomic_nc nc + in + nc0 + +let rec doc_typ (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_id id -> doc_id id + | Typ_app (id, []) -> doc_id id + | Typ_app (Id_aux (DeIid str, _), [x; y]) -> + separate space [doc_typ_arg x; doc_typ_arg y] + (* + | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> + string "bits" ^^ parens (doc_typ_arg len) + *) + | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) + | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) + | Typ_var kid -> doc_kid kid + (* Resugar set types like {|1, 2, 3|} *) + | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) + when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> + enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) + | Typ_exist (kids, nc, typ) -> + braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) + | Typ_fn (typ1, typ2, Effect_aux (Effect_set [], _)) -> + separate space [doc_typ typ1; string "->"; doc_typ typ2] + | 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] +and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = + match ta_aux with + | Typ_arg_typ typ -> doc_typ typ + | Typ_arg_nexp nexp -> doc_nexp nexp + | Typ_arg_order o -> doc_ord o + +let doc_quants quants = + let doc_qi_kopt (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] + | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] + | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] + | QI_id kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] + | QI_const nc -> [] + in + let qi_nc (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_const nc -> [nc] + | _ -> [] + in + let kdoc = separate space (List.concat (List.map doc_qi_kopt quants)) in + let ncs = List.concat (List.map qi_nc quants) in + match ncs with + | [] -> kdoc + | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc + | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) + + + +let doc_binding (TypQ_aux (tq_aux, _), typ) = + match tq_aux with + | TypQ_no_forall -> doc_typ typ + | TypQ_tq [] -> doc_typ typ + | TypQ_tq qs -> + string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ + +let doc_typschm (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_binding (typq, typ) + +let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ + +let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = + match tq_aux with + | TypQ_no_forall -> None + | TypQ_tq [] -> None + | TypQ_tq qs -> Some (doc_quants qs) let doc_lit (L_aux(l,_)) = utf8string (match l with @@ -97,473 +198,343 @@ let doc_lit (L_aux(l,_)) = | L_one -> "bitone" | L_true -> "true" | L_false -> "false" - | L_num i -> string_of_big_int i + | L_num i -> Big_int.to_string i | L_hex n -> "0x" ^ n | L_bin n -> "0b" ^ n | L_real r -> r | L_undef -> "undefined" | L_string s -> "\"" ^ String.escaped s ^ "\"") -let doc_pat, doc_atomic_pat = - let rec pat pa = pat_colons pa - and pat_colons ((P_aux(p,l)) as pa) = match p with - (* XXX add leading indentation if not flat - we need to define our own - * combinator for that *) - | P_vector_concat pats -> separate_map (space ^^ colon ^^ break 1) atomic_pat pats - | _ -> app_pat pa - and app_pat ((P_aux(p,l)) as pa) = match p with - | P_app(id, ((_ :: _) as pats)) -> doc_unop (doc_id id) (parens (separate_map comma_sp atomic_pat pats)) - | _ -> atomic_pat pa - and atomic_pat ((P_aux(p,(l,annot))) as pa) = match p with - | P_lit lit -> doc_lit lit - | P_wild -> underscore +let rec doc_pat (P_aux (p_aux, _) as pat) = + match p_aux with | P_id id -> doc_id id + | P_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen + | P_typ (typ, pat) -> separate space [doc_pat pat; colon; doc_typ typ] + | P_lit lit -> doc_lit lit + (* P_var short form sugar *) | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> - doc_var kid - | P_var(p,kid) -> parens (separate space [pat p; string "as"; doc_var kid]) - | P_as(p,id) -> parens (separate space [pat p; string "as"; doc_id id]) - | P_typ(typ,p) -> separate space [parens (doc_typ typ); atomic_pat p] - | P_app(id,[]) -> doc_id id - | P_record(fpats,_) -> braces (separate_map semi_sp fpat fpats) - | P_vector pats -> brackets (separate_map comma_sp atomic_pat pats) - | P_tup pats -> parens (separate_map comma_sp atomic_pat pats) - | P_list pats -> squarebarbars (separate_map semi_sp atomic_pat pats) - | P_cons (pat1, pat2) -> separate space [atomic_pat pat1; coloncolon; pat pat2] - | P_app(_, _ :: _) | P_vector_concat _ -> - group (parens (pat pa)) - and fpat (FP_aux(FP_Fpat(id,fpat),_)) = doc_op equals (doc_id id) (pat fpat) - and npat (i,p) = doc_op equals (doc_int i) (pat p) - - (* expose doc_pat and doc_atomic_pat *) - in pat, atomic_pat - -let doc_exp, doc_let = - let rec exp e = group (or_exp e) - and or_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("|" | "||"),_) as op),r) -> - doc_op (doc_id op) (and_exp l) (or_exp r) - | _ -> and_exp expr - and and_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("&" | "&&"),_) as op),r) -> - doc_op (doc_id op) (eq_exp l) (and_exp r) - | _ -> eq_exp expr - and eq_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ( - (* XXX this is not very consistent - is the parser bogus here? *) - "=" | "==" | "!=" - | ">=" | ">=_s" | ">=_u" | ">" | ">_s" | ">_u" - | "<=" | "<=_s" | "<" | "<_s" | "<_si" | "<_u" - ),_) as op),r) -> - doc_op (doc_id op) (eq_exp l) (at_exp r) - (* XXX assignment should not have the same precedence as equal etc. *) - | E_assign(le,exp) -> doc_op coloneq (doc_lexp le) (at_exp exp) - | _ -> at_exp expr - and at_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("@" | "^^" | "^" | "~^"),_) as op),r) -> - doc_op (doc_id op) (cons_exp l) (at_exp r) - | _ -> cons_exp expr - and cons_exp ((E_aux(e,_)) as expr) = match e with - | E_vector_append(l,r) -> - doc_op colon (shift_exp l) (cons_exp r) - | E_cons(l,r) -> - doc_op coloncolon (shift_exp l) (cons_exp r) - | _ -> shift_exp expr - and shift_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id (">>" | ">>>" | "<<" | "<<<"),_) as op),r) -> - doc_op (doc_id op) (shift_exp l) (plus_exp r) - | _ -> plus_exp expr - and plus_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("+" | "-" | "+_s" | "-_s"),_) as op),r) -> - doc_op (doc_id op) (plus_exp l) (star_exp r) - | _ -> star_exp expr - and star_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ( - "*" | "/" - | "div" | "quot" | "quot_s" | "rem" | "mod" - | "*_s" | "*_si" | "*_u" | "*_ui"),_) as op),r) -> - doc_op (doc_id op) (star_exp l) (starstar_exp r) - | _ -> starstar_exp expr - and starstar_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id "**",_) as op),r) -> - doc_op (doc_id op) (starstar_exp l) (app_exp r) - | E_if _ | E_for _ | E_loop _ | E_let _ - | E_internal_let _ | E_internal_plet _ -> right_atomic_exp expr - | _ -> app_exp expr - and right_atomic_exp ((E_aux(e,_)) as expr) = match e with - (* Special case: omit "else ()" when the else branch is empty. *) - | E_if(c,t,E_aux(E_block [], _)) -> - string "if" ^^ space ^^ group (exp c) ^/^ - string "then" ^^ space ^^ group (exp t) - | E_if(c,t,e) -> - string "if" ^^ space ^^ group (exp c) ^/^ - string "then" ^^ space ^^ group (exp t) ^/^ - string "else" ^^ space ^^ group (exp e) - | E_loop (While, c, e) -> - separate space [string "while"; atomic_exp c; string "do"] ^/^ - exp e - | E_loop (Until, c, e) -> - (string "repeat" - ^/^ exp e) - ^/^ (string "until" ^^ space ^^ atomic_exp c) - | E_for(id,exp1,exp2,exp3,order,exp4) -> - string "foreach" ^^ space ^^ - group (parens ( - separate (break 1) [ - doc_id id; - string "from " ^^ atomic_exp exp1; - string "to " ^^ atomic_exp exp2; - string "by " ^^ atomic_exp exp3; - string "in " ^^ doc_ord order - ] - )) ^/^ - exp exp4 - | E_let(leb,e) -> doc_op (string "in") (let_exp leb) (exp e) - | E_internal_let (lexp, exp1, exp2) -> - let le = - prefix 2 1 - (separate space [string "internal_let"; doc_lexp lexp; equals]) - (exp exp1) in - doc_op (string "in") le (exp exp2) + doc_kid kid + | P_var (pat, kid) -> separate space [doc_pat pat; string "as"; doc_kid kid] + | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) + | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats + | P_wild -> string "_" + | P_as (pat, id) -> separate space [doc_pat pat; string "as"; doc_id id] + | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) + | _ -> string (string_of_pat pat) + +(* if_block_x is true if x should be printed like a block, i.e. with + newlines. Blocks are automatically printed as blocks, so this + returns false for them. *) +let if_block_then (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ | E_if _ -> true + | _ -> false + +let if_block_else (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ -> true + | _ -> false + +let fixities = + let fixities' = + List.fold_left + (fun r (x, y) -> Bindings.add x y r) + Bindings.empty + [ + (mk_id "^", (InfixR, 8)); + (mk_id "*", (InfixL, 7)); + (mk_id "+", (InfixL, 6)); + (mk_id "-", (InfixL, 6)); + (mk_id "!=", (Infix, 4)); + (mk_id ">", (Infix, 4)); + (mk_id "<", (Infix, 4)); + (mk_id ">=", (Infix, 4)); + (mk_id "<=", (Infix, 4)); + (mk_id "&", (InfixR, 3)); + (mk_id "|", (InfixR, 2)); + ] + in + ref (fixities' : (prec * int) Bindings.t) + +let rec doc_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_block [] -> string "()" + | E_block [exp] -> doc_exp exp + | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace + | E_nondet exps -> assert false + (* This is mostly for the -convert option *) + | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> + separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] + | E_app_infix _ -> doc_infix 0 exp + | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) + + (* Various rules to try to format if blocks nicely based on content *) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp && if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, (E_aux (E_if _, _) as else_exp)) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) + ^^ space ^^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) -> + group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) + + | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" + | E_cons (exp1, exp2) -> string "E_cons" + | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] + | E_loop (While, cond, exp) -> + separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] + | E_loop (Until, cond, exp) -> + separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] + | E_record_update (exp, fexps) -> + separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] + | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] + | E_case (exp, pexps) -> + separate space [string "match"; doc_exp exp; doc_pexps pexps] + | E_let (LB_aux (LB_val (pat, binding), _), exp) -> + separate space [string "let"; doc_pat pat; equals; doc_exp binding; string "in"; doc_exp exp] | E_internal_plet (pat, exp1, exp2) -> let le = prefix 2 1 (separate space [string "internal_plet"; doc_pat pat; equals]) - (exp exp1) in - doc_op (string "in") le (exp exp2) - | _ -> group (parens (exp expr)) - and app_exp ((E_aux(e,_)) as expr) = match e with - | E_app(f,args) -> - (doc_id f) ^^ (parens (separate_map comma exp args)) - | _ -> vaccess_exp expr - and vaccess_exp ((E_aux(e,_)) as expr) = match e with - | E_vector_access(v,e) -> - atomic_exp v ^^ brackets (exp e) - | E_vector_subrange(v,e1,e2) -> - atomic_exp v ^^ brackets (doc_op dotdot (exp e1) (exp e2)) - | _ -> field_exp expr - and field_exp ((E_aux(e,_)) as expr) = match e with - | E_field(fexp,id) -> atomic_exp fexp ^^ dot ^^ doc_id id - | _ -> atomic_exp expr - and atomic_exp ((E_aux(e,_)) as expr) = match e with - (* Special case: an empty block is equivalent to unit, but { } would - * be parsed as a struct. *) - | E_block [] -> string "()" - | E_block exps -> - let exps_doc = separate_map (semi ^^ hardline) exp exps in - surround 2 1 lbrace exps_doc rbrace - | E_nondet exps -> - let exps_doc = separate_map (semi ^^ hardline) exp exps in - string "nondet" ^^ space ^^ (surround 2 1 lbrace exps_doc rbrace) - | E_comment s -> string ("(*" ^ s ^ "*) ()") - | E_comment_struc e -> string "(*" ^^ exp e ^^ string "*) ()" - | E_id id -> doc_id id + (doc_exp exp1) in + doc_op (string "in") le (doc_exp exp2) + | E_var (lexp, binding, exp) -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding; string "in"; doc_exp exp] + | E_assign (lexp, exp) -> + separate space [doc_lexp lexp; equals; doc_exp exp] + | E_for (id, exp1, exp2, exp3, order, exp4) -> + begin + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ doc_id id; + string "from " ^^ doc_atomic_exp exp1; + string "to " ^^ doc_atomic_exp exp2; + string "by " ^^ doc_atomic_exp exp3; + string "in " ^^ doc_ord order ])) + in + match exp4 with + | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 + | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 + | _ -> header ^//^ doc_exp exp4 + end + (* Resugar an assert with an empty message *) + | E_throw exp -> string "throw" ^^ parens (doc_exp exp) + | E_try (exp, pexps) -> + separate space [string "try"; doc_exp exp; string "catch"; doc_pexps pexps] + | E_return exp -> string "return" ^^ parens (doc_exp exp) + | E_internal_return exp -> string "internal_return" ^^ parens (doc_exp exp) + | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> + separate space [string "2"; string "^"; doc_atomic_exp exp] + | _ -> doc_atomic_exp exp +and doc_infix n (E_aux (e_aux, _) as exp) = + match e_aux with + | E_app_infix (l, op, r) when n < 10 -> + begin + try + match Bindings.find op !fixities with + | (Infix, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r] + | (Infix, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r]) + | (InfixL, m) when m >= n -> separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r] + | (InfixL, m) when m < n -> parens (separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r]) + | (InfixR, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r] + | (InfixR, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r]) + | _ -> assert false + with + | Not_found -> + separate space [doc_atomic_exp l; doc_id op; doc_atomic_exp r] + end + | _ -> doc_atomic_exp exp +and doc_atomic_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_cast (typ, exp) -> + separate space [doc_atomic_exp exp; colon; doc_typ typ] | E_lit lit -> doc_lit lit - | E_cast(typ,e) -> prefix 2 1 (parens (doc_typ typ)) (group (atomic_exp e)) - (* - | E_internal_cast((_,NoTyp),e) -> atomic_exp e - | E_internal_cast((_,Base((_,t),_,_,_,_,bindings)), (E_aux(_,(_,eannot)) as e)) -> - (match t.t,eannot with - (* XXX I don't understand why we can hide the internal cast here - AAA Because an internal cast between vectors is only generated to reset the base access; - the type checker generates far more than are needed and they're pruned off here, after constraint resolution *) - | Tapp("vector",[TA_nexp n1;_;_;_]),Base((_,{t=Tapp("vector",[TA_nexp n2;_;_;_])}),_,_,_,_,_) - when nexp_eq n1 n2 -> atomic_exp e - | _ -> prefix 2 1 (parens (doc_typ (t_to_typ t))) (group (atomic_exp e))) - *) - | E_tuple exps -> - parens (separate_map comma exp exps) - | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> - (* XXX E_record is not handled by parser currently - AAA The parser can't handle E_record due to ambiguity with blocks; initial_check looks for blocks that are all field assignments and converts *) - braces (separate_map semi_sp doc_fexp fexps) - | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> - braces (doc_op (string "with") (exp e) (separate_map semi_sp doc_fexp fexps)) - | E_vector exps -> - let default_print _ = brackets (separate_map comma exp exps) in - (match exps with - | [] -> default_print () - | E_aux(e,_)::es -> - (match e with - | E_lit (L_aux(L_one, _)) | E_lit (L_aux(L_zero, _)) -> - utf8string - ("0b" ^ - (List.fold_right (fun (E_aux( e,_)) rst -> - (match e with - | E_lit(L_aux(l, _)) -> - ((match l with | L_one -> "1" | L_zero -> "0" | L_undef -> "u" | _ -> assert false) ^ rst) - | _ -> assert false)) exps "")) - | _ -> default_print ())) - | E_vector_update(v,e1,e2) -> - brackets (doc_op (string "with") (exp v) (doc_op equals (atomic_exp e1) (exp e2))) - | E_vector_update_subrange(v,e1,e2,e3) -> - brackets ( - doc_op (string "with") (exp v) - (doc_op equals (atomic_exp e1 ^^ colon ^^ atomic_exp e2) (exp e3))) - | E_list exps -> - squarebarbars (separate_map comma exp exps) - | E_try(e,pexps) -> - let opening = separate space [string "try"; exp e; string "catch"; lbrace] in - let cases = separate_map (break 1) doc_case pexps in - surround 2 1 opening cases rbrace - | E_case(e,pexps) -> - let opening = separate space [string "switch"; exp e; lbrace] in - let cases = separate_map (break 1) doc_case pexps in - surround 2 1 opening cases rbrace - | E_sizeof n -> - parens (separate space [string "sizeof"; doc_nexp n]) - | E_constraint nc -> - string "constraint" ^^ parens (doc_nexp_constraint nc) - | E_exit e -> - separate space [string "exit"; atomic_exp e;] - | E_throw e -> - separate space [string "throw"; atomic_exp e;] - | E_return e -> - separate space [string "return"; atomic_exp e;] - | E_assert(c,m) -> - separate space [string "assert"; parens (separate comma [exp c; exp m])] - (* adding parens and loop for lower precedence *) - | E_app (_, _)|E_vector_access (_, _)|E_vector_subrange (_, _, _) - | E_cons (_, _)|E_field (_, _)|E_assign (_, _) - | E_if _ | E_for _ | E_loop _ | E_let _ - | E_internal_let _ | E_internal_plet _ - | E_vector_append _ - | E_app_infix (_, - (* for every app_infix operator caught at a higher precedence, - * we need to wrap around with parens *) - (Id_aux(Id("|" | "||" - | "&" | "&&" - | "=" | "==" | "!=" - | ">=" | ">=_s" | ">=_u" | ">" | ">_s" | ">_u" - | "<=" | "<=_s" | "<" | "<_s" | "<_si" | "<_u" - | "@" | "^^" | "^" | "~^" - | ">>" | ">>>" | "<<" | "<<<" - | "+" | "-" | "+_s" | "-_s" - | "*" | "/" - | "div" | "quot" | "quot_s" | "rem" | "mod" - | "*_s" | "*_si" | "*_u" | "*_ui" - | "**"), _)) - , _) -> - group (parens (exp expr)) - (* XXX default precedence for app_infix? *) - | E_app_infix(l,op,r) -> - failwith ("unexpected app_infix operator " ^ (pp_format_id op)) - (* doc_op (doc_id op) (exp l) (exp r) *) - | E_comment s -> comment (string s) - | E_comment_struc e -> comment (exp e) - (* - | E_internal_exp((l, Base((_,t),_,_,_,_,bindings))) -> (*TODO use bindings, and other params*) - (match t.t with - | Tapp("register",[TA_typ {t=Tapp("vector",[TA_nexp _;TA_nexp r;_;_])}]) - | Tapp("vector",[TA_nexp _;TA_nexp r;_;_]) -> - (match r.nexp with - | Nvar v -> utf8string v - | Nconst bi -> utf8string (Big_int.string_of_big_int bi) - | _ -> raise (Reporting_basic.err_unreachable l - ("Internal exp given vector without known length, instead given " ^ n_to_string r))) - | Tapp("implicit",[TA_nexp r]) -> - (match r.nexp with - | Nconst bi -> utf8string (Big_int.string_of_big_int bi) - | Nvar v -> utf8string v - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given implicit without var or const")) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal exp given non-vector, non-implicit " ^ t_to_string t))) - | E_internal_exp_user _ -> raise (Reporting_basic.err_unreachable Unknown ("internal_exp_user not rewritten away")) - | E_internal_cast ((_, Overload (_, _,_ )), _) | E_internal_exp _ -> assert false - *) - | E_internal_return exp1 -> - separate space [string "internal_return"; exp exp1] - | _ -> failwith ("Cannot print: " ^ Ast_util.string_of_exp expr) - and let_exp (LB_aux(lb,_)) = match lb with - | LB_val(pat,e) -> - prefix 2 1 - (separate space [string "let"; doc_atomic_pat pat; equals]) - (atomic_exp e) - - and doc_fexp (FE_aux(FE_Fexp(id,e),_)) = doc_op equals (doc_id id) (exp e) - - and doc_case (Pat_aux (pexp, _)) = - match pexp with - | Pat_exp(pat, e) -> - doc_op arrow (separate space [string "case"; doc_atomic_pat pat]) (group (exp e)) - | Pat_when(pat, guard, e) -> - doc_op arrow (separate space [string "case"; doc_atomic_pat pat; string "when"; exp guard]) (group (exp e)) - - (* lexps are parsed as eq_exp - we need to duplicate the precedence - * structure for them *) - and doc_lexp le = app_lexp le - and app_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_memory(id,args) -> doc_id id ^^ parens (separate_map comma exp args) - | _ -> vaccess_lexp le - and vaccess_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_vector(v,e) -> atomic_lexp v ^^ brackets (exp e) - | LEXP_vector_range(v,e1,e2) -> - atomic_lexp v ^^ brackets (exp e1 ^^ dotdot ^^ exp e2) - | _ -> field_lexp le - and field_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_field(v,id) -> atomic_lexp v ^^ dot ^^ doc_id id - | _ -> atomic_lexp le - and atomic_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with + | E_id id -> doc_id id + | E_ref id -> string "ref" ^^ space ^^ doc_id id + | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id + | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid + | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) + (* Format a function with a unit argument as f() rather than f(()) *) + | E_app (id, [E_aux (E_lit (L_aux (L_unit, _)), _)]) -> doc_id id ^^ string "()" + | E_app (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | E_constraint nc -> string "constraint" ^^ parens (doc_nc nc) + | E_assert (exp1, E_aux (E_lit (L_aux (L_string "", _)), _)) -> string "assert" ^^ parens (doc_exp exp1) + | E_assert (exp1, exp2) -> string "assert" ^^ parens (doc_exp exp1 ^^ comma ^^ space ^^ doc_exp exp2) + | E_exit exp -> string "exit" ^^ parens (doc_exp exp) + | E_vector_access (exp1, exp2) -> doc_atomic_exp exp1 ^^ brackets (doc_exp exp2) + | E_vector_subrange (exp1, exp2, exp3) -> doc_atomic_exp exp1 ^^ brackets (separate space [doc_exp exp2; string ".."; doc_exp exp3]) + | E_vector exps -> brackets (separate_map (comma ^^ space) doc_exp exps) + | E_vector_update (exp1, exp2, exp3) -> + brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) + | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> + brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) + | E_internal_value v -> string (Value.string_of_value v |> Util.green |> Util.clear) + | _ -> parens (doc_exp exp) +and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = + separate_map (comma ^^ space) doc_fexp fexps +and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = + separate space [doc_id id; equals; doc_exp exp] +and doc_block = function + | [] -> string "()" + | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> + separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [E_aux (E_var (lexp, binding, E_aux (E_block exps, _)), _)] -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [exp] -> doc_exp exp + | exp :: exps -> doc_exp exp ^^ semi ^^ hardline ^^ doc_block exps +and doc_lexp (LEXP_aux (l_aux, _) as lexp) = + match l_aux with + | LEXP_cast (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + | _ -> doc_atomic_lexp lexp +and doc_atomic_lexp (LEXP_aux (l_aux, _) as lexp) = + match l_aux with | LEXP_id id -> doc_id id - | LEXP_cast(typ,id) -> prefix 2 1 (parens (doc_typ typ)) (doc_id id) - | LEXP_memory _ | LEXP_vector _ | LEXP_vector_range _ - | LEXP_field _ -> group (parens (doc_lexp le)) - | LEXP_tup tups -> parens (separate_map comma doc_lexp tups) - - (* expose doc_exp and doc_let *) - in exp, let_exp + | LEXP_deref exp -> lparen ^^ string "*" ^^ doc_atomic_exp exp ^^ rparen + | LEXP_tup lexps -> lparen ^^ separate_map (comma ^^ space) doc_lexp lexps ^^ rparen + | LEXP_field (lexp, id) -> doc_atomic_lexp lexp ^^ dot ^^ doc_id id + | LEXP_vector (lexp, exp) -> doc_atomic_lexp lexp ^^ brackets (doc_exp exp) + | LEXP_vector_range (lexp, exp1, exp2) -> doc_atomic_lexp lexp ^^ brackets (separate space [doc_exp exp1; string ".."; doc_exp exp2]) + | LEXP_memory (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | _ -> parens (doc_lexp lexp) +and doc_pexps pexps = surround 2 0 lbrace (separate_map (comma ^^ hardline) doc_pexp pexps) rbrace +and doc_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_exp (pat, exp) -> separate space [doc_pat pat; string "=>"; doc_exp exp] + | Pat_when (pat, wh, exp) -> + separate space [doc_pat pat; string "if"; doc_exp wh; string "=>"; doc_exp exp] +and doc_letbind (LB_aux (lb_aux, _)) = + match lb_aux with + | LB_val (pat, exp) -> + separate space [doc_pat pat; equals; doc_exp exp] + +let doc_funcl funcl = string "FUNCL" + +let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = + match pexp with + | Pat_exp (pat,exp) -> + group (separate space [doc_id id; doc_pat pat; equals; doc_exp exp]) + | Pat_when (pat,wh,exp) -> + group (separate space [doc_id id; parens (separate space [doc_pat pat; string "if"; doc_exp wh]); string "="; doc_exp exp]) let doc_default (DT_aux(df,_)) = match df with - | DT_kind(bk,v) -> separate space [string "default"; doc_bkind bk; doc_var v] - | DT_typ(ts,id) -> separate space [string "default"; doc_typscm ts; doc_id id] + | DT_kind(bk,v) -> string "DT_kind" (* separate space [string "default"; doc_bkind bk; doc_var v] *) + | DT_typ(ts,id) -> separate space [string "default"; doc_typschm ts; doc_id id] | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] -let doc_spec (VS_aux(v,_)) = match v with - | VS_val_spec(ts,id,ext_opt,is_cast) -> - let cast_pp = if is_cast then [string "cast"] else [] in - (* This sail syntax only supports a single extern name, so just use the ocaml version *) - let extern_kwd_pp, id_pp = match ext_opt "ocaml" with - | Some ext -> [string "extern"], doc_op equals (doc_id id) (dquotes (string (ext))) - | None -> [], doc_id id - in - separate space ([string "val"] @ cast_pp @ extern_kwd_pp @ [doc_typscm ts] @ [id_pp]) - | _ -> failwith "Invalid valspec" - -let doc_namescm (Name_sect_aux(ns,_)) = match ns with - | Name_sect_none -> empty - (* include leading space because the caller doesn't know if ns is - * empty, and trailing break already added by the following equals *) - | Name_sect_some s -> space ^^ brackets (doc_op equals (string "name") (dquotes (string s))) - -let doc_type_union (Tu_aux(typ_u,_)) = match typ_u with - | Tu_ty_id(typ,id) -> separate space [doc_typ typ; doc_id id] - | Tu_id id -> doc_id id - -let doc_typdef (TD_aux(td,_)) = match td with - | TD_abbrev(id,nm,typschm) -> - doc_op equals (concat [string "typedef"; space; doc_id id; doc_namescm nm]) (doc_typscm typschm) - | TD_record(id,nm,typq,fs,_) -> - let f_pp (typ,id) = concat [doc_typ typ; space; doc_id id; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "const struct" ^^ space ^^ doc_typquant typq (braces fs_doc)) - | TD_variant(id,nm,typq,ar,_) -> - let ar_doc = group (separate_map (semi ^^ break 1) doc_type_union ar) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "const union" ^^ space ^^ doc_typquant typq (braces ar_doc)) - | TD_enum(id,nm,enums,_) -> - let enums_doc = group (separate_map (semi ^^ break 1) doc_id enums) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "enumerate" ^^ space ^^ braces enums_doc) - | TD_register(id,n1,n2,rs) -> - let doc_rid (r,id) = separate space [doc_range r; colon; doc_id id] ^^ semi in - let doc_rids = group (separate_map (break 1) doc_rid rs) in - doc_op equals - (string "typedef" ^^ space ^^ doc_id id) - (separate space [ - string "register bits"; - brackets (doc_nexp n1 ^^ colon ^^ doc_nexp n2); - braces doc_rids; - ]) - -let doc_kindef (KD_aux(kd,_)) = match kd with - | KD_nabbrev(kind,id,nm,n) -> - doc_op equals (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) (doc_nexp n) - -let doc_rec (Rec_aux(r,_)) = match r with - | Rec_nonrec -> empty - (* include trailing space because caller doesn't know if we return - * empty *) - | Rec_rec -> space ^^ string "rec" - -let doc_tannot_opt (Typ_annot_opt_aux(t,_)) = match t with - | Typ_annot_opt_some(tq,typ) -> space ^^ doc_typquant tq (doc_typ typ) - | Typ_annot_opt_none -> empty - -let doc_effects_opt (Effect_opt_aux(e,_)) = match e with - | Effect_opt_pure -> string "pure" - | Effect_opt_effect e -> doc_effects e - -let doc_funcl (FCL_aux(FCL_Funcl(id,pexp),_)) = - match pexp with - | Pat_aux (Pat_exp (pat,exp),_) -> - group (doc_op equals (separate space [doc_id id; doc_atomic_pat pat]) (doc_exp exp)) - | Pat_aux (Pat_when (pat,wh,exp),_) -> - group (doc_op equals (doc_id id ^^ space ^^ parens (separate space [doc_atomic_pat pat; string "when"; doc_exp wh])) - (doc_exp exp)) - -let doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),_)) = - match fcls with - | [] -> failwith "FD_function with empty function list" +let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = + match funcls with + | [] -> failwith "Empty function list" | _ -> - let sep = hardline ^^ string "and" ^^ space in - let clauses = separate_map sep doc_funcl fcls in - separate space ([string "function" ^^ doc_rec r ^^ doc_tannot_opt typa]@ - (match efa with - | Effect_opt_aux (Effect_opt_pure,_) -> [] - | _ -> [string "effect"; - doc_effects_opt efa;]) - @[clauses]) - -let doc_alias (AL_aux (alspec,_)) = - match alspec with - | AL_subreg((RI_aux (RI_id id,_)),subid) -> doc_id id ^^ dot ^^ doc_id subid - | AL_bit((RI_aux (RI_id id,_)),ac) -> doc_id id ^^ brackets (doc_exp ac) - | AL_slice((RI_aux (RI_id id,_)),b,e) -> doc_id id ^^ brackets (doc_op dotdot (doc_exp b) (doc_exp e)) - | AL_concat((RI_aux (RI_id f,_)),(RI_aux (RI_id s,_))) -> doc_op colon (doc_id f) (doc_id s) + let sep = hardline ^^ string "and" ^^ space in + let clauses = separate_map sep doc_funcl funcls in + string "function" ^^ space ^^ clauses let doc_dec (DEC_aux (reg,_)) = match reg with - | DEC_reg(typ,id) -> separate space [string "register"; doc_typ typ; doc_id id] - | DEC_alias(id,alspec) -> - doc_op equals (string "register alias" ^^ space ^^ doc_id id) (doc_alias alspec) - | DEC_typ_alias(typ,id,alspec) -> - doc_op equals (string "register alias" ^^ space ^^ doc_typ typ) (doc_alias alspec) - -let doc_scattered (SD_aux (sdef, _)) = match sdef with - | SD_scattered_function (r, typa, efa, id) -> - separate space ([ - string "scattered function"; - doc_rec r ^^ doc_tannot_opt typa;]@ - (match efa with - | Effect_opt_aux (Effect_opt_pure,_) -> [] - | _ -> [string "effect"; doc_effects_opt efa;]) - @[doc_id id]) - | SD_scattered_variant (id, ns, tq) -> - doc_op equals - (string "scattered typedef" ^^ space ^^ doc_id id ^^ doc_namescm ns) - (string "const union" ^^ space ^^ (doc_typquant tq empty)) - | SD_scattered_funcl funcl -> - string "function clause" ^^ space ^^ doc_funcl funcl - | SD_scattered_unioncl (id, tu) -> - separate space [string "union"; doc_id id; - string "member"; doc_type_union tu] - | SD_scattered_end id -> string "end" ^^ space ^^ doc_id id + | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] + | DEC_alias(id,alspec) -> string "ALIAS" + | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" + +let doc_field (typ, id) = + separate space [doc_id id; colon; doc_typ typ] + +let doc_union (Tu_aux (tu, l)) = match tu with + | Tu_id id -> doc_id id + | Tu_ty_id (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + +let doc_typdef (TD_aux(td,_)) = match td with + | TD_abbrev (id, _, typschm) -> + begin + match doc_typschm_quants typschm with + | Some qdoc -> + doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) + | None -> + doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) + end + | TD_enum (id, _, ids, _) -> + separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> + separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> + separate space [string "struct"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> + separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> + separate space [string "union"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | _ -> string "TYPEDEF" + +let doc_spec (VS_aux(v,_)) = + let doc_extern ext = + let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ + utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in + let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"]) in + if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) + in + match v with + | VS_val_spec(ts,id,ext,is_cast) -> + string "val" ^^ space + ^^ (if is_cast then (string "cast" ^^ space) else empty) + ^^ doc_id id ^^ space + ^^ doc_extern ext + ^^ colon ^^ space + ^^ doc_typschm ts + +let doc_prec = function + | Infix -> string "infix" + | InfixL -> string "infixl" + | InfixR -> string "infixr" + +let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = + separate space [string "integer"; doc_id id; equals; doc_nexp nexp] + +let rec doc_scattered (SD_aux (sd_aux, _)) = + match sd_aux with + | SD_scattered_function (_, _, _, id) -> + string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id + | SD_scattered_funcl funcl -> + string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl + | SD_scattered_end id -> + string "end" ^^ space ^^ doc_id id + | _ -> string "SCATTERED" let rec doc_def def = group (match def with | DEF_default df -> doc_default df | DEF_spec v_spec -> doc_spec v_spec | DEF_type t_def -> doc_typdef t_def - | DEF_kind k_def -> doc_kindef k_def + | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def - | DEF_val lbind -> doc_let lbind + | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind + | DEF_internal_mutrec fundefs -> + (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) + ^^ hardline ^^ string "}" | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef + | DEF_fixity (prec, n, id) -> + fixities := Bindings.add id (prec, Big_int.to_int n) !fixities; + separate space [doc_prec prec; doc_int n; doc_id id] | DEF_overload (id, ids) -> - let ids_doc = group (separate_map (semi ^^ break 1) doc_id ids) in - string "overload" ^^ space ^^ doc_id id ^^ space ^^ brackets ids_doc - | DEF_comm (DC_comm s) -> comment (string s) - | DEF_comm (DC_comm_struct d) -> comment (doc_def d) - | DEF_fixity _ -> empty + separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | DEF_comm (DC_comm s) -> string "TOPLEVEL" + | DEF_comm (DC_comm_struct d) -> string "TOPLEVEL" ) ^^ hardline let doc_defs (Defs(defs)) = separate_map hardline doc_def defs -let pp_defs f d = print f (doc_defs d) -let pp_exp b e = to_buf b (doc_exp e) -let pat_to_string p = - let b = Buffer.create 20 in - to_buf b (doc_pat p); +let pp_defs f d = ToChannel.pretty 1. 80 f (doc_defs d) + +let pretty_sail f doc = ToChannel.pretty 1. 120 f doc + +let to_string doc = + let b = Buffer.create 120 in + ToBuffer.pretty 1. 120 b doc; Buffer.contents b diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml deleted file mode 100644 index 0c531301..00000000 --- a/src/pretty_print_sail2.ml +++ /dev/null @@ -1,525 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Big_int -open PPrint - -let doc_op symb a b = infix 2 1 symb a b - -let doc_id (Id_aux (id_aux, _)) = - string (match id_aux with - | Id v -> v - | DeIid op -> "operator " ^ op) - -let doc_kid kid = string (Ast_util.string_of_kid kid) - -let doc_int n = string (string_of_big_int n) - -let doc_ord (Ord_aux(o,_)) = match o with - | Ord_var v -> doc_kid v - | Ord_inc -> string "inc" - | Ord_dec -> string "dec" - -let rec doc_nexp = - let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_constant c -> string (string_of_big_int c) - | Nexp_id id -> doc_id id - | Nexp_var kid -> doc_kid kid - | _ -> parens (nexp0 nexp) - and nexp0 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_sum (n1, Nexp_aux (Nexp_neg n2, _)) | Nexp_minus (n1, n2) -> - separate space [nexp0 n1; string "-"; nexp1 n2] - | Nexp_sum (n1, Nexp_aux (Nexp_constant c, _)) when lt_big_int c zero_big_int -> - separate space [nexp0 n1; string "-"; doc_int (abs_big_int c)] - | Nexp_sum (n1, n2) -> separate space [nexp0 n1; string "+"; nexp1 n2] - | _ -> nexp1 nexp - and nexp1 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_times (n1, n2) -> separate space [nexp1 n1; string "*"; nexp2 n2] - | _ -> nexp2 nexp - and nexp2 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_neg n -> separate space [string "-"; atomic_nexp n] - | Nexp_exp n -> separate space [string "2"; string "^"; atomic_nexp n] - | _ -> atomic_nexp nexp - in - nexp0 - -let doc_nc = - let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in - let rec atomic_nc (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_true -> string "true" - | NC_false -> string "false" - | NC_equal (n1, n2) -> nc_op "=" n1 n2 - | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 - | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 - | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 - | NC_set (kid, ints) -> - separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] - | _ -> parens (nc0 nc) - and nc0 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] - | _ -> nc1 nc - and nc1 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] - | _ -> atomic_nc nc - in - nc0 - -let rec doc_typ (Typ_aux (typ_aux, _)) = - match typ_aux with - | Typ_id id -> doc_id id - | Typ_app (id, []) -> doc_id id - | Typ_app (Id_aux (DeIid str, _), [x; y]) -> - separate space [doc_typ_arg x; doc_typ_arg y] - (* - | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> - string "bits" ^^ parens (doc_typ_arg len) - *) - | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) - | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) - | Typ_var kid -> doc_kid kid - (* Resugar set types like {|1, 2, 3|} *) - | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) - when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> - enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) - | Typ_exist (kids, nc, typ) -> - braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) - | Typ_fn (typ1, typ2, Effect_aux (Effect_set [], _)) -> - separate space [doc_typ typ1; string "->"; doc_typ typ2] - | 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] -and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = - match ta_aux with - | Typ_arg_typ typ -> doc_typ typ - | Typ_arg_nexp nexp -> doc_nexp nexp - | Typ_arg_order o -> doc_ord o - -let doc_quants quants = - let doc_qi_kopt (QI_aux (qi_aux, _)) = - match qi_aux with - | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] - | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] - | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] - | QI_id kopt when is_order_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] - | QI_const nc -> [] - in - let qi_nc (QI_aux (qi_aux, _)) = - match qi_aux with - | QI_const nc -> [nc] - | _ -> [] - in - let kdoc = separate space (List.concat (List.map doc_qi_kopt quants)) in - let ncs = List.concat (List.map qi_nc quants) in - match ncs with - | [] -> kdoc - | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc - | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) - -let doc_typschm (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = - match tq_aux with - | TypQ_no_forall -> doc_typ typ - | TypQ_tq [] -> doc_typ typ - | TypQ_tq qs -> - string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ - -let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ - -let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = - match tq_aux with - | TypQ_no_forall -> None - | TypQ_tq [] -> None - | TypQ_tq qs -> Some (doc_quants qs) - -let doc_lit (L_aux(l,_)) = - utf8string (match l with - | L_unit -> "()" - | L_zero -> "bitzero" - | L_one -> "bitone" - | L_true -> "true" - | L_false -> "false" - | L_num i -> string_of_big_int i - | L_hex n -> "0x" ^ n - | L_bin n -> "0b" ^ n - | L_real r -> r - | L_undef -> "undefined" - | L_string s -> "\"" ^ String.escaped s ^ "\"") - -let rec doc_pat (P_aux (p_aux, _) as pat) = - match p_aux with - | P_id id -> doc_id id - | P_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen - | P_app (id, pats) -> doc_id id ^^ lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen - | P_typ (typ, pat) -> separate space [doc_pat pat; colon; doc_typ typ] - | P_lit lit -> doc_lit lit - (* P_var short form sugar *) - | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> - doc_kid kid - | P_var (pat, kid) -> separate space [doc_pat pat; string "as"; doc_kid kid] - | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) - | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats - | P_wild -> string "_" - | P_as (pat, id) -> separate space [doc_pat pat; string "as"; doc_id id] - | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) - | _ -> string (string_of_pat pat) - -(* if_block_x is true if x should be printed like a block, i.e. with - newlines. Blocks are automatically printed as blocks, so this - returns false for them. *) -let if_block_then (E_aux (e_aux, _)) = - match e_aux with - | E_assign _ | E_if _ -> true - | _ -> false - -let if_block_else (E_aux (e_aux, _)) = - match e_aux with - | E_assign _ -> true - | _ -> false - -let fixities = - let fixities' = - List.fold_left - (fun r (x, y) -> Bindings.add x y r) - Bindings.empty - [ - (mk_id "^", (InfixR, 8)); - (mk_id "*", (InfixL, 7)); - (mk_id "+", (InfixL, 6)); - (mk_id "-", (InfixL, 6)); - (mk_id "!=", (Infix, 4)); - (mk_id ">", (Infix, 4)); - (mk_id "<", (Infix, 4)); - (mk_id ">=", (Infix, 4)); - (mk_id "<=", (Infix, 4)); - (mk_id "&", (InfixR, 3)); - (mk_id "|", (InfixR, 2)); - ] - in - ref (fixities' : (prec * int) Bindings.t) - -let rec doc_exp (E_aux (e_aux, _) as exp) = - match e_aux with - | E_block [] -> string "()" - | E_block [exp] -> doc_exp exp - | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace - | E_nondet exps -> assert false - (* This is mostly for the -convert option *) - | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> - separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] - | E_app_infix _ -> doc_infix 0 exp - | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) - - (* Various rules to try to format if blocks nicely based on content *) - | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp && if_block_else else_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^//^ doc_exp else_exp) - | E_if (if_exp, then_exp, (E_aux (E_if _, _) as else_exp)) when if_block_then then_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^^ space ^^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_exp) when if_block_else else_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) - ^^ space ^^ (string "else" ^//^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^^ space ^^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_exp) -> - group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) - - | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" - | E_cons (exp1, exp2) -> string "E_cons" - | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] - | E_loop (While, cond, exp) -> - separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] - | E_loop (Until, cond, exp) -> - separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] - | E_record_update (exp, fexps) -> - separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] - | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] - | E_case (exp, pexps) -> - separate space [string "match"; doc_exp exp; doc_pexps pexps] - | E_let (LB_aux (LB_val (pat, binding), _), exp) -> - separate space [string "let"; doc_pat pat; equals; doc_exp binding; string "in"; doc_exp exp] - | E_internal_plet (pat, exp1, exp2) -> - let le = - prefix 2 1 - (separate space [string "internal_plet"; doc_pat pat; equals]) - (doc_exp exp1) in - doc_op (string "in") le (doc_exp exp2) - | E_internal_let (lexp, binding, exp) -> - separate space [string "var"; doc_lexp lexp; equals; doc_exp binding; string "in"; doc_exp exp] - | E_assign (lexp, exp) -> - separate space [doc_lexp lexp; equals; doc_exp exp] - | E_for (id, exp1, exp2, exp3, order, exp4) -> - begin - let header = - string "foreach" ^^ space ^^ - group (parens (separate (break 1) - [ doc_id id; - string "from " ^^ doc_atomic_exp exp1; - string "to " ^^ doc_atomic_exp exp2; - string "by " ^^ doc_atomic_exp exp3; - string "in " ^^ doc_ord order ])) - in - match exp4 with - | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 - | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 - | _ -> header ^//^ doc_exp exp4 - end - (* Resugar an assert with an empty message *) - | E_throw exp -> string "throw" ^^ parens (doc_exp exp) - | E_try (exp, pexps) -> assert false - | E_return exp -> string "return" ^^ parens (doc_exp exp) - | E_internal_return exp -> string "internal_return" ^^ parens (doc_exp exp) - | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> - separate space [string "2"; string "^"; doc_atomic_exp exp] - | _ -> doc_atomic_exp exp -and doc_infix n (E_aux (e_aux, _) as exp) = - match e_aux with - | E_app_infix (l, op, r) when n < 10 -> - begin - try - match Bindings.find op !fixities with - | (Infix, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r] - | (Infix, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r]) - | (InfixL, m) when m >= n -> separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r] - | (InfixL, m) when m < n -> parens (separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r]) - | (InfixR, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r] - | (InfixR, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r]) - with - | Not_found -> - separate space [doc_atomic_exp l; doc_id op; doc_atomic_exp r] - end - | _ -> doc_atomic_exp exp -and doc_atomic_exp (E_aux (e_aux, _) as exp) = - match e_aux with - | E_cast (typ, exp) -> - separate space [doc_atomic_exp exp; colon; doc_typ typ] - | E_lit lit -> doc_lit lit - | E_id id -> doc_id id - | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id - | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid - | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) - (* Format a function with a unit argument as f() rather than f(()) *) - | E_app (id, [E_aux (E_lit (L_aux (L_unit, _)), _)]) -> doc_id id ^^ string "()" - | E_app (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) - | E_constraint nc -> string "constraint" ^^ parens (doc_nc nc) - | E_assert (exp1, E_aux (E_lit (L_aux (L_string "", _)), _)) -> string "assert" ^^ parens (doc_exp exp1) - | E_assert (exp1, exp2) -> string "assert" ^^ parens (doc_exp exp1 ^^ comma ^^ space ^^ doc_exp exp2) - | E_exit exp -> string "exit" ^^ parens (doc_exp exp) - | E_vector_access (exp1, exp2) -> doc_atomic_exp exp1 ^^ brackets (doc_exp exp2) - | E_vector_subrange (exp1, exp2, exp3) -> doc_atomic_exp exp1 ^^ brackets (separate space [doc_exp exp2; string ".."; doc_exp exp3]) - | E_vector exps -> brackets (separate_map (comma ^^ space) doc_exp exps) - | E_vector_update (exp1, exp2, exp3) -> - brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) - | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> - brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) - | _ -> parens (doc_exp exp) -and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = - separate_map (comma ^^ space) doc_fexp fexps -and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = - separate space [doc_id id; equals; doc_exp exp] -and doc_block = function - | [] -> string "()" - | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> - separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps - | [E_aux (E_internal_let (lexp, binding, E_aux (E_block exps, _)), _)] -> - separate space [string "var"; doc_lexp lexp; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps - | [exp] -> doc_exp exp - | exp :: exps -> doc_exp exp ^^ semi ^^ hardline ^^ doc_block exps -and doc_lexp (LEXP_aux (l_aux, _) as lexp) = - match l_aux with - | LEXP_cast (typ, id) -> separate space [doc_id id; colon; doc_typ typ] - | _ -> doc_atomic_lexp lexp -and doc_atomic_lexp (LEXP_aux (l_aux, _) as lexp) = - match l_aux with - | LEXP_id id -> doc_id id - | LEXP_tup lexps -> lparen ^^ separate_map (comma ^^ space) doc_lexp lexps ^^ rparen - | LEXP_field (lexp, id) -> doc_atomic_lexp lexp ^^ dot ^^ doc_id id - | LEXP_vector (lexp, exp) -> doc_atomic_lexp lexp ^^ brackets (doc_exp exp) - | LEXP_vector_range (lexp, exp1, exp2) -> doc_atomic_lexp lexp ^^ brackets (separate space [doc_exp exp1; string ".."; doc_exp exp2]) - | LEXP_memory (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) - | _ -> parens (doc_lexp lexp) -and doc_pexps pexps = surround 2 0 lbrace (separate_map (comma ^^ hardline) doc_pexp pexps) rbrace -and doc_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_exp (pat, exp) -> separate space [doc_pat pat; string "=>"; doc_exp exp] - | Pat_when (pat, wh, exp) -> - separate space [doc_pat pat; string "if"; doc_exp wh; string "=>"; doc_exp exp] -and doc_letbind (LB_aux (lb_aux, _)) = - match lb_aux with - | LB_val (pat, exp) -> - separate space [doc_pat pat; equals; doc_exp exp] - -let doc_funcl funcl = string "FUNCL" - -let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = - match pexp with - | Pat_exp (pat,exp) -> - group (separate space [doc_id id; doc_pat pat; equals; doc_exp exp]) - | Pat_when (pat,wh,exp) -> - group (separate space [doc_id id; parens (separate space [doc_pat pat; string "if"; doc_exp wh]); string "="; doc_exp exp]) - -let doc_default (DT_aux(df,_)) = match df with - | DT_kind(bk,v) -> string "DT_kind" (* separate space [string "default"; doc_bkind bk; doc_var v] *) - | DT_typ(ts,id) -> separate space [string "default"; doc_typschm ts; doc_id id] - | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] - -let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = - match funcls with - | [] -> failwith "Empty function list" - | _ -> - let sep = hardline ^^ string "and" ^^ space in - let clauses = separate_map sep doc_funcl funcls in - string "function" ^^ space ^^ clauses - -let doc_dec (DEC_aux (reg,_)) = - match reg with - | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] - | DEC_alias(id,alspec) -> string "ALIAS" - | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" - -let doc_field (typ, id) = - separate space [doc_id id; colon; doc_typ typ] - -let doc_union (Tu_aux (tu, l)) = match tu with - | Tu_id id -> doc_id id - | Tu_ty_id (typ, id) -> separate space [doc_id id; colon; doc_typ typ] - -let doc_typdef (TD_aux(td,_)) = match td with - | TD_abbrev (id, _, typschm) -> - begin - match doc_typschm_quants typschm with - | Some qdoc -> - doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) - | None -> - doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) - end - | TD_enum (id, _, ids, _) -> - separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] - | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> - separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] - | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> - separate space [string "struct"; doc_id id; doc_quants qs; equals; - surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] - | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> - separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] - | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> - separate space [string "union"; doc_id id; doc_quants qs; equals; - surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] - | _ -> string "TYPEDEF" - -let doc_spec (VS_aux(v,_)) = - let doc_extern ext = - let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ - utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in - let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"]) in - if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) - in - match v with - | VS_val_spec(ts,id,ext,is_cast) -> - string "val" ^^ space - ^^ (if is_cast then (string "cast" ^^ space) else empty) - ^^ doc_id id ^^ space - ^^ doc_extern ext - ^^ colon ^^ space - ^^ doc_typschm ts - -let doc_prec = function - | Infix -> string "infix" - | InfixL -> string "infixl" - | InfixR -> string "infixr" - -let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = - separate space [string "integer"; doc_id id; equals; doc_nexp nexp] - -let rec doc_scattered (SD_aux (sd_aux, _)) = - match sd_aux with - | SD_scattered_function (_, _, _, id) -> - string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id - | SD_scattered_funcl funcl -> - string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl - | SD_scattered_end id -> - string "end" ^^ space ^^ doc_id id - | _ -> string "SCATTERED" - -let rec doc_def def = group (match def with - | DEF_default df -> doc_default df - | DEF_spec v_spec -> doc_spec v_spec - | 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_internal_mutrec f_defs -> separate_map hardline doc_fundef f_defs - | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind - | DEF_internal_mutrec fundefs -> - (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) - ^^ hardline ^^ string "}" - | DEF_reg_dec dec -> doc_dec dec - | DEF_scattered sdef -> doc_scattered sdef - | DEF_fixity (prec, n, id) -> - fixities := Bindings.add id (prec, int_of_big_int n) !fixities; - separate space [doc_prec prec; doc_int n; doc_id id] - | DEF_overload (id, ids) -> - separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] - | DEF_comm (DC_comm s) -> string "TOPLEVEL" - | DEF_comm (DC_comm_struct d) -> string "TOPLEVEL" - ) ^^ hardline - -let doc_defs (Defs(defs)) = - separate_map hardline doc_def defs - -let pp_defs f d = ToChannel.pretty 1. 80 f (doc_defs d) diff --git a/src/process_file.ml b/src/process_file.ml index 9b5cd9da..435beb3c 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -48,7 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) -let opt_new_parser = ref false +let opt_lem_sequential = ref false +let opt_lem_mwords = ref false type out_type = | Lem_ast_out @@ -64,42 +65,14 @@ let get_lexbuf f = lexbuf, in_chan let parse_file (f : string) : Parse_ast.defs = - if not !opt_new_parser - then - let scanbuf, in_chan = get_lexbuf f in - let type_names = - try - Pre_parser.file Pre_lexer.token scanbuf - with - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p scanbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "pre"))) - | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) - | Lexer.LexError(s,p) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) - in - close_in in_chan; - Lexer.custom_type_names := !Lexer.custom_type_names @ type_names - else (); - let lexbuf, in_chan = get_lexbuf f in try - let ast = - if !opt_new_parser - then Parser2.file Lexer2.token lexbuf - else Parser.file Lexer.token lexbuf - in + let ast = Parser.file Lexer.token lexbuf in close_in in_chan; ast with - | Parser2.Error -> + | Parser.Error -> let pos = Lexing.lexeme_start_p lexbuf in raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "no information"))) - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p lexbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "main"))) - | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) | Lexer.LexError(s,p) -> raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) @@ -119,7 +92,7 @@ let opt_dno_cast = ref false let check_ast (defs : unit Ast.defs) : Type_check.tannot Ast.defs * Type_check.Env.t = let ienv = if !opt_dno_cast then Type_check.Env.no_casts Type_check.initial_env else Type_check.initial_env in let ast, env = Type_check.check ienv defs in - let () = if !opt_ddump_tc_ast then Pretty_print.pp_defs stdout ast else () in + let () = if !opt_ddump_tc_ast then Pretty_print_sail.pp_defs stdout ast else () in let () = if !opt_just_check then exit 0 else () in (ast, env) @@ -139,7 +112,7 @@ let monomorphise_ast locs type_env ast = all_split_errors = !opt_dall_split_errors } in let ast = monomorphise opts locs type_env ast in - let () = if !opt_ddump_raw_mono_ast then Pretty_print.pp_defs stdout ast else () in + let () = if !opt_ddump_raw_mono_ast then Pretty_print_sail.pp_defs stdout ast else () in let ienv = Type_check.Env.no_casts Type_check.initial_env in Type_check.check ienv ast @@ -225,7 +198,7 @@ let rewrite_step defs (name,rewriter) = let filename = f ^ "_rewrite_" ^ string_of_int i ^ "_" ^ name ^ ".sail" in (* output "" Lem_ast_out [filename, defs]; *) let ((ot,_, _) as ext_ot) = open_output_with_check_unformatted filename in - Pretty_print_sail2.pp_defs ot defs; + Pretty_print_sail.pp_defs ot defs; close_output_with_check ext_ot; opt_ddump_rewrite_ast := Some (f, i + 1) end @@ -241,5 +214,6 @@ let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !Pretty_print_lem.opt_mwords x)] let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_interpreter = rewrite Rewrites.rewrite_defs_interpreter let rewrite_ast_sil = rewrite Rewrites.rewrite_defs_sil let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/process_file.mli b/src/process_file.mli index 53bb9606..bc8936c8 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -56,13 +56,15 @@ val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_undefined: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_interpreter : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_sil : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val load_file_no_check : Ast.order -> string -> unit Ast.defs val load_file : Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t -val opt_new_parser : bool ref +val opt_lem_sequential : bool ref +val opt_lem_mwords : bool ref val opt_just_check : bool ref val opt_ddump_tc_ast : bool ref val opt_ddump_rewrite_ast : ((string * int) option) ref diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml index 166e0517..af1f85d0 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -97,7 +97,7 @@ let rec skip_lines in_chan = function | n when n <= 0 -> () - | n -> input_line in_chan; skip_lines in_chan (n - 1) + | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1) let rec read_lines in_chan = function | n when n <= 0 -> [] @@ -186,9 +186,9 @@ let read_from_file_pos2 p1 p2 = let ic = open_in p1.Lexing.pos_fname in let _ = seek_in ic s in let l = (e - s) in - let buf = String.create l in + let buf = Bytes.create l in let _ = input ic buf 0 l in - let _ = match multi with None -> () | Some sk -> String.fill buf 0 sk ' ' in + let _ = match multi with None -> () | Some sk -> Bytes.fill buf 0 sk ' ' in let _ = close_in ic in (buf, not (multi = None)) diff --git a/src/rewriter.ml b/src/rewriter.ml index 31bcb577..9e9409ec 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Ast_util open Type_check @@ -107,7 +107,7 @@ let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with let effsum = match e with | E_block es -> union_eff_exps es | E_nondet es -> union_eff_exps es - | E_id _ + | E_id _ | E_ref _ | E_lit _ -> eff | E_cast (_,e) -> effect_of e | E_app (f,es) -> @@ -141,11 +141,12 @@ let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with | E_internal_cast (_,e) -> effect_of e | E_internal_exp _ -> no_effect | E_internal_exp_user _ -> no_effect - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> union_effects (effect_of_lexp lexp) (union_effects (effect_of e1) (effect_of e2)) | E_internal_plet (_,e1,e2) -> union_effects (effect_of e1) (effect_of e2) | E_internal_return e1 -> effect_of e1 + | E_internal_value v -> no_effect in E_aux (e, (l, Some (env, typ, effsum))) | None -> @@ -156,6 +157,7 @@ let fix_eff_lexp (LEXP_aux (lexp,((l,_) as annot))) = match snd annot with let effsum = union_effects eff (match lexp with | LEXP_id _ -> no_effect | LEXP_cast _ -> no_effect + | LEXP_deref e -> effect_of e | LEXP_memory (_,es) -> union_eff_exps es | LEXP_tup les -> List.fold_left (fun eff le -> union_effects eff (effect_of_lexp le)) no_effect les @@ -204,24 +206,6 @@ let fix_eff_lb (LB_aux (lb,((l,_) as annot))) = match snd annot with | None -> LB_aux (lb, (l, None)) -let effectful_effs = function - | Effect_aux (Effect_set effs, _) -> - List.exists - (fun (BE_aux (be,_)) -> - match be with - | BE_nondet | BE_unspec | BE_undef | BE_lset -> false - | _ -> true - ) effs - | _ -> true - -let effectful eaux = effectful_effs (effect_of (propagate_exp_effect eaux)) -let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) - -(* let id_to_string (Id_aux(id,l)) = - match id with - | Id(s) -> s - | DeIid(s) -> s *) - let explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in exp (String.length s - 1) [] @@ -338,8 +322,8 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = | E_assert(e1,e2) -> rewrap (E_assert(rewrite e1,rewrite e2)) | E_internal_cast (casted_annot,exp) -> rewrap (E_internal_cast (casted_annot, rewrite exp)) - | E_internal_let (lexp, e1, e2) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters e1, rewriters.rewrite_exp rewriters e2)) + | E_var (lexp, e1, e2) -> + rewrap (E_var (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters e1, rewriters.rewrite_exp rewriters e2)) | E_internal_return _ -> raise (Reporting_basic.err_unreachable l "Internal return found before it should have been introduced") | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l " Internal plet found before it should have been introduced") | _ -> rewrap exp @@ -355,6 +339,7 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrap le = LEXP_aux(le,(l,annot)) in match lexp with | LEXP_id _ | LEXP_cast _ -> rewrap lexp + | LEXP_deref exp -> rewrap (LEXP_deref (rewriters.rewrite_exp rewriters exp)) | LEXP_tup tupls -> rewrap (LEXP_tup (List.map (rewriters.rewrite_lexp rewriters) tupls)) | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters) exps)) | LEXP_vector (lexp,exp) -> @@ -488,6 +473,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, { e_block : 'exp list -> 'exp_aux ; e_nondet : 'exp list -> 'exp_aux ; e_id : id -> 'exp_aux + ; e_ref : id -> 'exp_aux ; e_lit : lit -> 'exp_aux ; e_cast : Ast.typ * 'exp -> 'exp_aux ; e_app : id * 'exp list -> 'exp_aux @@ -525,8 +511,10 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux + ; e_internal_value : Value.value -> 'exp_aux ; e_aux : 'exp_aux * 'a annot -> 'exp ; lEXP_id : id -> 'lexp_aux + ; lEXP_deref : 'exp -> 'lexp_aux ; lEXP_memory : id * 'exp list -> 'lexp_aux ; lEXP_cast : Ast.typ * id -> 'lexp_aux ; lEXP_tup : 'lexp list -> 'lexp_aux @@ -553,6 +541,7 @@ let rec fold_exp_aux alg = function | E_block es -> alg.e_block (List.map (fold_exp alg) es) | E_nondet es -> alg.e_nondet (List.map (fold_exp alg) es) | E_id id -> alg.e_id id + | E_ref id -> alg.e_ref id | E_lit lit -> alg.e_lit lit | E_cast (typ,e) -> alg.e_cast (typ, fold_exp alg e) | E_app (id,es) -> alg.e_app (id, List.map (fold_exp alg) es) @@ -594,14 +583,16 @@ let rec fold_exp_aux alg = function | E_internal_exp_user (annot1,annot2) -> alg.e_internal_exp_user (annot1,annot2) | E_comment c -> alg.e_comment c | E_comment_struc e -> alg.e_comment_struc (fold_exp alg e) - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> alg.e_internal_let (fold_lexp alg lexp, fold_exp alg e1, fold_exp alg e2) | E_internal_plet (pat,e1,e2) -> alg.e_internal_plet (fold_pat alg.pat_alg pat, fold_exp alg e1, fold_exp alg e2) | E_internal_return e -> alg.e_internal_return (fold_exp alg e) + | E_internal_value v -> alg.e_internal_value v and fold_exp alg (E_aux (exp_aux,annot)) = alg.e_aux (fold_exp_aux alg exp_aux, annot) and fold_lexp_aux alg = function | LEXP_id id -> alg.lEXP_id id + | LEXP_deref exp -> alg.lEXP_deref (fold_exp alg exp) | LEXP_memory (id,es) -> alg.lEXP_memory (id, List.map (fold_exp alg) es) | LEXP_tup les -> alg.lEXP_tup (List.map (fold_lexp alg) les) | LEXP_cast (typ,id) -> alg.lEXP_cast (typ,id) @@ -632,6 +623,7 @@ let id_exp_alg = { e_block = (fun es -> E_block es) ; e_nondet = (fun es -> E_nondet es) ; e_id = (fun id -> E_id id) + ; e_ref = (fun id -> E_ref id) ; e_lit = (fun lit -> (E_lit lit)) ; e_cast = (fun (typ,e) -> E_cast (typ,e)) ; e_app = (fun (id,es) -> E_app (id,es)) @@ -666,11 +658,13 @@ let id_exp_alg = ; e_internal_exp_user = (fun (a1,a2) -> E_internal_exp_user (a1,a2)) ; e_comment = (fun c -> E_comment c) ; e_comment_struc = (fun e -> E_comment_struc e) - ; e_internal_let = (fun (lexp, e2, e3) -> E_internal_let (lexp,e2,e3)) + ; e_internal_let = (fun (lexp, e2, e3) -> E_var (lexp,e2,e3)) ; e_internal_plet = (fun (pat, e1, e2) -> E_internal_plet (pat,e1,e2)) ; e_internal_return = (fun e -> E_internal_return e) + ; e_internal_value = (fun v -> E_internal_value v) ; e_aux = (fun (e,annot) -> E_aux (e,annot)) ; lEXP_id = (fun id -> LEXP_id id) + ; lEXP_deref = (fun e -> LEXP_deref e) ; lEXP_memory = (fun (id,es) -> LEXP_memory (id,es)) ; lEXP_cast = (fun (typ,id) -> LEXP_cast (typ,id)) ; lEXP_tup = (fun tups -> LEXP_tup tups) @@ -725,6 +719,7 @@ let compute_exp_alg bot join = { e_block = split_join (fun es -> E_block es) ; e_nondet = split_join (fun es -> E_nondet es) ; e_id = (fun id -> (bot, E_id id)) + ; e_ref = (fun id -> (bot, E_ref id)) ; e_lit = (fun lit -> (bot, E_lit lit)) ; e_cast = (fun (typ,(v,e)) -> (v, E_cast (typ,e))) ; e_app = (fun (id,es) -> split_join (fun es -> E_app (id,es)) es) @@ -766,12 +761,14 @@ let compute_exp_alg bot join = ; e_comment = (fun c -> (bot, E_comment c)) ; e_comment_struc = (fun (v,e) -> (bot, E_comment_struc e)) (* ignore value by default, since it is comes from a comment *) ; e_internal_let = (fun ((vl, lexp), (v2,e2), (v3,e3)) -> - (join_list [vl;v2;v3], E_internal_let (lexp,e2,e3))) + (join_list [vl;v2;v3], E_var (lexp,e2,e3))) ; e_internal_plet = (fun ((vp,pat), (v1,e1), (v2,e2)) -> (join_list [vp;v1;v2], E_internal_plet (pat,e1,e2))) ; e_internal_return = (fun (v,e) -> (v, E_internal_return e)) + ; e_internal_value = (fun v -> (bot, E_internal_value v)) ; e_aux = (fun ((v,e),annot) -> (v, E_aux (e,annot))) ; lEXP_id = (fun id -> (bot, LEXP_id id)) + ; lEXP_deref = (fun (v, e) -> (v, LEXP_deref e)) ; lEXP_memory = (fun (id,es) -> split_join (fun es -> LEXP_memory (id,es)) es) ; lEXP_cast = (fun (typ,id) -> (bot, LEXP_cast (typ,id))) ; lEXP_tup = (fun ls -> diff --git a/src/rewriter.mli b/src/rewriter.mli index dc592a4d..c3c384bf 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Type_check @@ -108,6 +108,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, { e_block : 'exp list -> 'exp_aux ; e_nondet : 'exp list -> 'exp_aux ; e_id : id -> 'exp_aux + ; e_ref : id -> 'exp_aux ; e_lit : lit -> 'exp_aux ; e_cast : Ast.typ * 'exp -> 'exp_aux ; e_app : id * 'exp list -> 'exp_aux @@ -145,8 +146,10 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux + ; e_internal_value : Value.value -> 'exp_aux ; e_aux : 'exp_aux * 'a annot -> 'exp ; lEXP_id : id -> 'lexp_aux + ; lEXP_deref : 'exp -> 'lexp_aux ; lEXP_memory : id * 'exp list -> 'lexp_aux ; lEXP_cast : Ast.typ * id -> 'lexp_aux ; lEXP_tup : 'lexp list -> 'lexp_aux diff --git a/src/rewrites.ml b/src/rewrites.ml index 32ffe54a..e14ced08 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Ast_util open Type_check @@ -102,7 +102,6 @@ let effectful_effs = function | BE_nondet | BE_unspec | BE_undef | BE_lset -> false | _ -> true ) effs - | _ -> true let effectful eaux = effectful_effs (effect_of (propagate_exp_effect eaux)) let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) @@ -169,12 +168,12 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = constants? This will resolve a 'n - 1 sizeof when 'n is in scope. *) | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) -> - let one_exp = infer_exp env (mk_lit_exp (L_num unit_big_int)) in + let one_exp = infer_exp env (mk_lit_exp (L_num (Big_int.of_int 1))) in Some (E_aux (E_app (mk_id "add_range", [var; one_exp]), (gen_loc l, Some (env, atom_typ (nsum size (nint 1)), no_effect)))) | _ -> begin match destruct_vector env typ with - | Some (_, len, _, _) when prove env (nc_eq len nexp) -> + | Some (len, _, _) when prove env (nc_eq len nexp) -> Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) | _ -> None end @@ -329,6 +328,7 @@ let rewrite_sizeof (Defs defs) = { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) ; e_id = (fun id -> (E_id id, E_id id)) + ; e_ref = (fun id -> (E_ref id, E_ref id)) ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) @@ -363,11 +363,13 @@ let rewrite_sizeof (Defs defs) = ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) ; e_comment = (fun c -> (E_comment c, E_comment c)) ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) - ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) + ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_var (lexp,e2,e3), E_var (lexp',e2',e3'))) ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) + ; e_internal_value = (fun v -> (E_internal_value v, E_internal_value v)) ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) + ; lEXP_deref = (fun (e, e') -> (LEXP_deref e, LEXP_deref e')) ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) @@ -643,8 +645,8 @@ let remove_vector_concat_pat pat = let (start,last_idx) = (match vector_typ_args_of rtyp with | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> (start, if is_order_inc ord - then sub_big_int (add_big_int start length) unit_big_int - else add_big_int (sub_big_int start length) unit_big_int) + then Big_int.sub (Big_int.add start length) (Big_int.of_int 1) + else Big_int.add (Big_int.sub start length) (Big_int.of_int 1)) | _ -> raise (Reporting_basic.err_unreachable (fst rannot') ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in @@ -654,8 +656,8 @@ let remove_vector_concat_pat pat = let (pos',index_j) = match length with | Nexp_aux (Nexp_constant i,_) -> if is_order_inc ord - then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) - else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) + then (Big_int.add pos i, Big_int.sub (Big_int.add pos i) (Big_int.of_int 1)) + else (Big_int.sub pos i, Big_int.add (Big_int.sub pos i) (Big_int.of_int 1)) | Nexp_aux (_,l) -> if is_last then (pos,last_idx) else @@ -755,8 +757,8 @@ let remove_vector_concat_pat pat = with vector_concats patterns as direct child-nodes anymore *) let range a b = - let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in - if gt_big_int a b then List.rev (aux b a) else aux a b in + let rec aux a b = if Big_int.greater a b then [] else a :: aux (Big_int.add a (Big_int.of_int 1)) b in + if Big_int.greater a b then List.rev (aux b a) else aux a b in let remove_vector_concats = let p_vector_concat ps = @@ -770,9 +772,9 @@ let remove_vector_concat_pat pat = match p, vector_typ_args_of typ with | P_vector ps,_ -> acc @ ps | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> - acc @ (List.map wild (range zero_big_int (sub_big_int length unit_big_int))) + acc @ (List.map wild (range Big_int.zero (Big_int.sub length (Big_int.of_int 1)))) | _, _ -> - (*if is_last then*) acc @ [wild zero_big_int] + (*if is_last then*) acc @ [wild Big_int.zero] else raise (Reporting_basic.err_unreachable l ("remove_vector_concats: Non-vector in vector-concat pattern " ^ @@ -942,6 +944,7 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) = | P_wild -> raise (Reporting_basic.err_unreachable l "pat_to_exp given wildcard pattern") | P_as (pat,id) -> rewrap (E_id id) + | P_var (pat, _) -> pat_to_exp pat | P_typ (_,pat) -> pat_to_exp pat | P_id id -> rewrap (E_id id) | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) @@ -1036,7 +1039,7 @@ let compose_guard_opt g1 g2 = match g1, g2 with let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with | P_lit _ | P_wild | P_id _ -> false -| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat +| P_as (pat,_) | P_typ (_,pat) | P_var (pat,_) -> contains_bitvector_pat pat | P_vector _ | P_vector_concat _ -> let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in is_bitvector_typ typ @@ -1112,7 +1115,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = let subvec_exp = match start, length with | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) - when eq_big_int s i && eq_big_int l (big_int_of_int (List.length lits)) -> + when Big_int.equal s i && Big_int.equal l (Big_int.of_int (List.length lits)) -> mk_exp (E_id rootid) | _ -> mk_exp (E_vector_subrange (mk_exp (E_id rootid), mk_num_exp i, mk_num_exp j)) in @@ -1139,7 +1142,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = let collect_guards_decls ps rootid t = let (start,_,ord,_) = vector_typ_args_of t in let rec collect current (guards,dls) idx ps = - let idx' = if is_order_inc ord then add_big_int idx unit_big_int else sub_big_int idx unit_big_int in + let idx' = if is_order_inc ord then Big_int.add idx (Big_int.of_int 1) else Big_int.sub idx (Big_int.of_int 1) in (match ps with | pat :: ps' -> (match pat with @@ -1365,7 +1368,7 @@ let rewrite_fun_guarded_pats rewriters (FD_aux (FD_function (r,t,e,funcls),(l,fd (pat,guard,exp,annot) in let cs = rewrite_guarded_clauses l (List.map clause funcls) in List.map (fun (pat,exp,annot) -> - FCL_aux (FCL_Funcl(id,construct_pexp (pat,None,exp,(Unknown,None))),annot)) cs + FCL_aux (FCL_Funcl(id,construct_pexp (pat,None,exp,(Parse_ast.Unknown,None))),annot)) cs | _ -> funcls (* TODO is the empty list possible here? *) in FD_aux (FD_function(r,t,e,funcls),(l,fdannot)) @@ -1383,7 +1386,7 @@ let id_is_unbound id env = match Env.lookup_id id env with | _ -> false let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false + | LEXP_memory _ | LEXP_deref _ -> false | LEXP_id id | LEXP_cast (_, id) -> id_is_local_var id env | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps @@ -1392,7 +1395,7 @@ let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with | LEXP_field (lexp,_) -> lexp_is_local lexp env let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false + | LEXP_memory _ | LEXP_deref _ -> false | LEXP_id id | LEXP_cast (_, id) -> id_is_unbound id env | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps @@ -1407,7 +1410,7 @@ let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with let rec rewrite_lexp_to_rhs (do_rewrite : tannot lexp -> bool) ((LEXP_aux(lexp,((l,_) as annot))) as le) = if do_rewrite le then match lexp with - | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ | LEXP_deref _ -> (le, (fun exp -> exp)) | LEXP_vector (lexp, e) -> let (lhs, rhs) = rewrite_lexp_to_rhs do_rewrite lexp in (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) @@ -1420,21 +1423,6 @@ let rec rewrite_lexp_to_rhs (do_rewrite : tannot lexp -> bool) ((LEXP_aux(lexp,( let (LEXP_aux (_, lannot)) = lexp in let env = env_of_annot lannot in match Env.expand_synonyms env (typ_of_annot lannot) with - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id regtyp_id, _)), _)]), _) - | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> - let base, top, ranges = Env.get_regtyp regtyp_id env in - let range, _ = - try List.find (fun (_, fid) -> Id.compare fid id = 0) ranges with - | Not_found -> - raise (Reporting_basic.err_typ l ("Field " ^ string_of_id id ^ " doesn't exist for register type " ^ string_of_id regtyp_id)) - in - let lexp_exp = E_aux (E_app (mk_id ("cast_" ^ string_of_id regtyp_id), [lexp_to_exp lexp]), (l, None)) in - let n, m = match range with - | BF_aux (BF_single n, _) -> n, n - | BF_aux (BF_range (n, m), _) -> n, m - | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) in - let rhs' exp = rhs (E_aux (E_vector_update_subrange (lexp_exp, simple_num l n, simple_num l m, exp), lannot)) in - (lhs, rhs') | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), lannot)))) @@ -1469,7 +1457,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f let exps' = walker exps in let effects = union_eff_exps exps' in let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in - [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] + [fix_eff_exp (E_aux (E_var(le', e', block), annot))] (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> let vars_t = introduced_variables t in let vars_e = introduced_variables e in @@ -1506,7 +1494,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f (Parse_ast.Generated l, simple_annot t)) | _ -> e in let unioneffs = union_effects effects (get_effsum_exp set_exp) in - ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), + ([E_aux (E_var (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), (Parse_ast.Generated l, (tag_annot t Emp_intro))), set_exp, E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), @@ -1522,7 +1510,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f let e' = re' (rewrite_base e) in let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in check_exp (env_of full_exp) - (strip_exp (E_aux (E_internal_let(le', e', block), annot))) (typ_of full_exp) + (strip_exp (E_aux (E_var(le', e', block), annot))) (typ_of full_exp) | _ -> rewrite_base full_exp let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = @@ -1571,46 +1559,8 @@ let rewrite_register_ref_writes (Defs defs) = | None -> E_assign (lexp, exp) in let rewrite_exp _ = fold_exp { id_exp_alg with e_assign = e_assign } in - let generate_field_accessors l env id n1 n2 fields = - let i1, i2 = match n1, n2 with - | Nexp_aux(Nexp_constant i1, _),Nexp_aux(Nexp_constant i2, _) -> i1, i2 - | _ -> raise (Reporting_basic.err_typ l - ("Non-constant indices in register type " ^ string_of_id id)) in - let dir_b = i1 < i2 in - let dir = (if dir_b then "true" else "false") in - let ord = Ord_aux ((if dir_b then Ord_inc else Ord_dec), Parse_ast.Unknown) in - let size = if dir_b then succ_big_int (sub_big_int i2 i1) else succ_big_int (sub_big_int i1 i2) in - let rtyp = mk_id_typ id in - let vtyp = vector_typ (nconstant i1) (nconstant size) ord bit_typ in - let accessors (fr, fid) = - let i, j = match fr with - | BF_aux (BF_single i, _) -> (i, i) - | BF_aux (BF_range (i, j), _) -> (i, j) - | _ -> raise (Reporting_basic.err_unreachable l "unsupported field type") in - let mk_num_exp i = mk_lit_exp (L_num i) in - let reg_pat, reg_env = bind_pat env (mk_pat (P_typ (rtyp, mk_pat (P_id (mk_id "reg"))))) rtyp in - let inferred_get = infer_exp reg_env (mk_exp (E_vector_subrange - (mk_exp (E_id (mk_id "reg")), mk_num_exp i, mk_num_exp j))) in - let ftyp = typ_of inferred_get in - let v_pat, v_env = bind_pat reg_env (mk_pat (P_typ (ftyp, mk_pat (P_id (mk_id "v"))))) ftyp in - let inferred_set = infer_exp v_env (mk_exp (E_vector_update_subrange - (mk_exp (E_id (mk_id "reg")), mk_num_exp i, mk_num_exp j, mk_exp (E_id (mk_id "v"))))) in - let set_args = P_aux (P_tup [reg_pat; v_pat], (l, Some (env, tuple_typ [rtyp; ftyp], no_effect))) in - let fsuffix = "_" ^ string_of_id id ^ "_" ^ string_of_id fid in - let rec_opt = Rec_aux (Rec_nonrec, l) in - let tannot ret_typ = Typ_annot_opt_aux (Typ_annot_opt_some (TypQ_aux (TypQ_tq [], l), ret_typ), l) in - let eff_opt = Effect_opt_aux (Effect_opt_pure, l) in - let mk_funcl id pat exp = FCL_aux (FCL_Funcl (mk_id id, Pat_aux (Pat_exp (pat, exp),(l,None))), (l, None)) in - let mk_fundef id pat exp ret_typ = DEF_fundef (FD_aux (FD_function (rec_opt, tannot ret_typ, eff_opt, [mk_funcl id pat exp]), (l, None))) in - [mk_fundef ("get" ^ fsuffix) reg_pat inferred_get ftyp; - mk_fundef ("set" ^ fsuffix) set_args inferred_set (typ_of inferred_set)] in - List.concat (List.map accessors fields) in - let rewriters = { rewriters_base with rewrite_exp = rewrite_exp } in let rec rewrite ds = match ds with - | (DEF_type (TD_aux (TD_register (id, n1, n2, fields), (l, Some (env, _, _)))) as d) :: ds -> - let (Defs d), env = check env (Defs [d]) in - d @ (generate_field_accessors l env id n1 n2 fields) @ rewrite ds | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) | [] -> [] in Defs (rewrite (write_reg_spec @ defs)) @@ -1653,8 +1603,8 @@ let rewrite_register_ref_writes (Defs defs) = (fun (Pat_aux (Pat_exp(p,e),pannot)) -> Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) - | E_internal_let (lexp,exp,body) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) + | E_var (lexp,exp,body) -> + rewrap (E_var (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) | _ -> rewrite_base full_exp let rewrite_defs_separate_numbs defs = rewrite_defs_base @@ -1797,6 +1747,7 @@ let rewrite_fix_val_specs (Defs defs) = let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' + | _ -> assert false (* find_vs must return a function type *) in let annot = add_effect_annot annot eff in (Bindings.add id vs val_specs, @@ -1926,7 +1877,7 @@ let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = | TD_variant (id, nso, typq, tus, flag) -> TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) - | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) + | TD_bitfield _ -> assert false (* Processed before re-writing *) (* FIXME: other reg_dec types *) let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = @@ -1966,7 +1917,7 @@ let rewrite_undefined mwords = let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) and simple_typ_aux = function | Typ_id id -> Typ_id id - | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> + | Typ_app (id, [_; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> Typ_id (mk_id "int") @@ -2048,15 +1999,15 @@ let rewrite_tuple_vector_assignments defs = let (_, len, _, _) = vector_typ_args_of ltyp in match nexp_simp len with | Nexp_aux (Nexp_constant len, _) -> len - | _ -> unit_big_int - else unit_big_int in + | _ -> (Big_int.of_int 1) + else (Big_int.of_int 1) in let next i step = if is_order_inc ord - then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) - else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in + then (Big_int.sub (Big_int.add i step) (Big_int.of_int 1), Big_int.add i step) + else (Big_int.add (Big_int.sub i step) (Big_int.of_int 1), Big_int.sub i step) in let i = match nexp_simp start with | (Nexp_aux (Nexp_constant i, _)) -> i - | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in + | _ -> if is_order_inc ord then Big_int.zero else Big_int.of_int (List.length lexps - 1) in let l = gen_loc (fst annot) in let exp' = if small exp then strip_exp exp @@ -2189,8 +2140,8 @@ let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list match l with | [] -> k [] | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) - -let rewrite_defs_letbind_effects = + +let rewrite_defs_letbind_effects = let rec value ((E_aux (exp_aux,_)) as exp) = not (effectful exp || updates_vars exp) @@ -2212,7 +2163,7 @@ let rewrite_defs_letbind_effects = and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in - n_exp_name exp (fun exp -> + n_exp_name exp (fun exp -> k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = @@ -2252,6 +2203,9 @@ let rewrite_defs_letbind_effects = let (LEXP_aux (lexp_aux,annot)) = lexp in match lexp_aux with | LEXP_id _ -> k lexp + | LEXP_deref exp -> + n_exp exp (fun exp -> + k (fix_eff_lexp (LEXP_aux (LEXP_deref exp, annot)))) | LEXP_memory (id,es) -> n_exp_nameL es (fun es -> k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) @@ -2297,6 +2251,7 @@ let rewrite_defs_letbind_effects = | E_block es -> failwith "E_block should have been removed till now" | E_nondet _ -> failwith "E_nondet not supported" | E_id id -> k exp + | E_ref id -> k exp | E_lit _ -> k exp | E_cast (typ,exp') -> n_exp_name exp' (fun exp' -> @@ -2320,7 +2275,7 @@ let rewrite_defs_letbind_effects = let exp3 = n_exp_term newreturn exp3 in k (rewrap (E_if (exp1,exp2,exp3)))) | E_for (id,start,stop,by,dir,body) -> - n_exp_name start (fun start -> + n_exp_name start (fun start -> n_exp_name stop (fun stop -> n_exp_name by (fun by -> let body = n_exp_term (effectful body) body in @@ -2337,19 +2292,19 @@ let rewrite_defs_letbind_effects = n_exp_name exp2 (fun exp2 -> k (rewrap (E_vector_access (exp1,exp2))))) | E_vector_subrange (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> n_exp_name exp3 (fun exp3 -> k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) | E_vector_update (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> n_exp_name exp3 (fun exp3 -> k (rewrap (E_vector_update (exp1,exp2,exp3)))))) | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> n_exp_name exp4 (fun exp4 -> k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) | E_vector_append (exp1,exp2) -> @@ -2359,14 +2314,14 @@ let rewrite_defs_letbind_effects = | E_list exps -> n_exp_nameL exps (fun exps -> k (rewrap (E_list exps))) - | E_cons (exp1,exp2) -> + | E_cons (exp1,exp2) -> n_exp_name exp1 (fun exp1 -> n_exp_name exp2 (fun exp2 -> k (rewrap (E_cons (exp1,exp2))))) | E_record fexps -> n_fexps fexps (fun fexps -> k (rewrap (E_record fexps))) - | E_record_update (exp1,fexps) -> + | E_record_update (exp1,fexps) -> n_exp_name exp1 (fun exp1 -> n_fexps fexps (fun fexps -> k (rewrap (E_record_update (exp1,fexps))))) @@ -2375,7 +2330,7 @@ let rewrite_defs_letbind_effects = k (rewrap (E_field (exp1,id)))) | E_case (exp1,pexps) -> let newreturn = List.exists effectful_pexp pexps in - n_exp_name exp1 (fun exp1 -> + n_exp_name exp1 (fun exp1 -> n_pexpL newreturn pexps (fun pexps -> k (rewrap (E_case (exp1,pexps))))) | E_try (exp1,pexps) -> @@ -2384,7 +2339,7 @@ let rewrite_defs_letbind_effects = n_pexpL newreturn pexps (fun pexps -> k (rewrap (E_try (exp1,pexps))))) | E_let (lb,body) -> - n_lb lb (fun lb -> + n_lb lb (fun lb -> rewrap (E_let (lb,n_exp body k))) | E_sizeof nexp -> k (rewrap (E_sizeof nexp)) @@ -2406,18 +2361,20 @@ let rewrite_defs_letbind_effects = k (rewrap (E_internal_cast (annot',exp')))) | E_internal_exp _ -> k exp | E_internal_exp_user _ -> k exp - | E_internal_let (lexp,exp1,exp2) -> + | E_var (lexp,exp1,exp2) -> n_lexp lexp (fun lexp -> n_exp exp1 (fun exp1 -> - rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) + rewrap (E_var (lexp,exp1,n_exp exp2 k)))) | E_internal_return exp1 -> n_exp_name exp1 (fun exp1 -> k (rewrap (E_internal_return exp1))) + | E_internal_value v -> + k (rewrap (E_internal_value v)) | E_comment str -> - k (rewrap (E_comment str)) + k (rewrap (E_comment str)) | E_comment_struc exp' -> n_exp exp' (fun exp' -> - k (rewrap (E_comment_struc exp'))) + k (rewrap (E_comment_struc exp'))) | E_return exp' -> n_exp_name exp' (fun exp' -> k (rewrap (E_return exp'))) @@ -2487,7 +2444,7 @@ let rewrite_defs_internal_lets = (P_id id, annot) | LEXP_aux (LEXP_cast (typ, id), annot) -> (P_typ (typ, P_aux (P_id id, annot)), annot) - | _ -> failwith "E_internal_let with unexpected lexp" in + | _ -> failwith "E_var with unexpected lexp" in if effectful exp1 then E_internal_plet (P_aux (paux, annot), exp1, exp2) else @@ -2595,9 +2552,9 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | E_let (lb,exp) -> let exp = add_vars overwrite exp vars in E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) - | E_internal_let (lexp,exp1,exp2) -> + | E_var (lexp,exp1,exp2) -> let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) + E_aux (E_var (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) | E_internal_plet (pat,exp1,exp2) -> let exp2 = add_vars overwrite exp2 vars in E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) @@ -2791,8 +2748,8 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) - | E_internal_let (lexp,v,body) -> - (* Rewrite E_internal_let into E_let and call recursively *) + | E_var (lexp,v,body) -> + (* Rewrite E_var into E_let and call recursively *) let paux, typ = match lexp with | LEXP_aux (LEXP_id id, _) -> P_id id, typ_of v @@ -2800,7 +2757,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = P_typ (typ, annot_pat (P_id id) l env (typ_of v)), typ | _ -> raise (Reporting_basic.err_unreachable l - "E_internal_let with a lexp that is not a variable") in + "E_var with a lexp that is not a variable") in let lb = annot_letbind (paux, v) l env typ in let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in rewrite_var_updates exp @@ -3001,6 +2958,15 @@ let rewrite_defs_ocaml = [ (* ("separate_numbs", rewrite_defs_separate_numbs) *) ] +let rewrite_defs_interpreter = [ + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ] + let rewrite_defs_sil = [ ("top_sort_defs", top_sort_defs); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); diff --git a/src/rewrites.mli b/src/rewrites.mli index ce24a4c4..8fceadff 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -57,6 +57,9 @@ val rewrite_undefined : bool -> tannot defs -> tannot defs (* Perform rewrites to exclude AST nodes not supported for ocaml out*) val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list +(* Perform rewrites to exclude AST nodes not supported for interpreter *) +val rewrite_defs_interpreter : (string * (tannot defs -> tannot defs)) list + (* Perform rewrites to exclude AST nodes not supported for lem out*) val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list diff --git a/src/sail.ml b/src/sail.ml index c622b8ee..a5d1de67 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -52,6 +52,7 @@ open Process_file let lib = ref ([] : string list) let opt_file_out : string option ref = ref None +let opt_interactive = ref false let opt_print_version = ref false let opt_print_initial_env = ref false let opt_print_verbose = ref false @@ -59,7 +60,6 @@ let opt_print_lem_ast = ref false let opt_print_lem = ref false let opt_print_sil = ref false let opt_print_ocaml = ref false -let opt_convert = ref false let opt_memo_z3 = ref false let opt_sanity = ref false let opt_libs_lem = ref ([]:string list) @@ -71,6 +71,9 @@ let options = Arg.align ([ ( "-o", Arg.String (fun f -> opt_file_out := Some f), "<prefix> select output filename prefix"); + ( "-i", + Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen], + " start interactive interpreter"); ( "-ocaml", Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen], " output an OCaml translated version of the input"); @@ -114,12 +117,6 @@ let options = Arg.align ([ ( "-no_effects", Arg.Set Type_check.opt_no_effects, " (experimental) turn off effect checking"); - ( "-new_parser", - Arg.Set Process_file.opt_new_parser, - " (experimental) use new parser"); - ( "-convert", - Arg.Set opt_convert, - " (experimental) convert sail to new syntax for use with -new_parser"); ( "-just_check", Arg.Set opt_just_check, " (experimental) terminate immediately after typechecking"); @@ -175,6 +172,8 @@ let _ = opt_file_arguments := (!opt_file_arguments) @ [s]) usage_msg +let interactive_ast = ref (Ast.Defs []) +let interactive_env = ref Type_check.initial_env let main() = if !opt_print_version @@ -188,10 +187,6 @@ let main() = -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in let ast = convert_ast Ast_util.inc_ord ast in - if !opt_convert - then (Pretty_print_sail2.pp_defs stdout ast; exit 0) - else (); - let (ast, type_envs) = check_ast ast in let (ast, type_envs) = @@ -214,13 +209,17 @@ let main() = (*let _ = Printf.eprintf "Type checked, next to pretty print" in*) begin + (if !(opt_interactive) + then + (interactive_ast := Process_file.rewrite_ast_interpreter ast; interactive_env := type_envs) + else ()); (if !(opt_sanity) then let _ = rewrite_ast_check ast in () else ()); (if !(opt_print_verbose) - then ((Pretty_print.pp_defs stdout) ast) + then ((Pretty_print_sail.pp_defs stdout) ast) else ()); (if !(opt_print_lem_ast) then output "" Lem_ast_out [out_name,ast] @@ -228,7 +227,7 @@ let main() = (if !(opt_print_sil) then let ast = rewrite_ast_sil ast in - Pretty_print_sail2.pp_defs stdout ast + Pretty_print_sail.pp_defs stdout ast else ()); (if !(opt_print_ocaml) then diff --git a/src/sail_lib.ml b/src/sail_lib.ml new file mode 100644 index 00000000..849aa16c --- /dev/null +++ b/src/sail_lib.ml @@ -0,0 +1,479 @@ +module Big_int = Nat_big_num + +type 'a return = { return : 'b . 'a -> 'b } + +let opt_trace = ref false + +let trace_depth = ref 0 +let random = ref false + +let sail_call (type t) (f : _ -> t) = + let module M = + struct exception Return of t end + in + let return = { return = (fun x -> raise (M.Return x)) } in + try + f return + with M.Return x -> x + +let trace str = + if !opt_trace + then + begin + if !trace_depth < 0 then trace_depth := 0 else (); + prerr_endline (String.make (!trace_depth * 2) ' ' ^ str) + end + else () + +let trace_write name str = + trace ("Write: " ^ name ^ " " ^ str) + +let trace_read name str = + trace ("Read: " ^ name ^ " " ^ str) + +let sail_trace_call (type t) (name : string) (in_string : string) (string_of_out : t -> string) (f : _ -> t) = + let module M = + struct exception Return of t end + in + let return = { return = (fun x -> raise (M.Return x)) } in + trace ("Call: " ^ name ^ " " ^ in_string); + incr trace_depth; + let result = try f return with M.Return x -> x in + decr trace_depth; + trace ("Return: " ^ string_of_out result); + result + +let trace_call str = + trace str; incr trace_depth + +type bit = B0 | B1 + +let and_bit = function + | B1, B1 -> B1 + | _, _ -> B0 + +let or_bit = function + | B0, B0 -> B0 + | _, _ -> B1 + +let xor_bit = function + | B1, B0 -> B1 + | B0, B1 -> B1 + | _, _ -> B0 + +let and_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> and_bit (x, y)) xs ys + +let and_bool (b1, b2) = b1 && b2 + +let or_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> or_bit (x, y)) xs ys + +let or_bool (b1, b2) = b1 || b2 + +let xor_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> xor_bit (x, y)) xs ys + +let xor_bool (b1, b2) = (b1 || b2) && (b1 != b2) + +let undefined_bit () = + if !random + then (if Random.bool () then B0 else B1) + else B0 + +let undefined_bool () = + if !random then Random.bool () else false + +let rec undefined_vector (len, item) = + if Big_int.equal len Big_int.zero + then [] + else item :: undefined_vector (Big_int.sub len (Big_int.of_int 1), item) + +let undefined_string () = "" + +let undefined_unit () = () + +let undefined_int () = + if !random then Big_int.of_int (Random.int 0xFFFF) else Big_int.zero + +let undefined_nat () = Big_int.zero + +let undefined_range (lo, hi) = lo + +let internal_pick list = + if !random + then List.nth list (Random.int (List.length list)) + else List.nth list 0 + +let eq_int (n, m) = Big_int.equal n m + +let rec drop n xs = + match n, xs with + | 0, xs -> xs + | n, [] -> [] + | n, (x :: xs) -> drop (n -1) xs + +let rec take n xs = + match n, xs with + | 0, xs -> [] + | n, (x :: xs) -> x :: take (n - 1) xs + | n, [] -> [] + +let subrange (list, n, m) = + let n = Big_int.to_int n in + let m = Big_int.to_int m in + List.rev (take (n - (m - 1)) (drop m (List.rev list))) + +let slice (list, n, m) = + let n = Big_int.to_int n in + let m = Big_int.to_int m in + List.rev (take m (drop n (List.rev list))) + +let eq_list (xs, ys) = List.for_all2 (fun x y -> x = y) xs ys + +let access (xs, n) = List.nth (List.rev xs) (Big_int.to_int n) + +let append (xs, ys) = xs @ ys + +let update (xs, n, x) = + let n = (List.length xs - Big_int.to_int n) - 1 in + take n xs @ [x] @ drop (n + 1) xs + +let update_subrange (xs, n, m, ys) = + let rec aux xs o = function + | [] -> xs + | (y :: ys) -> aux (update (xs, o, y)) (Big_int.sub o (Big_int.of_int 1)) ys + in + aux xs n ys + + +let length xs = Big_int.of_int (List.length xs) + +let big_int_of_bit = function + | B0 -> Big_int.zero + | B1 -> (Big_int.of_int 1) + +let uint xs = + let uint_bit x (n, pos) = + Big_int.add n (Big_int.mul (Big_int.pow_int_positive 2 pos) (big_int_of_bit x)), pos + 1 + in + fst (List.fold_right uint_bit xs (Big_int.zero, 0)) + +let sint = function + | [] -> Big_int.zero + | [msb] -> Big_int.negate (big_int_of_bit msb) + | msb :: xs -> + let msb_pos = List.length xs in + let complement = + Big_int.negate (Big_int.mul (Big_int.pow_int_positive 2 msb_pos) (big_int_of_bit msb)) + in + Big_int.add complement (uint xs) + +let add (x, y) = Big_int.add x y +let sub (x, y) = Big_int.sub x y +let mult (x, y) = Big_int.mul x y +let quotient (x, y) = Big_int.div x y +let modulus (x, y) = Big_int.modulus x y + +let add_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B1, B0 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B1 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B1 + | B1, B0, B1 -> B0, B1 + | B1, B1, B1 -> B1, B1 + +let sub_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B0, B1 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B0 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B0 + | B1, B0, B1 -> B1, B1 + | B1, B1, B1 -> B1, B0 + +let not_bit = function + | B0 -> B1 + | B1 -> B0 + +let not_vec xs = List.map not_bit xs + +let add_vec_carry (xs, ys) = + assert (List.length xs = List.length ys); + let (carry, result) = + List.fold_right2 (fun x y (c, result) -> let (z, c) = add_bit_with_carry (x, y, c) in (c, z :: result)) xs ys (B0, []) + in + carry, result + +let add_vec (xs, ys) = snd (add_vec_carry (xs, ys)) + +let rec replicate_bits (bits, n) = + if Big_int.less_equal n Big_int.zero + then [] + else bits @ replicate_bits (bits, Big_int.sub n (Big_int.of_int 1)) + +let identity x = x + +let rec bits_of_big_int bit n = + if not (Big_int.equal bit Big_int.zero) + then + begin + if Big_int.greater (Big_int.div n bit) Big_int.zero + then B1 :: bits_of_big_int (Big_int.div bit (Big_int.of_int 2)) (Big_int.sub n bit) + else B0 :: bits_of_big_int (Big_int.div bit (Big_int.of_int 2)) n + end + else [] + +let add_vec_int (v, n) = + let n_bits = bits_of_big_int (Big_int.pow_int_positive 2 (List.length v - 1)) n in + add_vec(v, n_bits) + +let sub_vec (xs, ys) = add_vec (xs, add_vec_int (not_vec ys, (Big_int.of_int 1))) + +let sub_vec_int (v, n) = + let n_bits = bits_of_big_int (Big_int.pow_int_positive 2 (List.length v - 1)) n in + sub_vec(v, n_bits) + +let get_slice_int (n, m, o) = + let bits = bits_of_big_int (Big_int.pow_int_positive 2 (Big_int.add n o |> Big_int.to_int)) (Big_int.abs m) in + let bits = + if Big_int.less m Big_int.zero + then sub_vec (List.map (fun _ -> B0) bits, bits) + else bits + in + let slice = List.rev (take (Big_int.to_int n) (drop (Big_int.to_int o) (List.rev bits))) in + assert (Big_int.equal (Big_int.of_int (List.length slice)) n); + slice + +let hex_char = function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + +let list_of_string s = + let rec aux i acc = + if i < 0 then acc + else aux (i-1) (s.[i] :: acc) + in aux (String.length s - 1) [] + +let bits_of_string str = + List.concat (List.map hex_char (list_of_string str)) + +let concat_str (str1, str2) = str1 ^ str2 + +let rec break n = function + | [] -> [] + | (_ :: _ as xs) -> [take n xs] @ break n (drop n xs) + +let string_of_bit = function + | B0 -> "0" + | B1 -> "1" + +let string_of_hex = function + | [B0; B0; B0; B0] -> "0" + | [B0; B0; B0; B1] -> "1" + | [B0; B0; B1; B0] -> "2" + | [B0; B0; B1; B1] -> "3" + | [B0; B1; B0; B0] -> "4" + | [B0; B1; B0; B1] -> "5" + | [B0; B1; B1; B0] -> "6" + | [B0; B1; B1; B1] -> "7" + | [B1; B0; B0; B0] -> "8" + | [B1; B0; B0; B1] -> "9" + | [B1; B0; B1; B0] -> "A" + | [B1; B0; B1; B1] -> "B" + | [B1; B1; B0; B0] -> "C" + | [B1; B1; B0; B1] -> "D" + | [B1; B1; B1; B0] -> "E" + | [B1; B1; B1; B1] -> "F" + | _ -> failwith "Cannot convert binary sequence to hex" + +let string_of_bits bits = + if List.length bits mod 4 == 0 + then "0x" ^ String.concat "" (List.map string_of_hex (break 4 bits)) + else "0b" ^ String.concat "" (List.map string_of_bit bits) + +let hex_slice (str, n, m) = + let bits = List.concat (List.map hex_char (list_of_string (String.sub str 2 (String.length str - 2)))) in + let padding = replicate_bits([B0], n) in + let bits = padding @ bits in + let slice = List.rev (take (Big_int.to_int n) (drop (Big_int.to_int m) (List.rev bits))) in + slice + +let putchar n = + print_char (char_of_int (Big_int.to_int n)); + flush stdout + +let rec bits_of_int bit n = + if bit <> 0 + then + begin + if n / bit > 0 + then B1 :: bits_of_int (bit / 2) (n - bit) + else B0 :: bits_of_int (bit / 2) n + end + else [] + +let byte_of_int n = bits_of_int 128 n + +module BigIntHash = + struct + type t = Big_int.num + let equal i j = Big_int.equal i j + let hash i = Hashtbl.hash i + end + +module RAM = Hashtbl.Make(BigIntHash) + +let ram : int RAM.t = RAM.create 256 + +let write_ram' (addr_size, data_size, hex_ram, addr, data) = + let data = List.map (fun byte -> Big_int.to_int (uint byte)) (break 8 data) in + let rec write_byte i byte = + trace (Printf.sprintf "Store: %s 0x%02X" (Big_int.to_string (Big_int.add addr (Big_int.of_int i))) byte); + RAM.add ram (Big_int.add addr (Big_int.of_int i)) byte + in + List.iteri write_byte (List.rev data) + +let write_ram (addr_size, data_size, hex_ram, addr, data) = + write_ram' (addr_size, data_size, hex_ram, uint addr, data) + +let wram addr byte = + RAM.add ram addr byte + +let read_ram (addr_size, data_size, hex_ram, addr) = + let addr = uint addr in + let rec read_byte i = + if Big_int.equal i Big_int.zero + then [] + else + begin + let loc = Big_int.sub (Big_int.add addr i) (Big_int.of_int 1) in + let byte = try RAM.find ram loc with Not_found -> 0 in + trace (Printf.sprintf "Load: %s 0x%02X" (Big_int.to_string loc) byte); + byte_of_int byte @ read_byte (Big_int.sub i (Big_int.of_int 1)) + end + in + read_byte data_size + +let rec reverse_endianness bits = + if List.length bits <= 8 then bits else + reverse_endianness (drop 8 bits) @ (take 8 bits) + +(* FIXME: Casts can't be externed *) +let zcast_unit_vec x = [x] + +let shl_int (n, m) = Big_int.shift_left n (Big_int.to_int m) +let shr_int (n, m) = Big_int.shift_right n (Big_int.to_int m) + +let debug (str1, n, str2, v) = prerr_endline (str1 ^ Big_int.to_string n ^ str2 ^ string_of_bits v) + +let eq_string (str1, str2) = String.compare str1 str2 == 0 + +let lt_int (x, y) = Big_int.less x y + +let set_slice (out_len, slice_len, out, n, slice) = + let out = update_subrange(out, Big_int.add n (Big_int.of_int (List.length slice - 1)), n, slice) in + assert (List.length out = Big_int.to_int out_len); + out + +let set_slice_int (_, _, _, _) = assert false + +(* +let eq_real (x, y) = Num.eq_num x y +let lt_real (x, y) = Num.lt_num x y +let gt_real (x, y) = Num.gt_num x y +let lteq_real (x, y) = Num.le_num x y +let gteq_real (x, y) = Num.ge_num x y + +let round_down x = Num.big_int_of_num (Num.floor_num x) +let round_up x = Num.big_int_of_num (Num.ceiling_num x) +let quotient_real (x, y) = Num.div_num x y +let mult_real (x, y) = Num.mult_num x y +let real_power (x, y) = Num.power_num x (Num.num_of_big_int y) +let add_real (x, y) = Num.add_num x y +let sub_real (x, y) = Num.sub_num x y + +let abs_real x = Num.abs_num x + *) + +let lt (x, y) = Big_int.less x y +let gt (x, y) = Big_int.greater x y +let lteq (x, y) = Big_int.less_equal x y +let gteq (x, y) = Big_int.greater_equal x y + +let pow2 x = Big_int.pow_int x 2 + +let max_int (x, y) = Big_int.max x y +let min_int (x, y) = Big_int.min x y +let abs_int x = Big_int.abs x + +(* +let undefined_real () = Num.num_of_int 0 + +let real_of_string str = + try + let point = String.index str '.' in + let whole = Num.num_of_string (String.sub str 0 point) in + let frac_str = String.sub str (point + 1) (String.length str - (point + 1)) in + let frac = Num.div_num (Num.num_of_string frac_str) (Num.num_of_big_int (Big_int.pow_int_positive 10 (String.length frac_str))) in + Num.add_num whole frac + with + | Not_found -> Num.num_of_string str + +(* Not a very good sqrt implementation *) +let sqrt_real x = real_of_string (string_of_float (sqrt (Num.float_of_num x))) + *) + +let print_int (str, x) = + print_endline (str ^ Big_int.to_string x) + +let print_bits (str, xs) = + print_endline (str ^ string_of_bits xs) + +let reg_deref r = !r + +let string_of_zbit = function + | B0 -> "0" + | B1 -> "1" +let string_of_znat n = Big_int.to_string n +let string_of_zint n = Big_int.to_string n +let string_of_zunit () = "()" +let string_of_zbool = function + | true -> "true" + | false -> "false" +(* let string_of_zreal r = Num.string_of_num r *) +let string_of_zstring str = "\"" ^ String.escaped str ^ "\"" + +let rec string_of_list sep string_of = function + | [] -> "" + | [x] -> string_of x + | x::ls -> (string_of x) ^ sep ^ (string_of_list sep string_of ls) + +let zero_extend (vec, n) = + let m = Big_int.to_int n in + if m <= List.length vec + then take m vec + else replicate_bits ([B0], Big_int.of_int (m - List.length vec)) @ vec diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index b35bc48f..23ce6663 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -101,64 +101,64 @@ let rec default_order (Defs defs) = | (Nneg n, Nconst max) | (Nneg n, N2n(_, Some max))-> (match n.nexp with | Nconst abs_min | N2n(_,Some abs_min) -> - (minus_big_int abs_min), max + (Big_int.negate abs_min), max | _ -> assert false (*Put a better error message here*)) | (Nconst min,Nneg n) | (N2n(_, Some min), Nneg n) -> (match n.nexp with | Nconst abs_max | N2n(_,Some abs_max) -> - min, (minus_big_int abs_max) + min, (Big_int.negate abs_max) | _ -> assert false (*Put a better error message here*)) | (Nneg nmin, Nneg nmax) -> ((match nmin.nexp with - | Nconst abs_min | N2n(_,Some abs_min) -> (minus_big_int abs_min) + | Nconst abs_min | N2n(_,Some abs_min) -> (Big_int.negate abs_min) | _ -> assert false (*Put a better error message here*)), (match nmax.nexp with - | Nconst abs_max | N2n(_,Some abs_max) -> (minus_big_int abs_max) + | Nconst abs_max | N2n(_,Some abs_max) -> (Big_int.negate abs_max) | _ -> assert false (*Put a better error message here*))) | _ -> assert false - in le_big_int min candidate && le_big_int candidate max + in Big_int.less_equal min candidate && Big_int.less_equal candidate max | _ -> assert false (*Rmove me when switch to zarith*) let rec power_big_int b n = - if eq_big_int n zero_big_int - then unit_big_int - else mult_big_int b (power_big_int b (sub_big_int n unit_big_int)) + if Big_int.equal n Big_int.zero + then (Big_int.of_int 1) + else Big_int.mul b (power_big_int b (Big_int.sub n (Big_int.of_int 1))) let unpower_of_2 b = - let two = big_int_of_int 2 in - let four = big_int_of_int 4 in - let eight = big_int_of_int 8 in - let sixteen = big_int_of_int 16 in - let thirty_two = big_int_of_int 32 in - let sixty_four = big_int_of_int 64 in - let onetwentyeight = big_int_of_int 128 in - let twofiftysix = big_int_of_int 256 in - let fivetwelve = big_int_of_int 512 in - let oneotwentyfour = big_int_of_int 1024 in - let to_the_sixteen = big_int_of_int 65536 in - let to_the_thirtytwo = big_int_of_string "4294967296" in - let to_the_sixtyfour = big_int_of_string "18446744073709551616" in - let ck i = eq_big_int b i in - if ck unit_big_int then zero_big_int - else if ck two then unit_big_int + let two = Big_int.of_int 2 in + let four = Big_int.of_int 4 in + let eight = Big_int.of_int 8 in + let sixteen = Big_int.of_int 16 in + let thirty_two = Big_int.of_int 32 in + let sixty_four = Big_int.of_int 64 in + let onetwentyeight = Big_int.of_int 128 in + let twofiftysix = Big_int.of_int 256 in + let fivetwelve = Big_int.of_int 512 in + let oneotwentyfour = Big_int.of_int 1024 in + let to_the_sixteen = Big_int.of_int 65536 in + let to_the_thirtytwo = Big_int.of_string "4294967296" in + let to_the_sixtyfour = Big_int.of_string "18446744073709551616" in + let ck i = Big_int.equal b i in + if ck (Big_int.of_int 1) then Big_int.zero + else if ck two then (Big_int.of_int 1) else if ck four then two - else if ck eight then big_int_of_int 3 + else if ck eight then Big_int.of_int 3 else if ck sixteen then four - else if ck thirty_two then big_int_of_int 5 - else if ck sixty_four then big_int_of_int 6 - else if ck onetwentyeight then big_int_of_int 7 + else if ck thirty_two then Big_int.of_int 5 + else if ck sixty_four then Big_int.of_int 6 + else if ck onetwentyeight then Big_int.of_int 7 else if ck twofiftysix then eight - else if ck fivetwelve then big_int_of_int 9 - else if ck oneotwentyfour then big_int_of_int 10 + else if ck fivetwelve then Big_int.of_int 9 + else if ck oneotwentyfour then Big_int.of_int 10 else if ck to_the_sixteen then sixteen else if ck to_the_thirtytwo then thirty_two else if ck to_the_sixtyfour then sixty_four else let rec unpower b power = - if eq_big_int b unit_big_int + if Big_int.equal b (Big_int.of_int 1) then power - else (unpower (div_big_int b two) (succ_big_int power)) in - unpower b zero_big_int + else (unpower (Big_int.div b two) (Big_int.succ power)) in + unpower b Big_int.zero let is_within_range candidate range constraints = let candidate_actual = match candidate.t with @@ -183,7 +183,7 @@ let is_within_range candidate range constraints = | Tapp("vector", [_; TA_nexp size ; _; _]) -> (match size.nexp with | Nconst i | N2n(_, Some i) -> - if check_in_range (power_big_int (big_int_of_int 2) i) range + if check_in_range (power_big_int (Big_int.of_int 2) i) range then Yes else No | _ -> Maybe) @@ -342,7 +342,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. | E_let(lebind,e) -> let b,u,s = fv_of_let consider_var bound used set lebind in fv_of_exp consider_var b u s e - | E_internal_let (lexp, exp1, exp2) -> + | E_var (lexp, exp1, exp2) -> let b,u,s = fv_of_lexp consider_var bound used set lexp in let _,used,set = fv_of_exp consider_var bound used set exp1 in fv_of_exp consider_var b used set exp2 @@ -367,13 +367,13 @@ and fv_of_pes consider_var bound used set pes = let bound_g,us_g,set_g = fv_of_exp consider_var bound_p us_p set g in let bound_e,us_e,set_e = fv_of_exp consider_var bound_g us_g set_g e in fv_of_pes consider_var bound us_e set_e pes - + and fv_of_let consider_var bound used set (LB_aux(lebind,_)) = match lebind with | LB_val(pat,exp) -> let bound_p, us_p = pat_bindings consider_var bound used pat in let _,us_e,set_e = fv_of_exp consider_var bound used set exp in bound_p,Nameset.union us_p us_e,set_e - + and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = match lexp with | LEXP_id id -> @@ -382,6 +382,8 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = if Nameset.mem i bound then bound, used, Nameset.add i set else Nameset.add i bound, Nameset.add i used, set + | LEXP_deref exp -> + fv_of_exp consider_var bound used set exp | LEXP_cast(typ,id) -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in let i = string_of_id id in @@ -432,8 +434,8 @@ let fv_of_type_def consider_var (TD_aux(t,_)) = match t with typ_variants consider_var bindings tunions | TD_enum(id,_,ids,_) -> Nameset.of_list (List.map string_of_id (id::ids)),mt - | TD_register(id,n1,n2,_) -> - init_env (string_of_id id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 + | TD_bitfield(id,typ,_) -> + init_env (string_of_id id), Nameset.empty (* fv_of_typ consider_var mt typ *) let fv_of_tannot_opt consider_var (Typ_annot_opt_aux (t,_)) = match t with @@ -577,6 +579,10 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_fixity _ -> mt,mt | DEF_overload (id,ids) -> init_env (string_of_id id), List.fold_left (fun ns id -> Nameset.add (string_of_id id) ns) mt ids | DEF_default def -> mt,mt + | DEF_internal_mutrec fdefs -> + let fvs = List.map (fv_of_fun consider_var) fdefs in + List.fold_left Nameset.union Nameset.empty (List.map fst fvs), + List.fold_left Nameset.union Nameset.empty (List.map snd fvs) | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef | DEF_reg_dec rdec -> fv_of_rd consider_var rdec | DEF_comm _ -> mt,mt @@ -621,7 +627,7 @@ let merge_mutrecs defs = | DEF_fundef fundef -> fundef :: fundefs | DEF_internal_mutrec fundefs' -> fundefs' @ fundefs | _ -> - (* let _ = Pretty_print_sail2.pp_defs stderr (Defs [def]) in *) + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) raise (Reporting_basic.err_unreachable (def_loc def) "Trying to merge non-function definition with mutually recursive functions") in (* let _ = Printf.eprintf " - Merging %s (using %s)\n" (set_to_string binds') (set_to_string uses') in *) diff --git a/src/type_check.ml b/src/type_check.ml index a4b4bb39..d705c190 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -51,7 +51,7 @@ open Ast open Util open Ast_util -open Big_int +module Big_int = Nat_big_num (* opt_tc_debug controls the verbosity of the type checker. 0 is silent, 1 prints a tree of the type derivation and 2 is like 1 but @@ -76,7 +76,7 @@ type type_error = (* First parameter is the error that caused us to start doing type coercions, the second is the errors encountered by all possible coercions *) - | Err_no_casts of type_error * type_error list + | Err_no_casts of unit exp * type_error * type_error list | Err_no_overloading of id * (id * type_error) list | Err_unresolved_quants of id * quant_item list | Err_subtype of typ * typ * n_constraint list @@ -86,11 +86,13 @@ type type_error = let pp_type_error err = let open PPrint in let rec pp_err = function - | Err_no_casts (trigger, []) -> - (string "Tried performing type coercion because" ^//^ pp_err trigger) - ^/^ string "No possible coercions" - | Err_no_casts (trigger, errs) -> - (string "Tried performing type coerction because" ^//^ pp_err trigger) + | Err_no_casts (exp, trigger, []) -> + (string "Tried performing type coercion on" ^//^ Pretty_print_sail.doc_exp exp) + ^/^ (string "Failed because" ^//^ pp_err trigger) + ^/^ string "There were no possible casts" + | Err_no_casts (exp, trigger, errs) -> + (string "Tried performing type coercion on" ^//^ Pretty_print_sail.doc_exp exp) + ^/^ string "Failed because" ^//^ pp_err trigger | Err_no_overloading (id, errs) -> string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^ group (separate_map hardline (fun (id, err) -> string (string_of_id id) ^^ colon ^^ space ^^ pp_err err) errs) @@ -106,6 +108,9 @@ let pp_type_error err = ^//^ string (string_of_list ", " string_of_n_constraint constrs) | Err_no_num_ident id -> string "No num identifier" ^^ space ^^ string (string_of_id id) + | Err_unresolved_quants (id, quants) -> + string "Could not resolve quantifiers for" ^^ space ^^ string (string_of_id id) + ^//^ group (separate_map hardline (fun quant -> string (string_of_quant_item quant)) quants) | Err_other str -> string str in pp_err err @@ -293,7 +298,8 @@ module Env : sig val is_union_constructor : id -> t -> bool val add_record : id -> typquant -> (typ * id) list -> t -> t val is_record : id -> t -> bool - val get_accessor : id -> id -> t -> typquant * typ + val get_accessor_fn : id -> id -> t -> typquant * typ + val get_accessor : id -> id -> t -> typquant * typ * typ * effect 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 @@ -303,9 +309,6 @@ module Env : sig val is_register : id -> t -> bool val get_register : id -> t -> typ val add_register : id -> typ -> t -> t - val add_regtyp : id -> big_int -> big_int -> (index_range * id) list -> t -> t - val is_regtyp : id -> t -> bool - val get_regtyp : id -> t -> big_int * big_int * (index_range * id) list val is_mutable : id -> t -> bool val get_constraints : t -> n_constraint list val add_constraint : n_constraint -> t -> t @@ -360,7 +363,6 @@ end = struct locals : (mut * typ) Bindings.t; union_ids : (typquant * typ) Bindings.t; registers : typ Bindings.t; - regtyps : (big_int * big_int * (index_range * id) list) Bindings.t; variants : (typquant * type_union list) Bindings.t; typ_vars : base_kind_aux KBindings.t; typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; @@ -386,7 +388,6 @@ end = struct locals = Bindings.empty; union_ids = Bindings.empty; registers = Bindings.empty; - regtyps = Bindings.empty; variants = Bindings.empty; typ_vars = KBindings.empty; typ_synonyms = Bindings.empty; @@ -424,8 +425,9 @@ end = struct List.fold_left (fun m (name, kinds) -> Bindings.add (mk_id name) (kinds_typq kinds) m) Bindings.empty [ ("range", [BK_nat; BK_nat]); ("atom", [BK_nat]); - ("vector", [BK_nat; BK_nat; BK_order; BK_type]); + ("vector", [BK_nat; BK_order; BK_type]); ("register", [BK_type]); + ("ref", [BK_type]); ("bit", []); ("unit", []); ("int", []); @@ -441,7 +443,6 @@ end = struct Bindings.mem id env.typ_synonyms || Bindings.mem id env.variants || Bindings.mem id env.records - || Bindings.mem id env.regtyps || Bindings.mem id env.enums || Bindings.mem id builtin_typs @@ -451,7 +452,8 @@ end = struct let add_overloads id ids env = typ_print ("Adding overloads for " ^ string_of_id id ^ " [" ^ string_of_list ", " string_of_id ids ^ "]"); - { env with overloads = Bindings.add id ids env.overloads } + let existing = try Bindings.find id env.overloads with Not_found -> [] in + { env with overloads = Bindings.add id (existing @ ids) env.overloads } let add_smt_op id str env = typ_print ("Adding smt binding " ^ string_of_id id ^ " to " ^ str); @@ -472,7 +474,7 @@ end = struct fst (Bindings.find id env.variants) else if Bindings.mem id env.records then fst (Bindings.find id env.records) - else if Bindings.mem id env.enums || Bindings.mem id env.regtyps then + else if Bindings.mem id env.enums then mk_typquant [] else if Bindings.mem id env.typ_synonyms then typ_error (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id) @@ -490,8 +492,8 @@ end = struct | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> subst_args kopts args | [], [] -> ncs - | _, Typ_arg_aux (_, l) :: _ -> typ_error l "ERROR 1" - | _, _ -> typ_error Parse_ast.Unknown "ERROR 2" + | _, Typ_arg_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) + | _, _ -> typ_error Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) in let ncs = subst_args kopts args in if List.for_all (env.prove env) ncs @@ -685,12 +687,18 @@ end = struct accessors = List.fold_left fold_accessors env.accessors fields } end - let get_accessor rec_id id env = + let get_accessor_fn rec_id id env = let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in try freshen_bind (Bindings.find (field_name rec_id id) env.accessors) with | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id)) + let get_accessor rec_id id env = + match get_accessor_fn rec_id id env with + | (typq, Typ_aux (Typ_fn (rec_typ, field_typ, effect), _)) -> + (typq, rec_typ, field_typ, effect) + | _ -> typ_error (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id)) + let is_mutable id env = try let (mut, _) = Bindings.find id env.locals in @@ -698,7 +706,7 @@ end = struct | Mutable -> true | Immutable -> false with - | Not_found -> typ_error (id_loc id) ("No local binding found for " ^ string_of_id id) + | Not_found -> false let string_of_mtyp (mut, typ) = match mut with | Immutable -> string_of_typ typ @@ -758,29 +766,6 @@ end = struct let get_casts env = env.casts - let check_index_range cmp f t (BF_aux (ir, l)) = - match ir with - | BF_single n -> - if cmp f n && cmp n t - then n - else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_big_int [f; n; t]) - | BF_range (n1, n2) -> - if cmp f n1 && cmp n1 n2 && cmp n2 t - then n2 - else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_big_int [f; n1; n2; t]) - | BF_concat _ -> typ_error l "Index range concatenation currently unsupported" - - let rec check_index_ranges ids cmp base top = function - | [] -> () - | ((range, id) :: ranges) -> - if IdSet.mem id ids - then typ_error (id_loc id) ("Duplicate id " ^ string_of_id id ^ " in register typedef") - else - begin - let base' = check_index_range cmp base top range in - check_index_ranges (IdSet.add id ids) cmp base' top ranges - end - let add_register id typ env = wf_typ env typ; if Bindings.mem id env.registers @@ -791,24 +776,6 @@ end = struct { env with registers = Bindings.add id typ env.registers } end - let add_regtyp id base top ranges env = - if Bindings.mem id env.regtyps - then typ_error (id_loc id) ("Register type " ^ string_of_id id ^ " is already bound") - else - begin - typ_print ("Adding register type " ^ string_of_id id); - if gt_big_int base top - then check_index_ranges IdSet.empty gt_big_int (add_big_int base unit_big_int) (sub_big_int top unit_big_int) ranges - else check_index_ranges IdSet.empty lt_big_int (sub_big_int base unit_big_int) (add_big_int top unit_big_int) ranges; - { env with regtyps = Bindings.add id (base, top, ranges) env.regtyps } - end - - let is_regtyp id env = Bindings.mem id env.regtyps - - let get_regtyp id env = - try Bindings.find id env.regtyps with - | Not_found -> typ_error (id_loc id) (string_of_id id ^ " is not a register type") - let get_locals env = env.locals let lookup_id id env = @@ -913,16 +880,11 @@ end = struct rewrap (Typ_fn (aux t1, aux t2, eff)) | Typ_tup ts -> rewrap (Typ_tup (List.map aux ts)) - | Typ_app (register, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) - when string_of_id register = "register" -> + | Typ_app (r, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) + when string_of_id r = "register" || string_of_id r = "ref" -> aux rtyp | Typ_app (id, targs) -> rewrap (Typ_app (id, List.map aux_arg targs)) - | Typ_id id when is_regtyp id env -> - let base, top, ranges = get_regtyp id env in - let len = succ_big_int (abs_big_int (sub_big_int top base)) in - vector_typ (nconstant base) (nconstant len) (get_default_order env) bit_typ - (* TODO registers with non-default order? non-bitvector registers? *) | t -> rewrap t and aux_arg (Typ_arg_aux (targ,a)) = let rewrap targ = Typ_arg_aux (targ,a) in @@ -953,14 +915,10 @@ let add_typquant (quant : typquant) (env : Env.t) : Env.t = (* Create vectors with the default order from the environment *) -let dvector_typ env n m typ = vector_typ n m (Env.get_default_order env) typ +let default_order_error_string = + "No default Order (if you have set a default Order, move it earlier in the specification)" -let lvector_typ env l typ = - match Env.get_default_order env with - | Ord_aux (Ord_inc, _) as ord -> - vector_typ (nint 0) l ord typ - | Ord_aux (Ord_dec, _) as ord -> - vector_typ (nminus l (nint 1)) l ord typ +let dvector_typ env n typ = vector_typ n (Env.get_default_order env) typ let ex_counter = ref 0 @@ -988,10 +946,9 @@ let exist_typ constr typ = let destruct_vector env typ = let destruct_vector' = function | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_nexp n2, _); Typ_arg_aux (Typ_arg_order o, _); Typ_arg_aux (Typ_arg_typ vtyp, _)] - ), _) when string_of_id id = "vector" -> Some (n1, n2, o, vtyp) + ), _) when string_of_id id = "vector" -> Some (n1, o, vtyp) | typ -> None in destruct_vector' (Env.expand_synonyms env typ) @@ -1124,7 +1081,7 @@ let rec nexp_constraint env var_of (Nexp_aux (nexp, l)) = | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint env var_of nexp) - | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint env var_of nexp) + | Nexp_neg nexp -> Constraint.sub (Constraint.constant (Big_int.of_int 0)) (nexp_constraint env var_of nexp) | Nexp_app (id, nexps) -> Constraint.app (Env.get_smt_op id env) (List.map (nexp_constraint env var_of) nexps) let rec nc_constraint env var_of (NC_aux (nc, l)) = @@ -1179,9 +1136,9 @@ let prove env (NC_aux (nc_aux, _) as nc) = | _, _ -> false in match nc_aux with - | NC_equal (nexp1, nexp2) when compare_const eq_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_le (nexp1, nexp2) when compare_const le_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_ge (nexp1, nexp2) when compare_const ge_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_equal (nexp1, nexp2) when compare_const Big_int.equal (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_le (nexp1, nexp2) when compare_const Big_int.less_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_ge (nexp1, nexp2) when compare_const Big_int.greater_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true | NC_true -> true | _ -> prove_z3 env nc @@ -1272,6 +1229,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs) | 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) 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 @@ -1282,7 +1240,7 @@ let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = match nexp1, nexp2 with | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0 | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 = 0 - | Nexp_constant c1, Nexp_constant c2 -> eq_big_int c1 c2 + | Nexp_constant c1, Nexp_constant c2 -> Big_int.equal c1 c2 | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b @@ -1334,6 +1292,7 @@ let typ_identical env typ1 typ2 = | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2 | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical' typ1 typ2 | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2 + | _, _ -> false in typ_identical' (Env.expand_synonyms env typ1) (Env.expand_synonyms env typ2) @@ -1394,8 +1353,8 @@ let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (ne | Nexp_constant c2 -> begin match n1a with - | Nexp_aux (Nexp_constant c1,_) when eq_big_int (mod_big_int c2 c1) zero_big_int -> - unify_nexps l env goals n1b (mk_nexp (Nexp_constant (div_big_int c2 c1))) + | Nexp_aux (Nexp_constant c1,_) when Big_int.equal (Big_int.modulus c2 c1) Big_int.zero -> + unify_nexps l env goals n1b (mk_nexp (Nexp_constant (Big_int.div c2 c1))) | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) end | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) @@ -1648,8 +1607,12 @@ let rec subtyp l env typ1 typ2 = when is_some (destruct_atom_kid env typ1) && is_some (destruct_atom_kid env typ2) -> let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env kids1 in let env = Env.add_constraint nc1 env in - let Some atom_kid1 = destruct_atom_kid env typ1 in - let Some atom_kid2 = destruct_atom_kid env typ2 in + + (* Guaranteed to succeed because of the guard *) + let destruct_some x = match x with Some y -> y | _ -> assert false in + let atom_kid1 = destruct_some (destruct_atom_kid env typ1) in + let atom_kid2 = destruct_some (destruct_atom_kid env typ2) in + let kids2 = List.filter (fun kid -> Kid.compare atom_kid2 kid <> 0) kids2 in let env = Env.add_typ_var atom_kid2 BK_nat env in let env = Env.add_constraint (nc_eq (nvar atom_kid1) (nvar atom_kid2)) env in @@ -1675,6 +1638,7 @@ let rec subtyp l env typ1 typ2 = let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env existential_kids in let env = List.fold_left uv_nexp_constraint env (KBindings.bindings unifiers) in Env.add_constraint enc env + | _, None -> assert false (* Cannot have existential_kids without existential_nc *) in if prove env nc then () else typ_error l ("Could not show " ^ string_of_typ typ1 ^ " is a subset of existential " ^ string_of_typ typ2) @@ -1711,24 +1675,16 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = | L_bin str -> begin match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - dvector_typ env (nint 0) (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_dec, _) -> - dvector_typ env - (nint (String.length str - 1)) - (nint (String.length str)) - (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> + dvector_typ env (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string end | L_hex str -> begin match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - dvector_typ env (nint 0) (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_dec, _) -> - dvector_typ env - (nint (String.length str * 4 - 1)) - (nint (String.length str * 4)) - (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> + dvector_typ env (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string end | L_undef -> typ_error l "Cannot infer the type of undefined" @@ -1776,10 +1732,9 @@ let rec instantiate_quants quants kid uvar = match quants with let destruct_vec_typ l env typ = let destruct_vec_typ' l = function | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_nexp n2, _); Typ_arg_aux (Typ_arg_order o, _); Typ_arg_aux (Typ_arg_typ vtyp, _)] - ), _) when string_of_id id = "vector" -> (n1, n2, o, vtyp) + ), _) when string_of_id id = "vector" -> (n1, o, vtyp) | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ) in destruct_vec_typ' l (Env.expand_synonyms env typ) @@ -1812,13 +1767,13 @@ let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with | Nexp_constant c -> Some c | Nexp_times (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_sum (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_minus (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_exp n -> - Util.option_map (power_int_positive_big_int 2) (big_int_of_nexp n) + Util.option_map (fun n -> Big_int.pow_int_positive 2 (Big_int.to_int n)) (big_int_of_nexp n) | _ -> None let destruct_atom (Typ_aux (typ_aux, _)) = @@ -1830,7 +1785,7 @@ let destruct_atom (Typ_aux (typ_aux, _)) = when string_of_id f = "range" -> begin match big_int_of_nexp nexp1, big_int_of_nexp nexp2 with - | Some c1, Some c2 -> if eq_big_int c1 c2 then Some (c1, nexp1) else None + | Some c1, Some c2 -> if Big_int.equal c1 c2 then Some (c1, nexp1) else None | _ -> None end | _ -> None @@ -1865,8 +1820,8 @@ let rec assert_constraint env (E_aux (exp_aux, _) as exp) = None type flow_constraint = - | Flow_lteq of big_int * nexp - | Flow_gteq of big_int * nexp + | Flow_lteq of Big_int.num * nexp + | Flow_gteq of Big_int.num * nexp let restrict_range_upper c1 nexp1 (Typ_aux (typ_aux, l) as typ) = match typ_aux with @@ -1875,7 +1830,7 @@ let restrict_range_upper c1 nexp1 (Typ_aux (typ_aux, l) as typ) = begin match big_int_of_nexp nexp2 with | Some c2 -> - let upper = if (lt_big_int c1 c2) then nexp1 else nexp2 in + let upper = if (Big_int.less c1 c2) then nexp1 else nexp2 in range_typ nexp upper | _ -> typ end @@ -1888,7 +1843,7 @@ let restrict_range_lower c1 nexp1 (Typ_aux (typ_aux, l) as typ) = begin match big_int_of_nexp nexp2 with | Some c2 -> - let lower = if (gt_big_int c1 c2) then nexp1 else nexp2 in + let lower = if (Big_int.greater c1 c2) then nexp1 else nexp2 in range_typ lower nexp | _ -> typ end @@ -1897,10 +1852,10 @@ let restrict_range_lower c1 nexp1 (Typ_aux (typ_aux, l) as typ) = let apply_flow_constraint = function | Flow_lteq (c, nexp) -> (restrict_range_upper c nexp, - restrict_range_lower (succ_big_int c) (nexp_simp (nsum nexp (nint 1)))) + restrict_range_lower (Big_int.succ c) (nexp_simp (nsum nexp (nint 1)))) | Flow_gteq (c, nexp) -> (restrict_range_lower c nexp, - restrict_range_upper (pred_big_int c) (nexp_simp (nminus nexp (nint 1)))) + restrict_range_upper (Big_int.pred c) (nexp_simp (nminus nexp (nint 1)))) let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = match exp_aux with @@ -1909,7 +1864,7 @@ let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = begin match destruct_atom (typ_of y) with | Some (c, nexp) -> - [(v, Flow_lteq (pred_big_int c, nexp_simp (nminus nexp (nint 1))))], [] + [(v, Flow_lteq (Big_int.pred c, nexp_simp (nminus nexp (nint 1))))], [] | _ -> [], [] end | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" -> @@ -1924,7 +1879,7 @@ let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = begin match destruct_atom (typ_of y) with | Some (c, nexp) -> - [(v, Flow_gteq (succ_big_int c, nexp_simp (nsum nexp (nint 1))))], [] + [(v, Flow_gteq (Big_int.succ c, nexp_simp (nsum nexp (nint 1))))], [] | _ -> [], [] end | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" -> @@ -2017,7 +1972,10 @@ let strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp = let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in - let add_effect (E_aux (exp, (l, Some (env, typ, _)))) eff = E_aux (exp, (l, Some (env, typ, eff))) in + let add_effect exp eff = match exp with + | (E_aux (exp, (l, Some (env, typ, _)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Tried to add effect to unannoted expression" + in let annot_exp exp typ = annot_exp_effect exp typ no_effect in match (exp_aux, typ_aux) with | E_block exps, _ -> @@ -2090,7 +2048,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2105,7 +2063,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2165,10 +2123,13 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_throw exp, _ -> let checked_exp = crule check_exp env exp exc_typ in annot_exp_effect (E_throw checked_exp) typ (mk_effect [BE_escape]) - | E_internal_let (lexp, bind, exp), _ -> - let E_aux (E_assign (lexp, bind), _), env = bind_assignment env lexp bind in + | E_var (lexp, bind, exp), _ -> + let lexp, bind, env = match bind_assignment env lexp bind with + | E_aux (E_assign (lexp, bind), _), env -> lexp, bind, env + | _, _ -> assert false + in let checked_exp = crule check_exp env exp typ in - annot_exp (E_internal_let (lexp, bind, checked_exp)) typ + annot_exp (E_var (lexp, bind, checked_exp)) typ | E_internal_return exp, _ -> let checked_exp = crule check_exp env exp typ in annot_exp (E_internal_return checked_exp) typ @@ -2191,7 +2152,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let checked_body = crule check_exp env body typ in annot_exp (E_internal_plet (tpat, bind_exp, checked_body)) typ | E_vector vec, _ -> - let (start, len, ord, vtyp) = destruct_vec_typ l env typ in + let (len, ord, vtyp) = destruct_vec_typ l env typ in let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in if prove env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ else typ_error l "List length didn't match" (* FIXME: improve error message *) @@ -2199,11 +2160,6 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ if is_typ_monomorphic typ || Env.polymorphic_undefineds env then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef]) else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction") - (* This rule allows registers of type t to be passed by name with type register<t>*) - | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ arg_typ, _)]) - when string_of_id id = "register" && Env.is_register reg env -> - let rtyp = Env.get_register reg env in - subtyp l env rtyp arg_typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *) | E_id id, _ when is_union_id id env -> begin match Env.lookup_id id env with @@ -2249,9 +2205,12 @@ and check_case env pat_typ pexp typ = and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_typ exp typ = match exp with + | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type for unannotated function" + in let rec try_casts trigger errs = function - | [] -> typ_raise l (Err_no_casts (trigger, errs)) + | [] -> typ_raise l (Err_no_casts (strip_exp annotated_exp, trigger, errs)) | (cast :: casts) -> begin typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ); try @@ -2280,7 +2239,10 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_typ exp typ = match exp with + | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type for unannotated expression" + in let rec try_casts = function | [] -> unify_error l "No valid casts resulted in unification" | (cast :: casts) -> begin @@ -2307,7 +2269,10 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) = typ_print ("Binding " ^ string_of_pat pat ^ " to " ^ string_of_typ typ); let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in - let switch_typ (P_aux (pat_aux, (l, Some (env, _, eff)))) typ = P_aux (pat_aux, (l, Some (env, typ, eff))) in + let switch_typ pat typ = match pat with + | (P_aux (pat_aux, (l, Some (env, _, eff)))) -> P_aux (pat_aux, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type of unannotated pattern" + in let bind_tuple_pat (tpats, env) pat typ = let tpat, env = bind_pat env pat typ in tpat :: tpats, env in @@ -2446,7 +2411,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = | P_id v -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Unbound -> + | Local (Immutable, _) | Unbound | Union _ -> typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation") | Local (Mutable, _) | Register _ -> typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) @@ -2463,26 +2428,26 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = let typed_pat, env = bind_pat env pat bit_typ in pats @ [typed_pat], env in - let ((typed_pat :: typed_pats) as pats), env = + let pats, env = List.fold_left fold_pats ([], env) (pat :: pats) in let len = nexp_simp (nint (List.length pats)) in - let etyp = pat_typ_of typed_pat in - List.map (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; - annot_pat (P_vector pats) (lvector_typ env len etyp), env + let etyp = pat_typ_of (List.hd pats) in + List.iter (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; + annot_pat (P_vector pats) (dvector_typ env len etyp), env | P_vector_concat (pat :: pats) -> let fold_pats (pats, env) pat = let inferred_pat, env = infer_pat env pat in pats @ [inferred_pat], env in - let (inferred_pat :: inferred_pats), env = List.fold_left fold_pats ([], env) (pat :: pats) in - let (_, len, _, vtyp) = destruct_vec_typ l env (pat_typ_of inferred_pat) in + let inferred_pats, env = List.fold_left fold_pats ([], env) (pat :: pats) in + let (len, _, vtyp) = destruct_vec_typ l env (pat_typ_of (List.hd inferred_pats)) in let fold_len len pat = - let (_, len', _, vtyp') = destruct_vec_typ l env (pat_typ_of pat) in + let (len', _, vtyp') = destruct_vec_typ l env (pat_typ_of pat) in typ_equality l env vtyp vtyp'; nsum len len' in - let len = nexp_simp (List.fold_left fold_len len inferred_pats) in - annot_pat (P_vector_concat (inferred_pat :: inferred_pats)) (lvector_typ env len vtyp), env + 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 | P_as (pat, id) -> let (typed_pat, env) = infer_pat env pat in annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) env @@ -2513,38 +2478,26 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as let is_immutable, vtyp, is_register = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, vtyp, false | Local (Mutable, vtyp) -> false, vtyp, false | Register vtyp -> false, vtyp, true in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp]), _) = access in + let inferred_exp = match access with + | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp + | _ -> assert false + in typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register end + | _ -> typ_error l "Field l-expression must be either a vector or an identifier" in let regtyp, inferred_flexp, is_register = infer_flexp flexp in typ_debug ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp)); match Env.expand_synonyms env regtyp with - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id regtyp_id, _)), _)]), _) - | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> - let eff = mk_effect [BE_wreg] in - let base, top, ranges = Env.get_regtyp regtyp_id env in - let range, _ = - try List.find (fun (_, id) -> Id.compare id field = 0) ranges with - | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp_id) - in - let vec_typ = match range, Env.get_default_order env with - | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> - dvector_typ env (nconstant n) (nint 1) (mk_typ (Typ_id (mk_id "bit"))) - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> - dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) (mk_typ (Typ_id (mk_id "bit"))) - | _, _ -> typ_error l "Not implemented this register field type yet..." - in - let checked_exp = crule check_exp env exp vec_typ in - annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) vec_typ) checked_exp, env | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let eff = if is_register then mk_effect [BE_wreg] else no_effect in - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2574,10 +2527,20 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in match lexp_aux with + | LEXP_deref exp -> + let inferred_exp = infer_exp env exp in + begin match typ_of inferred_exp with + | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ vtyp, _)]), _) when string_of_id r = "ref" -> + subtyp l env typ vtyp; annot_lexp (LEXP_deref inferred_exp) typ, env + | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ vtyp, _)]), _) when string_of_id r = "register" -> + subtyp l env typ vtyp; annot_lexp_effect (LEXP_deref inferred_exp) typ (mk_effect [BE_wreg]), env + | _ -> + typ_error l (string_of_typ typ ^ " must be a ref or register type in (*" ^ string_of_exp exp ^ ")") + end | LEXP_id v -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env | Register vtyp -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ (mk_effect [BE_wreg]), env | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env @@ -2585,8 +2548,8 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | LEXP_cast (typ_annot, v) -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> begin subtyp l env typ typ_annot; @@ -2624,19 +2587,19 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Typ_app (id, _) when Id.compare id (mk_id "vector") == 0 -> begin match destruct_vector env typ with - | Some (_, vec_len, _, _) -> + | Some (vec_len, _, _) -> let bind_bits_tuple lexp (tlexps, env, llen) = match lexp with | LEXP_aux (LEXP_id v, _) -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Unbound -> typ_error l "Unbound variable in vector tuple assignment" | Local (Mutable, vtyp) | Register vtyp -> let llen' = match destruct_vector env vtyp with - | Some (_, llen', _, _) -> llen' + | Some (llen', _, _) -> llen' | None -> typ_error l "Variables in vector tuple assignment must be vectors" in let tlexp, env = bind_lexp env lexp vtyp in @@ -2649,9 +2612,9 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") in - let typq, (Typ_aux (Typ_fn (_, vtyp, _), _)) = Env.get_accessor rec_id fid env in + let typq, _, vtyp, _ = Env.get_accessor rec_id fid env in let llen' = match destruct_vector env vtyp with - | Some (_, llen', _, _) -> llen' + | Some (llen', _, _) -> llen' | None -> typ_error l "Variables in vector tuple assignment must be vectors" in let tlexp, env = bind_lexp env lexp vtyp in @@ -2671,16 +2634,17 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let is_immutable, is_register, vtyp = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, false, vtyp | Local (Mutable, vtyp) -> false, false, vtyp | Register vtyp -> false, true, vtyp in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_subrange", [E_aux (E_id v, (l, ())); exp1; exp2]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) = access in + let inferred_exp1, inferred_exp2 = match access with + | E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) -> inferred_exp1, inferred_exp2 + | _ -> assert false + in match typ_of access with - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> - subtyp l env typ deref_typ; - annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env | _ when not is_immutable && is_register -> subtyp l env typ (typ_of access); annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env @@ -2695,16 +2659,17 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let is_immutable, is_register, vtyp = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, false, vtyp | Local (Mutable, vtyp) -> false, false, vtyp | Register vtyp -> false, true, vtyp in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp]), _) = access in + let inferred_exp = match access with + | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp + | _ -> assert false + in match typ_of access with - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> - subtyp l env typ deref_typ; - annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env | _ when not is_immutable && is_register -> subtyp l env typ (typ_of access); annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env @@ -2720,7 +2685,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") in - let typq, (Typ_aux (Typ_fn (_, ret_typ, _), _)) = Env.get_accessor rec_id fid env in + let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ (mk_effect [BE_wreg]), env | _ -> typ_error l ("Unhandled l-expression " ^ string_of_lexp lexp) @@ -2750,35 +2715,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = begin let inferred_exp = irule infer_exp env exp in match Env.expand_synonyms env (typ_of inferred_exp) with - (* Accessing a (bit) field of a register *) - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ ((Typ_aux (Typ_id regtyp, _) as regtyp_aux)), _)]), _) - | (Typ_aux (Typ_id regtyp, _) as regtyp_aux) when Env.is_regtyp regtyp env -> - let base, top, ranges = Env.get_regtyp regtyp env in - let range, _ = - try List.find (fun (_, id) -> Id.compare id field = 0) ranges with - | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp) - in - let checked_exp = crule check_exp env (strip_exp inferred_exp) regtyp_aux in - begin - match range, Env.get_default_order env with - | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> - let vec_typ = dvector_typ env (nconstant n) (nint 1) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> - let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) -> - let vec_typ = dvector_typ env (nconstant n) (nint 1) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) -> - let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int m n) unit_big_int)) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | _, _ -> typ_error l "Invalid register field type" - end (* Accessing a field of a record *) | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env -> begin - let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor rectyp field env) [strip_exp inferred_exp] None in + let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in match inferred_acc with | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc) | _ -> assert false (* Unreachable *) @@ -2799,7 +2739,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let inferred_exp = crule check_exp env exp field_typ' in @@ -2832,6 +2772,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let f, t, is_dec = match ord with | Ord_aux (Ord_inc, _) -> f, t, false | Ord_aux (Ord_dec, _) -> t, f, true (* reverse direction to typechecking downto as upto loop *) + | Ord_aux (Ord_var _, _) -> typ_error l "Cannot check a loop with variable direction!" (* This should never happen *) in let inferred_f = irule infer_exp env f in let inferred_t = irule infer_exp env t in @@ -2874,20 +2815,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_vector ((item :: items) as vec) -> let inferred_item = irule infer_exp env item in let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in - let vec_typ = match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - mk_typ (Typ_app (mk_id "vector", - [mk_typ_arg (Typ_arg_nexp (nint 0)); - mk_typ_arg (Typ_arg_nexp (nint (List.length vec))); - mk_typ_arg (Typ_arg_order (Env.get_default_order env)); - mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) - | Ord_aux (Ord_dec, _) -> - mk_typ (Typ_app (mk_id "vector", - [mk_typ_arg (Typ_arg_nexp (nint (List.length vec - 1))); - mk_typ_arg (Typ_arg_nexp (nint (List.length vec))); - mk_typ_arg (Typ_arg_order (Env.get_default_order env)); - mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) - in + let vec_typ = dvector_typ env (nint (List.length vec)) (typ_of inferred_item) in annot_exp (E_vector (inferred_item :: checked_items)) vec_typ | E_assert (test, msg) -> let checked_test = crule check_exp env test bool_typ in @@ -2926,6 +2854,12 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let tpat, env = bind_pat env pat ptyp in let inferred_exp = irule infer_exp env exp in annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) (typ_of inferred_exp) + | E_ref id when Env.is_mutable id env -> + let (_, typ) = Bindings.find id (Env.get_locals env) in + annot_exp (E_ref id) (ref_typ typ) + | E_ref id when Env.is_register id env -> + let typ = Env.get_register id env in + annot_exp (E_ref id) (register_typ typ) | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp) and infer_funapp l env f xs ret_ctx_typ = fst (infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ) @@ -2938,7 +2872,10 @@ and instantiation_of (E_aux (exp_aux, (l, _)) as exp) = and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = let annot_exp exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in - let switch_annot env typ (E_aux (exp, (l, Some (_, _, eff)))) = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_annot env typ = function + | (E_aux (exp, (l, Some (_, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch annot for unannotated function" + in let all_unifiers = ref KBindings.empty in let ex_goal = ref None in let prove_goal env = match !ex_goal with @@ -2996,6 +2933,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = let enc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) nc) enc ex_kids in let env = List.fold_left (fun env kid -> Env.add_typ_var (prepend_kid ex_tag kid) BK_nat env) env ex_kids in Env.add_constraint enc env + | _, None -> assert false (* Cannot have ex_kids without ex_nc *) in let tag_unifier uvar = List.fold_left (fun uvar kid -> uvar_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) uvar) uvar ex_kids in let unifiers = KBindings.map tag_unifier unifiers in @@ -3123,6 +3061,7 @@ and propagate_exp_effect_aux = function let p_xs = List.map propagate_exp_effect xs in E_nondet p_xs, collect_effects p_xs | E_id id -> E_id id, no_effect + | E_ref id -> E_ref id, no_effect | E_lit lit -> E_lit lit, no_effect | E_cast (typ, exp) -> let p_exp = propagate_exp_effect exp in @@ -3211,11 +3150,11 @@ and propagate_exp_effect_aux = function let p_lexp = propagate_lexp_effect lexp in let p_exp = propagate_exp_effect exp in E_assign (p_lexp, p_exp), union_effects (effect_of p_exp) (effect_of_lexp p_lexp) - | E_internal_let (lexp, bind, exp) -> + | E_var (lexp, bind, exp) -> let p_lexp = propagate_lexp_effect lexp in let p_bind = propagate_exp_effect bind in let p_exp = propagate_exp_effect exp in - E_internal_let (p_lexp, p_bind, p_exp), union_effects (effect_of_lexp p_lexp) (collect_effects [p_bind; p_exp]) + E_var (p_lexp, p_bind, p_exp), union_effects (effect_of_lexp p_lexp) (collect_effects [p_bind; p_exp]) | E_sizeof nexp -> E_sizeof nexp, no_effect | E_constraint nc -> E_constraint nc, no_effect | E_exit exp -> @@ -3234,12 +3173,6 @@ and propagate_exp_effect_aux = function | E_field (exp, id) -> let p_exp = propagate_exp_effect exp in E_field (p_exp, id), effect_of p_exp - | E_internal_let (lexp, exp, body) -> - let p_lexp = propagate_lexp_effect lexp in - let p_exp = propagate_exp_effect exp in - let p_body = propagate_exp_effect body in - E_internal_let (p_lexp, p_exp, p_body), - union_effects (effect_of_lexp p_lexp) (collect_effects [p_exp; p_body]) | E_internal_plet (pat, exp, body) -> let p_pat = propagate_pat_effect pat in let p_exp = propagate_exp_effect exp in @@ -3337,6 +3270,9 @@ and propagate_lexp_effect (LEXP_aux (lexp, annot)) = add_effect_lexp (LEXP_aux (p_lexp, annot)) eff and propagate_lexp_effect_aux = function | LEXP_id id -> LEXP_id id, no_effect + | LEXP_deref exp -> + let p_exp = propagate_exp_effect exp in + LEXP_deref p_exp, effect_of p_exp | LEXP_memory (id, exps) -> let p_exps = List.map propagate_exp_effect exps in LEXP_memory (id, p_exps), collect_effects p_exps @@ -3357,7 +3293,6 @@ and propagate_lexp_effect_aux = function | LEXP_field (lexp, id) -> let p_lexp = propagate_lexp_effect lexp in LEXP_field (p_lexp, id),effect_of_lexp p_lexp - | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in lexp" (**************************************************************************) (* 6. Checking toplevel definitions *) @@ -3446,12 +3381,16 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) | None -> typ_error l "funcl list is empty" in typ_print ("\nChecking function " ^ string_of_id id); - let have_val_spec, (quant, (Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) as typ)), env = + let have_val_spec, (quant, typ), env = try true, Env.get_val_spec id env, env with | Type_error (l, _) -> let (quant, typ) = infer_funtyp l env tannotopt funcls in false, (quant, typ), env in + let vtyp_arg, vtyp_ret, declared_eff, vl = match typ with + | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> vtyp_arg, vtyp_ret, declared_eff, vl + | _ -> typ_error l "Function val spec was not a function type" + in check_tannotopt env quant vtyp_ret tannotopt; typ_debug ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)); let funcl_env = add_typquant quant env in @@ -3477,6 +3416,7 @@ let check_val_spec env (VS_aux (vs, (l, _))) = | VS_val_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id, ext_opt, is_cast) -> let env = match ext_opt "smt" with Some op -> Env.add_smt_op id op env | None -> env in Env.wf_typ (add_typquant quants env) typ; + typ_debug "CHECKED WELL-FORMED VAL SPEC"; let env = (* match ext_opt with | None -> env @@ -3486,7 +3426,7 @@ let check_val_spec env (VS_aux (vs, (l, _))) = let env = if is_cast then Env.add_cast id env else env in (id, quants, typ, env) in - [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, Env.expand_synonyms env typ) env + [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, Env.expand_synonyms (add_typquant quants env) typ) env let check_default env (DT_aux (ds, l)) = match ds with @@ -3497,23 +3437,6 @@ let check_default env (DT_aux (ds, l)) = (* This branch allows us to write something like: default forall Nat 'n. [|'n|] name... what does this even mean?! *) | DT_typ (typschm, id) -> typ_error l ("Unsupported default construct") -let check_register env id base top ranges = - match base, top with - | Nexp_aux (Nexp_constant basec, _), Nexp_aux (Nexp_constant topc, _) -> - let no_typq = TypQ_aux (TypQ_tq [], Parse_ast.Unknown) (* Maybe could be TypQ_no_forall? *) in - (* FIXME: wrong for default Order inc? *) - let vec_typ = dvector_typ env base (nconstant (add_big_int (sub_big_int basec topc) unit_big_int)) bit_typ in - let cast_typ = mk_typ (Typ_fn (mk_id_typ id, vec_typ, no_effect)) in - let cast_to_typ = mk_typ (Typ_fn (vec_typ, mk_id_typ id, no_effect)) in - env - |> Env.add_regtyp id basec topc ranges - (* |> Env.add_typ_synonym id (fun _ -> vec_typ) *) - |> Env.add_val_spec (mk_id ("cast_" ^ string_of_id id)) (no_typq, cast_typ) - |> Env.add_cast (mk_id ("cast_" ^ string_of_id id)) - |> Env.add_val_spec (mk_id ("cast_to_" ^ string_of_id id)) (no_typq, cast_to_typ) - |> Env.add_cast (mk_id ("cast_to_" ^ string_of_id id)) - | _, _ -> typ_error (id_loc id) "Num expressions in register type declaration do not evaluate to constants" - let kinded_id_arg kind_id = let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in match kind_id with @@ -3523,6 +3446,7 @@ let kinded_id_arg kind_id = typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) -> typ_arg (Typ_arg_typ (mk_typ (Typ_var kid))) + | KOpt_aux (KOpt_kind (K_aux (K_kind kinds, _), kid), l) -> typ_error l "Badly formed kind" let fold_union_quant quants (QI_aux (qi, l)) = match qi with @@ -3562,35 +3486,53 @@ let mk_synonym typq typ = let typ, ncs = subst_args kopts args in if List.for_all (prove env) ncs then typ - else typ_error Parse_ast.Unknown "Could not prove constraints in type synonym" + else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs + ^ " in type synonym " ^ string_of_typ typ + ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) -let check_typedef env (TD_aux (tdef, (l, _))) = +let check_kinddef env (KD_aux (kdef, (l, _))) = + let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented kind def") in + match kdef with + | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_nat, _)]),_) as kind), id, nmscm, nexp) -> + [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], + Env.add_num_def id nexp env + | _ -> kd_err () + +let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = + fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Typedef") in match tdef with - | TD_abbrev(id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> + | TD_abbrev (id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ) env - | TD_record(id, nmscm, typq, fields, _) -> + | TD_record (id, nmscm, typq, fields, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env - | TD_variant(id, nmscm, typq, arms, _) -> + | TD_variant (id, nmscm, typq, arms, _) -> let env = env |> Env.add_variant id (typq, arms) |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms) in [DEF_type (TD_aux (tdef, (l, None)))], env - | TD_enum(id, nmscm, ids, _) -> + | TD_enum (id, nmscm, ids, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env - | TD_register(id, base, top, ranges) -> [DEF_type (TD_aux (tdef, (l, Some (env, unit_typ, no_effect))))], check_register env id base top ranges - -let check_kinddef env (KD_aux (kdef, (l, _))) = - let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented kind def") in - match kdef with - | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_nat, _)]),_) as kind), id, nmscm, nexp) -> - [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], - Env.add_num_def id nexp env - | _ -> kd_err () + | TD_bitfield (id, typ, ranges) -> + let typ = Env.expand_synonyms env typ in + begin + match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant size, _)), _); + Typ_arg_aux (Typ_arg_order order, _); + Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id b, _)), _)]), _) + when string_of_id v = "vector" && string_of_id b = "bit" -> + let size = Big_int.to_int size in + let (Defs defs), env = check' env (Bitfield.macro id size order ranges) in + defs, env + | _ -> + typ_error l "Bad bitfield type" + end -let rec check_def env def = +and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = + fun env def -> let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Case") in match def with | DEF_kind kdef -> check_kinddef env kdef @@ -3619,7 +3561,8 @@ let rec check_def env def = let defs, env = check_def env def in List.map (fun def -> DEF_comm (DC_comm_struct def)) defs, env -let rec check' env (Defs defs) = +and check' : 'a. Env.t -> 'a defs -> tannot defs * Env.t = + fun env (Defs defs) -> match defs with | [] -> (Defs []), env | def :: defs -> @@ -3627,7 +3570,8 @@ let rec check' env (Defs defs) = let (Defs defs, env) = check' env (Defs defs) in (Defs (def @ defs)), env -let check env defs = +let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = + fun env defs -> try check' env defs with | Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) diff --git a/src/type_check.mli b/src/type_check.mli index 5066553e..e3daec75 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -50,13 +50,13 @@ open Ast open Ast_util -open Big_int +module Big_int = Nat_big_num val opt_tc_debug : int ref val opt_no_effects : bool ref type type_error = - | Err_no_casts of type_error * type_error list + | Err_no_casts of unit exp * type_error * type_error list | Err_no_overloading of id * (id * type_error) list | Err_unresolved_quants of id * quant_item list | Err_subtype of typ * typ * n_constraint list @@ -84,15 +84,10 @@ module Env : sig val get_register : id -> t -> typ - val get_regtyp : id -> t -> big_int * big_int * (index_range * id) list - (* Return all the identifiers in an enumeration. Throws a type error if the enumeration doesn't exist. *) val get_enum : id -> t -> id list - (* Returns true if id is a register type, false otherwise *) - val is_regtyp : id -> t -> bool - val get_locals : t -> (mut * typ) Bindings.t val add_local : id -> mut * typ -> t -> t @@ -115,7 +110,8 @@ module Env : sig val is_record : id -> t -> bool - val get_accessor : id -> id -> t -> typquant * typ + (* Return type is: quantifier, argument type, return type, effect *) + val get_accessor : id -> id -> t -> typquant * typ * typ * effect (* If the environment is checking a function, then this will get the expected return type of the function. It's useful for checking or @@ -178,10 +174,7 @@ val add_typquant : typquant -> Env.t -> Env.t val orig_kid : kid -> kid (* Vector with default order. *) -val dvector_typ : Env.t -> nexp -> nexp -> typ -> typ - -(* Vector of specific length with default order, i.e. lvector_typ env n bit_typ = bit[n]. *) -val lvector_typ : Env.t -> nexp -> typ -> typ +val dvector_typ : Env.t -> nexp -> typ -> typ val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ @@ -232,7 +225,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option existential to ensure that no name-clashes occur. *) val destruct_exist : Env.t -> typ -> (kid list * n_constraint * typ) option -val destruct_vector : Env.t -> typ -> (nexp * nexp * order * typ) option +val destruct_vector : Env.t -> typ -> (nexp * order * typ) option type uvar = | U_nexp of nexp diff --git a/src/util.ml b/src/util.ml index 6f7d6a95..51ed8926 100644 --- a/src/util.ml +++ b/src/util.ml @@ -372,9 +372,25 @@ let is_some = function | Some _ -> true | None -> false +let rec take_drop f = function + | [] -> ([], []) + | (x :: xs) when not (f x) -> ([], x :: xs) + | (x :: xs) -> + let (ys, zs) = take_drop f xs in + (x :: ys, zs) + let is_none opt = not (is_some opt) let rec take n xs = match n, xs with | 0, _ -> [] | n, [] -> [] | n, (x :: xs) -> x :: take (n - 1) xs + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" +let bold str = termcode 1 ^ str +let green str = termcode 92 ^ str +let yellow str = termcode 93 ^ str +let red str = termcode 91 ^ str +let cyan str = termcode 96 ^ str +let blue str = termcode 94 ^ str +let clear str = str ^ termcode 0 diff --git a/src/util.mli b/src/util.mli index 73dbd30b..39bc8a19 100644 --- a/src/util.mli +++ b/src/util.mli @@ -228,3 +228,15 @@ val is_some : 'a option -> bool val is_none : 'a option -> bool val take : int -> 'a list -> 'a list + +val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list) + +(* Terminal color codes *) +val termcode : int -> string +val bold : string -> string +val green : string -> string +val red : string -> string +val yellow : string -> string +val cyan : string -> string +val blue : string -> string +val clear : string -> string diff --git a/src/value.ml b/src/value.ml new file mode 100644 index 00000000..7dd3b30b --- /dev/null +++ b/src/value.ml @@ -0,0 +1,407 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +module Big_int = Nat_big_num + +module StringMap = Map.Make(String) + +type value = + | V_vector of value list + | V_list of value list + | V_int of Big_int.num + | V_bool of bool + | V_bit of Sail_lib.bit + | V_tuple of value list + | V_unit + | V_string of string + | V_ref of string + | V_ctor of string * value list + | V_record of value StringMap.t + +let coerce_bit = function + | V_bit b -> b + | _ -> assert false + +let coerce_ctor = function + | V_ctor (str, vals) -> (str, vals) + | _ -> assert false + +let coerce_bool = function + | V_bool b -> b + | _ -> assert false + +let coerce_record = function + | V_record record -> record + | _ -> assert false + +let and_bool = function + | [v1; v2] -> V_bool (coerce_bool v1 && coerce_bool v2) + | _ -> assert false + +let or_bool = function + | [v1; v2] -> V_bool (coerce_bool v1 || coerce_bool v2) + | _ -> assert false + +let tuple_value (vs : value list) : value = V_tuple vs + +let mk_vector (bits : Sail_lib.bit list) : value = V_vector (List.map (fun bit -> V_bit bit) bits) + +let coerce_bit = function + | V_bit b -> b + | _ -> assert false + +let coerce_tuple = function + | V_tuple vs -> vs + | _ -> assert false + +let coerce_listlike = function + | V_tuple vs -> vs + | V_list vs -> vs + | V_unit -> [] + | _ -> assert false + +let coerce_int = function + | V_int i -> i + | _ -> assert false + +let coerce_cons = function + | V_list (v :: vs) -> Some (v, vs) + | V_list [] -> None + | _ -> assert false + +let coerce_gv = function + | V_vector vs -> vs + | _ -> assert false + +let coerce_bv = function + | V_vector vs -> List.map coerce_bit vs + | _ -> assert false + +let coerce_string = function + | V_string str -> str + | _ -> assert false + +let coerce_ref = function + | V_ref str -> str + | _ -> assert false + +let unit_value = V_unit + +let value_eq_int = function + | [v1; v2] -> V_bool (Sail_lib.eq_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value eq_int" + +let value_lteq = function + | [v1; v2] -> V_bool (Sail_lib.lteq (coerce_int v1, coerce_int v2)) + | _ -> failwith "value lteq" + +let value_gteq = function + | [v1; v2] -> V_bool (Sail_lib.gteq (coerce_int v1, coerce_int v2)) + | _ -> failwith "value gteq" + +let value_lt = function + | [v1; v2] -> V_bool (Sail_lib.lt (coerce_int v1, coerce_int v2)) + | _ -> failwith "value lt" + +let value_gt = function + | [v1; v2] -> V_bool (Sail_lib.gt (coerce_int v1, coerce_int v2)) + | _ -> failwith "value gt" + +let value_eq_list = function + | [v1; v2] -> V_bool (Sail_lib.eq_list (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value eq_list" + +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_length = function + | [v] -> V_int (coerce_gv v |> List.length |> Big_int.of_int) + | _ -> failwith "value length" + +let value_subrange = function + | [v1; v2; v3] -> mk_vector (Sail_lib.subrange (coerce_bv v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value subrange" + +let value_access = function + | [v1; v2] -> Sail_lib.access (coerce_gv v1, coerce_int v2) + | _ -> failwith "value access" + +let value_update = function + | [v1; v2; v3] -> V_vector (Sail_lib.update (coerce_gv v1, coerce_int v2, v3)) + | _ -> failwith "value update" + +let value_update_subrange = function + | [v1; v2; v3; v4] -> mk_vector (Sail_lib.update_subrange (coerce_bv v1, coerce_int v2, coerce_int v3, coerce_bv v4)) + | _ -> failwith "value update_subrange" + +let value_append = function + | [v1; v2] -> V_vector (coerce_gv v1 @ coerce_gv v2) + | _ -> failwith "value append" + +let value_slice = function + | [v1; v2; v3] -> V_vector (Sail_lib.slice (coerce_gv v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value slice" + +let value_not = function + | [v] -> V_bool (not (coerce_bool v)) + | _ -> failwith "value not" + +let value_not_vec = function + | [v] -> mk_vector (Sail_lib.not_vec (coerce_bv v)) + | _ -> failwith "value not_vec" + +let value_and_vec = function + | [v1; v2] -> mk_vector (Sail_lib.and_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value not_vec" + +let value_or_vec = function + | [v1; v2] -> mk_vector (Sail_lib.or_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value not_vec" + +let value_uint = function + | [v] -> V_int (Sail_lib.uint (coerce_bv v)) + | _ -> failwith "value uint" + +let value_sint = function + | [v] -> V_int (Sail_lib.sint (coerce_bv v)) + | _ -> failwith "value sint" + +let value_get_slice_int = function + | [v1; v2; v3] -> mk_vector (Sail_lib.get_slice_int (coerce_int v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value get_slice_int" + +let value_set_slice_int = function + | [v1; v2; v3; v4] -> + V_int (Sail_lib.set_slice_int (coerce_int v1, coerce_int v2, coerce_int v3, coerce_bv v4)) + | _ -> failwith "value set_slice_int" + +let value_set_slice = function + | [v1; v2; v3; v4; v5] -> + mk_vector (Sail_lib.set_slice (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_int v4, coerce_bv v5)) + | _ -> failwith "value set_slice" + +let value_hex_slice = function + | [v1; v2; v3] -> + mk_vector (Sail_lib.hex_slice (coerce_string v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value hex_slice" + +let value_add = function + | [v1; v2] -> V_int (Sail_lib.add (coerce_int v1, coerce_int v2)) + | _ -> failwith "value add" + +let value_sub = function + | [v1; v2] -> V_int (Sail_lib.sub (coerce_int v1, coerce_int v2)) + | _ -> failwith "value sub" + +let value_mult = function + | [v1; v2] -> V_int (Sail_lib.mult (coerce_int v1, coerce_int v2)) + | _ -> failwith "value mult" + +let value_quotient = function + | [v1; v2] -> V_int (Sail_lib.quotient (coerce_int v1, coerce_int v2)) + | _ -> failwith "value quotient" + +let value_modulus = function + | [v1; v2] -> V_int (Sail_lib.modulus (coerce_int v1, coerce_int v2)) + | _ -> failwith "value modulus" + +let value_add_vec_int = function + | [v1; v2] -> mk_vector (Sail_lib.add_vec_int (coerce_bv v1, coerce_int v2)) + | _ -> failwith "value add_vec_int" + +let value_add_vec = function + | [v1; v2] -> mk_vector (Sail_lib.add_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value add_vec" + +let value_sub_vec = function + | [v1; v2] -> mk_vector (Sail_lib.sub_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value sub_vec" + +let value_shl_int = function + | [v1; v2] -> V_int (Sail_lib.shl_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value shl_int" + +let value_shr_int = function + | [v1; v2] -> V_int (Sail_lib.shr_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value shr_int" + +let value_max_int = function + | [v1; v2] -> V_int (Sail_lib.max_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value max_int" + +let value_min_int = function + | [v1; v2] -> V_int (Sail_lib.min_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value min_int" + +let value_replicate_bits = function + | [v1; v2] -> mk_vector (Sail_lib.replicate_bits (coerce_bv v1, coerce_int v2)) + | _ -> failwith "value replicate_bits" + +let is_bit = function + | V_bit _ -> true + | _ -> false + + +let is_ctor = function + | V_ctor _ -> true + | _ -> false + +let rec string_of_value = function + | V_vector vs when List.for_all is_bit vs -> Sail_lib.string_of_bits (List.map coerce_bit vs) + | V_vector vs -> "[" ^ Util.string_of_list ", " string_of_value vs ^ "]" + | V_bool true -> "true" + | V_bool false -> "false" + | V_bit Sail_lib.B0 -> "bitzero" + | V_bit Sail_lib.B1 -> "bitone" + | V_int n -> Big_int.to_string n + | V_tuple vals -> "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" + | V_list vals -> "[|" ^ Util.string_of_list ", " string_of_value vals ^ "|]" + | V_unit -> "()" + | V_string str -> "\"" ^ str ^ "\"" + | V_ref str -> "ref " ^ str + | V_ctor (str, vals) -> str ^ "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" + | V_record record -> + "{" ^ Util.string_of_list ", " (fun (field, v) -> field ^ "=" ^ string_of_value v) (StringMap.bindings record) ^ "}" + +let eq_value v1 v2 = string_of_value v1 = string_of_value v2 + +let value_eq_anything = function + | [v1; v2] -> V_bool (eq_value v1 v2) + | _ -> failwith "value eq_anything" + +let value_print = function + | [v] -> print_endline (string_of_value v |> Util.red |> Util.clear); V_unit + | _ -> assert false + +let value_internal_pick = function + | [v1] -> List.hd (coerce_listlike v1); + | _ -> failwith "value internal_pick" + +let value_undefined_vector = function + | [v1; v2] -> V_vector (Sail_lib.undefined_vector (coerce_int v1, v2)) + | _ -> failwith "value undefined_vector" + +let value_read_ram = function + | [v1; v2; v3; v4] -> mk_vector (Sail_lib.read_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4)) + | _ -> failwith "value read_ram" + +let value_write_ram = function + | [v1; v2; v3; v4; v5] -> + Sail_lib.write_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4, coerce_bv v5); + V_unit + | _ -> failwith "value write_ram" + +let value_putchar = function + | [v] -> Sail_lib.putchar (coerce_int v); V_unit + | _ -> failwith "value putchar" + +let value_print_bits = function + | [msg; bits] -> print_endline (coerce_string msg ^ string_of_value bits); V_unit + | _ -> failwith "value print_bits" + +let primops = + List.fold_left + (fun r (x, y) -> StringMap.add x y r) + StringMap.empty + [ ("and_bool", and_bool); + ("or_bool", or_bool); + ("print_endline", value_print); + ("prerr_endline", value_print); + ("putchar", value_putchar); + ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); + ("print_bits", value_print_bits); + ("eq_int", value_eq_int); + ("lteq", value_lteq); + ("gteq", value_gteq); + ("lt", value_lt); + ("gt", value_gt); + ("eq_list", value_eq_list); + ("eq_string", value_eq_string); + ("eq_anything", value_eq_anything); + ("length", value_length); + ("subrange", value_subrange); + ("access", value_access); + ("update", value_update); + ("update_subrange", value_update_subrange); + ("slice", value_slice); + ("append", value_append); + ("not", value_not); + ("not_vec", value_not_vec); + ("and_vec", value_and_vec); + ("or_vec", value_or_vec); + ("uint", value_uint); + ("sint", value_sint); + ("get_slice_int", value_get_slice_int); + ("set_slice_int", value_set_slice_int); + ("set_slice", value_set_slice); + ("hex_slice", value_hex_slice); + ("add", value_add); + ("sub", value_sub); + ("mult", value_mult); + ("quotient", value_quotient); + ("modulus", value_modulus); + ("shr_int", value_shr_int); + ("shl_int", value_shl_int); + ("max_int", value_max_int); + ("min_int", value_min_int); + ("add_vec_int", value_add_vec_int); + ("add_vec", value_add_vec); + ("sub_vec", value_sub_vec); + ("read_ram", value_read_ram); + ("write_ram", value_write_ram); + ("undefined_bit", fun _ -> V_bit Sail_lib.B0); + ("undefined_int", fun _ -> V_int Big_int.zero); + ("undefined_bool", fun _ -> V_bool false); + ("undefined_vector", value_undefined_vector); + ("internal_pick", value_internal_pick); + ("replicate_bits", value_replicate_bits); + ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); + ] |