parserAux.ml 3.28 KB
Newer Older
1 2 3 4 5 6 7 8
open Positions
open Syntax

let current_token_precedence =
  let c = ref 0 in
  fun pos1 pos2 ->
    incr c;
    PrecedenceLevel (Error.get_filemark (), !c, pos1, pos2)
9

10 11 12 13 14 15 16 17 18 19 20 21
let current_reduce_precedence =
  let c = ref 0 in
  fun () ->
    incr c;
    PrecedenceLevel (Error.get_filemark (), !c, Lexing.dummy_pos, Lexing.dummy_pos)

module IdSet = Set.Make (struct
  type t = identifier located
  let compare id1 id2 =
    compare (value id1) (value id2)
end)

22
let defined_identifiers (_, ido, _) accu =
23 24
  Option.fold IdSet.add ido accu

25
let defined_identifiers producers =
26 27
  List.fold_right defined_identifiers producers IdSet.empty

28
let check_production_group right_hand_sides =
29 30 31 32
  begin
    match right_hand_sides with
    | [] ->
	assert false
33
    | (producers, _, _, _) :: right_hand_sides ->
34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
	let ids = defined_identifiers producers in
	List.iter (fun (producers, _, _, _) ->
	  let ids' = defined_identifiers producers in
	  try
	    let id =
	      IdSet.choose (IdSet.union
				  (IdSet.diff ids ids')
				  (IdSet.diff ids' ids))
	    in
	    Error.error [Positions.position id]
	      "Two productions that share a semantic action must define\n\
	       exactly the same identifiers."
	  with Not_found ->
	    ()
	  ) right_hand_sides
49
  end
50

Yann Régis-Gianas's avatar
Yann Régis-Gianas committed
51 52
(* [normalize_producer i p] assigns a name of the form [_i]
   to the unnamed producer [p]. *)
53 54 55 56 57 58 59 60
let normalize_producer i (pos, opt_identifier, parameter) =
  let id =
    match opt_identifier with
      | Some id -> id
      | None -> Positions.with_pos pos ("_" ^ string_of_int (i + 1))
  in
  (id, parameter)

61 62
let normalize_producers producers =
  List.mapi normalize_producer producers
63 64 65 66 67 68 69 70 71 72

let override pos o1 o2 =
  match o1, o2 with
  | Some _, Some _ ->
      Error.signal [ pos ] "This production carries two %prec declarations.";
      o2
  | None, Some _ ->
      o2
  | _, None ->
      o1
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

(* Support for on-the-fly expansion of anonymous rules. Whenever such
   a rule is encountered, we create a fresh non-terminal symbol, add
   a definition of this symbol to a global variable, and return a
   reference to this symbol. Quick and dirty. So, in the end, clean. *)

let fresh : unit -> string =
  let next = ref 0 in
  fun () ->
    Printf.sprintf "__anonymous_%d" (Misc.postincrement next)

let rules =
  ref []

let anonymous pos branches =
  (* Generate a fresh non-terminal symbol. *)
  let symbol = fresh() in
  (* Construct its definition. Note that it is implicitly marked %inline. *)
  let rule = {
    pr_public_flag = false; 
    pr_inline_flag = true;
    pr_nt          = symbol;
    pr_positions   = [ pos ]; (* this list is not allowed to be empty *)
    pr_parameters  = [];
    pr_branches    = branches
  } in
  (* Record this definition. *)
  rules := rule :: !rules;
  (* Return the symbol that stands for it. *)
  symbol

let rules () =
  let result = !rules in
  (* Reset the global state, in case we need to read several .mly files. *)
  rules := [];
  result

110
(* Only unnamed producers can be referred to using positional identifiers.
111 112
   Besides, such positions must be taken in the interval [1
   .. List.length producers]. The output array [p] is such that
113
   [p.(idx) = Some x] if [idx] must be referred to using [x], not
114 115
   [$(idx + 1)]. *)
let producer_names producers =
116 117 118 119
  producers
  |> List.map (fun (_, oid, _) -> Option.map Positions.value oid)
  |> Array.of_list