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

CHANGES

@@ -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
 ============================

plugins/tptp/tptp_typing.ml

@@ -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

src/core/decl.ml

@@ -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

src/driver/driver.ml

@@ -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)

src/parser/typing.ml

@@ -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 *)
 

src/transform/eval_match.ml

@@ -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) ->

src/util/loc.ml

@@ -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 *)
 

src/util/loc.mli

@@ -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)
 

src/whyml/mlw_decl.ml

@@ -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

src/whyml/mlw_driver.ml

@@ -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)