summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorRobert Dewar <dewar@adacore.com>2010-06-22 07:26:02 +0000
committerArnaud Charlet <charlet@gcc.gnu.org>2010-06-22 09:26:02 +0200
commit74e7891f8d73153b50beebbd497d69b18fc8cb24 (patch)
tree622fd4753d7fcd2fe9b6e230fa034027b2f43b97 /gcc/ada
parentcf49bd32328f107c91df2fb7d92e1292b35f00ee (diff)
downloadgcc-74e7891f8d73153b50beebbd497d69b18fc8cb24.tar.gz
g-expect-vms.adb, [...]: Minor reformatting.
2010-06-22 Robert Dewar <dewar@adacore.com> * g-expect-vms.adb, sem_res.adb: Minor reformatting. * exp_aggr.adb: Minor comment changes and reformatting. * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order * sem_util.ads: Add some missing pragma Inline's (efficiency issue only) From-SVN: r161139
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog7
-rw-r--r--gcc/ada/exp_aggr.adb5
-rw-r--r--gcc/ada/g-expect-vms.adb4
-rw-r--r--gcc/ada/sem_eval.adb270
-rw-r--r--gcc/ada/sem_res.adb8
-rw-r--r--gcc/ada/sem_util.ads1
6 files changed, 154 insertions, 141 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 76c3f151827..bc310e38c51 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2010-06-22 Robert Dewar <dewar@adacore.com>
+
+ * g-expect-vms.adb, sem_res.adb: Minor reformatting.
+ * exp_aggr.adb: Minor comment changes and reformatting.
+ * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order
+ * sem_util.ads: Add some missing pragma Inline's (efficiency issue only)
+
2010-06-22 Thomas Quinot <quinot@adacore.com>
* sem_util.adb (Build_Actual_Subtype): Record original expression in
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index c15b92282e3..9345da2f56b 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -176,8 +176,9 @@ package body Exp_Aggr is
-- Very large static aggregates present problems to the back-end, and are
-- transformed into assignments and loops. This function verifies that the
-- total number of components of an aggregate is acceptable for rewriting
- -- into a purely positional static form. It is called prior to calling
- -- Flatten.
+ -- into a purely positional static form. Aggr_Size_OK must be called before
+ -- calling Flatten.
+ --
-- This function also detects and warns about one-component aggregates that
-- appear in a non-static context. Even if the component value is static,
-- such an aggregate must be expanded into an assignment.
diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb
index d92e1e7783e..4d1a770822a 100644
--- a/gcc/ada/g-expect-vms.adb
+++ b/gcc/ada/g-expect-vms.adb
@@ -524,6 +524,7 @@ package body GNAT.Expect is
for J in Descriptors'Range loop
Descriptors (J) := Regexps (J).Descriptor;
+
if Descriptors (J) /= null then
Reinitialize_Buffer (Regexps (J).Descriptor.all);
end if;
@@ -775,7 +776,8 @@ package body GNAT.Expect is
------------------------
function First_Dead_Process
- (Regexp : Multiprocess_Regexp_Array) return Natural is
+ (Regexp : Multiprocess_Regexp_Array) return Natural
+ is
begin
for R in Regexp'Range loop
if Regexp (R).Descriptor /= null
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index fb17144b668..11fba8e7a3a 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -3763,6 +3763,141 @@ package body Sem_Eval is
end if;
end Expr_Value_S;
+ ----------------------------------
+ -- Find_Universal_Operator_Type --
+ ----------------------------------
+
+ function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
+ PN : constant Node_Id := Parent (N);
+ Call : constant Node_Id := Original_Node (N);
+ Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
+
+ Is_Fix : constant Boolean :=
+ Nkind (N) in N_Binary_Op
+ and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
+ -- A mixed-mode operation in this context indicates the presence of
+ -- fixed-point type in the designated package.
+
+ Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
+ -- Case where N is a relational (or membership) operator (else it is an
+ -- arithmetic one).
+
+ In_Membership : constant Boolean :=
+ Nkind (PN) in N_Membership_Test
+ and then
+ Nkind (Right_Opnd (PN)) = N_Range
+ and then
+ Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
+ and then
+ Is_Universal_Numeric_Type
+ (Etype (Low_Bound (Right_Opnd (PN))))
+ and then
+ Is_Universal_Numeric_Type
+ (Etype (High_Bound (Right_Opnd (PN))));
+ -- Case where N is part of a membership test with a universal range
+
+ E : Entity_Id;
+ Pack : Entity_Id;
+ Typ1 : Entity_Id := Empty;
+ Priv_E : Entity_Id;
+
+ function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
+ -- Check whether one operand is a mixed-mode operation that requires
+ -- the presence of a fixed-point type. Given that all operands are
+ -- universal and have been constant-folded, retrieve the original
+ -- function call.
+
+ ---------------------------
+ -- Is_Mixed_Mode_Operand --
+ ---------------------------
+
+ function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
+ begin
+ return Nkind (Original_Node (Op)) = N_Function_Call
+ and then Present (Next_Actual (First_Actual (Original_Node (Op))))
+ and then Etype (First_Actual (Original_Node (Op))) /=
+ Etype (Next_Actual (First_Actual (Original_Node (Op))));
+ end Is_Mixed_Mode_Operand;
+
+ begin
+ if Nkind (Call) /= N_Function_Call
+ or else Nkind (Name (Call)) /= N_Expanded_Name
+ then
+ return Empty;
+
+ -- There are two cases where the context does not imply the type of the
+ -- operands: either the universal expression appears in a type
+ -- type conversion, or we are in the case of a predefined relational
+ -- operator, where the context type is always Boolean.
+
+ elsif Nkind (Parent (N)) = N_Type_Conversion
+ or else
+ Is_Relational
+ or else
+ In_Membership
+ then
+ Pack := Entity (Prefix (Name (Call)));
+
+ -- If the prefix is a package declared elsewhere, iterate over
+ -- its visible entities, otherwise iterate over all declarations
+ -- in the designated scope.
+
+ if Ekind (Pack) = E_Package
+ and then not In_Open_Scopes (Pack)
+ then
+ Priv_E := First_Private_Entity (Pack);
+ else
+ Priv_E := Empty;
+ end if;
+
+ Typ1 := Empty;
+ E := First_Entity (Pack);
+ while Present (E) and then E /= Priv_E loop
+ if Is_Numeric_Type (E)
+ and then Nkind (Parent (E)) /= N_Subtype_Declaration
+ and then Comes_From_Source (E)
+ and then Is_Integer_Type (E) = Is_Int
+ and then
+ (Nkind (N) in N_Unary_Op
+ or else Is_Relational
+ or else Is_Fixed_Point_Type (E) = Is_Fix)
+ then
+ if No (Typ1) then
+ Typ1 := E;
+
+ -- Before emitting an error, check for the presence of a
+ -- mixed-mode operation that specifies a fixed point type.
+
+ elsif Is_Relational
+ and then
+ (Is_Mixed_Mode_Operand (Left_Opnd (N))
+ or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
+ and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
+
+ then
+ if Is_Fixed_Point_Type (E) then
+ Typ1 := E;
+ end if;
+
+ else
+ -- More than one type of the proper class declared in P
+
+ Error_Msg_N ("ambiguous operation", N);
+ Error_Msg_Sloc := Sloc (Typ1);
+ Error_Msg_N ("\possible interpretation (inherited)#", N);
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N ("\possible interpretation (inherited)#", N);
+ return Empty;
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+
+ return Typ1;
+ end Find_Universal_Operator_Type;
+
--------------------------
-- Flag_Non_Static_Expr --
--------------------------
@@ -4761,141 +4896,6 @@ package body Sem_Eval is
end if;
end Test;
- ----------------------------------
- -- Find_Universal_Operator_Type --
- ----------------------------------
-
- function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
- PN : constant Node_Id := Parent (N);
- Call : constant Node_Id := Original_Node (N);
- Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
-
- Is_Fix : constant Boolean :=
- Nkind (N) in N_Binary_Op
- and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
- -- A mixed-mode operation in this context indicates the presence of
- -- fixed-point type in the designated package.
-
- Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
- -- Case where N is a relational (or membership) operator (else it is an
- -- arithmetic one).
-
- In_Membership : constant Boolean :=
- Nkind (PN) in N_Membership_Test
- and then
- Nkind (Right_Opnd (PN)) = N_Range
- and then
- Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
- and then
- Is_Universal_Numeric_Type
- (Etype (Low_Bound (Right_Opnd (PN))))
- and then
- Is_Universal_Numeric_Type
- (Etype (High_Bound (Right_Opnd (PN))));
- -- Case where N is part of a membership test with a universal range
-
- E : Entity_Id;
- Pack : Entity_Id;
- Typ1 : Entity_Id := Empty;
- Priv_E : Entity_Id;
-
- function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
- -- Check whether one operand is a mixed-mode operation that requires
- -- the presence of a fixed-point type. Given that all operands are
- -- universal and have been constant-folded, retrieve the original
- -- function call.
-
- ---------------------------
- -- Is_Mixed_Mode_Operand --
- ---------------------------
-
- function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
- begin
- return Nkind (Original_Node (Op)) = N_Function_Call
- and then Present (Next_Actual (First_Actual (Original_Node (Op))))
- and then Etype (First_Actual (Original_Node (Op))) /=
- Etype (Next_Actual (First_Actual (Original_Node (Op))));
- end Is_Mixed_Mode_Operand;
-
- begin
- if Nkind (Call) /= N_Function_Call
- or else Nkind (Name (Call)) /= N_Expanded_Name
- then
- return Empty;
-
- -- There are two cases where the context does not imply the type of the
- -- operands: either the universal expression appears in a type
- -- type conversion, or we are in the case of a predefined relational
- -- operator, where the context type is always Boolean.
-
- elsif Nkind (Parent (N)) = N_Type_Conversion
- or else
- Is_Relational
- or else
- In_Membership
- then
- Pack := Entity (Prefix (Name (Call)));
-
- -- If the prefix is a package declared elsewhere, iterate over
- -- its visible entities, otherwise iterate over all declarations
- -- in the designated scope.
-
- if Ekind (Pack) = E_Package
- and then not In_Open_Scopes (Pack)
- then
- Priv_E := First_Private_Entity (Pack);
- else
- Priv_E := Empty;
- end if;
-
- Typ1 := Empty;
- E := First_Entity (Pack);
- while Present (E) and then E /= Priv_E loop
- if Is_Numeric_Type (E)
- and then Nkind (Parent (E)) /= N_Subtype_Declaration
- and then Comes_From_Source (E)
- and then Is_Integer_Type (E) = Is_Int
- and then
- (Nkind (N) in N_Unary_Op
- or else Is_Relational
- or else Is_Fixed_Point_Type (E) = Is_Fix)
- then
- if No (Typ1) then
- Typ1 := E;
-
- -- Before emitting an error, check for the presence of a
- -- mixed-mode operation that specifies a fixed point type.
-
- elsif Is_Relational
- and then
- (Is_Mixed_Mode_Operand (Left_Opnd (N))
- or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
- and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
-
- then
- if Is_Fixed_Point_Type (E) then
- Typ1 := E;
- end if;
-
- else
- -- More than one type of the proper class declared in P
-
- Error_Msg_N ("ambiguous operation", N);
- Error_Msg_Sloc := Sloc (Typ1);
- Error_Msg_N ("\possible interpretation (inherited)#", N);
- Error_Msg_Sloc := Sloc (E);
- Error_Msg_N ("\possible interpretation (inherited)#", N);
- return Empty;
- end if;
- end if;
-
- Next_Entity (E);
- end loop;
- end if;
-
- return Typ1;
- end Find_Universal_Operator_Type;
-
---------------------------------
-- Test_Expression_Is_Foldable --
---------------------------------
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index a6b9d3a0549..c3be8b53368 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5083,13 +5083,15 @@ package body Sem_Res is
Expressions => Parameter_Associations (N));
end if;
+ -- Preserve the parenthesis count of the node
+
+ Set_Paren_Count (Index_Node, Paren_Count (N));
+
-- Since we are correcting a node classification error made
-- by the parser, we call Replace rather than Rewrite.
- -- Preserve the parenthesis count of the node, for use by
- -- tools.
- Set_Paren_Count (Index_Node, Paren_Count (N));
Replace (N, Index_Node);
+
Set_Etype (Prefix (N), Ret_Type);
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 1df648d43b2..2720b4e1232 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -801,6 +801,7 @@ package Sem_Util is
-- function simply tests if it is True (i.e. non-zero)
function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean;
+ pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
function Is_Value_Type (T : Entity_Id) return Boolean;