Commit 728f80d4 authored by POTTIER Francois's avatar POTTIER Francois

Modified [UnparameterizedSyntax] to carry attributes.

Attributes are propagated through the expansion of parameterized symbols,
at which time %attribute declarations are also desugared.
Inlining is easy (an %inline callee or caller cannot carry attributes).
parent a393246b
......@@ -590,8 +590,8 @@ module Production = struct
let nt = Nonterminal.lookup nonterminal in
let k' = List.fold_left (fun k branch ->
let symbols = Array.of_list branch.producers in
table.(k) <- (nt, Array.map (fun (v, _) -> Symbol.lookup v) symbols);
identifiers.(k) <- Array.map snd symbols;
table.(k) <- (nt, Array.map (fun producer -> Symbol.lookup (producer_symbol producer)) symbols);
identifiers.(k) <- Array.map producer_identifier symbols;
actions.(k) <- Some branch.action;
production_level.(k) <- branch.branch_production_level;
prec_decl.(k) <- branch.branch_prec_annotation;
......
......@@ -65,9 +65,10 @@ let actiondef grammar symbol branch =
depend on the production's right-hand side. *)
let formals =
List.fold_left (fun formals (symbol, id) ->
let id, startp, endp, starto, endo =
id,
List.fold_left (fun formals producer ->
let symbol = producer_symbol producer
and id = producer_identifier producer in
let startp, endp, starto, endo =
Printf.sprintf "_startpos_%s_" id,
Printf.sprintf "_endpos_%s_" id,
Printf.sprintf "_startofs_%s_" id,
......@@ -351,4 +352,3 @@ let infer grammar =
in
{ grammar with types = types }
......@@ -54,7 +54,9 @@ let rec symbolstartpos ((nullable, epsilon) as analysis) producers i n
[$startpos($i)]. Otherwise, we continue. Furthermore, as noted above, if
[symbol] is not nullable, then we know that the start and end positions
must differ, so we optimize this case. *)
let symbol, x = List.nth producers i in
let producer = List.nth producers i in
let symbol = producer_symbol producer
and x = producer_identifier producer in
let startp = Position (RightNamed x, WhereStart, FlavorPosition)
and endp = Position (RightNamed x, WhereEnd, FlavorPosition) in
if not (nullable symbol) then
......@@ -126,7 +128,7 @@ let expand_startend producers n keyword action =
nonzero length and [$endpos($0)] otherwise. *)
define keyword (fun e -> e) (
if n > 0 then
let _, x = List.hd producers in
let x = producer_identifier (List.hd producers) in
Position (RightNamed x, WhereStart, flavor)
else
Position (Before, WhereEnd, flavor)
......@@ -138,7 +140,7 @@ let expand_startend producers n keyword action =
nonzero length and [$endpos($0)] otherwise. *)
define keyword (fun e -> e) (
if n > 0 then
let _, x = List.hd (List.rev producers) in
let x = producer_identifier (List.hd (List.rev producers)) in
Position (RightNamed x, WhereEnd, flavor)
else
Position (Before, WhereEnd, flavor)
......@@ -207,4 +209,3 @@ let expand_rule analysis rule =
let expand_grammar grammar =
let analysis = analysis grammar in
{ grammar with rules = StringMap.map (expand_rule analysis) grammar.rules }
......@@ -15,8 +15,7 @@ type 'a color =
let index2id producers i =
try
let (_, x) = List.nth producers i in
x
producer_identifier (List.nth producers i)
with Failure _ ->
assert false (* should not happen *)
......@@ -56,15 +55,29 @@ let rename_sw_inner beforeendp (subject, where) : (subject * where) option =
[KeywordExpansion]. *)
assert false
(* This auxiliary function checks that a use site of an %inline symbol does
not carry any attributes. *)
let check_no_producer_attributes producer =
match producer_attributes producer with
| [] ->
()
| (id, _payload) :: _attributes ->
Error.error
[Positions.position id]
"the nonterminal symbol %s is declared %%inline.\n\
A use of it cannot carry an attribute."
(producer_symbol producer)
let names (producers : producers) : StringSet.t =
List.fold_left (fun s producer ->
StringSet.add (producer_identifier producer) s
) StringSet.empty producers
(* Inline a grammar. The resulting grammar does not contain any definitions
that can be inlined. *)
let inline grammar =
let names producers =
List.fold_left (fun s (_, x) -> StringSet.add x s)
StringSet.empty producers
in
(* This function returns a fresh name beginning with [prefix] and
that is not in the set of names [names]. *)
let rec fresh ?(c=0) names prefix =
......@@ -95,33 +108,37 @@ let inline grammar =
r
in
(* This function traverses the producers of the branch [b] and find
the first non terminal that can be inlined. If it finds one, it
inlines its branches into [b], that's why this function can return
several branches. If it does not find one non terminal to be
inlined, it raises [NoInlining]. *)
(* [find_inline_producer b] traverses the producers of the branch [b] and
looks for the first nonterminal symbol that can be inlined. If it finds
one, it inlines its branches into [b], which is why this function can
return several branches. Otherwise, it raises [NoInlining]. *)
let rec chop_inline (prefix, suffix) =
match suffix with
| [] ->
raise NoInlining
| x :: xs ->
let nt = producer_symbol x
and id = producer_identifier x in
try
let r = StringMap.find nt grammar.rules in
if r.inline_flag then begin
(* We have checked earlier than an %inline symbol does not carry
any attributes. In addition, we now check that the use site of
this symbol does not carry any attributes either. Thus, we need
not worry about propagating these attributes through inlining. *)
check_no_producer_attributes x;
(* We inline the rule [r] into [b] between [prefix] and [xs]. *)
List.rev prefix, nt, r, id, xs
end
else
chop_inline (x :: prefix, xs)
with Not_found ->
chop_inline (x :: prefix, xs)
in
let rec find_inline_producer b =
let prefix, nt, p, psym, suffix =
let rec chop_inline i (prefix, suffix) =
match suffix with
| [] ->
raise NoInlining
| ((nt, id) as x) :: xs ->
try
let r = StringMap.find nt grammar.rules in
if r.inline_flag then
(* We have to inline the rule [r] into [b] between
[prefix] and [xs]. *)
List.rev prefix, nt, r, id, xs
else
chop_inline (i + 1) (x :: prefix, xs)
with Not_found ->
chop_inline (i + 1) (x :: prefix, xs)
in
chop_inline 1 ([], b.producers)
in
prefix, expand_rule nt p, nt, psym, suffix
let prefix, nt, p, psym, suffix = chop_inline ([], b.producers) in
prefix, expand_rule nt p, nt, psym, suffix
(* We have to rename producers' names of the inlined production
if they clash with the producers' names of the branch into
......@@ -133,12 +150,13 @@ let inline grammar =
(* Compute a renaming and the new inlined producers' names. *)
let phi, producers' =
List.fold_left (fun (phi, producers) (p, x) ->
List.fold_left (fun (phi, producers) producer ->
let x = producer_identifier producer in
if StringSet.mem x producers_names then
let x' = fresh producers_names x in
((x, x') :: phi, (p, x') :: producers)
((x, x') :: phi, { producer with producer_identifier = x' } :: producers)
else
(phi, (p, x) :: producers)
(phi, producer :: producers)
) ([], []) producers
in
phi, List.rev producers'
......@@ -179,7 +197,7 @@ let inline grammar =
)
);
(* Rename the producers of this branch is they conflict with
(* Rename the producers of this branch if they conflict with
the name of the host's producers. *)
let phi, inlined_producers = rename_if_necessary b pb.producers in
......
......@@ -284,7 +284,7 @@ let check_grammar (p_grammar : Syntax.grammar) =
(* We only are interested by parameterized non terminals. *)
if parameters node <> [] then
List.fold_left (fun succs { pr_producers = symbols } ->
List.fold_left (fun succs -> function (_, p, _) ->
List.fold_left (fun succs (_, p, _) ->
let symbol, _ = Parameters.unapp p in
try
let symbol_node = conv symbol.value in
......@@ -495,6 +495,13 @@ let names_of_p_grammar p_grammar =
p_grammar.p_rules)
*)
let dummy : rule =
{ branches = [];
positions = [];
inline_flag = false;
attributes = [];
}
let expand p_grammar =
(* Check that it is safe to expand this parameterized grammar. *)
check_grammar p_grammar;
......@@ -558,13 +565,41 @@ let expand p_grammar =
InstanceTable.add rule_names param name;
name
in
(* Now is the time to eliminate (desugar) %attribute declarations. We build
a table of these declarations, and look up this table so as to place
appropriate attributes on terminal and nonterminal symbols. *)
let symbol_attributes : parameter -> attributes =
let table = InstanceTable.create 7 in
List.iter (fun (actuals, attributes) ->
List.iter (fun actual ->
let attributes', used =
try InstanceTable.find table actual
with Not_found -> [], ref false
in
InstanceTable.replace table actual (attributes @ attributes', used)
) actuals
) p_grammar.p_symbol_attributes;
fun actual ->
match InstanceTable.find table actual with
| (attrs, used) -> used := true; attrs
| exception Not_found -> []
in
(* This auxiliary function transfers information from the
table [symbol_attributes] towards terminal symbols. *)
let decorate tok prop : token_properties =
let attrs = symbol_attributes (ParameterVar (Positions.unknown_pos tok)) in
{ prop with tk_attributes = attrs @ prop.tk_attributes }
in
(* Given the substitution [subst] from parameters to non terminal, we
instantiate the parameterized branch. *)
let rec expand_branch subst pbranch =
let new_producers = List.map
(function (ido, p, _) ->
let sym, actual_parameters =
Parameters.unapp p in
let new_producers = List.map (fun (ido, p, attrs) ->
let sym, actual_parameters = Parameters.unapp p in
let sym, actual_parameters =
try
match List.assoc sym.value subst with
......@@ -582,9 +617,11 @@ let expand p_grammar =
with Not_found ->
sym, subst_parameters subst actual_parameters
in
(* Instantiate the definition of the producer. *)
(expand_branches subst sym actual_parameters, Positions.value ido))
pbranch.pr_producers
(* Instantiate the definition of the producer. *)
{ producer_identifier = Positions.value ido;
producer_symbol = expand_branches subst sym actual_parameters;
producer_attributes = attrs }
) pbranch.pr_producers
in
{
branch_position = pbranch.pr_branch_position;
......@@ -596,31 +633,43 @@ let expand p_grammar =
(* 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
if not (Hashtbl.mem expanded_rules nsym) then begin
let prule = StringMap.find (Positions.value sym) p_grammar.p_rules in
and expand_branches subst sym actual_parameters : symbol =
match StringMap.find (Positions.value sym) p_grammar.p_rules with
| exception Not_found ->
(* [sym] is a terminal symbol. Expansion is not needed. *)
Positions.value sym
| prule ->
let nsym = name_of sym actual_parameters in
(* Check up front if [nsym] is marked, so as to deal with it just once. *)
if Hashtbl.mem expanded_rules nsym then
nsym
else begin
(* Type checking ensures that parameterized nonterminal symbols
are applied to an appropriate number of arguments. *)
assert (List.length prule.pr_parameters =
List.length actual_parameters);
let subst =
(* Type checking ensures that parameterized non terminal
instantiations are well defined. *)
assert (List.length prule.pr_parameters
= List.length actual_parameters);
List.combine prule.pr_parameters actual_parameters @ subst in
Hashtbl.add expanded_rules nsym
{ branches = []; positions = []; inline_flag = false };
let rules = List.map (expand_branch subst) prule.pr_branches in
Hashtbl.replace expanded_rules nsym
{
branches = rules;
positions = prule.pr_positions;
inline_flag = prule.pr_inline_flag;
}
end;
nsym
(* If [sym] is a terminal, then it is not in [p_grammar.p_rules].
Expansion is not needed. *)
with Not_found -> Positions.value sym
List.combine prule.pr_parameters actual_parameters @ subst
in
(* Mark [nsym] up front, so as to avoid running in circles. *)
Hashtbl.add expanded_rules nsym dummy;
(* The attributes carried by the expanded symbol [nsym] are those
carried by the original parameterized symbol [sym], plus those
found in %attribute declarations for [nsym], plus those found
in %attribute declarations for [sym]. *)
let attributes =
symbol_attributes (ParameterApp (sym, actual_parameters)) @
symbol_attributes (ParameterVar sym) @
prule.pr_attributes
in
Hashtbl.replace expanded_rules nsym {
branches = List.map (expand_branch subst) prule.pr_branches;
positions = prule.pr_positions;
inline_flag = prule.pr_inline_flag;
attributes = attributes;
};
nsym
end
in
(* Process %type declarations. *)
......@@ -662,7 +711,8 @@ let expand p_grammar =
start_symbols = start_symbols;
types = types_from_list p_grammar.p_types;
on_error_reduce = on_error_reduce_from_list p_grammar.p_on_error_reduce;
tokens = p_grammar.p_tokens;
tokens = StringMap.mapi decorate p_grammar.p_tokens;
gr_attributes = p_grammar.p_grammar_attributes;
rules =
let closed_rules = StringMap.fold
(fun k prule rules ->
......@@ -672,16 +722,22 @@ let expand p_grammar =
"the start symbol %s cannot be parameterized."
k;
(* Entry points are the closed non terminals. *)
(* Entry points are the closed nonterminals. *)
if prule.pr_parameters = [] then
let attributes =
symbol_attributes (ParameterVar (Positions.unknown_pos k)) @
prule.pr_attributes
in
StringMap.add k {
branches = List.map (expand_branch []) prule.pr_branches;
positions = prule.pr_positions;
inline_flag = prule.pr_inline_flag;
attributes = attributes;
} rules
else rules)
p_grammar.p_rules
StringMap.empty
in
(* FIXME: warn about symbol_attributes not applying to any actual *)
Hashtbl.fold StringMap.add expanded_rules closed_rules
}
......@@ -588,6 +588,19 @@ let join grammar pgrammar =
List.fold_left (join_declaration filename) grammar pgrammar.pg_declarations
$$ join_postlude pgrammar.pg_postlude
(* If a rule is marked %inline, then it must not carry an attribute. *)
let check_inline_attribute prule =
match prule.pr_inline_flag, prule.pr_attributes with
| true, (id, _payload) :: _attributes ->
Error.error
[Positions.position id]
"the nonterminal symbol %s is declared %%inline.\n\
It cannot carry an attribute."
prule.pr_nt
| true, []
| false, _ ->
()
let check_parameterized_grammar_is_well_defined grammar =
(* Every start symbol is defined and has a %type declaration. *)
......@@ -707,6 +720,9 @@ let check_parameterized_grammar_is_well_defined grammar =
Error.error prule.pr_positions
"%s cannot be both a start symbol and inlined." k;
(* If a rule is marked %inline, then it must not carry an attribute. *)
check_inline_attribute prule
) grammar.p_rules;
(* Check that every token is used. *)
......
......@@ -16,8 +16,8 @@ let rec visit grammar visited symbol =
and visitb grammar visited { producers = symbols } =
List.fold_left (visits grammar) visited symbols
and visits grammar visited (symbol, _) =
visit grammar visited symbol
and visits grammar visited producer =
visit grammar visited (producer_symbol producer)
let trim grammar =
if StringSet.cardinal grammar.start_symbols = 0 then
......
......@@ -113,6 +113,18 @@ let if_ocaml_code_permitted f x =
(* -------------------------------------------------------------------------- *)
(* Testing whether attributes should be printed. *)
let attributes_printed : bool =
match mode with
| PrintNormal
| PrintUnitActions _ ->
true
| PrintForOCamlyacc ->
false
(* -------------------------------------------------------------------------- *)
(* Printing a semantic action. *)
let print_semantic_action f g branch =
......@@ -127,7 +139,9 @@ let print_semantic_action f g branch =
(* In ocamlyacc-compatibility mode, the code must be wrapped in
[let]-bindings whose right-hand side uses the [$i] keywords. *)
let bindings =
List.mapi (fun i (symbol, id) ->
List.mapi (fun i producer ->
let id = producer_identifier producer
and symbol = producer_symbol producer in
(* Test if [symbol] is a terminal symbol whose type is [unit]. *)
let is_unit_token =
try
......@@ -200,6 +214,19 @@ let print_parameters f g =
(* -------------------------------------------------------------------------- *)
(* Printing attributes. *)
let print_attribute f ((name, payload) : attribute) =
if attributes_printed then
fprintf f " [@%s %s]"
(Positions.value name)
payload.stretch_raw_content
let print_attributes f attrs =
List.iter (print_attribute f) attrs
(* -------------------------------------------------------------------------- *)
(* Printing token declarations and precedence declarations. *)
let print_assoc = function
......@@ -232,7 +259,10 @@ let print_tokens f g =
(* Print the %token declarations. *)
StringMap.iter (fun token prop ->
if prop.tk_is_declared then
fprintf f "%%token%s %s\n" (print_token_type prop) token
fprintf f "%%token%s %s%a\n"
(print_token_type prop)
token
print_attributes prop.tk_attributes
) g.tokens;
(* Sort the tokens wrt. precedence, and group them into levels. *)
let levels : (string * token_properties) list list =
......@@ -268,12 +298,17 @@ let print_types f g =
(* Printing branches and rules. *)
let print_producer sep f producer =
fprintf f "%s%s%s%a"
(sep())
(print_binding (producer_identifier producer))
(Misc.normalize (producer_symbol producer))
print_attributes (producer_attributes producer)
let print_branch f g branch =
(* Print the producers. *)
let sep = Misc.once "" " " in
List.iter (fun (symbol, id) ->
fprintf f "%s%s%s" (sep()) (print_binding id) (Misc.normalize symbol)
) branch.producers;
List.iter (print_producer sep f) branch.producers;
(* Print the %prec annotation, if there is one. *)
Option.iter (fun x ->
fprintf f " %%prec %s" x.value
......@@ -314,18 +349,19 @@ let compare_rules (_nt, (r : rule)) (_nt', (r' : rule)) =
(* To compare two rules, it suffices to compare their first productions. *)
compare_branches b b'
let print_rule f g (nt, r) =
fprintf f "\n%s%a:\n" (Misc.normalize nt) print_attributes r.attributes;
(* Menhir accepts a leading "|", but bison does not. Let's not print it.
So, we print a bar-separated list. *)
let sep = Misc.once (" ") ("| ") in
List.iter (fun br ->
fprintf f "%s" (sep());
print_branch f g br
) r.branches
let print_rules f g =
let rules = List.sort compare_rules (StringMap.bindings g.rules) in
List.iter (fun (nt, r) ->
fprintf f "\n%s:\n" (Misc.normalize nt);
(* Menhir accepts a leading "|", but bison does not. Let's not print it.
So, we print a bar-separated list. *)
let sep = Misc.once (" ") ("| ") in
List.iter (fun br ->
fprintf f "%s" (sep());
print_branch f g br
) r.branches
) rules
List.iter (print_rule f g) rules
(* -------------------------------------------------------------------------- *)
......@@ -359,6 +395,19 @@ let print_on_error_reduce_declarations f g =
(* -------------------------------------------------------------------------- *)
(* Printing %attribute declarations. *)
let print_grammar_attribute f ((name, payload) : attribute) =
if attributes_printed then
fprintf f "%%[@%s %s]\n"
(Positions.value name)
payload.stretch_raw_content
let print_grammar_attributes f g =
List.iter (print_grammar_attribute f) g.gr_attributes
(* -------------------------------------------------------------------------- *)
(* The main entry point. *)
let print f g =
......@@ -368,6 +417,7 @@ let print f g =
print_tokens f g;
print_types f g;
print_on_error_reduce_declarations f g;
print_grammar_attributes f g;
fprintf f "%%%%\n";
print_rules f g;
fprintf f "\n%%%%\n";
......
......@@ -15,11 +15,20 @@
*)
open Syntax
type producer =
{
producer_identifier : identifier;
producer_symbol : symbol;
producer_attributes : attributes;
}
type producers =
producer list
type branch =
{
branch_position : Positions.t;
producers : (symbol * identifier) list; (* TEMPORARY convention renversée
par rapport à syntax.mli; faire un type record au lieu d'une paire? *)
producers : producers;
action : action;
branch_prec_annotation : branch_prec_annotation;
branch_production_level : branch_production_level
......@@ -31,6 +40,7 @@ type rule =
positions : Positions.t list;
(* This flag is not relevant after the NonTerminalInlining.inline pass. *)
inline_flag : bool;
attributes : attributes;
}
type grammar =
......@@ -42,9 +52,16 @@ type grammar =
types : Stretch.ocamltype StringMap.t;
on_error_reduce : on_error_reduce_level StringMap.t;
tokens : Syntax.token_properties StringMap.t;
gr_attributes : attributes;
rules : rule StringMap.t;
}
(* Accessors for the type [producer]. *)
let producer_identifier { producer_identifier } = producer_identifier
let producer_symbol { producer_symbol } = producer_symbol
let producer_attributes { producer_attributes } = producer_attributes
(* [tokens grammar] is a list of all (real) tokens in the grammar
[grammar]. The special tokens "#" and "error" are not included.
Pseudo-tokens (used in %prec declarations, but never declared
......
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