Commit edd63e9b by Ed Schonberg Committed by Arnaud Charlet

einfo.ads, einfo.adb (Is_Local_Anonymous_Access): New flag on anonymous access types...

2005-06-14  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* einfo.ads, einfo.adb (Is_Local_Anonymous_Access): New flag on
	anonymous access types, to indicate that the accessibility level of
	the type is determined by that of the enclosing declaration.
	(Has_Persistent_BSS): New flag
	(Set_Is_Primitive_Wrapper): Upgrade the barrier to allow the usage
	of this attribute with functions.
	(Is_Primitive_Wrapper): Remove the barrier.
	(Has_Specified_Stream_Input, Has_Specified_Stream_Output,
	Has_Specified_Stream_Read, Has_Specified_Stream_Write):
	New subprograms.
	(Set_Has_Specified_Stream_Input, Set_Has_Specified_Stream_Output,
	Set_Has_Specified_Stream_Read, Set_Has_Specified_Stream_Write):
	New subprograms.
	(Is_Pure_Unit_Access_Type): New flag
	(Abstract_Interfaces): Complete the assertion to cover all usages.
	(Set_Is_Interface): Complete the assertion to cover all usages.
	(Is_Primitive_Wrapper): New attribute.
	(Is_Obsolescent): Now applies to all entities (though it is only set
	for subprograms currently)
	New flag:  Has_Constrained_Partial_View, to implemente Ada 2005 AI-363,
	which solves various problems concerning access subtypes.
	(Has_Persistent_BSS): New flag
	(Is_Primitive_Wrapper, Set_Primitive_Wrapper): Code cleanup.
	Remove these subprograms because this attribute is currently
	not used.
	New entity flags:
	Has_Specified_Stream_Input (Flag190)
	Has_Specified_Stream_Output (Flag191)
	Has_Specified_Stream_Read (Flag192)
	Has_Specified_Stream_Write (Flag193)
	Present in all type and subtype entities. Set for a given view if the
	corresponding stream-oriented attribute has been defined by an
	attribute definition clause. When such a clause occurs, a TSS is set
	on the underlying full view; the flags are used to track visibility of
	the attribute definition clause for partial or incomplete views.
	(Is_Pure_Unit_Access_Type): New flag
	Clarify use of Is_Internal.
	(Is_Primitive_Wrapper): New attribute present in primitive subprograms
	internally generated to wrap the invocation of tasks and protected
	types that implement interfaces.
	(Implementation_Base_Type): Documentation correction
	(Is_Obsolescent): Now applies to all entities (though it is only set
	for subprograms currently)
	New flag:  Has_Constrained_Partial_View, to implement Ada 2005 AI-363,
	which solves various problems concerning access subtypes.

	* exp_ch9.adb (Type_Conformant_Parameters): Introduce mode conformance
	for examined parameters. Identify unequal parameter list lengths as
	non-conformant parameters.
	(Overriding_Possible): Do not check for "All" qualifier in declaration
	of controlling access parameter, following prescription of AI-404.
	(Build_Entry_Wrapper_Spec, Build_Entry_Wrapper_Body): New subprograms
	that build the procedure body that wraps an entry invocation
	(Build_Corresponding_Record, Build_Protected_Sub_Specification,
	Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration,
	Expand_N_Task_Body, Expand_N_Task_Type_Declaration): Modified to
	give support to abstract interface types

	* freeze.adb (Freeze_Entity): Issue error message if
	Is_Pure_Unit_Access_Type set, unless we are in Ada 2005 mode and the
	type has no storage pool (Ada 2005) AI-366.
	Also modified to give support to abstract interface types
	(Freeze_Subprogram): Issue an error for a dispatching subprogram with an
	Inline_Always pragma.

	* par-ch9.adb (P_Task_Items): Reserved words "not" or "overriding" may
	now begin an entry declaration.
	(P_Entry_Or_Subprogram_With_Indicator): New procedure in
	P_Protected_Operation_Declaration_Opt. Parse an entry declaration or
	a subprogram declaration preceded by an overriding indicator.
	(P_Protected_Operation_Declaration_Opt): Add case for parsing entry
	declarations or subprogram declarations preceded by reserved words
	"not" or "overriding".
	(P_Entry_Declaration): Update comment. Parse and check overriding
	indicator, set semantic flags of entry declarations.
	(P_Task): New error message in case of private applied
	to a task type declaration.
	(P_Protected): New error message in case of private applied
	to a task type declaration.

	* sem_ch7.adb (Preserve_Full_Attributes): Modified to handle the case
	in which the full view of a type implementing an interface is a
	concurrent type.
	(Has_Overriding_Pragma): Remove obsolete implementation of AI-218.
	Declare_Inherited_Private_Subprograms): If an explicit operation
	overrides an operation that is inherited in the private part, mark the
	explicit one as overriding, to enable overriding indicator checks.
	(Preserve_Full_Attributes): Propagate Is_Unchecked_Union attribute from
	full view to partial view, to simplify handling in back-end.

	* sprint.adb: Print interface lists where needed: derived types,
	protected types, task types.
	output "is null" for null procedures. Part of implementation of

	* sem_cat.adb (Validate_Access_Type_Declaration): Implement AI-366
	relaxation of rules for access types in pure, shared passive partitions.

	* exp_strm.adb (Build_Mutable_Record_Read_Procedure): Reorganize to
	first read discriminants into temporary objects, performing checks on
	the read values, then possibly performing discriminant checks on the
	actual (if it is constrained), and only finally reading the components
	into a constrained temporary object.
	(Build_Elementary_Input_Call): Adjust the specific circuitry for the
	case of reading discriminants of a mutable record type to recognize
	the new form of the code generated by
	Build_Mutable_Record_Read_Procedure.

	* exp_tss.ads, exp_tss.adb (Make_Init_Proc_Name): Reimplement in terms
	of a simple call to Make_TSS_Name.
	(Make_TSS_Name_Local): Add the TSS name as the last thing in the name
	buffer, in order for Is_TSS to work correctly on local TSS names.

	* sem_attr.ads, sem_attr.adb (Resolve_Attribute, case 'Access): Use flag
	Is_Local_Anonymous_Access to check legaliy of attributes in the
	context of  access components and stand-alone access objects.
	(Stream_Attribute_Available): In Ada 95 mode, a stream attribute is
	treated as available for a limited private type if there is an
	attribute_definition_clause that applies to its full view, but not in
	other cases where the attribute is available for the full view
	(specifically, the sole fact that the full view is non-limited does not
	make the attribute available for the partial view).
	(Build_Access_Subprogram_Type): Diagnose attempt to apply 'access to a
	non-overloaded intrinsic subprogram.
	(Check_Stream_Attribute): Reject an attribute reference for an
	unavailable stream attribute even if the prefix is not a limited type
	(case of a 'Input attribute reference for an abstract, non-classwide
	type)
	(Stream_Attribute_Available): New function to determine whether a stream
	attribute is available at a place.
	(Check_Attribute): Use Stream_Attribute_Available instead of just
	testing for TSS presence on the implementation base type.
	(Analyze_Attribute): Modified to give support to task interfaces.
	(Analyze_Access_Attribute): Add error check for use of an Access (or
	Unrestricted_Access) attribute with a subprogram marked as
	Inline_Always.
	(Analyze_Attribute, case Attribute_Address): Add error check for use of
	an Address attribute with a subprogram marked as Inline_Always.
	Update Eval_Attribute to handle new value of Width from AI-395

	* sem_ch13.adb (Analyze_Stream_TSS_Definition): New subprogram.
	(Analyze_Attribute_Definition_Clause, cases Input, Output, Read, Write):
	Factor common code across the stream-oriented attribute circcuits into
	a new subprogram, Analyze_Stream_TSS_Definition. The new uniform
	processing is functionally identical to the previous duplicated one,
	except that an expression that denotes an abstract subprogram will now
	be rejected, as mandated by AI-195 item 5.

	* sem_util.ads, sem_util.adb (Type_Access_Level): Use flag
	Is_Local_Anonymous_Access to apply accessibility checks to access
	components and stand-alone access objects.
	(Has_Discriminant_Dependent_Constraint): Moved to spec for use
	elsewhere.
	(Is_Potentially_Persistent_Type): New function
	(Is_Dependent_Component_Of_Mutable_Object): If the enclosing object is
	a heap-object whose type has a constrained partial view, the object is
	unconstrained and the component may depend on a discriminant, making its
	renaming illegal.

	* sinfo.ads, sinfo.adb
	(Must_Not_Override): Flag applicable to N_Entry_Declaration.
	(Must_Override): Flag applicable to N_Entry_Declaration.
	Indicate that interface_list can appear in single task and single
	protected declarations.
	Replace Is_Overriding and Not_Overriding with Must_Override and
	Must_Not_Override, to better express intent of AI.
	Is_Overriding, Not_Overriding: Ada2005 flags that indicate the presence
	of an overriding indicator in a subprogram or instance.
	Ada 2005 (AI-248) Null_Present can appear in a procedure specification.
	Add the overriding indicator [[not] overriding] construct to the
	following grammar productions:
	 ENTRY_DECLARATION
	 GENERIC_INSTANTIATION
	 SUBPROGRAM_SPECIFICATION

	* par-ch10.adb (P_Compilation_Unit): Subprogram declaration or body
	can start with an overriding indicator.

	* par-ch6.adb (P_Subprogram): Recognize overriding indicator, and set
	flags accordingly on subrogram specifications or instances.

	* sem_ch8.adb:
	(Analyze_Subprogram_Renaming): For a renaming_as_body, verify that the
	overriding_indicator, if present, is consistent with status of spec.
	Improve error message for null-excluding checks on controlling access
	parameters.
	(Check_In_Previous_With_Clause): Protect the frontend against
	previously reported critical errors in the context clauses.
	Save and restore Ada_Version_Explicit, for implementation of AI-362
	(Analyze_Subprogram_Renaming): If the new entity is a dispatching
	operation verify that controlling formals of the renamed entity that
	are access parameters are explicitly non-null.
	(Find_Expanded_Name): Improve error message when prefix is an illegal
	reference to a private child unit.

	* exp_imgv.adb, s-imgwch.ads, s-imgwch.adb, s-valwch.adb,
	s-valwch.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, s-wwdwch.adb:
	Rewrite to correspond to new wide character names in AI-395

        * par-ch12.adb (P_Formal_Subprogram_Declaration): Recognize null
        default procedures.

From-SVN: r101029
parent d4881d36
......@@ -32,7 +32,6 @@ with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
......@@ -192,12 +191,10 @@ package body Exp_Imgv is
-- For types whose root type is Wide_Character
-- xx = Wide_Character
-- tv = Wide_Character (Expr)
-- pm = Wide_Character_Encoding_Method
-- For types whose root type is Wide_Wide_Character
-- xx = Wide_Wide_haracter
-- tv = Wide_Wide_Character (Expr)
-- pm = Wide_Character_Encoding_Method
-- For floating-point types
-- xx = Floating_Point
......@@ -391,15 +388,6 @@ package body Exp_Imgv is
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Aft));
-- For wide [wide] character, append encoding method
elsif Rtyp = Standard_Wide_Character
or else Rtyp = Standard_Wide_Wide_Character
then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
-- For decimal, append Scale and also set to do literal conversion
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
......@@ -434,6 +422,12 @@ package body Exp_Imgv is
-- For types whose root type is Character
-- xx = Character
-- For types whose root type is Wide_Character
-- xx = Wide_Character
-- For types whose root type is Wide_Wide_Character
-- xx = Wide_Wide_Character
-- For types whose root type is Boolean
-- xx = Boolean
......@@ -452,14 +446,6 @@ package body Exp_Imgv is
-- For floating-point types and ordinary fixed-point types
-- xx = Real
-- For types derived from Wide_Character, typ'Value (X) expands into
-- Value_Wide_Character (X, Wide_Character_Encoding_Method)
-- For types derived from Wide_Wide_Character, typ'Value (X) expands into
-- Value_Wide_Wide_Character (X, Wide_Character_Encoding_Method)
-- For decimal types with size <= Integer'Size, typ'Value (X)
-- expands into
......@@ -504,15 +490,9 @@ package body Exp_Imgv is
elsif Rtyp = Standard_Wide_Character then
Vid := RE_Value_Wide_Character;
Append_To (Args,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Standard_Wide_Wide_Character then
Vid := RE_Value_Wide_Wide_Character;
Append_To (Args,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
or else Rtyp = Base_Type (Standard_Short_Integer)
......@@ -686,42 +666,36 @@ package body Exp_Imgv is
-- Result_Type (Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last),
-- Wide_Character_Encoding_Method);
-- and typ'Wide_Width expands into:
-- Result_Type (Wide_Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last));
-- Wide_Character_Encoding_Method);
-- and typ'Wide_Wide_Width expands into
-- Result_Type (Wide_Wide_Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last));
-- Wide_Character_Encoding_Method);
-- For types derived from Wide_Wide_Character, typ'Width expands into
-- Result_Type (Width_Wide_Wide_Character (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last),
-- Wide_Character_Encoding_Method);
-- and typ'Wide_Width expands into:
-- Result_Type (Wide_Width_Wide_Wide_Character (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
-- Wide_Character_Encoding_Method);
-- and typ'Wide_Wide_Width expands into
-- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
-- Wide_Character_Encoding_Method);
-- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
......@@ -914,14 +888,6 @@ package body Exp_Imgv is
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last))));
-- For enumeration'Wide_[Wide_]Width, add encoding method parameter
if Attr /= Normal then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
end if;
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
......@@ -945,17 +911,6 @@ package body Exp_Imgv is
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last)));
-- For Wide_[Wide_]Character'Width, add encoding method parameter
if (Rtyp = Standard_Wide_Character
or else
Rtyp = Standard_Wide_Wide_Character)
and then Attr /= Normal then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
end if;
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
......
......@@ -592,12 +592,12 @@ package body Exp_Strm is
-- Call the function, and do an unchecked conversion of the result
-- to the actual type of the prefix. If the target is a discriminant,
-- set target type to force a constraint check (13.13.2 (35)).
-- and we are in the body of the default implementation of a 'Read
-- attribute, set target type to force a constraint check (13.13.2(35)).
if Nkind (Targ) = N_Selected_Component
and then Present (Entity (Selector_Name (Targ)))
and then Ekind (Entity (Selector_Name (Targ)))
= E_Discriminant
if Nkind (Targ) = N_Identifier
and then Is_Internal_Name (Chars (Targ))
and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
then
Res :=
Unchecked_Convert_To (Base_Type (P_Type),
......@@ -786,23 +786,41 @@ package body Exp_Strm is
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Stms : List_Id;
Out_Formal : Node_Id;
-- Expression denoting the out formal parameter
Dcls : constant List_Id := New_List;
-- Declarations for the 'Read body
Stms : List_Id := New_List;
-- Statements for the 'Read body
Disc : Entity_Id;
-- Entity of the discriminant being processed
Tmp_For_Disc : Entity_Id;
-- Temporary object used to read the value of Disc
Tmps_For_Discs : constant List_Id := New_List;
-- List of object declarations for temporaries holding the read values
-- for the discriminants.
Cstr : constant List_Id := New_List;
-- List of constraints to be applied on temporary record
Discriminant_Checks : constant List_Id := New_List;
-- List of discriminant checks to be performed if the actual object
-- is constrained.
Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
-- Temporary, must hide formal (assignments to components of the
-- Temporary record must hide formal (assignments to components of the
-- record are always generated with V as the identifier for the record).
Cstr : List_Id;
-- List of constraints to be applied on temporary
Disc : Entity_Id;
Disc_Ref : Node_Id;
Block : Node_Id;
Constrained_Stms : List_Id := New_List;
-- Statements within the block where we have the constrained temporary
begin
Stms := New_List;
Cstr := New_List;
Disc := First_Discriminant (Typ);
-- A mutable type cannot be a tagged type, so we generate a new name
......@@ -812,33 +830,50 @@ package body Exp_Strm is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
Out_Formal :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pnam, Loc),
Selector_Name => Make_Identifier (Loc, Name_V));
-- Generate Reads for the discriminants of the type. The discriminants
-- need to be read before the rest of the components, so that
-- variants are initialized correctly.
-- variants are initialized correctly. The discriminants must be read
-- into temporary variables so an incomplete Read (interrupted by an
-- exception, for example) does not alter the passed object.
while Present (Disc) loop
Disc_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pnam, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_V)),
Selector_Name => New_Occurrence_Of (Disc, Loc));
Tmp_For_Disc := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Disc), "D"));
Set_Assignment_OK (Disc_Ref);
Append_To (Tmps_For_Discs,
Make_Object_Declaration (Loc,
Defining_Identifier => Tmp_For_Disc,
Object_Definition => New_Occurrence_Of (Etype (Disc), Loc)));
Set_No_Initialization (Last (Tmps_For_Discs));
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Disc), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Disc_Ref)));
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
New_Occurrence_Of (Tmp_For_Disc, Loc))));
Append_To (Cstr,
Make_Discriminant_Association (Loc,
Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
Expression => New_Copy_Tree (Disc_Ref)));
Expression => New_Occurrence_Of (Tmp_For_Disc, Loc)));
Append_To (Discriminant_Checks,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Out_Formal),
Selector_Name => New_Occurrence_Of (Disc, Loc))),
Reason => CE_Discriminant_Check_Failed));
Next_Discriminant (Disc);
end loop;
......@@ -854,27 +889,33 @@ package body Exp_Strm is
-- prior to being initialized. To this effect, we wrap the component
-- assignments in a block where V is a constrained temporary.
Block :=
Append_To (Dcls,
Make_Object_Declaration (Loc,
Defining_Identifier => Tmp,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cstr))));
Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
Append_To (Stms,
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tmp,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cstr)))),
Handled_Statement_Sequence =>
Handled_Statement_Sequence (Decl));
Append_To (Stms, Block);
Append_To (Statements (Handled_Statement_Sequence (Block)),
Declarations => Dcls,
Handled_Statement_Sequence => Parent (Constrained_Stms)));
Append_To (Constrained_Stms,
Make_Implicit_If_Statement (Pnam,
Condition =>
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Out_Formal),
Attribute_Name => Name_Constrained),
Then_Statements => Discriminant_Checks));
Append_To (Constrained_Stms,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pnam, Loc),
Selector_Name => Make_Identifier (Loc, Name_V)),
Name => Out_Formal,
Expression => Make_Identifier (Loc, Name_V)));
if Is_Unchecked_Union (Typ) then
......@@ -890,6 +931,7 @@ package body Exp_Strm is
Reason => PE_Unchecked_Union_Restriction));
end if;
Set_Declarations (Decl, Tmps_For_Discs);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
......
......@@ -235,11 +235,7 @@ package body Exp_Tss is
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
begin
Get_Name_String (Chars (Typ));
Name_Len := Name_Len + 2;
Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1);
Name_Buffer (Name_Len) := TSS_Init_Proc (2);
return Name_Find;
return Make_TSS_Name (Typ, TSS_Init_Proc);
end Make_Init_Proc_Name;
-------------------------
......@@ -252,10 +248,10 @@ package body Exp_Tss is
is
begin
Get_Name_String (Chars (Typ));
Add_Char_To_Name_Buffer (Nam (1));
Add_Char_To_Name_Buffer (Nam (2));
Add_Char_To_Name_Buffer ('_');
Add_Nat_To_Name_Buffer (Increment_Serial_Number);
Add_Char_To_Name_Buffer (Nam (1));
Add_Char_To_Name_Buffer (Nam (2));
return Name_Find;
end Make_TSS_Name_Local;
......
......@@ -64,9 +64,13 @@ package Exp_Tss is
-- TSS Naming --
----------------
-- A TSS is identified by its Chars name. The name has the form typXY,
-- where typ is the type name, and XY are two characters that identify
-- the particular TSS routine, using the following codes:
-- A TSS is identified by its Chars name. The name has the form typXY or
-- typ_<serial>XY, where typ is the type name, and XY are two characters
-- that identify the particular TSS routine. A unique serial number is
-- included for the case where several local instances of the same TSS
-- must be generated (see discussion under Make_TSS_Name_Local).
-- The following codes are used to denote TSSs:
-- Note: When making additions to this list, update the list in snames.adb
......@@ -126,10 +130,11 @@ package Exp_Tss is
function Make_TSS_Name_Local
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Name_Id;
-- Similar to the above call, but a string of the form _nnn is appended
-- to the name, where nnn is a unique serial number. This is used when
-- multiple instances of the same TSS routine may be generated in the
-- same scope (see also discussion above of current limitations).
-- Similar to the above call, but a string of the form _nnn is inserted
-- before the TSS code suffix, where nnn is a unique serial number. This
-- is used when multiple instances of the same TSS routine may be
-- generated in the same scope (see also discussion above of current
-- limitations).
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
-- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
......
......@@ -354,8 +354,10 @@ package body Ch10 is
elsif Token = Tok_Separate then
Set_Unit (Comp_Unit_Node, P_Subunit);
elsif Token = Tok_Procedure
or else Token = Tok_Function
elsif Token = Tok_Function
or else Token = Tok_Not
or else Token = Tok_Overriding
or else Token = Tok_Procedure
then
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
......
......@@ -898,11 +898,13 @@ package body Ch12 is
-- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
-- DEFAULT_NAME ::= NAME
-- DEFAULT_NAME ::= NAME | null
-- The caller has checked that the initial tokens are WITH FUNCTION or
-- WITH PROCEDURE, and the initial WITH has been scanned out.
-- A null default is an Ada 2005 feature.
-- Error recovery: cannot raise Error_Resync
function P_Formal_Subprogram_Declaration return Node_Id is
......@@ -940,6 +942,22 @@ package body Ch12 is
Scan; -- past <>
T_Semicolon;
elsif Token = Tok_Null then
if Ada_Version < Ada_05 then
Error_Msg_SP
("null default subprograms are an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
if Nkind (Spec_Node) = N_Procedure_Specification then
Set_Null_Present (Spec_Node);
else
Error_Msg_SP ("only procedures can be null");
end if;
Scan; -- past NULL
T_Semicolon;
else
Set_Default_Name (Def_Node, P_Name);
T_Semicolon;
......
......@@ -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- --
......@@ -39,6 +39,7 @@ package body Ch6 is
function P_Defining_Operator_Symbol return Node_Id;
procedure Check_Junk_Semicolon_Before_Return;
-- Check for common error of junk semicolon before RETURN keyword of
-- function specification. If present, skip over it with appropriate
-- error message, leaving Scan_Ptr pointing to the RETURN after. This
......@@ -58,7 +59,7 @@ package body Ch6 is
if Token = Tok_Return then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("Unexpected semicolon ignored");
Error_Msg_SC ("unexpected semicolon ignored");
Scan; -- rescan past junk semicolon
else
......@@ -109,6 +110,13 @@ package body Ch6 is
-- | function DEFINING_DESIGNATOR is
-- new generic_function_NAME [GENERIC_ACTUAL_PART];
-- NULL_PROCEDURE_DECLARATION ::=
-- SUBPROGRAM_SPECIFICATION is null;
-- Null procedures are an Ada 2005 feature. A null procedure declaration
-- is classified as a basic declarative item, but it is parsed here, with
-- other subprogram constructs.
-- The value in Pf_Flags indicates which of these possible declarations
-- is acceptable to the caller:
......@@ -123,7 +131,8 @@ package body Ch6 is
-- context is issued. The only possible values for Pf_Flags are those
-- defined as constants in the Par package.
-- The caller has checked that the initial token is FUNCTION or PROCEDURE
-- The caller has checked that the initial token is FUNCTION, PROCEDURE,
-- NOT or OVERRIDING.
-- Error recovery: cannot raise Error_Resync
......@@ -143,6 +152,13 @@ package body Ch6 is
Func : Boolean;
Scan_State : Saved_Scan_State;
-- Flags for optional overriding indication. Two flags are needed,
-- to distinguish positive and negative overriding indicators from
-- the absence of any indicator.
Is_Overriding : Boolean := False;
Not_Overriding : Boolean := False;
begin
-- Set up scope stack entry. Note that the Labl field will be set later
......@@ -154,6 +170,41 @@ package body Ch6 is
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
-- Ada2005: scan leading overriding indicator.
if Token = Tok_Not then
Scan; -- past NOT
if Token = Tok_Overriding then
Scan; -- past OVERRIDING
Not_Overriding := True;
else
Error_Msg_SC ("OVERRIDING expected!");
end if;
elsif Token = Tok_Overriding then
Scan; -- past OVERRIDING
Is_Overriding := True;
end if;
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
-- An overriding indicator is allowed for subprogram declarations,
-- bodies, renamings, stubs, and instantiations.
elsif Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub then
Error_Msg_SC ("overriding indicator not allowed here!");
elsif Token /= Tok_Function
and then Token /= Tok_Procedure
then
Error_Msg_SC ("FUNCTION or PROCEDURE expected!");
end if;
end if;
Func := (Token = Tok_Function);
Fproc_Sloc := Token_Ptr;
Scan; -- past FUNCTION or PROCEDURE
......@@ -202,7 +253,7 @@ package body Ch6 is
if Token = Tok_Is then
Save_Scan_State (Scan_State); -- at the IS
T_Is; -- checks for redundant IS's
T_Is; -- checks for redundant IS
if Token = Tok_New then
if not Pf_Flags.Gins then
......@@ -223,6 +274,14 @@ package body Ch6 is
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
TF_Semicolon;
Pop_Scope_Stack; -- Don't need scope stack entry in this case
if Is_Overriding then
Set_Must_Override (Inst_Node);
elsif Not_Overriding then
Set_Must_Not_Override (Inst_Node);
end if;
return Inst_Node;
else
......@@ -291,6 +350,13 @@ package body Ch6 is
Set_Defining_Unit_Name (Specification_Node, Name_Node);
Set_Parameter_Specifications (Specification_Node, Fpart_List);
if Is_Overriding then
Set_Must_Override (Specification_Node);
elsif Not_Overriding then
Set_Must_Not_Override (Specification_Node);
end if;
-- Error check: barriers not allowed on protected functions/procedures
if Token = Tok_When then
......@@ -384,6 +450,25 @@ package body Ch6 is
TF_Semicolon;
return Absdec_Node;
-- Ada 2005 (AI-248): Parse a null procedure declaration
elsif Token = Tok_Null then
if Ada_Version < Ada_05 then
Error_Msg_SP ("null procedures are an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Scan; -- past NULL
if Func then
Error_Msg_SP ("only procedures can be null");
else
Set_Null_Present (Specification_Node);
end if;
TF_Semicolon;
goto Subprogram_Declaration;
-- Check for IS NEW with Formal_Part present and handle nicely
elsif Token = Tok_New then
......
......@@ -185,6 +185,11 @@ package body Ch9 is
end if;
Scan; -- past WITH
if Token = Tok_Private then
Error_Msg_SP
("PRIVATE not allowed in task type declaration");
end if;
end if;
Set_Task_Definition (Task_Node, P_Task_Definition);
......@@ -240,7 +245,7 @@ package body Ch9 is
-- Deal gracefully with multiple PRIVATE parts
while Token = Tok_Private loop
Error_Msg_SC ("Only one private part allowed per task");
Error_Msg_SC ("only one private part allowed per task");
Scan; -- past PRIVATE
Append_List (P_Task_Items, Private_Declarations (Def_Node));
end loop;
......@@ -284,7 +289,13 @@ package body Ch9 is
if Token = Tok_Pragma then
Append (P_Pragma, Items);
elsif Token = Tok_Entry then
-- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
-- may begin an entry declaration.
elsif Token = Tok_Entry
or else Token = Tok_Not
or else Token = Tok_Overriding
then
Append (P_Entry_Declaration, Items);
elsif Token = Tok_For then
......@@ -311,7 +322,7 @@ package body Ch9 is
elsif Token = Tok_Identifier
or else Token in Token_Class_Declk
then
Error_Msg_SC ("Illegal declaration in task definition");
Error_Msg_SC ("illegal declaration in task definition");
Resync_Past_Semicolon;
else
......@@ -454,6 +465,11 @@ package body Ch9 is
end if;
Scan; -- past WITH
if Token = Tok_Private then
Error_Msg_SP
("PRIVATE not allowed in protected type declaration");
end if;
end if;
Set_Protected_Definition (Protected_Node, P_Protected_Definition);
......@@ -561,6 +577,63 @@ package body Ch9 is
L : List_Id;
P : Source_Ptr;
function P_Entry_Or_Subprogram_With_Indicator return Node_Id;
-- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
-- indicator. The caller has checked that the initial token is NOT or
-- OVERRIDING.
------------------------------------------
-- P_Entry_Or_Subprogram_With_Indicator --
------------------------------------------
function P_Entry_Or_Subprogram_With_Indicator return Node_Id is
Decl : Node_Id := Error;
Is_Overriding : Boolean := False;
Not_Overriding : Boolean := False;
begin
if Token = Tok_Not then
Scan; -- past NOT
if Token = Tok_Overriding then
Scan; -- past OVERRIDING
Not_Overriding := True;
else
Error_Msg_SC ("OVERRIDING expected!");
end if;
else
Scan; -- past OVERRIDING
Is_Overriding := True;
end if;
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
elsif Token = Tok_Entry then
Decl := P_Entry_Declaration;
Set_Must_Override (Decl, Is_Overriding);
Set_Must_Not_Override (Decl, Not_Overriding);
elsif Token = Tok_Function or else Token = Tok_Procedure then
Decl := P_Subprogram (Pf_Decl);
Set_Must_Override (Specification (Decl), Is_Overriding);
Set_Must_Not_Override (Specification (Decl), Not_Overriding);
else
Error_Msg_SC ("ENTRY, FUNCTION or PROCEDURE expected!");
end if;
end if;
return Decl;
end P_Entry_Or_Subprogram_With_Indicator;
-- Start of processing for P_Protected_Operation_Declaration_Opt
begin
-- This loop runs more than once only when a junk declaration
-- is skipped.
......@@ -569,6 +642,9 @@ package body Ch9 is
if Token = Tok_Pragma then
return P_Pragma;
elsif Token = Tok_Not or else Token = Tok_Overriding then
return P_Entry_Or_Subprogram_With_Indicator;
elsif Token = Tok_Entry then
return P_Entry_Declaration;
......@@ -669,10 +745,12 @@ package body Ch9 is
------------------------------
-- ENTRY_DECLARATION ::=
-- [OVERRIDING_INDICATOR]
-- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
-- PARAMETER_PROFILE;
-- The caller has checked that the initial token is ENTRY
-- The caller has checked that the initial token is ENTRY, NOT or
-- OVERRIDING.
-- Error recovery: cannot raise Error_Resync
......@@ -680,7 +758,41 @@ package body Ch9 is
Decl_Node : Node_Id;
Scan_State : Saved_Scan_State;
-- Flags for optional overriding indication. Two flags are needed,
-- to distinguish positive and negative overriding indicators from
-- the absence of any indicator.
Is_Overriding : Boolean := False;
Not_Overriding : Boolean := False;
begin
-- Ada 2005 (AI-397): Scan leading overriding indicator.
if Token = Tok_Not then
Scan; -- past NOT
if Token = Tok_Overriding then
Scan; -- part OVERRIDING
Not_Overriding := True;
else
Error_Msg_SC ("OVERRIDING expected!");
end if;
elsif Token = Tok_Overriding then
Scan; -- part OVERRIDING
Is_Overriding := True;
end if;
if (Is_Overriding or else Not_Overriding) then
if Ada_Version < Ada_05 then
Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
elsif Token /= Tok_Entry then
Error_Msg_SC ("ENTRY expected!");
end if;
end if;
Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
Scan; -- past ENTRY
......@@ -724,6 +836,12 @@ package body Ch9 is
end if;
end if;
if Is_Overriding then
Set_Must_Override (Decl_Node);
elsif Not_Overriding then
Set_Must_Not_Override (Decl_Node);
end if;
-- Error recovery check for illegal return
if Token = Tok_Return then
......
......@@ -34,8 +34,6 @@
with Interfaces; use Interfaces;
with System.Img_Char; use System.Img_Char;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
package body System.Img_WChar is
......@@ -44,42 +42,12 @@ package body System.Img_WChar is
--------------------------
function Image_Wide_Character
(V : Wide_Character;
EM : WC_Encoding_Method) return String
(V : Wide_Character) return String
is
Val : constant Unsigned_16 := Wide_Character'Pos (V);
WS : Wide_String (1 .. 3);
begin
-- If in range of standard character, use standard character routine
if Val < 16#80#
or else (Val <= 16#FF#
and then EM not in WC_Upper_Half_Encoding_Method)
then
return Image_Character (Character'Val (Val));
-- if the value is one of the last two characters in the type, use
-- their language-defined names (3.5.2(3)).
elsif Val = 16#FFFE# then
return "FFFE";
elsif Val = 16#FFFF# then
return "FFFF";
-- Otherwise return an appropriate escape sequence (i.e. one matching
-- the convention implemented by Scn.Wide_Char). The easiest thing is
-- to build a wide string for the result, and then use the Wide_Value
-- function to build the resulting String.
else
WS (1) := ''';
WS (2) := V;
WS (3) := ''';
return Wide_String_To_String (WS, EM);
end if;
return
Image_Wide_Wide_Character
(Wide_Wide_Character'Val (Wide_Character'Pos (V)));
end Image_Wide_Character;
-------------------------------
......@@ -87,30 +55,32 @@ package body System.Img_WChar is
-------------------------------
function Image_Wide_Wide_Character
(V : Wide_Wide_Character;
EM : WC_Encoding_Method) return String
(V : Wide_Wide_Character) return String
is
Val : constant Unsigned_32 := Wide_Wide_Character'Pos (V);
WS : Wide_Wide_String (1 .. 3);
Val : Unsigned_32 := Wide_Wide_Character'Pos (V);
begin
-- If in range of standard Wide_Character, then we use the
-- Wide_Character routine
-- If in range of standard Character, use Character routine
if Val <= 16#FFFF# then
return Image_Wide_Character (Wide_Character'Val (Val), EM);
if Val <= 16#FF# then
return Image_Character (Character'Val (Wide_Wide_Character'Pos (V)));
-- Otherwise return an appropriate escape sequence (i.e. one matching
-- the convention implemented by Scn.Wide_Wide_Char). The easiest thing
-- is to build a wide string for the result, and then use the
-- Wide_Wide_Value function to build the resulting String.
-- Otherwise value returned is Hex_hhhhhhhh
else
WS (1) := ''';
WS (2) := V;
WS (3) := ''';
return Wide_Wide_String_To_String (WS, EM);
declare
Result : String (1 .. 12) := "Hex_hhhhhhhh";
Hex : constant array (Unsigned_32 range 0 .. 15) of Character :=
"0123456789ABCDEF";
begin
for J in reverse 5 .. 12 loop
Result (J) := Hex (Val mod 16);
Val := Val / 16;
end loop;
return Result;
end;
end if;
end Image_Wide_Wide_Character;
......
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ W C H A R --
-- --
......@@ -33,27 +33,13 @@
-- Wide_[Wide_]Character'Image
with System.WCh_Con;
package System.Img_WChar is
pragma Pure (Img_WChar);
function Image_Wide_Character
(V : Wide_Character;
EM : System.WCh_Con.WC_Encoding_Method) return String;
-- Computes Wide_Character'Image (V) and returns the computed result,
-- The argument EM is a constant representing the encoding method in use.
-- The encoding method used is guaranteed to be consistent across a
-- given program execution and to correspond to the method used in the
-- source programs.
function Image_Wide_Character (V : Wide_Character) return String;
-- Computes Wide_Character'Image (V) and returns the computed result
function Image_Wide_Wide_Character
(V : Wide_Wide_Character;
EM : System.WCh_Con.WC_Encoding_Method) return String;
-- Computes Wide_Wide_Character'Image (V) and returns the computed result,
-- The argument EM is a constant representing the encoding method in use.
-- The encoding method used is guaranteed to be consistent across a
-- given program execution and to correspond to the method used in the
-- source programs.
function Image_Wide_Wide_Character (V : Wide_Wide_Character) return String;
-- Computes Wide_Wide_Character'Image (V) and returns the computed result
end System.Img_WChar;
......@@ -33,8 +33,6 @@
with Interfaces; use Interfaces;
with System.Val_Util; use System.Val_Util;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_StW; use System.WCh_StW;
package body System.Val_WChar is
......@@ -43,15 +41,14 @@ package body System.Val_WChar is
--------------------------
function Value_Wide_Character
(Str : String;
EM : WC_Encoding_Method) return Wide_Character
(Str : String) return Wide_Character
is
WWC : constant Wide_Wide_Character :=
Value_Wide_Wide_Character (Str, EM);
WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC);
WWC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str);
WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC);
begin
if WWV > 16#FFFF# then
raise Constraint_Error;
raise Constraint_Error
with "out of range character for Value attribute";
else
return Wide_Character'Val (WWV);
end if;
......@@ -62,8 +59,7 @@ package body System.Val_WChar is
-------------------------------
function Value_Wide_Wide_Character
(Str : String;
EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character
(Str : String) return Wide_Wide_Character
is
F : Natural;
L : Natural;
......@@ -81,48 +77,47 @@ package body System.Val_WChar is
if L - F = 2 then
return Wide_Wide_Character'Val (Character'Pos (S (F + 1)));
-- Otherwise must be a wide character in quotes. The easiest
-- thing is to convert the string to a wide wide string and then
-- pick up the single character that it should contain.
-- Otherwise something is very wrong
else
declare
WS : constant Wide_Wide_String :=
String_To_Wide_Wide_String (S (F + 1 .. L - 1), EM);
begin
if WS'Length /= 1 then
raise Constraint_Error;
else
return WS (WS'First);
end if;
end;
raise Constraint_Error with "invalid string for Value attribute";
end if;
-- the last two values of the type have language-defined names:
-- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases
elsif S = "FFFE" then
return Wide_Wide_Character'Val (16#FFFE#);
elsif Str'Length = 12 and then Str (1 .. 4) = "Hex_" then
declare
W : Unsigned_32 := 0;
elsif S = "FFFF" then
return Wide_Wide_Character'Val (16#FFFF#);
begin
for J in 5 .. 12 loop
W := W * 16 + Character'Pos (Str (J));
-- Otherwise must be a control character
if Str (J) in '0' .. '9' then
W := W - Character'Pos ('0');
elsif Str (J) in 'A' .. 'F' then
W := W - Character'Pos ('A') + 10;
elsif Str (J) in 'a' .. 'f' then
W := W - Character'Pos ('a') + 10;
else
raise Constraint_Error
with "illegal hex character for Value attribute";
end if;
end loop;
else
for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop
if S (F .. L) = Character'Image (C) then
return Wide_Wide_Character'Val (Character'Pos (C));
if W > 16#7FFF_FFFF# then
raise Constraint_Error
with "out of range value for Value attribute";
else
return Wide_Wide_Character'Val (W);
end if;
end loop;
end;
for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop
if S (F .. L) = Character'Image (C) then
return Wide_Wide_Character'Val (Character'Pos (C));
end if;
end loop;
-- Otherwise must be one of the special names for Character
raise Constraint_Error;
else
return
Wide_Wide_Character'Val (Character'Pos (Character'Value (Str)));
end if;
end Value_Wide_Wide_Character;
......
......@@ -33,19 +33,15 @@
-- Processing for Wide_[Wide_]Value attribute
with System.WCh_Con;
package System.Val_WChar is
pragma Pure (Val_WChar);
function Value_Wide_Character
(Str : String;
EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character;
-- Computes Wide_Character'Value (Str).
(Str : String) return Wide_Character;
-- Computes Wide_Character'Value (Str)
function Value_Wide_Wide_Character
(Str : String;
EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character;
-- Computes Wide_Character'Value (Str).
(Str : String) return Wide_Wide_Character;
-- Computes Wide_Character'Value (Str)
end System.Val_WChar;
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ W C H A R --
-- --
......@@ -31,8 +31,6 @@
-- --
------------------------------------------------------------------------------
with System.WCh_Con; use System.WCh_Con;
package body System.Wid_WChar is
--------------------------
......@@ -40,8 +38,7 @@ package body System.Wid_WChar is
--------------------------
function Width_Wide_Character
(Lo, Hi : Wide_Character;
EM : WC_Encoding_Method) return Natural
(Lo, Hi : Wide_Character) return Natural
is
W : Natural;
P : Natural;
......@@ -52,36 +49,12 @@ package body System.Wid_WChar is
P := Wide_Character'Pos (C);
-- Here if we find a character in wide character range
-- Width is max value (12) for Hex_hhhhhhhh
if P > 16#FF# then
return 12;
case EM is
when WCEM_Hex =>
return Natural'Max (W, 5);
when WCEM_Upper =>
return Natural'Max (W, 2);
when WCEM_Shift_JIS =>
return Natural'Max (W, 2);
when WCEM_EUC =>
return Natural'Max (W, 2);
when WCEM_UTF8 =>
if Hi > Wide_Character'Val (16#07FF#) then
return Natural'Max (W, 3);
else
return Natural'Max (W, 2);
end if;
when WCEM_Brackets =>
return Natural'Max (W, 8);
end case;
-- If we are in character range then use length of character image
-- If we are in character range then use length of character image
else
declare
......@@ -100,8 +73,7 @@ package body System.Wid_WChar is
-------------------------------
function Width_Wide_Wide_Character
(Lo, Hi : Wide_Wide_Character;
EM : WC_Encoding_Method) return Natural
(Lo, Hi : Wide_Wide_Character) return Natural
is
W : Natural;
P : Natural;
......@@ -111,35 +83,11 @@ package body System.Wid_WChar is
for C in Lo .. Hi loop
P := Wide_Wide_Character'Pos (C);
-- Here if we find a character in wide wide character range
-- Here if we find a character in wide wide character range.
-- Width is max value (12) for Hex_hhhhhhhh
if P > 16#FF# then
case EM is
when WCEM_Hex =>
return Natural'Max (W, 5);
when WCEM_Upper =>
return Natural'Max (W, 2);
when WCEM_Shift_JIS =>
return Natural'Max (W, 2);
when WCEM_EUC =>
return Natural'Max (W, 2);
when WCEM_UTF8 =>
if Hi > Wide_Wide_Character'Val (16#FFFF#) then
return Natural'Max (W, 4);
elsif Hi > Wide_Wide_Character'Val (16#07FF#) then
return Natural'Max (W, 3);
else
return Natural'Max (W, 2);
end if;
when WCEM_Brackets =>
return Natural'Max (W, 10);
end case;
W := 12;
-- If we are in character range then use length of character image
......
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ W C H A R --
-- --
......@@ -33,21 +33,16 @@
-- This package contains the routines used for Wide_[Wide_]Character'Width
with System.WCh_Con;
package System.Wid_WChar is
pragma Pure (Wid_WChar);
function Width_Wide_Character
(Lo, Hi : Wide_Character;
EM : System.WCh_Con.WC_Encoding_Method) return Natural;
(Lo, Hi : Wide_Character) return Natural;
-- Compute Width attribute for non-static type derived from Wide_Character.
-- The arguments are the low and high bounds for the type. EM is the
-- wide-character encoding method.
-- The arguments are the low and high bounds for the type.
function Width_Wide_Wide_Character
(Lo, Hi : Wide_Wide_Character;
EM : System.WCh_Con.WC_Encoding_Method) return Natural;
(Lo, Hi : Wide_Wide_Character) return Natural;
-- Same function for type derived from Wide_Wide_Character
end System.Wid_WChar;
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W W D _ C H A R --
-- --
......@@ -43,11 +43,20 @@ package body System.WWd_Char is
begin
W := 0;
for C in Lo .. Hi loop
declare
S : constant Wide_String := Character'Wide_Image (C);
begin
W := Natural'Max (W, S'Length);
end;
-- For Character range, use length of image
if Character'Pos (C) < 256 then
declare
S : constant Wide_String := Character'Wide_Image (C);
begin
W := Natural'Max (W, S'Length);
end;
-- For wide character, always max out at 12 (Hex_hhhhhhhh)
else
return 12;
end if;
end loop;
return W;
......@@ -63,11 +72,21 @@ package body System.WWd_Char is
begin
W := 0;
for C in Lo .. Hi loop
declare
S : constant Wide_Wide_String := Character'Wide_Wide_Image (C);
begin
W := Natural'Max (W, S'Length);
end;
-- For Character range, use length of image
if Character'Pos (C) < 256 then
declare
S : constant String := Character'Image (C);
begin
W := Natural'Max (W, S'Length);
end;
-- For wide character, always max out at 12 (Hex_hhhhhhhh)
else
return 12;
end if;
end loop;
return W;
......
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W W D _ W C H A R --
-- --
......@@ -59,7 +59,6 @@ package body System.Wwd_WChar is
function Wide_Wide_Width_Wide_Wide_Char
(Lo, Hi : Wide_Wide_Character) return Natural
is
W : Natural := 0;
LV : constant Unsigned_32 := Wide_Wide_Character'Pos (Lo);
HV : constant Unsigned_32 := Wide_Wide_Character'Pos (Hi);
......@@ -68,36 +67,22 @@ package body System.Wwd_WChar is
if LV > HV then
return 0;
end if;
-- Return max value (12) for wide character (Hex_hhhhhhhh)
elsif HV > 255 then
return 12;
-- If any characters in normal character range, then use normal
-- Wide_Wide_Width attribute on this range to find out a starting point.
-- Otherwise start with zero.
if LV <= 255 then
W :=
else
return
System.WWd_Char.Wide_Wide_Width_Character
(Lo => Character'Val (LV),
Hi => Character'Val (Unsigned_32'Min (255, HV)));
else
W := 0;
end if;
-- Increase to at least 4 if FFFE or FFFF present. These correspond
-- to the special language defined names FFFE/FFFF for these values.
if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then
W := Natural'Max (W, 4);
end if;
-- Increase to at least 3 if any wide characters, corresponding to
-- the normal ' character ' sequence. We know that the character fits.
if HV > 255 then
W := Natural'Max (W, 3);
end if;
return W;
end Wide_Wide_Width_Wide_Wide_Char;
-------------------------------
......@@ -107,7 +92,6 @@ package body System.Wwd_WChar is
function Wide_Width_Wide_Character
(Lo, Hi : Wide_Character) return Natural
is
W : Natural := 0;
LV : constant Unsigned_32 := Wide_Character'Pos (Lo);
HV : constant Unsigned_32 := Wide_Character'Pos (Hi);
......@@ -116,62 +100,33 @@ package body System.Wwd_WChar is
if LV > HV then
return 0;
end if;
-- Return max value (12) for wide character (Hex_hhhhhhhh)
elsif HV > 255 then
return 12;
-- If any characters in normal character range, then use normal
-- Wide_Wide_Width attribute on this range to find out a starting point.
-- Otherwise start with zero.
if LV <= 255 then
W :=
else
return
System.WWd_Char.Wide_Width_Character
(Lo => Character'Val (LV),
Hi => Character'Val (Unsigned_32'Min (255, HV)));
else
W := 0;
end if;
-- Increase to at least 4 if FFFE or FFFF present. These correspond
-- to the special language defined names FFFE/FFFF for these values.
if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then
W := Natural'Max (W, 4);
end if;
-- Increase to at least 3 if any wide characters, corresponding to
-- the normal 'character' sequence. We know that the character fits.
if HV > 255 then
W := Natural'Max (W, 3);
end if;
return W;
end Wide_Width_Wide_Character;
------------------------------------
-- Wide_Width_Wide_Wide_Character --
------------------------------------
-- This is a nasty case, because we get into the business of representing
-- out of range wide wide characters as wide strings. Let's let image do
-- the work here. Too bad if this takes lots of time. It's silly anyway!
function Wide_Width_Wide_Wide_Character
(Lo, Hi : Wide_Wide_Character) return Natural
is
W : Natural;
begin
W := 0;
for J in Lo .. Hi loop
declare
S : constant Wide_String := Wide_Wide_Character'Wide_Image (J);
begin
W := Natural'Max (W, S'Length);
end;
end loop;
return W;
return Wide_Wide_Width_Wide_Wide_Char (Lo, Hi);
end Wide_Width_Wide_Wide_Character;
end System.Wwd_WChar;
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- 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- --
......@@ -1114,48 +1114,10 @@ package body Sem_Ch7 is
Found_Explicit : Boolean;
Decl_Privates : Boolean;
function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean;
-- Check whether a pragma Overriding has been provided for a primitive
-- operation that is found to be overriding in the private part.
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an
-- untagged derived type.
---------------------------
-- Has_Overriding_Pragma --
---------------------------
function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Prag : Node_Id;
begin
if No (Decl)
or else Nkind (Decl) /= N_Subprogram_Declaration
or else No (Next (Decl))
then
return False;
else
Prag := Next (Decl);
while Present (Prag)
and then Nkind (Prag) = N_Pragma
loop
if Chars (Prag) = Name_Overriding
or else Chars (Prag) = Name_Optional_Overriding
then
return True;
else
Next (Prag);
end if;
end loop;
end if;
return False;
end Has_Overriding_Pragma;
---------------------
-- Is_Primitive_Of --
---------------------
......@@ -1238,20 +1200,9 @@ package body Sem_Ch7 is
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Found_Explicit := True;
Set_Is_Overriding_Operation (New_Op);
Decl_Privates := True;
-- If explicit_overriding is in effect, check that
-- the overriding operation is properly labelled.
if Explicit_Overriding
and then Comes_From_Source (New_Op)
and then not Has_Overriding_Pragma (New_Op)
then
Error_Msg_NE
("Missing overriding pragma for&",
New_Op, New_Op);
end if;
exit;
end if;
......@@ -1692,9 +1643,13 @@ package body Sem_Ch7 is
Set_RM_Size (Priv, RM_Size (Full));
Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
(Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full));
if Is_Unchecked_Union (Full) then
Set_Is_Unchecked_Union (Base_Type (Priv));
end if;
-- Why is atomic not copied here ???
if Referenced (Full) then
......@@ -1717,8 +1672,34 @@ package body Sem_Ch7 is
and then not Error_Posted (Full)
then
if Priv_Is_Base_Type then
Set_Access_Disp_Table (Priv, Access_Disp_Table
(Base_Type (Full)));
-- Ada 2005 (AI-345): The full view of a type implementing
-- an interface can be a task type.
-- type T is new I with private;
-- private
-- task type T is new I with ...
if Is_Interface (Etype (Priv))
and then Is_Concurrent_Type (Base_Type (Full))
then
-- Protect the frontend against previous errors
if Present (Corresponding_Record_Type
(Base_Type (Full)))
then
Set_Access_Disp_Table
(Priv, Access_Disp_Table
(Corresponding_Record_Type (Base_Type (Full))));
else
pragma Assert (Serious_Errors_Detected > 0);
null;
end if;
else
Set_Access_Disp_Table
(Priv, Access_Disp_Table (Base_Type (Full)));
end if;
end if;
Set_First_Entity (Priv, First_Entity (Full));
......
......@@ -2773,6 +2773,53 @@ package body Sem_Util is
or else K = N_Package_Specification;
end Has_Declarations;
-------------------------------------------
-- Has_Discriminant_Dependent_Constraint --
-------------------------------------------
function Has_Discriminant_Dependent_Constraint
(Comp : Entity_Id) return Boolean
is
Comp_Decl : constant Node_Id := Parent (Comp);
Subt_Indic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp_Decl));
Constr : Node_Id;
Assn : Node_Id;
begin
if Nkind (Subt_Indic) = N_Subtype_Indication then
Constr := Constraint (Subt_Indic);
if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
Assn := First (Constraints (Constr));
while Present (Assn) loop
case Nkind (Assn) is
when N_Subtype_Indication |
N_Range |
N_Identifier
=>
if Depends_On_Discriminant (Assn) then
return True;
end if;
when N_Discriminant_Association =>
if Depends_On_Discriminant (Expression (Assn)) then
return True;
end if;
when others =>
null;
end case;
Next (Assn);
end loop;
end if;
end if;
return False;
end Has_Discriminant_Dependent_Constraint;
--------------------
-- Has_Infinities --
--------------------
......@@ -3403,58 +3450,9 @@ package body Sem_Util is
P_Aliased : Boolean := False;
Comp : Entity_Id;
function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp has a constrained subtype
-- that depends on a discriminant.
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp is declared within a variant part
------------------------------
-- Has_Dependent_Constraint --
------------------------------
function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
Comp_Decl : constant Node_Id := Parent (Comp);
Subt_Indic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp_Decl));
Constr : Node_Id;
Assn : Node_Id;
begin
if Nkind (Subt_Indic) = N_Subtype_Indication then
Constr := Constraint (Subt_Indic);
if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
Assn := First (Constraints (Constr));
while Present (Assn) loop
case Nkind (Assn) is
when N_Subtype_Indication |
N_Range |
N_Identifier
=>
if Depends_On_Discriminant (Assn) then
return True;
end if;
when N_Discriminant_Association =>
if Depends_On_Discriminant (Expression (Assn)) then
return True;
end if;
when others =>
null;
end case;
Next (Assn);
end loop;
end if;
end if;
return False;
end Has_Dependent_Constraint;
--------------------------------
-- Is_Declared_Within_Variant --
--------------------------------
......@@ -3503,8 +3501,21 @@ package body Sem_Util is
end if;
-- A heap object is constrained by its initial value
-- Ada 2005 AI-363:if the designated type is a type with a
-- constrained partial view, the resulting heap object is not
-- constrained, and a renaming of the component is now unsafe.
if Is_Access_Type (Prefix_Type)
or else Nkind (P) = N_Explicit_Dereference
and then
not Has_Constrained_Partial_View
(Designated_Type (Prefix_Type))
then
return False;
elsif Nkind (P) = N_Explicit_Dereference
and then not Has_Constrained_Partial_View (Prefix_Type)
then
return False;
end if;
......@@ -3523,7 +3534,7 @@ package body Sem_Util is
and then In_Package_Body (Current_Scope)))
and then (Is_Declared_Within_Variant (Comp)
or else Has_Dependent_Constraint (Comp))
or else Has_Discriminant_Dependent_Constraint (Comp))
and then not P_Aliased
then
return True;
......@@ -4306,6 +4317,70 @@ package body Sem_Util is
end if;
end Is_Partially_Initialized_Type;
------------------------------------
-- Is_Potentially_Persistent_Type --
------------------------------------
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
Comp : Entity_Id;
Indx : Node_Id;
begin
-- For private type, test corrresponding full type
if Is_Private_Type (T) then
return Is_Potentially_Persistent_Type (Full_View (T));
-- Scalar types are potentially persistent
elsif Is_Scalar_Type (T) then
return True;
-- Record type is potentially persistent if not tagged and the types of
-- all it components are potentially persistent, and no component has
-- an initialization expression.
elsif Is_Record_Type (T)
and then not Is_Tagged_Type (T)
and then not Is_Partially_Initialized_Type (T)
then
Comp := First_Component (T);
while Present (Comp) loop
if not Is_Potentially_Persistent_Type (Etype (Comp)) then
return False;
else
Next_Entity (Comp);
end if;
end loop;
return True;
-- Array type is potentially persistent if its component type is
-- potentially persistent and if all its constraints are static.
elsif Is_Array_Type (T) then
if not Is_Potentially_Persistent_Type (Component_Type (T)) then
return False;
end if;
Indx := First_Index (T);
while Present (Indx) loop
if not Is_OK_Static_Subtype (Etype (Indx)) then
return False;
else
Next_Index (Indx);
end if;
end loop;
return True;
-- All other types are not potentially persistent
else
return False;
end if;
end Is_Potentially_Persistent_Type;
-----------------------------
-- Is_RCI_Pkg_Spec_Or_Body --
-----------------------------
......@@ -6476,10 +6551,10 @@ package body Sem_Util is
-- the level is the same as that of the enclosing component type.
Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
if Ekind (Btyp) = E_Anonymous_Access_Type
and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230)
and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230)
and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230)
then
return Scope_Depth (Standard_Standard);
end if;
......
......@@ -370,6 +370,11 @@ package Sem_Util is
function Has_Declarations (N : Node_Id) return Boolean;
-- Determines if the node can have declarations
function Has_Discriminant_Dependent_Constraint
(Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp has a constrained subtype
-- that depends on a discriminant.
function Has_Infinities (E : Entity_Id) return Boolean;
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
......@@ -534,6 +539,14 @@ package Sem_Util is
-- one field has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
-- Determines if type T is a potentially persistent type. A potentially
-- persistent type is defined (recursively) as a scalar type, a non-tagged
-- record whose components are all of a potentially persistent type, or an
-- array with all static constraints whose component type is potentially
-- persistent. A private type is potentially persistent if the full type
-- is potentially persistent.
function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean;
-- Return True if a compilation unit is the specification or the
-- body of a remote call interface package.
......
......@@ -1415,6 +1415,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Single_Protected_Declaration
or else NT (N).Nkind = N_Single_Task_Declaration
or else NT (N).Nkind = N_Task_Type_Declaration);
return List2 (N);
end Interface_List;
......@@ -1745,6 +1747,30 @@ package body Sinfo is
return Flag8 (N);
end Must_Not_Freeze;
function Must_Not_Override
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Function_Specification
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Procedure_Specification);
return Flag15 (N);
end Must_Not_Override;
function Must_Override
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Function_Specification
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Procedure_Specification);
return Flag14 (N);
end Must_Override;
function Name
(N : Node_Id) return Node_Id is
begin
......@@ -1872,6 +1898,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_List
or else NT (N).Nkind = N_Procedure_Specification
or else NT (N).Nkind = N_Record_Definition);
return Flag13 (N);
end Null_Present;
......@@ -3939,6 +3966,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Single_Protected_Declaration
or else NT (N).Nkind = N_Single_Task_Declaration
or else NT (N).Nkind = N_Task_Type_Declaration);
Set_List2_With_Parent (N, Val);
end Set_Interface_List;
......@@ -4269,6 +4298,30 @@ package body Sinfo is
Set_Flag8 (N, Val);
end Set_Must_Not_Freeze;
procedure Set_Must_Not_Override
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Function_Specification
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Procedure_Specification);
Set_Flag15 (N, Val);
end Set_Must_Not_Override;
procedure Set_Must_Override
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Function_Specification
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Procedure_Specification);
Set_Flag14 (N, Val);
end Set_Must_Override;
procedure Set_Name
(N : Node_Id; Val : Node_Id) is
begin
......@@ -4396,6 +4449,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_List
or else NT (N).Nkind = N_Procedure_Specification
or else NT (N).Nkind = N_Record_Definition);
Set_Flag13 (N, Val);
end Set_Null_Present;
......
......@@ -1958,6 +1958,8 @@ package Sinfo is
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ACCESS_DEFINITION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- | SINGLE_TASK_DECLARATION
-- | SINGLE_PROTECTED_DECLARATION
......@@ -1994,13 +1996,17 @@ package Sinfo is
-- extra temporary (with Is_True_Constant set False), and initialize
-- this temporary as required (the temporary itself is not atomic).
-- Note: there is not node kind for object definition. Instead, the
-- corresponding field holds a subtype indication, an array type
-- definition, or (Ada 2005, AI-406) an access definition.
-- N_Object_Declaration
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
-- Aliased_Present (Flag4) set if ALIASED appears
-- Constant_Present (Flag17) set if CONSTANT appears
-- Null_Exclusion_Present (Flag11)
-- Object_Definition (Node4) subtype indication/array type definition
-- Object_Definition (Node4) subtype indic./array type def./ access def.
-- Expression (Node3) (set to Empty if not present)
-- Handler_List_Entry (Node2-Sem)
-- Corresponding_Generic_Association (Node5-Sem)
......@@ -3893,8 +3899,10 @@ package Sinfo is
-----------------------------------
-- SUBPROGRAM_SPECIFICATION ::=
-- [[not] overriding]
-- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
-- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
-- | [[not] overriding]
-- function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
-- Note: there are no separate nodes for the profiles, instead the
-- information appears directly in the following nodes.
......@@ -3906,6 +3914,8 @@ package Sinfo is
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Subtype_Mark (Node4) for return type
-- Generic_Parent (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- N_Procedure_Specification
-- Sloc points to PROCEDURE
......@@ -3913,6 +3923,11 @@ package Sinfo is
-- Elaboration_Boolean (Node2-Sem)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Generic_Parent (Node5-Sem)
-- Null_Present (Flag13) set for null procedure case (Ada 2005 feature)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- Note: overriding indicator is an Ada 2005 feature
---------------------
-- 6.1 Designator --
......@@ -4470,11 +4485,13 @@ package Sinfo is
----------------------------------
-- SINGLE_TASK_DECLARATION ::=
-- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
-- task DEFINING_IDENTIFIER
-- [is [new INTERFACE_LIST with] TASK_DEFINITITION];
-- N_Single_Task_Declaration
-- Sloc points to TASK
-- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
--------------------------
......@@ -4553,13 +4570,15 @@ package Sinfo is
---------------------------------------
-- SINGLE_PROTECTED_DECLARATION ::=
-- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
-- protected DEFINING_IDENTIFIER
-- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: single protected declarations are not allowed in Ada 83 mode
-- N_Single_Protected_Declaration
-- Sloc points to PROTECTED
-- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
-------------------------------
......@@ -4631,6 +4650,7 @@ package Sinfo is
------------------------------
-- ENTRY_DECLARATION ::=
-- [[not] overriding]
-- entry DEFINING_IDENTIFIER
-- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE;
......@@ -4640,6 +4660,10 @@ package Sinfo is
-- Discrete_Subtype_Definition (Node4) (set to Empty if not present)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Corresponding_Body (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- Note: overriding indicator is an Ada 2005 feature
-----------------------------
-- 9.5.2 Accept statement --
......@@ -5489,9 +5513,11 @@ package Sinfo is
-- GENERIC_INSTANTIATION ::=
-- package DEFINING_PROGRAM_UNIT_NAME is
-- new generic_package_NAME [GENERIC_ACTUAL_PART];
-- | procedure DEFINING_PROGRAM_UNIT_NAME is
-- | [[not] overriding]
-- procedure DEFINING_PROGRAM_UNIT_NAME is
-- new generic_procedure_NAME [GENERIC_ACTUAL_PART];
-- | function DEFINING_DESIGNATOR is
-- | [[not] overriding]
-- function DEFINING_DESIGNATOR is
-- new generic_function_NAME [GENERIC_ACTUAL_PART];
-- N_Package_Instantiation
......@@ -5512,6 +5538,8 @@ package Sinfo is
-- Generic_Associations (List3) (set to No_List if no
-- generic actual part)
-- Instance_Spec (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
-- N_Function_Instantiation
......@@ -5522,8 +5550,12 @@ package Sinfo is
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
-- Note: overriding indicator is an Ada 2005 feature
------------------------------
-- 12.3 Generic Actual Part --
------------------------------
......@@ -7565,6 +7597,12 @@ package Sinfo is
function Must_Not_Freeze
(N : Node_Id) return Boolean; -- Flag8
function Must_Not_Override
(N : Node_Id) return Boolean; -- Flag15
function Must_Override
(N : Node_Id) return Boolean; -- Flag14
function Name
(N : Node_Id) return Node_Id; -- Node2
......@@ -8366,6 +8404,12 @@ package Sinfo is
procedure Set_Must_Not_Freeze
(N : Node_Id; Val : Boolean := True); -- Flag8
procedure Set_Must_Not_Override
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Must_Override
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Name
(N : Node_Id; Val : Node_Id); -- Node2
......@@ -8828,6 +8872,8 @@ package Sinfo is
pragma Inline (More_Ids);
pragma Inline (Must_Be_Byte_Aligned);
pragma Inline (Must_Not_Freeze);
pragma Inline (Must_Not_Override);
pragma Inline (Must_Override);
pragma Inline (Name);
pragma Inline (Names);
pragma Inline (Next_Entity);
......@@ -9092,6 +9138,8 @@ package Sinfo is
pragma Inline (Set_More_Ids);
pragma Inline (Set_Must_Be_Byte_Aligned);
pragma Inline (Set_Must_Not_Freeze);
pragma Inline (Set_Must_Not_Override);
pragma Inline (Set_Must_Override);
pragma Inline (Set_Name);
pragma Inline (Set_Names);
pragma Inline (Set_Next_Entity);
......
......@@ -165,6 +165,9 @@ package body Sprint is
-- that is currently being written. Note that Debug_Node is always empty
-- if a debug source file is not being written.
procedure Sprint_And_List (List : List_Id);
-- Print the given list with items separated by vertical "and"
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
......@@ -480,16 +483,32 @@ package body Sprint is
end Source_Dump;
---------------------
-- Sprint_And_List --
---------------------
procedure Sprint_And_List (List : List_Id) is
Node : Node_Id;
begin
if Is_Non_Empty_List (List) then
Node := First (List);
loop
Sprint_Node (Node);
Next (Node);
exit when Node = Empty;
Write_Str (" and ");
end loop;
end if;
end Sprint_And_List;
---------------------
-- Sprint_Bar_List --
---------------------
procedure Sprint_Bar_List (List : List_Id) is
Node : Node_Id;
begin
if Is_Non_Empty_List (List) then
Node := First (List);
loop
Sprint_Node (Node);
Next (Node);
......@@ -509,7 +528,6 @@ package body Sprint is
begin
if Is_Non_Empty_List (List) then
Node := First (List);
loop
Sprint_Node (Node);
Next (Node);
......@@ -520,7 +538,6 @@ package body Sprint is
then
Write_Str (", ");
end if;
end loop;
end if;
end Sprint_Comma_List;
......@@ -1146,8 +1163,16 @@ package body Sprint is
Sprint_Node (Subtype_Indication (Node));
if Present (Record_Extension_Part (Node)) then
if Present (Interface_List (Node)) then
Sprint_And_List (Interface_List (Node));
Write_Str_With_Col_Check (" with ");
end if;
if Present (Record_Extension_Part (Node)) then
if No (Interface_List (Node)) then
Write_Str_With_Col_Check (" with ");
end if;
Sprint_Node (Record_Extension_Part (Node));
end if;
......@@ -2149,7 +2174,15 @@ package body Sprint is
Write_Indent_Str_Sloc ("protected type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
Write_Str (" is");
if Present (Interface_List (Node)) then
Write_Str (" is new ");
Sprint_And_List (Interface_List (Node));
Write_Str (" with ");
else
Write_Str (" is");
end if;
Sprint_Node (Protected_Definition (Node));
Write_Id (Defining_Identifier (Node));
Write_Char (';');
......@@ -2400,6 +2433,13 @@ package body Sprint is
when N_Subprogram_Declaration =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
if Nkind (Specification (Node)) = N_Procedure_Specification
and then Null_Present (Specification (Node))
then
Write_Str_With_Col_Check (" is null");
end if;
Write_Char (';');
when N_Subprogram_Info =>
......@@ -2471,8 +2511,18 @@ package body Sprint is
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
if Present (Interface_List (Node)) then
Write_Str (" is new ");
Sprint_And_List (Interface_List (Node));
end if;
if Present (Task_Definition (Node)) then
Write_Str (" is");
if No (Interface_List (Node)) then
Write_Str (" is");
else
Write_Str (" with ");
end if;
Sprint_Node (Task_Definition (Node));
Write_Id (Defining_Identifier (Node));
end if;
......
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