simplified typing of use/clone declarations

parent 2f34052b
...@@ -390,12 +390,12 @@ $(PGMCMO) $(PGMCMX): INCLUDES += -I src/programs ...@@ -390,12 +390,12 @@ $(PGMCMO) $(PGMCMX): INCLUDES += -I src/programs
byte: bin/why3ml.byte byte: bin/why3ml.byte
opt: bin/why3ml.opt opt: bin/why3ml.opt
bin/why3ml.opt: src/why3.cmxa $(PGMCMX) src/main.cmx bin/why3ml.opt: src/why3.cmxa $(PGMCMX) $(MLWCMX) src/main.cmx
$(if $(QUIET), @echo 'Linking $@' &&) \ $(if $(QUIET), @echo 'Linking $@' &&) \
$(OCAMLOPT) $(OFLAGS) -o $@ $(EXTCMXA) $^ $(OCAMLOPT) $(OFLAGS) -o $@ $(EXTCMXA) $^
$(STRIP) $@ $(STRIP) $@
bin/why3ml.byte: src/why3.cma $(PGMCMO) src/main.cmo bin/why3ml.byte: src/why3.cma $(PGMCMO) $(MLWCMO) src/main.cmo
$(if $(QUIET),@echo 'Linking $@' &&) \ $(if $(QUIET),@echo 'Linking $@' &&) \
$(OCAMLC) $(BFLAGS) -o $@ $(EXTCMA) $^ $(OCAMLC) $(BFLAGS) -o $@ $(EXTCMA) $^
...@@ -573,12 +573,12 @@ bin/why3ide.opt bin/why3ide.byte: INCLUDES += -I @LABLGTK2LIB@ ...@@ -573,12 +573,12 @@ bin/why3ide.opt bin/why3ide.byte: INCLUDES += -I @LABLGTK2LIB@
bin/why3ide.opt bin/why3ide.byte: EXTOBJS += bin/why3ide.opt bin/why3ide.byte: EXTOBJS +=
bin/why3ide.opt bin/why3ide.byte: EXTLIBS += lablgtk lablgtksourceview2 bin/why3ide.opt bin/why3ide.byte: EXTLIBS += lablgtk lablgtksourceview2
bin/why3ide.opt: src/why3.cmxa $(PGMCMX) $(IDECMX) bin/why3ide.opt: src/why3.cmxa $(PGMCMX) $(MLWCMX) $(IDECMX)
$(if $(QUIET), @echo 'Linking $@' &&) \ $(if $(QUIET), @echo 'Linking $@' &&) \
$(OCAMLOPT) $(OFLAGS) -o $@ $(EXTCMXA) $^ $(OCAMLOPT) $(OFLAGS) -o $@ $(EXTCMXA) $^
$(STRIP) $@ $(STRIP) $@
bin/why3ide.byte: src/why3.cma $(PGMCMO) $(IDECMO) bin/why3ide.byte: src/why3.cma $(PGMCMO) $(MLWCMO) $(IDECMO)
$(if $(QUIET),@echo 'Linking $@' &&) \ $(if $(QUIET),@echo 'Linking $@' &&) \
$(OCAMLC) $(BFLAGS) -o $@ $(EXTCMA) $^ $(OCAMLC) $(BFLAGS) -o $@ $(EXTCMA) $^
......
...@@ -179,8 +179,6 @@ let read_lib_theory lib path th = ...@@ -179,8 +179,6 @@ let read_lib_theory lib path th =
try Mstr.find th mth with Not_found -> try Mstr.find th mth with Not_found ->
raise (TheoryNotFound (path,th)) raise (TheoryNotFound (path,th))
let read_lib_file lib path = fst (read_lib_file lib path)
let register_format name exts read = let register_format name exts read =
if Hashtbl.mem read_format_table name then raise (KnownFormat name); if Hashtbl.mem read_format_table name then raise (KnownFormat name);
let getlib = Wenv.memoize 5 (mk_library read exts) in let getlib = Wenv.memoize 5 (mk_library read exts) in
......
...@@ -114,7 +114,7 @@ val env_of_library : 'a library -> env ...@@ -114,7 +114,7 @@ val env_of_library : 'a library -> env
val list_formats : unit -> (fformat * extension list) list val list_formats : unit -> (fformat * extension list) list
(** [list_formats ()] returns the list of registered formats *) (** [list_formats ()] returns the list of registered formats *)
val read_lib_file : 'a library -> pathname -> 'a val read_lib_file : 'a library -> pathname -> 'a * theory Mstr.t
(** [read_lib_file lib path] retrieves the contents of a library file (** [read_lib_file lib path] retrieves the contents of a library file
@raise LibFileNotFound [path] if the library file was not found *) @raise LibFileNotFound [path] if the library file was not found *)
......
...@@ -663,7 +663,6 @@ let is_empty_sm sm = ...@@ -663,7 +663,6 @@ let is_empty_sm sm =
Mls.is_empty sm.sm_ls && Mls.is_empty sm.sm_ls &&
Mpr.is_empty sm.sm_pr Mpr.is_empty sm.sm_pr
(** Meta properties *) (** Meta properties *)
let get_meta_arg_type = function let get_meta_arg_type = function
......
...@@ -124,6 +124,7 @@ val close_theory : theory_uc -> theory ...@@ -124,6 +124,7 @@ val close_theory : theory_uc -> theory
val open_namespace : theory_uc -> theory_uc val open_namespace : theory_uc -> theory_uc
val close_namespace : theory_uc -> bool -> string option -> theory_uc val close_namespace : theory_uc -> bool -> string option -> theory_uc
(* the Boolean indicates [import]; the string option indicates [as T] *)
val get_namespace : theory_uc -> namespace val get_namespace : theory_uc -> namespace
val get_known : theory_uc -> known_map val get_known : theory_uc -> known_map
......
...@@ -62,6 +62,7 @@ module Incremental = struct ...@@ -62,6 +62,7 @@ module Incremental = struct
let new_use_clone d = let new_use_clone d =
let env = ref_get env_ref in let lenv = ref_get lenv_ref in let env = ref_get env_ref in let lenv = ref_get lenv_ref in
ref_set uc_ref (Typing.add_use_clone env lenv (ref_get uc_ref) d) ref_set uc_ref (Typing.add_use_clone env lenv (ref_get uc_ref) d)
end end
open Ptree open Ptree
...@@ -184,6 +185,9 @@ end ...@@ -184,6 +185,9 @@ end
| Term.IConstBinary s -> int_of_string ("0b"^s) | Term.IConstBinary s -> int_of_string ("0b"^s)
with Failure _ -> raise Parsing.Parse_error with Failure _ -> raise Parsing.Parse_error
let qualid_last = function
| Qident x | Qdot (_, x) -> x.id
%} %}
/* Tokens */ /* Tokens */
...@@ -316,7 +320,7 @@ namespace_import: ...@@ -316,7 +320,7 @@ namespace_import:
; ;
namespace_name: namespace_name:
| uident { Some $1 } | uident { Some $1.id }
| UNDERSCORE { None } | UNDERSCORE { None }
; ;
...@@ -354,17 +358,17 @@ use_clone: ...@@ -354,17 +358,17 @@ use_clone:
use: use:
| imp_exp tqualid | imp_exp tqualid
{ { use_theory = $2; use_as = None; use_imp_exp = $1 } } { { use_theory = $2; use_as = Some (qualid_last $2); use_imp_exp = $1 } }
| imp_exp tqualid AS uident | imp_exp tqualid AS uident
{ { use_theory = $2; use_as = Some (Some $4); use_imp_exp = $1 } } { { use_theory = $2; use_as = Some $4.id; use_imp_exp = $1 } }
| imp_exp tqualid AS UNDERSCORE | imp_exp tqualid AS UNDERSCORE
{ { use_theory = $2; use_as = Some None; use_imp_exp = $1 } } { { use_theory = $2; use_as = None; use_imp_exp = $1 } }
; ;
imp_exp: imp_exp:
| IMPORT { Import } | IMPORT { Some true }
| EXPORT { Export } | EXPORT { None }
| /* epsilon */ { Nothing } | /* epsilon */ { Some false }
; ;
clone_subst: clone_subst:
...@@ -378,13 +382,13 @@ list1_comma_subst: ...@@ -378,13 +382,13 @@ list1_comma_subst:
; ;
subst: subst:
| NAMESPACE ns EQUAL ns { CSns ($2, $4) } | NAMESPACE ns EQUAL ns { CSns (floc (), $2, $4) }
| TYPE qualid EQUAL qualid { CStsym ($2, $4) } | TYPE qualid EQUAL qualid { CStsym (floc (), $2, $4) }
| CONSTANT qualid EQUAL qualid { CSfsym ($2, $4) } | CONSTANT qualid EQUAL qualid { CSfsym (floc (), $2, $4) }
| FUNCTION qualid EQUAL qualid { CSfsym ($2, $4) } | FUNCTION qualid EQUAL qualid { CSfsym (floc (), $2, $4) }
| PREDICATE qualid EQUAL qualid { CSpsym ($2, $4) } | PREDICATE qualid EQUAL qualid { CSpsym (floc (), $2, $4) }
| LEMMA qualid { CSlemma $2 } | LEMMA qualid { CSlemma (floc (), $2) }
| GOAL qualid { CSgoal $2 } | GOAL qualid { CSgoal (floc (), $2) }
; ;
ns: ns:
...@@ -1062,9 +1066,9 @@ opt_semicolon: ...@@ -1062,9 +1066,9 @@ opt_semicolon:
use_module: use_module:
| imp_exp MODULE tqualid | imp_exp MODULE tqualid
{ Duse ($3, $1, None) } { Duse ($3, $1, Some (qualid_last $3)) }
| imp_exp MODULE tqualid AS uident | imp_exp MODULE tqualid AS uident
{ Duse ($3, $1, Some $5) } { Duse ($3, $1, Some $5.id) }
; ;
list1_recfun_sep_and: list1_recfun_sep_and:
......
...@@ -94,22 +94,21 @@ type plogic_type = ...@@ -94,22 +94,21 @@ type plogic_type =
| PPredicate of pty list | PPredicate of pty list
| PFunction of pty list * pty | PFunction of pty list * pty
type imp_exp =
| Import | Export | Nothing
type use = { type use = {
use_theory : qualid; use_theory : qualid;
use_as : ident option option; use_as : string option;
use_imp_exp : imp_exp; (* None = as _, Some id = as id *)
use_imp_exp : bool option;
(* None = export, Some false = default, Some true = import *)
} }
type clone_subst = type clone_subst =
| CSns of qualid option * qualid option | CSns of loc * qualid option * qualid option
| CStsym of qualid * qualid | CStsym of loc * qualid * qualid
| CSfsym of qualid * qualid | CSfsym of loc * qualid * qualid
| CSpsym of qualid * qualid | CSpsym of loc * qualid * qualid
| CSlemma of qualid | CSlemma of loc * qualid
| CSgoal of qualid | CSgoal of loc * qualid
type is_mutable = bool type is_mutable = bool
...@@ -246,8 +245,8 @@ type program_decl = ...@@ -246,8 +245,8 @@ type program_decl =
| Dparam of ident * type_v | Dparam of ident * type_v
| Dexn of ident * pty option | Dexn of ident * pty option
(* modules *) (* modules *)
| Duse of qualid * imp_exp * (*as:*) ident option | Duse of qualid * bool option * (*as:*) string option
| Dnamespace of loc * ident option * (* import: *) bool * program_decl list | Dnamespace of loc * string option * (* import: *) bool * program_decl list
type theory = { type theory = {
pth_name : ident; pth_name : ident;
......
...@@ -31,7 +31,6 @@ open Denv ...@@ -31,7 +31,6 @@ open Denv
(** errors *) (** errors *)
exception Message of string
exception DuplicateTypeVar of string exception DuplicateTypeVar of string
exception TypeArity of qualid * int * int exception TypeArity of qualid * int * int
exception Clash of string exception Clash of string
...@@ -47,28 +46,15 @@ exception UnboundTypeVar of string ...@@ -47,28 +46,15 @@ exception UnboundTypeVar of string
exception UnboundType of string list exception UnboundType of string list
exception UnboundSymbol of string list exception UnboundSymbol of string list
let error ?loc e = match loc with let error = Loc.error
| None -> raise e
| Some loc -> raise (Loc.Located (loc,e)) let errorm = Loc.errorm
let errorm ?loc f =
let buf = Buffer.create 512 in
let fmt = Format.formatter_of_buffer buf in
Format.kfprintf
(fun _ ->
Format.pp_print_flush fmt ();
let s = Buffer.contents buf in
Buffer.clear buf;
error ?loc (Message s))
fmt f
let rec print_qualid fmt = function let rec print_qualid fmt = function
| Qident s -> fprintf fmt "%s" s.id | Qident s -> fprintf fmt "%s" s.id
| Qdot (m, s) -> fprintf fmt "%a.%s" print_qualid m s.id | Qdot (m, s) -> fprintf fmt "%a.%s" print_qualid m s.id
let () = Exn_printer.register (fun fmt e -> match e with let () = Exn_printer.register (fun fmt e -> match e with
| Message s ->
fprintf fmt "%s" s
| DuplicateTypeVar s -> | DuplicateTypeVar s ->
fprintf fmt "duplicate type parameter %s" s fprintf fmt "duplicate type parameter %s" s
| TypeArity (id, a, n) -> | TypeArity (id, a, n) ->
...@@ -1135,6 +1121,44 @@ let add_decl th = function ...@@ -1135,6 +1121,44 @@ let add_decl th = function
let add_decl th d = let add_decl th d =
if Debug.test_flag debug_parse_only then th else add_decl th d if Debug.test_flag debug_parse_only then th else add_decl th d
let type_inst th t s =
let add_inst s = function
| CSns (loc,p,q) ->
let find ns x = find_namespace_ns x ns in
let ns1 = option_fold find t.th_export p in
let ns2 = option_fold find (get_namespace th) q in
clone_ns loc t.th_local ns2 ns1 s
| CStsym (loc,p,q) ->
let ts1 = find_tysymbol_ns p t.th_export in
let ts2 = find_tysymbol q th in
if Mts.mem ts1 s.inst_ts
then error ~loc (Clash ts1.ts_name.id_string);
{ s with inst_ts = Mts.add ts1 ts2 s.inst_ts }
| CSfsym (loc,p,q) ->
let ls1 = find_fsymbol_ns p t.th_export in
let ls2 = find_fsymbol q th in
if Mls.mem ls1 s.inst_ls
then error ~loc (Clash ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSpsym (loc,p,q) ->
let ls1 = find_psymbol_ns p t.th_export in
let ls2 = find_psymbol q th in
if Mls.mem ls1 s.inst_ls
then error ~loc (Clash ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSlemma (loc,p) ->
let pr = find_prop_ns p t.th_export in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then error ~loc (Clash pr.pr_name.id_string);
{ s with inst_lemma = Spr.add pr s.inst_lemma }
| CSgoal (loc,p) ->
let pr = find_prop_ns p t.th_export in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then error ~loc (Clash pr.pr_name.id_string);
{ s with inst_goal = Spr.add pr s.inst_goal }
in
List.fold_left add_inst empty_inst s
let add_use_clone env lenv th (loc, use, subst) = let add_use_clone env lenv th (loc, use, subst) =
if Debug.test_flag debug_parse_only then th else if Debug.test_flag debug_parse_only then th else
let q, id = split_qualid use.use_theory in let q, id = split_qualid use.use_theory in
...@@ -1145,65 +1169,17 @@ let add_use_clone env lenv th (loc, use, subst) = ...@@ -1145,65 +1169,17 @@ let add_use_clone env lenv th (loc, use, subst) =
| TheoryNotFound _ -> error ~loc (UnboundTheory use.use_theory) | TheoryNotFound _ -> error ~loc (UnboundTheory use.use_theory)
in in
let use_or_clone th = match subst with let use_or_clone th = match subst with
| None -> | None -> use_export th t
use_export th t | Some s -> clone_export th t (type_inst th t s)
| Some s ->
let add_inst s = function
| CSns (p,q) ->
let find ns x = find_namespace_ns x ns in
let ns1 = option_fold find t.th_export p in
let ns2 = option_fold find (get_namespace th) q in
clone_ns loc t.th_local ns2 ns1 s
| CStsym (p,q) ->
let ts1 = find_tysymbol_ns p t.th_export in
let ts2 = find_tysymbol q th in
if Mts.mem ts1 s.inst_ts
then error ~loc (Clash ts1.ts_name.id_string);
{ s with inst_ts = Mts.add ts1 ts2 s.inst_ts }
| CSfsym (p,q) ->
let ls1 = find_fsymbol_ns p t.th_export in
let ls2 = find_fsymbol q th in
if Mls.mem ls1 s.inst_ls
then error ~loc (Clash ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSpsym (p,q) ->
let ls1 = find_psymbol_ns p t.th_export in
let ls2 = find_psymbol q th in
if Mls.mem ls1 s.inst_ls
then error ~loc (Clash ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSlemma p ->
let pr = find_prop_ns p t.th_export in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then error ~loc (Clash pr.pr_name.id_string);
{ s with inst_lemma = Spr.add pr s.inst_lemma }
| CSgoal p ->
let pr = find_prop_ns p t.th_export in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then error ~loc (Clash pr.pr_name.id_string);
{ s with inst_goal = Spr.add pr s.inst_goal }
in
let s = List.fold_left add_inst empty_inst s in
clone_export th t s
in
let n = match use.use_as with
| None -> Some t.th_name.id_string
| Some (Some x) -> Some x.id
| Some None -> None
in in
begin try match use.use_imp_exp with begin try match use.use_imp_exp with
| Nothing -> | Some imp ->
(* use T = namespace T use_export T end *) (* use T = namespace T use_export T end *)
let th = open_namespace th in let th = open_namespace th in
let th = use_or_clone th in let th = use_or_clone th in
close_namespace th false n close_namespace th imp use.use_as
| Import -> | None ->
(* use import T = namespace T use_export T end import T *) use_or_clone th
let th = open_namespace th in
let th = use_or_clone th in
close_namespace th true n
| Export ->
use_or_clone th
with ClashSymbol s -> error ~loc (Clash s) with ClashSymbol s -> error ~loc (Clash s)
end end
...@@ -1214,13 +1190,12 @@ let close_theory loc lenv th = ...@@ -1214,13 +1190,12 @@ let close_theory loc lenv th =
if Mstr.mem id lenv then error ~loc (ClashTheory id); if Mstr.mem id lenv then error ~loc (ClashTheory id);
Mstr.add id th lenv Mstr.add id th lenv
let close_namespace loc import name th = let close_namespace loc import id th =
let id = option_map (fun id -> id.id) name in
try close_namespace th import id try close_namespace th import id
with ClashSymbol s -> error ~loc (Clash s) with ClashSymbol s -> error ~loc (Clash s)
(* (*
Local Variables: Local Variables:
compile-command: "unset LANG; make -C ../.. test" compile-command: "unset LANG; make -C ../.."
End: End:
*) *)
...@@ -35,7 +35,7 @@ val add_use_clone : ...@@ -35,7 +35,7 @@ val add_use_clone :
unit Env.library -> theory Mstr.t -> theory_uc -> Ptree.use_clone -> theory_uc unit Env.library -> theory Mstr.t -> theory_uc -> Ptree.use_clone -> theory_uc
val close_namespace : val close_namespace :
Loc.position -> bool -> Ptree.ident option -> theory_uc -> theory_uc Loc.position -> bool -> string option -> theory_uc -> theory_uc
val close_theory : Loc.position -> theory Mstr.t -> theory_uc -> theory Mstr.t val close_theory : Loc.position -> theory Mstr.t -> theory_uc -> theory Mstr.t
...@@ -95,3 +95,4 @@ val list_fields: theory_uc -> ...@@ -95,3 +95,4 @@ val list_fields: theory_uc ->
(** check that the given fields all belong to the same record type (** check that the given fields all belong to the same record type
and do not appear several times *) and do not appear several times *)
val type_inst: theory_uc -> theory -> Ptree.clone_subst list -> th_inst
...@@ -2262,7 +2262,7 @@ let find_module penv lmod q id = match q with ...@@ -2262,7 +2262,7 @@ let find_module penv lmod q id = match q with
Mstr.find id lmod Mstr.find id lmod
| _ :: _ -> | _ :: _ ->
(* module in file f *) (* module in file f *)
Mstr.find id (Env.read_lib_file penv q) Mstr.find id (fst (Env.read_lib_file penv q))
(* env = to retrieve theories and modules from the loadpath (* env = to retrieve theories and modules from the loadpath
lmod = local modules *) lmod = local modules *)
...@@ -2346,22 +2346,13 @@ let rec decl ~wp env ltm lmod uc = function ...@@ -2346,22 +2346,13 @@ let rec decl ~wp env ltm lmod uc = function
with Not_found -> with Not_found ->
errorm ~loc "@[unbound module %a@]" print_qualid qid errorm ~loc "@[unbound module %a@]" print_qualid qid
in in
let n = match use_as with
| None -> Some (m.m_name.id_string)
| Some x -> Some x.id
in
begin try match imp_exp with begin try match imp_exp with
| Nothing -> | Some imp ->
(* use T = namespace T use_export T end *) (* use T = namespace T use_export T end *)
let uc = open_namespace uc in let uc = open_namespace uc in
let uc = use_export uc m in let uc = use_export uc m in
close_namespace uc false n close_namespace uc imp use_as
| Import -> | None ->
(* use import T = namespace T use_export T end import T *)
let uc = open_namespace uc in
let uc = use_export uc m in
close_namespace uc true n
| Export ->
use_export uc m use_export uc m
with ClashSymbol s -> with ClashSymbol s ->
errorm ~loc "clash with previous symbol %s" s errorm ~loc "clash with previous symbol %s" s
...@@ -2369,7 +2360,6 @@ let rec decl ~wp env ltm lmod uc = function ...@@ -2369,7 +2360,6 @@ let rec decl ~wp env ltm lmod uc = function
| Ptree.Dnamespace (loc, id, import, dl) -> | Ptree.Dnamespace (loc, id, import, dl) ->
let uc = open_namespace uc in let uc = open_namespace uc in
let uc = List.fold_left (decl ~wp env ltm lmod) uc dl in let uc = List.fold_left (decl ~wp env ltm lmod) uc dl in
let id = option_map (fun id -> id.id) id in
begin try close_namespace uc import id begin try close_namespace uc import id
with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end
| Ptree.Dlogic (TypeDecl d) -> | Ptree.Dlogic (TypeDecl d) ->
......
...@@ -26,5 +26,5 @@ val register : exn_printer -> unit ...@@ -26,5 +26,5 @@ val register : exn_printer -> unit
(* Register a formatter of exception *) (* Register a formatter of exception *)
val exn_printer : exn_printer val exn_printer : exn_printer
(* exn_printer fmt exn : print the exception using all the previously (* [exn_printer fmt exn] prints exception [exn] using all previously
registered printer and return *) registered printers and returns *)
...@@ -54,8 +54,6 @@ let user_position fname lnum cnum1 cnum2 = (fname,lnum,cnum1,cnum2) ...@@ -54,8 +54,6 @@ let user_position fname lnum cnum1 cnum2 = (fname,lnum,cnum1,cnum2)
let get loc = loc let get loc = loc
exception Located of position * exn
let dummy_position = ("",0,0,0) let dummy_position = ("",0,0,0)
let join (f1,l1,b1,e1) (f2,_,b2,e2) = let join (f1,l1,b1,e1) (f2,_,b2,e2) =
...@@ -77,9 +75,44 @@ let gen_report_position fmt (f,l,b,e) = ...@@ -77,9 +75,44 @@ let gen_report_position fmt (f,l,b,e) =
let report_position fmt = fprintf fmt "%a:@\n" gen_report_position let report_position fmt = fprintf fmt "%a:@\n" gen_report_position
(* located exceptions *)
exception Located of position * exn
let try1 loc f x =
try f x with Located _ as e -> raise e | e -> raise (Located (loc, e))
let try2 loc f x y =
try f x y with Located _ as e -> raise e | e -> raise (Located (loc, e))
let try3 loc f x y z =
try f x y z with Located _ as e -> raise e | e -> raise (Located (loc, e))
let try4 loc f x y z t =
try f x y z t 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))
(* located messages *)
exception Message of string
let errorm ?loc f =
let buf = Buffer.create 512 in
let fmt = Format.formatter_of_buffer buf in
Format.kfprintf
(fun _ ->
Format.pp_print_flush fmt ();
let s = Buffer.contents buf in
Buffer.clear buf;
error ?loc (Message s))
fmt f
let () = Exn_printer.register let () = Exn_printer.register
(fun fmt exn -> match exn with (fun fmt exn -> match exn with
| Located (loc,e) -> | Located (loc,e) ->
fprintf fmt "%a%a" report_position loc Exn_printer.exn_printer e fprintf fmt "%a%a" report_position loc Exn_printer.exn_printer e
| _ -> raise exn) | Message s ->