OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_tss.ads, [...] (Find_Inherited_TSS): New subprogram... 

2005-03-08  Thomas Quinot  <quinot@adacore.com>

	* exp_tss.ads, exp_tss.adb (Find_Inherited_TSS): New subprogram, moved
	here from exp_attr so it can be shared between exp_attr and exp_dist.
	(TSS_Names): Renamed from OK_TSS_Names. This array contains the list of
	all TSS names, not a subset thereof, and the previous name introduced
	an unnecessarily confusion that a distinction might exist between
	"OK" TSS names and some "not OK" TSS names.

From-SVN: r96497
This commit is contained in:
Thomas Quinot 2005-03-15 17:01:51 +01:00 committed by Arnaud Charlet
parent 4ee27193ec
commit 6e40e48148
2 changed files with 58 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/exp_tss.adb
View File

@ -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;

25
gcc/ada/exp_tss.ads
View File

@ -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;