Commit 557e662e authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Sanitize the handling of error messages.

parent 7c757365
......@@ -120,12 +120,10 @@ let rec print_exn ppf = function
Format.fprintf ppf "Unbound external identifier %a:%a@."
U.print (Librarian.name cu)
Ident.print x
(*| Sedlexer.Error (i,j,s) ->
let loc = Cduce_loc.loc_of_pos (i,j), `Full in
Cduce_loc.print_loc ppf loc;
Cduce_loc.html_hilight loc;
Format.fprintf ppf "%s" s *)
| Parse.Error s | Stream.Error s ->
| Ast.Parsing_error s | Stream.Error s ->
if s = "" then
Format.fprintf ppf "Parsing error@."
else
Format.fprintf ppf "Parsing error: %a@." print_protect s
| Librarian.InconsistentCrc name ->
Format.fprintf ppf "Link error:@.";
......@@ -302,7 +300,8 @@ let catch_exn ppf_err exn =
Format.fprintf ppf_err "@."
let parse rule input =
try Parse.localize_exn (fun () -> rule input)
try
rule input
with e -> Parse.sync (); raise e
let run rule ppf ppf_err input =
......
......@@ -3,6 +3,8 @@
open Cduce_loc
open Ident
exception Parsing_error of string
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
type pprog = pmodule_item list
......
%{
open Ast
open Ident
......@@ -6,6 +7,9 @@ let tloc (i,j) = (i.Lexing.pos_cnum, j.Lexing.pos_cnum)
let nopos = (-1,-1)
let lnopos = Lexing.dummy_pos, Lexing.dummy_pos
let parsing_error pos msg =
let i, j = tloc pos in
Cduce_loc.raise_loc i j (Ast.Parsing_error msg)
let mk loc x = Cduce_loc.mk_located (tloc loc) x
let mknoloc x = Cduce_loc.mknoloc x
......@@ -182,7 +186,6 @@ let id_dummy = U.mk "$$$"
%start <Ast.pprog> prog
%start <Ast.pprog> top_phrases
%type <Ast.ppat> pat
%start <Ast.pexpr> expr_eoi
%%
/* Macros */
......@@ -198,10 +201,6 @@ x=X { mk $sloc x }
/* Toplevel definitions */
expr_eoi:
e = expr EOI { e }
;
top_phrases:
| e = multi_expr ";;" { [ mk $sloc (EvalStatement e) ] }
......@@ -263,7 +262,7 @@ match n with
| "sample", [t] -> `Sample t
| "subtype", [t1; t2] -> `Subtype (t1, t2)
| "single", [t] -> `Single t
| _ -> raise Error
| _ -> parsing_error $loc(d) (Format.sprintf "Invalid debug directive %s" d)
in Directive (`Debug dir)
}
| d = HASH_DIRECTIVE {
......@@ -275,7 +274,7 @@ match n with
| "#reinit_ns" -> `Reinit_ns
| "#help" -> `Help
| "#builtins" -> `Builtins
| _ -> raise Error
| _ -> parsing_error $loc(d) (Format.sprintf "Invalid toplevel directive %s" d)
in Directive dir
}
| HASH_PRINT_TYPE t = pat { Directive(`Print_type t) }
......@@ -345,7 +344,8 @@ constr_pat:
| Some i, Some j ->
let i = V.mk i and j = V.mk j in
mk $sloc (Internal (Types.interval (bounded i j)))
| None, None -> raise Error
| None, None -> parsing_error $sloc
(Format.sprintf "Invalid interval *--*")
}
| i = INT {
let open Intervals in
......@@ -532,12 +532,14 @@ regexp_and:
| x = regexp_and "&" y = regexp_acc {
match x, y with
Elem x, Elem y -> Elem (mk $sloc (And (x, y)))
| _ -> raise Error
| _ -> parsing_error $sloc
"Conjunction not allowed in regular expression"
}
| x = regexp_and "\\" y = regexp_acc {
match x, y with
Elem x, Elem y -> Elem (mk $sloc (Diff (x, y)))
| _ -> raise Error
| _ -> parsing_error $sloc
"Difference not allowed in regular expression"
}
| r = regexp_acc { r }
......@@ -565,15 +567,16 @@ regexp_simple:
try
let i = int_of_string i in
if (i > 1024) then raise Exit else i
with Failure _ | Exit -> raise Error
with Failure _ | Exit -> parsing_error $loc(i) "Repetition number too large"
in
if i <= 0 then raise Error;
if i <= 0 then parsing_error $sloc "Repetition number must be a positive integer";
aux i Epsilon
}
| "(" x = separated_nonempty_list(",", regexp) ")" {
match x with
[ x ] -> x
| _ -> let x = List.map (function Elem x -> x | _ -> raise Error) x
| _ -> let x = List.map (function Elem x -> x | _ ->
parsing_error $sloc "Mixing regular expressions and products") x
in
Elem (multi_prod $sloc x)
}
......@@ -626,7 +629,7 @@ namespace_binding:
| _, (`Path _ as path) ->`Prefix(ident name, path)
| "on", `Empty -> `Keep true
| "off", `Empty -> `Keep false
| _ -> raise Error
| _ -> parsing_error $sloc "Invalid namespace specification"
}
;
......
......@@ -3,7 +3,6 @@ module L = Sedlexing
exception Error of int * int * string
let error i j s = raise (Error (i, j, s))
(* Buffer for string literals *)
......
exception Error of string
(* Taken from Menhir/Lib/Convert.ml*)
let for_sedlex parser =
......@@ -64,21 +61,23 @@ let mk_lexbuf cs =
lexbuf
let stream_of ic =
Stream.from (fun _ ->
match input_char ic with
c -> Some c
| exception End_of_file -> close_in ic; None
| exception e -> close_in ic; raise e
)
let include_stack = ref []
let pre_prog = for_sedlex Cparser.prog
let close_in ic =
try close_in ic with _ -> ()
let exit_include ic =
close_in ic;
Cduce_loc.pop_source ();
include_stack := List.tl !include_stack
let last_tok = ref Cparser.EOI
let last_tok_pos = ref (Lexing.dummy_pos, Lexing.dummy_pos)
let rec token lexbuf =
let f = Sedlexing.with_tokenizer Csedlexer.token lexbuf in
let last_tok = ref Cparser.EOI in
let f () =
let tok, p1, p2 = f () in
let tok =
......@@ -88,36 +87,63 @@ let rec token lexbuf =
let path = Cduce_loc.resolve_filename path in
if List.mem path !include_stack then tok
else begin
let ic =
try
open_in path
with
Sys_error msg ->
let last_p1, _ = !last_tok_pos in
Cduce_loc.raise_loc last_p1.Lexing.pos_cnum p2.Lexing.pos_cnum
(Ast.Parsing_error (Format.sprintf "include \"%s\" : %s" path msg))
in
include_stack := path :: !include_stack;
Cduce_loc.push_source (`File path);
let ic = open_in path in (* TODO Handle error *)
let cs = stream_of ic in
let newlb = mk_lexbuf cs in
let past = pre_prog (token newlb) in
Cduce_loc.pop_source ();
include_stack := List.tl !include_stack;
Cparser.RESOLVED_INCLUDE past
try
let cs = Stream.of_channel ic in
let newlb = mk_lexbuf cs in
let past = pre_prog (token newlb) in
exit_include ic;
Cparser.RESOLVED_INCLUDE past
with e ->
exit_include ic;
raise e
end
| _ -> tok
in
last_tok := tok;
last_tok_pos := (p1, p2);
(tok, p1, p2)
in f
let rec sync f =
match !last_tok with
Cparser.EOI | Cparser.SEMISEMI -> ()
| t ->
let tok, p1, p2 = f () in
last_tok := tok;
last_tok_pos := (p1, p2);
sync f
let protect_parser gram stream =
let protect_parser do_sync gram stream =
let b = mk_lexbuf stream in
try
gram (token b)
let f = token b in
try
gram f
with
e ->
if do_sync then sync f;
raise e
with
Cparser.Error ->
let loc1, loc2 = Sedlexing.lexing_positions b in
Cduce_loc.raise_loc loc1.Lexing.pos_cnum loc2.Lexing.pos_cnum (Error "")
Cduce_loc.raise_loc loc1.Lexing.pos_cnum loc2.Lexing.pos_cnum (Ast.Parsing_error "")
| Csedlexer.Error (i, j, msg) ->
Cduce_loc.raise_loc i j (Ast.Parsing_error msg)
let prog cs = protect_parser pre_prog cs
let top_phrases cs = protect_parser (for_sedlex Cparser.top_phrases) cs
let prog cs = protect_parser false pre_prog cs
let top_phrases cs = protect_parser true (for_sedlex Cparser.top_phrases) cs
......@@ -127,5 +153,3 @@ let protect_exn f g =
let sync () = ()
let localize_exn f = (* TODO Location *)
f ()
exception Error of string
val top_phrases : char Stream.t -> Ast.pmodule_item list
val prog : char Stream.t -> Ast.pmodule_item list
val sync : unit -> unit
val localize_exn: (unit -> 'a) -> 'a
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