← Back to branch summary

~ubuntu-branches/ubuntu/quantal/menhir/quantal

« back to all changes in this revision

Viewing changes to src/error.ml

  • Committer: Package Import Robot
  • Author(s): Mehdi Dogguy
  • Date: 2012-01-23 20:50:25 UTC
  • mfrom: (1.1.8) (2.1.7 sid)
  • Revision ID: package-import@ubuntu.com-20120123205025-nd325ikf9gmqe1v7
Tags: 20120123.dfsg-1
* New upstream release
  - fixes http://caml.inria.fr/mantis/view.php?id=5462

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/error.ml
22
22
(* TEMPORARY reprendre compl`etement implementation et interface
23
23
   de ce module *)
24
24
 
25
 
let log kind verbosity msg =
26
 
  if kind >= verbosity then
27
 
    Printf.fprintf stderr "%t%!" msg
28
 
 
29
 
let logG =
30
 
  log Settings.logG
31
 
 
32
 
let logA =
33
 
  log Settings.logA
34
 
 
35
 
let logC =
36
 
  log Settings.logC
 
25
(* ---------------------------------------------------------------------------- *)
 
26
 
 
27
(* Global state. *)
37
28
 
38
29
let get_initialized_ref ref =
39
30
  match !ref with
42
33
  | Some contents ->
43
34
      contents
44
35
 
45
 
let basename =
 
36
let filename =
46
37
  ref (None : string option)
47
38
 
48
39
let filemark =
49
40
  ref Mark.none
50
41
 
 
42
(* 2011/10/19: do not use [Filename.basename]. The [#] annotations that
 
43
   we insert in the [.ml] file must retain their full path. This does
 
44
   mean that the [#] annotations depend on how menhir is invoked -- e.g.
 
45
   [menhir foo/bar.mly] and [cd foo && menhir bar.mly] will produce
 
46
   different files. Nevertheless, this seems useful/reasonable. *)
 
47
 
 
48
(* This also influences the type error messages produced by [--infer]. *)
 
49
 
51
50
let set_filename name =
52
 
  basename := Some (Filename.basename name);
 
51
  filename := Some name;
53
52
  filemark := Mark.fresh()
54
53
 
55
 
let get_basename () =
56
 
  get_initialized_ref basename
 
54
let get_filename () =
 
55
  get_initialized_ref filename
57
56
 
58
57
let get_filemark () =
59
58
  !filemark
60
59
 
 
60
let file_contents =
 
61
  ref (None : string option)
 
62
 
 
63
let get_file_contents () =
 
64
  get_initialized_ref file_contents
 
65
 
 
66
(* ---------------------------------------------------------------------------- *)
 
67
 
 
68
(* Logging and log levels. *)
 
69
 
 
70
let log kind verbosity msg =
 
71
  if kind >= verbosity then
 
72
    Printf.fprintf stderr "%t%!" msg
 
73
 
 
74
let logG =
 
75
  log Settings.logG
 
76
 
 
77
let logA =
 
78
  log Settings.logA
 
79
 
 
80
let logC =
 
81
  log Settings.logC
 
82
 
 
83
(* ---------------------------------------------------------------------------- *)
 
84
 
 
85
(* Errors and warnings. *)
 
86
 
61
87
let errors =
62
88
  ref false
63
89
 
67
93
  ) positions;
68
94
  fprintf stderr "%s\n%!" message
69
95
 
70
 
let errorN positions message =
71
 
  printN positions (Printf.sprintf "Error: %s" message);
 
96
let error_message message =
 
97
  "Error: " ^ message
 
98
 
 
99
let error positions message =
 
100
  printN positions (error_message message);
72
101
  exit 1
73
102
 
74
 
let error_lexbuf lexbuf message =
75
 
  errorN [ Positions.lex_join lexbuf.Lexing.lex_start_p lexbuf.Lexing.lex_curr_p ] message
76
 
 
77
103
let errorp v message =
78
 
  errorN [ Positions.position v ] message
79
 
 
80
 
let error1 position message =
81
 
  errorN [ Positions.lex_join position position ] message
82
 
 
83
 
let error message =
84
 
  errorN [] message
85
 
 
86
 
let signalN positions message =
 
104
  error [ Positions.position v ] message
 
105
 
 
106
let signal positions message =
87
107
  printN positions message;
88
108
  errors := true
89
109
 
90
 
let signal position1 position2 message =
91
 
  signalN [ Positions.lex_join position1 position2 ] message
92
 
 
93
 
let signalp v message =
94
 
  signalN [ Positions.position v ] message
95
 
 
96
 
let file =
97
 
  ref (None : in_channel option)
98
 
 
99
 
let get_file () =
100
 
  get_initialized_ref file
101
 
 
102
 
let warningN positions message =
 
110
let warning positions message =
103
111
  printN positions (Printf.sprintf "Warning: %s" message)
104
112
 
105
 
let warningp v message =
106
 
  warningN [ Positions.position v ] message
107
 
 
108
 
let warning2 position1 position2 message =
109
 
  warningN [ Positions.lex_join position1 position2 ] message
110
 
 
111
 
let warning message =
112
 
  warningN [] message
113
 
 
114
113
let errors () =
115
114
  !errors
116
115
 
 
116
(* Certain warnings about the grammar can optionally be treated as errors.
 
117
   The following function emits a warning or error message, via [warning] or
 
118
   [signal]. It does not stop the program; the client must at some point call
 
119
   [errors] and stop the program if any errors have been reported. *)
 
120
 
 
121
let grammar_warning positions message =
 
122
  if Settings.strict then
 
123
    signal positions (error_message message)
 
124
  else
 
125
    warning positions message
 
126