Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit fb23cffb authored by POTTIER Francois's avatar POTTIER Francois
Browse files

Serious cleanup in [Action] and [NonTerminalDefinitionInlining].

parent ffea9880
open Keyword
type pkeywords =
keyword Positions.located list
type t = {
type t =
{
expr : IL.expr;
keywords : KeywordSet.t;
filenames : string list;
pkeywords : pkeywords
}
(* The code for this semantic action. *)
expr: IL.expr;
(* The files where this semantic action originates. Via inlining,
several semantic actions can be combined into one, so there can
be several files. *)
filenames: string list;
(* A list of keywords that appear in this semantic action, with their
positions. This list is maintained only up to the well-formedness check in
[PartialGrammar.check_keywords]. Thereafter, it is no longer used. So, the
keyword-renaming functions do not bother to update it. *)
pkeywords : keyword Positions.located list;
(* The set of keywords that appear in this semantic action. They can be thought
of as free variables that refer to positions. They must be renamed during
inlining. *)
keywords : KeywordSet.t;
}
(* Creation. *)
let pkeywords_to_keywords pkeywords =
KeywordSet.of_list (List.map Positions.value pkeywords)
......@@ -20,9 +34,11 @@ let from_stretch s =
expr = IL.ETextual s;
filenames = [ s.Stretch.stretch_filename ];
pkeywords = pkeywords;
keywords = pkeywords_to_keywords pkeywords; (* TEMPORARY maybe we do not need this redundancy? *)
keywords = pkeywords_to_keywords pkeywords;
}
(* Composition, used during inlining. *)
let compose x a1 a2 =
(* 2015/07/20: there used to be a call to [parenthesize_stretch] here,
which would insert parentheses around every stretch in [a1]. This is
......@@ -32,48 +48,52 @@ let compose x a1 a2 =
expr = IL.ELet ([ IL.PVar x, a1.expr ], a2.expr);
keywords = KeywordSet.union a1.keywords a2.keywords;
filenames = a1.filenames @ a2.filenames;
pkeywords = a1.pkeywords @ a2.pkeywords;
pkeywords = [] (* don't bother; already checked *)
}
(* Renaming of keywords, used during inlining. *)
type sw =
Keyword.subject * Keyword.where
type renaming_env =
type keyword_renaming =
string * sw * sw
let rename_inlined_psym ((psym, first_prod, last_prod) : renaming_env) phi pkeywords =
List.fold_left (fun (l, phi, (used1, used2)) pk ->
match Positions.value pk with
let rename_inlined_psym ((psym, first_prod, last_prod) : keyword_renaming) phi keywords =
let phi = ref phi in
let keywords =
KeywordSet.map (fun keyword ->
match keyword with
| Position (subject, where, flavor) ->
let (subject', where'), (used1, used2) =
let (subject', where') =
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)
| WhereStart -> first_prod
| WhereEnd -> last_prod
else
(* Otherwise, we just take the renaming into account. *)
let s' = try
List.assoc s phi
List.assoc s !phi
with Not_found -> s
in
(RightNamed s', w), (used1, used2)
| Left, _ -> (subject, where), (used1, used2)
(RightNamed s', w)
| Left, _ -> (subject, where)
in
let from_pos = Keyword.posvar subject where flavor
and to_pos = Keyword.posvar subject' where' flavor in
(Positions.with_pos (Positions.position pk)
(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))
if from_pos <> to_pos && not (List.mem_assoc from_pos !phi) then
phi := (from_pos, to_pos) :: !phi;
Position (subject', where', flavor)
| SyntaxError -> pk :: l, phi, (used1, used2)
| SyntaxError -> SyntaxError
)
([], phi, (false, false)) pkeywords
keywords
in
keywords, !phi
(* Rename the keywords related to position to handle the composition
of semantic actions during non terminal inlining.
......@@ -87,43 +107,45 @@ let rename_inlined_psym ((psym, first_prod, last_prod) : renaming_env) phi pkeyw
- [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) =
let rename_pkeywords (psym, first_prod, last_prod) phi keywords =
let phi = ref phi in
let keywords =
KeywordSet.map (fun keyword ->
match keyword with
| Position (subject, where, flavor) ->
let (subject', where') =
match subject, where with
(* $startpos is changed to $startpos(first_prod) in the
inlined rule. *)
| Left, WhereStart -> first_prod, (true, used2)
| Left, WhereStart -> first_prod
(* Similarly for $endpos. *)
| Left, WhereEnd -> last_prod, (used1, true)
(* $i cannot be combined with inlining. *)
| Left, WhereEnd -> last_prod
| 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)
| WhereStart -> first_prod;
| WhereEnd -> last_prod
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)
(* Otherwise, we just take the renaming into account. *)
let s' = try List.assoc s !phi with Not_found -> s in
(RightNamed s', w)
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))
if from_pos <> to_pos && not (List.mem_assoc from_pos !phi) then
phi := (from_pos, to_pos) :: !phi;
Position (subject', where', flavor)
([], phi, (false, false)) l
| SyntaxError -> SyntaxError
)
keywords
in
keywords, !phi
let rename renaming_fun renaming_env phi a =
let pkeywords, phi, used_fg = renaming_fun renaming_env phi a.pkeywords in
let rename renaming_fun keyword_renaming phi a =
let keywords, phi = renaming_fun keyword_renaming phi a.keywords in
{ a with
(* We use the let construct to rename without modification of the semantic
action code. *)
......@@ -132,9 +154,9 @@ let rename renaming_fun renaming_env phi a =
a.expr);
(* Keywords related to positions are updated too. *)
pkeywords = pkeywords;
keywords = pkeywords_to_keywords pkeywords;
}, used_fg
pkeywords = []; (* don't bother *)
keywords = keywords;
}
let rename_inlined_psym =
rename rename_inlined_psym
......
......@@ -10,23 +10,23 @@ val compose : string -> t -> t -> t
type sw =
Keyword.subject * Keyword.where
type renaming_env =
type keyword_renaming =
string * sw * sw
(** [rename renaming_env phi a] builds the action
(** [rename keyword_renaming phi a] builds the action
[let x1 = x1' and ... xn = xn' in a] if [phi] is [(x1, x1') ... (xn, xn')].
Moreover, [renaming_env] is used to correctly replace $startpos/$endpos
present in the semantic action. *)
val rename:
renaming_env
-> (string * string) list -> t -> t * (bool * bool)
keyword_renaming
-> (string * string) list -> t -> t
(** [rename_inlined_psym renaming_env phi a] updates the occurrences of the
(** [rename_inlined_psym keyword_renaming phi a] updates the occurrences of the
inlined non terminal in the action [a].
*)
val rename_inlined_psym:
renaming_env
-> (string * string) list -> t -> t * (bool * bool)
keyword_renaming
-> (string * string) list -> t -> t
(** Semantic actions are translated into [IL] code using the
[IL.ETextual] and [IL.ELet] constructors. *)
......
......@@ -110,42 +110,39 @@ let inline grammar =
let phi, inlined_producers = rename_if_necessary b pb.producers in
(* Define the renaming environment given the shape of the branch. *)
let renaming_env, prefix', suffix' =
let start_position, prefix' =
let start_position =
match List.rev prefix with
(* If the prefix is empty, the start position is the rule
start position. *)
| [] -> (Keyword.Left, Keyword.WhereStart), prefix
| [] -> (Keyword.Left, Keyword.WhereStart)
(* The last producer of prefix is named [x],
$startpos in the inlined rule will be changed to $endpos(x). *)
| (_, x) :: _ -> (Keyword.RightNamed x, Keyword.WhereEnd), prefix
| (_, x) :: _ -> (Keyword.RightNamed x, Keyword.WhereEnd)
in
(* Same thing for the suffix. *)
let end_position, suffix' =
let end_position =
match suffix with
| [] -> (Keyword.Left, Keyword.WhereEnd), suffix
| (_, x) :: _ -> (Keyword.RightNamed x, Keyword.WhereStart), suffix
| [] -> (Keyword.Left, Keyword.WhereEnd)
| (_, x) :: _ -> (Keyword.RightNamed x, Keyword.WhereStart)
in
(psym, start_position, end_position), prefix', suffix'
let renaming_env =
(psym, start_position, end_position)
in
(* Rename the host semantic action.
Each reference of the inlined non terminal [psym] must be taken into
account. $startpos(psym) is changed to $startpos(x) where [x] is
the first producer of the inlined branch if it is not empty or
the preceding producer found in the prefix. *)
let outer_action, (used1, used2) =
let outer_action =
Action.rename_inlined_psym renaming_env [] b.action
in
let action', (used1', used2') =
let action' =
Action.rename renaming_env phi pb.action
in
assert (prefix == prefix' && suffix == suffix');
let prefix = if used1 || used1' then prefix' else prefix in
let suffix = if used2 || used2' then suffix' else suffix in
{ b with
producers = prefix @ inlined_producers @ suffix;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment