+2009-04-17 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Add documentation about No_Streams restriction
+
+ * sem_attr.adb (Check_Stream_Attribute): Exclude implicit stream
+ attributes when checking No_Streams restriction.
+
+2009-04-17 Thomas Quinot <quinot@adacore.com>
+
+ * rtsfind.ads (RE_Request_Destroy): New PolyORB s-parint entity.
+
+ * exp_dist.adb (PolyORB_Support.Build_General_Calling_Stubs): Add
+ missing calls to RE_Request_Destroy to deallocate request objects after
+ use.
+
+2009-04-17 Nicolas Setton <setton@adacore.com>
+
+ * link.c: Fix support for passing a response file under Darwin.
+
+2009-04-17 Emmanuel Briot <briot@adacore.com>
+
+ * prj.adb (Free): new subprogram.
+
+2009-04-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb: additional initialization on incomplete subtypes.
+
+ * sem_ch6.adb (Process_Formals): if the subprogram is in the private
+ part and one of the formals is an incomplete tagged type, attach to
+ list of private dependends of the type for later validation.
+
+ * sem_ch7.adb (Uninstall_Declarations): diagnose attempts to declare
+ primitive operations of a Taft-amendmment type.
+
+ * freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
+ type. The check is performed on package exit, possibly after the
+ subprogram is frozen.
+
+2009-04-17 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb (Get_Directories): Get the object and exec directory
+ before looking for source directories, but make sure that there are nil
+ if they are not explicitely declared and there is explicitely no
+ sources in the project.
+
2009-04-17 Pascal Obry <obry@adacore.com>
* initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows.
is
Loc : constant Source_Ptr := Sloc (Nod);
+ Request : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ -- The request object constructed by these stubs
+ -- Could we use Name_R instead??? (see GLADE client stubs)
+
+ function Make_Request_RTE_Call
+ (RE : RE_Id;
+ Actuals : List_Id := New_List) return Node_Id;
+ -- Generate a procedure call statement calling RE with the given
+ -- actuals. Request is appended to the list.
+
+ ---------------------------
+ -- Make_Request_RTE_Call --
+ ---------------------------
+
+ function Make_Request_RTE_Call
+ (RE : RE_Id;
+ Actuals : List_Id := New_List) return Node_Id
+ is
+ begin
+ Append_To (Actuals, New_Occurrence_Of (Request, Loc));
+ return Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE), Loc),
+ Parameter_Associations => Actuals);
+ end Make_Request_RTE_Call;
+
Arguments : Node_Id;
-- Name of the named values list used to transmit parameters
-- to the remote package
- Request : Node_Id;
- -- The request object constructed by these stubs
-
Result : Node_Id;
-- Name of the result named value (in non-APC cases) which get the
-- result of the remote subprogram.
-- after the regular statements for writing out parameters.
After_Statements : constant List_Id := New_List;
- -- Statements to be executed after call returns (to assign
- -- in out or out parameter values).
+ -- Statements to be executed after call returns (to assign IN OUT or
+ -- OUT parameter values).
Etyp : Entity_Id;
-- The type of the formal parameter being processed
begin
-- ??? document general form of stub subprograms for the PolyORB case
- Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Append_List_To (Statements, Extra_Formal_Statements);
Append_To (Statements,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Request_Create), Loc),
-
- Parameter_Associations => New_List (
- Target_Object,
- Subprogram_Id,
- New_Occurrence_Of (Arguments, Loc),
- New_Occurrence_Of (Result, Loc),
- New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
-
- Append_To (Parameter_Associations (Last (Statements)),
- New_Occurrence_Of (Request, Loc));
+ Make_Request_RTE_Call (RE_Request_Create, New_List (
+ Target_Object,
+ Subprogram_Id,
+ New_Occurrence_Of (Arguments, Loc),
+ New_Occurrence_Of (Result, Loc),
+ New_Occurrence_Of
+ (RTE (RE_Nil_Exc_List), Loc))));
pragma Assert
(not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
Expressions => New_List (Asynchronous_P)));
- Append_To (Statements,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Request, Loc))));
+ Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
- Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
- Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
+ -- Asynchronous case
- if not Is_Known_Asynchronous then
+ if not Is_Known_Non_Asynchronous then
+ Asynchronous_Statements :=
+ New_List (Make_Request_RTE_Call (RE_Request_Destroy));
+ end if;
+ -- Non-asynchronous case
+
+ if not Is_Known_Asynchronous then
-- Reraise an exception occurrence from the completed request.
-- If the exception occurrence is empty, this is a no-op.
- Append_To (Non_Asynchronous_Statements,
+ Non_Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
if Is_Function then
+ Append_To (Non_Asynchronous_Statements,
+ Make_Request_RTE_Call (RE_Request_Destroy));
+
-- If this is a function call, read the value and return it
Append_To (Non_Asynchronous_Statements,
Prefix => Result,
Selector_Name => Name_Argument),
Decls))));
+
+ else
+
+ -- Case of a procedure: deal with IN OUT and OUT formals
+
+ Append_List_To (Non_Asynchronous_Statements, After_Statements);
+
+ Append_To (Non_Asynchronous_Statements,
+ Make_Request_RTE_Call (RE_Request_Destroy));
end if;
end if;
- Append_List_To (Non_Asynchronous_Statements, After_Statements);
-
if Is_Known_Asynchronous then
Append_List_To (Statements, Asynchronous_Statements);
Error_Msg_Qual_Level := 0;
end if;
- -- Ada 2005 (AI-326): Check wrong use of tag incomplete
- -- types with unknown discriminants. For example:
-
- -- type T (<>) is tagged;
- -- procedure P (X : access T); -- ERROR
- -- procedure P (X : T); -- ERROR
-
if not From_With_Type (F_Type) then
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
- if Ekind (F_Type) = E_Incomplete_Type
- and then Is_Tagged_Type (F_Type)
- and then not Is_Class_Wide_Type (F_Type)
- and then No (Full_View (F_Type))
- and then Unknown_Discriminants_Present
- (Parent (F_Type))
- and then No (Stored_Constraint (F_Type))
- then
- Error_Msg_N
- ("(Ada 2005): invalid use of unconstrained tagged"
- & " incomplete type", E);
-
-- If the formal is an anonymous_access_to_subprogram
-- freeze the subprogram type as well, to prevent
-- scope anomalies in gigi, because there is no other
-- clear point at which it could be frozen.
- elsif Is_Itype (Etype (Formal))
+ if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
then
Freeze_And_Append (F_Type, Loc, Result);
Next_Formal (Formal);
end loop;
- -- Case of function
+ -- Case of function: similar checks on return type.
if Ekind (E) = E_Function then
end if;
end if;
- if Is_Array_Type (Etype (E))
- and then not Is_Constrained (Etype (E))
+ if Is_Array_Type (R_Type)
+ and then not Is_Constrained (R_Type)
and then not Is_Imported (E)
and then Has_Foreign_Convention (E)
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (Etype (E))
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?foreign convention function& should not " &
"return unconstrained array!", E);
-
- -- Ada 2005 (AI-326): Check wrong use of
- -- incomplete type
-
- -- type T; -- tagged or just incomplete.
- -- function F (X : Boolean) return T; -- ERROR
-
- -- The type must be declared in the current scope for the
- -- use to be legal, and the full view must be available
- -- when the construct that mentions it is frozen.
-
- elsif Ekind (Etype (E)) = E_Incomplete_Type
- and then No (Full_View (Etype (E)))
- and then not Is_Value_Type (Etype (E))
- then
- Error_Msg_NE
- ("invalid use of incomplete type&", E, Etype (E));
end if;
end if;
end;
as long as no actual stream objects are created and no
stream attributes are used.
+Note that the use of restriction allows optimization of tagged types,
+since they do not need to worry about dispatching stream operations.
+To take maximum advantage of this space-saving optimization, any
+unit declaring a tagged type should be compiled with the restriction,
+though this is not required.
+
@item No_Task_Attributes_Package
@findex No_Task_Attributes_Package
This restriction ensures at compile time that there are no implicit or
const char *__gnat_object_library_extension = ".a";
#elif defined (__APPLE__)
-const char *__gnat_object_file_option = "";
+const char *__gnat_object_file_option = "-Wl,-filelist,";
const char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 262144;
unsigned char __gnat_objlist_file_supported = 1;
-unsigned char __gnat_using_gnu_linker = 1;
+unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (linux) || defined(__GLIBC__)
Util.Value_Of
(Name_Source_Files, Data.Decl.Attributes, In_Tree);
+ Languages : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Name_Languages, Data.Decl.Attributes, In_Tree);
+
Last_Source_Dir : String_List_Id := Nil_String;
procedure Find_Source_Dirs
Write_Line ("Starting to look for directories");
end if;
- -- We set the object directory to its default. It may be set to nil, if
- -- there is no sources in the project.
-
- Data.Object_Directory := Data.Directory;
-
- -- Look for the source directories
-
- if Current_Verbosity = High then
- Write_Line ("Starting to look for source directories");
- end if;
-
- pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list");
+ -- Set the object directory to its default which may be nil, if there
+ -- is no sources in the project.
- if (not Source_Files.Default) and then
- Source_Files.Values = Nil_String
+ if (((not Source_Files.Default)
+ and then Source_Files.Values = Nil_String)
+ or else
+ ((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String)
+ or else
+ ((not Languages.Default) and then Languages.Values = Nil_String))
+ and then Data.Extends = No_Project
then
- Data.Source_Dirs := Nil_String;
-
- if Data.Qualifier = Standard then
- Error_Msg
- (Project,
- In_Tree,
- "a standard project cannot have no sources",
- Source_Files.Location);
- end if;
-
- if Data.Extends = No_Project
- and then Data.Object_Directory = Data.Directory
- then
- Data.Object_Directory := No_Path_Information;
- end if;
-
- elsif Source_Dirs.Default then
-
- -- No Source_Dirs specified: the single source directory is the one
- -- containing the project file
-
- String_Element_Table.Increment_Last
- (In_Tree.String_Elements);
- Data.Source_Dirs := String_Element_Table.Last
- (In_Tree.String_Elements);
- In_Tree.String_Elements.Table (Data.Source_Dirs) :=
- (Value => Name_Id (Data.Directory.Name),
- Display_Value => Name_Id (Data.Directory.Display_Name),
- Location => No_Location,
- Flag => False,
- Next => Nil_String,
- Index => 0);
-
- if Current_Verbosity = High then
- Write_Line ("Single source directory:");
- Write_Str (" """);
- Write_Str (Get_Name_String (Data.Directory.Display_Name));
- Write_Line ("""");
- end if;
-
- elsif Source_Dirs.Values = Nil_String then
- if Data.Qualifier = Standard then
- Error_Msg
- (Project,
- In_Tree,
- "a standard project cannot have no source directories",
- Source_Dirs.Location);
- end if;
-
- -- If Source_Dirs is an empty string list, this means that this
- -- project contains no source. For projects that don't extend other
- -- projects, this also means that there is no need for an object
- -- directory, if not specified.
-
- if Data.Extends = No_Project
- and then Data.Object_Directory = Data.Directory
- then
- Data.Object_Directory := No_Path_Information;
- end if;
-
- Data.Source_Dirs := Nil_String;
+ Data.Object_Directory := No_Path_Information;
else
- declare
- Source_Dir : String_List_Id;
- Element : String_Element;
-
- begin
- -- Process the source directories for each element of the list
-
- Source_Dir := Source_Dirs.Values;
- while Source_Dir /= Nil_String loop
- Element := In_Tree.String_Elements.Table (Source_Dir);
- Find_Source_Dirs
- (File_Name_Type (Element.Value), Element.Location);
- Source_Dir := Element.Next;
- end loop;
- end;
- end if;
-
- if not Excluded_Source_Dirs.Default
- and then Excluded_Source_Dirs.Values /= Nil_String
- then
- declare
- Source_Dir : String_List_Id;
- Element : String_Element;
-
- begin
- -- Process the source directories for each element of the list
-
- Source_Dir := Excluded_Source_Dirs.Values;
- while Source_Dir /= Nil_String loop
- Element := In_Tree.String_Elements.Table (Source_Dir);
- Find_Source_Dirs
- (File_Name_Type (Element.Value),
- Element.Location,
- Removed => True);
- Source_Dir := Element.Next;
- end loop;
- end;
- end if;
-
- if Current_Verbosity = High then
- Write_Line ("Putting source directories in canonical cases");
+ Data.Object_Directory := Data.Directory;
end if;
- declare
- Current : String_List_Id := Data.Source_Dirs;
- Element : String_Element;
-
- begin
- while Current /= Nil_String loop
- Element := In_Tree.String_Elements.Table (Current);
- if Element.Value /= No_Name then
- if not Osint.File_Names_Case_Sensitive then
- Get_Name_String (Element.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Element.Value := Name_Find;
- end if;
-
- In_Tree.String_Elements.Table (Current) := Element;
- end if;
-
- Current := Element.Next;
- end loop;
- end;
-
-- Check the object directory
- pragma Assert (Object_Dir.Kind = Single,
- "Object_Dir is not a single string");
-
if Object_Dir.Value /= Empty_String then
Get_Name_String (Object_Dir.Value);
-- Check the exec directory
- pragma Assert (Exec_Dir.Kind = Single,
- "Exec_Dir is not a single string");
-
-- We set the object directory to its default
Data.Exec_Directory := Data.Object_Directory;
Write_Line ("""");
end if;
end if;
+
+ -- Look for the source directories
+
+ if Current_Verbosity = High then
+ Write_Line ("Starting to look for source directories");
+ end if;
+
+ pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list");
+
+ if (not Source_Files.Default) and then
+ Source_Files.Values = Nil_String
+ then
+ Data.Source_Dirs := Nil_String;
+
+ if Data.Qualifier = Standard then
+ Error_Msg
+ (Project,
+ In_Tree,
+ "a standard project cannot have no sources",
+ Source_Files.Location);
+ end if;
+
+ elsif Source_Dirs.Default then
+
+ -- No Source_Dirs specified: the single source directory is the one
+ -- containing the project file
+
+ String_Element_Table.Increment_Last
+ (In_Tree.String_Elements);
+ Data.Source_Dirs := String_Element_Table.Last
+ (In_Tree.String_Elements);
+ In_Tree.String_Elements.Table (Data.Source_Dirs) :=
+ (Value => Name_Id (Data.Directory.Name),
+ Display_Value => Name_Id (Data.Directory.Display_Name),
+ Location => No_Location,
+ Flag => False,
+ Next => Nil_String,
+ Index => 0);
+
+ if Current_Verbosity = High then
+ Write_Line ("Single source directory:");
+ Write_Str (" """);
+ Write_Str (Get_Name_String (Data.Directory.Display_Name));
+ Write_Line ("""");
+ end if;
+
+ elsif Source_Dirs.Values = Nil_String then
+ if Data.Qualifier = Standard then
+ Error_Msg
+ (Project,
+ In_Tree,
+ "a standard project cannot have no source directories",
+ Source_Dirs.Location);
+ end if;
+
+ Data.Source_Dirs := Nil_String;
+
+ else
+ declare
+ Source_Dir : String_List_Id;
+ Element : String_Element;
+
+ begin
+ -- Process the source directories for each element of the list
+
+ Source_Dir := Source_Dirs.Values;
+ while Source_Dir /= Nil_String loop
+ Element := In_Tree.String_Elements.Table (Source_Dir);
+ Find_Source_Dirs
+ (File_Name_Type (Element.Value), Element.Location);
+ Source_Dir := Element.Next;
+ end loop;
+ end;
+ end if;
+
+ if not Excluded_Source_Dirs.Default
+ and then Excluded_Source_Dirs.Values /= Nil_String
+ then
+ declare
+ Source_Dir : String_List_Id;
+ Element : String_Element;
+
+ begin
+ -- Process the source directories for each element of the list
+
+ Source_Dir := Excluded_Source_Dirs.Values;
+ while Source_Dir /= Nil_String loop
+ Element := In_Tree.String_Elements.Table (Source_Dir);
+ Find_Source_Dirs
+ (File_Name_Type (Element.Value),
+ Element.Location,
+ Removed => True);
+ Source_Dir := Element.Next;
+ end loop;
+ end;
+ end if;
+
+ if Current_Verbosity = High then
+ Write_Line ("Putting source directories in canonical cases");
+ end if;
+
+ declare
+ Current : String_List_Id := Data.Source_Dirs;
+ Element : String_Element;
+
+ begin
+ while Current /= Nil_String loop
+ Element := In_Tree.String_Elements.Table (Current);
+ if Element.Value /= No_Name then
+ if not Osint.File_Names_Case_Sensitive then
+ Get_Name_String (Element.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Element.Value := Name_Find;
+ end if;
+
+ In_Tree.String_Elements.Table (Current) := Element;
+ end if;
+
+ Current := Element.Next;
+ end loop;
+ end;
end Get_Directories;
---------------
-- Table to store the path name of all the created temporary files, so that
-- they can be deleted at the end, or when the program is interrupted.
+ procedure Free (Project : in out Project_Data);
+ -- Free memory allocated for Project
+
-------------------
-- Add_To_Buffer --
-------------------
-- Free --
----------
+ procedure Free (Project : in out Project_Data) is
+ begin
+ Free (Project.Dir_Path);
+ Free (Project.Include_Path);
+ Free (Project.Ada_Include_Path);
+ Free (Project.Objects_Path);
+ Free (Project.Ada_Objects_Path);
+ end Free;
+
+ ----------
+ -- Free --
+ ----------
+
procedure Free (Tree : in out Project_Tree_Ref) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Project_Tree_Data, Project_Tree_Ref);
Array_Table.Free (Tree.Arrays);
Package_Table.Free (Tree.Packages);
Project_List_Table.Free (Tree.Project_Lists);
- Project_Table.Free (Tree.Projects);
Source_Data_Table.Free (Tree.Sources);
Alternate_Language_Table.Free (Tree.Alt_Langs);
Unit_Table.Free (Tree.Units);
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
+ for P in Project_Table.First ..
+ Project_Table.Last (Tree.Projects)
+ loop
+ Free (Tree.Projects.Table (P));
+ end loop;
+ Project_Table.Free (Tree.Projects);
+
-- Private part
Naming_Table.Free (Tree.Private_Part.Namings);
Array_Table.Init (Tree.Arrays);
Package_Table.Init (Tree.Packages);
Project_List_Table.Init (Tree.Project_Lists);
- Project_Table.Init (Tree.Projects);
Source_Data_Table.Init (Tree.Sources);
Alternate_Language_Table.Init (Tree.Alt_Langs);
Unit_Table.Init (Tree.Units);
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
+ if not Project_Table."=" (Tree.Projects.Table, null) then
+ for P in Project_Table.First ..
+ Project_Table.Last (Tree.Projects)
+ loop
+ Free (Tree.Projects.Table (P));
+ end loop;
+ end if;
+ Project_Table.Init (Tree.Projects);
+
-- Private part table
Naming_Table.Init (Tree.Private_Part.Namings);
RE_Request_Arguments, -- System.Partition_Interface
RE_Request_Set_Out, -- System.Partition_Interface
RE_Request_Raise_Occurrence, -- System.Partition_Interface
+ RE_Request_Destroy, -- System.Partition_Interface
RE_Nil_Exc_List, -- System.Partition_Interface
RE_Servant, -- System.Partition_Interface
RE_Move_Any_Value, -- System.Partition_Interface
RE_Request_Arguments => System_Partition_Interface,
RE_Request_Set_Out => System_Partition_Interface,
RE_Request_Raise_Occurrence => System_Partition_Interface,
+ RE_Request_Destroy => System_Partition_Interface,
RE_Nil_Exc_List => System_Partition_Interface,
RE_Servant => System_Partition_Interface,
RE_Move_Any_Value => System_Partition_Interface,
-- Check restriction violations
- Check_Restriction (No_Streams, P);
+ -- First check the No_Streams restriction, which prohibits the use
+ -- of explicit stream attributes in the source program. We do not
+ -- prevent the occurrence of stream attributes in generated code,
+ -- for instance those generated implicitly for dispatching purposes.
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Streams, P);
+ end if;
+
+ -- Check special case of Exception_Id and Exception_Occurrence which
+ -- are not allowed for restriction No_Exception_Regstriation.
if Is_RTE (P_Type, RE_Exception_Id)
or else
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Address_Of_Intrinsic));
+
else
Error_Msg_N
("cannot take Address of intrinsic subprogram", N);
Set_Etype (Derived_Type, Parent_Base);
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
- Set_Size_Info (Derived_Type, Parent_Type);
- Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
- Set_Convention (Derived_Type, Convention (Parent_Type));
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
+ Set_Size_Info (Derived_Type, Parent_Type);
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+ Set_Convention (Derived_Type, Convention (Parent_Type));
+ Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
+ Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
-- The derived type inherits the representation clauses of the parent.
-- However, for a private type that is completed by a derivation, there
Error_Msg_NE (
"full declaration of } must be a record extension",
Prev, Id);
+
+ -- Set some attributes to produce a usable full view.
+
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
end if;
E_Incomplete_Type =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
+
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
Set_Private_Dependents (Def_Id, New_Elmt_List);
(Is_Class_Wide_Type (Formal_Type)
and then Is_Incomplete_Type (Root_Type (Formal_Type)))
then
- -- Ada 2005 (AI-326): Tagged incomplete types allowed
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed in
+ -- primitive operations, as long as their completion is
+ -- in the same declarative part. If in the private part
+ -- this means that the type cannot be a Taft-amendment type.
+ -- Check is done on package exit.
if Is_Tagged_Type (Formal_Type) then
- null;
+ if Ekind (Scope (Current_Scope)) = E_Package
+ and then In_Private_Part (Scope (Current_Scope))
+ and then not From_With_Type (Formal_Type)
+ and then not Is_Class_Wide_Type (Formal_Type)
+ then
+ Append_Elmt
+ (Current_Scope,
+ Private_Dependents (Base_Type (Formal_Type)));
+ end if;
-- Special handling of Value_Type for CIL case
end if;
elsif Ekind (Id) = E_Incomplete_Type
+ and then Comes_From_Source (Id)
and then No (Full_View (Id))
then
- -- Mark Taft amendment types
+
+ -- Mark Taft amendment types. Verify that there are no
+ -- primitive operations declared for the type (3.10.1 (9)).
Set_Has_Completion_In_Body (Id);
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Private_Dependents (Id));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ if Is_Overloadable (Subp) then
+ Error_Msg_NE
+ ("type& must be completed in the private part",
+ Parent (Subp), Id);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+
elsif not Is_Child_Unit (Id)
and then (not Is_Private_Type (Id)
or else No (Full_View (Id)))
projects / thirdparty / gcc.git / commitdiff
