diff options
| -rw-r--r-- | gcc/ada/exp_tss.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/exp_tss.ads | 25 |
2 files changed, 58 insertions, 8 deletions
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 5068b242225..50d96053817 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 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- -- @@ -97,6 +97,41 @@ package body Exp_Tss is Prepend_Elmt (TSS, TSS_Elist (FN)); end Copy_TSS; + ------------------------ + -- Find_Inherited_TSS -- + ------------------------ + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id + is + Btyp : Entity_Id := Typ; + Proc : Entity_Id; + + begin + loop + Btyp := Base_Type (Btyp); + Proc := TSS (Btyp, Nam); + + exit when Present (Proc) + or else not Is_Derived_Type (Btyp); + + -- If Typ is a derived type, it may inherit attributes from some + -- ancestor. + + Btyp := Etype (Btyp); + end loop; + + if No (Proc) then + + -- If nothing else, use the TSS of the root type + + Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam); + end if; + + return Proc; + end Find_Inherited_TSS; + ----------------------- -- Get_TSS_Name_Type -- ----------------------- @@ -112,8 +147,8 @@ package body Exp_Tss is if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then Nm := (C1, C2); - for J in OK_TSS_Names'Range loop - if Nm = OK_TSS_Names (J) then + for J in TSS_Names'Range loop + if Nm = TSS_Names (J) then return Nm; end if; end loop; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index a85fff07d37..de3a20f6e68 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -77,21 +77,27 @@ package Exp_Tss is TSS_Deep_Finalize : constant TNT := "DF"; -- Deep Finalize TSS_Deep_Initialize : constant TNT := "DI"; -- Deep Initialize TSS_Composite_Equality : constant TNT := "EQ"; -- Composite Equality + TSS_From_Any : constant TNT := "FA"; -- PolyORB/DSA From_Any TSS_Init_Proc : constant TNT := "IP"; -- Initialization Procedure - TSS_RAS_Access : constant TNT := "RA"; -- RAs type access - TSS_RAS_Dereference : constant TNT := "RD"; -- RAs type deference + TSS_RAS_Access : constant TNT := "RA"; -- RAS type access + TSS_RAS_Dereference : constant TNT := "RD"; -- RAS type deference TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion TSS_Slice_Assign : constant TNT := "SA"; -- Slice assignment TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute TSS_Stream_Write : constant TNT := "SW"; -- Stream Write attribute + TSS_To_Any : constant TNT := "TA"; -- PolyORB/DSA To_Any + TSS_TypeCode : constant TNT := "TC"; -- PolyORB/DSA TypeCode - OK_TSS_Names : constant array (Natural range <>) of TSS_Name_Type := + -- The array below contains all valid TSS names + + TSS_Names : constant array (Natural range <>) of TSS_Name_Type := (TSS_Deep_Adjust, TSS_Deep_Finalize, TSS_Deep_Initialize, TSS_Composite_Equality, + TSS_From_Any, TSS_Init_Proc, TSS_RAS_Access, TSS_RAS_Dereference, @@ -100,7 +106,9 @@ package Exp_Tss is TSS_Stream_Input, TSS_Stream_Output, TSS_Stream_Read, - TSS_Stream_Write); + TSS_Stream_Write, + TSS_To_Any, + TSS_TypeCode); TSS_Null : constant TNT := " "; -- Dummy entry used to indicated that this is not really a TSS @@ -206,4 +214,11 @@ package Exp_Tss is -- is used to test for the presence of an init proc in cases where -- a null init proc is considered equivalent to no init proc. + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id; + -- Returns the TSS of name Nam of Typ, or of its closest ancestor defining + -- such a TSS. Empty is returned is neither Typ nor any of its ancestors + -- have such a TSS. + end Exp_Tss; |