From: Bob Duff <[email protected]>
We should not mix "syntactic" and "semantic" for the same field
in different node kinds.
The Chars field is both syntactic and semantic. This patch
makes it always syntactic, and does some other Chars-related
cleanups.
An attempt was made to instead rename the semantic field
to be Op_Chars, but that complicates things, because there
is a fair amount of code that fetches the Chars field
without knowing the node kind. Notably, Errout does this.
No change in overall compiler behavior.
gcc/ada/ChangeLog:
* gen_il-gen-gen_nodes.adb (N_Op):
Make Chars syntactic, and move it down into subclasses
N_Binary_Op and N_Unary_Op.
* gen_il-gen.adb (Create_Type):
Do not exempt Chars from the ordering rule.
(Exception_To_Inheritance_Rule): Exempt Chars from the
inheritance rule.
(Check_For_Syntactic_Field_Mismatch):
Do not exempt Chars from the syntactic mismatch rule.
This is the main point of this change.
(Put_Make_Bodies): The Nmake functions for types in N_Op
will now take a Chars parameter, which should always
default to No_Name. This will be overwritten by the
special-case Set_Chars call. Assert that it is in
fact defaulted.
* exp_ch4.adb (Expand_Array_Comparison):
Use the Nkind instead of the Chars, which seems cleaner.
Use a case instead of an elsif chain.
* sem_attr.adb (Proper_Op): Minor cleanup.
* sem_ch8.adb: Minor reformatting.
* sem_res.adb (Operator_Kind): Tighten up the result subtype.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 66 ++++++++++++++++----------------
gcc/ada/gen_il-gen-gen_nodes.adb | 19 +++++++--
gcc/ada/gen_il-gen.adb | 13 ++++---
gcc/ada/sem_attr.adb | 66 ++++++++++++++++----------------
gcc/ada/sem_ch8.adb | 18 ++++-----
gcc/ada/sem_res.adb | 7 ++--
6 files changed, 99 insertions(+), 90 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 8fba1c4e71f..8a6abfc4907 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1432,46 +1432,48 @@ package body Exp_Ch4 is
-- For (a <= b) we convert to not (a > b)
- if Chars (N) = Name_Op_Le then
- Rewrite (N,
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Op_Gt (Loc,
- Left_Opnd => Op1,
- Right_Opnd => Op2)));
- Analyze_And_Resolve (N, Standard_Boolean);
- return;
+ case Nkind (N) is
+ when N_Op_Le =>
+ Rewrite (N,
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Op1,
+ Right_Opnd => Op2)));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ return;
- -- For < the Boolean expression is
- -- greater__nn (op2, op1)
+ -- For < the Boolean expression is
+ -- greater__nn (op2, op1)
- elsif Chars (N) = Name_Op_Lt then
- Func_Body := Make_Array_Comparison_Op (Typ1, N);
+ when N_Op_Lt =>
+ Func_Body := Make_Array_Comparison_Op (Typ1, N);
- -- Switch operands
+ -- Switch operands
- Op1 := Right_Opnd (N);
- Op2 := Left_Opnd (N);
+ Op1 := Right_Opnd (N);
+ Op2 := Left_Opnd (N);
- -- For (a >= b) we convert to not (a < b)
+ -- For (a >= b) we convert to not (a < b)
- elsif Chars (N) = Name_Op_Ge then
- Rewrite (N,
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Op_Lt (Loc,
- Left_Opnd => Op1,
- Right_Opnd => Op2)));
- Analyze_And_Resolve (N, Standard_Boolean);
- return;
+ when N_Op_Ge =>
+ Rewrite (N,
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => Op1,
+ Right_Opnd => Op2)));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ return;
- -- For > the Boolean expression is
- -- greater__nn (op1, op2)
+ -- For > the Boolean expression is
+ -- greater__nn (op1, op2)
- else
- pragma Assert (Chars (N) = Name_Op_Gt);
- Func_Body := Make_Array_Comparison_Op (Typ1, N);
- end if;
+ when N_Op_Gt =>
+ Func_Body := Make_Array_Comparison_Op (Typ1, N);
+
+ when others => raise Program_Error;
+ end case;
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Expr :=
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 9ce2511a561..9fb962bf39c 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -192,14 +192,24 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Char_Literal_Value, Unat)));
Ab (N_Op, N_Has_Entity,
- (Sm (Chars, Name_Id),
- Sm (Do_Overflow_Check, Flag),
+ (Sm (Do_Overflow_Check, Flag),
Sm (Has_Private_View, Flag),
Sm (Has_Secondary_Private_View, Flag)));
Ab (N_Binary_Op, N_Op,
(Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sy (Chars, Name_Id, Default_No_Name)));
+ -- N_Binary_Op and N_Unary_Op do not strictly need Chars, since the value
+ -- is fully determined by the Nkind. However, for example, Errout refers to
+ -- Chars without knowing statically whether the Nkind is in N_Op.
+ -- In any case, we don't inherit Chars from N_Op, because we want it to
+ -- come after the other syntactic fields, so that positional notation can
+ -- be used in calls to Make_Op_Add and friends.
+ --
+ -- Make_Op_Add and friends will now have a Chars parameter. Callers
+ -- should always use the default, because the Chars field is set
+ -- properly as a special case (see Gen_IL.Gen).
Cc (N_Op_Add, N_Binary_Op);
@@ -259,7 +269,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Op_Shift_Right_Arithmetic, N_Op_Shift);
Ab (N_Unary_Op, N_Op,
- (Sy (Right_Opnd, Node_Id)));
+ (Sy (Right_Opnd, Node_Id),
+ Sy (Chars, Name_Id, Default_No_Name)));
Cc (N_Op_Abs, N_Unary_Op);
Cc (N_Op_Minus, N_Unary_Op);
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index 5eb1a5893d2..7cf99977dcb 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -167,7 +167,7 @@ package body Gen_IL.Gen is
-- Check that syntactic fields precede semantic fields. Note that this
-- check is happening before we compute inherited fields.
- -- Exempt Chars and Actions from this rule, for now.
+ -- Exempt Actions from this rule, for now.
declare
Semantic_Seen : Boolean := False;
@@ -180,7 +180,7 @@ package body Gen_IL.Gen is
end if;
else
- if Fields (J).F not in Chars | Actions then
+ if Fields (J).F /= Actions then
Semantic_Seen := True;
end if;
end if;
@@ -896,7 +896,7 @@ package body Gen_IL.Gen is
-- For example, Left_Opnd comes before Right_Opnd,
-- which wouldn't be the case if Right_Opnd were
-- inherited from N_Op.
- ((T = N_Op and then F = Right_Opnd)
+ ((T = N_Op and then F in Right_Opnd | Chars)
or else (T = N_Renaming_Declaration and then F = Name)
or else (T = N_Generic_Renaming_Declaration and then F = Name)
or else F in Defining_Unit_Name
@@ -1306,7 +1306,7 @@ package body Gen_IL.Gen is
-- for now. At least, we don't want to add any new cases of
-- syntactic/semantic mismatch.
- if F in Chars | Actions | Expression | Default_Expression
+ if F in Actions | Expression | Default_Expression
then
pragma Assert (Syntactic_Seen and Semantic_Seen);
@@ -2675,7 +2675,7 @@ package body Gen_IL.Gen is
if Is_Descendant (N_Op, T) then
-- Special cases for N_Op nodes: fill in the Chars and
Entity
- -- fields even though they were not passed in.
+ -- fields. Assert that the Chars passed in is defaulted.
declare
Op : constant String := Image_Sans_N (T);
@@ -2705,6 +2705,7 @@ package body Gen_IL.Gen is
-- "Op_", but the Name_Id constant does not.
begin
+ Put (S, "pragma Assert (Chars = No_Name);" & LF);
Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF);
Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF);
end;
@@ -2990,7 +2991,7 @@ package body Gen_IL.Gen is
(if T in Entity_Type and then F in Node_Field then
" -- N" else "");
-- A comment to put out for fields of entities that are
- -- shared with nodes, such as Chars.
+ -- shared with nodes.
begin
while First_Bit < Type_Bit_Size_Aligned (T) loop
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index e9e245afb60..962b0889c84 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12805,45 +12805,43 @@ package body Sem_Attr is
and then Scope (Op) = Standard_Standard
and then not Strict
then
- declare
- Op_Chars : constant Any_Operator_Name := Chars (Op);
- -- Nonassociative ops like division are unlikely
- -- to come up in practice, but they are legal.
- begin
- case Op_Chars is
- when Name_Op_Add
- | Name_Op_Subtract
- | Name_Op_Multiply
- | Name_Op_Divide
- | Name_Op_Expon
- =>
- return Is_Numeric_Type (Typ);
+ -- Nonassociative ops like division are unlikely to
+ -- come up in practice, but they are legal.
- when Name_Op_Mod | Name_Op_Rem =>
- return Is_Numeric_Type (Typ)
- and then Is_Discrete_Type (Typ);
+ case Any_Operator_Name'(Chars (Op)) is
+ when Name_Op_Add
+ | Name_Op_Subtract
+ | Name_Op_Multiply
+ | Name_Op_Divide
+ | Name_Op_Expon
+ =>
+ return Is_Numeric_Type (Typ);
- when Name_Op_And | Name_Op_Or | Name_Op_Xor =>
- -- No Boolean array operators in Standard
- return Is_Boolean_Type (Typ)
- or else Is_Modular_Integer_Type (Typ);
+ when Name_Op_Mod | Name_Op_Rem =>
+ return Is_Numeric_Type (Typ)
+ and then Is_Discrete_Type (Typ);
- when Name_Op_Concat =>
- return Is_Array_Type (Typ)
- and then Number_Dimensions (Typ) = 1;
+ when Name_Op_And | Name_Op_Or | Name_Op_Xor =>
+ -- No Boolean array operators in Standard
+ return Is_Boolean_Type (Typ)
+ or else Is_Modular_Integer_Type (Typ);
- when Name_Op_Eq | Name_Op_Ne
- | Name_Op_Lt | Name_Op_Le
- | Name_Op_Gt | Name_Op_Ge
- =>
- return Is_Boolean_Type (Typ);
+ when Name_Op_Concat =>
+ return Is_Array_Type (Typ)
+ and then Number_Dimensions (Typ) = 1;
+
+ when Name_Op_Eq | Name_Op_Ne
+ | Name_Op_Lt | Name_Op_Le
+ | Name_Op_Gt | Name_Op_Ge
+ =>
+ return Is_Boolean_Type (Typ);
+
+ when Name_Op_Abs | Name_Op_Not =>
+ -- unary ops were already handled
+
+ raise Program_Error;
+ end case;
- when Name_Op_Abs | Name_Op_Not =>
- -- unary ops were already handled
- pragma Assert (False);
- raise Program_Error;
- end case;
- end;
else
return False;
end if;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index a83ac645e92..fe7f311f74c 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -136,7 +136,7 @@ package body Sem_Ch8 is
-- the order of their corresponding scopes on the scope stack. For
-- example, if package P and the enclosing scope both contain entities
-- named E, then when compiling the package body the chain for E will
- -- hold the global entity first, and the local one (corresponding to
+ -- hold the global entity first, and the local one (corresponding to
-- the current inner scope) next. As a result, name resolution routines
-- do not assume any relative ordering of the homonym chains, either
-- for scope nesting or to order of appearance of context clauses.
@@ -207,7 +207,7 @@ package body Sem_Ch8 is
-- a private or incomplete type declaration, or a protected type speci-
-- fication) and re-chained when compiling the second view.
- -- In the case of operators, we do not make operators on derived types
+ -- In the case of operators, we do not make operators on derived types
-- explicit. As a result, the notation P."+" may denote either a user-
-- defined function with name "+", or else an implicit declaration of the
-- operator "+" in package P. The resolution of expanded names always
@@ -1892,7 +1892,7 @@ package body Sem_Ch8 is
Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
if Old_S = Any_Id then
- Error_Msg_N ("no subprogram or entry matches specification", N);
+ Error_Msg_N ("no subprogram or entry matches specification", N);
else
if Is_Body then
Check_Subtype_Conformant (New_S, Old_S, N);
@@ -2073,7 +2073,7 @@ package body Sem_Ch8 is
end if;
if Old_S = Any_Id then
- Error_Msg_N ("no subprogram or entry matches specification", N);
+ Error_Msg_N ("no subprogram or entry matches specification", N);
else
if Is_Body then
@@ -3848,7 +3848,7 @@ package body Sem_Ch8 is
elsif Ekind (Old_S) /= E_Operator then
-- If this a defaulted subprogram for a class-wide actual there is
- -- no check for mode conformance, given that the signatures don't
+ -- no check for mode conformance, given that the signatures don't
-- match (the source mentions T but the actual mentions T'Class).
if CW_Actual then
@@ -5213,7 +5213,7 @@ package body Sem_Ch8 is
-- An entity in the current scope is not necessarily the first one
-- on its homonym chain. Find its predecessor if any,
-- If it is an internal entity, it will not be in the visibility
- -- chain altogether, and there is nothing to unchain.
+ -- chain altogether, and there is nothing to unchain.
if Id /= Current_Entity (Id) then
Prev := Current_Entity (Id);
@@ -5248,7 +5248,7 @@ package body Sem_Ch8 is
Set_Name_Entity_Id (Chars (Id), Outer);
elsif Scope (Prev) /= Scope (Id) then
- Set_Homonym (Prev, Outer);
+ Set_Homonym (Prev, Outer);
end if;
<<Next_Ent>>
@@ -9948,9 +9948,7 @@ package body Sem_Ch8 is
and then Scope (S) /= Standard_Standard
and then not Is_Child_Unit (S)
then
- if Nkind (E) not in N_Entity then
- return;
- end if;
+ pragma Assert (Nkind (E) in N_Entity);
-- Copy categorization flags from Scope (S) to S, this is not done
-- when Scope (S) is Standard_Standard since propagation is from
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 4d467553373..e1b015aacca 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -262,9 +262,8 @@ package body Sem_Res is
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean) return Node_Kind;
- -- Utility to map the name of an operator into the corresponding Node. Used
- -- by other node rewriting procedures.
+ Is_Binary : Boolean) return N_Op;
+ -- Map the name of an operator into the corresponding Node_Kind
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones.
@@ -1986,7 +1985,7 @@ package body Sem_Res is
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean) return Node_Kind
+ Is_Binary : Boolean) return N_Op
is
Kind : Node_Kind;
--
2.51.0
