end Elist15;
function Elist16 (N : Node_Id) return Elist_Id is
+ Value : constant Union_Id := Nodes.Table (N + 2).Field9;
+
begin
pragma Assert (Nkind (N) in N_Entity);
- return Elist_Id (Nodes.Table (N + 2).Field9);
+ if Value = 0 then
+ return No_Elist;
+ else
+ return Elist_Id (Nodes.Table (N + 2).Field9);
+ end if;
end Elist16;
function Elist18 (N : Node_Id) return Elist_Id is
return Elist_Id (Nodes.Table (N + 3).Field10);
end Elist23;
+ function Elist24 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 4).Field6);
+ end Elist24;
+
function Name1 (N : Node_Id) return Name_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
Nodes.Table (N + 3).Field10 := Union_Id (Val);
end Set_Elist23;
+ procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 4).Field6 := Union_Id (Val);
+ end Set_Elist24;
+
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
-- a node contains a number of fields, much as though the nodes were
-- defined as a record type. The fields in a node are as follows:
- -- Nkind Indicates the kind of the node. This field is present
- -- in all nodes. The type is Node_Kind, which is declared
- -- in the package Sinfo.
+ -- Nkind Indicates the kind of the node. This field is present
+ -- in all nodes. The type is Node_Kind, which is declared
+ -- in the package Sinfo.
- -- Sloc Location (Source_Ptr) of the corresponding token
- -- in the Source buffer. The individual node definitions
- -- show which token is referenced by this pointer.
+ -- Sloc Location (Source_Ptr) of the corresponding token
+ -- in the Source buffer. The individual node definitions
+ -- show which token is referenced by this pointer.
- -- In_List A flag used to indicate if the node is a member
+ -- In_List A flag used to indicate if the node is a member
-- of a node list.
- -- Rewrite_Sub A flag set if the node has been rewritten using
- -- the Rewrite procedure. The original value of the
- -- node is retrievable with Original_Node.
+ -- Rewrite_Sub A flag set if the node has been rewritten using
+ -- the Rewrite procedure. The original value of the
+ -- node is retrievable with Original_Node.
- -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
- -- node as a result of a call to Mark_Rewrite_Insertion.
+ -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
+ -- node as a result of a call to Mark_Rewrite_Insertion.
- -- Paren_Count A 2-bit count used on expression nodes to indicate
- -- the level of parentheses. Up to 3 levels can be
- -- accomodated. Anything more than 3 levels is treated
- -- as 3 levels (conformance tests that complain about
- -- this are hereby deemed pathological!) Set to zero
- -- for non-subexpression nodes.
+ -- Paren_Count A 2-bit count used on expression nodes to indicate
+ -- the level of parentheses. Up to 3 levels can be
+ -- accomodated. Anything more than 3 levels is treated
+ -- as 3 levels (conformance tests that complain about
+ -- this are hereby deemed pathological!) Set to zero
+ -- for non-subexpression nodes.
-- Comes_From_Source
- -- This flag is present in all nodes. It is set if the
- -- node is built by the scanner or parser, and clear if
- -- the node is built by the analyzer or expander. It
- -- indicates that the node corresponds to a construct
- -- that appears in the original source program.
-
- -- Analyzed This flag is present in all nodes. It is set when
- -- a node is analyzed, and is used to avoid analyzing
- -- the same node twice. Analysis includes expansion if
- -- expansion is active, so in this case if the flag is
- -- set it means the node has been analyzed and expanded.
-
- -- Error_Posted This flag is present in all nodes. It is set when
- -- an error message is posted which is associated with
- -- the flagged node. This is used to avoid posting more
- -- than one message on the same node.
+ -- This flag is present in all nodes. It is set if the
+ -- node is built by the scanner or parser, and clear if
+ -- the node is built by the analyzer or expander. It
+ -- indicates that the node corresponds to a construct
+ -- that appears in the original source program.
+
+ -- Analyzed This flag is present in all nodes. It is set when
+ -- a node is analyzed, and is used to avoid analyzing
+ -- the same node twice. Analysis includes expansion if
+ -- expansion is active, so in this case if the flag is
+ -- set it means the node has been analyzed and expanded.
+
+ -- Error_Posted This flag is present in all nodes. It is set when
+ -- an error message is posted which is associated with
+ -- the flagged node. This is used to avoid posting more
+ -- than one message on the same node.
-- Field1
-- Field2
-- Field3
-- Field4
- -- Field5 Five fields holding Union_Id values
-
- -- ElistN Synonym for FieldN typed as Elist_Id
- -- ListN Synonym for FieldN typed as List_Id
- -- NameN Synonym for FieldN typed as Name_Id
- -- NodeN Synonym for FieldN typed as Node_Id
- -- StrN Synonym for FieldN typed as String_Id
- -- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
- -- UrealN Synonym for FieldN typed as Ureal
+ -- Field5 Five fields holding Union_Id values
+
+ -- ElistN Synonym for FieldN typed as Elist_Id (Empty = No_Elist)
+ -- ListN Synonym for FieldN typed as List_Id
+ -- NameN Synonym for FieldN typed as Name_Id
+ -- NodeN Synonym for FieldN typed as Node_Id
+ -- StrN Synonym for FieldN typed as String_Id
+ -- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
+ -- UrealN Synonym for FieldN typed as Ureal
+
+ -- Note: in the case of ElistN and UintN fields, it is common that we
+ -- end up with a value of Union_Id'(0) as the default value. This value
+ -- is meaningless as a Uint or Elist_Id value. We have two choices here.
+ -- We could require that all Uint and Elist fields be initialized to an
+ -- appropriate value, but that's error prone, since it would be easy to
+ -- miss an initialization. So instead we have the retrieval functions
+ -- generate an appropriate default value (Uint_0 or No_Elist). Probably
+ -- it would be cleaner to generate No_Uint in the Uint case but we got
+ -- stuck with representing an "unset" size value as zero early on, and
+ -- it will take a bit of fiddling to change that ???
-- Note: the actual usage of FieldN (i.e. whether it contains a Elist_Id,
-- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal), depends on the
-- it is useful to be able to do untyped traversals, and an internal
-- package in Atree allows for direct untyped accesses in such cases.
- -- Flag4 Fifteen Boolean flags (use depends on Nkind and
- -- Flag5 Ekind, as described for FieldN). Again the access
- -- Flag6 is usually via subprograms in Sinfo and Einfo which
- -- Flag7 provide high-level synonyms for these flags, and
- -- Flag8 contain debugging code that checks that the values
- -- Flag9 in Nkind and Ekind are appropriate for the access.
+ -- Flag4 Fifteen Boolean flags (use depends on Nkind and
+ -- Flag5 Ekind, as described for FieldN). Again the access
+ -- Flag6 is usually via subprograms in Sinfo and Einfo which
+ -- Flag7 provide high-level synonyms for these flags, and
+ -- Flag8 contain debugging code that checks that the values
+ -- Flag9 in Nkind and Ekind are appropriate for the access.
-- Flag10
- -- Flag11 Note that Flag1-3 are missing from this list. The
- -- Flag12 first three flag positions are reserved for the
- -- Flag13 standard flags (Comes_From_Source, Error_Posted,
- -- Flag14 and Analyzed)
+ -- Flag11 Note that Flag1-3 are missing from this list. The
+ -- Flag12 first three flag positions are reserved for the
+ -- Flag13 standard flags (Comes_From_Source, Error_Posted,
+ -- Flag14 and Analyzed)
-- Flag15
-- Flag16
-- Flag17
-- Flag18
- -- Link For a node, points to the Parent. For a list, points
- -- to the list header. Note that in the latter case, a
- -- client cannot modify the link field. This field is
- -- private to the Atree package (but is also modified
- -- by the Nlists package).
+ -- Link For a node, points to the Parent. For a list, points
+ -- to the list header. Note that in the latter case, a
+ -- client cannot modify the link field. This field is
+ -- private to the Atree package (but is also modified
+ -- by the Nlists package).
-- The following additional fields are present in extended nodes used
-- for entities (Nkind in N_Entity).
- -- Ekind Entity type. This field indicates the type of the
- -- entity, it is of type Entity_Kind which is defined
- -- in package Einfo.
+ -- Ekind Entity type. This field indicates the type of the
+ -- entity, it is of type Entity_Kind which is defined
+ -- in package Einfo.
- -- Flag19 197 additional flags
+ -- Flag19 197 additional flags
-- ...
-- Flag215
- -- Convention Entity convention (Convention_Id value)
+ -- Convention Entity convention (Convention_Id value)
- -- Field6 Additional Union_Id value stored in tree
+ -- Field6 Additional Union_Id value stored in tree
- -- Node6 Synonym for Field6 typed as Node_Id
- -- Elist6 Synonym for Field6 typed as Elist_Id
- -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
+ -- Node6 Synonym for Field6 typed as Node_Id
+ -- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist)
+ -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-- Similar definitions for Field7 to Field27 (and Node7-Node27,
-- Elist7-Elist27, Uint7-Uint27, Ureal7-Ureal27). Note that not all
function Elist23 (N : Node_Id) return Elist_Id;
pragma Inline (Elist23);
+ function Elist24 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist24);
+
function Name1 (N : Node_Id) return Name_Id;
pragma Inline (Name1);
procedure Set_Elist23 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist23);
+ procedure Set_Elist24 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist24);
+
procedure Set_Name1 (N : Node_Id; Val : Name_Id);
pragma Inline (Set_Name1);
procedure Set_Flag215 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag215);
-
-- The following versions of Set_Noden also set the parent
-- pointer of the referenced node if it is non_Empty
#define Field24(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7)
#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8)
-#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9)
+#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
#define Elist8(N) Field8 (N)
#define Elist13(N) Field13 (N)
#define Elist15(N) Field15 (N)
+#define Elist16(N) Field16 (N)
#define Elist18(N) Field18 (N)
#define Elist21(N) Field21 (N)
#define Elist23(N) Field23 (N)
+#define Elist24(N) Field24 (N)
#define Name1(N) Field1 (N)
#define Name2(N) Field2 (N)
-- String_Literal_Low_Bound Node15
-- Shared_Var_Read_Proc Node15
- -- Access_Disp_Table Node16
+ -- Access_Disp_Table Elist16
-- Cloned_Subtype Node16
-- DTC_Entity Node16
-- Entry_Formal Node16
-- Protected_Operation Node23
-- Obsolescent_Warning Node24
+ -- Task_Body_Procedure Node24
+ -- Abstract_Interfaces Node24
+
+ -- Abstract_Interface_Alias Node25
- -- (unused) Node25
-- (unused) Node26
+
-- (unused) Node27
---------------------------------------------
-- Must_Be_On_Byte_Boundary Flag183
-- Has_Stream_Size_Clause Flag184
-- Is_Ada_2005 Flag185
+ -- Is_Interface Flag186
- -- (unused) Flag186
-- (unused) Flag187
-- (unused) Flag188
-- (unused) Flag189
-- Attribute Access Functions --
--------------------------------
+ function Abstract_Interfaces (Id : E) return L is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ return Elist24 (Id);
+ end Abstract_Interfaces;
+
+ function Abstract_Interface_Alias (Id : E) return E is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+ return Node25 (Id);
+ end Abstract_Interface_Alias;
+
function Accept_Address (Id : E) return L is
begin
return Elist21 (Id);
end Accept_Address;
- function Access_Disp_Table (Id : E) return E is
+ function Access_Disp_Table (Id : E) return L is
begin
pragma Assert (Is_Tagged_Type (Id));
- return Node16 (Implementation_Base_Type (Id));
+ return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Actual_Subtype (Id : E) return E is
return Flag11 (Id);
end Is_Inlined;
+ function Is_Interface (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private
+ or else Ekind (Id) = E_Class_Wide_Type);
+ return Flag186 (Id);
+ end Is_Interface;
+
function Is_Instantiated (Id : E) return B is
begin
return Flag126 (Id);
return Flag165 (Id);
end Suppress_Style_Checks;
+ function Task_Body_Procedure (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Task_Type
+ or else Ekind (Id) = E_Task_Subtype);
+ return Node24 (Id);
+ end Task_Body_Procedure;
+
function Treat_As_Volatile (Id : E) return B is
begin
return Flag41 (Id);
-- Attribute Set Procedures --
------------------------------
+ procedure Set_Abstract_Interfaces (Id : E; V : L) is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ Set_Elist24 (Id, V);
+ end Set_Abstract_Interfaces;
+
+ procedure Set_Abstract_Interface_Alias (Id : E; V : E) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+ Set_Node25 (Id, V);
+ end Set_Abstract_Interface_Alias;
+
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
end Set_Accept_Address;
- procedure Set_Access_Disp_Table (Id : E; V : E) is
+ procedure Set_Access_Disp_Table (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
- Set_Node16 (Id, V);
+ Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Final_Chain (Id : E; V : E) is
Set_Flag11 (Id, V);
end Set_Is_Inlined;
+ procedure Set_Is_Interface (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ Set_Flag186 (Id, V);
+ end Set_Is_Interface;
+
procedure Set_Is_Instantiated (Id : E; V : B := True) is
begin
Set_Flag126 (Id, V);
Set_Flag165 (Id, V);
end Set_Suppress_Style_Checks;
+ procedure Set_Task_Body_Procedure (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Task_Type
+ or else Ekind (Id) = E_Task_Subtype);
+ Set_Node24 (Id, V);
+ end Set_Task_Body_Procedure;
+
procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
return Kind;
end Subtype_Kind;
- -------------------
- -- Tag_Component --
- -------------------
+ -------------------------
+ -- First_Tag_Component --
+ -------------------------
- function Tag_Component (Id : E) return E is
+ function First_Tag_Component (Id : E) return E is
Comp : Entity_Id;
Typ : Entity_Id := Id;
-- No tag component found
return Empty;
- end Tag_Component;
+ end First_Tag_Component;
+
+ ------------------------
+ -- Next_Tag_Component --
+ ------------------------
+
+ function Next_Tag_Component (Id : E) return E is
+ Comp : Entity_Id;
+ Typ : constant Entity_Id := Scope (Id);
+
+ begin
+ pragma Assert (Ekind (Id) = E_Component
+ and then Is_Tagged_Type (Typ));
+
+ Comp := Next_Entity (Id);
+ while Present (Comp) loop
+ if Is_Tag (Comp) then
+ pragma Assert (Chars (Comp) /= Name_uTag);
+ return Comp;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- No tag component found
+
+ return Empty;
+ end Next_Tag_Component;
---------------------
-- Type_High_Bound --
W ("Is_Imported", Flag24 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Instantiated", Flag126 (Id));
+ W ("Is_Interface", Flag186 (Id));
W ("Is_Internal", Flag17 (Id));
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
E_Procedure =>
Write_Str ("Alias");
- when E_Record_Type =>
+ when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
when E_Entry_Index_Parameter =>
procedure Write_Field24_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Record_Type |
+ E_Record_Subtype |
+ E_Record_Type_With_Private |
+ E_Record_Subtype_With_Private =>
+ Write_Str ("Abstract_Interfaces");
+
when Subprogram_Kind =>
Write_Str ("Obsolescent_Warning");
+ when Task_Kind =>
+ Write_Str ("Task_Body_Procedure");
+
when others =>
Write_Str ("Field24??");
end case;
procedure Write_Field25_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Procedure |
+ E_Function =>
+ Write_Str ("Abstract_Interface_Alias");
+
when others =>
Write_Str ("Field25??");
end case;
-- and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
+-- Abstract_Interfaces (Elist24)
+-- Present in record types and subtypes. List of abstract interfaces
+-- implemented by a tagged type that are not already implemented by the
+-- ancestors (Ada 2005: AI-251).
+
+-- Abstract_Interface_Alias (Node25)
+-- Present in subprograms that cover a primitive operation of an abstract
+-- interface type. Points to its associated interface subprogram. It is
+-- used to register the subprogram in secondary dispatch table of the
+-- interface (Ada 2005: AI-251).
+
-- Accept_Address (Elist21)
-- Present in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
-- rather irregular, and the semantic checks that depend on the nominal
-- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv).
--- Access_Disp_Table (Node16) [implementation base type only]
+-- Access_Disp_Table (Elist16) [implementation base type only]
-- Present in record type entities. For a tagged type, points to the
--- dispatch table associated with the tagged type. For a non-tagged
+-- dispatch tables associated with the tagged type. For a non-tagged
-- record, contains Empty.
-- Address_Clause (synthesized)
-- function of a tagged type which can dispatch on result
-- Has_Controlled_Component (Flag43) [base type only]
--- Present in composite type entities. Indicates that the type has a
--- component that either is a controlled type, or itself contains a
--- controlled component (i.e. either Has_Controlled_Component or
--- Is_Controlled is set for at least one component).
+-- Present in all entities. Set only for composite type entities which
+-- contain a component that either is a controlled type, or itself
+-- contains controlled component (i.e. either Has_Controlled_Component
+-- or Is_Controlled is set for at least one component).
-- Has_Convention_Pragma (Flag119)
-- Present in an entity for which a Convention, Import, or Export
-- Is_Integer_Type (synthesized)
-- Applies to all entities, true for integer types and subtypes
+-- Is_Interface (Flag186)
+-- Present in record types and subtypes to indicate that the current
+-- entity corresponds with an abstract interface. Because abstract
+-- interfaces are conceptually a special kind of abstract tagged types
+-- we represent them by means of tagged record types and subtypes
+-- marked with this attribute. This allows us to reuse most of the
+-- compiler support for abstract tagged types to implement interfaces
+-- (Ada 2005: AI-251).
+
-- Is_Internal (Flag17)
-- Present in all entities. Set to indicate an entity created during
-- semantic processing (e.g. an implicit type). Need more documentation
-- accurately a storage unit boundary). The front end checks that
-- component clauses respect this rule, and the back end ensures
-- that record packing does not violate this rule. Currently the
--- flag is set only for packed arrays longer than 64 bits.
+-- flag is set only for packed arrays longer than 64 bits where
+-- the component size is not a power of 2.
-- Needs_Debug_Info (Flag147)
-- Present in all entities. Set if the entity requires debugging
-- Present in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
--- Tag_Component (synthesized)
--- Applies to tagged record types, returns the entity for the _Tag
--- field in this record, which must be present.
+-- Task_Body_Procedure (Node24)
+-- Present in task types and subtypes. Points to the entity for
+-- the task body procedure (as further described in Exp_Ch9, task
+-- bodies are expanded into procedures). A convenient function to
+-- retrieve this field is Sem_Util.Get_Task_Body_Procedure.
+
+-- First_Tag_Component (synthesized)
+-- Applies to tagged record types, returns the entity for the first
+-- _Tag field in this record.
+
+-- Next_Tag_Component (synthesized)
+-- Applies to components of tagged record types. Given a _Tag field
+-- of a record, returns the next _Tag field in this record.
-- Treat_As_Volatile (Flag41)
-- Present in all type entities, and also in constants, components and
-- Can_Never_Be_Null (Flag38)
-- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
+ -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Freeze (Flag18)
-- Has_Fully_Qualified_Name (Flag173)
-- Packed_Array_Type (Node23)
-- Component_Alignment (special) (base type only)
-- Has_Component_Size_Clause (Flag68) (base type only)
- -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Pragma_Pack (Flag121) (base type only)
-- Is_Aliased (Flag15)
-- Is_Constrained (Flag12)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty in type case)
-- Last_Entity (Node20)
- -- Has_Controlled_Component (Flag43) (base type only)
-- First_Component (synth)
-- (plus type attributes)
-- Treat_As_Volatile (Flag41)
-- Is_Protected_Private (synth)
-- Next_Component (synth)
+ -- Next_Tag_Component (synth)
-- E_Constant
-- E_Loop_Parameter
-- Inner_Instances (Elist23) (for a generic function)
-- Privals_Chain (Elist23) (for a protected function)
-- Obsolescent_Warning (Node24)
+ -- Abstract_Interface_Alias (Node25)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169)
-- Inner_Instances (Elist23) (for a generic procedure)
-- Privals_Chain (Elist23) (for a protected procedure)
-- Obsolescent_Warning (Node24)
+ -- Abstract_Interface_Alias (Node25)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure)
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
- -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Uses_Sec_Stack (Flag95) ???
-- E_Record_Type
-- E_Record_Subtype
-- Primitive_Operations (Elist15)
- -- Access_Disp_Table (Node16) (base type only)
+ -- Access_Disp_Table (Elist16) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- Stored_Constraint (Elist23)
+ -- Abstract_Interfaces (Elist24)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
- -- Has_Controlled_Component (Flag43) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
+ -- Is_Interface (Flag186)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
-- First_Stored_Discriminant (synth)
- -- Tag_Component (synth)
+ -- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- Primitive_Operations (Elist15)
- -- Access_Disp_Table (Node16) (base type only)
+ -- Access_Disp_Table (Elist16) (base type only)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
+ -- Abstract_Interfaces (Elist24)
-- Has_Completion (Flag26)
-- Has_Completion_In_Body (Flag71)
- -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
+ -- Is_Interface (Flag186)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
-- First_Stored_Discriminant (synth)
- -- Tag_Component (synth)
+ -- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Signed_Integer_Type
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
+ -- Task_Body_Procedure (Node24)
-- Delay_Cleanups (Flag114)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
+ function Abstract_Interfaces (Id : E) return L;
function Accept_Address (Id : E) return L;
- function Access_Disp_Table (Id : E) return E;
+ function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
+ function Abstract_Interface_Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Final_Chain (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function Is_Immediately_Visible (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Inlined (Id : E) return B;
+ function Is_Interface (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Is_Internal (Id : E) return B;
function Is_Interrupt_Handler (Id : E) return B;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Init_Proc (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
+ function Task_Body_Procedure (Id : E) return N;
function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
function Unset_Reference (Id : E) return N;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
- function Tag_Component (Id : E) return E;
+ function First_Tag_Component (Id : E) return E;
+ function Next_Tag_Component (Id : E) return E;
function Type_High_Bound (Id : E) return N;
function Type_Low_Bound (Id : E) return N;
function Underlying_Type (Id : E) return E;
-- Attribute Set Procedures --
------------------------------
+ procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
- procedure Set_Access_Disp_Table (Id : E; V : E);
+ procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
+ procedure Set_Abstract_Interface_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Final_Chain (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
+ procedure Set_Is_Interface (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Is_Internal (Id : E; V : B := True);
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Init_Proc (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
+ procedure Set_Task_Body_Procedure (Id : E; V : N);
procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Unset_Reference (Id : E; V : N);
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
+ pragma Inline (Abstract_Interfaces);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
+ pragma Inline (Abstract_Interface_Alias);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Final_Chain);
pragma Inline (Is_Imported);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Inlined);
+ pragma Inline (Is_Interface);
pragma Inline (Is_Instantiated);
pragma Inline (Is_Integer_Type);
pragma Inline (Is_Internal);
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Init_Proc);
pragma Inline (Suppress_Style_Checks);
+ pragma Inline (Task_Body_Procedure);
pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
pragma Inline (Unset_Reference);
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
+ pragma Inline (Set_Abstract_Interfaces);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
+ pragma Inline (Set_Abstract_Interface_Alias);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Final_Chain);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Inlined);
+ pragma Inline (Set_Is_Interface);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Is_Internal);
pragma Inline (Set_Is_Interrupt_Handler);
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Init_Proc);
pragma Inline (Set_Suppress_Style_Checks);
+ pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Unset_Reference);
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Indexed_Comp),
Selector_Name =>
- New_Reference_To (Tag_Component (Comp_Type), Loc)),
+ New_Reference_To
+ (First_Tag_Component (Comp_Type), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Comp_Type), Loc)));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
+ Loc)));
Append_To (L, A);
end if;
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
- (Find_Prim_Op (RTE (RE_Limited_Record_Controller),
- Name_Initialize), Loc),
+ (Find_Prim_Op
+ (RTE (RE_Limited_Record_Controller), Name_Initialize),
+ Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
else
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
- Name_Initialize), Loc),
+ New_Reference_To
+ (Find_Prim_Op
+ (RTE (RE_Record_Controller), Name_Initialize),
+ Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Reference_To (
- Tag_Component (Base_Type (Typ)), Loc)),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Base_Type (Typ)), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Base_Type (Typ)), Loc)));
+ New_Reference_To
+ (Node (First_Elmt
+ (Access_Disp_Table (Base_Type (Typ)))),
+ Loc)));
Set_Assignment_OK (Name (Instr));
Append_To (L, Instr);
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Comp_Expr),
Selector_Name =>
- New_Reference_To (Tag_Component (Comp_Type), Loc)),
+ New_Reference_To
+ (First_Tag_Component (Comp_Type), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Comp_Type), Loc)));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
+ Loc)));
Append_To (L, Instr);
end if;
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
- New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)),
+ New_Reference_To
+ (First_Tag_Component (Base_Type (Typ)), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc)));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
+ Loc)));
Append_To (L, Instr);
end if;
if Present (Obj)
and then Finalize_Storage_Only (Typ)
- and then (Is_Library_Level_Entity (Obj)
- or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
- = Standard_True)
+ and then
+ (Is_Library_Level_Entity (Obj)
+ or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
+ Standard_True)
then
Attach := Make_Integer_Literal (Loc, 0);
Set_Assignment_OK (Ref);
Append_To (L,
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (
- Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
Parent_Expr => A);
else
Expand_Record_Aggregate (N,
- Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc),
+ Orig_Tag =>
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
Parent_Expr => A);
end if;
end if;
elsif Java_VM then
Tag_Value := Empty;
else
- Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc);
+ Tag_Value :=
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
end if;
-- For a derived type, an aggregate for the parent is formed with
elsif not Java_VM then
declare
Tag_Name : constant Node_Id :=
- New_Occurrence_Of (Tag_Component (Typ), Loc);
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Loc);
Typ_Tag : constant Entity_Id := RTE (RE_Tag);
Conv_Node : constant Node_Id :=
Unchecked_Convert_To (Typ_Tag, Tag_Value);
-- A reference to a type within its own scope is resolved to a reference
-- to the current instance of the type in its initialization procedure.
- function Find_Inherited_TSS
- (Typ : Entity_Id;
- Nam : TSS_Name_Type) return Entity_Id;
- -- Returns the TSS of name Nam of Typ, or of its closest ancestor defining
- -- such a TSS. Empty is returned is neither Typ nor any of its ancestors
- -- have such a TSS.
-
function Find_Stream_Subprogram
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
if not Java_VM then
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Pref),
Selector_Name =>
- New_Reference_To (Tag_Component (Ttyp), Loc)));
+ New_Reference_To (First_Tag_Component (Ttyp), Loc)));
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
end Tag;
Reason => CE_Overflow_Check_Failed));
end Expand_Pred_Succ;
- ------------------------
- -- Find_Inherited_TSS --
- ------------------------
-
- function Find_Inherited_TSS
- (Typ : Entity_Id;
- Nam : TSS_Name_Type) return Entity_Id
- is
- Btyp : Entity_Id := Typ;
- Proc : Entity_Id;
-
- begin
- loop
- Btyp := Base_Type (Btyp);
- Proc := TSS (Btyp, Nam);
-
- exit when Present (Proc)
- or else not Is_Derived_Type (Btyp);
-
- -- If Typ is a derived type, it may inherit attributes from
- -- some ancestor.
-
- Btyp := Etype (Btyp);
- end loop;
-
- if No (Proc) then
-
- -- If nothing else, use the TSS of the root type
-
- Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
- end if;
-
- return Proc;
- end Find_Inherited_TSS;
-
----------------------------
-- Find_Stream_Subprogram --
----------------------------
Str : String_Id;
begin
+ -- If a string expression is present, then the raise statement is
+ -- converted to a call:
+
+ -- Raise_Exception (exception-name'Identity, string);
+
+ -- and there is nothing else to do
+
+ if Present (Expression (N)) then
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Name (N),
+ Attribute_Name => Name_Identity),
+ Expression (N))));
+ Analyze (N);
+ return;
+ end if;
+
+ -- Remaining processing is for the case where no string expression
+ -- is present.
+
-- There is no expansion needed for statement "raise <exception>;" when
-- compiling for the JVM since the JVM has a built-in exception
-- mechanism. However we need the keep the expansion for "raise;"
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc)),
+ New_Reference_To (First_Tag_Component (Typ), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Typ), Loc))));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
end if;
-- Adjust the component if controlled except if it is an
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
- New_Reference_To (Tag_Component (Rec_Type), Loc)),
+ New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
Expression =>
- New_Reference_To (Access_Disp_Table (Rec_Type), Loc));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
-- The tag must be inserted before the assignments to other
-- components, because the initial value of the component may
end;
end if;
- -- For tagged types, when an init value is given, the tag has
- -- to be re-initialized separately in order to avoid the
- -- propagation of a wrong tag coming from a view conversion
- -- unless the type is class wide (in this case the tag comes
- -- from the init value). Suppress the tag assignment when
- -- Java_VM because JVM tags are represented implicitly
- -- in objects. Ditto for types that are CPP_CLASS.
+ -- For tagged types, when an init value is given, the tag has to
+ -- be re-initialized separately in order to avoid the propagation
+ -- of a wrong tag coming from a view conversion unless the type
+ -- is class wide (in this case the tag comes from the init
+ -- value). Suppress the tag assignment when Java_VM because JVM
+ -- tags are represented implicitly in objects. Ditto for types
+ -- that are CPP_CLASS, and for initializations that are
+ -- aggregates, because they have to have the right tag.
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then not Java_VM
+ and then Nkind (Expr) /= N_Aggregate
then
-- The re-assignment of the tag has to be done even if
-- the object is a constant
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Def_Id, Loc),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc));
+ New_Reference_To (First_Tag_Component (Typ), Loc));
Set_Assignment_OK (New_Ref);
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
- (Access_Disp_Table (Base_Type (Typ)), Loc))));
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Base_Type (Typ)))),
+ Loc))));
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid.
end if;
-- For access types set the Is_Known_Non_Null flag if the
- -- initializing value is known to be non-null. We can also
- -- set Can_Never_Be_Null if this is a constant.
+ -- initializing value is known to be non-null. We can also set
+ -- Can_Never_Be_Null if this is a constant.
if Known_Non_Null (Expr) then
Set_Is_Known_Non_Null (Def_Id);
end if;
end if;
- if Is_Possibly_Unaligned_Slice (Expr) then
+ -- Cases where the back end cannot handle the initialization
+ -- directly. In such cases, we expand an assignment that will
+ -- be appropriately handled by Expand_N_Assignment_Statement.
- -- Make a separate assignment that will be expanded into a
- -- loop, to bypass back-end problems with misaligned arrays.
+ -- The exclusion of the unconstrained case is wrong, but for
+ -- now it is too much trouble ???
+ if (Is_Possibly_Unaligned_Slice (Expr)
+ or else (Is_Possibly_Unaligned_Object (Expr)
+ and then not Represented_As_Scalar (Etype (Expr))))
+
+ -- The exclusion of the unconstrained case is wrong, but for
+ -- now it is too much trouble ???
+
+ and then not (Is_Array_Type (Etype (Expr))
+ and then not Is_Constrained (Etype (Expr)))
+ then
declare
Stat : constant Node_Id :=
Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Def_Id, Loc),
+ Name => New_Reference_To (Def_Id, Loc),
Expression => Relocate_Node (Expr));
-
begin
Set_Expression (N, Empty);
Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
+ Set_No_Ctrl_Actions (Stat);
Insert_After (N, Stat);
Analyze (Stat);
end;
-- Expand_N_Subtype_Indication --
---------------------------------
- -- Add a check on the range of the subtype. The static case is
- -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3,
- -- but we still need to check here for the static case in order to
- -- avoid generating extraneous expanded code.
+ -- Add a check on the range of the subtype. The static case is partially
+ -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
+ -- to check here for the static case in order to avoid generating
+ -- extraneous expanded code.
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
-- Expand_N_Variant_Part --
---------------------------
- -- If the last variant does not contain the Others choice, replace
- -- it with an N_Others_Choice node since Gigi always wants an Others.
- -- Note that we do not bother to call Analyze on the modified variant
- -- part, since it's only effect would be to compute the contents of
- -- the Others_Discrete_Choices node laboriously, and of course we
- -- already know the list of choices that corresponds to the others
- -- choice (it's the list we are replacing!)
+ -- If the last variant does not contain the Others choice, replace it with
+ -- an N_Others_Choice node since Gigi always wants an Others. Note that we
+ -- do not bother to call Analyze on the modified variant part, since it's
+ -- only effect would be to compute the contents of the
+ -- Others_Discrete_Choices node laboriously, and of course we already know
+ -- the list of choices that corresponds to the others choice (it's the
+ -- list we are replacing!)
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
-
begin
if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Last_Var));
Set_Null_Present (Comp_List, False);
else
- -- The controller cannot be placed before the _Parent field
- -- since gigi lays out field in order and _parent must be
- -- first to preserve the polymorphism of tagged types.
+ -- The controller cannot be placed before the _Parent field since
+ -- gigi lays out field in order and _parent must be first to
+ -- preserve the polymorphism of tagged types.
First_Comp := First (Component_Items (Comp_List));
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
- -- Move the _controller entity ahead in the list of internal
- -- entities of the enclosing record so that it is selected
- -- instead of a potentially inherited one.
+ -- Move the _controller entity ahead in the list of internal entities
+ -- of the enclosing record so that it is selected instead of a
+ -- potentially inherited one.
declare
E : constant Entity_Id := Last_Entity (T);
Comp_Decl :=
Make_Component_Declaration (Sloc_N,
- Defining_Identifier => Tag_Component (T),
+ Defining_Identifier => First_Tag_Component (T),
Component_Definition =>
Make_Component_Definition (Sloc_N,
Aliased_Present => False,
end if;
-- We don't Analyze the whole expansion because the tag component has
- -- already been analyzed previously. Here we just insure that the
- -- tree is coherent with the semantic decoration
+ -- already been analyzed previously. Here we just insure that the tree
+ -- is coherent with the semantic decoration
Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
begin
if not Is_Bit_Packed_Array (Typ) then
- -- If the component contains tasks, so does the array type.
- -- This may not be indicated in the array type because the
- -- component may have been a private type at the point of
- -- definition. Same if component type is controlled.
+ -- If the component contains tasks, so does the array type. This may
+ -- not be indicated in the array type because the component may have
+ -- been a private type at the point of definition. Same if component
+ -- type is controlled.
Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
Set_Has_Controlled_Component (Base,
if No (Init_Proc (Base)) then
- -- If this is an anonymous array created for a declaration
- -- with an initial value, its init_proc will never be called.
- -- The initial value itself may have been expanded into assign-
+ -- If this is an anonymous array created for a declaration with
+ -- an initial value, its init_proc will never be called. The
+ -- initial value itself may have been expanded into assign-
-- ments, in which case the object declaration is carries the
-- No_Initialization flag.
end if;
end if;
- -- For packed case, there is a default initialization, except
- -- if the component type is itself a packed structure with an
- -- initialization procedure.
+ -- For packed case, there is a default initialization, except if the
+ -- component type is itself a packed structure with an initialization
+ -- procedure.
elsif Present (Init_Proc (Component_Type (Base)))
and then No (Base_Init_Proc (Base))
pragma Warnings (Off, Func);
begin
- -- Various optimization are possible if the given representation
- -- is contiguous.
+ -- Various optimization are possible if the given representation is
+ -- contiguous.
Is_Contiguous := True;
Ent := First_Literal (Typ);
-- typA : array (Natural range 0 .. num - 1) of ctype :=
-- (v, v, v, v, v, ....)
- -- where ctype is the corresponding integer type. If the
- -- representation is contiguous, we only keep the first literal,
- -- which provides the offset for Pos_To_Rep computations.
+ -- where ctype is the corresponding integer type. If the representation
+ -- is contiguous, we only keep the first literal, which provides the
+ -- offset for Pos_To_Rep computations.
Arr :=
Make_Defining_Identifier (Loc,
-- representation) raises Constraint_Error or returns a unique value
-- of minus one. The latter case is used, e.g. in 'Valid code.
- -- Note: the reason we use Enum_Rep values in the case here is to
- -- avoid the code generator making inappropriate assumptions about
- -- the range of the values in the case where the value is invalid.
- -- ityp is a signed or unsigned integer type of appropriate width.
+ -- Note: the reason we use Enum_Rep values in the case here is to avoid
+ -- the code generator making inappropriate assumptions about the range
+ -- of the values in the case where the value is invalid. ityp is a
+ -- signed or unsigned integer type of appropriate width.
-- Note: if exceptions are not supported, then we suppress the raise
-- and return -1 unconditionally (this is an erroneous program in any
- -- case and there is no obligation to raise Constraint_Error here!)
- -- We also do this if pragma Restrictions (No_Exceptions) is active.
+ -- case and there is no obligation to raise Constraint_Error here!) We
+ -- also do this if pragma Restrictions (No_Exceptions) is active.
-- Representations are signed
if Enumeration_Rep (First_Literal (Typ)) < 0 then
-- The underlying type is signed. Reset the Is_Unsigned_Type
- -- explicitly, because it might have been inherited from a
+ -- explicitly, because it might have been inherited from
-- parent type.
Set_Is_Unsigned_Type (Typ, False);
end if;
end if;
- -- The body of the function is a case statement. First collect
- -- case alternatives, or optimize the contiguous case.
+ -- The body of the function is a case statement. First collect case
+ -- alternatives, or optimize the contiguous case.
Lst := New_List;
end loop;
-- Creation of the Dispatch Table. Note that a Dispatch Table is
- -- created for regular tagged types as well as for Ada types
- -- deriving from a C++ Class, but not for tagged types directly
- -- corresponding to the C++ classes. In the later case we assume
- -- that the Vtable is created in the C++ side and we just use it.
+ -- created for regular tagged types as well as for Ada types deriving
+ -- from a C++ Class, but not for tagged types directly corresponding to
+ -- the C++ classes. In the later case we assume that the Vtable is
+ -- created in the C++ side and we just use it.
if Is_Tagged_Type (Def_Id) then
if Is_CPP_Class (Def_Id) then
Set_Default_Constructor (Def_Id);
else
- -- Usually inherited primitives are not delayed but the first
- -- Ada extension of a CPP_Class is an exception since the
- -- address of the inherited subprogram has to be inserted in
- -- the new Ada Dispatch Table and this is a freezing action
- -- (usually the inherited primitive address is inserted in the
- -- DT by Inherit_DT)
-
- -- Similarly, if this is an inherited operation whose parent
- -- is not frozen yet, it is not in the DT of the parent, and
- -- we generate an explicit freeze node for the inherited
- -- operation, so that it is properly inserted in the DT of the
- -- current type.
+ -- Usually inherited primitives are not delayed but the first Ada
+ -- extension of a CPP_Class is an exception since the address of
+ -- the inherited subprogram has to be inserted in the new Ada
+ -- Dispatch Table and this is a freezing action (usually the
+ -- inherited primitive address is inserted in the DT by
+ -- Inherit_DT)
+
+ -- Similarly, if this is an inherited operation whose parent is
+ -- not frozen yet, it is not in the DT of the parent, and we
+ -- generate an explicit freeze node for the inherited operation,
+ -- so that it is properly inserted in the DT of the current type.
declare
Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
Expand_Tagged_Root (Def_Id);
end if;
- -- Unfreeze momentarily the type to add the predefined
- -- primitives operations. The reason we unfreeze is so
- -- that these predefined operations will indeed end up
- -- as primitive operations (which must be before the
- -- freeze point).
+ -- Unfreeze momentarily the type to add the predefined primitives
+ -- operations. The reason we unfreeze is so that these predefined
+ -- operations will indeed end up as primitive operations (which
+ -- must be before the freeze point).
Set_Is_Frozen (Def_Id, False);
Make_Predefined_Primitive_Specs
Set_All_DT_Position (Def_Id);
-- Add the controlled component before the freezing actions
- -- it is referenced in those actions.
+ -- referenced in those actions.
if Has_New_Controlled_Component (Def_Id) then
Expand_Record_Controller (Def_Id);
end if;
- -- Suppress creation of a dispatch table when Java_VM because
- -- the dispatching mechanism is handled internally by the JVM.
+ -- Suppress creation of a dispatch table when Java_VM because the
+ -- dispatching mechanism is handled internally by the JVM.
if not Java_VM then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
- -- Make sure that the primitives Initialize, Adjust and
- -- Finalize are Frozen before other TSS subprograms. We
- -- don't want them Frozen inside.
+ -- Make sure that the primitives Initialize, Adjust and Finalize
+ -- are Frozen before other TSS subprograms. We don't want them
+ -- Frozen inside.
if Is_Controlled (Def_Id) then
if not Is_Limited_Type (Def_Id) then
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
end if;
- -- In the non-tagged case, an equality function is provided only
- -- for variant records (that are not unchecked unions).
+ -- In the non-tagged case, an equality function is provided only for
+ -- variant records (that are not unchecked unions).
elsif Has_Discriminants (Def_Id)
and then not Is_Limited_Type (Def_Id)
end if;
-- Before building the record initialization procedure, if we are
- -- dealing with a concurrent record value type, then we must go
- -- through the discriminants, exchanging discriminals between the
- -- concurrent type and the concurrent record value type. See the
- -- section "Handling of Discriminants" in the Einfo spec for details.
+ -- dealing with a concurrent record value type, then we must go through
+ -- the discriminants, exchanging discriminals between the concurrent
+ -- type and the concurrent record value type. See the section "Handling
+ -- of Discriminants" in the Einfo spec for details.
if Is_Concurrent_Record_Type (Def_Id)
and then Has_Discriminants (Def_Id)
Adjust_Discriminants (Def_Id);
Build_Record_Init_Proc (Type_Decl, Def_Id);
- -- For tagged type, build bodies of primitive operations. Note
- -- that we do this after building the record initialization
- -- experiment, since the primitive operations may need the
- -- initialization routine
+ -- For tagged type, build bodies of primitive operations. Note that we
+ -- do this after building the record initialization experiment, since
+ -- the primitive operations may need the initialization routine
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
-- Freeze_Type --
-----------------
- -- Full type declarations are expanded at the point at which the type
- -- is frozen. The formal N is the Freeze_Node for the type. Any statements
- -- or declarations generated by the freezing (e.g. the procedure generated
+ -- Full type declarations are expanded at the point at which the type is
+ -- frozen. The formal N is the Freeze_Node for the type. Any statements or
+ -- declarations generated by the freezing (e.g. the procedure generated
-- for initialization) are chained in the Acions field list of the freeze
-- node using Append_Freeze_Actions.
- procedure Freeze_Type (N : Node_Id) is
+ function Freeze_Type (N : Node_Id) return Boolean is
Def_Id : constant Entity_Id := Entity (N);
RACW_Seen : Boolean := False;
+ Result : Boolean := False;
begin
-- Process associated access types needing special processing
if Ekind (Def_Id) = E_Record_Type then
Freeze_Record_Type (N);
- -- The subtype may have been declared before the type was frozen.
- -- If the type has controlled components it is necessary to create
- -- the entity for the controller explicitly because it did not
- -- exist at the point of the subtype declaration. Only the entity is
- -- needed, the back-end will obtain the layout from the type.
- -- This is only necessary if this is constrained subtype whose
- -- component list is not shared with the base type.
+ -- The subtype may have been declared before the type was frozen. If
+ -- the type has controlled components it is necessary to create the
+ -- entity for the controller explicitly because it did not exist at
+ -- the point of the subtype declaration. Only the entity is needed,
+ -- the back-end will obtain the layout from the type. This is only
+ -- necessary if this is constrained subtype whose component list is
+ -- not shared with the base type.
elsif Ekind (Def_Id) = E_Record_Subtype
and then Has_Discriminants (Def_Id)
end if;
end;
- -- Similar process if the controller of the subtype is not
- -- present but the parent has it. This can happen with constrained
+ if Is_Itype (Def_Id)
+ and then Is_Record_Type (Underlying_Type (Scope (Def_Id)))
+ then
+ -- The freeze node is only used to introduce the controller,
+ -- the back-end has no use for it for a discriminated
+ -- component.
+
+ Set_Freeze_Node (Def_Id, Empty);
+ Set_Has_Delayed_Freeze (Def_Id, False);
+ Result := True;
+ end if;
+
+ -- Similar process if the controller of the subtype is not present
+ -- but the parent has it. This can happen with constrained
-- record components where the subtype is an itype.
elsif Ekind (Def_Id) = E_Record_Subtype
Set_Freeze_Node (Def_Id, Empty);
Set_Has_Delayed_Freeze (Def_Id, False);
- Remove (N);
+ Result := True;
end;
end if;
DT_Align : Node_Id;
begin
- -- For unconstrained composite types we give a size of
- -- zero so that the pool knows that it needs a special
- -- algorithm for variable size object allocation.
+ -- For unconstrained composite types we give a size of zero
+ -- so that the pool knows that it needs a special algorithm
+ -- for variable size object allocation.
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Def_Id), 'P'));
- -- We put the code associated with the pools in the
- -- entity that has the later freeze node, usually the
- -- acces type but it can also be the designated_type;
- -- because the pool code requires both those types to be
- -- frozen
+ -- We put the code associated with the pools in the entity
+ -- that has the later freeze node, usually the acces type
+ -- but it can also be the designated_type; because the pool
+ -- code requires both those types to be frozen
if Is_Frozen (Desig_Type)
and then (not Present (Freeze_Node (Desig_Type))
null;
end if;
- -- For access-to-controlled types (including class-wide types
- -- and Taft-amendment types which potentially have controlled
- -- components), expand the list controller object that will
- -- store the dynamically allocated objects. Do not do this
+ -- For access-to-controlled types (including class-wide types and
+ -- Taft-amendment types which potentially have controlled
+ -- components), expand the list controller object that will store
+ -- the dynamically allocated objects. Do not do this
-- transformation for expander-generated access types, but do it
-- for types that are the full view of types derived from other
-- private types. Also suppress the list controller in the case
-- of a designated type with convention Java, since this is used
- -- when binding to Java API specs, where there's no equivalent
- -- of a finalization list and we don't want to pull in the
+ -- when binding to Java API specs, where there's no equivalent of
+ -- a finalization list and we don't want to pull in the
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
and then Freeze_Node (Full_View (Def_Id)) = N
then
Set_Entity (N, Full_View (Def_Id));
- Freeze_Type (N);
+ Result := Freeze_Type (N);
Set_Entity (N, Def_Id);
- -- All other types require no expander action. There are such
- -- cases (e.g. task types and protected types). In such cases,
- -- the freeze nodes are there for use by Gigi.
+ -- All other types require no expander action. There are such cases
+ -- (e.g. task types and protected types). In such cases, the freeze
+ -- nodes are there for use by Gigi.
end if;
Freeze_Stream_Operations (N, Def_Id);
+ return Result;
exception
when RE_Not_Available =>
- return;
+ return False;
end Freeze_Type;
-------------------------
-- These are the values computed by the procedure Check_Subtype_Bounds
procedure Check_Subtype_Bounds;
- -- This procedure examines the subtype T, and its ancestor subtypes
- -- and derived types to determine the best known information about
- -- the bounds of the subtype. After the call Lo_Bound is set either
- -- to No_Uint if no information can be determined, or to a value which
+ -- This procedure examines the subtype T, and its ancestor subtypes and
+ -- derived types to determine the best known information about the
+ -- bounds of the subtype. After the call Lo_Bound is set either to
+ -- No_Uint if no information can be determined, or to a value which
-- represents a known low bound, i.e. a valid value of the subtype can
-- not be less than this value. Hi_Bound is similarly set to a known
-- high bound (valid value cannot be greater than this).
begin
-- For a private type, we should always have an underlying type
-- (because this was already checked in Needs_Simple_Initialization).
- -- What we do is to get the value for the underlying type and then
- -- do an Unchecked_Convert to the private type.
+ -- What we do is to get the value for the underlying type and then do
+ -- an Unchecked_Convert to the private type.
if Is_Private_Type (T) then
Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
- -- A special case, if the underlying value is null, then qualify
- -- it with the underlying type, so that the null is properly typed
- -- Similarly, if it is an aggregate it must be qualified, because
- -- an unchecked conversion does not provide a context for it.
+ -- A special case, if the underlying value is null, then qualify it
+ -- with the underlying type, so that the null is properly typed
+ -- Similarly, if it is an aggregate it must be qualified, because an
+ -- unchecked conversion does not provide a context for it.
if Nkind (Val) = N_Null
or else Nkind (Val) = N_Aggregate
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
- -- Compute size of object. If it is given by the caller, we can
- -- use it directly, otherwise we use Esize (T) as an estimate. As
- -- far as we know this covers all cases correctly.
+ -- Compute size of object. If it is given by the caller, we can use
+ -- it directly, otherwise we use Esize (T) as an estimate. As far as
+ -- we know this covers all cases correctly.
if Size = No_Uint or else Size <= Uint_0 then
Size_To_Use := UI_Max (Uint_1, Esize (T));
begin
-- Normally we like to use the most negative number. The
- -- one exception is when this number is in the known subtype
- -- range and the largest positive number is not in the known
- -- subtype range.
+ -- one exception is when this number is in the known
+ -- subtype range and the largest positive number is not in
+ -- the known subtype range.
-- For this exceptional case, use largest positive value
begin
Renamed_Eq := Empty;
- -- Spec of _Alignment
+ -- Spec of _Size
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
+ Name => Name_uSize,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- Ret_Type => Standard_Integer));
+ Ret_Type => Standard_Long_Long_Integer));
- -- Spec of _Size
+ -- Spec of _Alignment
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
- Name => Name_uSize,
+ Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- Ret_Type => Standard_Long_Long_Integer));
+ Ret_Type => Standard_Integer));
-- Specs for dispatching stream attributes. We skip these for limited
-- types, since there is no question of dispatching in the limited case.
-- initialization call corresponds to a default initialized component
-- of an aggregate.
- procedure Freeze_Type (N : Node_Id);
- -- This procedure executes the freezing actions associated with the given
- -- freeze type node N.
+ function Freeze_Type (N : Node_Id) return Boolean;
+ -- This function executes the freezing actions associated with the given
+ -- freeze type node N and returns True if the node is to be deleted.
+ -- We delete the node if it is present just for front end purpose and
+ -- we don't want Gigi to see the node. This function can't delete the
+ -- node itself since it would confuse any remaining processing of the
+ -- freeze node.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
- New_Reference_To (Tag_Component (T), Loc)),
+ New_Reference_To (First_Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (T), Loc)));
+ New_Reference_To
+ (Elists.Node (First_Elmt (Access_Disp_Table (T))),
+ Loc)));
-- The previous assignment has to be done in any case
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
- New_Reference_To (Tag_Component (Utyp), Loc)),
+ New_Reference_To (First_Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
- Access_Disp_Table (Utyp), Loc)));
+ Elists.Node (First_Elmt (Access_Disp_Table (Utyp))),
+ Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
- -- If some (sub)component is an unchecked_union, the whole
- -- operation will raise program error.
+ -- If some (sub)component is an unchecked_union, the whole operation
+ -- will raise program error.
if Nkind (Test) = N_Raise_Program_Error then
+
+ -- This node is going to be inserted at a location where a
+ -- statement is expected: clear its Etype so analysis will
+ -- set it to the expected Standard_Void_Type.
+
+ Set_Etype (Test, Empty);
return Test;
else
Handle_One_Dimension (N + 1, Next_Index (Index)));
if Need_Separate_Indexes then
+
-- Generate guard for loop, followed by increments of indices
Append_To (Stm_List,
Expressions => New_List (New_Reference_To (Bn, Loc)))));
end if;
- -- If separate indexes, we need a declare block for An and Bn,
- -- and a loop without an iteration scheme.
+ -- If separate indexes, we need a declare block for An and Bn, and a
+ -- loop without an iteration scheme.
if Need_Separate_Indexes then
Loop_Stm :=
Typ : constant Entity_Id := Etype (N);
begin
- if Is_Bit_Packed_Array (Typ) then
+ -- Special case of bit packed array where both operands are known
+ -- to be properly aligned. In this case we use an efficient run time
+ -- routine to carry out the operation (see System.Bit_Ops).
+
+ if Is_Bit_Packed_Array (Typ)
+ and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
+ and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
+ then
Expand_Packed_Boolean_Operator (N);
+ return;
+ end if;
- else
- -- For the normal non-packed case, the general expansion is
- -- to build a function for carrying out the comparison (using
- -- Make_Boolean_Array_Op) and then inserting it into the tree.
- -- The original operator node is then rewritten as a call to
- -- this function.
+ -- For the normal non-packed case, the general expansion is to build
+ -- function for carrying out the comparison (use Make_Boolean_Array_Op)
+ -- and then inserting it into the tree. The original operator node is
+ -- then rewritten as a call to this function. We also use this in the
+ -- packed case if either operand is a possibly unaligned object.
- declare
- Loc : constant Source_Ptr := Sloc (N);
- L : constant Node_Id := Relocate_Node (Left_Opnd (N));
- R : constant Node_Id := Relocate_Node (Right_Opnd (N));
- Func_Body : Node_Id;
- Func_Name : Entity_Id;
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ L : constant Node_Id := Relocate_Node (Left_Opnd (N));
+ R : constant Node_Id := Relocate_Node (Right_Opnd (N));
+ Func_Body : Node_Id;
+ Func_Name : Entity_Id;
- begin
- Convert_To_Actual_Subtype (L);
- Convert_To_Actual_Subtype (R);
- Ensure_Defined (Etype (L), N);
- Ensure_Defined (Etype (R), N);
- Apply_Length_Check (R, Etype (L));
-
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
- then
- Build_Boolean_Array_Proc_Call (Parent (N), L, R);
+ begin
+ Convert_To_Actual_Subtype (L);
+ Convert_To_Actual_Subtype (R);
+ Ensure_Defined (Etype (L), N);
+ Ensure_Defined (Etype (R), N);
+ Apply_Length_Check (R, Etype (L));
+
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
+ then
+ Build_Boolean_Array_Proc_Call (Parent (N), L, R);
- elsif Nkind (Parent (N)) = N_Op_Not
- and then Nkind (N) = N_Op_And
- and then
- Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
- then
- return;
- else
+ elsif Nkind (Parent (N)) = N_Op_Not
+ and then Nkind (N) = N_Op_And
+ and then
+ Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
+ then
+ return;
+ else
- Func_Body := Make_Boolean_Array_Op (Etype (L), N);
- Func_Name := Defining_Unit_Name (Specification (Func_Body));
- Insert_Action (N, Func_Body);
+ Func_Body := Make_Boolean_Array_Op (Etype (L), N);
+ Func_Name := Defining_Unit_Name (Specification (Func_Body));
+ Insert_Action (N, Func_Body);
- -- Now rewrite the expression with a call
+ -- Now rewrite the expression with a call
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Func_Name, Loc),
- Parameter_Associations =>
- New_List
- (L, Make_Type_Conversion
- (Loc, New_Reference_To (Etype (L), Loc), R))));
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List (
+ L,
+ Make_Type_Conversion
+ (Loc, New_Reference_To (Etype (L), Loc), R))));
- Analyze_And_Resolve (N, Typ);
- end if;
- end;
- end if;
+ Analyze_And_Resolve (N, Typ);
+ end if;
+ end;
end Expand_Boolean_Operator;
-------------------------------
Force_Validity_Checks := Save_Force_Validity_Checks;
end;
- -- Packed case
+ -- Packed case where both operands are known aligned
- elsif Is_Bit_Packed_Array (Typl) then
+ elsif Is_Bit_Packed_Array (Typl)
+ and then not Is_Possibly_Unaligned_Object (Lhs)
+ and then not Is_Possibly_Unaligned_Object (Rhs)
+ then
Expand_Packed_Eq (N);
-- Where the component type is elementary we can use a block bit
-- comparison (if supported on the target) exception in the case
-- of floating-point (negative zero issues require element by
-- element comparison), and atomic types (where we must be sure
- -- to load elements independently).
+ -- to load elements independently) and possibly unaligned arrays.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not Is_Atomic (Component_Type (Typl))
+ and then not Is_Possibly_Unaligned_Object (Lhs)
+ and then not Is_Possibly_Unaligned_Object (Rhs)
and then Support_Composite_Compare_On_Target
then
null;
return;
end if;
- -- Case of array operand. If bit packed, handle it in Exp_Pakd
+ -- Case of array operand. If bit packed with a component size of 1,
+ -- handle it in Exp_Pakd if the operand is known to be aligned.
- if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
+ if Is_Bit_Packed_Array (Typ)
+ and then Component_Size (Typ) = 1
+ and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
+ then
Expand_Packed_Not (N);
return;
end if;
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
- Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
return
Action => CW_Membership,
Args => New_List (
Obj_Tag,
- New_Reference_To (
- Access_Disp_Table (Root_Type (Right_Type)), Loc)));
+ New_Reference_To
+ (Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc)));
else
return
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
- New_Reference_To (Access_Disp_Table (Right_Type), Loc));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
end if;
end Tagged_Membership;
-- --
-- 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- --
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
+with Elists; use Elists;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
end if;
end Check_Unconstrained_Bit_Packed_Array;
- -- Gigi can always handle the assignment if the right side is a string
- -- literal (note that overlap is definitely impossible in this case).
- -- If the type is packed, a string literal is always converted into a
- -- aggregate, except in the case of a null slice, for which no aggregate
- -- can be written. In that case, rewrite the assignment as a null
- -- statement, a length check has already been emitted to verify that
- -- the range of the left-hand side is empty.
+ -- The back end can always handle the assignment if the right side is a
+ -- string literal (note that overlap is definitely impossible in this
+ -- case). If the type is packed, a string literal is always converted
+ -- into aggregate, except in the case of a null slice, for which no
+ -- aggregate can be written. In that case, rewrite the assignment as a
+ -- null statement, a length check has already been emitted to verify
+ -- that the range of the left-hand side is empty.
-- Note that this code is not executed if we had an assignment of
-- a string literal to a non-bit aligned component of a record, a
-- If either operand is bit packed, then we need a loop, since we
-- can't be sure that the slice is byte aligned. Similarly, if either
-- operand is a possibly unaligned slice, then we need a loop (since
- -- gigi cannot handle unaligned slices).
+ -- the back end cannot handle unaligned slices).
elsif Is_Bit_Packed_Array (L_Type)
or else Is_Bit_Packed_Array (R_Type)
-- If we are not bit-packed, and we have only one slice, then no
-- overlap is possible except in the parameter case, so we can let
- -- gigi handle things.
+ -- the back end handle things.
elsif not (L_Slice and R_Slice) then
if Forwards_OK (N) then
if not Loop_Required then
if Forwards_OK (N) then
return;
-
else
null;
-- Here is where a memmove would be appropriate ???
then
-- Call TSS procedure for array assignment, passing the
- -- the explicit bounds of right- and left-hand side.
+ -- the explicit bounds of right and left hand sides.
declare
Proc : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
- Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
+ Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
Expressions => ExprL),
Expression =>
Make_Indexed_Component (Loc,
- Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
+ Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
Expressions => ExprR));
+ -- We set assignment OK, since there are some cases, e.g. in object
+ -- declarations, where we are actually assigning into a constant.
+ -- If there really is an illegality, it was caught long before now,
+ -- and was flagged when the original assignment was analyzed.
+
+ Set_Assignment_OK (Name (Assign));
+
-- Propagate the No_Ctrl_Actions flag to individual assignments
Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
-- Expand_N_Assignment_Statement --
-----------------------------------
- -- For array types, deal with slice assignments and setting the flags
- -- to indicate if it can be statically determined which direction the
- -- move should go in. Also deal with generating range/length checks.
+ -- This procedure implements various cases where an assignment statement
+ -- cannot just be passed on to the back end in untransformed state.
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
declare
Uses_Transient_Scope : constant Boolean :=
- Scope_Is_Transient and then N = Node_To_Be_Wrapped;
+ Scope_Is_Transient
+ and then N = Node_To_Be_Wrapped;
begin
if Uses_Transient_Scope then
Expand_Bit_Packed_Element_Set (N);
return;
- -- Case of tagged type assignment
-
elsif Is_Tagged_Type (Typ)
or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ))
then
if Is_Class_Wide_Type (Typ)
- -- If the type is tagged, we may as well use the predefined
- -- primitive assignment. This avoids inlining a lot of code
- -- and in the class-wide case, the assignment is replaced by
- -- a dispatch call to _assign. Note that this cannot be done
- -- when discriminant checks are locally suppressed (as in
- -- extension aggregate expansions) because otherwise the
- -- discriminant check will be performed within the _assign
- -- call.
-
- or else (Is_Tagged_Type (Typ)
- and then Chars (Current_Scope) /= Name_uAssign
- and then Expand_Ctrl_Actions
- and then not Discriminant_Checks_Suppressed (Empty))
+ -- If the type is tagged, we may as well use the predefined
+ -- primitive assignment. This avoids inlining a lot of code
+ -- and in the class-wide case, the assignment is replaced by
+ -- dispatch call to _assign. Note that this cannot be done
+ -- when discriminant checks are locally suppressed (as in
+ -- extension aggregate expansions) because otherwise the
+ -- discriminant check will be performed within the _assign
+ -- call. It is also suppressed for assignmments created by the
+ -- expander that correspond to initializations, where we do
+ -- want to copy the tag (No_Ctrl_Actions flag set True).
+ -- by the expander and we do not need to mess with tags ever
+ -- (Expand_Ctrl_Actions flag is set True in this case).
+
+ or else (Is_Tagged_Type (Typ)
+ and then Chars (Current_Scope) /= Name_uAssign
+ and then Expand_Ctrl_Actions
+ and then not Discriminant_Checks_Suppressed (Empty))
then
-- Fetch the primitive op _assign and proper type to call
-- it. Because of possible conflits between private and
then
declare
Blk : constant Entity_Id :=
- New_Internal_Entity (
- E_Block, Current_Scope, Sloc (N), 'B');
+ New_Internal_Entity
+ (E_Block, Current_Scope, Sloc (N), 'B');
begin
Set_Scope (Blk, Current_Scope);
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
- New_Reference_To (Tag_Component (Utyp), Loc)),
+ New_Reference_To (First_Tag_Component (Utyp), Loc)),
Right_Opnd =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
- (Access_Disp_Table (Base_Type (Utyp)), Loc))),
+ (Node (First_Elmt
+ (Access_Disp_Table (Base_Type (Utyp)))),
+ Loc))),
Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type,
Expression =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name => New_Reference_To (Tag_Component (T), Loc))));
+ Selector_Name => New_Reference_To (First_Tag_Component (T),
+ Loc))));
-- Otherwise Tag_Tmp not used
-- Index of first byte to be copied after outermost record
-- controller data.
- Expr, Source_Size : Node_Id;
+ Expr, Source_Size : Node_Id;
+ Source_Actual_Subtype : Entity_Id;
-- Used for computation of the size of the data to be copied
Range_Type : Entity_Id;
Expr := Expression (Expr);
end if;
+ Source_Actual_Subtype := Etype (Expr);
+
+ if Has_Discriminants (Source_Actual_Subtype)
+ and then not Is_Constrained (Source_Actual_Subtype)
+ then
+ Append_To (Res,
+ Build_Actual_Subtype (Source_Actual_Subtype, Expr));
+ Source_Actual_Subtype := Defining_Identifier (Last (Res));
+ end if;
+
Source_Size :=
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
- Expr,
+ New_Occurrence_Of (Source_Actual_Subtype, Loc),
Attribute_Name =>
Name_Size),
Right_Opnd =>
Make_Integer_Literal (Loc,
System_Storage_Unit - 1));
-
- -- If Expr is a type conversion, standard Ada does not allow
- -- 'Size to be taken on it, but Gigi can handle this case,
- -- and thus we can determine the amount of data to be copied.
- -- The appropriate circuitry is enabled only for conversions
- -- that do not Come_From_Source.
-
- Set_Comes_From_Source (Prefix (Left_Opnd (Source_Size)), False);
-
Source_Size :=
Make_Op_Divide (Loc,
Left_Opnd => Source_Size,
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name => New_Reference_To (Tag_Component (T), Loc)),
+ Selector_Name => New_Reference_To (First_Tag_Component (T),
+ Loc)),
Expression => New_Reference_To (Tag_Tmp, Loc)));
end if;
-- --
-- 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- --
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected
- -- subprogram. Its statement sequence first defers abortion, then locks
+ -- subprogram. Its statement sequence first defers abort, then locks
-- the associated protected object, and then enters a block that contains
-- a call to the unprotected version of the subprogram (for details, see
-- Build_Unprotected_Subprogram_Body). This block statement requires
-----------------------------------
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (T);
- Nam : constant Name_Id := Chars (T);
- Tdec : constant Node_Id := Declaration_Node (T);
- Ent : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (T);
+ Nam : constant Name_Id := Chars (T);
+ Ent : Entity_Id;
begin
Ent :=
-- Associate the procedure with the task, if this is the declaration
-- (and not the body) of the procedure.
- if No (Task_Body_Procedure (Tdec)) then
- Set_Task_Body_Procedure (Tdec, Ent);
+ if No (Task_Body_Procedure (T)) then
+ Set_Task_Body_Procedure (T, Ent);
end if;
return
New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats));
- -- Protected the call against abortion
+ -- Protected the call against abort
Prepend_To (Stmts,
Make_Procedure_Call_Statement (Loc,
-- typ!(Displaced_This (Address!(Param)))
if Param = Ctrl_Arg
- and then DTC_Entity (Subp) /= Tag_Component (Typ)
+ and then DTC_Entity (Subp) /= First_Tag_Component (Typ)
then
Append_To (New_Params,
Make_Selected_Component (Loc,
Prefix => New_Value (Ctrl_Arg),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc)),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ, New_Value (Param)),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc))),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
Then_Statements =>
New_List (New_Constraint_Error (Loc))));
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc)),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc))),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
return Node_Id
is
Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
- DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ);
+ DT_Ptr : constant Entity_Id := Node (First_Elmt
+ (Access_Disp_Table (Typ)));
begin
return
function Make_DT (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
- Result : constant List_Id := New_List;
- Elab_Code : constant List_Id := New_List;
+ ADT_List : constant Elist_Id := New_Elmt_List;
+ Result : constant List_Id := New_List;
+ Elab_Code : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ);
Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc,
- DT_Entry_Count (Tag_Component (Typ)))));
+ DT_Entry_Count (First_Tag_Component (Typ)))));
Append_To (Result,
Make_Object_Declaration (Loc,
-- Set Access_Disp_Table field to be the dispatch table pointer
- Set_Access_Disp_Table (Typ, DT_Ptr);
+ Append_Elmt (DT_Ptr, ADT_List);
+ Set_Access_Disp_Table (Typ, ADT_List);
-- Count ancestors to compute the inheritance depth. For private
-- extensions, always go to the full view in order to compute the real
Make_Integer_Literal (Loc, 0));
else
- Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc);
+ Old_Tag :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
Old_TSD :=
Make_DT_Access_Action (Typ,
Action => Get_TSD,
Args => New_List (
- New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc)));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc)));
end if;
-- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
Node1 => Old_Tag,
Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc,
- DT_Entry_Count (Tag_Component (Etype (Typ)))))));
+ DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
-- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
- The_Tag : constant Entity_Id := Tag_Component (Typ);
+ The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Parent_EC : Int;
-- Get Entry_Count of the parent
if Parent_Typ /= Typ
- and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint
+ and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
then
- Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ)));
+ Parent_EC := UI_To_Int (DT_Entry_Count
+ (First_Tag_Component (Parent_Typ)));
else
Parent_EC := 0;
end if;
pragma Assert (
DT_Entry_Count (The_Tag) >=
- DT_Entry_Count (Tag_Component (Parent_Typ)));
+ DT_Entry_Count (First_Tag_Component (Parent_Typ)));
end if;
end Set_All_DT_Position;
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
- TSS_Nam : Name_Id);
+ TSS_Nam : TSS_Name_Type);
-- Create a renaming declaration of subprogram Nam,
-- and register it as a TSS for Typ with name TSS_Nam.
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
- New_Occurrence_Of (Tag_Component
+ New_Occurrence_Of (First_Tag_Component
(Designated_Type (Etype (Pointer))), Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RACW_Type, Fnam, Name_uFrom_Any);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
end Add_RACW_From_Any;
-----------------------------
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RACW_Type, Fnam, Name_uTo_Any);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
end Add_RACW_To_Any;
-----------------------
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RACW_Type, Fnam, Name_uTypeCode);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
end Add_RACW_TypeCode;
------------------------------
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RAS_Type, Fnam, Name_uFrom_Any);
+ Set_Renaming_TSS (RAS_Type, Fnam, TSS_From_Any);
end Add_RAS_From_Any;
--------------------
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RAS_Type, Fnam, Name_uTo_Any);
+ Set_Renaming_TSS (RAS_Type, Fnam, TSS_To_Any);
end Add_RAS_To_Any;
----------------------
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
- Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode);
+ Set_Renaming_TSS (RAS_Type, Fnam, TSS_TypeCode);
end Add_RAS_TypeCode;
-----------------------------------------
-- Local Subprograms --
-----------------------
- function Find_Inherited_TSS
- (Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id;
- -- A TSS reference for a representation aspect of a derived tagged
- -- type must take into account inheritance of that aspect from
- -- ancestor types. (copied from exp_attr.adb, should be shared???)
-
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id;
-- Given a numeric type Typ, return the smallest integer or floarting
-- First simple case where the From_Any function is present
-- in the type's TSS.
- Fnam := Find_Inherited_TSS (U_Type, Name_uFrom_Any);
+ Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
-
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
-- First simple case where the To_Any function is present
-- in the type's TSS.
- Fnam := Find_Inherited_TSS (U_Type, Name_uTo_Any);
+ Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
-- Check first for Boolean and Character. These are enumeration
-- types, but we treat them specially, since they may require
-- First simple case where the TypeCode is present
-- in the type's TSS.
- Fnam := Find_Inherited_TSS (U_Type, Name_uTypeCode);
+ Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
if Present (Fnam) then
Statements => Stms));
end Build_TypeCode_Function;
- ------------------------
- -- Find_Inherited_TSS --
- ------------------------
-
- function Find_Inherited_TSS
- (Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id
- is
- P_Type : Entity_Id := Typ;
- Proc : Entity_Id;
-
- begin
- Proc := TSS (Base_Type (Typ), Nam);
-
- -- Check first if there is a TSS given for the type itself
-
- if Present (Proc) then
- return Proc;
- end if;
-
- -- If Typ is a derived type, it may inherit attributes from some
- -- ancestor which is not the ultimate underlying one. If Typ is a
- -- derived tagged type, The corresponding primitive operation has
- -- been created explicitly.
-
- if Is_Derived_Type (P_Type) then
- if Is_Tagged_Type (P_Type) then
- return Find_Prim_Op (P_Type, Nam);
- else
- while Is_Derived_Type (P_Type) loop
- Proc := TSS (Base_Type (Etype (Typ)), Nam);
-
- if Present (Proc) then
- return Proc;
- else
- P_Type := Base_Type (Etype (P_Type));
- end if;
- end loop;
- end if;
- end if;
-
- -- If nothing else, use the TSS of the root type
-
- return TSS (Base_Type (Underlying_Type (Typ)), Nam);
- end Find_Inherited_TSS;
-
---------------------------------
-- Find_Numeric_Representation --
---------------------------------
Counter => Counter,
Datum => New_Occurrence_Of (Inner_Any, Loc));
-
Append_To (Stmts,
Make_Block_Statement (Loc,
Declarations =>
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
- TSS_Nam : Name_Id)
+ TSS_Nam : TSS_Name_Type)
is
Loc : constant Source_Ptr := Sloc (Nam);
Spec : constant Node_Id := Parent (Nam);
Specification =>
Copy_Specification (Loc,
Spec => Spec,
- New_Name => TSS_Nam),
+ New_Name => Make_TSS_Name (Typ, TSS_Nam)),
Name => New_Occurrence_Of (Nam, Loc));
Snam : constant Entity_Id :=
-- --
-- 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- --
Set_Name (Raise_Node, P_Name);
end if;
+ if Token = Tok_With then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SC ("string expression in raise is Ada 2005 extension");
+ Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Scan; -- past WITH
+ Set_Expression (Raise_Node, P_Expression);
+ end if;
+
TF_Semicolon;
return Raise_Node;
end P_Raise_Statement;
-- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
-- | FORMAL_ARRAY_TYPE_DEFINITION
-- | FORMAL_ACCESS_TYPE_DEFINITION
+ -- | FORMAL_INTERFACE_TYPE_DEFINITION
-- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
-- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+ -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION
+
function P_Formal_Type_Definition return Node_Id is
- Scan_State : Saved_Scan_State;
+ Scan_State : Saved_Scan_State;
+ Typedef_Node : Node_Id;
begin
if Token_Name = Name_Abstract then
return P_Formal_Private_Type_Definition;
end if;
- when Tok_Private | Tok_Limited | Tok_Tagged =>
- return P_Formal_Private_Type_Definition;
+ when Tok_Access =>
+ return P_Access_Type_Definition;
- when Tok_New =>
- return P_Formal_Derived_Type_Definition;
+ when Tok_Array =>
+ return P_Array_Type_Definition;
+
+ when Tok_Delta =>
+ return P_Formal_Fixed_Point_Definition;
+
+ when Tok_Digits =>
+ return P_Formal_Floating_Point_Definition;
+
+ when Tok_Interface => -- Ada 2005 (AI-251)
+ return P_Interface_Type_Definition (Is_Synchronized => False);
when Tok_Left_Paren =>
return P_Formal_Discrete_Type_Definition;
- when Tok_Range =>
- return P_Formal_Signed_Integer_Type_Definition;
+ when Tok_Limited =>
+ Save_Scan_State (Scan_State);
+ Scan; -- past LIMITED
+
+ if Token = Tok_Interface then
+ Typedef_Node := P_Interface_Type_Definition
+ (Is_Synchronized => False);
+ Set_Limited_Present (Typedef_Node);
+ return Typedef_Node;
+
+ else
+ Restore_Scan_State (Scan_State);
+ return P_Formal_Private_Type_Definition;
+ end if;
when Tok_Mod =>
return P_Formal_Modular_Type_Definition;
- when Tok_Digits =>
- return P_Formal_Floating_Point_Definition;
-
- when Tok_Delta =>
- return P_Formal_Fixed_Point_Definition;
+ when Tok_New =>
+ return P_Formal_Derived_Type_Definition;
- when Tok_Array =>
- return P_Array_Type_Definition;
+ when Tok_Private |
+ Tok_Tagged =>
+ return P_Formal_Private_Type_Definition;
- when Tok_Access =>
- return P_Access_Type_Definition;
+ when Tok_Range =>
+ return P_Formal_Signed_Integer_Type_Definition;
when Tok_Record =>
Error_Msg_SC ("record not allowed in generic type definition!");
Discard_Junk_Node (P_Record_Definition);
return Error;
+ -- Ada 2005 (AI-345)
+
+ when Tok_Protected |
+ Tok_Synchronized |
+ Tok_Task =>
+
+ Scan; -- past TASK, PROTECTED or SYNCHRONIZED
+
+ declare
+ Saved_Token : constant Token_Type := Token;
+
+ begin
+ Typedef_Node := P_Interface_Type_Definition
+ (Is_Synchronized => True);
+
+ case Saved_Token is
+ when Tok_Task =>
+ Set_Task_Present (Typedef_Node);
+
+ when Tok_Protected =>
+ Set_Protected_Present (Typedef_Node);
+
+ when Tok_Synchronized =>
+ Set_Synchronized_Present (Typedef_Node);
+
+ when others =>
+ null;
+ end case;
+
+ return Typedef_Node;
+ end;
+
when others =>
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new SUBTYPE_MARK [with private]
+ -- [abstract] new SUBTYPE_MARK [[AND interface_list] with private]
-- The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
+ -- Ada 2005 (AI-251): Deal with interfaces
+
+ if Token = Tok_And then
+ Scan; -- past AND
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Def_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name, Interface_List (Def_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+ end if;
+
if Token = Tok_With then
Scan; -- past WITH
Set_Private_Present (Def_Node, True);
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
- -- | DERIVED_TYPE_DEFINITION
+ -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
-- INTEGER_TYPE_DEFINITION ::=
-- SIGNED_INTEGER_TYPE_DEFINITION
-- MODULAR_TYPE_DEFINITION
+ -- INTERFACE_TYPE_DEFINITION ::=
+ -- [limited | task | protected | synchronized ] interface
+ -- [AND interface_list]
+
-- Error recovery: can raise Error_Resync
-- Note: The processing for full type declaration, incomplete type
-- function handles only declarations starting with TYPE).
function P_Type_Declaration return Node_Id is
- Type_Loc : Source_Ptr;
- Type_Start_Col : Column_Number;
- Ident_Node : Node_Id;
+ Abstract_Present : Boolean;
+ Abstract_Loc : Source_Ptr;
Decl_Node : Node_Id;
Discr_List : List_Id;
- Unknown_Dis : Boolean;
Discr_Sloc : Source_Ptr;
- Abstract_Present : Boolean;
- Abstract_Loc : Source_Ptr;
End_Labl : Node_Id;
+ Type_Loc : Source_Ptr;
+ Type_Start_Col : Column_Number;
+ Ident_Node : Node_Id;
+ Is_Derived_Iface : Boolean := False;
+ Unknown_Dis : Boolean;
- Typedef_Node : Node_Id;
+ Typedef_Node : Node_Id;
-- Normally holds type definition, except in the case of a private
-- extension declaration, in which case it holds the declaration itself
TF_Semicolon;
exit;
- when Tok_Private =>
- Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
- Scan; -- past PRIVATE
- TF_Semicolon;
- exit;
-
when Tok_Limited =>
Scan; -- past LIMITED
Typedef_Node := P_Record_Definition;
Set_Limited_Present (Typedef_Node, True);
+ -- Ada 2005 (AI-251): LIMITED INTERFACE
+
+ elsif Token = Tok_Interface then
+ Typedef_Node := P_Interface_Type_Definition
+ (Is_Synchronized => False);
+ Abstract_Present := True;
+ Set_Limited_Present (Typedef_Node);
+
+ if Nkind (Typedef_Node) = N_Derived_Type_Definition then
+ Is_Derived_Iface := True;
+ end if;
+
-- LIMITED PRIVATE is the only remaining possibility here
else
exit;
+ -- Ada 2005 (AI-251): INTERFACE
+
+ when Tok_Interface =>
+ Typedef_Node := P_Interface_Type_Definition
+ (Is_Synchronized => False);
+ Abstract_Present := True;
+ TF_Semicolon;
+ exit;
+
+ when Tok_Private =>
+ Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
+ Scan; -- past PRIVATE
+ TF_Semicolon;
+ exit;
+
+ -- Ada 2005 (AI-345)
+
+ when Tok_Protected |
+ Tok_Synchronized |
+ Tok_Task =>
+
+ declare
+ Saved_Token : constant Token_Type := Token;
+
+ begin
+ Scan; -- past TASK, PROTECTED or SYNCHRONIZED
+
+ Typedef_Node := P_Interface_Type_Definition
+ (Is_Synchronized => True);
+
+ case Saved_Token is
+ when Tok_Task =>
+ Set_Task_Present (Typedef_Node);
+
+ when Tok_Protected =>
+ Set_Protected_Present (Typedef_Node);
+
+ when Tok_Synchronized =>
+ Set_Synchronized_Present (Typedef_Node);
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+ end;
+
+ TF_Semicolon;
+ exit;
+
-- Anything else is an error
when others =>
if Nkind (Typedef_Node) = N_Record_Definition
or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node)))
+ or else Is_Derived_Iface
then
Set_Abstract_Present (Typedef_Node, Abstract_Present);
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
- Error_Msg_SC ("'RENAMES' expected");
+ Error_Msg_SC ("RENAMES expected");
raise Error_Resync;
end if;
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
if Token /= Tok_Renames then
- Error_Msg_SC ("'RENAMES' expected");
+ Error_Msg_SC ("RENAMES expected");
raise Error_Resync;
end if;
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
- -- [RECORD_EXTENSION_PART]
+ -- [[AND interface_list] RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
+ -- [abstract] new ancestor_SUBTYPE_INDICATION
+ -- [AND interface_list] with PRIVATE;
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
Typedef_Node : Node_Id;
Typedecl_Node : Node_Id;
Not_Null_Present : Boolean := False;
+
begin
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
T_New;
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
+ -- Ada 2005 (AI-251): Deal with interfaces
+
+ if Token = Tok_And then
+ Scan; -- past AND
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Typedef_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+
+ if Token /= Tok_With then
+ Error_Msg_SC ("WITH expected");
+ raise Error_Resync;
+ end if;
+ end if;
+
-- Deal with record extension, note that we assume that a WITH is
-- missing in the case of "type X is new Y record ..." or in the
-- case of "type X is new Y null record".
-- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
+ --------------------------------------
+ -- 3.9.4 Interface Type Definition --
+ --------------------------------------
+
+ -- INTERFACE_TYPE_DEFINITION ::=
+ -- [limited | task | protected | synchronized] interface
+ -- [AND interface_list]
+
+ -- Error recovery: cannot raise Error_Resync
+
+ function P_Interface_Type_Definition
+ (Is_Synchronized : Boolean) return Node_Id
+ is
+ Typedef_Node : Node_Id;
+
+ begin
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Scan; -- past INTERFACE
+
+ -- Ada 2005 (AI-345): In case of synchronized interfaces and
+ -- interfaces with a null list of interfaces we build a
+ -- record_definition node.
+
+ if Is_Synchronized
+ or else Token = Tok_Semicolon
+ then
+ Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
+
+ Set_Abstract_Present (Typedef_Node);
+ Set_Tagged_Present (Typedef_Node);
+ Set_Null_Present (Typedef_Node);
+ Set_Interface_Present (Typedef_Node);
+
+ if Is_Synchronized
+ and then Token = Tok_And
+ then
+ Scan; -- past AND
+ Set_Interface_List (Typedef_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name,
+ Interface_List (Typedef_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+ end if;
+
+ -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
+ -- a list of interfaces we build a derived_type_definition node. This
+ -- simplifies the semantic analysis (and hence further mainteinance)
+
+ else
+ if Token /= Tok_And then
+ Error_Msg_AP ("AND expected");
+ else
+ Scan; -- past AND
+ end if;
+
+ Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
+
+ Set_Abstract_Present (Typedef_Node);
+ Set_Interface_Present (Typedef_Node);
+ Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
+
+ Set_Record_Extension_Part (Typedef_Node,
+ New_Node (N_Record_Definition, Token_Ptr));
+ Set_Null_Present (Record_Extension_Part (Typedef_Node));
+
+ if Token = Tok_And then
+ Set_Interface_List (Typedef_Node, New_List);
+ Scan; -- past AND
+
+ loop
+ Append (P_Qualified_Simple_Name,
+ Interface_List (Typedef_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+ end if;
+ end if;
+
+ return Typedef_Node;
+ end P_Interface_Type_Definition;
+
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------
-- --
-- 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- --
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- [is TASK_DEFINITION];
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- SINGLE_TASK_DECLARATION ::=
-- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
end if;
else
TF_Is; -- must have IS if no semicolon
+
+ -- Ada 2005 (AI-345)
+
+ if Token = Tok_New then
+ Scan; -- past NEW
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("task interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Task_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name, Interface_List (Task_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+
+ if Token /= Tok_With then
+ Error_Msg_SC ("WITH expected");
+ end if;
+
+ Scan; -- past WITH
+ end if;
+
Set_Task_Definition (Task_Node, P_Task_Definition);
end if;
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- is PROTECTED_DEFINITION;
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- SINGLE_PROTECTED_DECLARATION ::=
-- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
end if;
T_Is;
+
+ -- Ada 2005 (AI-345)
+
+ if Token = Tok_New then
+ Scan; -- past NEW
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("task interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Protected_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name,
+ Interface_List (Protected_Node));
+
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+
+ if Token /= Tok_With then
+ Error_Msg_SC ("WITH expected");
+ end if;
+
+ Scan; -- past WITH
+ end if;
+
Set_Protected_Definition (Protected_Node, P_Protected_Definition);
return Protected_Node;
end if;
-- --
-- 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- --
-- treatment of errors in case a reserved word is scanned. See the
-- declaration of this type for details.
+ function P_Interface_Type_Definition
+ (Is_Synchronized : Boolean) return Node_Id;
+ -- Ada 2005 (AI-251): Parse the interface type definition part. The
+ -- parameter Is_Synchronized is True in case of task interfaces,
+ -- protected interfaces, and synchronized interfaces; it is used to
+ -- generate a record_definition node. In the rest of cases (limited
+ -- interfaces and interfaces) we generate a record_definition node if
+ -- the list of interfaces is empty; otherwise we generate a
+ -- derived_type_definition node (the first interface in this list is the
+ -- ancestor interface).
+
function P_Null_Exclusion return Boolean;
-- Ada 2005 (AI-231): Parse the null-excluding part. True indicates
-- that the null-excluding part was present.
-- --
-- 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- --
procedure Analyze_Raise_Statement (N : Node_Id) is
Exception_Id : constant Node_Id := Name (N);
- Exception_Name : Entity_Id := Empty;
+ Exception_Name : Entity_Id := Empty;
P : Node_Id;
Nkind_P : Node_Kind;
Error_Msg_N
("exception name expected in raise statement", Exception_Id);
end if;
+
+ if Present (Expression (N)) then
+ Analyze_And_Resolve (Expression (N), Standard_String);
+ end if;
end if;
end Analyze_Raise_Statement;
if Expander_Active and then Typ = Root_Type (Typ) then
- Tag_C := Tag_Component (Typ);
+ Tag_C := First_Tag_Component (Typ);
C := First_Entity (Typ);
if C = Tag_C then
-- . DT_Position will be set at the freezing point
if Arg_Count = 1 then
- Set_DTC_Entity (Subp, Tag_Component (Typ));
+ Set_DTC_Entity (Subp, First_Tag_Component (Typ));
return;
end if;
-- If it is the first pragma Vtable, This becomes the default tag
elsif (not Is_Tag (DTC))
- and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
+ and then DT_Entry_Count (First_Tag_Component (Typ)) = No_Uint
then
- Set_Is_Tag (Tag_Component (Typ), False);
+ Set_Is_Tag (First_Tag_Component (Typ), False);
Set_Is_Tag (DTC, True);
Set_DT_Entry_Count (DTC, No_Uint);
end if;
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Package_Declaration);
return Flag15 (N);
end Box_Present;
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
return Node2 (N);
end Default_Name;
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
- return Flag11 (N);
+ return Flag7 (N);
end Exception_Junk;
function Expansion_Delayed
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
return Flag16 (N);
end Implicit_With;
+ function Interface_List
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_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_Task_Type_Declaration);
+ return List2 (N);
+ end Interface_List;
+
+ function Interface_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag16 (N);
+ end Interface_Present;
+
function In_Present
(N : Node_Id) return Boolean is
begin
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Subtype_Declaration);
- return Flag9 (N);
+ return Flag11 (N);
end Null_Exclusion_Present;
function Null_Record_Present
return Node4 (N);
end Object_Definition;
- function OK_For_Stream
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Flag4 (N);
- end OK_For_Stream;
-
function Original_Discriminant
(N : Node_Id) return Node_Id is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition);
- return Flag15 (N);
+ or else NT (N).Nkind = N_Access_Procedure_Definition
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag6 (N);
end Protected_Present;
function Raises_Constraint_Error
begin
pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
return Node1 (N);
end Specification;
return List2 (N);
end Subtype_Marks;
+ function Synchronized_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag7 (N);
+ end Synchronized_Present;
+
function Tagged_Present
(N : Node_Id) return Boolean is
begin
return Node2 (N);
end Target_Type;
- function Task_Body_Procedure
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return Node2 (N);
- end Task_Body_Procedure;
-
function Task_Definition
(N : Node_Id) return Node_Id is
begin
return Node3 (N);
end Task_Definition;
+ function Task_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ return Flag5 (N);
+ end Task_Present;
+
function Then_Actions
(N : Node_Id) return List_Id is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Package_Declaration);
Set_Flag15 (N, Val);
end Set_Box_Present;
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
Set_Node2_With_Parent (N, Val);
end Set_Default_Name;
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Flag11 (N, Val);
+ Set_Flag7 (N, Val);
end Set_Exception_Junk;
procedure Set_Expansion_Delayed
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
Set_Flag16 (N, Val);
end Set_Implicit_With;
+ procedure Set_Interface_List
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_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_Task_Type_Declaration);
+ Set_List2_With_Parent (N, Val);
+ end Set_Interface_List;
+
+ procedure Set_Interface_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag16 (N, Val);
+ end Set_Interface_Present;
+
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True) is
begin
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Flag9 (N, Val);
+ Set_Flag11 (N, Val);
end Set_Null_Exclusion_Present;
procedure Set_Null_Record_Present
Set_Node4_With_Parent (N, Val);
end Set_Object_Definition;
- procedure Set_OK_For_Stream
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Flag4 (N, Val);
- end Set_OK_For_Stream;
-
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id) is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition);
- Set_Flag15 (N, Val);
+ or else NT (N).Nkind = N_Access_Procedure_Definition
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag6 (N, Val);
end Set_Protected_Present;
procedure Set_Raises_Constraint_Error
begin
pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
+ or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
+ or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
Set_Node1_With_Parent (N, Val);
end Set_Specification;
Set_List2_With_Parent (N, Val);
end Set_Subtype_Marks;
+ procedure Set_Synchronized_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag7 (N, Val);
+ end Set_Synchronized_Present;
+
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True) is
begin
Set_Node2 (N, Val); -- semantic field, no parent set
end Set_Target_Type;
- procedure Set_Task_Body_Procedure
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Task_Body_Procedure;
-
procedure Set_Task_Definition
(N : Node_Id; Val : Node_Id) is
begin
Set_Node3_With_Parent (N, Val);
end Set_Task_Definition;
+ procedure Set_Task_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Record_Definition);
+ Set_Flag5 (N, Val);
+ end Set_Task_Present;
+
procedure Set_Then_Actions
(N : Node_Id; Val : List_Id) is
begin
-- Note: if the Is_Overloaded flag is set, then Etype points to
-- an essentially arbitrary choice from the possible set of types.
- -- Exception_Junk (Flag11-Sem)
+ -- Exception_Junk (Flag7-Sem)
-- This flag is set in a various nodes appearing in a statement
-- sequence to indicate that the corresponding node is an artifact
-- of the generated code for exception handling, and should be
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
- -- OK_For_Stream (Flag4-Sem)
- -- Present in N_Attribute_Definition clauses for stream attributes. If
- -- set, indicates that the attribute is permitted even though the type
- -- involved is a limited type. In the case of a protected type, the
- -- result is to stream all components (including discriminants) in
- -- lexical order. For other limited types, the effect is simply to
- -- use the corresponding stream routine for the full type. This flag
- -- is used for internally generated code, where the streaming of these
- -- types is required, even though not normally allowed by the language.
-
-- Original_Discriminant (Node2-Sem)
-- Present in identifiers. Used in references to discriminants that
-- appear in generic units. Because the names of the discriminants
-- be rounded to the nearest integer (breaking ties away from zero),
-- rather than truncated towards zero as usual. These rounded integer
-- operations are the result of expansion of rounded fixed-point
- -- divide, conersion and multiplication operations.
+ -- divide, conversion and multiplication operations.
-- Scope (Node3-Sem)
-- Present in defining identifiers, defining character literals and
-- target type entity for the unchecked conversion instantiation
-- which gigi must do size validation for.
- -- Task_Body_Procedure (Node2-Sem)
- -- Present in task type declaration nodes. Points to the entity for
- -- the task body procedure (as further described in Exp_Ch9, task
- -- bodies are expanded into procedures). A convenient function to
- -- retrieve this field is Sem_Util.Get_Task_Body_Procedure.
-
-- Then_Actions (List3-Sem)
-- This field is present in conditional expression nodes. During code
-- expansion we use the Insert_Actions procedure (in Exp_Util) to insert
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
- -- | DERIVED_TYPE_DEFINITION
+ -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
--------------------------------
-- 3.2.2 Subtype Declaration --
-- N_Subtype_Declaration
-- Sloc points to SUBTYPE
-- Defining_Identifier (Node1)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
- -- Exception_Junk (Flag11-Sem)
+ -- Exception_Junk (Flag7-Sem)
-------------------------------
-- 3.2.2 Subtype Indication --
-- Defining_Identifier (Node1)
-- Aliased_Present (Flag4) set if ALIASED appears
-- Constant_Present (Flag17) set if CONSTANT appears
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Object_Definition (Node4) subtype indication/array type definition
-- Expression (Node3) (set to Empty if not present)
-- Handler_List_Entry (Node2-Sem)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- No_Initialization (Flag13-Sem)
-- Assignment_OK (Flag15-Sem)
- -- Exception_Junk (Flag11-Sem)
+ -- Exception_Junk (Flag7-Sem)
-- Delay_Finalize_Attach (Flag14-Sem)
-- Is_Subprogram_Descriptor (Flag16-Sem)
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
- -- [RECORD_EXTENSION_PART]
+ -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- Note: ABSTRACT, record extension part not permitted in Ada 83 mode
-- N_Derived_Type_Definition
-- Sloc points to NEW
-- Abstract_Present (Flag4)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11) (set to False if not present)
-- Subtype_Indication (Node5)
-- Record_Extension_Part (Node3) (set to Empty if not present)
+ -- Limited_Present (Flag17) set in interfaces
+ -- Task_Present (Flag5) set in task interfaces
+ -- Protected_Present (Flag6) set in protected interfaces
+ -- Synchronized_Present (Flag7) set in interfaces
+ -- Interface_List (List2) (set to No_List if none)
+ -- Interface_Present (Flag16) set in abstract interfaces
+
+ -- Note: The attributes Limited_Present, Task_Present, Protected_Present
+ -- Synchronized_Present, Interface_List and Interface_Present are
+ -- used for abstract interfaces (see comment in the definition
+ -- of INTERFACE_TYPE_DEFINITION)
---------------------------
-- 3.5 Range Constraint --
-- N_Component_Definition
-- Sloc points to ALIASED, ACCESS or to first token of subtype mark
-- Aliased_Present (Flag4)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5) (set to Empty if not present)
-- Access_Definition (Node3) (set to Empty if not present)
-- N_Discriminant_Specification
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
- -- Discriminant_Type (Node5) subtype mark or
- -- access parameter definition
+ -- Null_Exclusion_Present (Flag11)
+ -- Discriminant_Type (Node5) subtype mark or access parameter definition
-- Expression (Node3) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- Limited_Present (Flag17)
-- Component_List (Node1) empty in null record case
-- Null_Present (Flag13) set in null record case
+ -- Task_Present (Flag5) set in task interfaces
+ -- Protected_Present (Flag6) set in protected interfaces
+ -- Synchronized_Present (Flag7) set in interfaces
+ -- Interface_Present (Flag16) set in abstract interfaces
+ -- Interface_List (List2) (set to No_List if none)
+
+ -- Note: The attributes Task_Present, Protected_Present, Synchronized
+ -- _Present, Interface_List and Interface_Present are
+ -- used for abstract interfaces (see comment in the definition
+ -- of INTERFACE_TYPE_DEFINITION)
-------------------------
-- 3.8 Component List --
-- Note: record extension parts are not permitted in Ada 83 mode
+ --------------------------------------
+ -- 3.9.4 Interface Type Definition --
+ --------------------------------------
+
+ -- INTERFACE_TYPE_DEFINITION ::=
+ -- [limited | task | protected | synchronized]
+ -- interface [interface_list]
+
+ -- Note: Interfaces are implemented with N_Record_Definition and
+ -- N_Derived_Type_Definition nodes because most of the support
+ -- for the analysis of abstract types has been reused to
+ -- analyze abstract interfaces.
+
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------
-- N_Access_To_Object_Definition
-- Sloc points to ACCESS
-- All_Present (Flag15)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5)
-- Constant_Present (Flag17)
-- N_Access_Function_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
- -- Protected_Present (Flag15)
+ -- Null_Exclusion_Present (Flag11)
+ -- Protected_Present (Flag6)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Subtype_Mark (Node4) result subtype
-- N_Access_Procedure_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
- -- Protected_Present (Flag15)
+ -- Null_Exclusion_Present (Flag11)
+ -- Protected_Present (Flag6)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-----------------------------
-- N_Access_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- All_Present (Flag15)
-- Constant_Present (Flag17)
-- Subtype_Mark (Node4)
-- i.e. digits, access, delta, range, the Attribute_Name field contains
-- the corresponding name, even though no identifier is involved.
- -- The flag OK_For_Stream is used in generated code to indicate that
- -- a stream attribute is permissible for a limited type, and results
- -- in the use of the stream attribute for the underlying full type,
- -- or in the case of a protected type, the components (including any
- -- disriminants) are merely streamed in order.
+ -- Note: the generated code may contain stream attributes applied to
+ -- limited types for which no stream routines exist officially. In such
+ -- case, the result is to use the stream attribute for the underlying
+ -- full type, or in the case of a protected type, the components
+ -- (including any disriminants) are merely streamed in order.
-- See Exp_Attr for a complete description of which attributes are
-- passed onto Gigi, and which are handled entirely by the front end.
-- Associated_Node (Node4-Sem)
-- Do_Overflow_Check (Flag17-Sem)
-- Redundant_Use (Flag13-Sem)
- -- OK_For_Stream (Flag4-Sem)
-- Must_Be_Byte_Aligned (Flag14)
-- plus fields for expression
-- N_Allocator
-- Sloc points to NEW
-- Expression (Node3) subtype indication or qualified expression
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Storage_Pool (Node1-Sem)
-- Procedure_To_Call (Node4-Sem)
-- No_Initialization (Flag13-Sem)
-- N_Label
-- Sloc points to <<
-- Identifier (Node1) direct name of statement identifier
- -- Exception_Junk (Flag11-Sem)
+ -- Exception_Junk (Flag7-Sem)
-------------------------------
-- 5.1 Statement Identifier --
-- N_Goto_Statement
-- Sloc points to GOTO
-- Name (Node2)
- -- Exception_Junk (Flag11-Sem)
+ -- Exception_Junk (Flag7-Sem)
---------------------------------
-- 6.1 Subprogram Declaration --
-- Defining_Identifier (Node1)
-- In_Present (Flag15)
-- Out_Present (Flag17)
- -- Null_Exclusion_Present (Flag9) (set to False if not present)
+ -- Null_Exclusion_Present (Flag11)
-- Parameter_Type (Node2) subtype mark or access definition
-- Expression (Node3) (set to Empty if no default expression present)
-- Do_Accessibility_Check (Flag13-Sem)
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
+ -- [abstract] new ancestor_SUBTYPE_INDICATION
+ -- [and INTERFACE_LIST] with private;
-- Note: private extension declarations are not allowed in Ada 83 mode
-- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
-- Abstract_Present (Flag4)
-- Subtype_Indication (Node5)
+ -- Interface_List (List2) (set to No_List if none)
---------------------
-- 8.4 Use Clause --
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- [is TASK_DEFINITITION];
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITITION];
-- N_Task_Type_Declaration
-- Sloc points to TASK
-- Defining_Identifier (Node1)
- -- Task_Body_Procedure (Node2-Sem)
-- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part)
+ -- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
-- Corresponding_Body (Node5-Sem)
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- is PROTECTED_DEFINITION;
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: protected type declarations are not permitted in Ada 83 mode
-- Defining_Identifier (Node1)
-- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part)
+ -- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
-- Corresponding_Body (Node5-Sem)
-- RAISE_STATEMENT ::= raise [exception_NAME];
+ -- In Ada 2005, we have
+
+ -- RAISE_STATEMENT ::= raise; | raise exception_NAME [with EXPRESSION];
+
-- N_Raise_Statement
-- Sloc points to RAISE
-- Name (Node2) (set to Empty if no exception name present)
+ -- Expression (Node3) (set to Empty if no expression present)
-------------------------------
-- 12.1 Generic Declaration --
-- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
-- | FORMAL_ARRAY_TYPE_DEFINITION
-- | FORMAL_ACCESS_TYPE_DEFINITION
+ -- | FORMAL_INTERFACE_TYPE_DEFINITION
---------------------------------------------
-- 12.5.1 Formal Private Type Definition --
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new SUBTYPE_MARK [with private]
-
+ -- [abstract] new SUBTYPE_MARK [[and INTERFACE_LIST] with private]
-- Note: this construct is not allowed in Ada 83 mode
-- N_Formal_Derived_Type_Definition
-- Subtype_Mark (Node4)
-- Private_Present (Flag15)
-- Abstract_Present (Flag4)
+ -- Interface_List (List2) (set to No_List if none)
---------------------------------------------
-- 12.5.2 Formal Discrete Type Definition --
-- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+ ----------------------------------------------
+ -- 12.5.5 Formal Interface Type Definition --
+ ----------------------------------------------
+
+ -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION
+
-----------------------------------------
-- 12.6 Formal Subprogram Declaration --
-----------------------------------------
N_Unused_At_Start,
-- N_Representation_Clause
+
N_At_Clause,
N_Component_Clause,
N_Enumeration_Representation_Clause,
N_Record_Representation_Clause,
-- N_Representation_Clause, N_Has_Chars
+
N_Attribute_Definition_Clause,
-- N_Has_Chars
+
N_Empty,
N_Pragma,
N_Pragma_Argument_Association,
-- N_Has_Etype
+
N_Error,
-- N_Entity, N_Has_Etype, N_Has_Chars
+
N_Defining_Character_Literal,
N_Defining_Identifier,
N_Defining_Operator_Symbol,
-- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity
+
N_Expanded_Name,
-- N_Direct_Name, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
+
N_Identifier,
N_Operator_Symbol,
-- N_Direct_Name, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
+
N_Character_Literal,
-- N_Binary_Op, N_Op, N_Subexpr,
-- N_Has_Etype, N_Has_Chars, N_Has_Entity
+
N_Op_Add,
N_Op_Concat,
N_Op_Expon,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean
+
N_Op_And,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
- -- N_Has_Entity, N_Has_Chars, N_Op_Boolean,
- -- N_Op_Compare
+ -- N_Has_Entity, N_Has_Chars, N_Op_Boolean, N_Op_Compare
+
N_Op_Eq,
N_Op_Ge,
N_Op_Gt,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean
+
N_Op_Or,
N_Op_Xor,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype,
-- N_Op_Shift, N_Has_Chars, N_Has_Entity
+
N_Op_Rotate_Left,
N_Op_Rotate_Right,
N_Op_Shift_Left,
-- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
+
N_Op_Abs,
N_Op_Minus,
N_Op_Not,
N_Op_Plus,
-- N_Subexpr, N_Has_Etype, N_Has_Entity
+
N_Attribute_Reference,
-- N_Subexpr, N_Has_Etype
+
N_And_Then,
N_Conditional_Expression,
N_Explicit_Dereference,
N_Unchecked_Type_Conversion,
-- N_Has_Etype
+
N_Subtype_Indication,
-- N_Declaration
+
N_Component_Declaration,
N_Entry_Declaration,
N_Formal_Object_Declaration,
N_Subtype_Declaration,
-- N_Subprogram_Specification, N_Declaration
+
N_Function_Specification,
N_Procedure_Specification,
- -- (nothing special)
- N_Entry_Index_Specification,
- N_Freeze_Entity,
-
-- N_Access_To_Subprogram_Definition
+
N_Access_Function_Definition,
N_Access_Procedure_Definition,
- -- N_Later_Decl_Item,
+ -- N_Later_Decl_Item
+
N_Task_Type_Declaration,
-- N_Body_Stub, N_Later_Decl_Item
+
N_Package_Body_Stub,
N_Protected_Body_Stub,
N_Subprogram_Body_Stub,
N_Task_Body_Stub,
-- N_Generic_Instantiation, N_Later_Decl_Item
+
N_Function_Instantiation,
N_Package_Instantiation,
N_Procedure_Instantiation,
-- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body
+
N_Package_Body,
N_Subprogram_Body,
-- N_Later_Decl_Item, N_Proper_Body
+
N_Protected_Body,
N_Task_Body,
-- N_Later_Decl_Item
+
N_Implicit_Label_Declaration,
N_Package_Declaration,
N_Single_Task_Declaration,
N_Use_Package_Clause,
-- N_Generic_Declaration, N_Later_Decl_Item
+
N_Generic_Package_Declaration,
N_Generic_Subprogram_Declaration,
-- N_Array_Type_Definition
+
N_Constrained_Array_Definition,
N_Unconstrained_Array_Definition,
-- N_Renaming_Declaration
+
N_Exception_Renaming_Declaration,
N_Object_Renaming_Declaration,
N_Package_Renaming_Declaration,
N_Subprogram_Renaming_Declaration,
-- N_Generic_Renaming_Declarations, N_Renaming_Declaration
+
N_Generic_Function_Renaming_Declaration,
N_Generic_Package_Renaming_Declaration,
N_Generic_Procedure_Renaming_Declaration,
-- N_Statement_Other_Than_Procedure_Call
+
N_Abort_Statement,
N_Accept_Statement,
N_Assignment_Statement,
N_Timed_Entry_Call,
-- N_Statement_Other_Than_Procedure_Call, N_Has_Condition
+
N_Exit_Statement,
N_If_Statement,
-- N_Has_Condition
+
N_Accept_Alternative,
N_Delay_Alternative,
N_Elsif_Part,
N_Iteration_Scheme,
N_Terminate_Alternative,
+ -- N_Formal_Subprogram_Declaration
+
+ N_Formal_Abstract_Subprogram_Declaration,
+ N_Formal_Concrete_Subprogram_Declaration,
+
-- Other nodes (not part of any subtype class)
+
N_Abortable_Part,
N_Abstract_Subprogram_Declaration,
N_Access_Definition,
N_Enumeration_Type_Definition,
N_Entry_Body,
N_Entry_Call_Alternative,
+ N_Entry_Index_Specification,
N_Exception_Declaration,
N_Exception_Handler,
N_Floating_Point_Definition,
- N_Formal_Abstract_Subprogram_Declaration,
- N_Formal_Concrete_Subprogram_Declaration,
N_Formal_Decimal_Fixed_Point_Definition,
N_Formal_Derived_Type_Definition,
N_Formal_Discrete_Type_Definition,
N_Formal_Package_Declaration,
N_Formal_Private_Type_Definition,
N_Formal_Signed_Integer_Type_Definition,
+ N_Freeze_Entity,
N_Generic_Association,
N_Handled_Sequence_Of_Statements,
N_Index_Or_Discriminant_Constraint,
(N : Node_Id) return List_Id; -- List5
function Exception_Junk
- (N : Node_Id) return Boolean; -- Flag11
+ (N : Node_Id) return Boolean; -- Flag7
function Explicit_Actual_Parameter
(N : Node_Id) return Node_Id; -- Node3
function Identifier
(N : Node_Id) return Node_Id; -- Node1
+ function Interface_List
+ (N : Node_Id) return List_Id; -- List2
+
+ function Interface_Present
+ (N : Node_Id) return Boolean; -- Flag16
+
function Implicit_With
(N : Node_Id) return Boolean; -- Flag16
(N : Node_Id) return Boolean; -- Flag13
function Null_Exclusion_Present
- (N : Node_Id) return Boolean; -- Flag9
+ (N : Node_Id) return Boolean; -- Flag11
function Null_Record_Present
(N : Node_Id) return Boolean; -- Flag17
function Object_Definition
(N : Node_Id) return Node_Id; -- Node4
- function OK_For_Stream
- (N : Node_Id) return Boolean; -- Flag4
-
function Original_Discriminant
(N : Node_Id) return Node_Id; -- Node2
(N : Node_Id) return Node_Id; -- Node3
function Protected_Present
- (N : Node_Id) return Boolean; -- Flag15
+ (N : Node_Id) return Boolean; -- Flag6
function Raises_Constraint_Error
(N : Node_Id) return Boolean; -- Flag7
function Subtype_Marks
(N : Node_Id) return List_Id; -- List2
+ function Synchronized_Present
+ (N : Node_Id) return Boolean; -- Flag7
+
function Tagged_Present
(N : Node_Id) return Boolean; -- Flag15
function Target_Type
(N : Node_Id) return Entity_Id; -- Node2
- function Task_Body_Procedure
- (N : Node_Id) return Entity_Id; -- Node2
-
function Task_Definition
(N : Node_Id) return Node_Id; -- Node3
+ function Task_Present
+ (N : Node_Id) return Boolean; -- Flag5
+
function Then_Actions
(N : Node_Id) return List_Id; -- List2
(N : Node_Id; Val : List_Id); -- List5
procedure Set_Exception_Junk
- (N : Node_Id; Val : Boolean := True); -- Flag11
+ (N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Expansion_Delayed
(N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Identifier
(N : Node_Id; Val : Node_Id); -- Node1
+ procedure Set_Interface_List
+ (N : Node_Id; Val : List_Id); -- List2
+
+ procedure Set_Interface_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag16
+
procedure Set_Implicit_With
(N : Node_Id; Val : Boolean := True); -- Flag16
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Null_Exclusion_Present
- (N : Node_Id; Val : Boolean := True); -- Flag9
+ (N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Null_Record_Present
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Object_Definition
(N : Node_Id; Val : Node_Id); -- Node4
- procedure Set_OK_For_Stream
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id); -- Node2
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Protected_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
+ (N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Raises_Constraint_Error
(N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Subtype_Marks
(N : Node_Id; Val : List_Id); -- List2
+ procedure Set_Synchronized_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag7
+
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id); -- Node2
- procedure Set_Task_Body_Procedure
- (N : Node_Id; Val : Entity_Id); -- Node2
-
procedure Set_Task_Definition
(N : Node_Id; Val : Node_Id); -- Node3
+ procedure Set_Task_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
procedure Set_Then_Actions
(N : Node_Id; Val : List_Id); -- List2
pragma Inline (High_Bound);
pragma Inline (Identifier);
pragma Inline (Implicit_With);
+ pragma Inline (Interface_List);
+ pragma Inline (Interface_Present);
pragma Inline (Includes_Infinities);
pragma Inline (In_Present);
pragma Inline (Instance_Spec);
pragma Inline (Null_Exclusion_Present);
pragma Inline (Null_Record_Present);
pragma Inline (Object_Definition);
- pragma Inline (OK_For_Stream);
pragma Inline (Original_Discriminant);
pragma Inline (Original_Entity);
pragma Inline (Others_Discrete_Choices);
pragma Inline (Subtype_Indication);
pragma Inline (Subtype_Mark);
pragma Inline (Subtype_Marks);
+ pragma Inline (Synchronized_Present);
pragma Inline (Tagged_Present);
pragma Inline (Target_Type);
- pragma Inline (Task_Body_Procedure);
pragma Inline (Task_Definition);
+ pragma Inline (Task_Present);
pragma Inline (Then_Actions);
pragma Inline (Then_Statements);
pragma Inline (Triggering_Alternative);
pragma Inline (Set_Identifier);
pragma Inline (Set_Implicit_With);
pragma Inline (Set_Includes_Infinities);
+ pragma Inline (Set_Interface_List);
+ pragma Inline (Set_Interface_Present);
pragma Inline (Set_In_Present);
pragma Inline (Set_Instance_Spec);
pragma Inline (Set_Intval);
pragma Inline (Set_Null_Exclusion_Present);
pragma Inline (Set_Null_Record_Present);
pragma Inline (Set_Object_Definition);
- pragma Inline (Set_OK_For_Stream);
pragma Inline (Set_Original_Discriminant);
pragma Inline (Set_Original_Entity);
pragma Inline (Set_Others_Discrete_Choices);
pragma Inline (Set_Subtype_Indication);
pragma Inline (Set_Subtype_Mark);
pragma Inline (Set_Subtype_Marks);
+ pragma Inline (Set_Synchronized_Present);
pragma Inline (Set_Tagged_Present);
pragma Inline (Set_Target_Type);
- pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Task_Definition);
+ pragma Inline (Set_Task_Present);
pragma Inline (Set_Then_Actions);
pragma Inline (Set_Then_Statements);
pragma Inline (Set_Triggering_Alternative);
-- --
-- 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- --
with Atree; use Atree;
with Einfo; use Einfo;
+with Elists; use Elists;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
return
Unchecked_Convert_To (
- New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
+ New_Occurrence_Of
+ (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
Make_Selected_Component (Loc,
Prefix => New_Copy (Rec),
Selector_Name =>
- New_Reference_To (Tag_Component (Full_Type), Loc)));
+ New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
-----------------------
function Make_DT_Component
(Loc : Source_Ptr;
Typ : Entity_Id;
- I : Positive) return Node_Id
+ N : Positive) return Node_Id
is
- X : Node_Id;
+ X : Node_Id;
Full_Type : Entity_Id := Typ;
begin
Full_Type := Underlying_Type (Typ);
end if;
- X := First_Component (
- Designated_Type (Etype (Access_Disp_Table (Full_Type))));
+ X :=
+ First_Component
+ (Designated_Type
+ (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type))))));
- for J in 2 .. I loop
+ for J in 2 .. N loop
X := Next_Component (X);
end loop;
is
begin
Check_Restriction (No_Implicit_Conditionals, Node);
+
return Make_If_Statement (Sloc (Node),
Condition,
Then_Statements,
is
N : constant Node_Id :=
Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
-
begin
Set_Label_Construct (N, Label_Construct);
return N;
projects / platform / upstream / linaro-gcc.git / commitdiff