This adds an internal abstraction for testing for standard string types.
Internal front end cleanup, no function effect, no test required.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-08-04 Robert Dewar <de...@adacore.com>
* einfo.ads, einfo.adb (Is_Standard_String_Type): New function.
* exp_ch3.adb (Build_Array_Init_Proc): Use
Is_Standard_String_Type.
(Expand_Freeze_Array_Type): ditto.
(Get_Simple_Init_Val): ditto.
(Needs_Simple_Initialization): ditto.
* sem_eval.adb (Eval_String_Literal): Use Is_Standard_String_Type.
* sem_warn.adb (Is_Suspicious_Type): Use Is_Standard_String_Type.
Index: einfo.adb
===================================================================
--- einfo.adb (revision 213565)
+++ einfo.adb (working copy)
@@ -7264,6 +7264,29 @@
end if;
end Is_Standard_Character_Type;
+ -----------------------------
+ -- Is_Standard_String_Type --
+ -----------------------------
+
+ function Is_Standard_String_Type (Id : E) return B is
+ begin
+ if Is_Type (Id) then
+ declare
+ R : constant Entity_Id := Root_Type (Id);
+ begin
+ return
+ R = Standard_String
+ or else
+ R = Standard_Wide_String
+ or else
+ R = Standard_Wide_Wide_String;
+ end;
+
+ else
+ return False;
+ end if;
+ end Is_Standard_String_Type;
+
--------------------
-- Is_String_Type --
--------------------
Index: einfo.ads
===================================================================
--- einfo.ads (revision 213566)
+++ einfo.ads (working copy)
@@ -2940,9 +2940,14 @@
-- Is_Standard_Character_Type (synthesized)
-- Applies to all entities, true for types and subtypes whose root type
--- is one of the standard character types (Character, Wide_Character,
+-- is one of the standard character types (Character, Wide_Character, or
-- Wide_Wide_Character).
+-- Is_Standard_String_Type (synthesized)
+-- Applies to all entities, true for types and subtypes whose root
+-- type is one of the standard string types (String, Wide_String, or
+-- Wide_Wide_String).
+
-- Is_Statically_Allocated (Flag28)
-- Defined in all entities. This can only be set for exception,
-- variable, constant, and type/subtype entities. If the flag is set,
@@ -5233,6 +5238,7 @@
-- Has_Foreign_Convention (synth)
-- Is_Dynamic_Scope (synth)
-- Is_Standard_Character_Type (synth)
+ -- Is_Standard_String_Type (synth)
-- Underlying_Type (synth)
-- all classification attributes (synth)
@@ -7002,6 +7008,7 @@
function Is_Protected_Interface (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B;
+ function Is_Standard_String_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
Index: sem_warn.adb
===================================================================
--- sem_warn.adb (revision 213568)
+++ sem_warn.adb (working copy)
@@ -3650,11 +3650,7 @@
if Is_Array_Type (Typ)
and then not Is_Constrained (Typ)
and then Number_Dimensions (Typ) = 1
- and then (Root_Type (Typ) = Standard_String
- or else
- Root_Type (Typ) = Standard_Wide_String
- or else
- Root_Type (Typ) = Standard_Wide_Wide_String)
+ and then Is_Standard_String_Type (Typ)
and then not Has_Warnings_Off (Typ)
then
LB := Type_Low_Bound (Etype (First_Index (Typ)));
Index: sem_eval.adb
===================================================================
--- sem_eval.adb (revision 213536)
+++ sem_eval.adb (working copy)
@@ -3661,16 +3661,11 @@
-- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
-- if its bounds are outside the index base type and this index type is
-- static. This can happen in only two ways. Either the string literal
- -- is too long, or it is null, and the lower bound is type'First. In
- -- either case it is the upper bound that is out of range of the index
- -- type.
+ -- is too long, or it is null, and the lower bound is type'First. Either
+ -- way it is the upper bound that is out of range of the index type.
+
if Ada_Version >= Ada_95 then
- if Root_Type (Bas) = Standard_String
- or else
- Root_Type (Bas) = Standard_Wide_String
- or else
- Root_Type (Bas) = Standard_Wide_Wide_String
- then
+ if Is_Standard_String_Type (Bas) then
Xtp := Standard_Positive;
else
Xtp := Etype (First_Index (Bas));
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 213584)
+++ exp_ch3.adb (working copy)
@@ -713,9 +713,7 @@
if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (A_Type)
- and then Root_Type (A_Type) /= Standard_String
- and then Root_Type (A_Type) /= Standard_Wide_String
- and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
+ and then not Is_Standard_String_Type (A_Type))
then
Proc_Id :=
Make_Defining_Identifier (Loc,
@@ -6257,10 +6255,7 @@
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
- elsif Root_Type (Base) = Standard_String
- or else Root_Type (Base) = Standard_Wide_String
- or else Root_Type (Base) = Standard_Wide_Wide_String
- then
+ elsif Is_Standard_String_Type (Base) then
null;
-- Otherwise we have to build an init proc for the subtype
@@ -8001,12 +7996,7 @@
-- String or Wide_[Wide]_String (must have Initialize_Scalars set)
- elsif Root_Type (T) = Standard_String
- or else
- Root_Type (T) = Standard_Wide_String
- or else
- Root_Type (T) = Standard_Wide_Wide_String
- then
+ elsif Is_Standard_String_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
return
@@ -9714,11 +9704,8 @@
-- filled with appropriate initializing values before they are used).
elsif Consider_IS_NS
+ and then Is_Standard_String_Type (T)
and then
- (Root_Type (T) = Standard_String or else
- Root_Type (T) = Standard_Wide_String or else
- Root_Type (T) = Standard_Wide_Wide_String)
- and then
(not Is_Itype (T)
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
then
