parameterizedGrammar.ml 21.7 KB
Newer Older
1 2 3 4 5 6 7 8 9
open Positions
open Syntax
open UnparameterizedSyntax
open Misc

(* Inference for non terminals. *)

(* Unification variables convey [variable_info] to describe
   the multi-equation they take part of. *)
POTTIER Francois's avatar
POTTIER Francois committed
10
type variable_info =
11 12 13 14 15 16 17 18 19 20
    {
      mutable structure : nt_type option;
      mutable name      : string option;
      mutable mark      : Mark.t
    }

(* [UnionFind] is used to improve the union and the equality test
   between multi-equations. *)
and variable = variable_info UnionFind.point

POTTIER Francois's avatar
POTTIER Francois committed
21
(* Types are simple types.
22 23
   [star] denotes the type of ground symbol (non terminal or terminal).
   [Arrow] describes the type of a parameterized non terminal. *)
POTTIER Francois's avatar
POTTIER Francois committed
24 25
and nt_type =
    Arrow of variable list
26 27 28 29 30 31 32

let star =
  Arrow []

(* [var_name] is a name generator for unification variables. *)
let var_name =
  let name_counter = ref (-1) in
POTTIER Francois's avatar
POTTIER Francois committed
33
  let next_name () =
34 35 36 37
    incr name_counter;
    String.make 1 (char_of_int (97 + !name_counter mod 26))
    ^ let d = !name_counter / 26 in if d = 0 then "" else string_of_int d
  in
POTTIER Francois's avatar
POTTIER Francois committed
38 39
    fun v ->
      let repr = UnionFind.find v in
40 41 42
        match repr.name with
            None -> let name = next_name () in repr.name <- Some name; name
          | Some x -> x
43

POTTIER Francois's avatar
POTTIER Francois committed
44
(* [string_of_nt_type] is a simple pretty printer for types (they can be
45 46 47 48
   recursive). *)

(* 2011/04/05: types can no longer be recursive, but I won't touch the printer -fpottier *)

POTTIER Francois's avatar
POTTIER Francois committed
49 50 51 52 53
let string_of paren_fun ?paren ?colors t : string =
  let colors =
    match colors with
        None    -> (Mark.fresh (), Mark.fresh ())
      | Some cs -> cs
54 55
  in
  let s, p = paren_fun colors t in
POTTIER Francois's avatar
POTTIER Francois committed
56
    if paren <> None && p = true then
57 58 59
      "("^ s ^")"
    else s

60 61
let rec paren_nt_type colors = function
  (* [colors] is a pair [white, black] *)
POTTIER Francois's avatar
POTTIER Francois committed
62 63

    Arrow [] ->
64 65 66
      "*", false

  | Arrow ins ->
POTTIER Francois's avatar
POTTIER Francois committed
67 68
      let args = separated_list_to_string
        (string_of paren_var ~paren:true ~colors) ", " ins
69
      in
POTTIER Francois's avatar
POTTIER Francois committed
70
      let args =
71 72
        if List.length ins > 1 then
          "("^ args ^ ")"
POTTIER Francois's avatar
POTTIER Francois committed
73
        else
74
          args
75
      in
76
        args^" -> *", true
POTTIER Francois's avatar
POTTIER Francois committed
77 78

and paren_var (white, black) x =
79 80 81 82
  let descr = UnionFind.find x in
    if Mark.same descr.mark white then begin
      descr.mark <- black;
      var_name x, false
POTTIER Francois's avatar
POTTIER Francois committed
83 84
    end
    else begin
85 86
      descr.mark <- white;
      let s, p = match descr.structure with
87 88
          None -> var_name x, false
        | Some t -> paren_nt_type (white, black) t
89
      in
90 91
        if Mark.same descr.mark black then
          (var_name x ^ " = " ^ s, true)
POTTIER Francois's avatar
POTTIER Francois committed
92
        else
93
          (s, p)
94 95
    end

POTTIER Francois's avatar
POTTIER Francois committed
96
let string_of_nt_type ?colors t =
97
  (* TEMPORARY note: always called without a [colors] argument! *)
98 99
  string_of ?colors paren_nt_type t

POTTIER Francois's avatar
POTTIER Francois committed
100
let string_of_var ?colors v =
101
  (* TEMPORARY note: always called without a [colors] argument! *)
102 103
  string_of ?colors paren_var v

104 105
(* for debugging:

106
(* [print_env env] returns a string description of the typing environment. *)
POTTIER Francois's avatar
POTTIER Francois committed
107 108
let print_env =
  List.iter (fun (k, (_, v)) ->
109
               Printf.eprintf "%s: %s\n" k (string_of_var v))
110

111 112
*)

113 114 115 116 117 118 119
(* [occurs_check x y] checks that [x] does not occur within [y]. *)

let dfs action x =

  let black = Mark.fresh () in

  let rec visit_var x =
POTTIER Francois's avatar
POTTIER Francois committed
120
    let descr = UnionFind.find x in
121 122 123 124 125
    if not (Mark.same descr.mark black) then begin
      descr.mark <- black;
      action x;
      match descr.structure with
      | None ->
126
          ()
POTTIER Francois's avatar
POTTIER Francois committed
127
      | Some t ->
128
          visit_term t
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
    end

  and visit_term (Arrow ins) =
    List.iter visit_var ins

  in
  visit_var x

exception OccursError of variable * variable

let occurs_check x y =
  dfs (fun z -> if UnionFind.equivalent x z then raise (OccursError (x, y))) y

(* First order unification. *)

(* 2011/04/05: perform an eager occurs check and prevent the construction
   of any cycles. *)

POTTIER Francois's avatar
POTTIER Francois committed
147
let fresh_flexible_variable () =
148 149
  UnionFind.fresh { structure = None; name = None; mark = Mark.none }

POTTIER Francois's avatar
POTTIER Francois committed
150
let fresh_structured_variable t =
151 152 153 154 155 156 157 158 159 160 161 162
  UnionFind.fresh { structure = Some t; name = None; mark = Mark.none }

let star_variable =
  fresh_structured_variable star

exception UnificationError of nt_type * nt_type
exception BadArityError of int * int

let rec unify_var toplevel x y =
  if not (UnionFind.equivalent x y) then
    let reprx, repry = UnionFind.find x, UnionFind.find y in
      match reprx.structure, repry.structure with
163 164 165 166
          None, Some _    -> occurs_check x y; UnionFind.union x y
        | Some _, None    -> occurs_check y x; UnionFind.union y x
        | None, None      -> UnionFind.union x y
        | Some t, Some t' -> unify toplevel t t'; UnionFind.union x y
POTTIER Francois's avatar
POTTIER Francois committed
167 168

and unify toplevel t1 t2 =
169 170 171
  match t1, t2 with

    | Arrow ins, Arrow ins' ->
172 173 174 175 176 177 178 179 180
        let n1, n2 = List.length ins, List.length ins' in
        if n1 <> n2 then
          if n1 = 0 || n2 = 0 || not toplevel then
            raise (UnificationError (t1, t2))
          else
            (* the flag [toplevel] is used only here and influences which
               exception is raised; BadArityError is raised only at toplevel *)
            raise (BadArityError (n1, n2));
        List.iter2 (unify_var false) ins ins'
181 182 183 184 185 186 187 188 189

let unify_var x y =
  unify_var true x y

(* Typing environment. *)
type environment =
    (string * (Positions.t list * variable)) list

(* [lookup x env] returns the type related to [x] in the typing environment
POTTIER Francois's avatar
POTTIER Francois committed
190
   [env].
191 192
   By convention, identifiers that are not in [env] are terminals. They are
   given the type [Star]. *)
POTTIER Francois's avatar
POTTIER Francois committed
193 194
let lookup x (env: environment) =
  try
195 196 197 198 199 200 201 202 203
    snd (List.assoc x env)
  with Not_found -> star_variable

(* This function checks that the symbol [k] has the type [expected_type]. *)
let check positions env k expected_type =
  let inference_var = lookup k env in
  let checking_var = fresh_structured_variable expected_type in
    try
      unify_var inference_var checking_var
POTTIER Francois's avatar
POTTIER Francois committed
204
    with
205 206 207
        UnificationError (t1, t2) ->
          Error.error
            positions
208
             "how is this symbol parameterized?\n\
209
              It is used at sorts %s and %s.\n\
210
              The sort %s is not compatible with the sort %s."
211 212
               (string_of_var inference_var) (string_of_var checking_var)
               (string_of_nt_type t1) (string_of_nt_type t2)
POTTIER Francois's avatar
POTTIER Francois committed
213

214
      | BadArityError (n1, n2) ->
215 216
          Error.error
            positions
POTTIER Francois's avatar
POTTIER Francois committed
217
               "does this symbol expect %d or %d arguments?"
218
               (min n1 n2) (max n1 n2)
219 220

      | OccursError (x, y) ->
221 222
          Error.error
            positions
223
             "how is this symbol parameterized?\n\
224
              It is used at sorts %s and %s.\n\
225
              The sort %s cannot be unified with the sort %s."
226 227
               (string_of_var inference_var) (string_of_var checking_var)
               (string_of_var x) (string_of_var y)
POTTIER Francois's avatar
POTTIER Francois committed
228

229 230 231


(* An identifier can be used either in a total application or as a
232
   higher-order nonterminal (no partial application is allowed). *)
233 234 235 236 237 238 239
let rec parameter_type env = function
  | ParameterVar x ->
      lookup x.value env

  | ParameterApp (x, args) ->
      assert (args <> []);
      let expected_type =
POTTIER Francois's avatar
POTTIER Francois committed
240
        (* [x] is applied, it must be to the exact number
241
           of arguments. *)
POTTIER Francois's avatar
POTTIER Francois committed
242
        Arrow (List.map (parameter_type env) args)
243
      in
244 245
        (* Check the well-formedness of the application. *)
        check [x.position] env x.value expected_type;
246

POTTIER Francois's avatar
POTTIER Francois committed
247
        (* Similarly, if it was a total application the result is
248 249
           [Star] otherwise it is the flexible variable. *)
        star_variable
250

251 252 253 254
  | ParameterAnonymous _ ->
      (* Anonymous rules are eliminated early on. *)
      assert false

255
let check_grammar (p_grammar : Syntax.grammar) =
256 257 258
  (* [n] is the grammar size. *)
  let n        = StringMap.cardinal p_grammar.p_rules in

POTTIER Francois's avatar
POTTIER Francois committed
259
  (* The successors of the non terminal [N] are its producers. It
260 261 262
     induce a graph over the non terminals and its successor function
     is implemented by [successors]. Non terminals are indexed using
     [nt].
POTTIER Francois's avatar
POTTIER Francois committed
263
  *)
264
  let nt, conv, _iconv = index_map p_grammar.p_rules in
POTTIER Francois's avatar
POTTIER Francois committed
265
  let parameters, name, branches, positions =
266 267 268
    (fun n -> (nt n).pr_parameters), (fun n -> (nt n).pr_nt),
    (fun n -> (nt n).pr_branches), (fun n -> (nt n).pr_positions)
  in
POTTIER Francois's avatar
POTTIER Francois committed
269 270

  (* The successors function is implemented as an array using the
271
     indexing previously created. *)
POTTIER Francois's avatar
POTTIER Francois committed
272 273
  let successors =
    Array.init n (fun node ->
274 275
      (* We only are interested by parameterized non terminals. *)
      if parameters node <> [] then
276
        List.fold_left (fun succs { pr_producers = symbols } ->
POTTIER Francois's avatar
POTTIER Francois committed
277
          List.fold_left (fun succs -> function (_, p) ->
278
            let symbol, _ = Parameters.unapp p in
POTTIER Francois's avatar
POTTIER Francois committed
279
            try
280
              let symbol_node = conv symbol.value in
POTTIER Francois's avatar
POTTIER Francois committed
281
                (* [symbol] is a parameterized non terminal, we add it
282 283 284
                   to the successors set. *)
                if parameters symbol_node <> [] then
                  IntSet.add symbol_node succs
POTTIER Francois's avatar
POTTIER Francois committed
285
                else
286
                  succs
POTTIER Francois's avatar
POTTIER Francois committed
287
            with Not_found ->
288 289 290 291
              (* [symbol] is a token, it is not interesting for type inference
                 purpose. *)
              succs
          ) succs symbols
292 293
        ) IntSet.empty (branches node)
      else
294
        Misc.IntSet.empty
295 296 297
    )
  in

POTTIER Francois's avatar
POTTIER Francois committed
298
  (* The successors function and the indexing induce the following graph
299
     module. *)
POTTIER Francois's avatar
POTTIER Francois committed
300
  let module RulesGraph =
301 302
      struct

303
        type node = int
304

305
        let n = n
306

POTTIER Francois's avatar
POTTIER Francois committed
307
        let index node =
308
          node
309

POTTIER Francois's avatar
POTTIER Francois committed
310
        let successors f node =
311
          IntSet.iter f successors.(node)
312

POTTIER Francois's avatar
POTTIER Francois committed
313 314
        let iter f =
          for i = 0 to n - 1 do
315 316
            f i
          done
317 318 319 320 321 322 323 324 325 326

      end
  in
  let module ConnectedComponents = Tarjan.Run (RulesGraph) in
    (* We check that:
       - all the parameterized definitions of a particular component
       have the same number of parameters.
       - every parameterized non terminal definition always uses
       parameterized definitions of the same component with its
       formal parameters.
POTTIER Francois's avatar
POTTIER Francois committed
327

328 329 330 331 332
       Components are marked during the traversal:
       -1 means unvisited
       n with n > 0 is the number of parameters of the clique.
    *)
  let unseen = -1 in
333
  let marked_components = Array.make n unseen in
POTTIER Francois's avatar
POTTIER Francois committed
334

335 336
  let flexible_arrow args =
    let ty = Arrow (List.map (fun _ -> fresh_flexible_variable ()) args) in
POTTIER Francois's avatar
POTTIER Francois committed
337
      fresh_structured_variable ty
338 339 340 341 342
  in

  (* [nt_type i] is the type of the i-th non terminal. *)
  let nt_type i =
    match parameters i with
POTTIER Francois's avatar
POTTIER Francois committed
343
      | [] ->
344
          star_variable
POTTIER Francois's avatar
POTTIER Francois committed
345 346

      | x ->
347
          flexible_arrow x
348 349
  in

POTTIER Francois's avatar
POTTIER Francois committed
350
  (* [actual_parameters_as_formal] is the well-formedness checker for
351
     parameterized non terminal application. *)
POTTIER Francois's avatar
POTTIER Francois committed
352 353 354
  let actual_parameters_as_formal actual_parameters formal_parameters =
    List.for_all2 (fun y -> (function ParameterVar x -> x.value = y
                              | _ -> false))
355 356 357 358
      formal_parameters actual_parameters
  in

  (* The environment is initialized. *)
POTTIER Francois's avatar
POTTIER Francois committed
359 360 361
  let env : environment = StringMap.fold
    (fun k r acu ->
       (k, (r.pr_positions, nt_type (conv k)))
362 363 364 365 366 367
       :: acu)
    p_grammar.p_rules []
  in

    (* We traverse the graph checking each parameterized non terminal
       definition is well-formed. *)
POTTIER Francois's avatar
POTTIER Francois committed
368
    RulesGraph.iter
369
      (fun i ->
POTTIER Francois's avatar
POTTIER Francois committed
370 371 372
         let params    = parameters i
         and iname     = name i
         and repr      = ConnectedComponents.representative i
373 374 375 376 377
         and positions = positions i
         in

         (* The environment is augmented with the parameters whose types are
            unknown. *)
POTTIER Francois's avatar
POTTIER Francois committed
378
         let env' = List.map
379 380 381
           (fun k -> (k, (positions, fresh_flexible_variable ()))) params
         in
         let env = env' @ env in
POTTIER Francois's avatar
POTTIER Francois committed
382

383 384
         (* The type of the parameterized non terminal is constrained to be
            [expected_ty]. *)
POTTIER Francois's avatar
POTTIER Francois committed
385
         let check_type () =
386 387 388 389
           check positions env iname (Arrow (List.map (fun (_, (_, t)) -> t) env'))
         in

         (* We check the number of parameters. *)
POTTIER Francois's avatar
POTTIER Francois committed
390
         let check_parameters () =
391 392 393 394
           let parameters_len = List.length params in
             (* The component is visited for the first time. *)
             if marked_components.(repr) = unseen then
               marked_components.(repr) <- parameters_len
POTTIER Francois's avatar
POTTIER Francois committed
395 396 397
             else (* Otherwise, we check that the arity is homogeneous
                     in the component. *)
               if marked_components.(repr) <> parameters_len then
398 399
                 Error.error positions
                      "mutually recursive definitions must have the same parameters.\n\
400
                       This is not the case for %s and %s."
401 402 403 404 405 406 407
                         (name repr) iname
         in

        (* In each production rule, the parameterized non terminal
           of the same component must be instantiated with the same
           formal arguments. *)
         let check_producers () =
POTTIER Francois's avatar
POTTIER Francois committed
408 409
           List.iter
             (fun { pr_producers = symbols } -> List.iter
410 411 412
                (function (_, p) ->
                   let symbol, actuals = Parameters.unapp p in
                   (* We take the use of each symbol into account. *)
POTTIER Francois's avatar
POTTIER Francois committed
413 414
                     check [ symbol.position ] env symbol.value
                       (if actuals = [] then star else
415 416 417
                          Arrow (List.map (parameter_type env) actuals));
                   (* If it is in the same component, check in addition that
                      the arguments are the formal arguments. *)
POTTIER Francois's avatar
POTTIER Francois committed
418 419
                   try
                     let idx = conv symbol.value in
420 421 422 423 424
                       if ConnectedComponents.representative idx = repr then
                         if not (actual_parameters_as_formal actuals params)
                         then
                           Error.error [ symbol.position ]
                                "mutually recursive definitions must have the same \
425
                                 parameters.\n\
426 427 428 429 430 431 432 433 434 435
                                 This is not the case for %s."
                                 (let name1, name2 = (name idx), (name i) in
                                    if name1 <> name2 then name1 ^ " and "^ name2
                                    else name1)
                   with _ -> ())
                    symbols) (branches i)
         in
           check_type ();
           check_parameters ();
           check_producers ())
436

POTTIER Francois's avatar
POTTIER Francois committed
437

438 439
let rec subst_parameter subst = function
  | ParameterVar x ->
POTTIER Francois's avatar
POTTIER Francois committed
440 441
      (try
        List.assoc x.value subst
442
      with Not_found ->
443
        ParameterVar x)
444

POTTIER Francois's avatar
POTTIER Francois committed
445 446
  | ParameterApp (x, ps) ->
      (try
447 448 449
        match List.assoc x.value subst with
          | ParameterVar y ->
              ParameterApp (y, List.map (subst_parameter subst) ps)
450

451 452
          | ParameterApp _ ->
              (* Type-checking ensures that we cannot do partial
453
                 application. Consequently, if a higher-order nonterminal
POTTIER Francois's avatar
POTTIER Francois committed
454
                 is an actual argument, it cannot be the result of a
455 456
                 partial application. *)
              assert false
457

458 459 460 461
          | ParameterAnonymous _ ->
              (* Anonymous rules are eliminated early on. *)
              assert false

POTTIER Francois's avatar
POTTIER Francois committed
462
      with Not_found ->
463
          ParameterApp (x, List.map (subst_parameter subst) ps))
464

465 466 467 468 469
  | ParameterAnonymous _ ->
      (* Anonymous rules are eliminated early on. *)
      assert false


POTTIER Francois's avatar
POTTIER Francois committed
470
let subst_parameters subst =
471 472
  List.map (subst_parameter subst)

473
(* TEMPORARY why unused?
POTTIER Francois's avatar
POTTIER Francois committed
474 475 476
let names_of_p_grammar p_grammar =
  StringMap.fold (fun tok _ acu -> StringSet.add tok acu)
    p_grammar.p_tokens StringSet.empty
477
    $$ (StringMap.fold (fun nt _ acu -> StringSet.add nt acu)
478
          p_grammar.p_rules)
479
*)
480

POTTIER Francois's avatar
POTTIER Francois committed
481
let expand p_grammar =
482 483 484 485 486 487 488 489
  (* Check that it is safe to expand this parameterized grammar. *)
  check_grammar p_grammar;

  (* Set up a mechanism that ensures that names are unique -- and, in
     fact, ensures the stronger condition that normalized names are
     unique. *)

  let names =
POTTIER Francois's avatar
POTTIER Francois committed
490
    ref (StringSet.empty)
491 492 493 494 495
  in
  let ensure_fresh name =
    let normalized_name = Misc.normalize name in
    if StringSet.mem normalized_name !names then
      Error.error []
496
        "internal name clash over %s" normalized_name;
497 498 499
    names := StringSet.add normalized_name !names;
    name
  in
POTTIER Francois's avatar
POTTIER Francois committed
500 501 502 503
  let expanded_rules =
    Hashtbl.create 13
  in
  let module InstanceTable =
504 505
    Hashtbl.Make (Parameters)
  in
POTTIER Francois's avatar
POTTIER Francois committed
506 507
  let rule_names =
    InstanceTable.create 13
508 509 510 511 512
  in

  (* [mangle p] chooses a name for the new nonterminal symbol that corresponds
     to the parameter [p]. *)

POTTIER Francois's avatar
POTTIER Francois committed
513
  let rec mangle = function
514 515
    | ParameterVar x
    | ParameterApp (x, []) ->
516
        Positions.value x
517 518
    | ParameterApp (x, ps) ->

519 520 521 522 523
        (* We include parentheses and commas in the names that we
           assign to expanded nonterminals, because that is more
           readable and acceptable in many situations. We replace them
           with underscores in situations where these characters are
           not valid. *)
524

525 526 527
        Printf.sprintf "%s(%s)"
          (Positions.value x)
          (separated_list_to_string mangle "," ps)
528

529 530 531 532 533
    | ParameterAnonymous _ ->
        (* Anonymous rules are eliminated early on. *)
        assert false


534
  in
POTTIER Francois's avatar
POTTIER Francois committed
535
  let name_of symbol parameters =
536
    let param = ParameterApp (symbol, parameters) in
POTTIER Francois's avatar
POTTIER Francois committed
537
    try
538 539 540 541 542 543 544 545
      InstanceTable.find rule_names param
    with Not_found ->
      let name = ensure_fresh (mangle param) in
      InstanceTable.add rule_names param name;
      name
  in
  (* Given the substitution [subst] from parameters to non terminal, we
     instantiate the parameterized branch. *)
POTTIER Francois's avatar
POTTIER Francois committed
546 547
  let rec expand_branch subst pbranch =
    let new_producers = List.map
548
      (function (ido, p) ->
POTTIER Francois's avatar
POTTIER Francois committed
549
         let sym, actual_parameters =
550
           Parameters.unapp p in
POTTIER Francois's avatar
POTTIER Francois committed
551 552
         let sym, actual_parameters =
           try
553 554 555 556 557 558 559
             match List.assoc sym.value subst with
               | ParameterVar x ->
                   x, subst_parameters subst actual_parameters

               | ParameterApp (x, ps) ->
                   assert (actual_parameters = []);
                   x, ps
POTTIER Francois's avatar
POTTIER Francois committed
560

561 562 563 564
               | ParameterAnonymous _ ->
                   (* Anonymous rules are eliminated early on. *)
                   assert false

POTTIER Francois's avatar
POTTIER Francois committed
565
           with Not_found ->
566 567 568 569
             sym, subst_parameters subst actual_parameters
         in
           (* Instantiate the definition of the producer. *)
           (expand_branches subst sym actual_parameters, Positions.value ido))
570 571 572 573
      pbranch.pr_producers
    in
      {
        branch_position          = pbranch.pr_branch_position;
574 575 576 577
        producers                = new_producers;
        action                   = pbranch.pr_action;
        branch_prec_annotation   = pbranch.pr_branch_prec_annotation;
        branch_production_level  = pbranch.pr_branch_production_level;
578 579 580 581 582 583 584
      }

  (* Instantiate the branches of sym for a particular set of actual
     parameters. *)
  and expand_branches subst sym actual_parameters =
    let nsym = name_of sym actual_parameters in
      try
585 586
        if not (Hashtbl.mem expanded_rules nsym) then begin
          let prule = StringMap.find (Positions.value sym) p_grammar.p_rules in
POTTIER Francois's avatar
POTTIER Francois committed
587 588
          let subst =
            (* Type checking ensures that parameterized non terminal
589
               instantiations are well defined. *)
POTTIER Francois's avatar
POTTIER Francois committed
590
            assert (List.length prule.pr_parameters
591 592
                    = List.length actual_parameters);
            List.combine prule.pr_parameters actual_parameters @ subst in
POTTIER Francois's avatar
POTTIER Francois committed
593
            Hashtbl.add expanded_rules nsym
594 595 596
              { branches = []; positions = []; inline_flag = false };
          let rules = List.map (expand_branch subst) prule.pr_branches in
            Hashtbl.replace expanded_rules nsym
POTTIER Francois's avatar
POTTIER Francois committed
597 598 599
              {
                branches    = rules;
                positions   = prule.pr_positions;
600 601 602 603
                inline_flag = prule.pr_inline_flag;
              }
        end;
        nsym
POTTIER Francois's avatar
POTTIER Francois committed
604
      (* If [sym] is a terminal, then it is not in [p_grammar.p_rules].
605
         Expansion is not needed. *)
POTTIER Francois's avatar
POTTIER Francois committed
606
      with Not_found -> Positions.value sym
607
  in
608 609 610 611 612 613

  (* Process %type declarations. *)
  let rec types_from_list
      (ps : (Syntax.parameter * 'a Positions.located) list)
    : 'a StringMap.t =
    match ps with
614 615 616 617 618
    | [] -> StringMap.empty
    | (nt, ty)::q ->
        let accu = types_from_list q in
        let mangled = mangle nt in
        if StringMap.mem mangled accu then
619
          Error.error [Parameters.position nt]
620 621
               "there are multiple %%type declarations for nonterminal %s."
               mangled;
622 623 624
        StringMap.add mangled (Positions.value ty) accu
  in

625
  (* Process %on_error_reduce declarations. *)
626
  let rec on_error_reduce_from_list (ps : (Syntax.parameter * 'p) list) : 'p StringMap.t =
627 628
    match ps with
    | [] ->
629 630
        StringMap.empty
    | (nt, prec) :: ps ->
631 632
        let accu = on_error_reduce_from_list ps in
        let mangled = mangle nt in
633
        if StringMap.mem mangled accu then
634
          Error.error [Parameters.position nt]
635 636
               "there are multiple %%on_error_reduce declarations for nonterminal %s."
               mangled;
637
        StringMap.add mangled prec accu
638 639
  in

640 641 642
  let start_symbols = StringMap.domain (p_grammar.p_start_symbols) in
  {
    preludes      = p_grammar.p_preludes;
643
    postludes     = p_grammar.p_postludes;
644 645 646
    parameters    = p_grammar.p_parameters;
    start_symbols = start_symbols;
    types         = types_from_list p_grammar.p_types;
647
    on_error_reduce = on_error_reduce_from_list p_grammar.p_on_error_reduce;
648
    tokens        = p_grammar.p_tokens;
POTTIER Francois's avatar
POTTIER Francois committed
649 650 651
    rules         =
      let closed_rules = StringMap.fold
        (fun k prule rules ->
652 653 654 655 656 657 658
           (* If [k] is a start symbol then it cannot be parameterized. *)
           if prule.pr_parameters <> [] && StringSet.mem k start_symbols then
             Error.error []
               "the start symbol %s cannot be parameterized."
                  k;

           (* Entry points are the closed non terminals. *)
POTTIER Francois's avatar
POTTIER Francois committed
659 660
           if prule.pr_parameters = [] then
             StringMap.add k {
661 662 663 664 665 666 667
               branches    = List.map (expand_branch []) prule.pr_branches;
               positions   = prule.pr_positions;
               inline_flag = prule.pr_inline_flag;
             } rules
           else rules)
        p_grammar.p_rules
        StringMap.empty
668
      in
POTTIER Francois's avatar
POTTIER Francois committed
669
        Hashtbl.fold StringMap.add expanded_rules closed_rules
670
  }