[multiple changes]
2011-08-02 Robert Dewar <dewar@adacore.com> * mlib-prj.adb, restrict.ads, sem_aggr.adb, sem_ch12.adb: Minor reformatting. 2011-08-02 Robert Dewar <dewar@adacore.com> * aspects.adb: New aspects Default_Value and Default_Component_Value New format of Aspect_Names table checks for omitted entries * aspects.ads: Remove mention of Aspect_Cancel and add documentation on handling of boolean aspects for derived types. New aspects Default_Value and Default_Component_Value New format of Aspect_Names table checks for omitted entries * einfo.ads, einfo.adb (Has_Default_Component_Value): New flag (Has_Default_Value): New flag (Has_Default_Component_Value): New flag (Has_Default_Value): New flag * par-ch13.adb (P_Aspect_Specifications): New format of Aspect_Names table. * par-prag.adb: New pragmas Default_Value and Default_Component_Value * sem_ch13.adb (Analyze_Aspect_Specifications): New aspects Default_Value and Default_Component_Value * sem_prag.adb: New pragmas Default_Value and Default_Component_Value New aspects Default_Value and Default_Component_Value * snames.ads-tmpl: New pragmas Default_Value and Default_Component_Value * sprint.adb: Print N_Aspect_Specification node when called from gdb 2011-08-02 Ed Schonberg <schonberg@adacore.com> * sem_res.adb: Add guards in calls to Matching_Static_Array_Bounds. Minor reformatting. 2011-08-02 Robert Dewar <dewar@adacore.com> * i-cstrin.ads: Updates to make Interfaces.C.Strings match RM From-SVN: r177110
This commit is contained in:
parent
e443b7f97e
commit
19fb051ccb
|
@ -1,3 +1,44 @@
|
|||
2011-08-02 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* mlib-prj.adb, restrict.ads, sem_aggr.adb, sem_ch12.adb: Minor
|
||||
reformatting.
|
||||
|
||||
2011-08-02 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* aspects.adb: New aspects Default_Value and Default_Component_Value
|
||||
New format of Aspect_Names table checks for omitted entries
|
||||
* aspects.ads: Remove mention of Aspect_Cancel and add documentation on
|
||||
handling of boolean aspects for derived types.
|
||||
New aspects Default_Value and Default_Component_Value
|
||||
New format of Aspect_Names table checks for omitted entries
|
||||
* einfo.ads, einfo.adb (Has_Default_Component_Value): New flag
|
||||
(Has_Default_Value): New flag
|
||||
(Has_Default_Component_Value): New flag
|
||||
(Has_Default_Value): New flag
|
||||
* par-ch13.adb (P_Aspect_Specifications): New format of Aspect_Names
|
||||
table.
|
||||
* par-prag.adb: New pragmas Default_Value and Default_Component_Value
|
||||
* sem_ch13.adb (Analyze_Aspect_Specifications): New aspects
|
||||
Default_Value and Default_Component_Value
|
||||
* sem_prag.adb: New pragmas Default_Value and Default_Component_Value
|
||||
New aspects Default_Value and Default_Component_Value
|
||||
* snames.ads-tmpl: New pragmas Default_Value and Default_Component_Value
|
||||
* sprint.adb: Print N_Aspect_Specification node when called from gdb
|
||||
|
||||
2011-08-02 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* prj-nmsc.adb (Check_Library_Attributes): For virtual library project,
|
||||
inherit library kind.
|
||||
|
||||
2011-08-02 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_res.adb: Add guards in calls to Matching_Static_Array_Bounds.
|
||||
Minor reformatting.
|
||||
|
||||
2011-08-02 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* i-cstrin.ads: Updates to make Interfaces.C.Strings match RM
|
||||
|
||||
2011-08-02 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* sem_aggr.adb (Resolve_Aggregate): Fix thinko.
|
||||
|
|
|
@ -179,6 +179,8 @@ package body Aspects is
|
|||
Aspect_Atomic_Components => Aspect_Atomic_Components,
|
||||
Aspect_Bit_Order => Aspect_Bit_Order,
|
||||
Aspect_Component_Size => Aspect_Component_Size,
|
||||
Aspect_Default_Component_Value => Aspect_Default_Component_Value,
|
||||
Aspect_Default_Value => Aspect_Default_Value,
|
||||
Aspect_Discard_Names => Aspect_Discard_Names,
|
||||
Aspect_Dynamic_Predicate => Aspect_Predicate,
|
||||
Aspect_External_Tag => Aspect_External_Tag,
|
||||
|
@ -289,7 +291,7 @@ package body Aspects is
|
|||
-- Package initialization sets up Aspect Id hash table
|
||||
|
||||
begin
|
||||
for J in Aspect_Names'Range loop
|
||||
Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp);
|
||||
for J in Aspect_Id loop
|
||||
Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
|
||||
end loop;
|
||||
end Aspects;
|
||||
|
|
|
@ -48,6 +48,8 @@ package Aspects is
|
|||
Aspect_Alignment,
|
||||
Aspect_Bit_Order,
|
||||
Aspect_Component_Size,
|
||||
Aspect_Default_Component_Value,
|
||||
Aspect_Default_Value,
|
||||
Aspect_Dynamic_Predicate,
|
||||
Aspect_External_Tag,
|
||||
Aspect_Input,
|
||||
|
@ -157,111 +159,112 @@ package Aspects is
|
|||
-- The following array indicates what argument type is required
|
||||
|
||||
Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression :=
|
||||
(No_Aspect => Optional,
|
||||
Aspect_Address => Expression,
|
||||
Aspect_Alignment => Expression,
|
||||
Aspect_Bit_Order => Expression,
|
||||
Aspect_Component_Size => Expression,
|
||||
Aspect_Dynamic_Predicate => Expression,
|
||||
Aspect_External_Tag => Expression,
|
||||
Aspect_Input => Name,
|
||||
Aspect_Invariant => Expression,
|
||||
Aspect_Machine_Radix => Expression,
|
||||
Aspect_Object_Size => Expression,
|
||||
Aspect_Output => Name,
|
||||
Aspect_Post => Expression,
|
||||
Aspect_Postcondition => Expression,
|
||||
Aspect_Pre => Expression,
|
||||
Aspect_Precondition => Expression,
|
||||
Aspect_Predicate => Expression,
|
||||
Aspect_Read => Name,
|
||||
Aspect_Size => Expression,
|
||||
Aspect_Static_Predicate => Expression,
|
||||
Aspect_Storage_Pool => Name,
|
||||
Aspect_Storage_Size => Expression,
|
||||
Aspect_Stream_Size => Expression,
|
||||
Aspect_Suppress => Name,
|
||||
Aspect_Type_Invariant => Expression,
|
||||
Aspect_Unsuppress => Name,
|
||||
Aspect_Value_Size => Expression,
|
||||
Aspect_Warnings => Name,
|
||||
Aspect_Write => Name,
|
||||
(No_Aspect => Optional,
|
||||
Aspect_Address => Expression,
|
||||
Aspect_Alignment => Expression,
|
||||
Aspect_Bit_Order => Expression,
|
||||
Aspect_Component_Size => Expression,
|
||||
Aspect_Default_Component_Value => Expression,
|
||||
Aspect_Default_Value => Expression,
|
||||
Aspect_Dynamic_Predicate => Expression,
|
||||
Aspect_External_Tag => Expression,
|
||||
Aspect_Input => Name,
|
||||
Aspect_Invariant => Expression,
|
||||
Aspect_Machine_Radix => Expression,
|
||||
Aspect_Object_Size => Expression,
|
||||
Aspect_Output => Name,
|
||||
Aspect_Post => Expression,
|
||||
Aspect_Postcondition => Expression,
|
||||
Aspect_Pre => Expression,
|
||||
Aspect_Precondition => Expression,
|
||||
Aspect_Predicate => Expression,
|
||||
Aspect_Read => Name,
|
||||
Aspect_Size => Expression,
|
||||
Aspect_Static_Predicate => Expression,
|
||||
Aspect_Storage_Pool => Name,
|
||||
Aspect_Storage_Size => Expression,
|
||||
Aspect_Stream_Size => Expression,
|
||||
Aspect_Suppress => Name,
|
||||
Aspect_Type_Invariant => Expression,
|
||||
Aspect_Unsuppress => Name,
|
||||
Aspect_Value_Size => Expression,
|
||||
Aspect_Warnings => Name,
|
||||
Aspect_Write => Name,
|
||||
|
||||
Library_Unit_Aspects => Optional,
|
||||
Boolean_Aspects => Optional);
|
||||
Library_Unit_Aspects => Optional,
|
||||
Boolean_Aspects => Optional);
|
||||
|
||||
-----------------------------------------
|
||||
-- Table Linking Names and Aspect_Id's --
|
||||
-----------------------------------------
|
||||
|
||||
type Aspect_Entry is record
|
||||
Nam : Name_Id;
|
||||
Asp : Aspect_Id;
|
||||
end record;
|
||||
|
||||
-- Table linking aspect names and id's
|
||||
|
||||
Aspect_Names : constant array (Integer range <>) of Aspect_Entry :=
|
||||
((Name_Ada_2005, Aspect_Ada_2005),
|
||||
(Name_Ada_2012, Aspect_Ada_2012),
|
||||
(Name_Address, Aspect_Address),
|
||||
(Name_Alignment, Aspect_Alignment),
|
||||
(Name_All_Calls_Remote, Aspect_All_Calls_Remote),
|
||||
(Name_Atomic, Aspect_Atomic),
|
||||
(Name_Atomic_Components, Aspect_Atomic_Components),
|
||||
(Name_Bit_Order, Aspect_Bit_Order),
|
||||
(Name_Compiler_Unit, Aspect_Compiler_Unit),
|
||||
(Name_Component_Size, Aspect_Component_Size),
|
||||
(Name_Discard_Names, Aspect_Discard_Names),
|
||||
(Name_Dynamic_Predicate, Aspect_Dynamic_Predicate),
|
||||
(Name_Elaborate_Body, Aspect_Elaborate_Body),
|
||||
(Name_External_Tag, Aspect_External_Tag),
|
||||
(Name_Favor_Top_Level, Aspect_Favor_Top_Level),
|
||||
(Name_Inline, Aspect_Inline),
|
||||
(Name_Inline_Always, Aspect_Inline_Always),
|
||||
(Name_Input, Aspect_Input),
|
||||
(Name_Invariant, Aspect_Invariant),
|
||||
(Name_Machine_Radix, Aspect_Machine_Radix),
|
||||
(Name_Object_Size, Aspect_Object_Size),
|
||||
(Name_Output, Aspect_Output),
|
||||
(Name_Pack, Aspect_Pack),
|
||||
(Name_Persistent_BSS, Aspect_Persistent_BSS),
|
||||
(Name_Post, Aspect_Post),
|
||||
(Name_Postcondition, Aspect_Postcondition),
|
||||
(Name_Pre, Aspect_Pre),
|
||||
(Name_Precondition, Aspect_Precondition),
|
||||
(Name_Predicate, Aspect_Predicate),
|
||||
(Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
|
||||
(Name_Preelaborate, Aspect_Preelaborate),
|
||||
(Name_Preelaborate_05, Aspect_Preelaborate_05),
|
||||
(Name_Pure, Aspect_Pure),
|
||||
(Name_Pure_05, Aspect_Pure_05),
|
||||
(Name_Pure_Function, Aspect_Pure_Function),
|
||||
(Name_Read, Aspect_Read),
|
||||
(Name_Remote_Call_Interface, Aspect_Remote_Call_Interface),
|
||||
(Name_Remote_Types, Aspect_Remote_Types),
|
||||
(Name_Shared, Aspect_Shared),
|
||||
(Name_Shared_Passive, Aspect_Shared_Passive),
|
||||
(Name_Size, Aspect_Size),
|
||||
(Name_Static_Predicate, Aspect_Static_Predicate),
|
||||
(Name_Storage_Pool, Aspect_Storage_Pool),
|
||||
(Name_Storage_Size, Aspect_Storage_Size),
|
||||
(Name_Stream_Size, Aspect_Stream_Size),
|
||||
(Name_Suppress, Aspect_Suppress),
|
||||
(Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info),
|
||||
(Name_Type_Invariant, Aspect_Type_Invariant),
|
||||
(Name_Unchecked_Union, Aspect_Unchecked_Union),
|
||||
(Name_Universal_Aliasing, Aspect_Universal_Aliasing),
|
||||
(Name_Universal_Data, Aspect_Universal_Data),
|
||||
(Name_Unmodified, Aspect_Unmodified),
|
||||
(Name_Unreferenced, Aspect_Unreferenced),
|
||||
(Name_Unreferenced_Objects, Aspect_Unreferenced_Objects),
|
||||
(Name_Unsuppress, Aspect_Unsuppress),
|
||||
(Name_Value_Size, Aspect_Value_Size),
|
||||
(Name_Volatile, Aspect_Volatile),
|
||||
(Name_Volatile_Components, Aspect_Volatile_Components),
|
||||
(Name_Warnings, Aspect_Warnings),
|
||||
(Name_Write, Aspect_Write));
|
||||
Aspect_Names : constant array (Aspect_Id) of Name_Id := (
|
||||
No_Aspect => No_Name,
|
||||
Aspect_Ada_2005 => Name_Ada_2005,
|
||||
Aspect_Ada_2012 => Name_Ada_2012,
|
||||
Aspect_Address => Name_Address,
|
||||
Aspect_Alignment => Name_Alignment,
|
||||
Aspect_All_Calls_Remote => Name_All_Calls_Remote,
|
||||
Aspect_Atomic => Name_Atomic,
|
||||
Aspect_Atomic_Components => Name_Atomic_Components,
|
||||
Aspect_Bit_Order => Name_Bit_Order,
|
||||
Aspect_Compiler_Unit => Name_Compiler_Unit,
|
||||
Aspect_Component_Size => Name_Component_Size,
|
||||
Aspect_Default_Value => Name_Default_Value,
|
||||
Aspect_Default_Component_Value => Name_Default_Component_Value,
|
||||
Aspect_Discard_Names => Name_Discard_Names,
|
||||
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
|
||||
Aspect_Elaborate_Body => Name_Elaborate_Body,
|
||||
Aspect_External_Tag => Name_External_Tag,
|
||||
Aspect_Favor_Top_Level => Name_Favor_Top_Level,
|
||||
Aspect_Inline => Name_Inline,
|
||||
Aspect_Inline_Always => Name_Inline_Always,
|
||||
Aspect_Input => Name_Input,
|
||||
Aspect_Invariant => Name_Invariant,
|
||||
Aspect_Machine_Radix => Name_Machine_Radix,
|
||||
Aspect_No_Return => Name_No_Return,
|
||||
Aspect_Object_Size => Name_Object_Size,
|
||||
Aspect_Output => Name_Output,
|
||||
Aspect_Pack => Name_Pack,
|
||||
Aspect_Persistent_BSS => Name_Persistent_BSS,
|
||||
Aspect_Post => Name_Post,
|
||||
Aspect_Postcondition => Name_Postcondition,
|
||||
Aspect_Pre => Name_Pre,
|
||||
Aspect_Precondition => Name_Precondition,
|
||||
Aspect_Predicate => Name_Predicate,
|
||||
Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization,
|
||||
Aspect_Preelaborate => Name_Preelaborate,
|
||||
Aspect_Preelaborate_05 => Name_Preelaborate_05,
|
||||
Aspect_Pure => Name_Pure,
|
||||
Aspect_Pure_05 => Name_Pure_05,
|
||||
Aspect_Pure_Function => Name_Pure_Function,
|
||||
Aspect_Read => Name_Read,
|
||||
Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,
|
||||
Aspect_Remote_Types => Name_Remote_Types,
|
||||
Aspect_Shared => Name_Shared,
|
||||
Aspect_Shared_Passive => Name_Shared_Passive,
|
||||
Aspect_Size => Name_Size,
|
||||
Aspect_Static_Predicate => Name_Static_Predicate,
|
||||
Aspect_Storage_Pool => Name_Storage_Pool,
|
||||
Aspect_Storage_Size => Name_Storage_Size,
|
||||
Aspect_Stream_Size => Name_Stream_Size,
|
||||
Aspect_Suppress => Name_Suppress,
|
||||
Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info,
|
||||
Aspect_Type_Invariant => Name_Type_Invariant,
|
||||
Aspect_Unchecked_Union => Name_Unchecked_Union,
|
||||
Aspect_Universal_Aliasing => Name_Universal_Aliasing,
|
||||
Aspect_Universal_Data => Name_Universal_Data,
|
||||
Aspect_Unmodified => Name_Unmodified,
|
||||
Aspect_Unreferenced => Name_Unreferenced,
|
||||
Aspect_Unreferenced_Objects => Name_Unreferenced_Objects,
|
||||
Aspect_Unsuppress => Name_Unsuppress,
|
||||
Aspect_Value_Size => Name_Value_Size,
|
||||
Aspect_Volatile => Name_Volatile,
|
||||
Aspect_Volatile_Components => Name_Volatile_Components,
|
||||
Aspect_Warnings => Name_Warnings,
|
||||
Aspect_Write => Name_Write);
|
||||
|
||||
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
|
||||
pragma Inline (Get_Aspect_Id);
|
||||
|
|
|
@ -283,6 +283,7 @@ package body Einfo is
|
|||
-- Referenced_As_LHS Flag36
|
||||
-- Is_Known_Non_Null Flag37
|
||||
-- Can_Never_Be_Null Flag38
|
||||
-- Has_Default_Value Flag39
|
||||
-- Body_Needed_For_SAL Flag40
|
||||
|
||||
-- Treat_As_Volatile Flag41
|
||||
|
@ -406,6 +407,7 @@ package body Einfo is
|
|||
-- Is_Compilation_Unit Flag149
|
||||
-- Has_Pragma_Elaborate_Body Flag150
|
||||
|
||||
-- Has_Default_Component_Value Flag151
|
||||
-- Entry_Accepted Flag152
|
||||
-- Is_Obsolescent Flag153
|
||||
-- Has_Per_Object_Constraint Flag154
|
||||
|
@ -514,8 +516,6 @@ package body Einfo is
|
|||
-- Has_Inheritable_Invariants Flag248
|
||||
-- Has_Predicates Flag250
|
||||
|
||||
-- (unused) Flag39
|
||||
-- (unused) Flag151
|
||||
-- (unused) Flag249
|
||||
-- (unused) Flag251
|
||||
-- (unused) Flag252
|
||||
|
@ -1226,6 +1226,18 @@ package body Einfo is
|
|||
return Flag119 (Id);
|
||||
end Has_Convention_Pragma;
|
||||
|
||||
function Has_Default_Component_Value (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Is_Array_Type (Id));
|
||||
return Flag151 (Base_Type (Id));
|
||||
end Has_Default_Component_Value;
|
||||
|
||||
function Has_Default_Value (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Is_Scalar_Type (Id));
|
||||
return Flag39 (Base_Type (Id));
|
||||
end Has_Default_Value;
|
||||
|
||||
function Has_Delayed_Aspects (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Nkind (Id) in N_Entity);
|
||||
|
@ -3663,6 +3675,18 @@ package body Einfo is
|
|||
Set_Flag119 (Id, V);
|
||||
end Set_Has_Convention_Pragma;
|
||||
|
||||
procedure Set_Has_Default_Component_Value (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
|
||||
Set_Flag151 (Id, V);
|
||||
end Set_Has_Default_Component_Value;
|
||||
|
||||
procedure Set_Has_Default_Value (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
|
||||
Set_Flag39 (Id, V);
|
||||
end Set_Has_Default_Value;
|
||||
|
||||
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Nkind (Id) in N_Entity);
|
||||
|
@ -7326,6 +7350,8 @@ package body Einfo is
|
|||
W ("Has_Controlled_Component", Flag43 (Id));
|
||||
W ("Has_Controlling_Result", Flag98 (Id));
|
||||
W ("Has_Convention_Pragma", Flag119 (Id));
|
||||
W ("Has_Default_Component_Value", Flag151 (Id));
|
||||
W ("Has_Default_Value", Flag39 (Id));
|
||||
W ("Has_Delayed_Aspects", Flag200 (Id));
|
||||
W ("Has_Delayed_Freeze", Flag18 (Id));
|
||||
W ("Has_Discriminants", Flag5 (Id));
|
||||
|
|
|
@ -1428,6 +1428,18 @@ package Einfo is
|
|||
-- node must be generated for the entity at its freezing point. See
|
||||
-- separate section ("Delayed Freezing and Elaboration") for details.
|
||||
|
||||
-- Has_Default_Component_Value (Flag151) [root type only]
|
||||
-- Present in array types. Set on a base type to indicate that the base
|
||||
-- type and all its subtypes have a Default_Component_Value aspect. If
|
||||
-- this flag is True, then there will be a pragma Default_Component_Value
|
||||
-- chained to the Rep_Item list for the base type.
|
||||
|
||||
-- Has_Default_Value (Flag39) [base type only]
|
||||
-- Present in scalar types. Set on a base type to indicate that the base
|
||||
-- type and all its subtypes have a Default_Value aspect. If this flag is
|
||||
-- True, then there will always be a pragma Default_Value chained to the
|
||||
-- Rep_Item list for the base type.
|
||||
|
||||
-- Has_Discriminants (Flag5)
|
||||
-- Present in all types and subtypes. For types that are allowed to have
|
||||
-- discriminants (record types and subtypes, task types and subtypes,
|
||||
|
@ -3099,12 +3111,12 @@ package Einfo is
|
|||
-- interpreted as true. Currently this is set true for derived Boolean
|
||||
-- types which have a convention of C, C++ or Fortran.
|
||||
|
||||
-- No_Pool_Assigned (Flag131) [root type only] Present in access types.
|
||||
-- Set if a storage size clause applies to the variable with a static
|
||||
-- expression value of zero. This flag is used to generate errors if any
|
||||
-- attempt is made to allocate or free an instance of such an access
|
||||
-- type. This is set only in the root type, since derived types must
|
||||
-- have the same pool.
|
||||
-- No_Pool_Assigned (Flag131) [root type only]
|
||||
-- Present in access types. Set if a storage size clause applies to the
|
||||
-- variable with a static expression value of zero. This flag is used to
|
||||
-- generate errors if any attempt is made to allocate or free an instance
|
||||
-- of such an access type. This is set only in the root type, since
|
||||
-- derived types must have the same pool.
|
||||
|
||||
-- No_Return (Flag113)
|
||||
-- Present in all entities. Always false except in the case of procedures
|
||||
|
@ -4902,6 +4914,7 @@ package Einfo is
|
|||
-- Packed_Array_Type (Node23)
|
||||
-- Component_Alignment (special) (base type only)
|
||||
-- Has_Component_Size_Clause (Flag68) (base type only)
|
||||
-- Has_Default_Component_Value (Flag151) (base type only)
|
||||
-- Is_Aliased (Flag15)
|
||||
-- Is_Constrained (Flag12)
|
||||
-- Next_Index (synth)
|
||||
|
@ -5001,6 +5014,7 @@ package Einfo is
|
|||
-- Scalar_Range (Node20)
|
||||
-- Delta_Value (Ureal18)
|
||||
-- Small_Value (Ureal21)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Has_Machine_Radix_Clause (Flag83)
|
||||
-- Machine_Radix_10 (Flag84)
|
||||
-- Aft_Value (synth)
|
||||
|
@ -5077,6 +5091,7 @@ package Einfo is
|
|||
-- Static_Predicate (List25)
|
||||
-- Has_Biased_Representation (Flag139)
|
||||
-- Has_Contiguous_Rep (Flag181)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Has_Enumeration_Rep_Clause (Flag66)
|
||||
-- Has_Pragma_Ordered (Flag198) (base type only)
|
||||
-- Nonzero_Is_True (Flag162) (base type only)
|
||||
|
@ -5103,6 +5118,8 @@ package Einfo is
|
|||
-- E_Floating_Point_Subtype
|
||||
-- Digits_Value (Uint17)
|
||||
-- Float_Rep (Uint10) (Float_Rep_Kind)
|
||||
-- Scalar_Range (Node20)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Machine_Emax_Value (synth)
|
||||
-- Machine_Emin_Value (synth)
|
||||
-- Machine_Mantissa_Value (synth)
|
||||
|
@ -5114,7 +5131,6 @@ package Einfo is
|
|||
-- Safe_Emax_Value (synth)
|
||||
-- Safe_First_Value (synth)
|
||||
-- Safe_Last_Value (synth)
|
||||
-- Scalar_Range (Node20)
|
||||
-- Type_Low_Bound (synth)
|
||||
-- Type_High_Bound (synth)
|
||||
-- Vax_Float (synth)
|
||||
|
@ -5272,12 +5288,13 @@ package Einfo is
|
|||
|
||||
-- E_Modular_Integer_Type
|
||||
-- E_Modular_Integer_Subtype
|
||||
-- Modulus (Uint17) (base type only)
|
||||
-- Modulus (Uint17) (base type only)
|
||||
-- Original_Array_Type (Node21)
|
||||
-- Scalar_Range (Node20)
|
||||
-- Static_Predicate (List25)
|
||||
-- Non_Binary_Modulus (Flag58) (base type only)
|
||||
-- Non_Binary_Modulus (Flag58) (base type only)
|
||||
-- Has_Biased_Representation (Flag139)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Type_Low_Bound (synth)
|
||||
-- Type_High_Bound (synth)
|
||||
-- (plus type attributes)
|
||||
|
@ -5308,6 +5325,7 @@ package Einfo is
|
|||
-- Delta_Value (Ureal18)
|
||||
-- Scalar_Range (Node20)
|
||||
-- Small_Value (Ureal21)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Has_Small_Clause (Flag67)
|
||||
-- Aft_Value (synth)
|
||||
-- Type_Low_Bound (synth)
|
||||
|
@ -5544,6 +5562,7 @@ package Einfo is
|
|||
-- Scalar_Range (Node20)
|
||||
-- Static_Predicate (List25)
|
||||
-- Has_Biased_Representation (Flag139)
|
||||
-- Has_Default_Value (Flag39) (base type only)
|
||||
-- Type_Low_Bound (synth)
|
||||
-- Type_High_Bound (synth)
|
||||
-- (plus type attributes)
|
||||
|
@ -5993,6 +6012,8 @@ package Einfo is
|
|||
function Has_Controlled_Component (Id : E) return B;
|
||||
function Has_Controlling_Result (Id : E) return B;
|
||||
function Has_Convention_Pragma (Id : E) return B;
|
||||
function Has_Default_Component_Value (Id : E) return B;
|
||||
function Has_Default_Value (Id : E) return B;
|
||||
function Has_Delayed_Aspects (Id : E) return B;
|
||||
function Has_Delayed_Freeze (Id : E) return B;
|
||||
function Has_Discriminants (Id : E) return B;
|
||||
|
@ -6573,6 +6594,8 @@ package Einfo is
|
|||
procedure Set_Has_Controlled_Component (Id : E; V : B := True);
|
||||
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
|
||||
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
|
||||
procedure Set_Has_Default_Component_Value (Id : E; V : B := True);
|
||||
procedure Set_Has_Default_Value (Id : E; V : B := True);
|
||||
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
|
||||
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
|
||||
procedure Set_Has_Discriminants (Id : E; V : B := True);
|
||||
|
@ -7262,6 +7285,8 @@ package Einfo is
|
|||
pragma Inline (Has_Controlled_Component);
|
||||
pragma Inline (Has_Controlling_Result);
|
||||
pragma Inline (Has_Convention_Pragma);
|
||||
pragma Inline (Has_Default_Component_Value);
|
||||
pragma Inline (Has_Default_Value);
|
||||
pragma Inline (Has_Delayed_Aspects);
|
||||
pragma Inline (Has_Delayed_Freeze);
|
||||
pragma Inline (Has_Discriminants);
|
||||
|
@ -7698,6 +7723,8 @@ package Einfo is
|
|||
pragma Inline (Set_Has_Controlled_Component);
|
||||
pragma Inline (Set_Has_Controlling_Result);
|
||||
pragma Inline (Set_Has_Convention_Pragma);
|
||||
pragma Inline (Set_Has_Default_Component_Value);
|
||||
pragma Inline (Set_Has_Default_Value);
|
||||
pragma Inline (Set_Has_Delayed_Aspects);
|
||||
pragma Inline (Set_Has_Delayed_Freeze);
|
||||
pragma Inline (Set_Has_Discriminants);
|
||||
|
|
|
@ -45,8 +45,9 @@ package Interfaces.C.Strings is
|
|||
-- strict aliasing assumptions for this type.
|
||||
|
||||
type chars_ptr is private;
|
||||
pragma Preelaborable_Initialization (chars_ptr);
|
||||
|
||||
type chars_ptr_array is array (size_t range <>) of chars_ptr;
|
||||
type chars_ptr_array is array (size_t range <>) of aliased chars_ptr;
|
||||
|
||||
Null_Ptr : constant chars_ptr;
|
||||
|
||||
|
|
|
@ -73,26 +73,29 @@ package body MLib.Prj is
|
|||
-- Name_Id for "g-trasym.ads"
|
||||
|
||||
Arguments : String_List_Access := No_Argument;
|
||||
-- Used to accumulate arguments for the invocation of gnatbind and of
|
||||
-- the compiler. Also used to collect the interface ALI when copying
|
||||
-- the ALI files to the library directory.
|
||||
-- Used to accumulate arguments for the invocation of gnatbind and of the
|
||||
-- compiler. Also used to collect the interface ALI when copying the ALI
|
||||
-- files to the library directory.
|
||||
|
||||
Argument_Number : Natural := 0;
|
||||
-- Index of the last argument in Arguments
|
||||
|
||||
Initial_Argument_Max : constant := 10;
|
||||
-- Where does the magic constant 10 come from???
|
||||
|
||||
No_Main_String : aliased String := "-n";
|
||||
No_Main : constant String_Access := No_Main_String'Access;
|
||||
No_Main_String : aliased String := "-n";
|
||||
No_Main : constant String_Access := No_Main_String'Access;
|
||||
|
||||
Output_Switch_String : aliased String := "-o";
|
||||
Output_Switch : constant String_Access := Output_Switch_String'Access;
|
||||
Output_Switch_String : aliased String := "-o";
|
||||
Output_Switch : constant String_Access :=
|
||||
Output_Switch_String'Access;
|
||||
|
||||
Compile_Switch_String : aliased String := "-c";
|
||||
Compile_Switch : constant String_Access := Compile_Switch_String'Access;
|
||||
Compile_Switch_String : aliased String := "-c";
|
||||
Compile_Switch : constant String_Access :=
|
||||
Compile_Switch_String'Access;
|
||||
|
||||
No_Warning_String : aliased String := "-gnatws";
|
||||
No_Warning : constant String_Access := No_Warning_String'Access;
|
||||
No_Warning_String : aliased String := "-gnatws";
|
||||
No_Warning : constant String_Access := No_Warning_String'Access;
|
||||
|
||||
Auto_Initialize : constant String := "-a";
|
||||
|
||||
|
@ -296,27 +299,24 @@ package body MLib.Prj is
|
|||
is
|
||||
Maximum_Size : Integer;
|
||||
pragma Import (C, Maximum_Size, "__gnat_link_max");
|
||||
-- Maximum number of bytes to put in an invocation of the
|
||||
-- gnatbind.
|
||||
-- Maximum number of bytes to put in an invocation of gnatbind
|
||||
|
||||
Size : Integer;
|
||||
-- The number of bytes for the invocation of the gnatbind
|
||||
-- The number of bytes for the invocation of gnatbind
|
||||
|
||||
Warning_For_Library : Boolean := False;
|
||||
-- Set to True for the first warning about a unit missing from the
|
||||
-- interface set.
|
||||
-- Set True for first warning for a unit missing from the interface set
|
||||
|
||||
Current_Proj : Project_Id;
|
||||
|
||||
Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed;
|
||||
-- Set to True if library needs to be linked with libgnarl
|
||||
-- Set True if library needs to be linked with libgnarl
|
||||
|
||||
Libdecgnat_Needed : Boolean := False;
|
||||
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
|
||||
-- On OpenVMS, set True if library needs to be linked with libdecgnat
|
||||
|
||||
Gtrasymobj_Needed : Boolean := False;
|
||||
-- On OpenVMS, set to True if library needs to be linked with
|
||||
-- g-trasym.obj.
|
||||
-- On OpenVMS, set rue if library needs to be linked with g-trasym.obj
|
||||
|
||||
Object_Directory_Path : constant String :=
|
||||
Get_Name_String
|
||||
|
@ -354,15 +354,14 @@ package body MLib.Prj is
|
|||
-- Initial size of Rpath, when first allocated
|
||||
|
||||
Path_Option : String_Access := Linker_Library_Path_Option;
|
||||
-- If null, Path Option is not supported.
|
||||
-- Not a constant so that it can be deallocated.
|
||||
-- If null, Path Option is not supported. Not a constant so that it can
|
||||
-- be deallocated.
|
||||
|
||||
First_ALI : File_Name_Type := No_File;
|
||||
-- Store the ALI file name of a source of the library (the first found)
|
||||
|
||||
procedure Add_ALI_For (Source : File_Name_Type);
|
||||
-- Add the name of the ALI file corresponding to Source to the
|
||||
-- Arguments.
|
||||
-- Add name of the ALI file corresponding to Source to the Arguments
|
||||
|
||||
procedure Add_Rpath (Path : String);
|
||||
-- Add a path name to Rpath
|
||||
|
@ -375,8 +374,8 @@ package body MLib.Prj is
|
|||
-- to link with -lgnarl (this is the case when there is a dependency
|
||||
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
|
||||
-- indicates that there is a need to link with -ldecgnat (this is the
|
||||
-- case when there is a dependency on dec.ads), and set
|
||||
-- Gtrasymobj_Needed if there is a dependency on g-trasym.ads.
|
||||
-- case when there is a dependency on dec.ads). Set Gtrasymobj_Needed
|
||||
-- if there is a dependency on g-trasym.ads.
|
||||
|
||||
procedure Process (The_ALI : File_Name_Type);
|
||||
-- Check if the closure of a library unit which is or should be in the
|
||||
|
@ -914,9 +913,9 @@ package body MLib.Prj is
|
|||
In_Tree.Packages.Table
|
||||
(Binder_Package).Decl.Arrays,
|
||||
In_Tree => In_Tree);
|
||||
Switches : Variable_Value := Nil_Variable_Value;
|
||||
|
||||
Switch : String_List_Id := Nil_String;
|
||||
Switches : Variable_Value := Nil_Variable_Value;
|
||||
Switch : String_List_Id := Nil_String;
|
||||
|
||||
begin
|
||||
if Defaults /= No_Array_Element then
|
||||
|
@ -1180,8 +1179,7 @@ package body MLib.Prj is
|
|||
|
||||
-- Invoke <gcc> -c b__<lib>.adb
|
||||
|
||||
-- Allocate Arguments, if it is the first time we see a standalone
|
||||
-- library.
|
||||
-- Allocate Arguments, if first time we see a standalone library
|
||||
|
||||
if Arguments = No_Argument then
|
||||
Arguments := new String_List (1 .. Initial_Argument_Max);
|
||||
|
@ -1247,8 +1245,7 @@ package body MLib.Prj is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- Now that all the arguments are set, compile the binder
|
||||
-- generated file.
|
||||
-- Now all the arguments are set, compile binder generated file
|
||||
|
||||
Display (Gcc);
|
||||
Spawn
|
||||
|
@ -1277,8 +1274,7 @@ package body MLib.Prj is
|
|||
Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver);
|
||||
end if;
|
||||
|
||||
-- If attribute Library_Options was specified, add these additional
|
||||
-- options.
|
||||
-- If attribute Library_Options was specified, add these options
|
||||
|
||||
Library_Options := Value_Of
|
||||
(Name_Library_Options, For_Project.Decl.Attributes, In_Tree);
|
||||
|
@ -1353,7 +1349,7 @@ package body MLib.Prj is
|
|||
loop
|
||||
if Current_Proj.Object_Directory /= No_Path_Information then
|
||||
|
||||
-- The following code gets far too indented, I suggest some
|
||||
-- The following code gets far too indented ... suggest some
|
||||
-- procedural abstraction here. How about making this declare
|
||||
-- block a named procedure???
|
||||
|
||||
|
@ -1557,8 +1553,7 @@ package body MLib.Prj is
|
|||
Opts.Increment_Last;
|
||||
Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
|
||||
|
||||
-- If Path Option is supported, add libgnat directory path name to
|
||||
-- Rpath.
|
||||
-- If Path Option supported, add libgnat directory path name to Rpath
|
||||
|
||||
if Path_Option /= null then
|
||||
declare
|
||||
|
|
|
@ -427,9 +427,9 @@ package body Ch13 is
|
|||
|
||||
-- Check bad spelling
|
||||
|
||||
for J in Aspect_Names'Range loop
|
||||
if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J).Nam) then
|
||||
Error_Msg_Name_1 := Aspect_Names (J).Nam;
|
||||
for J in Aspect_Id loop
|
||||
if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then
|
||||
Error_Msg_Name_1 := Aspect_Names (J);
|
||||
Error_Msg_SC -- CODEFIX
|
||||
("\possible misspelling of%");
|
||||
exit;
|
||||
|
|
|
@ -1142,6 +1142,8 @@ begin
|
|||
Pragma_Controlled |
|
||||
Pragma_Convention |
|
||||
Pragma_Debug_Policy |
|
||||
Pragma_Default_Value |
|
||||
Pragma_Default_Component_Value |
|
||||
Pragma_Detect_Blocking |
|
||||
Pragma_Default_Storage_Pool |
|
||||
Pragma_Dimension |
|
||||
|
|
|
@ -220,10 +220,10 @@ package Restrict is
|
|||
-- message is posted on the node given as argument.
|
||||
|
||||
procedure Check_Formal_Restriction (Msg : String; N : Node_Id);
|
||||
-- Provides a wrappper on Error_Msg_F which prepends the special characters
|
||||
-- "|~~" (error not serious, language prepended) provided the current mode
|
||||
-- is formal verification and the node N comes originally from source.
|
||||
-- Otherwise, does nothing.
|
||||
-- Node N represents a construct not allowed in formal mode. If this is a
|
||||
-- source node, then an error is issued on N (using Err_Msg_F), prepending
|
||||
-- "|~~" (error not serious, language prepended). Call has no effect if
|
||||
-- not in formal mode, or if N does not come originally from source.
|
||||
|
||||
procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id);
|
||||
-- Tests to see if dynamic code generation (dynamically generated
|
||||
|
|
|
@ -805,11 +805,13 @@ package body Sem_Aggr is
|
|||
procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is
|
||||
Comp_Expr : Node_Id;
|
||||
Comp_Assn : Node_Id;
|
||||
|
||||
begin
|
||||
if Level = 0 then
|
||||
if Nkind (Parent (Expr)) /= N_Qualified_Expression then
|
||||
Check_Formal_Restriction ("aggregate should be qualified", Expr);
|
||||
end if;
|
||||
|
||||
else
|
||||
Comp_Expr := First (Expressions (Expr));
|
||||
while Present (Comp_Expr) loop
|
||||
|
|
|
@ -5064,10 +5064,10 @@ package body Sem_Ch12 is
|
|||
-- exchange views to restore the proper visiblity in the instance.
|
||||
|
||||
declare
|
||||
Typ : constant Entity_Id := Base_Type (Etype (E));
|
||||
Typ : constant Entity_Id := Base_Type (Etype (E));
|
||||
-- The type of the actual
|
||||
|
||||
Gen_Id : Entity_Id;
|
||||
Gen_Id : Entity_Id;
|
||||
-- The generic unit
|
||||
|
||||
Parent_Scope : Entity_Id;
|
||||
|
|
|
@ -982,7 +982,31 @@ package body Sem_Ch13 is
|
|||
|
||||
-- Aspects corresponding to pragmas with two arguments, where
|
||||
-- the first argument is a local name referring to the entity,
|
||||
-- and the second argument is the aspect definition expression.
|
||||
-- and the second argument is the aspect definition expression
|
||||
-- which is an expression which must be delayed and analyzed.
|
||||
|
||||
when Aspect_Default_Component_Value |
|
||||
Aspect_Default_Value =>
|
||||
|
||||
-- Construct the pragma
|
||||
|
||||
Aitem :=
|
||||
Make_Pragma (Loc,
|
||||
Pragma_Argument_Associations => New_List (
|
||||
New_Occurrence_Of (E, Eloc),
|
||||
Relocate_Node (Expr)),
|
||||
Pragma_Identifier =>
|
||||
Make_Identifier (Sloc (Id), Chars (Id)));
|
||||
|
||||
-- These aspects do require delaying
|
||||
|
||||
Delay_Required := True;
|
||||
Set_Is_Delayed_Aspect (Aspect);
|
||||
|
||||
-- Aspects corresponding to pragmas with two arguments, where
|
||||
-- the first argument is a local name referring to the entity,
|
||||
-- and the second argument is the aspect definition expression
|
||||
-- which is an expression that does not get analyzed.
|
||||
|
||||
when Aspect_Suppress |
|
||||
Aspect_Unsuppress =>
|
||||
|
@ -5209,20 +5233,25 @@ package body Sem_Ch13 is
|
|||
when Library_Unit_Aspects =>
|
||||
raise Program_Error;
|
||||
|
||||
-- Aspects taking an optional boolean argument. Note that we will
|
||||
-- never be called with an empty expression, because such aspects
|
||||
-- never need to be delayed anyway.
|
||||
-- Aspects taking an optional boolean argument. Should be impossible
|
||||
-- since these are never delayed.
|
||||
|
||||
when Boolean_Aspects =>
|
||||
pragma Assert (Present (Expression (ASN)));
|
||||
T := Standard_Boolean;
|
||||
raise Program_Error;
|
||||
|
||||
-- Default_Value and Default_Component_Value are resolved with
|
||||
-- the entity, which is the type in question.
|
||||
|
||||
when Aspect_Default_Component_Value |
|
||||
Aspect_Default_Value =>
|
||||
T := Entity (ASN);
|
||||
|
||||
-- Aspects corresponding to attribute definition clauses
|
||||
|
||||
when Aspect_Address =>
|
||||
when Aspect_Address =>
|
||||
T := RTE (RE_Address);
|
||||
|
||||
when Aspect_Bit_Order =>
|
||||
when Aspect_Bit_Order =>
|
||||
T := RTE (RE_Bit_Order);
|
||||
|
||||
when Aspect_External_Tag =>
|
||||
|
|
|
@ -7266,6 +7266,139 @@ package body Sem_Prag is
|
|||
Debug_Pragmas_Enabled :=
|
||||
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
|
||||
|
||||
-----------------------------
|
||||
-- Default_Component_Value --
|
||||
-----------------------------
|
||||
|
||||
when Pragma_Default_Component_Value => declare
|
||||
Arg : Node_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
GNAT_Pragma;
|
||||
Check_Arg_Count (2);
|
||||
Check_Arg_Is_Local_Name (Arg1);
|
||||
|
||||
Arg := Get_Pragma_Arg (Arg1);
|
||||
Analyze (Arg);
|
||||
|
||||
if Etype (Arg) = Any_Type then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if not Is_Entity_Name (Arg)
|
||||
or else not Is_Array_Type (Entity (Arg))
|
||||
then
|
||||
Error_Pragma_Arg ("pragma% requires an array type", Arg1);
|
||||
end if;
|
||||
|
||||
Check_First_Subtype (Arg1);
|
||||
|
||||
E := Entity (Arg);
|
||||
Check_Duplicate_Pragma (E);
|
||||
|
||||
-- Check for rep item too early or too late, but skip this if
|
||||
-- the pragma comes from the corresponding aspect, since we do
|
||||
-- not need the checks, and more importantly, the pragma is on
|
||||
-- the rep item chain alreay, and must not be put there twice!
|
||||
|
||||
if not From_Aspect_Specification (N) then
|
||||
if Rep_Item_Too_Early (E, N)
|
||||
or else
|
||||
Rep_Item_Too_Late (E, N)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Analyze the default value
|
||||
|
||||
Arg := Get_Pragma_Arg (Arg2);
|
||||
Analyze_And_Resolve (Arg, Component_Type (E));
|
||||
|
||||
if not Is_OK_Static_Expression (Arg) then
|
||||
Flag_Non_Static_Expr
|
||||
("non-static expression not allowed for " &
|
||||
"Default_Component_Value",
|
||||
Arg2);
|
||||
raise Pragma_Exit;
|
||||
end if;
|
||||
|
||||
-- Set the flag on the root type and then check for Rep_Item too
|
||||
-- early or too late, the latter call chains the pragma onto the
|
||||
-- Rep_Item chain.
|
||||
|
||||
Set_Has_Default_Component_Value (Base_Type (E));
|
||||
end;
|
||||
|
||||
-------------------
|
||||
-- Default_Value --
|
||||
-------------------
|
||||
|
||||
when Pragma_Default_Value => declare
|
||||
Arg : Node_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Error checks
|
||||
|
||||
GNAT_Pragma;
|
||||
Check_Arg_Count (2);
|
||||
Check_Arg_Is_Local_Name (Arg1);
|
||||
|
||||
Arg := Get_Pragma_Arg (Arg1);
|
||||
Analyze (Arg);
|
||||
|
||||
if Etype (Arg) = Any_Type then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if not Is_Entity_Name (Arg)
|
||||
or else not Is_Scalar_Type (Entity (Arg))
|
||||
then
|
||||
Error_Pragma_Arg ("pragma% requires a scalar type", Arg1);
|
||||
end if;
|
||||
|
||||
Check_First_Subtype (Arg1);
|
||||
|
||||
E := Entity (Arg);
|
||||
Check_Duplicate_Pragma (E);
|
||||
|
||||
-- Check for rep item too early or too late, but skip this if
|
||||
-- the pragma comes from the corresponding aspect, since we do
|
||||
-- not need the checks, and more importantly, the pragma is on
|
||||
-- the rep item chain alreay, and must not be put there twice!
|
||||
|
||||
if not From_Aspect_Specification (N) then
|
||||
if Rep_Item_Too_Early (E, N)
|
||||
or else
|
||||
Rep_Item_Too_Late (E, N)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Analyze the default value. Note that we must do that after
|
||||
-- checking for Rep_Item_Too_Late since this resolution will
|
||||
-- freeze the type involved.
|
||||
|
||||
Arg := Get_Pragma_Arg (Arg2);
|
||||
Analyze_And_Resolve (Arg, E);
|
||||
|
||||
if not Is_OK_Static_Expression (Arg) then
|
||||
Flag_Non_Static_Expr
|
||||
("non-static expression not allowed for Default_Value",
|
||||
Arg2);
|
||||
raise Pragma_Exit;
|
||||
end if;
|
||||
|
||||
-- Set the flag on the root type and then check for Rep_Item too
|
||||
-- early or too late, the latter call chains the pragma onto the
|
||||
-- Rep_Item chain.
|
||||
|
||||
Set_Has_Default_Value (Base_Type (E));
|
||||
end;
|
||||
|
||||
---------------------
|
||||
-- Detect_Blocking --
|
||||
---------------------
|
||||
|
@ -13910,6 +14043,8 @@ package body Sem_Prag is
|
|||
Pragma_Convention_Identifier => 0,
|
||||
Pragma_Debug => -1,
|
||||
Pragma_Debug_Policy => 0,
|
||||
Pragma_Default_Value => -1,
|
||||
Pragma_Default_Component_Value => -1,
|
||||
Pragma_Detect_Blocking => -1,
|
||||
Pragma_Default_Storage_Pool => -1,
|
||||
Pragma_Dimension => -1,
|
||||
|
|
|
@ -644,8 +644,8 @@ package body Sem_Res is
|
|||
N_Derived_Type_Definition)
|
||||
and then D = Constraint (P))
|
||||
|
||||
-- The constraint itself may be given by a subtype indication,
|
||||
-- rather than by a more common discrete range.
|
||||
-- The constraint itself may be given by a subtype indication,
|
||||
-- rather than by a more common discrete range.
|
||||
|
||||
or else (Nkind (P) = N_Subtype_Indication
|
||||
and then
|
||||
|
@ -869,7 +869,7 @@ package body Sem_Res is
|
|||
exit when Nkind (Nod) /= N_Raise_Statement
|
||||
and then
|
||||
(Nkind (Nod) not in N_Raise_xxx_Error
|
||||
or else Present (Condition (Nod)));
|
||||
or else Present (Condition (Nod)));
|
||||
end;
|
||||
end if;
|
||||
|
||||
|
@ -1018,9 +1018,9 @@ package body Sem_Res is
|
|||
-- functions, this is never a parameterless call (RM 4.1.4(6)).
|
||||
|
||||
if Nkind (Parent (N)) = N_Attribute_Reference
|
||||
and then (Attribute_Name (Parent (N)) = Name_Address
|
||||
or else Attribute_Name (Parent (N)) = Name_Code_Address
|
||||
or else Attribute_Name (Parent (N)) = Name_Access)
|
||||
and then (Attribute_Name (Parent (N)) = Name_Address or else
|
||||
Attribute_Name (Parent (N)) = Name_Code_Address or else
|
||||
Attribute_Name (Parent (N)) = Name_Access)
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
@ -1900,9 +1900,9 @@ package body Sem_Res is
|
|||
-- a non-remote access-to-subprogram type.
|
||||
|
||||
if Nkind (N) = N_Attribute_Reference
|
||||
and then (Attribute_Name (N) = Name_Access
|
||||
or else Attribute_Name (N) = Name_Unrestricted_Access
|
||||
or else Attribute_Name (N) = Name_Unchecked_Access)
|
||||
and then (Attribute_Name (N) = Name_Access or else
|
||||
Attribute_Name (N) = Name_Unrestricted_Access or else
|
||||
Attribute_Name (N) = Name_Unchecked_Access)
|
||||
and then Comes_From_Source (N)
|
||||
and then Is_Entity_Name (Prefix (N))
|
||||
and then Is_Subprogram (Entity (Prefix (N)))
|
||||
|
@ -1922,8 +1922,7 @@ package body Sem_Res is
|
|||
|
||||
if Nkind (N) = N_Attribute_Reference
|
||||
and then Comes_From_Source (N)
|
||||
and then (Is_Remote_Call_Interface (Typ)
|
||||
or else Is_Remote_Types (Typ))
|
||||
and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ))
|
||||
then
|
||||
declare
|
||||
Attr : constant Attribute_Id :=
|
||||
|
@ -1970,16 +1969,16 @@ package body Sem_Res is
|
|||
-- perform semantic checks against the corresponding
|
||||
-- remote entities.
|
||||
|
||||
if (Attr = Attribute_Access
|
||||
or else Attr = Attribute_Unchecked_Access
|
||||
or else Attr = Attribute_Unrestricted_Access)
|
||||
if (Attr = Attribute_Access or else
|
||||
Attr = Attribute_Unchecked_Access or else
|
||||
Attr = Attribute_Unrestricted_Access)
|
||||
and then Expander_Active
|
||||
and then Get_PCS_Name /= Name_No_DSA
|
||||
then
|
||||
Check_Subtype_Conformant
|
||||
(New_Id => Entity (Prefix (N)),
|
||||
Old_Id => Designated_Type
|
||||
(Corresponding_Remote_Type (Typ)),
|
||||
(Corresponding_Remote_Type (Typ)),
|
||||
Err_Loc => N);
|
||||
|
||||
if Is_Remote then
|
||||
|
@ -2512,6 +2511,7 @@ package body Sem_Res is
|
|||
-- Protected operation: retrieve operation name
|
||||
|
||||
Subp_Name := Selector_Name (Name (N));
|
||||
|
||||
else
|
||||
raise Program_Error;
|
||||
end if;
|
||||
|
@ -2542,6 +2542,7 @@ package body Sem_Res is
|
|||
else
|
||||
Error_Msg_N ("\use -gnatf for details", N);
|
||||
end if;
|
||||
|
||||
else
|
||||
Wrong_Type (N, Typ);
|
||||
end if;
|
||||
|
@ -2565,11 +2566,11 @@ package body Sem_Res is
|
|||
-- types, rather than a specific type, propagate the actual type
|
||||
-- downward.
|
||||
|
||||
if Typ = Any_Integer
|
||||
or else Typ = Any_Boolean
|
||||
or else Typ = Any_Modular
|
||||
or else Typ = Any_Real
|
||||
or else Typ = Any_Discrete
|
||||
if Typ = Any_Integer or else
|
||||
Typ = Any_Boolean or else
|
||||
Typ = Any_Modular or else
|
||||
Typ = Any_Real or else
|
||||
Typ = Any_Discrete
|
||||
then
|
||||
Ctx_Type := Expr_Type;
|
||||
|
||||
|
@ -2880,13 +2881,10 @@ package body Sem_Res is
|
|||
-- not come from source, or this warning is off.
|
||||
|
||||
if not Warn_On_Parameter_Order
|
||||
or else
|
||||
No (Parameter_Associations (N))
|
||||
or else
|
||||
not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
|
||||
N_Function_Call)
|
||||
or else
|
||||
not Comes_From_Source (N)
|
||||
or else No (Parameter_Associations (N))
|
||||
or else not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
|
||||
N_Function_Call)
|
||||
or else not Comes_From_Source (N)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
@ -3299,6 +3297,7 @@ package body Sem_Res is
|
|||
and then Ekind (F) /= E_In_Parameter
|
||||
then
|
||||
Generate_Reference (Orig_A, A, 'm');
|
||||
|
||||
elsif not Is_Overloaded (A) then
|
||||
Generate_Reference (Orig_A, A);
|
||||
end if;
|
||||
|
@ -3307,8 +3306,7 @@ package body Sem_Res is
|
|||
|
||||
if Present (A)
|
||||
and then (Nkind (Parent (A)) /= N_Parameter_Association
|
||||
or else
|
||||
Chars (Selector_Name (Parent (A))) = Chars (F))
|
||||
or else Chars (Selector_Name (Parent (A))) = Chars (F))
|
||||
then
|
||||
-- If style checking mode on, check match of formal name
|
||||
|
||||
|
@ -3417,8 +3415,7 @@ package body Sem_Res is
|
|||
and then Is_Limited_Record (Etype (F))
|
||||
and then not Is_Constrained (Etype (F))
|
||||
and then Expander_Active
|
||||
and then
|
||||
(Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
|
||||
and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
|
||||
then
|
||||
Establish_Transient_Scope (A, False);
|
||||
|
||||
|
@ -3624,7 +3621,7 @@ package body Sem_Res is
|
|||
|
||||
if Is_Scalar_Type (A_Typ)
|
||||
or else (Ekind (F) = E_In_Parameter
|
||||
and then not Is_Partially_Initialized_Type (A_Typ))
|
||||
and then not Is_Partially_Initialized_Type (A_Typ))
|
||||
then
|
||||
Check_Unset_Reference (A);
|
||||
end if;
|
||||
|
@ -3722,7 +3719,7 @@ package body Sem_Res is
|
|||
and then Has_Discriminants (F_Typ)
|
||||
and then Is_Constrained (F_Typ)
|
||||
and then (not Is_Derived_Type (F_Typ)
|
||||
or else Comes_From_Source (Nam))
|
||||
or else Comes_From_Source (Nam))
|
||||
then
|
||||
Apply_Discriminant_Check (A, F_Typ);
|
||||
|
||||
|
@ -3780,12 +3777,10 @@ package body Sem_Res is
|
|||
else
|
||||
if Is_Scalar_Type (F_Typ) then
|
||||
Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
|
||||
|
||||
elsif Is_Array_Type (F_Typ)
|
||||
and then Ekind (F) = E_Out_Parameter
|
||||
then
|
||||
Apply_Length_Check (A, F_Typ);
|
||||
|
||||
else
|
||||
Apply_Range_Check (A, A_Typ, F_Typ);
|
||||
end if;
|
||||
|
@ -4208,7 +4203,7 @@ package body Sem_Res is
|
|||
-- class-wide matching is not allowed.
|
||||
|
||||
if (Is_Class_Wide_Type (Etype (Expression (E)))
|
||||
or else Is_Class_Wide_Type (Etype (E)))
|
||||
or else Is_Class_Wide_Type (Etype (E)))
|
||||
and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
|
||||
then
|
||||
Wrong_Type (Expression (E), Etype (E));
|
||||
|
@ -4593,7 +4588,6 @@ package body Sem_Res is
|
|||
Get_First_Interp (N, Index, It);
|
||||
while Present (It.Typ) loop
|
||||
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
|
||||
|
||||
if Analyzed (N) then
|
||||
Error_Msg_N ("ambiguous operand in fixed operation", N);
|
||||
else
|
||||
|
@ -4601,7 +4595,6 @@ package body Sem_Res is
|
|||
end if;
|
||||
|
||||
elsif Is_Fixed_Point_Type (It.Typ) then
|
||||
|
||||
if Analyzed (N) then
|
||||
Error_Msg_N ("ambiguous operand in fixed operation", N);
|
||||
else
|
||||
|
@ -5206,12 +5199,13 @@ package body Sem_Res is
|
|||
elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
|
||||
and then
|
||||
((Is_Array_Type (Etype (Nam))
|
||||
and then Covers (Typ, Component_Type (Etype (Nam))))
|
||||
and then Covers (Typ, Component_Type (Etype (Nam))))
|
||||
or else (Is_Access_Type (Etype (Nam))
|
||||
and then Is_Array_Type (Designated_Type (Etype (Nam)))
|
||||
and then
|
||||
Covers (Typ,
|
||||
Component_Type (Designated_Type (Etype (Nam))))))
|
||||
and then Is_Array_Type (Designated_Type (Etype (Nam)))
|
||||
and then
|
||||
Covers
|
||||
(Typ,
|
||||
Component_Type (Designated_Type (Etype (Nam))))))
|
||||
then
|
||||
declare
|
||||
Index_Node : Node_Id;
|
||||
|
@ -5873,7 +5867,7 @@ package body Sem_Res is
|
|||
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
|
||||
Condition : constant Node_Id := First (Expressions (N));
|
||||
Then_Expr : constant Node_Id := Next (Condition);
|
||||
Else_Expr : Node_Id := Next (Then_Expr);
|
||||
Else_Expr : Node_Id := Next (Then_Expr);
|
||||
|
||||
begin
|
||||
Resolve (Condition, Any_Boolean);
|
||||
|
@ -6071,9 +6065,9 @@ package body Sem_Res is
|
|||
elsif Ekind (E) = E_Out_Parameter
|
||||
and then Ada_Version = Ada_83
|
||||
and then (Nkind (Parent (N)) in N_Op
|
||||
or else (Nkind (Parent (N)) = N_Assignment_Statement
|
||||
and then N = Expression (Parent (N)))
|
||||
or else Nkind (Parent (N)) = N_Explicit_Dereference)
|
||||
or else (Nkind (Parent (N)) = N_Assignment_Statement
|
||||
and then N = Expression (Parent (N)))
|
||||
or else Nkind (Parent (N)) = N_Explicit_Dereference)
|
||||
then
|
||||
Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
|
||||
|
||||
|
@ -6188,9 +6182,7 @@ package body Sem_Res is
|
|||
|
||||
begin
|
||||
if not Has_Discriminants (Tsk)
|
||||
or else (not Is_Entity_Name (Lo)
|
||||
and then
|
||||
not Is_Entity_Name (Hi))
|
||||
or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi))
|
||||
then
|
||||
return Entry_Index_Type (E);
|
||||
|
||||
|
@ -6413,8 +6405,10 @@ package body Sem_Res is
|
|||
|
||||
or else (Is_Access_Type (Etype (Nam))
|
||||
and then Is_Array_Type (Designated_Type (Etype (Nam)))
|
||||
and then Covers (Typ,
|
||||
Component_Type (Designated_Type (Etype (Nam))))))
|
||||
and then
|
||||
Covers
|
||||
(Typ,
|
||||
Component_Type (Designated_Type (Etype (Nam))))))
|
||||
then
|
||||
declare
|
||||
Index_Node : Node_Id;
|
||||
|
@ -6423,8 +6417,7 @@ package body Sem_Res is
|
|||
Index_Node :=
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Make_Function_Call (Loc,
|
||||
Name => Relocate_Node (Entry_Name)),
|
||||
Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)),
|
||||
Expressions => Parameter_Associations (N));
|
||||
|
||||
-- Since we are correcting a node classification error made by
|
||||
|
@ -6449,6 +6442,7 @@ package body Sem_Res is
|
|||
declare
|
||||
New_Call : Node_Id;
|
||||
New_Actuals : List_Id;
|
||||
|
||||
begin
|
||||
New_Actuals := New_List (Obj);
|
||||
|
||||
|
@ -6654,9 +6648,9 @@ package body Sem_Res is
|
|||
end if;
|
||||
|
||||
if T /= Any_Type then
|
||||
if T = Any_String
|
||||
or else T = Any_Composite
|
||||
or else T = Any_Character
|
||||
if T = Any_String or else
|
||||
T = Any_Composite or else
|
||||
T = Any_Character
|
||||
then
|
||||
if T = Any_Character then
|
||||
Ambiguous_Character (L);
|
||||
|
@ -6701,6 +6695,7 @@ package body Sem_Res is
|
|||
|
||||
if Is_Array_Type (T)
|
||||
and then Base_Type (T) /= Standard_String
|
||||
and then Base_Type (Etype (L)) = Base_Type (Etype (R))
|
||||
and then not Matching_Static_Array_Bounds (Etype (L), Etype (R))
|
||||
then
|
||||
Check_Formal_Restriction
|
||||
|
@ -6739,7 +6734,7 @@ package body Sem_Res is
|
|||
or else Comes_From_Source (Entity (N))
|
||||
or else Ekind (Entity (N)) = E_Operator
|
||||
or else Is_Intrinsic_Subprogram
|
||||
(Corresponding_Equality (Entity (N)))
|
||||
(Corresponding_Equality (Entity (N)))
|
||||
then
|
||||
Eval_Relational_Op (N);
|
||||
|
||||
|
@ -6913,8 +6908,10 @@ package body Sem_Res is
|
|||
and then Covers (Typ, Component_Type (It.Typ)))
|
||||
or else (Is_Access_Type (It.Typ)
|
||||
and then Is_Array_Type (Designated_Type (It.Typ))
|
||||
and then Covers
|
||||
(Typ, Component_Type (Designated_Type (It.Typ))))
|
||||
and then
|
||||
Covers
|
||||
(Typ,
|
||||
Component_Type (Designated_Type (It.Typ))))
|
||||
then
|
||||
if Found then
|
||||
It := Disambiguate (P, I1, I, Any_Type);
|
||||
|
@ -7212,6 +7209,7 @@ package body Sem_Res is
|
|||
("no modular type available in this context", N);
|
||||
Set_Etype (N, Any_Type);
|
||||
return;
|
||||
|
||||
elsif Is_Modular_Integer_Type (Typ)
|
||||
and then Etype (Left_Opnd (N)) = Universal_Integer
|
||||
and then Etype (Right_Opnd (N)) = Universal_Integer
|
||||
|
@ -7231,9 +7229,14 @@ package body Sem_Res is
|
|||
|
||||
-- In SPARK or ALFA, logical operations AND, OR and XOR for arrays are
|
||||
-- defined only when both operands have same static lower and higher
|
||||
-- bounds.
|
||||
-- bounds. Of course the types have to match, so only check if operands
|
||||
-- are compatible and the node itself has no errors.
|
||||
|
||||
if Is_Array_Type (B_Typ)
|
||||
and then Nkind (N) in N_Binary_Op
|
||||
and then
|
||||
Base_Type (Etype (Left_Opnd (N)))
|
||||
= Base_Type (Etype (Right_Opnd (N)))
|
||||
and then not Matching_Static_Array_Bounds (Etype (Left_Opnd (N)),
|
||||
Etype (Right_Opnd (N)))
|
||||
then
|
||||
|
@ -7301,7 +7304,8 @@ package body Sem_Res is
|
|||
|
||||
elsif not Is_Overloaded (R)
|
||||
and then
|
||||
(Etype (R) = Universal_Integer or else
|
||||
(Etype (R) = Universal_Integer
|
||||
or else
|
||||
Etype (R) = Universal_Real)
|
||||
and then Is_Overloaded (L)
|
||||
then
|
||||
|
@ -7327,7 +7331,6 @@ package body Sem_Res is
|
|||
and then not Is_Interface (Etype (R))
|
||||
then
|
||||
return;
|
||||
|
||||
else
|
||||
T := Intersect_Types (L, R);
|
||||
end if;
|
||||
|
@ -7560,13 +7563,14 @@ package body Sem_Res is
|
|||
else
|
||||
Error_Msg_N
|
||||
("ambiguous operand for concatenation!", Arg);
|
||||
|
||||
Get_First_Interp (Arg, I, It);
|
||||
while Present (It.Nam) loop
|
||||
Error_Msg_Sloc := Sloc (It.Nam);
|
||||
|
||||
if Base_Type (It.Typ) = Base_Type (Typ)
|
||||
or else Base_Type (It.Typ) =
|
||||
Base_Type (Component_Type (Typ))
|
||||
Base_Type (Component_Type (Typ))
|
||||
then
|
||||
Error_Msg_N -- CODEFIX
|
||||
("\\possible interpretation#", Arg);
|
||||
|
@ -9851,8 +9855,7 @@ package body Sem_Res is
|
|||
while Present (T2) loop
|
||||
if Is_Fixed_Point_Type (T2)
|
||||
and then Scope (Base_Type (T2)) = Scop
|
||||
and then (Is_Potentially_Use_Visible (T2)
|
||||
or else In_Use (T2))
|
||||
and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2))
|
||||
then
|
||||
if Present (T1) then
|
||||
Fixed_Point_Error;
|
||||
|
@ -9991,9 +9994,9 @@ package body Sem_Res is
|
|||
-- checks that must be applied to such conversions to prevent
|
||||
-- out-of-scope references.
|
||||
|
||||
elsif
|
||||
Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type,
|
||||
E_Anonymous_Access_Subprogram_Type)
|
||||
elsif Ekind_In
|
||||
(Target_Comp_Base, E_Anonymous_Access_Type,
|
||||
E_Anonymous_Access_Subprogram_Type)
|
||||
and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
|
||||
and then
|
||||
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
|
||||
|
@ -10019,6 +10022,7 @@ package body Sem_Res is
|
|||
"has deeper accessibility level than target", Operand);
|
||||
return False;
|
||||
end if;
|
||||
|
||||
else
|
||||
null;
|
||||
end if;
|
||||
|
|
|
@ -448,6 +448,8 @@ package Snames is
|
|||
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
|
||||
Name_CPU : constant Name_Id := N + $; -- Ada 12
|
||||
Name_Debug : constant Name_Id := N + $; -- GNAT
|
||||
Name_Default_Value : constant Name_Id := N + $; -- GNAT
|
||||
Name_Default_Component_Value : constant Name_Id := N + $; -- GNAT
|
||||
Name_Dimension : constant Name_Id := N + $; -- GNAT
|
||||
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
|
||||
Name_Elaborate_All : constant Name_Id := N + $;
|
||||
|
@ -1554,6 +1556,8 @@ package Snames is
|
|||
Pragma_CPP_Vtable,
|
||||
Pragma_CPU,
|
||||
Pragma_Debug,
|
||||
Pragma_Default_Value,
|
||||
Pragma_Default_Component_Value,
|
||||
Pragma_Dimension,
|
||||
Pragma_Elaborate,
|
||||
Pragma_Elaborate_All,
|
||||
|
|
|
@ -1062,8 +1062,15 @@ package body Sprint is
|
|||
Write_Str_Sloc (" and then ");
|
||||
Sprint_Right_Opnd (Node);
|
||||
|
||||
-- Note: the following code for N_Aspect_Specification is not
|
||||
-- normally used, since we deal with aspects as part of a
|
||||
-- declaration, but it is here in case we deliberately try
|
||||
-- to print an N_Aspect_Speficiation node (e.g. from GDB).
|
||||
|
||||
when N_Aspect_Specification =>
|
||||
raise Program_Error;
|
||||
Sprint_Node (Identifier (Node));
|
||||
Write_Str (" => ");
|
||||
Sprint_Node (Expression (Node));
|
||||
|
||||
when N_Assignment_Statement =>
|
||||
Write_Indent;
|
||||
|
|
Loading…
Reference in New Issue