diff options
Diffstat (limited to 'gcc/ada/einfo.adb')
| -rw-r--r-- | gcc/ada/einfo.adb | 159 |
1 files changed, 105 insertions, 54 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 39ab963..8606bf0 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -209,7 +209,8 @@ package body Einfo is -- Privals_Chain Elist23 -- Protected_Operation Node23 - -- (unused) Node24 + -- Obsolescent_Warning Node24 + -- (unused) Node25 -- (unused) Node26 -- (unused) Node27 @@ -391,6 +392,7 @@ package body Einfo is -- Vax_Float Flag151 -- Entry_Accepted Flag152 + -- Is_Obsolescent Flag153 -- Has_Per_Object_Constraint Flag154 -- Has_Private_Declaration Flag155 -- Referenced Flag156 @@ -424,10 +426,9 @@ package body Einfo is -- Has_Contiguous_Rep Flag181 -- Has_Xref_Entry Flag182 -- Must_Be_On_Byte_Boundary Flag183 + -- Has_Stream_Size_Clause Flag184 + -- Is_Ada_2005 Flag185 - -- (unused) Flag153 - -- (unused) Flag184 - -- (unused) Flag185 -- (unused) Flag186 -- (unused) Flag187 -- (unused) Flag188 @@ -459,6 +460,36 @@ package body Einfo is -- (unused) Flag214 -- (unused) Flag215 + ----------------------- + -- Local subprograms -- + ----------------------- + + function Rep_Clause (Id : E; Rep_Name : Name_Id) return N; + -- Returns the attribute definition clause whose name is Rep_Name. Returns + -- Empty if not found. + + ---------------- + -- Rep_Clause -- + ---------------- + + function Rep_Clause (Id : E; Rep_Name : Name_Id) return N is + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Attribute_Definition_Clause + and then Chars (Ritem) = Rep_Name + then + return Ritem; + else + Ritem := Next_Rep_Item (Ritem); + end if; + end loop; + + return Empty; + end Rep_Clause; + -------------------------------- -- Attribute Access Functions -- -------------------------------- @@ -1238,6 +1269,12 @@ package body Einfo is return Flag23 (Implementation_Base_Type (Id)); end Has_Storage_Size_Clause; + function Has_Stream_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Elementary_Type (Id)); + return Flag184 (Id); + end Has_Stream_Size_Clause; + function Has_Subprogram_Descriptor (Id : E) return B is begin return Flag93 (Id); @@ -1317,6 +1354,11 @@ package body Einfo is return Flag69 (Id); end Is_Access_Constant; + function Is_Ada_2005 (Id : E) return B is + begin + return Flag185 (Id); + end Is_Ada_2005; + function Is_Aliased (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -1574,6 +1616,12 @@ package body Einfo is return Flag178 (Id); end Is_Null_Init_Proc; + function Is_Obsolescent (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag153 (Id); + end Is_Obsolescent; + function Is_Optional_Parameter (Id : E) return B is begin pragma Assert (Is_Formal (Id)); @@ -1881,6 +1929,12 @@ package body Einfo is return Node17 (Id); end Object_Ref; + function Obsolescent_Warning (Id : E) return N is + begin + pragma Assert (Is_Subprogram (Id)); + return Node24 (Id); + end Obsolescent_Warning; + function Original_Access_Type (Id : E) return E is begin pragma Assert @@ -3171,6 +3225,12 @@ package body Einfo is Set_Flag23 (Id, V); end Set_Has_Storage_Size_Clause; + procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Elementary_Type (Id)); + Set_Flag184 (Id, V); + end Set_Has_Stream_Size_Clause; + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True) is begin Set_Flag93 (Id, V); @@ -3254,6 +3314,11 @@ package body Einfo is Set_Flag69 (Id, V); end Set_Is_Access_Constant; + procedure Set_Is_Ada_2005 (Id : E; V : B := True) is + begin + Set_Flag185 (Id, V); + end Set_Is_Ada_2005; + procedure Set_Is_Aliased (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3528,6 +3593,12 @@ package body Einfo is Set_Flag178 (Id, V); end Set_Is_Null_Init_Proc; + procedure Set_Is_Obsolescent (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag153 (Id, V); + end Set_Is_Obsolescent; + procedure Set_Is_Optional_Parameter (Id : E; V : B := True) is begin pragma Assert (Is_Formal (Id)); @@ -3840,6 +3911,12 @@ package body Einfo is Set_Node17 (Id, V); end Set_Object_Ref; + procedure Set_Obsolescent_Warning (Id : E; V : N) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Node24 (Id, V); + end Set_Obsolescent_Warning; + procedure Set_Original_Access_Type (Id : E; V : E) is begin pragma Assert @@ -4421,21 +4498,8 @@ package body Einfo is -------------------- function Address_Clause (Id : E) return N is - Ritem : Node_Id; - begin - Ritem := First_Rep_Item (Id); - while Present (Ritem) loop - if Nkind (Ritem) = N_Attribute_Definition_Clause - and then Chars (Ritem) = Name_Address - then - return Ritem; - else - Ritem := Next_Rep_Item (Ritem); - end if; - end loop; - - return Empty; + return Rep_Clause (Id, Name_Address); end Address_Clause; ---------------------- @@ -4443,35 +4507,20 @@ package body Einfo is ---------------------- function Alignment_Clause (Id : E) return N is - Ritem : Node_Id; - begin - Ritem := First_Rep_Item (Id); - while Present (Ritem) loop - if Nkind (Ritem) = N_Attribute_Definition_Clause - and then Chars (Ritem) = Name_Alignment - then - return Ritem; - else - Ritem := Next_Rep_Item (Ritem); - end if; - end loop; - - return Empty; + return Rep_Clause (Id, Name_Alignment); end Alignment_Clause; ---------------------- -- Ancestor_Subtype -- ---------------------- - function Ancestor_Subtype (Id : E) return E is + function Ancestor_Subtype (Id : E) return E is begin -- If this is first subtype, or is a base type, then there is no -- ancestor subtype, so we return Empty to indicate this fact. - if Is_First_Subtype (Id) - or else Id = Base_Type (Id) - then + if Is_First_Subtype (Id) or else Id = Base_Type (Id) then return Empty; end if; @@ -4623,7 +4672,7 @@ package body Einfo is then Full_D := Parent (Full_View (Id)); - -- The full view may have been rewritten as an object renaming. + -- The full view may have been rewritten as an object renaming if Nkind (Full_D) = N_Object_Renaming_Declaration then return Name (Full_D); @@ -4779,7 +4828,7 @@ package body Einfo is Ent := Next_Entity (Ent); end if; - -- Skip all hidden stored discriminants if any. + -- Skip all hidden stored discriminants if any while Present (Ent) loop exit when Ekind (Ent) = E_Discriminant @@ -5583,7 +5632,7 @@ package body Einfo is -- E_Discriminant d2 -- ... - -- so it is critical not to go past the leading discriminants. + -- so it is critical not to go past the leading discriminants D : E := Id; @@ -5903,23 +5952,19 @@ package body Einfo is ----------------- function Size_Clause (Id : E) return N is - Ritem : Node_Id; - begin - Ritem := First_Rep_Item (Id); - while Present (Ritem) loop - if Nkind (Ritem) = N_Attribute_Definition_Clause - and then Chars (Ritem) = Name_Size - then - return Ritem; - else - Ritem := Next_Rep_Item (Ritem); - end if; - end loop; - - return Empty; + return Rep_Clause (Id, Name_Size); end Size_Clause; + ------------------------ + -- Stream_Size_Clause -- + ------------------------ + + function Stream_Size_Clause (Id : E) return N is + begin + return Rep_Clause (Id, Name_Stream_Size); + end Stream_Size_Clause; + ------------------ -- Subtype_Kind -- ------------------ @@ -6216,6 +6261,7 @@ package body Einfo is W ("Has_Small_Clause", Flag67 (Id)); W ("Has_Specified_Layout", Flag100 (Id)); W ("Has_Storage_Size_Clause", Flag23 (Id)); + W ("Has_Stream_Size_Clause", Flag184 (Id)); W ("Has_Subprogram_Descriptor", Flag93 (Id)); W ("Has_Task", Flag30 (Id)); W ("Has_Unchecked_Union", Flag123 (Id)); @@ -6228,6 +6274,7 @@ package body Einfo is W ("Is_AST_Entry", Flag132 (Id)); W ("Is_Abstract", Flag19 (Id)); W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Ada_2005", Flag185 (Id)); W ("Is_Aliased", Flag15 (Id)); W ("Is_Asynchronous", Flag81 (Id)); W ("Is_Atomic", Flag85 (Id)); @@ -6275,6 +6322,7 @@ package body Einfo is W ("Is_Machine_Code_Subprogram", Flag137 (Id)); W ("Is_Non_Static_Subtype", Flag109 (Id)); W ("Is_Null_Init_Proc", Flag178 (Id)); + W ("Is_Obsolescent", Flag153 (Id)); W ("Is_Optional_Parameter", Flag134 (Id)); W ("Is_Overriding_Operation", Flag39 (Id)); W ("Is_Package_Body_Entity", Flag160 (Id)); @@ -7207,6 +7255,9 @@ package body Einfo is procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is + when Subprogram_Kind => + Write_Str ("Obsolescent_Warning"); + when others => Write_Str ("Field24??"); end case; |