+2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-tags.ads, a-tags.adb (Unregister_Tag): New routine.
+ Remove the external tag of a tagged type from the internal hash table.
+ * exp_ch7.adb (Build_Cleanup_Statements): Update the comment on the
+ expanded usage of the routine. Strenghten the check for Is_Master. Add
+ processing for tagged types.
+ (Build_Finalizer): Create all the necessary lists used in finalizer
+ creation when the processed context is a package that may contain
+ tagged types.
+ (Expand_Cleanup_Actions): Rename the call to Has_Controlled_Objects to
+ Requires_Cleanup_Actions.
+ (Expand_N_Package_Body): Package bodies may need clean up code
+ depending on whether they contain tagged types.
+ (Expand_N_Package_Declaration): Package declarations may need clean up
+ code depending on whether they contain tagged types.
+ (Unregister_Tagged_Types): New routine. Search through a list of
+ declarations or statements, looking for non-abstract Ada tagged types.
+ For each such type, generate code to unregister the external tag.
+ * exp_util.adb (Has_Controlled_Objects (Node_Id)): Renamed to
+ Requires_Cleanup_Actions.
+ (Requires_Cleanup_Actions (List_Id, Boolean)): New routine. Search
+ through a list of declarations or statements looking for non-abstract
+ Ada tagged types or controlled objects.
+ * exp_util.ads (Has_Controlled_Objects (Node_Id)): Renamed to
+ Requires_Cleanup_Actions.
+ (Has_Controlled_Objects (List_Id, Boolean)): Removed.
+ * rtsfind.ads: Add entry RE_Unregister_Tag to tables RE_Id and
+ RE_Unit_Table.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * prj-env.adb (For_All_Source_Dirs.For_Project): Check if project Prj
+ has Ada sources, not project Project, because if the root project
+ Project has no sources of its own, all projects will be deemed without
+ sources.
+
+2011-08-04 Gary Dismukes <dismukes@adacore.com>
+
+ * bindgen.adb (Gen_Adainit_Ada): Move the generation of the declaration
+ of the No_Param_Proc acc-to-subp type used for initialization of
+ __gnat_finalize_library_objects so that it's declared at library level
+ rather than nested inside of the adainit routine.
+
+2011-08-04 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_DT): Generate code to check the external tag ONLY
+ if the tagged type has a representation clause which specifies its
+ external tag.
+
+2011-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types.
+ Remove previous procedure with that name.
+ * sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor
+ when appropriate.
+ * sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a
+ subtype mark, the ancestor cannot have unknown discriminants.
+ (Resolve_Record_Aggregate): if the type has invisible components
+ because of a private ancestor, the aggregate is illegal.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * switch-m.adb (Normalize_Compiler_Switches): Recognize and take into
+ account switches -gnat2005, -gnat12 and -gnat2012.
+
+2011-08-04 Bob Duff <duff@adacore.com>
+
+ * s-tasdeb.ads: Minor comment fix.
+
+2011-08-04 Arnaud Charlet <charlet@adacore.com>
+
+ * gnatlink.adb (Gnatlink): Pass -gnat83/95/05/12 switch to gcc in
+ CodePeer mode.
+ * switch.ads, switch.adb (Is_Language_Switch): New function.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * switch-c.adb: Minor comment addition.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * vms_conv.adb (Process_Argument): Fail graciously when qualifier
+ ending with '=' is followed by a space (missing file name).
+
+2011-08-04 Pascal Obry <obry@adacore.com>
+
+ * g-regist.ads: Fix size of HKEY on x86_64-windows.
+
+2011-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations): New routine
+ Check_Overloaded_Formal_Subprogram to reject a formal package when
+ there is a named association or a box initialisation for an overloaded
+ formal subprogram of the corresponding generic.
+
+2011-08-04 Yannick Moy <moy@adacore.com>
+
+ * alfa.ads (ALFA_Xref_Record): add component for type of entity
+ * get_alfa.adb, put_alfa.adb: Read and write new component of
+ cross-reference.
+ * lib-xref-alfa.adb (Collect_ALFA): generate new component.
+
2011-08-04 Pascal Obry <obry@adacore.com>
* urealp.adb: Minor reformatting.
return TSD.Type_Is_Abstract;
end Type_Is_Abstract;
+ --------------------
+ -- Unregister_Tag --
+ --------------------
+
+ procedure Unregister_Tag (T : Tag) is
+ TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+ TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+ begin
+ External_Tag_HTable.Remove (To_Address (TSD.External_Tag));
+ end Unregister_Tag;
+
------------------------
-- Wide_Expanded_Name --
------------------------
-- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
-- table indexed by Position.
+ procedure Unregister_Tag (T : Tag);
+ -- Remove a particular tag from the external tag hash table
+
Max_Predef_Prims : constant Positive := 16;
-- Number of reserved slots for the following predefined ada primitives:
--
-- entity-number and identity identify a scope entity in FS lines for
-- the file previously identified.
- -- line col entity ref*
+ -- line typ col entity ref*
-- line is the line number of the referenced entity
+ -- typ is the type of the referenced entity, using a code similar to
+ -- the one used for cross-references:
+
+ -- > = IN parameter
+ -- < = OUT parameter
+ -- = = IN OUT parameter
+ -- * = all other cases
+
-- col is the column number of the referenced entity
-- entity is the name of the referenced entity as written in the source
Entity_Line : Nat;
-- Line number for the entity referenced
+ Etype : Character;
+ -- Indicates type of entity, using code used in ALI file:
+ -- > = IN parameter
+ -- < = OUT parameter
+ -- = = IN OUT parameter
+ -- * = all other cases
+
Entity_Col : Nat;
-- Column number for the entity referenced
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
begin
+ -- Declare the access-to-subprogram type used for initialization of
+ -- of __gnat_finalize_library_objects. This is declared at library
+ -- level for compatibility with the type used in System.Soft_Links.
+ -- The import of the soft link which performs library-level object
+ -- finalization is not needed for VM targets; regular Ada is used in
+ -- that case. For restricted run-time libraries (ZFP and Ravenscar)
+ -- tasks are non-terminating, so we do not want finalization.
+
+ if not Suppress_Standard_Library_On_Target
+ and then VM_Target = No_VM
+ and then not Configurable_Run_Time_On_Target
+ then
+ WBI (" type No_Param_Proc is access procedure;");
+ WBI ("");
+ end if;
+
WBI (" procedure " & Ada_Init_Name.all & " is");
-- If the standard library is suppressed, then the only global variables
if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then
WBI ("");
- WBI (" type No_Param_Proc is access procedure;");
WBI (" Finalize_Library_Objects : No_Param_Proc;");
WBI (" pragma Import (C, Finalize_Library_Objects, " &
"""__gnat_finalize_library_objects"");");
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
+ -- Has_Private_Ancestor Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
function Has_Invariants (Id : E) return B is
begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Generic_Procedure);
return Flag232 (Id);
end Has_Invariants;
return Flag120 (Base_Type (Id));
end Has_Primitive_Operations;
+ function Has_Private_Ancestor (Id : E) return B is
+ begin
+ return Flag151 (Id);
+ end Has_Private_Ancestor;
+
function Has_Private_Declaration (Id : E) return B is
begin
return Flag155 (Id);
Set_Flag120 (Id, V);
end Set_Has_Primitive_Operations;
+ procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag151 (Id, V);
+ end Set_Has_Private_Ancestor;
+
procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
begin
Set_Flag155 (Id, V);
return False;
end Has_Interrupt_Handler;
- --------------------------
- -- Has_Private_Ancestor --
- --------------------------
-
- function Has_Private_Ancestor (Id : E) return B is
- R : constant Entity_Id := Root_Type (Id);
- T1 : Entity_Id := Id;
- begin
- loop
- if Is_Private_Type (T1) then
- return True;
- elsif T1 = R then
- return False;
- else
- T1 := Etype (T1);
- end if;
- end loop;
- end Has_Private_Ancestor;
-
--------------------
-- Has_Rep_Pragma --
--------------------
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
+ W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
-- Present in all type entities. Set if at least one primitive operation
-- is defined for the type.
--- Has_Private_Ancestor (synthesized)
--- Applies to all type and subtype entities. Returns True if at least
--- one ancestor is private, and otherwise False if there are no private
--- ancestors.
+-- Has_Private_Ancestor (Flag151)
+-- Applies to type extensions. True if some ancestor is derived from a
+-- private type, making some components invisible and aggregates illegal.
+-- This flag is set at the point of derivation. The legality of the
+-- aggregate must be rechecked because it also depends on the visibility
+-- at the point the aggregate is resolved. See sem_aggr.adb.
+-- This is part of AI05-0115.
-- Has_Private_Declaration (Flag155)
-- Present in all entities. Returns True if it is the defining entity
-- Alignment_Clause (synth)
-- Base_Type (synth)
- -- Has_Private_Ancestor (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Pragma_Pack (Flag121) (impl base type only)
+ -- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
+ -- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
+ function Has_Private_Ancestor (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
function Has_Record_Rep_Clause (Id : E) return B;
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
- function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Base_Type (Id : E) return B;
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
+ procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
pragma Inline (Has_Pragma_Unreferenced_Objects);
pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
+ pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
pragma Inline (Set_Has_Predicates);
pragma Inline (Set_Has_Primitive_Operations);
+ pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
function Build_Cleanup_Statements (N : Node_Id) return List_Id;
-- Create the clean up calls for an asynchronous call block, task master,
- -- protected subprogram body, task allocation block or task body. If N is
- -- neither of these constructs, the routine returns a new list.
+ -- protected subprogram body, task allocation block or task body. Generate
+ -- code to unregister the external tags of all library-level tagged types
+ -- found in the declarations and/or statements of N. If the context does
+ -- not contain the above constructs or types, the routine returns an empty
+ -- list.
function Build_Exception_Handler
(Loc : Source_Ptr;
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
+
Is_Master : constant Boolean :=
- Nkind (N) /= N_Entry_Body
+ not Nkind_In (N, N_Entry_Body,
+ N_Package_Body,
+ N_Package_Declaration)
and then Is_Task_Master (N);
Is_Protected_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
Loc : constant Source_Ptr := Sloc (N);
Stmts : constant List_Id := New_List;
+ procedure Unregister_Tagged_Types (Decls : List_Id);
+ -- Unregister the external tag of each tagged type found in the list
+ -- Decls. The generated statements are added to list Stmts.
+
+ -----------------------------
+ -- Unregister_Tagged_Types --
+ -----------------------------
+
+ procedure Unregister_Tagged_Types (Decls : List_Id) is
+ Decl : Node_Id;
+ DT_Ptr : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if No (Decls) or else Is_Empty_List (Decls) then
+ return;
+ end if;
+
+ -- Process all declarations or statements in reverse order
+
+ Decl := Last_Non_Pragma (Decls);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Typ := Defining_Identifier (Decl);
+
+ if Is_Tagged_Type (Typ)
+ and then Is_Library_Level_Entity (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then Present (Access_Disp_Table (Typ))
+ and then RTE_Available (RE_Unregister_Tag)
+ and then not No_Run_Time_Mode
+ and then not Is_Abstract_Type (Typ)
+ then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ -- Generate:
+ -- Ada.Tags.Unregister_Tag (<Typ>P);
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Unregister_Tag), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc))));
+ end if;
+ end if;
+
+ Prev_Non_Pragma (Decl);
+ end loop;
+ end Unregister_Tagged_Types;
+
+ -- Start of processing for Build_Cleanup_Statements
+
begin
if Is_Task_Body then
if Restricted_Profile then
end;
end if;
+ -- Inspect all declaration and/or statement lists of N for library-level
+ -- tagged types. Generate code to unregister the external tag of such a
+ -- type.
+
+ if Nkind (N) = N_Package_Declaration then
+ Unregister_Tagged_Types (Private_Declarations (Specification (N)));
+ Unregister_Tagged_Types (Visible_Declarations (Specification (N)));
+
+ -- Accept statement, block, entry body, package body, protected body,
+ -- subprogram body or task body.
+
+ else
+ if Present (Handled_Statement_Sequence (N)) then
+ Unregister_Tagged_Types
+ (Statements (Handled_Statement_Sequence (N)));
+ end if;
+
+ Unregister_Tagged_Types (Declarations (N));
+ end if;
+
return Stmts;
end Build_Cleanup_Statements;
if For_Package_Spec then
Process_Declarations
(Priv_Decls, Preprocess => True, Top_Level => True);
+ end if;
- -- The preprocessing has determined that the context has objects
- -- that need finalization actions. Private declarations are
- -- processed first in order to preserve possible dependencies
- -- between public and private objects.
+ -- The current context may lack controlled objects, but require some
+ -- other form of completion (task termination for instance). In such
+ -- cases, the finalizer must be created and carry the additional
+ -- statements.
- if Has_Ctrl_Objs then
- Build_Components;
- Process_Declarations (Priv_Decls);
- end if;
+ if Acts_As_Clean or else Has_Ctrl_Objs then
+ Build_Components;
end if;
- -- Process the public declarations
+ -- The preprocessing has determined that the context has objects that
+ -- need finalization actions.
if Has_Ctrl_Objs then
- Build_Components;
+
+ -- Private declarations are processed first in order to preserve
+ -- possible dependencies between public and private objects.
+
+ if For_Package_Spec then
+ Process_Declarations (Priv_Decls);
+ end if;
+
Process_Declarations (Decls);
end if;
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
- Has_Controlled_Objects (N)
+ Requires_Cleanup_Actions (N)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
if Ekind (Spec_Ent) /= E_Generic_Package then
Build_Finalizer
(N => N,
- Clean_Stmts => No_List,
+ Clean_Stmts => Build_Cleanup_Statements (N),
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,
if Ekind (Id) /= E_Generic_Package then
Build_Finalizer
(N => N,
- Clean_Stmts => No_List,
+ Clean_Stmts => Build_Cleanup_Statements (N),
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,
end if;
end if;
- -- Generate code to check if the external tag of this type is the same
- -- as the external tag of some other declaration.
+ -- If the type has a representation clause which specifies its external
+ -- tag then generate code to check if the external tag of this type is
+ -- the same as the external tag of some other declaration.
-- Check_TSD (TSD'Unrestricted_Access);
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005
+ and then Has_External_Tag_Rep_Clause (Typ)
and then RTE_Available (RE_Check_TSD)
and then not Debug_Flag_QQ
then
N : Node_Id) return Entity_Id;
-- Create an implicit subtype of CW_Typ attached to node N
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ For_Package : Boolean) return Boolean;
+ -- Given a list L, determine whether it contains one of the following:
+ --
+ -- 1) controlled objects
+ -- 2) library-level tagged types
+ --
+ -- Flag For_Package should be set when the list comes from a package spec
+ -- or body.
+
----------------------
-- Adjust_Condition --
----------------------
end if;
end Has_Access_Constraint;
- ----------------------------
- -- Has_Controlled_Objects --
- ----------------------------
-
- function Has_Controlled_Objects (N : Node_Id) return Boolean is
- For_Pkg : constant Boolean :=
- Nkind_In (N, N_Package_Body, N_Package_Specification);
-
- begin
- case Nkind (N) is
- when N_Accept_Statement |
- N_Block_Statement |
- N_Entry_Body |
- N_Package_Body |
- N_Protected_Body |
- N_Subprogram_Body |
- N_Task_Body =>
- return Has_Controlled_Objects (Declarations (N), For_Pkg)
- or else
-
- -- An expanded sequence of statements may introduce
- -- controlled objects.
-
- (Present (Handled_Statement_Sequence (N))
- and then
- Has_Controlled_Objects
- (Statements (Handled_Statement_Sequence (N)), For_Pkg));
-
- when N_Package_Specification =>
- return Has_Controlled_Objects (Visible_Declarations (N), For_Pkg)
- or else
- Has_Controlled_Objects (Private_Declarations (N), For_Pkg);
-
- when others =>
- return False;
- end case;
- end Has_Controlled_Objects;
-
- ----------------------------
- -- Has_Controlled_Objects --
- ----------------------------
-
- function Has_Controlled_Objects
- (L : List_Id;
- For_Package : Boolean) return Boolean
- is
- Decl : Node_Id;
- Expr : Node_Id;
- Obj_Id : Entity_Id;
- Obj_Typ : Entity_Id;
- Pack_Id : Entity_Id;
- Typ : Entity_Id;
-
- begin
- if No (L)
- or else Is_Empty_List (L)
- then
- return False;
- end if;
-
- Decl := First (L);
- while Present (Decl) loop
-
- -- Regular object declarations
-
- if Nkind (Decl) = N_Object_Declaration then
- Obj_Id := Defining_Identifier (Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-
- -- Bypass any form of processing for objects which have their
- -- finalization disabled. This applies only to objects at the
- -- library level.
-
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
- null;
-
- -- Transient variables are treated separately in order to minimize
- -- the size of the generated code. See Exp_Ch7.Process_Transient_
- -- Objects.
-
- elsif Is_Processed_Transient (Obj_Id) then
- null;
-
- -- The object is of the form:
- -- Obj : Typ [:= Expr];
- --
- -- Do not process the incomplete view of a deferred constant. Do
- -- not consider tag-to-class-wide conversions.
-
- elsif not Is_Imported (Obj_Id)
- and then Needs_Finalization (Obj_Typ)
- and then not (Ekind (Obj_Id) = E_Constant
- and then not Has_Completion (Obj_Id))
- and then not Is_Tag_To_CW_Conversion (Obj_Id)
- then
- return True;
-
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
- --
- -- Obj : Access_Typ :=
- -- BIP_Function_Call
- -- (..., BIPaccess => null, ...)'reference;
-
- elsif Is_Access_Type (Obj_Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Obj_Typ)))
- and then Present (Expr)
- and then
- (Is_Null_Access_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
- then
- return True;
-
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
-
- elsif Is_Access_Type (Obj_Typ)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
- and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
- and then Is_Finalizable_Transient
- (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
- then
- return True;
-
- -- Simple protected objects which use type System.Tasking.
- -- Protected_Objects.Protection to manage their locks should be
- -- treated as controlled since they require manual cleanup.
-
- elsif Ekind (Obj_Id) = E_Variable
- and then
- (Is_Simple_Protected_Type (Obj_Typ)
- or else Has_Simple_Protected_Object (Obj_Typ))
- then
- return True;
- end if;
-
- -- Specific cases of object renamings
-
- elsif Nkind (Decl) = N_Object_Renaming_Declaration
- and then Nkind (Name (Decl)) = N_Explicit_Dereference
- and then Nkind (Prefix (Name (Decl))) = N_Identifier
- then
- Obj_Id := Defining_Identifier (Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
-
- -- Bypass any form of processing for objects which have their
- -- finalization disabled. This applies only to objects at the
- -- library level.
-
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
- null;
-
- -- Return object of a build-in-place function. This case is
- -- recognized and marked by the expansion of an extended return
- -- statement (see Expand_N_Extended_Return_Statement).
-
- elsif Needs_Finalization (Obj_Typ)
- and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
- then
- return True;
- end if;
-
- -- Inspect the freeze node of an access-to-controlled type and
- -- look for a delayed finalization collection. This case arises
- -- when the freeze actions are inserted at a later time than the
- -- expansion of the context. Since Build_Finalizer is never called
- -- on a single construct twice, the collection will be ultimately
- -- left out and never finalized. This is also needed for freeze
- -- actions of designated types themselves, since in some cases the
- -- finalization collection is associated with a designated type's
- -- freeze node rather than that of the access type (see handling
- -- for freeze actions in Build_Finalization_Collection).
-
- elsif Nkind (Decl) = N_Freeze_Entity
- and then Present (Actions (Decl))
- then
- Typ := Entity (Decl);
-
- if (Is_Access_Type (Typ)
- and then not Is_Access_Subprogram_Type (Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Typ))))
- or else
- (Is_Type (Typ)
- and then Needs_Finalization (Typ))
- then
- return True;
- end if;
-
- -- Nested package declarations
-
- elsif Nkind (Decl) = N_Package_Declaration then
- Pack_Id := Defining_Unit_Name (Specification (Decl));
-
- if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
- Pack_Id := Defining_Identifier (Pack_Id);
- end if;
-
- if Ekind (Pack_Id) /= E_Generic_Package
- and then Has_Controlled_Objects (Specification (Decl))
- then
- return True;
- end if;
-
- -- Nested package bodies
-
- elsif Nkind (Decl) = N_Package_Body then
- Pack_Id := Corresponding_Spec (Decl);
-
- if Ekind (Pack_Id) /= E_Generic_Package
- and then Has_Controlled_Objects (Decl)
- then
- return True;
- end if;
- end if;
-
- Next (Decl);
- end loop;
-
- return False;
- end Has_Controlled_Objects;
-
----------------------------------
-- Has_Following_Address_Clause --
----------------------------------
and then Is_Scalar_Type (Packed_Array_Type (UT)));
end Represented_As_Scalar;
+ ------------------------------
+ -- Requires_Cleanup_Actions --
+ ------------------------------
+
+ function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
+ For_Pkg : constant Boolean :=
+ Nkind_In (N, N_Package_Body, N_Package_Specification);
+
+ begin
+ case Nkind (N) is
+ when N_Accept_Statement |
+ N_Block_Statement |
+ N_Entry_Body |
+ N_Package_Body |
+ N_Protected_Body |
+ N_Subprogram_Body |
+ N_Task_Body =>
+ return
+ Requires_Cleanup_Actions (Declarations (N), For_Pkg)
+ or else
+ (Present (Handled_Statement_Sequence (N))
+ and then
+ Requires_Cleanup_Actions
+ (Statements (Handled_Statement_Sequence (N)), For_Pkg));
+
+ when N_Package_Specification =>
+ return
+ Requires_Cleanup_Actions (Visible_Declarations (N), For_Pkg)
+ or else
+ Requires_Cleanup_Actions (Private_Declarations (N), For_Pkg);
+
+ when others =>
+ return False;
+ end case;
+ end Requires_Cleanup_Actions;
+
+ ------------------------------
+ -- Requires_Cleanup_Actions --
+ ------------------------------
+
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ For_Package : Boolean) return Boolean
+ is
+ Decl : Node_Id;
+ Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Pack_Id : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if No (L)
+ or else Is_Empty_List (L)
+ then
+ return False;
+ end if;
+
+ Decl := First (L);
+ while Present (Decl) loop
+
+ -- Library-level tagged types
+
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Typ := Defining_Identifier (Decl);
+
+ if Is_Tagged_Type (Typ)
+ and then Is_Library_Level_Entity (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then Present (Access_Disp_Table (Typ))
+ and then RTE_Available (RE_Unregister_Tag)
+ and then not No_Run_Time_Mode
+ and then not Is_Abstract_Type (Typ)
+ then
+ return True;
+ end if;
+
+ -- Regular object declarations
+
+ elsif Nkind (Decl) = N_Object_Declaration then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+ Expr := Expression (Decl);
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if For_Package
+ and then Finalize_Storage_Only (Obj_Typ)
+ then
+ null;
+
+ -- Transient variables are treated separately in order to minimize
+ -- the size of the generated code. See Exp_Ch7.Process_Transient_
+ -- Objects.
+
+ elsif Is_Processed_Transient (Obj_Id) then
+ null;
+
+ -- The object is of the form:
+ -- Obj : Typ [:= Expr];
+ --
+ -- Do not process the incomplete view of a deferred constant. Do
+ -- not consider tag-to-class-wide conversions.
+
+ elsif not Is_Imported (Obj_Id)
+ and then Needs_Finalization (Obj_Typ)
+ and then not (Ekind (Obj_Id) = E_Constant
+ and then not Has_Completion (Obj_Id))
+ and then not Is_Tag_To_CW_Conversion (Obj_Id)
+ then
+ return True;
+
+ -- The object is of the form:
+ -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
+ --
+ -- Obj : Access_Typ :=
+ -- BIP_Function_Call
+ -- (..., BIPaccess => null, ...)'reference;
+
+ elsif Is_Access_Type (Obj_Typ)
+ and then Needs_Finalization
+ (Available_View (Designated_Type (Obj_Typ)))
+ and then Present (Expr)
+ and then
+ (Is_Null_Access_BIP_Func_Call (Expr)
+ or else
+ (Is_Non_BIP_Func_Call (Expr)
+ and then not Is_Related_To_Func_Return (Obj_Id)))
+ then
+ return True;
+
+ -- Processing for "hook" objects generated for controlled
+ -- transients declared inside an Expression_With_Actions.
+
+ elsif Is_Access_Type (Obj_Typ)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
+ and then Is_Finalizable_Transient
+ (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ then
+ return True;
+
+ -- Simple protected objects which use type System.Tasking.
+ -- Protected_Objects.Protection to manage their locks should be
+ -- treated as controlled since they require manual cleanup.
+
+ elsif Ekind (Obj_Id) = E_Variable
+ and then
+ (Is_Simple_Protected_Type (Obj_Typ)
+ or else Has_Simple_Protected_Object (Obj_Typ))
+ then
+ return True;
+ end if;
+
+ -- Specific cases of object renamings
+
+ elsif Nkind (Decl) = N_Object_Renaming_Declaration
+ and then Nkind (Name (Decl)) = N_Explicit_Dereference
+ and then Nkind (Prefix (Name (Decl))) = N_Identifier
+ then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if For_Package
+ and then Finalize_Storage_Only (Obj_Typ)
+ then
+ null;
+
+ -- Return object of a build-in-place function. This case is
+ -- recognized and marked by the expansion of an extended return
+ -- statement (see Expand_N_Extended_Return_Statement).
+
+ elsif Needs_Finalization (Obj_Typ)
+ and then Is_Return_Object (Obj_Id)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ then
+ return True;
+ end if;
+
+ -- Inspect the freeze node of an access-to-controlled type and
+ -- look for a delayed finalization collection. This case arises
+ -- when the freeze actions are inserted at a later time than the
+ -- expansion of the context. Since Build_Finalizer is never called
+ -- on a single construct twice, the collection will be ultimately
+ -- left out and never finalized. This is also needed for freeze
+ -- actions of designated types themselves, since in some cases the
+ -- finalization collection is associated with a designated type's
+ -- freeze node rather than that of the access type (see handling
+ -- for freeze actions in Build_Finalization_Collection).
+
+ elsif Nkind (Decl) = N_Freeze_Entity
+ and then Present (Actions (Decl))
+ then
+ Typ := Entity (Decl);
+
+ if (Is_Access_Type (Typ)
+ and then not Is_Access_Subprogram_Type (Typ)
+ and then Needs_Finalization
+ (Available_View (Designated_Type (Typ))))
+ or else
+ (Is_Type (Typ)
+ and then Needs_Finalization (Typ))
+ then
+ return True;
+ end if;
+
+ -- Nested package declarations
+
+ elsif Nkind (Decl) = N_Package_Declaration then
+ Pack_Id := Defining_Unit_Name (Specification (Decl));
+
+ if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
+ Pack_Id := Defining_Identifier (Pack_Id);
+ end if;
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ and then Requires_Cleanup_Actions (Specification (Decl))
+ then
+ return True;
+ end if;
+
+ -- Nested package bodies
+
+ elsif Nkind (Decl) = N_Package_Body then
+ Pack_Id := Corresponding_Spec (Decl);
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ and then Requires_Cleanup_Actions (Decl)
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return False;
+ end Requires_Cleanup_Actions;
+
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------
function Has_Access_Constraint (E : Entity_Id) return Boolean;
-- Given object or type E, determine if a discriminant is of an access type
- function Has_Controlled_Objects (N : Node_Id) return Boolean;
- -- Given a node N, determine if it has a declarative or a statement part
- -- and whether those lists contain at least one controlled object.
-
- function Has_Controlled_Objects
- (L : List_Id;
- For_Package : Boolean) return Boolean;
- -- Given a list, determine whether L contains at least one controlled
- -- object. Flag For_Package should be set when the list comes from a
- -- package spec or body.
-
function Has_Following_Address_Clause (D : Node_Id) return Boolean;
-- D is the node for an object declaration. This function searches the
-- current declarative part to look for an address clause for the object
-- terms is scalar. This is true for scalars in the Ada sense, and for
-- packed arrays which are represented by a scalar (modular) type.
+ function Requires_Cleanup_Actions (N : Node_Id) return Boolean;
+ -- Given a node N, determine whether its declarative and/or statement list
+ -- contains one of the following:
+ --
+ -- 1) controlled objects
+ -- 2) library-level tagged types
+ --
+ -- The above cases require special actions on scope exit.
+
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
-- Given the node for an N_Unchecked_Type_Conversion, return True if this
-- is an unchecked conversion that Gigi can handle directly. Otherwise
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2011, 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- --
private
- type HKEY is mod 2 ** Integer'Size;
+ type HKEY is mod 2 ** Standard'Address_Size;
HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#;
HKEY_CURRENT_USER : constant HKEY := 16#80000001#;
XR_Entity : String_Ptr;
XR_Entity_Line : Nat;
XR_Entity_Col : Nat;
+ XR_Entity_Typ : Character;
XR_File : Nat;
-- Keeps track of the current file (changed by nn|)
XR_Scope := Cur_Scope;
XR_Entity_Line := Get_Nat;
- Check (' ');
+ XR_Entity_Typ := Getc;
XR_Entity_Col := Get_Nat;
Skip_Spaces;
ALFA_Xref_Table.Append (
(Entity_Name => XR_Entity,
Entity_Line => XR_Entity_Line,
+ Etype => XR_Entity_Typ,
Entity_Col => XR_Entity_Col,
File_Num => XR_File,
Scope_Num => XR_Scope,
-- is to be dealt with specially because it needs to be passed
-- if the binder-generated file is in Ada and may also be used
-- to drive the linker.
+ -- Also in CodePeer mode, we need to pass the -gnat05 or
+ -- -gnat12 switches to be able to compile the binder file.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
- if not Is_Front_End_Switch (Arg.all) then
+ if not Is_Front_End_Switch (Arg.all)
+ or else (Opt.CodePeer_Mode
+ and then Is_Language_Switch (Arg.all))
+ then
Binder_Options_From_ALI.Increment_Last;
Binder_Options_From_ALI.Table
(Binder_Options_From_ALI.Last) := String_Access (Arg);
-- Return scope entity which corresponds to index Cur_Scope_Idx in
-- table ALFA_Scope_Table.
+ function Get_Entity_Type (E : Entity_Id) return Character;
+ -- Return a character representing the type of entity
+
function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
-- Check whether entity E is in ALFA_Scope_Table at index
-- Cur_Scope_Idx or higher.
return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
end Cur_Scope;
+ ---------------------
+ -- Get_Entity_Type --
+ ---------------------
+
+ function Get_Entity_Type (E : Entity_Id) return Character is
+ C : Character;
+ begin
+ case Ekind (E) is
+ when E_Out_Parameter => C := '<';
+ when E_In_Out_Parameter => C := '=';
+ when E_In_Parameter => C := '>';
+ when others => C := '*';
+ end case;
+ return C;
+ end Get_Entity_Type;
+
----------------------------
-- Is_Future_Scope_Entity --
----------------------------
ALFA_Xref_Table.Append (
(Entity_Name => Cur_Entity_Name,
Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
+ Etype => Get_Entity_Type (XE.Ent),
Entity_Col => Int (Get_Column_Number (XE.Def)),
File_Num => Dependency_Num (XE.Lun),
Scope_Num => Get_Scope_Num (XE.Ref_Scope),
-- If there are Ada sources, call action with the name of every
-- source directory.
- if Has_Ada_Sources (Project) then
+ if Has_Ada_Sources (Prj) then
while Current /= Nil_String loop
The_String := In_Tree.Shared.String_Elements.Table (Current);
Action (Get_Name_String (The_String.Display_Value));
Write_Info_Initiate ('F');
Write_Info_Char (' ');
Write_Info_Nat (R.Entity_Line);
- Write_Info_Char (' ');
+ Write_Info_Char (R.Etype);
Write_Info_Nat (R.Entity_Col);
Write_Info_Char (' ');
RE_TK_Protected, -- Ada.Tags
RE_TK_Tagged, -- Ada.Tags
RE_TK_Task, -- Ada.Tags
+ RE_Unregister_Tag, -- Ada.Tags
RE_Set_Specific_Handler, -- Ada.Task_Termination
RE_Specific_Handler, -- Ada.Task_Termination
RE_TK_Protected => Ada_Tags,
RE_TK_Tagged => Ada_Tags,
RE_TK_Task => Ada_Tags,
+ RE_Unregister_Tag => Ada_Tags,
RE_Set_Specific_Handler => Ada_Task_Termination,
RE_Specific_Handler => Ada_Task_Termination,
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
subtype Event_Kind_Type is Positive range 1 .. 11;
-- Event kinds currently defined for debugging, used globally
- -- below and on a per taak basis.
+ -- below and on a per task basis.
procedure Signal_Debug_Event
(Event_Kind : Event_Kind_Type;
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;
and then Is_Type (Entity (A))
then
Check_SPARK_Restriction ("ancestor part cannot be a type mark", A);
+
+ -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ -- must not have unknown discriminants.
+
+ if Has_Unknown_Discriminants (Root_Type (Typ)) then
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants", N, Typ);
+ end if;
end if;
if not Is_Tagged_Type (Typ) then
Positional_Expr := Empty;
end if;
+ -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ -- must npt have unknown discriminants.
+
+ if Is_Derived_Type (Typ)
+ and then Has_Unknown_Discriminants (Root_Type (Typ))
+ and then Nkind (N) /= N_Extension_Aggregate
+ then
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants ", N, Typ);
+ end if;
+
if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
Errors_Found : Boolean := False;
Dnode : Node_Id;
+ function Find_Private_Ancestor return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from a private view. Whether the aggregate is legal
+ -- depends on the current visibility of the type as well as that
+ -- of the parent of the ancestor.
+
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor return Entity_Id is
+ Par : Entity_Id;
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
+
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
+ -- AI05-0115: check legality of aggregate for type with
+ -- aa private ancestor.
+
Root_Typ := Root_Type (Typ);
+ if Has_Private_Ancestor (Typ) then
+ declare
+ Ancestor : constant Entity_Id :=
+ Find_Private_Ancestor;
+ Ancestor_Unit : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Ancestor));
+ Parent_Unit : constant Entity_Id :=
+ Cunit_Entity
+ (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ begin
- if Nkind (Parent (Base_Type (Root_Typ))) =
- N_Private_Type_Declaration
- then
- Error_Msg_NE
- ("type of aggregate has private ancestor&!",
- N, Root_Typ);
- Error_Msg_N ("must use extension aggregate!", N);
- return;
+ -- check whether we are in a scope that has full view
+ -- over the private ancestor and its parent. This can
+ -- only happen if the derivation takes place in a child
+ -- unit of the unit that declares the parent, and we are
+ -- in the private part or body of that child unit, else
+ -- the aggregate is illegal.
+
+ if Is_Child_Unit (Ancestor_Unit)
+ and then Scope (Ancestor_Unit) = Parent_Unit
+ and then In_Open_Scopes (Scope (Ancestor))
+ and then
+ (In_Private_Part (Scope (Ancestor))
+ or else In_Package_Body (Scope (Ancestor)))
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("type of aggregate has private ancestor&!",
+ N, Root_Typ);
+ Error_Msg_N ("must use extension aggregate!", N);
+ return;
+ end if;
+ end;
end if;
Dnode := Declaration_Node (Base_Type (Root_Typ));
Actual : Node_Id;
Formal : Node_Id;
Next_Formal : Node_Id;
- Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
Num_Actuals : Int := 0;
Others_Present : Boolean := False;
+ Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parametrization of a formal
-- package. As usual an other association must be last in the list.
+ procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
+ -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
+ -- cannot have a named association for it. AI05-0025 extends this rule
+ -- to formals of formal packages by AI05-0025, and it also applies to
+ -- box-initialized formals.
+
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id) return Node_Id;
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
+ ----------------------------------------
+ -- Check_Overloaded_Formal_Subprogram --
+ ----------------------------------------
+
+ procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
+ Temp_Formal : Entity_Id;
+
+ begin
+ Temp_Formal := First (Formals);
+ while Present (Temp_Formal) loop
+ if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
+ and then Temp_Formal /= Formal
+ and then
+ Chars (Defining_Unit_Name (Specification (Formal))) =
+ Chars (Defining_Unit_Name (Specification (Temp_Formal)))
+ then
+ if Present (Found_Assoc) then
+ Error_Msg_N
+ ("named association not allowed for overloaded formal",
+ Found_Assoc);
+
+ else
+ Error_Msg_N
+ ("named association not allowed for overloaded formal",
+ Others_Choice);
+ end if;
+
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ Next (Temp_Formal);
+ end loop;
+ end Check_Overloaded_Formal_Subprogram;
+
---------------------
-- Matching_Actual --
---------------------
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
+ Others_Choice := Actual;
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
and then Is_Named_Assoc
and then Comes_From_Source (Found_Assoc)
then
- Temp_Formal := First (Formals);
- while Present (Temp_Formal) loop
- if Nkind (Temp_Formal) in
- N_Formal_Subprogram_Declaration
- and then Temp_Formal /= Formal
- and then
- Chars (Selector_Name (Found_Assoc)) =
- Chars (Defining_Unit_Name
- (Specification (Temp_Formal)))
- then
- Error_Msg_N
- ("name not allowed for overloaded formal",
- Found_Assoc);
- Abandon_Instantiation (Instantiation_Node);
- end if;
-
- Next (Temp_Formal);
- end loop;
+ Check_Overloaded_Formal_Subprogram (Formal);
end if;
-- If there is no corresponding actual, this may be case of
and then Partial_Parametrization
then
Process_Default (Formal);
+ if Nkind (I_Node) = N_Formal_Package_Declaration then
+ Check_Overloaded_Formal_Subprogram (Formal);
+ end if;
+
else
Append_To (Assoc,
Instantiate_Formal_Subprogram
Parent_Base := Base_Type (Parent_Type);
end if;
+ -- AI05-0115 : if this is a derivation from a private type in some
+ -- other scope that may lead to invisible components for the derived
+ -- type, mark it accordingly.
+
+ if Is_Private_Type (Parent_Type) then
+ if Scope (Parent_Type) = Scope (Derived_Type) then
+ null;
+
+ elsif In_Open_Scopes (Scope (Parent_Type))
+ and then In_Private_Part (Scope (Parent_Type))
+ then
+ null;
+
+ else
+ Set_Has_Private_Ancestor (Derived_Type);
+ end if;
+
+ else
+ Set_Has_Private_Ancestor
+ (Derived_Type, Has_Private_Ancestor (Parent_Type));
+ end if;
+
-- Before we start the previously documented transformations, here is
-- little fix for size and alignment of tagged types. Normally when we
-- derive type D from type P, we copy the size and alignment of P as the
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2011, 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- --
Osint.Fail
("-gnatZ is no longer supported: consider using --RTS=zcx");
+ -- Note on language version switches: whenever a new language
+ -- version switch is added, function Switch.Is_Language_Switch and
+ -- procedure Switch.M.Normalize_Compiler_Switches must be updated.
+
-- Processing for 83 switch
when '8' =>
Ptr := Ptr + 1;
end if;
+ -- -gnat12
+
+ when '1' =>
+ Last_Stored := First_Stored;
+ Storing (Last_Stored) := C;
+ Ptr := Ptr + 1;
+
+ if Ptr /= Max or else Switch_Chars (Ptr) /= '2' then
+
+ -- Invalid switch
+
+ Last := 0;
+ return;
+
+ else
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := '2';
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+ Ptr := Ptr + 1;
+ end if;
+
+ -- -gnat2005 -gnat2012
+
+ when '2' =>
+ if Ptr + 3 /= Max then
+ Last := 0;
+ return;
+
+ elsif Switch_Chars (Ptr + 1 .. Ptr + 3) = "005" then
+ Last_Stored := First_Stored + 3;
+ Storing (First_Stored .. Last_Stored) := "2005";
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+ Ptr := Max + 1;
+
+ elsif Switch_Chars (Ptr + 1 .. Ptr + 3) = "012" then
+ Last_Stored := First_Stored + 3;
+ Storing (First_Stored .. Last_Stored) := "2012";
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+ Ptr := Max + 1;
+
+ else
+
+ -- Invalid switch
+
+ Last := 0;
+ return;
+
+ end if;
+
-- -gnat83
when '8' =>
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
and then Switch_Chars (Ptr + 2 .. Ptr + 4) = "RTS"));
end Is_Front_End_Switch;
+ -------------------------
+ -- Is_Language_Switch --
+ -------------------------
+
+ function Is_Language_Switch (Switch_Chars : String) return Boolean is
+ Ptr : constant Positive := Switch_Chars'First;
+ begin
+ return Is_Switch (Switch_Chars)
+ and then
+ (Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat83"
+ or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat95"
+ or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat05"
+ or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat2005"
+ or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat12"
+ or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat2012");
+ end Is_Language_Switch;
+
----------------------------
-- Is_Internal_GCC_Switch --
----------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- Returns True iff Switch_Chars represents a front-end switch, i.e. it
-- starts with -I, -gnat or -?RTS.
+ function Is_Language_Switch (Switch_Chars : String) return Boolean;
+ -- Returns True iff Switch_Chars represents a language switch, i.e. it
+ -- specifies -gnat83/95/2005/2012.
+
function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents an internal GCC switch to be
-- followed by a single argument, such as -dumpbase, --param or -auxbase.
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2011, 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- --
end if;
when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
+ if SwP + 2 > Arg'Last then
Put (Standard_Error,
"missing file for: ");
Put_Line (Standard_Error, Arg.all);
projects / gcc.git / commitdiff