Project

General

Profile

Download (5.5 KB) Statistics
| Branch: | Tag: | Revision:
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11
open Utils.Format
12

    
13
module I = Parser_lustre_table.MenhirInterpreter
14
module Inc = Parser_lustre_table.Incremental
15
module E = MenhirLib.ErrorReports
16
module L = MenhirLib.LexerUtil
17

    
18
exception Error
19

    
20
type start_symbol =
21
  | Header
22
  | Program
23

    
24
(* [env checkpoint] extracts a parser environment out of a checkpoint,
25
   which must be of the form [HandlingError env]. *)
26
let env checkpoint =
27
  match checkpoint with
28
  | I.HandlingError env -> env
29
  | _ -> assert false
30

    
31
(* [state checkpoint] extracts the number of the current state out of a
32
   checkpoint. *)
33
let state checkpoint : int =
34
  match I.top (env checkpoint) with
35
  | Some (I.Element (s, _, _, _)) ->
36
    I.number s
37
  | None ->
38
    (* Hmm... The parser is in its initial state. The incremental API
39
       currently lacks a way of finding out the number of the initial
40
       state. It is usually 0, so we return 0. This is unsatisfactory
41
       and should be fixed in the future. *)
42
      0
43

    
44
(* [show text (pos1, pos2)] displays a range of the input text [text]
45
   delimited by the positions [pos1] and [pos2]. *)
46
let show text positions =
47
  E.extract text positions
48
  |> E.sanitize
49
  |> E.compress
50
  |> E.shorten 20 (* max width 43 *)
51

    
52
(* (\* [get text checkpoint i] extracts and shows the range of the input text that
53
 *    corresponds to the [i]-th stack cell. The top stack cell is numbered zero. *\)
54
 * let get text checkpoint i =
55
 *   match I.get i (env checkpoint) with
56
 *   | Some (I.Element (_, _, pos1, pos2)) ->
57
 *     show text (pos1, pos2)
58
 *   | None ->
59
 *     (\* The index is out of range. This should not happen if [$i]
60
 *        keywords are correctly inside the syntax error message
61
 *        database. The integer [i] should always be a valid offset
62
 *        into the known suffix of the stack. *\)
63
 *     "???" *)
64

    
65
module type LEXER = sig
66
  val token: Lexing.lexbuf -> Parser_lustre.token
67
  type error
68
  exception Error of Location.t * error
69
  val pp_error: formatter -> error -> unit
70
end
71

    
72
let reparse (module Lexer : LEXER) ?orig_loc filename start src =
73
  (* Allocate and initialize a lexing buffer. *)
74
  let lexbuf = L.init filename (Lexing.from_string src) in
75
  (* Wrap the lexer and lexbuf together into a supplier, that is, a
76
     function of type [unit -> token * position * position]. *)
77
  let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in
78
  (* Equip the supplier with a two-place buffer that records the positions
79
     of the last two tokens. This is useful when a syntax error occurs, as
80
     these are the token just before and just after the error. *)
81
  let buffer, supplier = E.wrap_supplier supplier in
82
  (* Fetch the parser's initial checkpoint. *)
83
  let checkpoint = start lexbuf.lex_curr_p in
84
  (* [succeed v] is invoked when the parser has succeeded and produced a
85
     semantic value [v]. In our setting, this cannot happen, since the
86
     table-based parser is invoked only when we know that there is a
87
     syntax error in the input file. *)
88
  let succeed _v = assert false in
89
  (* [fail checkpoint] is invoked when parser has encountered a syntax error. *)
90
  let fail (checkpoint : _ I.checkpoint) =
91
    (* Indicate where in the input file the error occurred. *)
92
    let loc = E.last buffer in
93
    let loc = match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc in
94
    (* Show the tokens just before and just after the error. *)
95
    let indication = E.show (show src) buffer in
96
    (* Fetch an error message from the database. *)
97
    let message = Parser_lustre_messages.message (state checkpoint) in
98
    (* Expand away the $i keywords that might appear in the message. *)
99
    (* let message = E.expand (get src checkpoint) message in *)
100
    (* Show these three components. *)
101
    eprintf "@[<v>%aSyntax error %s.@,%s@]@."
102
      Location.pp_loc loc indication message;
103
    raise Error
104
  in
105
  (* Run the parser. *)
106
  (* We do not handle [Lexer.Error] because we know that we will not
107
     encounter a lexical error during this second parsing run. *)
108
  I.loop_handle succeed fail supplier checkpoint
109

    
110
let parse (module Lexer : LEXER) ?orig_loc filename src lexbuf start_mono start_incr =
111
  let lexbuf = L.init filename lexbuf in
112
  try
113
    start_mono Lexer.token lexbuf
114
  with
115
  | Lexer.Error (loc, err) ->
116
    let loc = match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc in
117
    eprintf "@[<v>%aSyntax error.@,%a@]@."
118
      Location.pp_loc loc Lexer.pp_error err;
119
    raise Error
120
  | Parser_lustre.Error ->
121
    reparse (module Lexer) ?orig_loc filename start_incr src
122

    
123
let parse_filename (module Lexer : LEXER) filename start =
124
  let start_mono, start_incr = match start with
125
    | Header -> Parser_lustre.header, Inc.header
126
    | Program -> Parser_lustre.prog, Inc.prog
127
  in
128
  let src, lexbuf = L.read filename in
129
  Location.set_input filename;
130
  parse (module Lexer) filename src lexbuf start_mono start_incr
131

    
132
(* Local Variables: *)
133
(* compile-command:"make -C .." *)
134
(* End: *)
(5-5/8)