File: cmly_read.ml

package info (click to toggle)
menhir 20210929-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, sid
  • size: 4,292 kB
  • sloc: ml: 24,825; sh: 180; makefile: 100; lisp: 8
file content (340 lines) | stat: -rw-r--r-- 9,204 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
(******************************************************************************)
(*                                                                            *)
(*                                   Menhir                                   *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU General Public License version 2, as described in the    *)
(*  file LICENSE.                                                             *)
(*                                                                            *)
(******************************************************************************)

open Cmly_format
open Cmly_api

(* ------------------------------------------------------------------------ *)

(* Reading a .cmly file. *)

exception Error of string

let read (ic : in_channel) : grammar =
  (* .cmly file format: CMLY ++ version string ++ grammar *)
  let magic = "CMLY" ^ Version.version in
  try
    let m = really_input_string ic (String.length magic) in
    if m <> magic then
      raise (Error (Printf.sprintf "Invalid magic string in .cmly file.\n\
                 Expecting %S, but got %S." magic m))
    else
      (input_value ic : grammar)
  with
  | End_of_file  (* [really_input_string], [input_value] *)
  | Failure _ -> (* [input_value] *)
      raise (Error (Printf.sprintf "Invalid or damaged .cmly file."))

let read (filename : string) : grammar =
  let ic = open_in_bin filename in
  match read ic with
  | x ->
      close_in_noerr ic;
      x
  | exception exn ->
      close_in_noerr ic;
      raise exn

(* ------------------------------------------------------------------------ *)

(* Packaging the interval [0..count) as a module of type [INDEXED]. *)

module Index (P : sig
  val name: string (* for error messages only *)
  val count: int
end)
: INDEXED with type t = int
= struct

  type t = int

  let count = P.count

  let of_int n =
    if 0 <= n && n < count then n
    else invalid_arg (P.name ^ ".of_int: index out of bounds")

  let to_int n = n

  let iter f =
    for i = 0 to count - 1 do
      f i
    done

  let fold f x =
    let r = ref x in
    for i = 0 to count - 1 do
      r := f i !r
    done;
    !r

  let tabulate f =
    let a = Array.init count f in
    Array.get a

end

(* ------------------------------------------------------------------------ *)

(* Packaging a data structure of type [Cmly_format.grammar] as a module
   of type [Cmly_api.GRAMMAR]. *)

module Make (G : sig val grammar : grammar end) : GRAMMAR = struct
  open G

  type terminal    = int
  type nonterminal = int
  type production  = int
  type lr0         = int
  type lr1         = int
  type item        = production * int
  type ocamltype   = string
  type ocamlexpr   = string

  module Range = struct

    type t =
      Cmly_format.range

    let startp range =
      range.r_start

    let endp range =
      range.r_end

  end

  module Attribute = struct

    type t =
      Cmly_format.attribute

    let label attr =
      attr.a_label

    let has_label label attr =
      label = attr.a_label

    let payload attr =
      attr.a_payload

    let position attr =
      attr.a_position

  end

  module Grammar = struct
    let basename     = grammar.g_basename
    let preludes     = grammar.g_preludes
    let postludes    = grammar.g_postludes
    let entry_points = grammar.g_entry_points
    let attributes   = grammar.g_attributes
    let parameters   = grammar.g_parameters
  end

  module Terminal = struct
    let table = grammar.g_terminals
    let name       i = table.(i).t_name
    let kind       i = table.(i).t_kind
    let typ        i = table.(i).t_type
    let attributes i = table.(i).t_attributes
    include Index(struct
      let name = "Terminal"
      let count = Array.length table
    end)
  end

  module Nonterminal = struct
    let table = grammar.g_nonterminals
    let name         i = table.(i).n_name
    let mangled_name i = table.(i).n_mangled_name
    let kind         i = table.(i).n_kind
    let typ          i = table.(i).n_type
    let positions    i = table.(i).n_positions
    let nullable     i = table.(i).n_nullable
    let first        i = table.(i).n_first
    let attributes   i = table.(i).n_attributes
    include Index(struct
      let name = "Nonterminal"
      let count = Array.length table
    end)
  end

  type symbol = Cmly_format.symbol =
    | T of terminal
    | N of nonterminal

  let symbol_name ?(mangled=false) = function
    | T t ->
        Terminal.name t
    | N n ->
        if mangled then Nonterminal.mangled_name n
        else Nonterminal.name n

  type identifier = string

  module Action = struct
    type t = action
    let expr      t = t.a_expr
    let keywords  t = t.a_keywords
  end

  module Production = struct
    let table = grammar.g_productions
    let kind       i = table.(i).p_kind
    let lhs        i = table.(i).p_lhs
    let rhs        i = table.(i).p_rhs
    let positions  i = table.(i).p_positions
    let action     i = table.(i).p_action
    let attributes i = table.(i).p_attributes
    include Index(struct
      let name = "Production"
      let count = Array.length table
    end)
  end

  module Lr0 = struct
    let table = grammar.g_lr0_states
    let incoming i = table.(i).lr0_incoming
    let items    i = table.(i).lr0_items
    include Index(struct
      let name = "Lr0"
      let count = Array.length table
    end)
  end

  module Lr1 = struct
    let table = grammar.g_lr1_states
    let lr0         i = table.(i).lr1_lr0
    let transitions i = table.(i).lr1_transitions
    let reductions  i = table.(i).lr1_reductions
    include Index(struct
      let name = "Lr1"
      let count = Array.length table
    end)
  end

  module Print = struct

    let terminal ppf t =
      Format.pp_print_string ppf (Terminal.name t)

    let nonterminal ppf t =
      Format.pp_print_string ppf (Nonterminal.name t)

    let symbol ppf = function
      | T t -> terminal ppf t
      | N n -> nonterminal ppf n

    let mangled_nonterminal ppf t =
      Format.pp_print_string ppf (Nonterminal.name t)

    let mangled_symbol ppf = function
      | T t -> terminal ppf t
      | N n -> mangled_nonterminal ppf n

    let rec lengths l acc = function
      | [] ->
          if l = -1 then []
          else l :: lengths (-1) [] acc
      | [] :: rows ->
          lengths l acc rows
      | (col :: cols) :: rows ->
          lengths (max l (String.length col)) (cols :: acc) rows

    let rec adjust_length lengths cols =
      match lengths, cols with
      | l :: ls, c :: cs ->
          let pad = l - String.length c in
          let c =
            if pad = 0 then c
            else c ^ String.make pad ' '
          in
          c :: adjust_length ls cs
      | _, [] -> []
      | [], _ -> assert false

    let align_tabular rows =
      let lengths = lengths (-1) [] rows in
      List.map (adjust_length lengths) rows

    let print_line ppf = function
      | [] -> ()
      | x :: xs ->
          Format.fprintf ppf "%s" x;
          List.iter (Format.fprintf ppf " %s") xs

    let print_table ppf table =
      let table = align_tabular table in
      List.iter (Format.fprintf ppf "%a\n" print_line) table

    let annot_itemset annots ppf items =
      let last_lhs = ref (-1) in
      let prepare (p, pos) annot =
        let rhs =
          Array.map (fun (sym, id, _) ->
            if id <> "" && id.[0] <> '_' then
              "(" ^ id ^ " = " ^ symbol_name sym ^ ")"
            else symbol_name sym
          ) (Production.rhs p)
        in
        if pos >= 0 && pos < Array.length rhs then
          rhs.(pos) <- ". " ^ rhs.(pos)
        else if pos > 0 && pos = Array.length rhs then
          rhs.(pos - 1) <- rhs.(pos - 1) ^ " .";
        let lhs = Production.lhs p in
        let rhs = Array.to_list rhs in
        let rhs =
          if !last_lhs = lhs then
            "" :: "  |" :: rhs
          else begin
            last_lhs := lhs;
            Nonterminal.name lhs :: "::=" :: rhs
          end
        in
        if annot = [] then
          [rhs]
        else
          [rhs; ("" :: "" :: annot)]
      in
      let rec prepare_all xs ys =
        match xs, ys with
        | [], _ ->
            []
        | (x :: xs), (y :: ys) ->
            let z = prepare x y in
            z :: prepare_all xs ys
        | (x :: xs), [] ->
            let z = prepare x [] in
            z :: prepare_all xs []
      in
      print_table ppf (List.concat (prepare_all items annots))

    let itemset ppf t =
      annot_itemset [] ppf t

    let annot_item annot ppf item =
      annot_itemset [annot] ppf [item]

    let item ppf t =
      annot_item [] ppf t

    let production ppf t =
      item ppf (t, -1)

  end

end

module Read (X : sig val filename : string end) =
  Make (struct let grammar = read X.filename end)