mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-11 18:01:34 +08:00
Code Issues Packages Projects Releases Wiki Activity

einfo.adb (Itype_Printed): New flag

Browse Source 
2005-12-05  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb (Itype_Printed): New flag
	(Is_Limited_Type): Derived types do not inherit limitedness from
	interface progenitors.
	(Is_Return_By_Reference_Type): Predicate does not apply to limited
	interfaces.

	* einfo.ads (Itype_Printed): New flag
	Move Is_Wrapper_Package to proper section
	Add missing Inline for Is_Volatile

	* output.ads, output.adb (Write_Erase_Char): New procedure
	(Save/Restore_Output_Buffer): New procedures
	(Save/Restore_Output_Buffer): New procedures

	* sprint.ads, sprint.adb (Write_Itype): Handle case of record itypes
	Add missing support for anonymous access type
	(Write_Id): Insert calls to Write_Itype
	(Write_Itype): New procedure to output itypes

	* par-ch12.adb (P_Formal_Derived_Type_Definition): In Ada 2005, handle
	use of "limited" in declaration.

	* sinfo.ads, sinfo.adb: 
	Formal derived types can carry an explicit "limited" indication.

	* sem_ch3.adb: Add with and use of Targparm.
	(Create_Component): If Frontend_Layout_On_Target is True and the
	copied component does not have a known static Esize, then reset
	the size and positional fields of the new component.
	(Analyze_Component_Declaration): A limited component is
	legal within a protected type that implements an interface.
	(Collect_Interfaces): Do not add to the list the interfaces that
	are implemented by the ancestors.
	(Derived_Type_Declaration): If the parent of the full-view is an
	interface perform a transformation of the tree to ensure that it has
	the same parent than the partial-view. This simplifies the job of the
	expander in order to generate the correct object layout, and it is
	needed because the list of interfaces of the full-view can be given in
	any order.
	(Process_Full_View): The parent of the full-view does not need to be
	a descendant of the parent of the partial view if both parents are
	interfaces.
	(Analyze_Private_Extension_Declaration): If declaration has an explicit
	"limited" the parent must be a limited type.
	(Build_Derived_Record_Type): A derived type that is explicitly limited
	must have limited ancestor and progenitors.
	(Build_Derived_Type): Ditto.
	(Process_Full_View): Verify that explicit uses of "limited" in partial
	and full declarations are consistent.
	(Find_Ancestor_Interface): Remove function.
	(Collect_Implemented_Interfaces): New procedure used to gather all
	implemented interfaces by a type.
	(Contain_Interface): New function used to check whether an interface is
	present in a list.
	(Find_Hidden_Interface): New function used to determine whether two
	lists of interfaces constitute a set equality. If not, the first
	differing interface is returned.
	(Process_Full_View): Improve the check for the "no hidden interface"
	rule as defined by AI-396.

From-SVN: r108295
This commit is contained in:
Robert Dewar 2005-12-09 18:19:49 +01:00 committed by Arnaud Charlet
parent ea985d9542
commit 653da90603
10 changed files with 1576 additions and 915 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/einfo.adb
View File

@ -452,8 +452,8 @@ package body Einfo is
-- Is_Task_Interface Flag200
-- Has_Anon_Block_Suffix Flag201
-- Itype_Printed Flag202
-- (unused) Flag202
-- (unused) Flag203
-- (unused) Flag204
-- (unused) Flag205
@ -1877,6 +1877,7 @@ package body Einfo is
function Is_Volatile (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
if Is_Type (Id) then
return Flag16 (Base_Type (Id));
else
@ -1884,6 +1885,12 @@ package body Einfo is
end if;
end Is_Volatile;
function Itype_Printed (Id : E) return B is
begin
pragma Assert (Is_Itype (Id));
return Flag202 (Id);
end Itype_Printed;
function Kill_Elaboration_Checks (Id : E) return B is
begin
return Flag32 (Id);
@ -4016,6 +4023,12 @@ package body Einfo is
Set_Flag16 (Id, V);
end Set_Is_Volatile;
procedure Set_Itype_Printed (Id : E; V : B := True) is
begin
pragma Assert (Is_Itype (Id));
Set_Flag202 (Id, V);
end Set_Itype_Printed;
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True) is
begin
Set_Flag32 (Id, V);
@ -5722,6 +5735,7 @@ package body Einfo is
function Is_Limited_Type (Id : E) return B is
Btype : constant E := Base_Type (Id);
Rtype : constant E := Root_Type (Btype);
begin
if not Is_Type (Id) then
@ -5744,11 +5758,17 @@ package body Einfo is
return False;
elsif Is_Record_Type (Btype) then
if Is_Limited_Record (Root_Type (Btype)) then
return True;
-- AI-419: limitedness is not inherited from a limited interface
if Is_Limited_Record (Rtype) then
return not Is_Interface (Rtype)
or else Is_Protected_Interface (Rtype)
or else Is_Synchronized_Interface (Rtype)
or else Is_Task_Interface (Rtype);
elsif Is_Class_Wide_Type (Btype) then
return Is_Limited_Type (Root_Type (Btype));
return Is_Limited_Type (Rtype);
else
declare
@ -5813,6 +5833,8 @@ package body Einfo is
-- Is_Return_By_Reference_Type --
---------------------------------
-- Note: this predicate has disappeared from Ada 2005: see AI-318-2
function Is_Return_By_Reference_Type (Id : E) return B is
Btype : constant Entity_Id := Base_Type (Id);
@ -5820,7 +5842,6 @@ package body Einfo is
if Is_Private_Type (Btype) then
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
@ -5834,7 +5855,10 @@ package body Einfo is
elsif Is_Record_Type (Btype) then
if Is_Limited_Record (Btype) then
return True;
return not Is_Interface (Btype)
or else Is_Protected_Interface (Btype)
or else Is_Synchronized_Interface (Btype)
or else Is_Task_Interface (Btype);
elsif Is_Class_Wide_Type (Btype) then
return Is_Return_By_Reference_Type (Root_Type (Btype));
@ -6700,6 +6724,7 @@ package body Einfo is
W ("Is_Valued_Procedure", Flag127 (Id));
W ("Is_Visible_Child_Unit", Flag116 (Id));
W ("Is_Volatile", Flag16 (Id));
W ("Itype_Printed", Flag202 (Id));
W ("Kill_Elaboration_Checks", Flag32 (Id));
W ("Kill_Range_Checks", Flag33 (Id));
W ("Kill_Tag_Checks", Flag34 (Id));

15
gcc/ada/einfo.ads
View File

@ -2469,6 +2469,10 @@ package Einfo is
-- Present in package entities. Indicates that the package has been
-- created as a wrapper for a subprogram instantiation.
-- Itype_Printed (Flag202)
-- Set in Itypes if the Itype has been printed by Sprint. This is used to
-- avoid printing an Itype more than once.
-- Kill_Elaboration_Checks (Flag32)
-- Present in all entities. Set by the expander to kill elaboration
-- checks which are known not to be needed. Equivalent in effect to
@ -4166,6 +4170,7 @@ package Einfo is
-- Is_Tagged_Type (Flag55)
-- Is_Unsigned_Type (Flag144)
-- Is_Volatile (Flag16)
-- Itype_Printed (Flag202) (itypes only)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Size_Depends_On_Discriminant (Flag177)
-- Size_Known_At_Compile_Time (Flag92)
@ -5363,7 +5368,6 @@ package Einfo is
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
@ -5387,7 +5391,7 @@ package Einfo is
function Is_Valued_Procedure (Id : E) return B;
function Is_Visible_Child_Unit (Id : E) return B;
function Is_Volatile (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Itype_Printed (Id : E) return B;
function Kill_Elaboration_Checks (Id : E) return B;
function Kill_Range_Checks (Id : E) return B;
function Kill_Tag_Checks (Id : E) return B;
@ -5567,6 +5571,7 @@ package Einfo is
function Is_Return_By_Reference_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Next_Component (Id : E) return E;
function Next_Discriminant (Id : E) return E;
function Next_Formal (Id : E) return E;
@ -5890,6 +5895,7 @@ package Einfo is
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True);
procedure Set_Is_Volatile (Id : E; V : B := True);
procedure Set_Itype_Printed (Id : E; V : B := True);
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
procedure Set_Kill_Range_Checks (Id : E; V : B := True);
procedure Set_Kill_Tag_Checks (Id : E; V : B := True);
@ -6445,7 +6451,6 @@ package Einfo is
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type);
@ -6477,6 +6482,7 @@ package Einfo is
pragma Inline (Is_VMS_Exception);
pragma Inline (Is_Valued_Procedure);
pragma Inline (Is_Visible_Child_Unit);
pragma Inline (Itype_Printed);
pragma Inline (Kill_Elaboration_Checks);
pragma Inline (Kill_Range_Checks);
pragma Inline (Kill_Tag_Checks);
@ -6788,7 +6794,6 @@ package Einfo is
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Protected_Interface);
@ -6812,6 +6817,7 @@ package Einfo is
pragma Inline (Set_Is_Valued_Procedure);
pragma Inline (Set_Is_Visible_Child_Unit);
pragma Inline (Set_Is_Volatile);
pragma Inline (Set_Itype_Printed);
pragma Inline (Set_Kill_Elaboration_Checks);
pragma Inline (Set_Kill_Range_Checks);
pragma Inline (Set_Kill_Tag_Checks);
@ -6909,6 +6915,7 @@ package Einfo is
-- access/set format that can be handled by xeinfo.
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);
pragma Inline (Known_Static_Component_Bit_Offset);

81
gcc/ada/output.adb
View File

@ -42,29 +42,6 @@ package body Output is
-- Record argument to last call to Set_Special_Output. If this is
-- non-null, then we are in special output mode.
-------------------------
-- Line Buffer Control --
-------------------------
-- Note: the following buffer and column position are maintained by
-- the subprograms defined in this package, and are not normally
-- directly modified or accessed by a client. However, a client is
-- permitted to modify these values, using the knowledge that only
-- Write_Eol actually generates any output.
Buffer_Max : constant := 8192;
Buffer : String (1 .. Buffer_Max + 1);
-- Buffer used to build output line. We do line buffering because it
-- is needed for the support of the debug-generated-code option (-gnatD).
-- Historically it was first added because on VMS, line buffering is
-- needed with certain file formats. So in any case line buffering must
-- be retained for this purpose, even if other reasons disappear. Note
-- any attempt to write more output to a line than can fit in the buffer
-- will be silently ignored.
Next_Column : Pos range 1 .. Buffer'Length + 1 := 1;
-- Column about to be written
-----------------------
-- Local_Subprograms --
-----------------------
@ -86,7 +63,7 @@ package body Output is
------------------
procedure Flush_Buffer is
Len : constant Natural := Natural (Next_Column - 1);
Len : constant Natural := Next_Col - 1;
begin
if Len /= 0 then
@ -111,7 +88,7 @@ package body Output is
else
Current_FD := Standerr;
Next_Column := 1;
Next_Col := 1;
Write_Line ("fatal error: disk full");
OS_Exit (2);
end if;
@ -119,7 +96,7 @@ package body Output is
-- Buffer is now empty
Next_Column := 1;
Next_Col := 1;
end if;
end Flush_Buffer;
@ -127,11 +104,34 @@ package body Output is
-- Column --
------------
function Column return Nat is
function Column return Pos is
begin
return Next_Column;
return Pos (Next_Col);
end Column;
---------------------------
-- Restore_Output_Buffer --
---------------------------
procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
begin
Next_Col := S.Next_Col;
Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
end Restore_Output_Buffer;
------------------------
-- Save_Output_Buffer --
------------------------
function Save_Output_Buffer return Saved_Output_Buffer is
S : Saved_Output_Buffer;
begin
S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
S.Next_Col := Next_Col;
Next_Col := 1;
return S;
end Save_Output_Buffer;
------------------------
-- Set_Special_Output --
------------------------
@ -149,7 +149,7 @@ package body Output is
begin
if Special_Output_Proc = null then
Flush_Buffer;
Next_Column := 1;
Next_Col := 1;
end if;
Current_FD := Standerr;
@ -163,7 +163,7 @@ package body Output is
begin
if Special_Output_Proc = null then
Flush_Buffer;
Next_Column := 1;
Next_Col := 1;
end if;
Current_FD := Standout;
@ -236,12 +236,12 @@ package body Output is
procedure Write_Char (C : Character) is
begin
if Next_Column = Buffer'Length then
if Next_Col = Buffer'Length then
Write_Eol;
end if;
Buffer (Natural (Next_Column)) := C;
Next_Column := Next_Column + 1;
Buffer (Next_Col) := C;
Next_Col := Next_Col + 1;
end Write_Char;
---------------
@ -250,11 +250,22 @@ package body Output is
procedure Write_Eol is
begin
Buffer (Natural (Next_Column)) := ASCII.LF;
Next_Column := Next_Column + 1;
Buffer (Next_Col) := ASCII.LF;
Next_Col := Next_Col + 1;
Flush_Buffer;
end Write_Eol;
----------------------
-- Write_Erase_Char --
----------------------
procedure Write_Erase_Char (C : Character) is
begin
if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
Next_Col := Next_Col - 1;
end if;
end Write_Erase_Char;
---------------
-- Write_Int --
---------------

53
gcc/ada/output.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 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- --
@ -35,7 +35,8 @@
-- for writing error messages and informational output. It is also used
-- by the debug source file output routines (see Sprintf.Print_Eol).
with Types; use Types;
with Hostparm; use Hostparm;
with Types; use Types;
package Output is
pragma Elaborate_Body;
@ -86,6 +87,9 @@ package Output is
-- Write one character to the standard output file. Note that the
-- character should not be LF or CR (use Write_Eol for end of line)
procedure Write_Erase_Char (C : Character);
-- If last character in buffer matches C, erase it, otherwise no effect
procedure Write_Eol;
-- Write an end of line (whatever is required by the system in use,
-- e.g. CR/LF for DOS, or LF for Unix) to the standard output file.
@ -106,11 +110,30 @@ package Output is
procedure Write_Line (S : String);
-- Equivalent to Write_Str (S) followed by Write_Eol;
function Column return Nat;
function Column return Pos;
pragma Inline (Column);
-- Returns the number of the column about to be written (e.g. a value
-- of 1 means the current line is empty).
-------------------------
-- Buffer Save/Restore --
-------------------------
-- This facility allows the current line buffer to be saved and restored
type Saved_Output_Buffer is private;
-- Type used for Save/Restore_Buffer
Buffer_Max : constant := Hostparm.Max_Line_Length;
-- Maximal size of a buffered output line
function Save_Output_Buffer return Saved_Output_Buffer;
-- Save current line buffer and reset line buffer to empty
procedure Restore_Output_Buffer (S : Saved_Output_Buffer);
-- Restore previously saved output buffer. The value in S is not affected
-- so it is legtimate to restore a buffer more than once.
--------------------------
-- Debugging Procedures --
--------------------------
@ -144,4 +167,28 @@ package Output is
procedure w (L : String; B : Boolean);
-- Dump contents of string followed by blank, Boolean, line return
private
-- Note: the following buffer and column position are maintained by the
-- subprograms defined in this package, and cannot be directly modified or
-- accessed by a client.
Buffer : String (1 .. Buffer_Max + 1);
for Buffer'Alignment use 4;
-- Buffer used to build output line. We do line buffering because it
-- is needed for the support of the debug-generated-code option (-gnatD).
-- Historically it was first added because on VMS, line buffering is
-- needed with certain file formats. So in any case line buffering must
-- be retained for this purpose, even if other reasons disappear. Note
-- any attempt to write more output to a line than can fit in the buffer
-- will be silently ignored. The alignment clause improves the efficiency
-- of the save/restore procedures.
Next_Col : Positive range 1 .. Buffer'Length + 1 := 1;
-- Column about to be written
type Saved_Output_Buffer is record
Buffer : String (1 .. Buffer_Max + 1);
Next_Col : Positive;
end record;
end Output;

69
gcc/ada/par-ch12.adb
View File

@ -519,6 +519,9 @@ package body Ch12 is
-- exception is ABSTRACT, where we have to scan ahead to see if we
-- have a formal derived type or a formal private type definition.
-- In addition, in Ada 2005 LIMITED may appear after abstract, so
-- that the lookahead must be extended by one more token.
when Tok_Abstract =>
Save_Scan_State (Scan_State);
Scan; -- past ABSTRACT
@ -527,6 +530,18 @@ package body Ch12 is
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Derived_Type_Definition;
elsif Token = Tok_Limited then
Scan; -- past LIMITED
if Token = Tok_New then
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Derived_Type_Definition;
else
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Private_Type_Definition;
end if;
else
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Private_Type_Definition;
@ -560,7 +575,25 @@ package body Ch12 is
Set_Limited_Present (Typedef_Node);
return Typedef_Node;
elsif Token = Tok_New then
Restore_Scan_State (Scan_State); -- to LIMITED
return P_Formal_Derived_Type_Definition;
else
if Token = Tok_Abstract then
Error_Msg_SC ("ABSTRACT must come before LIMITED");
Scan; -- past improper ABSTRACT
if Token = Tok_New then
Restore_Scan_State (Scan_State); -- to LIMITED
return P_Formal_Derived_Type_Definition;
else
Restore_Scan_State (Scan_State);
return P_Formal_Private_Type_Definition;
end if;
end if;
Restore_Scan_State (Scan_State);
return P_Formal_Private_Type_Definition;
end if;
@ -666,6 +699,20 @@ package body Ch12 is
Scan; -- past LIMITED
end if;
if Token = Tok_Abstract then
if Prev_Token = Tok_Tagged then
Error_Msg_SC ("ABSTRACT must come before TAGGED");
elsif Prev_Token = Tok_Limited then
Error_Msg_SC ("ABSTRACT must come before LIMITED");
end if;
Resync_Past_Semicolon;
elsif Token = Tok_Tagged then
Error_Msg_SC ("TAGGED must come before LIMITED");
Resync_Past_Semicolon;
end if;
Set_Sloc (Def_Node, Token_Ptr);
T_Private;
return Def_Node;
@ -676,9 +723,11 @@ package body Ch12 is
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
-- [abstract] new SUBTYPE_MARK [[AND interface_list] with private]
-- [abstract] [limited]
-- new SUBTYPE_MARK [[AND interface_list] with private]
-- The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
-- The caller has checked the initial token(s) is/are NEW, ASTRACT NEW
-- LIMITED NEW, or ABSTRACT LIMITED NEW
-- Error recovery: cannot raise Error_Resync
@ -693,6 +742,22 @@ package body Ch12 is
Scan; -- past ABSTRACT
end if;
if Token = Tok_Limited then
Set_Limited_Present (Def_Node);
Scan; -- past Limited
if Ada_Version < Ada_05 then
Error_Msg_SP
("LIMITED in derived type is an Ada 2005 extension");
Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
end if;
if Token = Tok_Abstract then
Scan; -- past ABSTRACT. diagnosed already in caller.
end if;
end if;
Scan; -- past NEW;
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;

415
gcc/ada/sem_ch3.adb
View File

@ -65,6 +65,7 @@ with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@ -1416,6 +1417,7 @@ package body Sem_Ch3 is
elsif not Is_Derived_Type (Current_Scope)
and then not Is_Limited_Record (Current_Scope)
and then not Is_Concurrent_Type (Current_Scope)
then
Error_Msg_N
("nonlimited tagged type cannot have limited components", N);
@ -2654,6 +2656,15 @@ package body Sem_Ch3 is
end if;
Build_Derived_Record_Type (N, Parent_Type, T);
if Limited_Present (N) then
Set_Is_Limited_Record (T);
if not Is_Limited_Type (Parent_Type) then
Error_Msg_NE ("parent type& of limited extension must be limited",
N, Parent_Type);
end if;
end if;
end Analyze_Private_Extension_Declaration;
---------------------------------
@ -5703,8 +5714,12 @@ package body Sem_Ch3 is
-- are only specified for limited records. For completeness, these
-- flags are also initialized along with all the other flags below.
-- AI-419: limitedness is not inherited from an interface parent
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
Set_Is_Limited_Record (Derived_Type,
Is_Limited_Record (Parent_Type)
and then not Is_Interface (Parent_Type));
-- STEP 2a: process discriminants of derived type if any
@ -5887,7 +5902,9 @@ package body Sem_Ch3 is
Set_Is_Limited_Composite
(Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Limited_Record
(Derived_Type, Is_Limited_Record (Parent_Type));
(Derived_Type,
Is_Limited_Record (Parent_Type)
and then not Is_Interface (Parent_Type));
Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type));
@ -7646,7 +7663,7 @@ package body Sem_Ch3 is
end if;
end Add_Interface;
-- Start of processing for Add_Interface
-- Start of processing for Collect_Interfaces
begin
pragma Assert (False
@ -7682,29 +7699,6 @@ package body Sem_Ch3 is
Next (Intf);
end loop;
-- A type extension may be written as a derivation from an interface.
-- The completion will have to implement the same, or derive from a
-- type that implements it as well.
elsif Nkind (N) = N_Private_Extension_Declaration
and then Is_Interface (Etype (Derived_Type))
then
Add_Interface (Etype (Derived_Type));
end if;
-- Same for task and protected types, that can derive directly from
-- an interface (and implement additional interfaces that will be
-- present in the interface list of the declaration).
if Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration
or else Nkind (N) = N_Single_Protected_Declaration
or else Nkind (N) = N_Single_Task_Declaration
then
if Is_Interface (Etype (Derived_Type)) then
Add_Interface (Etype (Derived_Type));
end if;
end if;
end Collect_Interfaces;
@ -9719,24 +9713,42 @@ package body Sem_Ch3 is
New_Compon : constant Entity_Id := New_Copy (Old_Compon);
begin
-- Set the parent so we have a proper link for freezing etc. This
-- is not a real parent pointer, since of course our parent does
-- not own up to us and reference us, we are an illegitimate
-- child of the original parent!
-- Set the parent so we have a proper link for freezing etc. This is
-- not a real parent pointer, since of course our parent does not own
-- up to us and reference us, we are an illegitimate child of the
-- original parent!
Set_Parent (New_Compon, Parent (Old_Compon));
-- If the old component's Esize was already determined and is a
-- static value, then the new component simply inherits it. Otherwise
-- the old component's size may require run-time determination, but
-- the new component's size still might be statically determinable
-- (if, for example it has a static constraint). In that case we want
-- Layout_Type to recompute the component's size, so we reset its
-- size and positional fields.
if Frontend_Layout_On_Target
and then not Known_Static_Esize (Old_Compon)
then
Set_Esize (New_Compon, Uint_0);
Init_Normalized_First_Bit (New_Compon);
Init_Normalized_Position (New_Compon);
Init_Normalized_Position_Max (New_Compon);
end if;
-- We do not want this node marked as Comes_From_Source, since
-- otherwise it would get first class status and a separate
-- cross-reference line would be generated. Illegitimate
-- children do not rate such recognition.
-- otherwise it would get first class status and a separate cross-
-- reference line would be generated. Illegitimate children do not
-- rate such recognition.
Set_Comes_From_Source (New_Compon, False);
-- But it is a real entity, and a birth certificate must be
-- properly registered by entering it into the entity list.
-- But it is a real entity, and a birth certificate must be properly
-- registered by entering it into the entity list.
Enter_Name (New_Compon);
return New_Compon;
end Create_Component;
@ -10749,6 +10761,13 @@ package body Sem_Ch3 is
if not Is_Interface (T) then
Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T);
elsif Limited_Present (Def)
and then not Is_Limited_Interface (T)
then
Error_Msg_NE
("progenitor interface& of limited type must be limited",
N, T);
end if;
Next (Intf);
@ -10782,6 +10801,100 @@ package body Sem_Ch3 is
return;
end if;
-- Ada 2005 (AI-251): The case in which the parent of the full-view is
-- an interface is special because the list of interfaces in the full
-- view can be given in any order. For example:
-- type A is interface;
-- type B is interface and A;
-- type D is new B with private;
-- private
-- type D is new A and B with null record; -- 1 --
-- In this case we perform the following transformation of -1-:
-- type D is new B and A with null record;
-- If the parent of the full-view covers the parent of the partial-view
-- we have two possible cases:
-- 1) They have the same parent
-- 2) The parent of the full-view implements some further interfaces
-- In both cases we do not need to perform the transformation. In the
-- first case the source program is correct and the transformation is
-- not needed; in the second case the source program does not fulfill
-- the no-hidden interfaces rule (AI-396) and the error will be reported
-- later.
-- This transformation not only simplifies the rest of the analysis of
-- this type declaration but also simplifies the correct generation of
-- the object layout to the expander.
if In_Private_Part (Current_Scope)
and then Is_Interface (Parent_Type)
then
declare
Iface : Node_Id;
Partial_View : Entity_Id;
Partial_View_Parent : Entity_Id;
New_Iface : Node_Id;
begin
-- Look for the associated private type declaration
Partial_View := First_Entity (Current_Scope);
loop
exit when not Present (Partial_View)
or else (Has_Private_Declaration (Partial_View)
and then Full_View (Partial_View) = T);
Next_Entity (Partial_View);
end loop;
-- If the partial view was not found then the source code has
-- errors and the transformation is not needed.
if Present (Partial_View) then
Partial_View_Parent := Etype (Partial_View);
-- If the parent of the full-view covers the parent of the
-- partial-view we have nothing else to do.
if Interface_Present_In_Ancestor
(Parent_Type, Partial_View_Parent)
then
null;
-- Traverse the list of interfaces of the full-view to look
-- for the parent of the partial-view and perform the tree
-- transformation.
else
Iface := First (Interface_List (Def));
while Present (Iface) loop
if Etype (Iface) = Etype (Partial_View) then
Rewrite (Subtype_Indication (Def),
New_Copy (Subtype_Indication
(Parent (Partial_View))));
New_Iface := Make_Identifier (Sloc (N),
Chars (Parent_Type));
Append (New_Iface, Interface_List (Def));
-- Analyze the transformed code
Derived_Type_Declaration (T, N, Is_Completion);
return;
end if;
Next (Iface);
end loop;
end if;
end if;
end;
end if;
-- Only composite types other than array types are allowed to have
-- discriminants.
@ -10905,6 +11018,20 @@ package body Sem_Ch3 is
end if;
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
-- AI-419: the parent type of an explicitly limited derived type must
-- be limited. Interface progenitors were checked earlier.
if Limited_Present (Def) then
Set_Is_Limited_Record (T);
if not Is_Limited_Type (Parent_Type)
and then not Is_Interface (Parent_Type)
then
Error_Msg_NE ("parent type& of limited type must be limited",
N, Parent_Type);
end if;
end if;
end Derived_Type_Declaration;
----------------------------------
@ -13186,36 +13313,136 @@ package body Sem_Ch3 is
Full_Parent : Entity_Id;
Full_Indic : Node_Id;
function Find_Ancestor_Interface
(Typ : Entity_Id) return Entity_Id;
-- Find an implemented interface in the derivation chain of Typ
procedure Collect_Implemented_Interfaces
(Typ : Entity_Id;
Ifaces : Elist_Id);
-- Ada 2005: Gather all the interfaces that Typ directly or
-- inherently implements. Duplicate entries are not added to
-- the list Ifaces.
-----------------------------
-- Find_Ancestor_Interface --
-----------------------------
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean;
-- Ada 2005: Determine whether Iface is present in the list Ifaces
function Find_Ancestor_Interface
(Typ : Entity_Id) return Entity_Id
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id;
-- Ada 2005: Determine whether the interfaces in list Src are all
-- present in the list Dest. Return the first differing interface,
-- or Empty otherwise.
------------------------------------
-- Collect_Implemented_Interfaces --
------------------------------------
procedure Collect_Implemented_Interfaces
(Typ : Entity_Id;
Ifaces : Elist_Id)
is
T : Entity_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
T := Typ;
while T /= Etype (T) loop
if Is_Interface (Etype (T)) then
return Etype (T);
end if;
-- Implementations of the form:
-- type Typ is new Iface ...
T := Etype (T);
if Is_Interface (Etype (Typ))
and then not Contain_Interface (Etype (Typ), Ifaces)
then
Append_Elmt (Etype (Typ), Ifaces);
end if;
-- Protect us against erroneous code that has a large
-- chain of circularity dependencies
-- Implementations of the form:
-- type Typ is ... and Iface ...
exit when T = Typ;
end loop;
if Present (Abstract_Interfaces (Typ)) then
Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Is_Interface (Iface)
and then not Contain_Interface (Iface, Ifaces)
then
Append_Elmt (Iface, Ifaces);
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
-- Implementations of the form:
-- type Typ is new Parent_Typ and ...
if Ekind (Typ) = E_Record_Type
and then Present (Parent_Subtype (Typ))
then
Collect_Implemented_Interfaces (Parent_Subtype (Typ), Ifaces);
-- Implementations of the form:
-- type Typ is ... with private;
elsif Ekind (Typ) = E_Record_Type_With_Private
and then Present (Full_View (Typ))
and then Etype (Typ) /= Full_View (Typ)
and then Etype (Typ) /= Typ
then
Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
end if;
end Collect_Implemented_Interfaces;
-----------------------
-- Contain_Interface --
-----------------------
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean
is
Iface_Elmt : Elmt_Id;
begin
if Present (Ifaces) then
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
if Node (Iface_Elmt) = Iface then
return True;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return False;
end Contain_Interface;
---------------------------
-- Find_Hidden_Interface --
---------------------------
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id
is
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
if Present (Src) and then Present (Dest) then
Iface_Elmt := First_Elmt (Src);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if not Contain_Interface (Iface, Dest) then
return Iface;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return Empty;
end Find_Ancestor_Interface;
end Find_Hidden_Interface;
-- Start of processing for Process_Full_View
@ -13255,49 +13482,28 @@ package body Sem_Ch3 is
Error_Msg_N ("generic type cannot have a completion", Full_T);
end if;
-- Ada 2005 (AI-396): A full view shall be a descendant of an
-- interface type if and only if the corresponding partial view
-- (if any) is also a descendant of the interface type, or if
-- the partial view is untagged.
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Priv_T)
and then Is_Tagged_Type (Full_T)
then
declare
Iface : Entity_Id;
Iface_Def : Node_Id;
Iface : Entity_Id;
Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
begin
Iface := Find_Ancestor_Interface (Full_T);
Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
-- Ada 2005 (AI-396): The partial view shall be a descendant of
-- an interface type if and only if the full view is a descendant
-- of the interface type.
Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
if Present (Iface) then
Iface_Def := Type_Definition (Parent (Iface));
-- The full view derives from an interface descendant, but the
-- partial view does not share the same tagged type.
if Is_Tagged_Type (Priv_T)
and then Etype (Priv_T) /= Etype (Full_T)
and then Etype (Priv_T) /= Iface
then
Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
"completed by a type that implements an " &
"interface", Priv_T);
end if;
-- The full view derives from a limited, protected,
-- synchronized or task interface descendant, but the
-- partial view is not labeled as limited.
if (Limited_Present (Iface_Def)
or else Protected_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Task_Present (Iface_Def))
and then not Limited_Present (Parent (Priv_T))
then
Error_Msg_N ("(Ada 2005) non-limited private type cannot be "
& "completed by a limited type", Priv_T);
end if;
Error_Msg_NE ("interface & not implemented by partial view " &
"('R'M'-2005 7.3(9))", Full_T, Iface);
end if;
end;
end if;
@ -13328,6 +13534,15 @@ package body Sem_Ch3 is
if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
return;
-- Ada 2005 (AI-251): Interfaces in the full-typ can be given in
-- any order. Therefore we don't have to check that its parent must
-- be a descendant of the parent of the private type declaration.
elsif Is_Interface (Priv_Parent)
and then Is_Interface (Full_Parent)
then
null;
elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
Error_Msg_N
("parent of full type must descend from parent"
@ -13428,6 +13643,23 @@ package body Sem_Ch3 is
end if;
end if;
-- AI-419: verify that the use of "limited" is consistent
declare
Orig_Decl : constant Node_Id := Original_Node (N);
begin
if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
and then not Limited_Present (Parent (Priv_T))
and then Nkind (Orig_Decl) = N_Full_Type_Declaration
and then Nkind
(Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
and then Limited_Present (Type_Definition (Orig_Decl))
then
Error_Msg_N
("full view of non-limited extension cannot be limited", N);
end if;
end;
-- Ada 2005 AI-363: if the full view has discriminants with
-- defaults, it is illegal to declare constrained access subtypes
-- whose designated type is the current type. This allows objects
@ -14072,8 +14304,7 @@ package body Sem_Ch3 is
if Nkind (Parent (S)) /= N_Access_To_Object_Definition
and then not
(Nkind (Parent (S)) = N_Subtype_Declaration
and then
Is_Itype (Defining_Identifier (Parent (S))))
and then Is_Itype (Defining_Identifier (Parent (S))))
then
Check_Incomplete (Subtype_Mark (S));
end if;

2
gcc/ada/sinfo.adb
View File

@ -1692,6 +1692,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration
@ -4278,6 +4279,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration

1512
gcc/ada/sinfo.ads
View File

File diff suppressed because it is too large Load Diff

306
gcc/ada/sprint.adb
View File

@ -193,7 +193,7 @@ package body Sprint is
-- declarations that can have discriminants.
procedure Write_Ekind (E : Entity_Id);
-- Write the String corresponding to the Ekind without "E_".
-- Write the String corresponding to the Ekind without "E_"
procedure Write_Id (N : Node_Id);
-- N is a node with a Chars field. This procedure writes the name that
@ -203,7 +203,8 @@ package body Sprint is
-- the name associated with the entity (since it may have been encoded).
-- One other special case is that an entity has an active external name
-- (i.e. an external name present with no address clause), then this
-- external name is output.
-- external name is output. This procedure also deals with outputting
-- declarations of referenced itypes, if not output earlier.
function Write_Identifiers (Node : Node_Id) return Boolean;
-- Handle node where the grammar has a list of defining identifiers, but
@ -238,6 +239,10 @@ package body Sprint is
-- the Sloc of the current node is set to the first non-blank character
-- in the string S.
procedure Write_Itype (Typ : Entity_Id);
-- If Typ is an Itype that has not been written yet, write it. If Typ is
-- any other kind of entity or tree node, the call is ignored.
procedure Write_Name_With_Col_Check (N : Name_Id);
-- Write name (using Write_Name) with initial column check, and possible
-- initial Write_Indent (to get new line) if current line is too full.
@ -272,6 +277,11 @@ package body Sprint is
-- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug
-- node to first non-blank character if a current debug node is active.
procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format);
-- Write Uint (using UI_Write) with initial column check, and possible
-- initial Write_Indent (to get new line) if current line is too full.
-- The format parameter determines the output format (see UI_Write).
procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
-- Write Uint (using UI_Write) with initial column check, and possible
-- initial Write_Indent (to get new line) if current line is too full.
@ -417,7 +427,7 @@ package body Sprint is
Write_Eol;
end Underline;
-- Start of processing for Tree_Dump.
-- Start of processing for Tree_Dump
begin
Dump_Generated_Only := Debug_Flag_G or
@ -1078,7 +1088,6 @@ package body Sprint is
Condition : constant Node_Id := First (Expressions (Node));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
begin
Write_Str_With_Col_Check_Sloc ("(if ");
Sprint_Node (Condition);
@ -2344,7 +2353,6 @@ package body Sprint is
declare
Alt_Node : Node_Id;
begin
Alt_Node := First (Select_Alternatives (Node));
loop
@ -2607,7 +2615,6 @@ package body Sprint is
declare
Node1 : Node_Id;
begin
Node1 := First (Subtype_Marks (Node));
loop
@ -2808,9 +2815,7 @@ package body Sprint is
if Dump_Original_Only then
N := First (List);
while Present (N) loop
if not Is_Rewrite_Insertion (N) then
Node_Exists := True;
exit;
@ -2944,6 +2949,19 @@ package body Sprint is
procedure Write_Id (N : Node_Id) is
begin
-- Deal with outputting Itype
-- Note: if we are printing the full tree with -gnatds, then we may
-- end up picking up the Associated_Node link from a generic template
-- here which overlaps the Entity field, but as documented, Write_Itype
-- is defended against junk calls.
if Nkind (N) in N_Entity then
Write_Itype (N);
elsif Nkind (N) in N_Has_Entity then
Write_Itype (Entity (N));
end if;
-- Case of a defining identifier
if Nkind (N) = N_Defining_Identifier then
@ -3022,7 +3040,6 @@ package body Sprint is
Write_Str_With_Col_Check (" (");
Ind := First_Index (E);
while Present (Ind) loop
Sprint_Node (Ind);
Next_Index (Ind);
@ -3153,6 +3170,266 @@ package body Sprint is
Write_Str_Sloc (S);
end Write_Indent_Str_Sloc;
-----------------
-- Write_Itype --
-----------------
procedure Write_Itype (Typ : Entity_Id) is
procedure Write_Header (T : Boolean := True);
-- Write type if T is True, subtype if T is false
------------------
-- Write_Header --
------------------
procedure Write_Header (T : Boolean := True) is
begin
if T then
Write_Str ("[type ");
else
Write_Str ("[subtype ");
end if;
Write_Name_With_Col_Check (Chars (Typ));
Write_Str (" is ");
end Write_Header;
-- Start of processing for Write_Itype
begin
if Nkind (Typ) in N_Entity
and then Is_Itype (Typ)
and then not Itype_Printed (Typ)
then
-- Itype to be printed
declare
B : constant Node_Id := Etype (Typ);
X : Node_Id;
P : constant Node_Id := Parent (Typ);
S : constant Saved_Output_Buffer := Save_Output_Buffer;
-- Save current output buffer
begin
-- Write indentation at start of line
for J in 1 .. Indent loop
Write_Char (' ');
end loop;
-- If we have a constructed declaration, print it
if Present (P) and then Nkind (P) in N_Declaration then
-- We must set Itype_Printed true before the recursive call to
-- print the node, otherwise we get an infinite recursion!
Set_Itype_Printed (Typ, True);
-- Write the declaration enclosed in [], avoiding new line
-- at start of declaration, and semicolon at end.
Write_Char ('[');
Indent_Annull_Flag := True;
Sprint_Node (P);
Write_Erase_Char (';');
-- If no constructed declaration, then we have to concoct the
-- source corresponding to the type entity that we have at hand.
else
case Ekind (Typ) is
-- Access types and subtypes
when Access_Kind =>
Write_Header (Ekind (Typ) = E_Access_Type);
Write_Str ("access ");
if Is_Access_Constant (Typ) then
Write_Str ("constant ");
elsif Can_Never_Be_Null (Typ) then
Write_Str ("not null ");
end if;
Write_Id (Directly_Designated_Type (Typ));
-- Array types and string types
when E_Array_Type | E_String_Type =>
Write_Header;
Write_Str ("array (");
X := First_Index (Typ);
loop
Sprint_Node (X);
if not Is_Constrained (Typ) then
Write_Str (" range <>");
end if;
Next_Index (X);
exit when No (X);
Write_Str (", ");
end loop;
Write_Str (") of ");
Sprint_Node (Component_Type (Typ));
-- Array subtypes and string subtypes
when E_Array_Subtype | E_String_Subtype =>
Write_Header (False);
Write_Id (Etype (Typ));
Write_Str (" (");
X := First_Index (Typ);
loop
Sprint_Node (X);
Next_Index (X);
exit when No (X);
Write_Str (", ");
end loop;
Write_Char (')');
-- Signed integer types, and modular integer subtypes
when E_Signed_Integer_Type |
E_Signed_Integer_Subtype |
E_Modular_Integer_Subtype =>
Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
if Ekind (Typ) = E_Signed_Integer_Type then
Write_Str ("new ");
end if;
Write_Id (B);
-- Print bounds if not different from base type
declare
L : constant Node_Id := Type_Low_Bound (Typ);
H : constant Node_Id := Type_High_Bound (Typ);
LE : constant Node_Id := Type_Low_Bound (B);
HE : constant Node_Id := Type_High_Bound (B);
begin
if Nkind (L) = N_Integer_Literal
and then Nkind (H) = N_Integer_Literal
and then Nkind (LE) = N_Integer_Literal
and then Nkind (HE) = N_Integer_Literal
and then UI_Eq (Intval (L), Intval (LE))
and then UI_Eq (Intval (H), Intval (HE))
then
null;
else
Write_Str (" range ");
Sprint_Node (Type_Low_Bound (Typ));
Write_Str (" .. ");
Sprint_Node (Type_High_Bound (Typ));
end if;
end;
-- Modular integer types
when E_Modular_Integer_Type =>
Write_Header;
Write_Str (" mod ");
Write_Uint_With_Col_Check (Modulus (Typ), Auto);
-- Floating point types and subtypes
when E_Floating_Point_Type |
E_Floating_Point_Subtype =>
Write_Header (Ekind (Typ) = E_Floating_Point_Type);
if Ekind (Typ) = E_Floating_Point_Type then
Write_Str ("new ");
end if;
Write_Id (Etype (Typ));
if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
Write_Str (" digits ");
Write_Uint_With_Col_Check
(Digits_Value (Typ), Decimal);
end if;
-- Print bounds if not different from base type
declare
L : constant Node_Id := Type_Low_Bound (Typ);
H : constant Node_Id := Type_High_Bound (Typ);
LE : constant Node_Id := Type_Low_Bound (B);
HE : constant Node_Id := Type_High_Bound (B);
begin
if Nkind (L) = N_Real_Literal
and then Nkind (H) = N_Real_Literal
and then Nkind (LE) = N_Real_Literal
and then Nkind (HE) = N_Real_Literal
and then UR_Eq (Realval (L), Realval (LE))
and then UR_Eq (Realval (H), Realval (HE))
then
null;
else
Write_Str (" range ");
Sprint_Node (Type_Low_Bound (Typ));
Write_Str (" .. ");
Sprint_Node (Type_High_Bound (Typ));
end if;
end;
-- Record subtypes
when E_Record_Subtype =>
Write_Header (False);
Write_Str ("record");
Indent_Begin;
declare
C : Entity_Id;
begin
C := First_Entity (Typ);
while Present (C) loop
Write_Indent;
Write_Id (C);
Write_Str (" : ");
Write_Id (Etype (C));
Next_Entity (C);
end loop;
end;
Indent_End;
Write_Indent_Str (" end record");
-- For all other Itypes, print ??? (fill in later)
when others =>
Write_Header (True);
Write_Str ("???");
end case;
end if;
-- Add terminating bracket and restore output buffer
Write_Char (']');
Write_Eol;
Restore_Output_Buffer (S);
end;
Set_Itype_Printed (Typ);
end if;
end Write_Itype;
-------------------------------
-- Write_Name_With_Col_Check --
-------------------------------
@ -3167,7 +3444,6 @@ package body Sprint is
-- name by three dots (e.g. R7b becomes R...b).
if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then
J := 2;
while J < Name_Len loop
exit when Name_Buffer (J) not in 'A' .. 'Z';
@ -3355,6 +3631,16 @@ package body Sprint is
end if;
end Write_Str_With_Col_Check_Sloc;
-------------------------------
-- Write_Uint_With_Col_Check --
-------------------------------
procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is
begin
Col_Check (UI_Decimal_Digits_Hi (U));
UI_Write (U, Format);
end Write_Uint_With_Col_Check;
------------------------------------
-- Write_Uint_With_Col_Check_Sloc --
------------------------------------

1
gcc/ada/sprint.ads
View File

@ -58,6 +58,7 @@ package Sprint is
-- Freeze entity with freeze actions freeze entityname [ actions ]
-- Interpretation interpretation type [, entity]
-- Intrinsic calls function-name!(arg, arg, arg)
-- Itype declaration [(sub)type declaration without ;]
-- Itype reference reference itype
-- Label declaration labelname : label
-- Mod wi Treat_Fixed_As_Integer x #mod y