+2016-05-02 Tristan Gingold <gingold@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected
+ to check for the no local protected objects restriction.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Anonymous_Master now uses Node35.
+ (Anonymous_Master): Update the assertion and node reference.
+ (Set_Anonymous_Master): Update the assertion and node reference.
+ (Write_Field35_Name): Add output for Anonymous_Master.
+ (Write_Field36_Name): The output is now undefined.
+ * einfo.ads Update the node and description of attribute
+ Anonymous_Master. Remove prior occurrences in entities as this
+ is now a type attribute.
+ * exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable
+ Ins_Node. Anonymous access- to-controlled component types no
+ longer need finalization masters. The master is now built when
+ a related allocator is expanded.
+ (Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not
+ detect whether the record type has at least one component of anonymous
+ access-to- controlled type. These types no longer need finalization
+ masters. The master is now built when a related allocator is expanded.
+ * exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8.
+ (Current_Anonymous_Master): Removed.
+ (Expand_N_Allocator): Call Build_Anonymous_Master to create a
+ finalization master for an anonymous access-to-controlled type.
+ * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
+ Call routine Build_Anonymous_Master to create a finalization master
+ for an anonymous access-to-controlled type.
+ * exp_ch7.adb (Allows_Finalization_Master): New routine.
+ (Build_Anonymous_Master): New routine.
+ (Build_Finalization_Master): Remove formal parameter
+ For_Anonymous. Use Allows_Finalization_Master to determine whether
+ circumstances warrant a finalization master. This routine no
+ longer creates masters for anonymous access-to-controlled types.
+ (In_Deallocation_Instance): Removed.
+ * exp_ch7.ads (Build_Anonymous_Master): New routine.
+ (Build_Finalization_Master): Remove formal parameter For_Anonymous
+ and update the comment on usage.
+ * sem_util.adb (Get_Qualified_Name): New routines.
+ (Output_Name): Reimplemented.
+ (Output_Scope): Removed.
+ * sem_util.ads (Get_Qualified_Name): New routines.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * debug.adb: Document the use of switch -gnatd.H.
+ * gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when
+ -gnatd.H is present.
+ (Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active.
+ * opt.ads: Add new option ASIS_GNSA_Mode.
+ * sem_ch13.adb (Alignment_Error): New routine.
+ (Analyze_Attribute_Definition_Clause): Suppress certain errors in
+ ASIS mode for attribute clause Alignment, Machine_Radix, Size, and
+ Stream_Size.
+ (Check_Size): Use routine Size_Too_Small_Error to
+ suppress certain errors in ASIS mode.
+ (Get_Alignment_Value): Use routine Alignment_Error to suppress certain
+ errors in ASIS mode.
+ (Size_Too_Small_Error): New routine.
+
2016-05-02 Arnaud Charlet <charlet@adacore.com>
* spark_xrefs.ads Description of the spark cross-references
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G Ignore calls through generic formal parameters for elaboration
- -- d.H
+ -- d.H GNSA mode for ASIS
-- d.I Do not ignore enum representation clauses in CodePeer mode
-- d.J Disable parallel SCIL generation mode
-- d.K
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
+ -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
+ -- the call to gigi in ASIS_Mode.
+
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some
-- Contract Node34
+ -- Anonymous_Master Node35
-- Import_Pragma Node35
- -- Anonymous_Master Node36
-
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
function Anonymous_Master (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
- return Node36 (Id);
+ pragma Assert (Is_Type (Id));
+ return Node35 (Id);
end Anonymous_Master;
function Anonymous_Object (Id : E) return E is
procedure Set_Anonymous_Master (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
- Set_Node36 (Id, V);
+ pragma Assert (Is_Type (Id));
+ Set_Node35 (Id, V);
end Set_Anonymous_Master;
procedure Set_Anonymous_Object (Id : E; V : E) is
procedure Write_Field35_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when Type_Kind =>
+ Write_Str ("Anonymous_Master");
+
when Subprogram_Kind =>
Write_Str ("Import_Pragma");
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
+ pragma Unreferenced (Id);
begin
- case Ekind (Id) is
- when E_Function |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Subprogram_Body =>
- Write_Str ("Anonymous_Master");
-
- when others =>
- Write_Str ("Field36??");
- end case;
+ Write_Str ("Field36??");
end Write_Field36_Name;
------------------------
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
--- Anonymous_Master (Node36)
--- Defined in the entities of non-generic packages, subprograms and their
--- corresponding bodies. Contains the entity of a special heterogeneous
--- finalization master that services most anonymous access-to-controlled
--- allocations that occur within the unit.
+-- Anonymous_Master (Node35)
+-- Defined in all types. Contains the entity of an anonymous finalization
+-- master which services all anonymous access types associated with the
+-- same designated type within the current semantic unit. The attribute
+-- is set reactively during the expansion of allocators.
-- Anonymous_Object (Node30)
-- Present in protected and task type entities. Contains the entity of
-- Derived_Type_Link (Node31)
-- No_Tagged_Streams_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
+ -- Anonymous_Master (Node35)
-- Depends_On_Private (Flag14)
-- Disable_Controlled (Flag253)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
- -- Last_Entity (Node20)
-- Non_Limited_View (Node19)
+ -- Last_Entity (Node20)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
-- Current_Use_Clause (Node27)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36) (non-generic case only)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Delay_Subprogram_Descriptors (Flag50)
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
-- Scope_Depth_Value (Uint22)
-- Extra_Formals (Node28)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- SPARK_Pragma_Inherited (Flag265)
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- Ins_Node : Node_Id;
-
begin
-- Ensure that all freezing activities are properly flagged as Ghost
end if;
end if;
- if Typ = Base then
- if Has_Controlled_Component (Base) then
- Build_Controlling_Procs (Base);
-
- if not Is_Limited_Type (Comp_Typ)
- and then Number_Dimensions (Typ) = 1
- then
- Build_Slice_Assignment (Typ);
- end if;
- end if;
-
- -- Create a finalization master to service the anonymous access
- -- components of the array.
+ if Typ = Base and then Has_Controlled_Component (Base) then
+ Build_Controlling_Procs (Base);
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
+ if not Is_Limited_Type (Comp_Typ)
+ and then Number_Dimensions (Typ) = 1
then
- -- The finalization master is inserted before the declaration
- -- of the array type. The only exception to this is when the
- -- array type is an itype, in which case the master appears
- -- before the related context.
-
- if Is_Itype (Typ) then
- Ins_Node := Associated_Node_For_Itype (Typ);
- else
- Ins_Node := Parent (Typ);
- end if;
-
- Build_Finalization_Master
- (Typ => Comp_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Typ),
- Insertion_Node => Ins_Node);
+ Build_Slice_Assignment (Typ);
end if;
end if;
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data),
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
-- If either of the restrictions No_Exceptions_Handlers/Propagation is
-- active then return -1 (we cannot usefully raise Constraint_Error in
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
end if;
-- Now we can build the function body
Comp : Entity_Id;
Comp_Typ : Entity_Id;
- Has_AACC : Boolean;
Predef_List : List_Id;
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
+
Renamed_Eq : Node_Id := Empty;
-- Defining unit name for the predefined equality function in the case
-- where the type has a primitive operation that is a renaming of
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Wrapper_Decl_List : List_Id := No_List;
- Wrapper_Body_List : List_Id := No_List;
-
-- Start of processing for Expand_Freeze_Record_Type
begin
-- of the component types may have been private at the point of the
-- record declaration. Detect anonymous access-to-controlled components.
- Has_AACC := False;
-
Comp := First_Component (Typ);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
Set_Has_Controlled_Component (Typ);
end if;
- -- Non-self-referential anonymous access-to-controlled component
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- Has_AACC := True;
- end if;
-
Next_Component (Comp);
end loop;
end;
end if;
- -- Create a heterogeneous finalization master to service the anonymous
- -- access-to-controlled components of the record type.
-
- if Has_AACC then
- declare
- Encl_Scope : constant Entity_Id := Scope (Typ);
- Ins_Node : constant Node_Id := Parent (Typ);
- Loc : constant Source_Ptr := Sloc (Typ);
- Fin_Mas_Id : Entity_Id;
-
- Attributes_Set : Boolean := False;
- Master_Built : Boolean := False;
- -- Two flags which control the creation and initialization of a
- -- common heterogeneous master.
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
-
- -- A non-self-referential anonymous access-to-controlled
- -- component.
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- -- Build a homogeneous master for the first anonymous
- -- access-to-controlled component. This master may be
- -- converted into a heterogeneous collection if more
- -- components are to follow.
-
- if not Master_Built then
- Master_Built := True;
-
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- Build_Finalization_Master
- (Typ => Root_Type (Comp_Typ),
- For_Anonymous => True,
- Context_Scope => Encl_Scope,
- Insertion_Node => Ins_Node);
-
- Fin_Mas_Id := Finalization_Master (Comp_Typ);
-
- -- Subsequent anonymous access-to-controlled components
- -- reuse the available master.
-
- else
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that both the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- -- Shared the master among multiple components
-
- Set_Finalization_Master
- (Root_Type (Comp_Typ), Fin_Mas_Id);
-
- -- Convert the master into a heterogeneous collection.
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
-
- if not Attributes_Set then
- Attributes_Set := True;
-
- Insert_Action (Ins_Node,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc))));
- end if;
- end if;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
-- Check whether individual components have a defined invariant, and add
-- the corresponding component invariant checks.
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
-with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
- function Current_Anonymous_Master return Entity_Id;
- -- Return the entity of the heterogeneous finalization master belonging to
- -- the current unit (either function, package or procedure). This master
- -- services all anonymous access-to-controlled types. If the current unit
- -- does not have such master, create one.
-
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
-- Expand_Allocator_Expression. Allocating class-wide interface objects
return;
end Build_Boolean_Array_Proc_Call;
- ------------------------------
- -- Current_Anonymous_Master --
- ------------------------------
-
- function Current_Anonymous_Master return Entity_Id is
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id;
- -- Create a new anonymous master for a compilation unit denoted by its
- -- entity Unit_Id and declaration Unit_Decl. The declaration of the new
- -- master along with any specialized initialization is inserted at the
- -- top of the unit's declarations (see body for special cases). Return
- -- the entity of the anonymous master.
-
- -----------------------------
- -- Create_Anonymous_Master --
- -----------------------------
-
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id
- is
- Insert_Nod : Node_Id := Empty;
- -- The point of insertion into the declarative list of the unit. All
- -- nodes are inserted before Insert_Nod.
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id);
- -- Insert arbitrary node N in declarative list Decls and analyze it
-
- ------------------------
- -- Insert_And_Analyze --
- ------------------------
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is
- begin
- -- The declarative list is already populated, the nodes are
- -- inserted at the top of the list, preserving their order.
-
- if Present (Insert_Nod) then
- Insert_Before (Insert_Nod, N);
-
- -- Otherwise append to the declarations to preserve order
-
- else
- Append_To (Decls, N);
- end if;
-
- Analyze (N);
- end Insert_And_Analyze;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Unit_Id);
- Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
- Decls : List_Id;
- FM_Id : Entity_Id;
- Pref : Character;
- Unit_Spec : Node_Id;
-
- -- Start of processing for Create_Anonymous_Master
-
- begin
- -- Find the declarative list of the unit
-
- if Nkind (Unit_Decl) = N_Package_Declaration then
- Unit_Spec := Specification (Unit_Decl);
- Decls := Visible_Declarations (Unit_Spec);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Visible_Declarations (Unit_Spec, Decls);
- end if;
-
- -- Package or subprogram body
-
- -- ??? A subprogram declaration that acts as a compilation unit may
- -- contain a formal parameter of an anonymous access-to-controlled
- -- type initialized by an allocator.
-
- -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-
- -- There is no suitable place to create the anonymous master as the
- -- subprogram is not in a declarative list.
-
- else
- Decls := Declarations (Unit_Decl);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (Unit_Decl, Decls);
- end if;
- end if;
-
- -- The anonymous master and all initialization actions are inserted
- -- before the first declaration (if any).
-
- Insert_Nod := First (Decls);
-
- -- Since the anonymous master and all its initialization actions are
- -- inserted at top level, use the scope of the unit when analyzing.
-
- Push_Scope (Spec_Id);
-
- -- Step 1: Anonymous master creation
-
- -- Use a unique prefix in case the same unit requires two anonymous
- -- masters, one for the spec (S) and one for the body (B).
-
- if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
- Pref := 'S';
- else
- Pref := 'B';
- end if;
-
- FM_Id :=
- Make_Defining_Identifier (Loc,
- New_External_Name
- (Related_Id => Chars (Unit_Id),
- Suffix => "AM",
- Prefix => Pref));
-
- Set_Anonymous_Master (Unit_Id, FM_Id);
-
- -- Generate:
- -- <FM_Id> : Finalization_Master;
-
- Insert_And_Analyze (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => FM_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
-
- -- Step 2: Initialization actions
-
- -- Generate:
- -- Set_Base_Pool
- -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
- Attribute_Name => Name_Unrestricted_Access))));
-
- -- Generate:
- -- Set_Is_Heterogeneous (<FM_Id>);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc))));
-
- Pop_Scope;
- return FM_Id;
- end Create_Anonymous_Master;
-
- -- Local declarations
-
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
-
- -- Start of processing for Current_Anonymous_Master
-
- begin
- Unit_Decl := Unit (Cunit (Current_Sem_Unit));
- Unit_Id := Defining_Entity (Unit_Decl);
-
- -- The compilation unit is a package instantiation. In this case the
- -- anonymous master is associated with the package spec as both the
- -- spec and body appear at the same level.
-
- if Nkind (Unit_Decl) = N_Package_Body
- and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
- then
- Unit_Id := Corresponding_Spec (Unit_Decl);
- Unit_Decl := Unit_Declaration_Node (Unit_Id);
- end if;
-
- if Present (Anonymous_Master (Unit_Id)) then
- return Anonymous_Master (Unit_Id);
-
- -- Create a new anonymous master when allocating an object of anonymous
- -- access-to-controlled type for the first time.
-
- else
- return Create_Anonymous_Master (Unit_Id, Unit_Decl);
- end if;
- end Current_Anonymous_Master;
-
--------------------------------
-- Displace_Allocator_Pointer --
--------------------------------
Set_Finalization_Master
(Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
- Set_Finalization_Master
- (Root_Type (PtrT), Current_Anonymous_Master);
+ Build_Anonymous_Master (Root_Type (PtrT));
end if;
end if;
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
then
- Build_Finalization_Master
- (Typ => Ptr_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Ptr_Typ),
- Insertion_Node => Associated_Node_For_Itype (Ptr_Typ));
+ Build_Anonymous_Master (Ptr_Typ);
end if;
-- Access-to-controlled types should always have a master
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
Finalize_Case => TSS_Deep_Finalize,
Address_Case => TSS_Finalize_Address);
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
+ -- Determine whether access type Typ may have a finalization master
+
procedure Build_Array_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
+ --------------------------------
+ -- Allows_Finalization_Master --
+ --------------------------------
+
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean;
+ -- Determine whether entity E is inside a wrapper package created for
+ -- an instance of Ada.Unchecked_Deallocation.
+
+ ------------------------------
+ -- In_Deallocation_Instance --
+ ------------------------------
+
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean is
+ Pkg : constant Entity_Id := Scope (E);
+ Par : Node_Id := Empty;
+
+ begin
+ if Ekind (Pkg) = E_Package
+ and then Present (Related_Instance (Pkg))
+ and then Ekind (Related_Instance (Pkg)) = E_Procedure
+ then
+ Par := Generic_Parent (Parent (Related_Instance (Pkg)));
+
+ return
+ Present (Par)
+ and then Chars (Par) = Name_Unchecked_Deallocation
+ and then Chars (Scope (Par)) = Name_Ada
+ and then Scope (Scope (Par)) = Standard_Standard;
+ end if;
+
+ return False;
+ end In_Deallocation_Instance;
+
+ -- Local variables
+
+ Desig_Typ : constant Entity_Id := Designated_Type (Typ);
+ Ptr_Typ : constant Entity_Id :=
+ Root_Type_Of_Full_View (Base_Type (Typ));
+
+ -- Start of processing for Allows_Finalization_Master
+
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types and therefore do not need masters.
+
+ if Restriction_Active (No_Finalization) then
+ return False;
+
+ -- Do not consider C and C++ types since it is assumed that the non-Ada
+ -- side will handle their clean up.
+
+ elsif Convention (Desig_Typ) = Convention_C
+ or else Convention (Desig_Typ) = Convention_CPP
+ then
+ return False;
+
+ -- Do not consider types that return on the secondary stack
+
+ elsif Present (Associated_Storage_Pool (Ptr_Typ))
+ and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
+ then
+ return False;
+
+ -- Do not consider types which may never allocate an object
+
+ elsif No_Pool_Assigned (Ptr_Typ) then
+ return False;
+
+ -- Do not consider access types coming from Ada.Unchecked_Deallocation
+ -- instances. Even though the designated type may be controlled, the
+ -- access type will never participate in allocation.
+
+ elsif In_Deallocation_Instance (Ptr_Typ) then
+ return False;
+
+ -- Do not consider non-library access types when restriction
+ -- No_Nested_Finalization is in effect since masters are controlled
+ -- objects.
+
+ elsif Restriction_Active (No_Nested_Finalization)
+ and then not Is_Library_Level_Entity (Ptr_Typ)
+ then
+ return False;
+
+ -- Do not create finalization masters in GNATprove mode because this
+ -- causes unwanted extra expansion. A compilation in this mode must
+ -- keep the tree as close as possible to the original sources.
+
+ elsif GNATprove_Mode then
+ return False;
+
+ -- Otherwise the access type may use a finalization master
+
+ else
+ return True;
+ end if;
+ end Allows_Finalization_Master;
+
+ ----------------------------
+ -- Build_Anonymous_Master --
+ ----------------------------
+
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id;
+ -- Create a new anonymous finalization master for access type Ptr_Typ
+ -- with designated type Desig_Typ. The declaration of the master along
+ -- with its specialized initialization is inserted in the declarative
+ -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl.
+
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N appears within the subtree rooted
+ -- at node Root.
+
+ -----------------------------
+ -- Create_Anonymous_Master --
+ -----------------------------
+
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Unit_Id);
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
+ Decls : List_Id;
+ FM_Decl : Node_Id;
+ FM_Id : Entity_Id;
+ FM_Init : Node_Id;
+ Pref : Character;
+ Unit_Spec : Node_Id;
+
+ begin
+ -- Find the declarative list of the unit
+
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Spec := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Spec);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Unit_Spec, Decls);
+ end if;
+
+ -- Package body or subprogram case
+
+ -- ??? A subprogram spec or body that acts as a compilation unit may
+ -- contain a formal parameter of an anonymous access-to-controlled
+ -- type initialized by an allocator.
+
+ -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
+
+ -- There is no suitable place to create the anonymous master as the
+ -- subprogram is not in a declarative list.
+
+ else
+ Decls := Declarations (Unit_Decl);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Unit_Decl, Decls);
+ end if;
+ end if;
+
+ -- Step 1: Anonymous master creation
+
+ -- Use a unique prefix in case the same unit requires two anonymous
+ -- masters, one for the spec (S) and one for the body (B).
+
+ if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
+ Pref := 'S';
+ else
+ Pref := 'B';
+ end if;
+
+ -- The name of the anonymous master has the following format:
+
+ -- [BS]scopN__scop1__chars_of_desig_typAM
+
+ -- The name utilizes the fully qualified name of the designated type
+ -- in case two controlled types with the same name are declared in
+ -- different scopes and both have anonymous access types.
+
+ FM_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name
+ (Related_Id => Get_Qualified_Name (Desig_Typ),
+ Suffix => "AM",
+ Prefix => Pref));
+
+ -- Associate the anonymous master with the designated type. This
+ -- ensures that any additional anonymous access types with the same
+ -- designated type will share the same anonymous paster within the
+ -- same unit.
+
+ Set_Anonymous_Master (Desig_Typ, FM_Id);
+
+ -- Generate:
+ -- <FM_Id> : Finalization_Master;
+
+ FM_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => FM_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
+
+ -- Step 2: Initialization actions
+
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
+
+ FM_Init :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (FM_Id, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ Prepend_To (Decls, FM_Init);
+ Prepend_To (Decls, FM_Decl);
+
+ -- Since the anonymous master and all its initialization actions are
+ -- inserted at top level, use the scope of the unit when analyzing.
+
+ Push_Scope (Spec_Id);
+ Analyze (FM_Decl);
+ Analyze (FM_Init);
+ Pop_Scope;
+
+ return FM_Id;
+ end Create_Anonymous_Master;
+
+ ----------------
+ -- In_Subtree --
+ ----------------
+
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Traverse the parent chain until reaching the same root
+
+ Par := N;
+ while Present (Par) loop
+ if Par = Root then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Subtree;
+
+ -- Local variables
+
+ Desig_Typ : Entity_Id;
+ FM_Id : Entity_Id;
+ Priv_View : Entity_Id;
+ Unit_Decl : Node_Id;
+ Unit_Id : Entity_Id;
+
+ -- Start of processing for Build_Anonymous_Master
+
+ begin
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
+
+ if not Allows_Finalization_Master (Ptr_Typ) then
+ return;
+ end if;
+
+ Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+ Unit_Id := Defining_Entity (Unit_Decl);
+
+ -- The compilation unit is a package instantiation. In this case the
+ -- anonymous master is associated with the package spec as both the
+ -- spec and body appear at the same level.
+
+ if Nkind (Unit_Decl) = N_Package_Body
+ and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
+ then
+ Unit_Id := Corresponding_Spec (Unit_Decl);
+ Unit_Decl := Unit_Declaration_Node (Unit_Id);
+ end if;
+
+ -- Use the initial declaration of the designated type when it denotes
+ -- the full view of an incomplete or private type. This ensures that
+ -- types with one and two views are treated the same.
+
+ Desig_Typ := Directly_Designated_Type (Ptr_Typ);
+ Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
+
+ if Present (Priv_View) then
+ Desig_Typ := Priv_View;
+ end if;
+
+ FM_Id := Anonymous_Master (Desig_Typ);
+
+ -- The designated type already has at least one anonymous access type
+ -- pointing to it within the current unit. Reuse the anonymous master
+ -- because the designated type is the same.
+
+ if Present (FM_Id)
+ and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl)
+ then
+ null;
+
+ -- Otherwise the designated type lacks an anonymous master or it is
+ -- declared in a different unit. Create a brand new master.
+
+ else
+ FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
+ end if;
+
+ Set_Finalization_Master (Ptr_Typ, FM_Id);
+ end Build_Anonymous_Master;
+
----------------------------
-- Build_Array_Deep_Procs --
----------------------------
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
Ptr_Typ : Entity_Id);
-- Add access type Ptr_Typ to the pending access type list for type Typ
- function In_Deallocation_Instance (E : Entity_Id) return Boolean;
- -- Determine whether entity E is inside a wrapper package created for
- -- an instance of Ada.Unchecked_Deallocation.
-
-----------------------------
-- Add_Pending_Access_Type --
-----------------------------
Prepend_Elmt (Ptr_Typ, List);
end Add_Pending_Access_Type;
- ------------------------------
- -- In_Deallocation_Instance --
- ------------------------------
-
- function In_Deallocation_Instance (E : Entity_Id) return Boolean is
- Pkg : constant Entity_Id := Scope (E);
- Par : Node_Id := Empty;
-
- begin
- if Ekind (Pkg) = E_Package
- and then Present (Related_Instance (Pkg))
- and then Ekind (Related_Instance (Pkg)) = E_Procedure
- then
- Par := Generic_Parent (Parent (Related_Instance (Pkg)));
-
- return
- Present (Par)
- and then Chars (Par) = Name_Unchecked_Deallocation
- and then Chars (Scope (Par)) = Name_Ada
- and then Scope (Scope (Par)) = Standard_Standard;
- end if;
-
- return False;
- end In_Deallocation_Instance;
-
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
-- Start of processing for Build_Finalization_Master
begin
- -- Certain run-time configurations and targets do not provide support
- -- for controlled types.
-
- if Restriction_Active (No_Finalization) then
- return;
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
- -- Do not process C, C++ types since it is assumed that the non-Ada side
- -- will handle their clean up.
-
- elsif Convention (Desig_Typ) = Convention_C
- or else Convention (Desig_Typ) = Convention_CPP
- then
+ if not Allows_Finalization_Master (Typ) then
return;
-- Various machinery such as freezing may have already created a
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-
- -- Do not process types that return on the secondary stack
-
- elsif Present (Associated_Storage_Pool (Ptr_Typ))
- and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
- then
- return;
-
- -- Do not process types which may never allocate an object
-
- elsif No_Pool_Assigned (Ptr_Typ) then
- return;
-
- -- Do not process access types coming from Ada.Unchecked_Deallocation
- -- instances. Even though the designated type may be controlled, the
- -- access type will never participate in allocation.
-
- elsif In_Deallocation_Instance (Ptr_Typ) then
- return;
-
- -- Ignore the general use of anonymous access types unless the context
- -- requires a finalization master.
-
- elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then not For_Anonymous
- then
- return;
-
- -- Do not process non-library access types when restriction No_Nested_
- -- Finalization is in effect since masters are controlled objects.
-
- elsif Restriction_Active (No_Nested_Finalization)
- and then not Is_Library_Level_Entity (Ptr_Typ)
- then
- return;
-
- -- Do not create finalization masters in GNATprove mode because this
- -- unwanted extra expansion. A compilation in this mode keeps the tree
- -- as close as possible to the original sources.
-
- elsif GNATprove_Mode then
- return;
end if;
declare
Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
- -- A finalization master created for an anonymous access type or an
- -- access designating a type with private components must be inserted
- -- before a context-dependent node.
+ -- A finalization master created for an access designating a type
+ -- with private components is inserted before a context-dependent
+ -- node.
- if For_Anonymous or For_Private then
+ if For_Private then
-- At this point both the scope of the context and the insertion
-- mode must be known.
end if;
end Check_Visibly_Controlled;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
-
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
-
------------------
-- Convert_View --
------------------
end if;
end Convert_View;
+ -------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
+
------------------------
-- Enclosing_Function --
------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- Finalization Management --
-----------------------------
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id);
+ -- Build a finalization master for an anonymous access-to-controlled type
+ -- denoted by Ptr_Typ. The master is inserted in the declarations of the
+ -- current unit.
+
procedure Build_Controlling_Procs (Typ : Entity_Id);
-- Typ is a record, and array type having controlled components.
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
Insertion_Node : Node_Id := Empty);
-- Build a finalization master for an access type. The designated type may
-- not necessarely be controlled or need finalization actions depending on
- -- the context. Flag For_Anonymous must be set when creating a master for
- -- an anonymous access type. Flag For_Lib_Level must be set when creating
- -- a master for a build-in-place function call access result type. Flag
- -- For_Private must be set when the designated type contains a private
- -- component. Parameters Context_Scope and Insertion_Node must be used in
- -- conjunction with flags For_Anonymous and For_Private. Context_Scope is
- -- the scope of the context where the finalization master must be analyzed.
- -- Insertion_Node is the insertion point before which the master is to be
- -- inserted.
+ -- the context. Flag For_Lib_Level must be set when creating a master for a
+ -- build-in-place function call access result type. Flag For_Private must
+ -- be set when the designated type contains a private component. Parameters
+ -- Context_Scope and Insertion_Node must be used in conjunction with flag
+ -- For_Private. Context_Scope is the scope of the context where the
+ -- finalization master must be analyzed. Insertion_Node is the insertion
+ -- point before which the master is to be inserted.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
if Operating_Mode = Check_Semantics and then Tree_Output then
ASIS_Mode := True;
+ -- Set ASIS GNSA mode if -gnatd.H is set
+
+ if Debug_Flag_Dot_HH then
+ ASIS_GNSA_Mode := True;
+ end if;
+
-- Turn off inlining in ASIS mode, since ASIS cannot handle the extra
-- information in the trees caused by inlining being active.
if GNATprove_Mode then
declare
Unused_E : constant Entity_Id :=
- Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
+ Rtsfind.RTE (Rtsfind.RE_Interrupt_Priority);
begin
null;
end;
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
- elsif Nkind_In (Main_Kind,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind_In (Main_Kind, N_Package_Declaration,
+ N_Subprogram_Declaration)
and then
(not Body_Required (Main_Unit_Node)
- or else
- Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+ or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
then
Back_End_Mode := Generate_Object;
if Back_End_Mode = Skip then
Set_Standard_Error;
- Write_Str ("cannot generate code for ");
- Write_Str ("file ");
+ Write_Str ("cannot generate code for file ");
Write_Name (Unit_File_Name (Main_Unit));
if Subunits_Missing then
-- Annotation is suppressed for targets where front-end layout is
-- enabled, because the front end determines representations.
+ -- The back-end is not invoked in ASIS mode with GNSA because all type
+ -- representation information will be provided by the GNSA back-end, not
+ -- gigi.
+
if Back_End_Mode = Declarations_Only
and then
(not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
or else Main_Kind = N_Subunit
- or else Frontend_Layout_On_Target)
+ or else Frontend_Layout_On_Target
+ or else ASIS_GNSA_Mode)
then
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);
-- Set to non-null when Bind_Alternate_Main_Name is True. This value
-- is modified as needed by Gnatbind.Scan_Bind_Arg.
+ ASIS_GNSA_Mode : Boolean := False;
+ -- GNAT
+ -- Enable GNSA back-end processing assuming ASIS_Mode is already set to
+ -- True. ASIS_GNSA mode suppresses the call to gigi.
+
ASIS_Mode : Boolean := False;
-- GNAT
-- Enable semantic checks and tree transformations that are important
elsif Is_Subprogram (U_Ent) then
if Has_Homonym (U_Ent) then
Error_Msg_N
- ("address clause cannot be given " &
- "for overloaded subprogram",
- Nam);
+ ("address clause cannot be given for overloaded "
+ & "subprogram", Nam);
return;
end if;
if Warn_On_Obsolescent_Feature then
Error_Msg_N
- ("?j?attaching interrupt to task entry is an " &
- "obsolescent feature (RM J.7.1)", N);
+ ("?j?attaching interrupt to task entry is an obsolescent "
+ & "feature (RM J.7.1)", N);
Error_Msg_N
("\?j?use interrupt procedure instead", N);
end if;
Set_Has_Alignment_Clause (U_Ent);
-- Tagged type case, check for attempt to set alignment to a
- -- value greater than Max_Align, and reset if so.
+ -- value greater than Max_Align, and reset if so. This error
+ -- is suppressed in ASIS mode to allow for different ASIS
+ -- back-ends or ASIS-based tools to query the illegal clause.
- if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
+ if Is_Tagged_Type (U_Ent)
+ and then Align > Max_Align
+ and then not ASIS_Mode
+ then
Error_Msg_N
("alignment for & set to Maximum_Aligment??", Nam);
- Set_Alignment (U_Ent, Max_Align);
+ Set_Alignment (U_Ent, Max_Align);
-- All other cases
end if;
Btype := Base_Type (U_Ent);
- Ctyp := Component_Type (Btype);
+ Ctyp := Component_Type (Btype);
if Duplicate_Clause then
null;
Error_Msg_NE
("??non-unique external tag supplied for &", N, U_Ent);
Error_Msg_N
- ("\??same external tag applies to all "
- & "subprogram calls", N);
+ ("\??same external tag applies to all subprogram calls",
+ N);
Error_Msg_N
("\??corresponding internal tag cannot be obtained", N);
end if;
if From_Aspect_Specification (N) then
if not Is_Concurrent_Type (U_Ent) then
Error_Msg_N
- ("Interrupt_Priority can only be defined for task "
- & "and protected object", Nam);
+ ("Interrupt_Priority can only be defined for task and "
+ & "protected object", Nam);
elsif Duplicate_Clause then
null;
if Radix = 2 then
null;
+
elsif Radix = 10 then
Set_Machine_Radix_10 (U_Ent);
- else
+
+ -- The following error is suppressed in ASIS mode to allow for
+ -- different ASIS back-ends or ASIS-based tools to query the
+ -- illegal clause.
+
+ elsif not ASIS_Mode then
Error_Msg_N ("machine radix value must be 2 or 10", Expr);
end if;
end if;
else
Check_Size (Expr, U_Ent, Size, Biased);
- if Is_Scalar_Type (U_Ent) then
+ -- The following errors are suppressed in ASIS mode to allow
+ -- for different ASIS back-ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if ASIS_Mode then
+ null;
+
+ elsif Is_Scalar_Type (U_Ent) then
if Size /= 8 and then Size /= 16 and then Size /= 32
and then UI_Mod (Size, 64) /= 0
then
begin
if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
Error_Msg_N
- ("Scalar_Storage_Order can only be defined for "
- & "record or array type", Nam);
+ ("Scalar_Storage_Order can only be defined for record or "
+ & "array type", Nam);
elsif Duplicate_Clause then
null;
Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
else
Error_Msg_N
- ("non-default Scalar_Storage_Order "
- & "not supported on target", Expr);
+ ("non-default Scalar_Storage_Order not supported on "
+ & "target", Expr);
end if;
end if;
-- For objects, set Esize only
else
- if Is_Elementary_Type (Etyp) then
- if Size /= System_Storage_Unit
- and then
- Size /= System_Storage_Unit * 2
- and then
- Size /= System_Storage_Unit * 4
- and then
- Size /= System_Storage_Unit * 8
- then
- Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
- Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
- Error_Msg_N
- ("size for primitive object must be a power of 2"
- & " in the range ^-^", N);
- end if;
+ -- The following error is suppressed in ASIS mode to allow
+ -- for different ASIS back-ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if Is_Elementary_Type (Etyp)
+ and then Size /= System_Storage_Unit
+ and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 4
+ and then Size /= System_Storage_Unit * 8
+ and then not ASIS_Mode
+ then
+ Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+ Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
+ Error_Msg_N
+ ("size for primitive object must be a power of 2 in "
+ & "the range ^-^", N);
end if;
Set_Esize (U_Ent, Size);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
- ("?j?storage size clause for task is an " &
- "obsolescent feature (RM J.9)", N);
+ ("?j?storage size clause for task is an obsolescent "
+ & "feature (RM J.9)", N);
Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
end if;
end if;
null;
elsif Is_Elementary_Type (U_Ent) then
- if Size /= System_Storage_Unit
- and then
- Size /= System_Storage_Unit * 2
- and then
- Size /= System_Storage_Unit * 4
- and then
- Size /= System_Storage_Unit * 8
+
+ -- The following errors are suppressed in ASIS mode to allow
+ -- for different ASIS back-ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if ASIS_Mode then
+ null;
+
+ elsif Size /= System_Storage_Unit
+ and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 4
+ and then Size /= System_Storage_Unit * 8
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_N
- ("stream size for elementary type must be a"
- & " power of 2 and at least ^", N);
+ ("stream size for elementary type must be a power of 2 "
+ & "and at least ^", N);
elsif RM_Size (U_Ent) > Size then
Error_Msg_Uint_1 := RM_Size (U_Ent);
Error_Msg_N
- ("stream size for elementary type must be a"
- & " power of 2 and at least ^", N);
+ ("stream size for elementary type must be a power of 2 "
+ & "and at least ^", N);
end if;
Set_Has_Stream_Size_Clause (U_Ent);
and then Lbit /= No_Uint
then
if Posit < 0 then
- Error_Msg_N
- ("position cannot be negative", Position (CC));
+ Error_Msg_N ("position cannot be negative", Position (CC));
elsif Fbit < 0 then
- Error_Msg_N
- ("first bit cannot be negative", First_Bit (CC));
+ Error_Msg_N ("first bit cannot be negative", First_Bit (CC));
-- The Last_Bit specified in a component clause must not be
-- less than the First_Bit minus one (RM-13.5.1(10)).
Intval (Last_Bit (CC))
then
Error_Msg_N
- ("component clause inconsistent "
- & "with representation of ancestor", CC);
+ ("component clause inconsistent with "
+ & "representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then
Error_Msg_N
Siz : Uint;
Biased : out Boolean)
is
+ procedure Size_Too_Small_Error (Min_Siz : Uint);
+ -- Emit an error concerning illegal size Siz. Min_Siz denotes the
+ -- minimum size.
+
+ --------------------------
+ -- Size_Too_Small_Error --
+ --------------------------
+
+ procedure Size_Too_Small_Error (Min_Siz : Uint) is
+ begin
+ -- This error is suppressed in ASIS mode to allow for different ASIS
+ -- back-ends or ASIS-based tools to query the illegal clause.
+
+ if not ASIS_Mode then
+ Error_Msg_Uint_1 := Min_Siz;
+ Error_Msg_NE ("size for & too small, minimum allowed is ^", N, T);
+ end if;
+ end Size_Too_Small_Error;
+
+ -- Local variables
+
UT : constant Entity_Id := Underlying_Type (T);
M : Uint;
+ -- Start of processing for Check_Size
+
begin
Biased := False;
- -- Reject patently improper size values.
+ -- Reject patently improper size values
if Is_Elementary_Type (T)
and then Siz > UI_From_Int (Int'Last)
return;
else
- Error_Msg_Uint_1 := Asiz;
- Error_Msg_NE
- ("size for& too small, minimum allowed is ^", N, T);
+ Size_Too_Small_Error (Asiz);
Set_Esize (T, Asiz);
Set_RM_Size (T, Asiz);
end if;
-- since we don't know all the characteristics of the type that can
-- affect the size (e.g. a specified small) till freeze time.
- elsif Is_Fixed_Point_Type (UT)
- and then not Is_Frozen (UT)
- then
+ elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then
null;
-- Cases for which a minimum check is required
M := UI_From_Int (Minimum_Size (UT, Biased => True));
if Siz < M then
- Error_Msg_Uint_1 := M;
- Error_Msg_NE
- ("size for& too small, minimum allowed is ^", N, T);
- Set_Esize (T, M);
+ Size_Too_Small_Error (M);
+ Set_Esize (T, M);
Set_RM_Size (T, M);
else
Biased := True;
-------------------------
function Get_Alignment_Value (Expr : Node_Id) return Uint is
+ procedure Alignment_Error;
+ -- Issue an error concerning a negatize or zero alignment represented by
+ -- expression Expr.
+
+ ---------------------
+ -- Alignment_Error --
+ ---------------------
+
+ procedure Alignment_Error is
+ begin
+ -- This error is suppressed in ASIS mode to allow for different ASIS
+ -- back-ends or ASIS-based tools to query the illegal clause.
+
+ if not ASIS_Mode then
+ Error_Msg_N ("alignment value must be positive", Expr);
+ end if;
+ end Alignment_Error;
+
+ -- Local variables
+
Align : constant Uint := Static_Integer (Expr);
+ -- Start of processing for Get_Alignment_Value
+
begin
if Align = No_Uint then
return No_Uint;
elsif Align <= 0 then
- Error_Msg_N ("alignment value must be positive", Expr);
+ Alignment_Error;
return No_Uint;
else
exit when M = Align;
if M > Align then
- Error_Msg_N
- ("alignment value must be power of 2", Expr);
+ Alignment_Error;
return No_Uint;
end if;
end;
-- Special checks for protected objects not at library level
- if Is_Protected_Type (T)
- and then not Is_Library_Level_Entity (Id)
- then
+ if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Local_Protected_Objects, Id);
-- Protected objects with interrupt handlers must be at library level
-- AI05-0303: The AI is in fact a binding interpretation, and thus
-- applies to the '95 version of the language as well.
- if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
+ if Is_Protected_Type (T)
+ and then Has_Interrupt_Handler (T)
+ and then Ada_Version < Ada_95
+ then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;
return Get_Pragma_Id (Pragma_Name (N));
end Get_Pragma_Id;
+ ------------------------
+ -- Get_Qualified_Name --
+ ------------------------
+
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id
+ is
+ Suffix_Nam : Name_Id := No_Name;
+
+ begin
+ if Present (Suffix) then
+ Suffix_Nam := Chars (Suffix);
+ end if;
+
+ return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
+ end Get_Qualified_Name;
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id
+ is
+ procedure Add_Scope (S : Entity_Id);
+ -- Add the fully qualified form of scope S to the name buffer. The
+ -- format is:
+ -- s-1__s__
+
+ ---------------
+ -- Add_Scope --
+ ---------------
+
+ procedure Add_Scope (S : Entity_Id) is
+ begin
+ if S = Empty then
+ null;
+
+ elsif S = Standard_Standard then
+ null;
+
+ else
+ Add_Scope (Scope (S));
+ Get_Name_String_And_Append (Chars (S));
+ Add_Str_To_Name_Buffer ("__");
+ end if;
+ end Add_Scope;
+
+ -- Start of processing for Get_Qualified_Name
+
+ begin
+ Name_Len := 0;
+ Add_Scope (Scop);
+
+ -- Append the base name after all scopes have been chained
+
+ Get_Name_String_And_Append (Nam);
+
+ -- Append the suffix (if present)
+
+ if Suffix /= No_Name then
+ Add_Str_To_Name_Buffer ("__");
+ Get_Name_String_And_Append (Suffix);
+ end if;
+
+ return Name_Find;
+ end Get_Qualified_Name;
+
-----------------------
-- Get_Reason_String --
-----------------------
-----------------
procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
- procedure Output_Scope (S : Entity_Id);
- -- Add the fully qualified form of scope S to the name buffer. The
- -- qualification format is:
- -- scope1__scopeN__
-
- ------------------
- -- Output_Scope --
- ------------------
-
- procedure Output_Scope (S : Entity_Id) is
- begin
- if S = Empty then
- null;
-
- elsif S = Standard_Standard then
- null;
-
- else
- Output_Scope (Scope (S));
- Add_Str_To_Name_Buffer (Get_Name_String (Chars (S)));
- Add_Str_To_Name_Buffer ("__");
- end if;
- end Output_Scope;
-
- -- Start of processing for Output_Name
-
begin
- Name_Len := 0;
- Output_Scope (Scop);
-
- Add_Str_To_Name_Buffer (Get_Name_String (Nam));
-
- Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Str
+ (Get_Name_String
+ (Get_Qualified_Name
+ (Nam => Nam,
+ Suffix => No_Name,
+ Scop => Scop)));
Write_Eol;
end Output_Name;
pragma Inline (Get_Pragma_Id);
-- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id;
+ -- Obtain the fully qualified form of entity Id. The format is:
+ -- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id;
+ -- Obtain the fully qualified form of name Nam assuming it appears in scope
+ -- Scop. The format is:
+ -- scop-1__scop__nam__suffix
+
procedure Get_Reason_String (N : Node_Id);
-- Recursive routine to analyze reason argument for pragma Warnings. The
-- value of the reason argument is appended to the current string using
projects / gcc.git / commitdiff