bundles/menhirLib/menhir-20120123/src/action.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 (* $Id: action.ml,v 1.10 2006/06/26 09:41:33 regisgia Exp $ *)
  16
  17 open Keyword
  18
  19 type t =
  20     {
  21       expr      : IL.expr;
  22       keywords  : Keyword.KeywordSet.t;
  23       filenames : string list;
  24       pkeywords : Keyword.keyword Positions.located list
  25     }
  26
  27 let from_stretch s =
  28   {
  29     expr      = IL.ETextual s;
  30     filenames = [ s.Stretch.stretch_filename ];
  31     keywords  = Keyword.KeywordSet.from_list (List.map Positions.value s.Stretch.stretch_keywords);
  32     pkeywords = s.Stretch.stretch_keywords;
  33   }
  34
  35 let parenthesize s =
  36   if String.length s < 2 || s.[0] <> '(' || s.[String.length s - 1] <> ')' then
  37     "(" ^ s ^ ")"
  38   else
  39     s
  40
  41 let rec parenthesize_stretch = function
  42   | IL.ETextual s ->
  43       IL.ETextual { s with Stretch.stretch_raw_content = parenthesize s.Stretch.stretch_raw_content }
  44   | IL.ELet (es, e) ->
  45       IL.ELet (List.map (fun (p, e) -> (p, parenthesize_stretch e)) es, parenthesize_stretch e)
  46   | x -> x
  47
  48 let compose x a1 a2 =
  49   {
  50     expr      = IL.ELet ([ IL.PVar x, parenthesize_stretch a1.expr ], a2.expr);
  51     keywords  = Keyword.KeywordSet.union a1.keywords a2.keywords;
  52     filenames = a1.filenames @ a2.filenames;
  53     pkeywords = a1.pkeywords @ a2.pkeywords;
  54   }
  55
  56 let rename_inlined_psym (psym, first_prod, last_prod) phi l =
  57   List.fold_left
  58     (fun (l, phi, (used1, used2)) pk ->
  59        match pk.Positions.value with
  60          | Position (subject, where, flavor) ->
  61              let (subject', where'), (used1, used2) =
  62                match subject, where with
  63                  | RightNamed s, w  ->
  64                      (* In the host rule, $startpos(x) is changed
  65                         to $startpos(first_prod) (same thing for $endpos). *)
  66                      if s = psym then
  67                        match w with
  68                          | WhereStart -> first_prod, (true, used2)
  69                          | WhereEnd -> last_prod, (used1, true)
  70                      else
  71                        (* Otherwise, we just that the renaming into account. *)
  72                        let s' = try
  73                          List.assoc s phi
  74                        with Not_found -> s
  75                        in
  76                          (RightNamed s', w), (used1, used2)
  77                  | _ -> (subject, where), (used1, used2)
  78              in
  79              let from_pos = Keyword.posvar subject where flavor
  80              and to_pos = Keyword.posvar subject' where' flavor in
  81                (Positions.with_pos pk.Positions.position
  82                   (Position (subject', where', flavor)) :: l,
  83                 (if from_pos <> to_pos && not (List.mem_assoc from_pos phi) then
  84                    (from_pos, to_pos) :: phi else phi),
  85                 (used1, used2))
  86
  87          | _ -> pk :: l, phi, (used1, used2)
  88     )
  89     ([], phi, (false, false)) l
  90
  91 (* Rename the keywords related to position to handle the composition
  92    of semantic actions during non terminal inlining.
  93
  94    The first argument describes the context:
  95    - [first_prod] is the first producer that starts the action's rule.
  96    - [last_prod] is the last one.
  97    For instance, if %inline rule r is A -> B C and rule r' is D -> E A F,
  98    then [first_prod] is B and [last_prod] is C.
  99    If r is A -> and r' is unchanged. [first_prod] is E and [last_prod] is F.
 100    - [psym] is the producer that is being inlined.
 101
 102 *)
 103 let rename_pkeywords (psym, first_prod, last_prod) phi l =
 104   List.fold_left (fun (l, phi, (used1, used2)) pk -> match pk.Positions.value with
 105             | Position (subject, where, flavor) ->
 106                 let (subject', where'), (used1, used2) =
 107                   match subject, where with
 108                       (* $startpos is changed to $startpos(first_prod) in the
 109                          inlined rule. *)
 110                     | Left, WhereStart -> first_prod, (true, used2)
 111                       (* Similarly for $endpos. *)
 112                     | Left, WhereEnd   -> last_prod, (used1, true)
 113                       (* $i cannot be combined with inlining. *)
 114                     | RightDollar i, w -> assert false
 115                     | RightNamed s, w  ->
 116                         (* In the host rule, $startpos(x) is changed to
 117                            to $startpos(first_prod) (same thing for $endpos). *)
 118                         if s = psym then
 119                           match w with
 120                             | WhereStart -> first_prod, (true, used2)
 121                             | WhereEnd -> last_prod, (used1, true)
 122                         else
 123                           (* Otherwise, we just that the renaming into account. *)
 124                           let s' = try List.assoc s phi with Not_found -> s in
 125                             (RightNamed s', w), (used1, used2)
 126                 in
 127                 let from_pos = Keyword.posvar subject where flavor
 128                 and to_pos = Keyword.posvar subject' where' flavor in
 129                   (Positions.with_pos pk.Positions.position
 130                      (Position (subject', where', flavor)) :: l,
 131                    (if from_pos <> to_pos && not (List.mem_assoc from_pos phi) then
 132                       (from_pos, to_pos) :: phi else phi),
 133                    (used1, used2))
 134
 135             | x -> pk :: l, phi, (used1, used2))
 136
 137     ([], phi, (false, false)) l
 138
 139 let rename renaming_fun renaming_env phi a =
 140   let pkeywords, phi, used_fg = renaming_fun renaming_env phi a.pkeywords in
 141   { a with
 142       (* We use the let construct to rename without modification of the semantic
 143          action code. *)
 144       expr =
 145       IL.ELet (List.map (fun (x, x') -> (IL.PVar x, IL.EVar x')) phi,
 146                a.expr);
 147
 148       (* Keywords related to positions are updated too. *)
 149       keywords =
 150       List.fold_left
 151         (fun acu pk -> Keyword.KeywordSet.add pk.Positions.value acu)
 152         Keyword.KeywordSet.empty
 153         pkeywords;
 154
 155       pkeywords = pkeywords
 156   }, used_fg
 157
 158 let rename_inlined_psym =
 159   rename rename_inlined_psym
 160
 161 let rename =
 162   rename rename_pkeywords
 163
 164 let to_il_expr action =
 165   action.expr
 166
 167 let filenames action =
 168   action.filenames
 169
 170 let keywords action =
 171   action.keywords
 172
 173 let pkeywords action =
 174   action.pkeywords
 175
 176 let rec print f action =
 177   let module P = Printer.Make (struct let f = f
 178                                       let locate_stretches = None
 179                                       let raw_stretch_action = true
 180                                end)
 181   in
 182     P.expr action.expr
 183
 184 let has_previouserror action =
 185   KeywordSet.mem PreviousError (keywords action)
 186
 187 let has_syntaxerror action =
 188   KeywordSet.mem SyntaxError (keywords action)
 189
 190 let has_leftstart action =
 191   KeywordSet.exists (function
 192     | Position (Left, WhereStart, _) ->
 193         true
 194     | _ ->
 195         false
 196   ) (keywords action)
 197
 198 let has_leftend action =
 199   KeywordSet.exists (function
 200     | Position (Left, WhereEnd, _) ->
 201         true
 202     | _ ->
 203         false
 204   ) (keywords action)
 205
 206 let has_dollar i action =
 207   KeywordSet.exists (function
 208     | Dollar j when i = j ->
 209         true
 210     | _ ->
 211         false
 212   ) (keywords action)
 213
 214 let use_dollar action =
 215   KeywordSet.exists (function
 216     | Dollar _ ->
 217         true
 218     | _ ->
 219         false
 220   ) (keywords action)
 221
 222
 223
 224