Source file `ExtMenhirLib.ml`

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
(**************************************************************************)
(*  Copyright (C) 2017-2023 Yann Régis-Gianas, Nicolas Jeannerod,         *)
(*  Ralf Treinen.                                                         *)
(*                                                                        *)
(*  This is free software: you can redistribute it and/or modify it       *)
(*  under the terms of the GNU General Public License, version 3.         *)
(*                                                                        *)
(*  Additional terms apply, due to the reproduction of portions of        *)
(*  the POSIX standard. Please refer to the file COPYING for details.     *)
(**************************************************************************)

open Parser.MenhirInterpreter
open MenhirLib.General

let current_items parsing_state =
  match Lazy.force (stack parsing_state) with
    | Nil ->
      []
    | Cons (Element (s, _, _, _), _) ->
      items s

type 'a status =
  | AcceptedNow of 'a
  | Fine
  | Wrong

let rec close checkpoint =
  match checkpoint with
    | AboutToReduce (_, _) | Shifting _ -> close (resume checkpoint)
    | Rejected | HandlingError _ -> Wrong
    | Accepted x -> AcceptedNow x
    | InputNeeded _ -> Fine

let accepted_token checkpoint token =
  match checkpoint with
    | InputNeeded _ -> close (offer checkpoint token)
    | _ -> Wrong

let is_accepted_token checkpoint token =
  accepted_token checkpoint token <> Wrong

let accepted_raw_token checkpoint raw_token =
  accepted_token checkpoint (raw_token, Lexing.dummy_pos, Lexing.dummy_pos)

(** [finished checkpoint] is [true] if the current [checkpoint] can
    move the LR(1) automaton to an accepting state with no extra
    input.
*)
let rec finished = function
  | Accepted _ -> true
  | (AboutToReduce (_, _) | Shifting (_, _, _)) as checkpoint ->
    finished (resume checkpoint)
  | _ -> false

(** [nonterminal_production p] returns the non terminal of [p].
    The nonterminals of Menhir API are a too precisely typed for
    our needs. Hence, we introduce an extential type for weaken
    this precision. *)
type nonterminal =
  AnyN : 'a Parser.MenhirInterpreter.nonterminal -> nonterminal

let nonterminal_of_production p =
  match lhs p with
  | X (N nt) -> AnyN nt
  | _ -> assert false (* Because every production as a nonterminal. *)

exception EmptyStack

type 'b top_symbol_processor = {
   perform : 'a. 'a symbol * 'a -> 'b
}

let on_top_symbol env f =
  match top env with
  | Some (Element (state, v, _, _)) -> f.perform (incoming_symbol state, v)
  | _ -> raise EmptyStack