Skip to content

R
riscv-gcc-1
Commit 653da906 by Robert Dewar Committed by Arnaud Charlet
Options

einfo.adb (Itype_Printed): New flag 

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
parent ea985d95
Showing with 208 additions and 50 deletions
gcc/ada/einfo.adb
......@@ -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));
......
gcc/ada/einfo.ads
......@@ -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);
......
gcc/ada/output.adb
......@@ -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 --
---------------
......
gcc/ada/output.ads
......@@ -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;
gcc/ada/par-ch12.adb
......@@ -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;
......
gcc/ada/sinfo.adb
......@@ -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
......
gcc/ada/sinfo.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/sprint.ads
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment