action.ml 5.39 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
open Keyword

type t = 
    {
      expr	: IL.expr;
      keywords  : Keyword.KeywordSet.t;
      filenames : string list;
      pkeywords : Keyword.keyword Positions.located list
    }

let from_stretch s = 
  { 
    expr      = IL.ETextual s;
    filenames = [ s.Stretch.stretch_filename ];
15
    keywords  = Keyword.KeywordSet.of_list (List.map Positions.value s.Stretch.stretch_keywords);
16 17 18 19
    pkeywords = s.Stretch.stretch_keywords;
  }

let compose x a1 a2 = 
20 21 22 23
  (* 2015/07/20: there used to be a call to [parenthesize_stretch] here,
     which would insert parentheses around every stretch in [a1]. This is
     not necessary, as far as I can see, since every stretch that represents
     a semantic action is already parenthesized by the lexer. *)
24
  {
25
    expr      = IL.ELet ([ IL.PVar x, a1.expr ], a2.expr);
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 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
    keywords  = Keyword.KeywordSet.union a1.keywords a2.keywords;
    filenames = a1.filenames @ a2.filenames;
    pkeywords = a1.pkeywords @ a2.pkeywords;
  }

let rename_inlined_psym (psym, first_prod, last_prod) phi l =
  List.fold_left
    (fun (l, phi, (used1, used2)) pk ->
       match pk.Positions.value with
	 | Position (subject, where, flavor) ->
	     let (subject', where'), (used1, used2) = 
	       match subject, where with
		 | RightNamed s, w  -> 
		     (* In the host rule, $startpos(x) is changed 
			to $startpos(first_prod) (same thing for $endpos). *)
		     if s = psym then
		       match w with
			 | WhereStart -> first_prod, (true, used2)
			 | WhereEnd -> last_prod, (used1, true)
		     else 
		       (* Otherwise, we just that the renaming into account. *)
		       let s' = try 
			 List.assoc s phi
		       with Not_found -> s 
		       in
			 (RightNamed s', w), (used1, used2)
		 | _ -> (subject, where), (used1, used2)
	     in
	     let from_pos = Keyword.posvar subject where flavor
	     and to_pos = Keyword.posvar subject' where' flavor in
	       (Positions.with_pos pk.Positions.position 
		  (Position (subject', where', flavor)) :: l,
		(if from_pos <> to_pos && not (List.mem_assoc from_pos phi) then 
		   (from_pos, to_pos) :: phi else phi),
		(used1, used2))

	 | _ -> pk :: l, phi, (used1, used2)
    )
    ([], phi, (false, false)) l

(* Rename the keywords related to position to handle the composition
   of semantic actions during non terminal inlining. 

   The first argument describes the context: 
   - [first_prod] is the first producer that starts the action's rule.
   - [last_prod] is the last one.
   For instance, if %inline rule r is A -> B C and rule r' is D -> E A F,
   then [first_prod] is B and [last_prod] is C. 
   If r is A -> and r' is unchanged. [first_prod] is E and [last_prod] is F.
   - [psym] is the producer that is being inlined.
   
*)
let rename_pkeywords (psym, first_prod, last_prod) phi l = 
  List.fold_left (fun (l, phi, (used1, used2)) pk -> match pk.Positions.value with
	    | Position (subject, where, flavor) ->
		let (subject', where'), (used1, used2) = 
		  match subject, where with
		      (* $startpos is changed to $startpos(first_prod) in the 
			 inlined rule. *)
		    | Left, WhereStart -> first_prod, (true, used2)
		      (* Similarly for $endpos. *)
		    | Left, WhereEnd   -> last_prod, (used1, true)
		      (* $i cannot be combined with inlining. *)
		    | RightNamed s, w  -> 
			(* In the host rule, $startpos(x) is changed to 
			   to $startpos(first_prod) (same thing for $endpos). *)
			if s = psym then
			  match w with
			    | WhereStart -> first_prod, (true, used2)
			    | WhereEnd -> last_prod, (used1, true)
			else 
			  (* Otherwise, we just that the renaming into account. *)
			  let s' = try List.assoc s phi with Not_found -> s in
			    (RightNamed s', w), (used1, used2)
		in
		let from_pos = Keyword.posvar subject where flavor
		and to_pos = Keyword.posvar subject' where' flavor in
		  (Positions.with_pos pk.Positions.position 
		     (Position (subject', where', flavor)) :: l,
		   (if from_pos <> to_pos && not (List.mem_assoc from_pos phi) then 
		      (from_pos, to_pos) :: phi else phi), 
		   (used1, used2))

109
	    | _ -> pk :: l, phi, (used1, used2))
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149

    ([], phi, (false, false)) l
		
let rename renaming_fun renaming_env phi a = 
  let pkeywords, phi, used_fg = renaming_fun renaming_env phi a.pkeywords in
  { a with 
      (* We use the let construct to rename without modification of the semantic
	 action code. *)
      expr = 
      IL.ELet (List.map (fun (x, x') -> (IL.PVar x, IL.EVar x')) phi, 
	       a.expr);

      (* Keywords related to positions are updated too. *)
      keywords = 
      List.fold_left 
	(fun acu pk -> Keyword.KeywordSet.add pk.Positions.value acu) 
	Keyword.KeywordSet.empty
	pkeywords;

      pkeywords = pkeywords
  }, used_fg

let rename_inlined_psym =
  rename rename_inlined_psym

let rename =
  rename rename_pkeywords

let to_il_expr action = 
  action.expr

let filenames action = 
  action.filenames

let keywords action = 
  action.keywords

let pkeywords action = 
  action.pkeywords

150
let print f action = 
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  let module P = Printer.Make (struct let f = f 
				      let locate_stretches = None 
			       end) 
  in
    P.expr action.expr

let has_syntaxerror action =
  KeywordSet.mem SyntaxError (keywords action)

let has_leftstart action =
  KeywordSet.exists (function
    | Position (Left, WhereStart, _) ->
	true
    | _ ->
	false
  ) (keywords action)

let has_leftend action =
  KeywordSet.exists (function
    | Position (Left, WhereEnd, _) ->
	true
    | _ ->
	false
  ) (keywords action)