cmly_read.ml 8.99 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
(******************************************************************************)
(*                                                                            *)
(*                                   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.                                                             *)
(*                                                                            *)
(******************************************************************************)

14 15 16 17 18 19 20 21 22 23
open Cmly_format
open Cmly_api

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

(* Reading a .cmly file. *)

exception Error of string

let read (ic : in_channel) : grammar =
24 25
  (* .cmly file format: CMLY ++ version string ++ grammar *)
  let magic = "CMLY" ^ Version.version in
26
  try
27 28 29 30
    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))
31 32 33 34 35 36 37 38 39
    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
40 41 42 43 44 45 46
  match read ic with
  | x ->
      close_in_noerr ic;
      x
  | exception exn ->
      close_in_noerr ic;
      raise exn
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

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

(* 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
101
  type ocamltype   = string
102
  type ocamlexpr   = string
103

104 105 106 107 108 109 110 111 112 113 114 115 116
  module Range = struct

    type t =
      Cmly_format.range

    let startp range =
      range.r_start

    let endp range =
      range.r_end

  end

117
  module Attribute = struct
118

119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
    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
135 136 137

  module Grammar = struct
    let basename     = grammar.g_basename
138 139
    let preludes     = grammar.g_preludes
    let postludes    = grammar.g_postludes
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
    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
164
    let nullable     i = table.(i).n_nullable
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
    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)