Commit 4ff04130 authored by Andrei Paskevich's avatar Andrei Paskevich

Loc.try[1-7] functions now take location as an optional parameter

parent 6e5d6e58
......@@ -4,6 +4,7 @@
backward compatible
* [emacs] why.el renamed to why3.el
o [GTK sourceview] why.lang renamed to why3.lang
* Loc.try[1-7] functions now take location as an optional parameter
version 0.81, March 25, 2013
============================
......
......@@ -118,7 +118,7 @@ let defined_ty ~loc denv env impl dw tyl =
| DT DTdummy -> error ~loc InvalidDummy
| DT (DTtype|DTprop) | DF _ | DP _ -> error ~loc TypeExpected
in
Loc.try2 loc ty_app ts tyl
Loc.try2 ~loc ty_app ts tyl
let defined_arith ~loc denv env impl dw tl =
let ts = match tl with
......@@ -185,7 +185,7 @@ let defined_arith ~loc denv env impl dw tl =
| DP DPisrat -> ns_find_ls th.th_export ["is_rat"]
| DP (DPtrue|DPfalse|DPdistinct) | DT _ -> assert false
in
Loc.try2 loc t_app_infer ls tl
Loc.try2 ~loc t_app_infer ls tl
let defined_expr ~loc is_fmla denv env impl dw tl = match dw, tl with
| (DT DTdummy), _ -> error ~loc InvalidDummy
......@@ -201,7 +201,7 @@ let defined_expr ~loc is_fmla denv env impl dw tl = match dw, tl with
dist (List.fold_left add acc tl) tl
| _ -> acc
in
Loc.try2 loc dist t_true tl
Loc.try2 ~loc dist t_true tl
| _ -> defined_arith ~loc denv env impl dw tl
(** TPTP environment *)
......@@ -270,13 +270,13 @@ let find_dobj ~loc denv env impl s =
| _ -> assert false (* impossible *)
let ty_check loc s ty1 t =
Loc.try3 loc ty_match s ty1 (Opt.get t.t_ty)
Loc.try3 ~loc ty_match s ty1 (Opt.get t.t_ty)
let rec ty denv env impl { e_loc = loc; e_node = n } = match n with
| Eapp (aw,al) ->
let ts = find_ts ~loc env impl aw al in
let tyl = List.map (ty denv env impl) al in
Loc.try2 loc ty_app ts tyl
Loc.try2 ~loc ty_app ts tyl
| Edef (dw,al) ->
let tyl = List.map (ty denv env impl) al in
defined_ty ~loc denv env impl dw tyl
......
......@@ -673,8 +673,7 @@ let check_match kn d =
| Tcase (t1,bl) ->
let find ts = List.map fst (find_constructors kn ts) in
let bl = List.map (fun b -> let p,t = t_open_branch b in [p],t) bl in
let try3 f = match t.t_loc with Some l -> Loc.try3 l f | None -> f in
ignore (try3 Pattern.CompileTerm.compile find [t1] bl);
ignore (Loc.try3 ?loc:t.t_loc Pattern.CompileTerm.compile find [t1] bl);
t_fold check () t
| _ -> t_fold check () t
in
......
......@@ -154,7 +154,7 @@ let load_driver = let driver_tag = ref (-1) in fun env file extra_files ->
| PTyapp ((loc,_) as q,tyl) ->
let ts = find_ts th q in
let tyl = List.map ty_of_pty tyl in
Loc.try2 loc Ty.ty_app ts tyl
Loc.try2 ~loc Ty.ty_app ts tyl
| PTuple tyl ->
let ts = Ty.ts_tuple (List.length tyl) in
Ty.ty_app ts (List.map ty_of_pty tyl)
......
......@@ -198,7 +198,7 @@ let rec dty uc = function
| PPTtyapp (x, p) ->
let ts = find_tysymbol x uc in
let tyl = List.map (dty uc) p in
Loc.try2 (qloc x) tyapp ts tyl
Loc.try2 ~loc:(qloc x) tyapp ts tyl
| PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in
tyapp ts (List.map (dty uc) tyl)
......@@ -209,7 +209,7 @@ let rec ty_of_pty uc = function
| PPTtyapp (x, p) ->
let ts = find_tysymbol x uc in
let tyl = List.map (ty_of_pty uc) p in
Loc.try2 (qloc x) ty_app ts tyl
Loc.try2 ~loc:(qloc x) ty_app ts tyl
| PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in
ty_app ts (List.map (ty_of_pty uc) tyl)
......@@ -261,8 +261,8 @@ let binop = function
let check_pat_linearity p =
let s = ref Sstr.empty in
let add id =
s := Loc.try3 id.id_loc Sstr.add_new (DuplicateVar id.id) id.id !s
let add { id = id; id_loc = loc } =
s := Loc.try3 ~loc Sstr.add_new (DuplicateVar id) id !s
in
let rec check p = match p.pat_desc with
| PPpwild -> ()
......@@ -293,7 +293,7 @@ and dpat_node loc uc env = function
| PPprec fl ->
let renv = ref env in
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let cs,pjl,flm = Loc.try2 ~loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let get_val pj ty = match Mls.find_opt pj flm with
| Some e ->
......@@ -351,7 +351,7 @@ let param_tys uc pl =
let ty_of_param (loc,id,gh,ty) =
if gh then Loc.errorm ~loc "ghost parameters are not allowed here";
Opt.iter (fun { id = id; id_loc = loc } ->
s := Loc.try3 loc Sstr.add_new (DuplicateVar id) id !s) id;
s := Loc.try3 ~loc Sstr.add_new (DuplicateVar id) id !s) id;
ty_of_dty (dty uc ty) in
List.map ty_of_param pl
......@@ -364,7 +364,7 @@ let quant_var uc env (id,ty) =
let quant_vars uc env qvl =
let s = ref Sstr.empty in
let add env (({ id = id; id_loc = loc }, _) as qv) =
s := Loc.try3 loc Sstr.add_new (DuplicateVar id) id !s;
s := Loc.try3 ~loc Sstr.add_new (DuplicateVar id) id !s;
quant_var uc env qv in
Lists.map_fold_left add env qvl
......@@ -523,7 +523,7 @@ and dterm_node ~localize loc uc env = function
Teps (id, ty, Fquant (Tforall, uqu, trl, f)), ty
| PPrecord fl ->
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let cs,pjl,flm = Loc.try2 ~loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let get_val pj ty = match Mls.find_opt pj flm with
| Some e ->
......@@ -538,7 +538,7 @@ and dterm_node ~localize loc uc env = function
| PPupdate (e,fl) ->
let e = dterm ~localize uc env e in
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let cs,pjl,flm = Loc.try2 ~loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let get_val pj ty = match Mls.find_opt pj flm with
| Some e ->
......@@ -723,7 +723,7 @@ let add_types dl th =
| Qident _ | Qdot _ ->
find_tysymbol q th
in
Loc.try2 (qloc q) ty_app ts (List.map apply tyl)
Loc.try2 ~loc:(qloc q) ty_app ts (List.map apply tyl)
| PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in
ty_app ts (List.map apply tyl)
......@@ -766,17 +766,17 @@ let add_types dl th =
let ty = ty_app ts (List.map ty_var ts.ts_args) in
let projection (_,id,_,_) fty = match id with
| None -> None
| Some id ->
| Some ({ id = x; id_loc = loc } as id) ->
try
let pj = Hstr.find ht id.id in
let pj = Hstr.find ht x in
let ty = Opt.get pj.ls_value in
ignore (Loc.try2 id.id_loc ty_equal_check ty fty);
ignore (Loc.try2 ~loc ty_equal_check ty fty);
Some pj
with Not_found ->
let fn = create_user_id id in
let pj = create_fsymbol ~opaque fn [ty] fty in
Hstr.replace csymbols id.id id.id_loc;
Hstr.replace ht id.id pj;
Hstr.replace csymbols x loc;
Hstr.replace ht x pj;
Some pj
in
let constructor (loc, id, pl) =
......@@ -844,7 +844,7 @@ let add_logics dl th =
let opaque = opaque_tvs d.ld_params d.ld_type in
let ls = create_lsymbol ~opaque v pl ty in
Hstr.add lsymbols id ls;
Loc.try2 d.ld_loc add_param_decl th ls
Loc.try2 ~loc:d.ld_loc add_param_decl th ls
in
let th' = List.fold_left create_symbol th dl in
(* 2. then type-check all definitions *)
......@@ -924,7 +924,7 @@ let type_fmla uc gfn f =
let add_prop k loc s f th =
let pr = create_prsymbol (create_user_id s) in
let f = type_fmla th (fun _ -> None) f in
Loc.try4 loc add_prop_decl th k pr f
Loc.try4 ~loc add_prop_decl th k pr f
let loc_of_id id = Opt.get id.Ident.id_loc
......@@ -938,7 +938,7 @@ let add_inductives s dl th =
let opaque = opaque_tvs d.in_params None in
let ps = create_psymbol ~opaque v pl in
Hstr.add psymbols id ps;
Loc.try2 d.in_loc add_param_decl th ps
Loc.try2 ~loc:d.in_loc add_param_decl th ps
in
let th' = List.fold_left create_symbol th dl in
(* 2. then type-check all definitions *)
......@@ -1053,11 +1053,11 @@ let add_decl loc th = function
| PMAint i -> MAint i
in
let add s = add_meta th (lookup_meta s) (List.map convert al) in
Loc.try1 loc add id.id
Loc.try1 ~loc add id.id
let add_decl loc th d =
if Debug.test_flag debug_parse_only then th else
Loc.try3 loc add_decl loc th d
Loc.try3 ~loc add_decl loc th d
let type_inst th t s =
let add_inst s = function
......@@ -1065,7 +1065,7 @@ let type_inst th t s =
let find ns x = find_namespace_ns x ns in
let ns1 = Opt.fold find t.th_export p in
let ns2 = Opt.fold find (get_namespace th) q in
Loc.try6 loc clone_ns t.th_known t.th_local [] ns2 ns1 s
Loc.try6 ~loc clone_ns t.th_known t.th_local [] ns2 ns1 s
| CStsym (loc,p,[],PPTtyapp (q,[])) ->
let ts1 = find_tysymbol_ns p t.th_export in
let ts2 = find_tysymbol q th in
......@@ -1077,7 +1077,7 @@ let type_inst th t s =
let id = id_user (ts1.ts_name.id_string ^ "_subst") loc in
let tvl = List.map (fun id -> create_user_tv id.id) tvl in
let def = Some (ty_of_pty th pty) in
let ts2 = Loc.try3 loc create_tysymbol id tvl def in
let ts2 = Loc.try3 ~loc create_tysymbol id tvl def in
if Mts.mem ts1 s.inst_ts
then error ~loc (ClashSymbol ts1.ts_name.id_string);
{ s with inst_ts = Mts.add ts1 ts2 s.inst_ts }
......@@ -1128,7 +1128,7 @@ let add_use_clone env lenv th loc (use, subst) =
| None ->
use_or_clone th
in
Loc.try1 loc use_or_clone th
Loc.try1 ~loc use_or_clone th
let close_theory lenv th =
if Debug.test_flag debug_parse_only then lenv else
......@@ -1139,7 +1139,7 @@ let close_theory lenv th =
Mstr.add id th lenv
let close_namespace loc import th =
Loc.try2 loc close_namespace th import
Loc.try2 ~loc close_namespace th import
(* incremental parsing *)
......
......@@ -49,7 +49,7 @@ let apply_projection kn ls t = match t.t_node with
List.fold_left2 find t_true tl pjl
| _ -> assert false
let make_flat_case kn t bl =
let flat_case kn t bl =
let mk_b b = let p,t = t_open_branch b in [p],t in
let find_constructors kn ts = List.map fst (find_constructors kn ts) in
Pattern.CompileTerm.compile (find_constructors kn) [t] (List.map mk_b bl)
......@@ -129,10 +129,7 @@ let eval_match ~inline kn t =
let_map eval env t1 tb2
| Tcase (t1, bl1) ->
let t1 = eval env t1 in
let make_flat_case = match t.t_loc with
| Some loc -> Loc.try3 loc make_flat_case
| None -> make_flat_case in
let fn env t = eval env (make_flat_case kn t bl1) in
let fn env t2 = eval env (Loc.try3 ?loc:t.t_loc flat_case kn t2 bl1) in
begin try dive_to_constructor kn fn env t1
with Exit -> branch_map eval env t1 bl1 end
| Tquant (q, qf) ->
......
......@@ -73,39 +73,37 @@ let report_position fmt = fprintf fmt "%a:@\n" gen_report_position
exception Located of position * exn
let try1 loc f x =
let error ?loc e = match loc with
| Some loc -> raise (Located (loc, e))
| None -> raise e
let try1 ?loc f x =
if Debug.test_flag Debug.stack_trace then f x else
try f x with Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x with Located _ as e -> raise e | e -> error ?loc e
let try2 loc f x y =
let try2 ?loc f x y =
if Debug.test_flag Debug.stack_trace then f x y else
try f x y with Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x y with Located _ as e -> raise e | e -> error ?loc e
let try3 loc f x y z =
let try3 ?loc f x y z =
if Debug.test_flag Debug.stack_trace then f x y z else
try f x y z with Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x y z with Located _ as e -> raise e | e -> error ?loc e
let try4 loc f x y z t =
let try4 ?loc f x y z t =
if Debug.test_flag Debug.stack_trace then f x y z t else
try f x y z t with Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x y z t with Located _ as e -> raise e | e -> error ?loc e
let try5 loc f x y z t u =
let try5 ?loc f x y z t u =
if Debug.test_flag Debug.stack_trace then f x y z t u else
try f x y z t u with Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x y z t u with Located _ as e -> raise e | e -> error ?loc e
let try6 loc f x y z t u v =
let try6 ?loc f x y z t u v =
if Debug.test_flag Debug.stack_trace then f x y z t u v else
try f x y z t u v with
Located _ as e -> raise e | e -> raise (Located (loc, e))
try f x y z t u v with Located _ as e -> raise e | e -> error ?loc e
let try7 loc f x y z t u v w =
let try7 ?loc f x y z t u v w =
if Debug.test_flag Debug.stack_trace then f x y z t u v w else
try f x y z t u v w with
Located _ as e -> raise e | e -> raise (Located (loc, e))
let error ?loc e = match loc with
| None -> raise e
| Some loc -> raise (Located (loc, e))
try f x y z t u v w with Located _ as e -> raise e | e -> error ?loc e
(* located messages *)
......
......@@ -44,21 +44,21 @@ val report_position : formatter -> position -> unit
exception Located of position * exn
val try1: position -> ('a -> 'b) -> ('a -> 'b)
val try2: position -> ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
val try3: position -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd)
val try1: ?loc:position -> ('a -> 'b) -> ('a -> 'b)
val try2: ?loc:position -> ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
val try3: ?loc:position -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd)
val try4: position ->
val try4: ?loc:position ->
('a -> 'b -> 'c -> 'd -> 'e) -> ('a -> 'b -> 'c -> 'd -> 'e)
val try5: position ->
val try5: ?loc:position ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f)
val try6: position ->
val try6: ?loc:position ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g)
val try7: position ->
val try7: ?loc:position ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h)
......
......@@ -273,9 +273,8 @@ let check_match lkn _kn d =
let t_p = t_var (create_vsymbol (id_fresh "x") typ) in
let t_e = t_var (create_vsymbol (id_fresh "y") tye) in
let bl = List.map (fun (pp,_) -> [pp.ppat_pattern], t_e) bl in
let try3 f = match e.e_loc with Some l -> Loc.try3 l f | None -> f in
let find ts = List.map fst (Decl.find_constructors lkn ts) in
ignore (try3 Pattern.CompileTerm.compile find [t_p] bl);
let get ts = List.map fst (Decl.find_constructors lkn ts) in
ignore (Loc.try3 ?loc:e.e_loc Pattern.CompileTerm.compile get [t_p] bl);
e_fold checkE () e
| _ -> e_fold checkE () e
in
......
......@@ -121,7 +121,7 @@ let load_driver lib file extra_files =
| PTyapp ((loc,_) as q,tyl) ->
let ts = find_ts th q in
let tyl = List.map ty_of_pty tyl in
Loc.try2 loc Ty.ty_app ts tyl
Loc.try2 ~loc Ty.ty_app ts tyl
| PTuple tyl ->
let ts = Ty.ts_tuple (List.length tyl) in
Ty.ty_app ts (List.map ty_of_pty tyl)
......
This diff is collapsed.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment