diff --git a/Changes b/Changes index 95dae98b659b..e4ea4dc14b80 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,7 @@ Bug fixes: - PR#4994: ocaml-mode doesn't work with xemacs21 * PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails, rather than raising 'Not_found' +- PR#5212: Improve ocamlbuild error messages of _tags parser - PR#5327: (Windows) Unix.select blocks if same socket listed in first and third arguments - PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound) diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index 9e43c5f3c774..64b818c1dc00 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -101,7 +101,7 @@ let env_path = lazy begin let paths = try parse_path (Lexing.from_string path_var) - with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg)) + with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos)) in let norm_current_dir_name path = if path = "" then Filename.current_dir_name else path diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index ffdd0392bcd6..ae71292bd793 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -32,17 +32,17 @@ let (configs, add_config) = configs := config :: !configs; Hashtbl.clear cache) -let parse_string s = - let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in +let parse_lexbuf ?dir source lexbuf = + lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source }; + let conf = Lexers.conf_lines dir lexbuf in add_config conf +let parse_string s = parse_lexbuf (Printf.sprintf "String %S" s) (Lexing.from_string s) + let parse_file ?dir file = - try - with_input_file file begin fun ic -> - let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in - add_config conf - end - with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg)) + with_input_file file begin fun ic -> + parse_lexbuf ?dir (Printf.sprintf "File %S" file) (Lexing.from_channel ic) + end let key_match = Glob.eval diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 06819f354760..199bc4fd241f 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -110,7 +110,7 @@ let rec query name = (* TODO: Improve to differenciate whether ocamlfind cannot be run or is not installed *) error Cannot_run_ocamlfind - | Lexers.Error s -> + | Lexers.Error (s,_) -> error (Cannot_parse_query (name, s)) let split_nl s = diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index d962d5cb06fa..ae4939aa4842 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -12,7 +12,7 @@ (* Original author: Nicolas Pouillard *) -exception Error of string +exception Error of (string * Lexing.position) type conf_values = { plus_tags : string list; @@ -36,7 +36,7 @@ val parse_environment_path : Lexing.lexbuf -> string list (* Same one, for Windows (PATH is ;-separated) *) val parse_environment_path_w : Lexing.lexbuf -> string list -val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf +val conf_lines : string option -> Lexing.lexbuf -> conf val path_scheme : bool -> Lexing.lexbuf -> [ `Word of string | `Var of (string * Glob.globber) diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 45029b356f30..12099febd7e2 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -13,7 +13,10 @@ (* Original author: Nicolas Pouillard *) { -exception Error of string +exception Error of (string * Lexing.position) + +let error lexbuf fmt = Printf.ksprintf (fun s -> raise (Error (s,Lexing.lexeme_start_p lexbuf))) fmt + open Glob_ast type conf_values = @@ -42,45 +45,45 @@ let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])* rule ocamldep_output = parse | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } | eof { [] } - | _ { raise (Error "Expecting colon followed by space-separated module name list") } + | _ { error lexbuf "Expecting colon followed by space-separated module name list" } and space_sep_strings_nl = parse | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } - | space* newline { [] } - | _ { raise (Error "Expecting space-separated strings terminated with newline") } + | space* newline { Lexing.new_line lexbuf; [] } + | _ { error lexbuf "Expecting space-separated strings terminated with newline" } and space_sep_strings = parse | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } | space* newline? eof { [] } - | _ { raise (Error "Expecting space-separated strings") } + | _ { error lexbuf "Expecting space-separated strings" } and blank_sep_strings = parse | blank* '#' not_newline* newline { blank_sep_strings lexbuf } | blank* '#' not_newline* eof { [] } | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } | blank* eof { [] } - | _ { raise (Error "Expecting blank-separated strings") } + | _ { error lexbuf "Expecting blank-separated strings" } and comma_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting comma-separated strings (1)") } + | _ { error lexbuf "Expecting comma-separated strings (1)" } and comma_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting comma-separated strings (2)") } + | _ { error lexbuf "Expecting comma-separated strings (2)" } and comma_or_blank_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") } + | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" } and comma_or_blank_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } + | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" } and parse_environment_path_w = parse | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } @@ -89,7 +92,7 @@ and parse_environment_path_w = parse and parse_environment_path_aux_w = parse | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } | eof { [] } - | _ { raise (Error "Impossible: expecting colon-separated strings") } + | _ { error lexbuf "Impossible: expecting colon-separated strings" } and parse_environment_path = parse | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } @@ -98,31 +101,35 @@ and parse_environment_path = parse and parse_environment_path_aux = parse | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | eof { [] } - | _ { raise (Error "Impossible: expecting colon-separated strings") } + | _ { error lexbuf "Impossible: expecting colon-separated strings" } -and conf_lines dir pos err = parse - | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf } +and conf_lines dir = parse + | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } | space* '#' not_newline* eof { [] } - | space* newline { conf_lines dir (pos + 1) err lexbuf } + | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } | space* eof { [] } | space* (not_newline_nor_colon+ as k) space* ':' space* { - let bexpr = Glob.parse ?dir k in - let v1 = conf_value pos err empty lexbuf in - let v2 = conf_values pos err v1 lexbuf in - let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest + let bexpr = + try Glob.parse ?dir k + with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) + in + let v1 = conf_value empty lexbuf in + let v2 = conf_values v1 lexbuf in + Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *) + let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest } - | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) } + | _ { error lexbuf "Invalid line syntax" } -and conf_value pos err x = parse +and conf_value x = parse | '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } } | '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } } - | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) } + | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } -and conf_values pos err x = parse - | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf } +and conf_values x = parse + | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf } | (newline | eof) { x } - | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) } + | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" } and path_scheme patt_allowed = parse | ([^ '%' ]+ as prefix) @@ -133,14 +140,13 @@ and path_scheme patt_allowed = parse { if patt_allowed then let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf - else raise (Error( - Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" - var patt)) } + else + error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } | '%' { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf } | eof { [] } - | _ { raise (Error("Bad pathanme scheme")) } + | _ { error lexbuf "Bad pathanme scheme" } and unescape = parse | '\\' (['(' ')'] as c) { c :: unescape lexbuf } @@ -156,11 +162,11 @@ and ocamlfind_query = parse "linkopts:" space* (not_newline* as lo) newline+ "location:" space* (not_newline* as l) newline+ { n, d, v, a, lo, l } - | _ { raise (Error "Bad ocamlfind query") } + | _ { error lexbuf "Bad ocamlfind query" } and trim_blanks = parse | blank* (not_blank* as word) blank* { word } - | _ { raise (Error "Bad input for trim_blanks") } + | _ { error lexbuf "Bad input for trim_blanks" } and tag_gen = parse | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param } diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index fcda4516c1ce..627b39f1dc68 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -277,8 +277,9 @@ let main () = | Ocaml_utils.Ocamldep_error msg -> Log.eprintf "Ocamldep error: %s" msg; exit rc_ocamldep_error - | Lexers.Error msg -> - Log.eprintf "Lexical analysis error: %s" msg; + | Lexers.Error (msg,pos) -> + let module L = Lexing in + Log.eprintf "%s, line %d, column %d: Lexing error: %s." pos.L.pos_fname pos.L.pos_lnum (pos.L.pos_cnum - pos.L.pos_bol) msg; exit rc_lexing_error | Arg.Bad msg -> Log.eprintf "%s" msg; diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index bc2ddfb44eca..dd74e1048ccc 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -145,7 +145,7 @@ let read_path_dependencies = with_input_file depends begin fun ic -> let ocamldep_output = try Lexers.ocamldep_output (Lexing.from_channel ic) - with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in + with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in let deps = List.fold_right begin fun (path, deps) acc -> let module_name' = module_name_of_pathname path in diff --git a/ocamlbuild/testsuite/level0.ml b/ocamlbuild/testsuite/level0.ml index b60e7cfd3444..96b2fbd19c33 100644 --- a/ocamlbuild/testsuite/level0.ml +++ b/ocamlbuild/testsuite/level0.ml @@ -64,10 +64,16 @@ test "camlp4.opt" ~matching:[M.x "dummy.native" ~output:"Hello"] ~targets:("dummy.native",[]) ();; -test "TagsErrorMessage" - ~description:"Confirm relevance of an error message due to erronous _tags" - ~failing_msg:"Failure: lexing: empty token." - ~tree:[T.f "_tags" ~content:"* : not_hygienic"] - ~targets:("none.native",[]) ();; +let tag_pat_msgs = + ["*:a", "File \"_tags\", line 1, column 0: Lexing error: Invalid globbing pattern \"*\"."; + "\n<*{>:a", "File \"_tags\", line 2, column 0: Lexing error: Invalid globbing pattern \"<*{>\"."; + "<*>: ~@a,# ~a", "File \"_tags\", line 1, column 10: Lexing error: Only ',' separated tags are alllowed."];; + +List.iteri (fun i (content,failing_msg) -> + test (Printf.sprintf "TagsErrorMessage_%d" (i+1)) + ~description:"Confirm relevance of an error message due to erronous _tags" + ~failing_msg + ~tree:[T.f "_tags" ~content; T.f "dummy.ml"] + ~targets:("dummy.native",[]) ()) tag_pat_msgs;; run ~root:"_test";;