+2004-08-13 Olivier Hainque <hainque@act-europe.fr>
+
+ * decl.c (gnat_to_gnu_entity) <E_Variable>: When building an allocator
+ for a global aliased object with a variable size and an unconstrained
+ nominal subtype, pretend there is no initializer if the one we have is
+ incomplete, and avoid referencing an inexistant component in there. The
+ part we have will be rebuilt anyway and the reference may confuse
+ further operations.
+
+2004-08-13 Thomas Quinot <quinot@act-europe.fr>
+
+ * einfo.ads: Minor reformatting
+
+ * lib-writ.adb (Output_Main_Program_Line): Do not set parameter
+ restrictions in the ALI if we only want to warn about violations.
+
+2004-08-13 Vincent Celier <celier@gnat.com>
+
+ * ali.adb (Scan_ALI): Initialize component Body_Needed_For_SAL to False
+ when creating a new Unit_Record in table Units.
+
+ * gnatls.adb (Output_Unit): In verbose mode, output the restrictions
+ that are violated, if any.
+
+ * prj-nmsc.adb (Ada_Check.Get_Path_Names_And_Record_Sources): Do not
+ add directory separator if path already ends with a directory separator.
+
+2004-08-13 Ed Schonberg <schonberg@gnat.com>
+
+ * rtsfind.adb (Entity_Not_Defined): If the error ocurrs in a predefined
+ unit, this is an attempt to inline a construct that is not available in
+ the current restricted mode, so abort rather than trying to continue.
+
+ * sem_ch3.adb (Build_Underlying_Full_View): If the new type has
+ discriminants that rename those of the parent, recover names of
+ original discriminants for the constraint on the full view of the
+ parent.
+ (Complete_Private_Subtype): Do not create a subtype declaration if the
+ subtype is an itype.
+
+ * gnat_rm.texi: Added section on implementation of discriminated
+ records with default values for discriminants.
+
+2004-08-13 Ed Schonberg <schonberg@gnat.com>
+
+ PR ada/15601
+ * sem_res.adb (Make_Call_Into_Operator): Handle properly the case where
+ the second operand is overloaded.
+
2004-08-10 Richard Henderson <rth@redhat.com>
* utils.c (gnat_install_builtins): Remove __builtin_stack_alloc,
Units.Table (Units.Last).First_Arg := First_Arg;
Units.Table (Units.Last).Elab_Position := 0;
Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface;
+ Units.Table (Units.Last).Body_Needed_For_SAL := False;
if Debug_Flag_U then
Write_Str (" ----> reading unit ");
used_by_ref = true;
const_flag = true;
- /* Get the data part of GNU_EXPR in case this was a
- aliased object whose nominal subtype is unconstrained.
- In that case the pointer above will be a thin pointer and
- build_allocator will automatically make the template and
- constructor already made above. */
+ /* In case this was a aliased object whose nominal subtype is
+ unconstrained, the pointer above will be a thin pointer and
+ build_allocator will automatically make the template.
+
+ If we have a template initializer only (that we made above),
+ pretend there is none and rely on what build_allocator creates
+ again anyway. Otherwise (if we have a full initializer), get
+ the data part and feed that to build_allocator. */
if (definition)
{
{
gnu_alloc_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
- gnu_expr
- = build_component_ref
- (gnu_expr, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
- false);
+
+ if (TREE_CODE (gnu_expr) == CONSTRUCTOR
+ &&
+ TREE_CHAIN (CONSTRUCTOR_ELTS (gnu_expr)) == NULL_TREE)
+ gnu_expr = 0;
+ else
+ gnu_expr
+ = build_component_ref
+ (gnu_expr, NULL_TREE,
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
+ false);
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
-- Present in private subtypes that are the completion of other private
-- types, or in private types that are derived from private subtypes.
-- If the full view of a private type T is derived from another
--- private type with discriminants Td, the full view of T is also
+-- private type with discriminants Td, the full view of T is also
-- private, and there is no way to attach to it a further full view that
-- would convey the structure of T to the back end. The Underlying_Full_
-- View is an attribute of the full view that is a subtype of Td with
* GNAT Implementation of Tasking::
* GNAT Implementation of Shared Passive Packages::
* Code Generation for Array Aggregates::
+* The Size of Discriminated Records with Default Discriminants::
Project File Reference
* GNAT Implementation of Tasking::
* GNAT Implementation of Shared Passive Packages::
* Code Generation for Array Aggregates::
+* The Size of Discriminated Records with Default Discriminants::
@end menu
@node Machine Code Insertions
a temporary (created either by the front-end or the code generator) and then
that temporary will be copied onto the target.
+
+@node The Size of Discriminated Records with Default Discriminants
+@section The Size of Discriminated Records with Default Discriminants
+
+@noindent
+If a discriminated type @code{T} has discriminants with default values, it is
+possible to declare an object of this type without providing an explicit
+constraint:
+
+@smallexample @c ada
+@group
+type Size is range 1..100;
+
+type Rec (D : Size := 15) is record
+ Name : String (1..D);
+end T;
+
+Word : Rec;
+@end group
+@end smallexample
+
+@noindent
+Such an object is said to be @emph{unconstrained}.
+The discriminant of the object
+can be modified by a full assignment to the object, as long as it preserves the
+relation between the value of the discriminant, and the value of the components
+that depend on it:
+
+@smallexample @c ada
+@group
+Word := (3, "yes");
+
+Word := (5, "maybe");
+
+Word := (5, "no"); -- raises Constraint_Error
+@end group
+@end smallexample
+
+@noindent
+In order to support this behavior efficiently, an unconstrained object is
+given the maximum size that any value of the type requires. In the case
+above, @code{Word} has storage for the discriminant and for
+a @code{String} of length 100.
+It is important to note that unconstrained objects do not require dynamic
+allocation. It would be an improper implementation to place on the heap those
+components whose size depends on discriminants. (This improper implementation
+was used by some Ada83 compilers, where the @code{Name} component above
+would have
+been stored as a pointer to a dynamic string). Following the principle that
+dynamic storage management should never be introduced implicitly,
+an Ada95 compiler should reserve the full size for an unconstrained declared
+object, and place it on the stack.
+
+This maximum size approach
+has been a source of surprise to some users, who expect the default
+values of the discriminants to determine the size reserved for an
+unconstrained object: ``If the default is 15, why should the object occupy
+a larger size?''
+The answer, of course, is that the discriminant may be later modified,
+and its full range of values must be taken into account. This is why the
+declaration:
+
+@smallexample
+@group
+type Rec (D : Positive := 15) is record
+ Name : String (1..D);
+end record;
+
+Too_Large : Rec;
+@end group
+@end smallexample
+
+@noindent
+is flagged by the compiler with a warning:
+an attempt to create @code{Too_Large} will raise @code{Storage_Error},
+because the required size includes @code{Positive'Last}
+bytes. As the first example indicates, the proper approach is to declare an
+index type of ``reasonable'' range so that unconstrained objects are not too
+large.
+
+One final wrinkle: if the object is declared to be @code{aliased}, or if it is
+created in the heap by means of an allocator, then it is @emph{not}
+unconstrained:
+it is constrained by the default values of the discriminants, and those values
+cannot be modified by full assignment. This is because in the presence of
+aliasing all views of the object (which may be manipulated by different tasks,
+say) must be consistent, so it is imperative that the object, once created,
+remain invariant.
+
+
+
+
@node Project File Reference
@chapter Project File Reference
else
Write_Str ("Unit => ");
- Write_Eol; Write_Str (" Name => ");
+ Write_Eol;
+ Write_Str (" Name => ");
Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Eol; Write_Str (" Kind => ");
+ Write_Eol;
+ Write_Str (" Kind => ");
if Units.Table (U_Id).Unit_Kind = 'p' then
Write_Str ("package ");
U.Body_Needed_For_SAL or
U.Elaborate_Body
then
- Write_Eol; Write_Str (" Flags =>");
+ Write_Eol;
+ Write_Str (" Flags =>");
if U.Preelab then
Write_Str (" Preelaborable");
-- Display these restrictions.
if Restrictions.Set /= (All_Restrictions => False) then
- Write_Eol; Write_Str (" Restrictions =>");
+ Write_Eol;
+ Write_Str (" pragma Restrictions =>");
-- For boolean restrictions, just display the name of the
-- restriction; for valued restrictions, also display the
end if;
end loop;
end if;
+
+ -- If the unit violates some Restrictions, display the list of
+ -- these restrictions.
+
+ if Restrictions.Violated /= (All_Restrictions => False) then
+ Write_Eol;
+ Write_Str (" Restrictions violated =>");
+
+ -- For boolean restrictions, just display the name of the
+ -- restriction; for valued restrictions, also display the
+ -- restriction value.
+
+ for Restriction in All_Restrictions loop
+ if Restrictions.Violated (Restriction) then
+ Write_Eol;
+ Write_Str (" ");
+ Write_Str (Image (Restriction));
+
+ if Restriction in All_Parameter_Restrictions then
+ if Restrictions.Count (Restriction) > 0 then
+ Write_Str (" =>");
+
+ if Restrictions.Unknown (Restriction) then
+ Write_Str (" at least");
+ end if;
+
+ Write_Str (Restrictions.Count (Restriction)'Img);
+ end if;
+ end if;
+ end if;
+ end loop;
+ end if;
end;
end if;
if Print_Source then
if Too_Long then
- Write_Eol; Write_Str (" ");
+ Write_Eol;
+ Write_Str (" ");
else
Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End));
end if;
-- And now the information for the parameter restrictions
for RP in All_Parameter_Restrictions loop
- if Main_Restrictions.Set (RP) then
+ if Main_Restrictions.Set (RP)
+ and then not Restriction_Warnings (RP)
+ then
Write_Info_Char ('r');
Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
else
with Hostparm;
with MLib.Tgt;
with Namet; use Namet;
-with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with MLib.Tgt; use MLib.Tgt;
-- a spec suffix, a body suffix or a separate suffix.
procedure Locate_Directory
- (Name : Name_Id;
- Parent : Name_Id;
- Dir : out Name_Id;
- Display : out Name_Id;
- Project : Project_Id := No_Project;
- Kind : String := "";
- Location : Source_Ptr := No_Location);
- -- Locate a directory. Dir is the canonical path name. Display is the
- -- path name for display purpose.
- -- When the directory does not exist, Setup_Projects is True and Kind is
- -- not the empty string, an attempt is made to create the directory.
- -- Returns No_Name in Dir and Display if directory does not exist or
- -- cannot be created.
+ (Name : Name_Id;
+ Parent : Name_Id;
+ Dir : out Name_Id;
+ Display : out Name_Id);
+ -- Locate a directory (returns No_Name for Dir and Display if directory
+ -- does not exist). Name is the directory name. Parent is the root
+ -- directory, if Name is a relative path name. Dir is the canonical case
+ -- path name of the directory, Display is the directory path name for
+ -- display purposes.
function Path_Name_Of
(File_Name : Name_Id;
Source_Names.Set (Canonical_Name, NL);
Name_Len := Dir_Path'Length;
Name_Buffer (1 .. Name_Len) := Dir_Path;
- Add_Char_To_Name_Buffer (Directory_Separator);
+
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ end if;
+
Add_Str_To_Name_Buffer (Name_Str (1 .. Last));
Path := Name_Find;
-- the object directory or one of the source directories.
-- This is the directory where copies of the interface
-- sources will be copied. Note that this directory may be
- -- the library directory. If setting up projects (gnat setup)
- -- and the directory does not exist, attempt to create it.
+ -- the library directory.
if Lib_Src_Dir.Value /= Empty_String then
declare
Locate_Directory
(Dir_Id, Data.Display_Directory,
Data.Library_Src_Dir,
- Data.Display_Library_Src_Dir,
- Project => Project,
- Kind => "library interface copy",
- Location => Lib_Src_Dir.Location);
+ Data.Display_Library_Src_Dir);
- -- If directory does not exist, report an error. No need
- -- to do that if Setup_Projects is True, as an error
- -- has already been reported by Locate_Directory.
+ -- If directory does not exist, report an error
- if not Setup_Projects
- and then Data.Library_Src_Dir = No_Name
- then
+ if Data.Library_Src_Dir = No_Name then
-- Get the absolute name of the library directory
-- that does not exist, to report an error.
end if;
if For_Language = Lang_Ada then
-
- -- If we have looked for sources and found none, then it is an
- -- error, except if it is an extending project. If a non-extending
- -- project is not supposed to contain any source, then we never
- -- Find_Sources. No error is signalled when setting up projects
- -- using gnat setup.
+ -- If we have looked for sources and found none, then
+ -- it is an error, except if it is an extending project.
+ -- If a non extending project is not supposed to contain
+ -- any source, then we never call Find_Sources.
if Current_Source /= Nil_String then
Data.Ada_Sources_Present := True;
- elsif not Setup_Projects and then Data.Extends = No_Project then
+ elsif Data.Extends = No_Project then
Error_Msg
(Project,
"there are no Ada sources in this project",
Object_Dir.Location);
else
- -- Check that the specified object directory does exist, and
- -- attempt to create it if setting up projects (gnat setup).
+ -- We check that the specified object directory
+ -- does exist.
Locate_Directory
(Object_Dir.Value, Data.Display_Directory,
- Data.Object_Directory, Data.Display_Object_Dir,
- Project => Project, Kind => "object",
- Location => Object_Dir.Location);
+ Data.Object_Directory, Data.Display_Object_Dir);
- if not Setup_Projects
- and then Data.Object_Directory = No_Name
- then
+ if Data.Object_Directory = No_Name then
-- The object directory does not exist, report an error
-
Err_Vars.Error_Msg_Name_1 := Object_Dir.Value;
Error_Msg
(Project,
Data.Location);
-- Do not keep a nil Object_Directory. Set it to the
- -- specified (relative or absolute) path. This is for the
- -- benefit of tools that recover from errors. For example,
- -- these tools could create the non-existent directory.
+ -- specified (relative or absolute) path.
+ -- This is for the benefit of tools that recover from
+ -- errors; for example, these tools could create the
+ -- non existent directory.
Data.Display_Object_Dir := Object_Dir.Value;
Get_Name_String (Object_Dir.Value);
Exec_Dir.Location);
else
- -- We check that the specified exec directory does exist and
- -- attempt to create it if setting up projects (gnat setup).
+ -- We check that the specified object directory
+ -- does exist.
Locate_Directory
(Exec_Dir.Value, Data.Directory,
- Data.Exec_Directory, Data.Display_Exec_Dir,
- Project => Project, Kind => "exec",
- Location => Exec_Dir.Location);
+ Data.Exec_Directory, Data.Display_Exec_Dir);
- if not Setup_Projects
- and then Data.Exec_Directory = No_Name
- then
+ if Data.Exec_Directory = No_Name then
Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value;
Error_Msg
(Project,
elsif Source_Dirs.Values = Nil_String then
- -- If Source_Dirs is an empty string list, this means that this
- -- contains no sources. For projects that do not extend other
- -- projects, this also means that there is no need for an object
- -- directory unless one is specified explicitly.
+ -- 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
begin
-- If the project extended is a library project, we inherit
- -- the library name, if it is not redefined, we check that
- -- the library directory is specified, and we reset the
+ -- the library name, if it is not redefined; we check that
+ -- the library directory is specified; and we reset the
-- library flag for the extended project.
if Extended_Data.Library then
end if;
else
- -- Find path name, check that it is a directory, and attempt
- -- to create it if setting up projects (gnat setup).
+ -- Find path name, check that it is a directory
Locate_Directory
(Lib_Dir.Value, Data.Display_Directory,
- Data.Library_Dir, Data.Display_Library_Dir,
- Project => Project, Kind => "library",
- Location => Lib_Dir.Location);
+ Data.Library_Dir, Data.Display_Library_Dir);
- if not Setup_Projects and then Data.Library_Dir = No_Name then
+ if Data.Library_Dir = No_Name then
-- Get the absolute name of the library directory that
-- does not exist, to report an error.
-- Check Spec_Suffix
declare
- Spec_Suffixes : Array_Element_Id :=
- Util.Value_Of
- (Name_Spec_Suffix,
- Naming.Decl.Arrays);
+ Spec_Suffixs : Array_Element_Id :=
+ Util.Value_Of
+ (Name_Spec_Suffix,
+ Naming.Decl.Arrays);
Suffix : Array_Element_Id;
Element : Array_Element;
Suffix2 : Array_Element_Id;
begin
- -- If some suffixes have been specified, we make sure that
+ -- If some suffixs have been specified, we make sure that
-- for each language for which a default suffix has been
-- specified, there is a suffix specified, either the one
-- in the project file or if there were none, the default.
- if Spec_Suffixes /= No_Array_Element then
+ if Spec_Suffixs /= No_Array_Element then
Suffix := Data.Naming.Spec_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
- Suffix2 := Spec_Suffixes;
+ Suffix2 := Spec_Suffixs;
while Suffix2 /= No_Array_Element loop
exit when Array_Elements.Table (Suffix2).Index =
Suffix2 := Array_Elements.Table (Suffix2).Next;
end loop;
- -- There is a registered default suffix, but no suffix is
- -- specified in the project file. Add default to array.
+ -- There is a registered default suffix, but no
+ -- suffix specified in the project file.
+ -- Add the default to the array.
if Suffix2 = No_Array_Element then
Array_Elements.Increment_Last;
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
- Next => Spec_Suffixes);
- Spec_Suffixes := Array_Elements.Last;
+ Next => Spec_Suffixs);
+ Spec_Suffixs := Array_Elements.Last;
end if;
Suffix := Element.Next;
end loop;
- -- Put the resulting array as the specification suffixes
+ -- Put the resulting array as the specification suffixs
- Data.Naming.Spec_Suffix := Spec_Suffixes;
+ Data.Naming.Spec_Suffix := Spec_Suffixs;
end if;
end;
-- Check Body_Suffix
declare
- Impl_Suffixes : Array_Element_Id :=
- Util.Value_Of
- (Name_Body_Suffix, Naming.Decl.Arrays);
+ Impl_Suffixs : Array_Element_Id :=
+ Util.Value_Of
+ (Name_Body_Suffix,
+ Naming.Decl.Arrays);
Suffix : Array_Element_Id;
Element : Array_Element;
Suffix2 : Array_Element_Id;
begin
- -- If some suffixes have been specified, we make sure that
+ -- If some suffixs have been specified, we make sure that
-- for each language for which a default suffix has been
-- specified, there is a suffix specified, either the one
-- in the project file or if there were noe, the default.
- if Impl_Suffixes /= No_Array_Element then
+ if Impl_Suffixs /= No_Array_Element then
Suffix := Data.Naming.Body_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
- Suffix2 := Impl_Suffixes;
+ Suffix2 := Impl_Suffixs;
while Suffix2 /= No_Array_Element loop
exit when Array_Elements.Table (Suffix2).Index =
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
- Next => Impl_Suffixes);
- Impl_Suffixes := Array_Elements.Last;
+ Next => Impl_Suffixs);
+ Impl_Suffixs := Array_Elements.Last;
end if;
Suffix := Element.Next;
end loop;
- -- Put the resulting array as the implementation suffixes
+ -- Put the resulting array as the implementation suffixs
- Data.Naming.Body_Suffix := Impl_Suffixes;
+ Data.Naming.Body_Suffix := Impl_Suffixs;
end if;
end;
----------------------
procedure Locate_Directory
- (Name : Name_Id;
- Parent : Name_Id;
- Dir : out Name_Id;
- Display : out Name_Id;
- Project : Project_Id := No_Project;
- Kind : String := "";
- Location : Source_Ptr := No_Location)
+ (Name : Name_Id;
+ Parent : Name_Id;
+ Dir : out Name_Id;
+ Display : out Name_Id)
is
The_Name : constant String := Get_Name_String (Name);
The_Parent : constant String :=
The_Parent_Last : constant Natural :=
Compute_Directory_Last (The_Parent);
- procedure Create_Directory (Absolute_Path : String);
- -- Attempt to create a new directory
-
- procedure Get_Names_For (Absolute_Path : String);
- -- Create name ids Dir and Display for directory Absolute_Path
-
- ----------------------
- -- Create_Directory --
- ----------------------
-
- procedure Create_Directory (Absolute_Path : String) is
- begin
- -- Attempt to create the directory
-
- Make_Dir (Absolute_Path);
-
- -- Setup Dir and Display if creation was successful
-
- Get_Names_For (Absolute_Path);
-
- exception
- when Directory_Error =>
- Error_Msg
- (Project,
- "could not create " & Kind & " directory """ &
- Absolute_Path & """",
- Location);
- end Create_Directory;
-
- -------------------
- -- Get_Names_For --
- -------------------
-
- procedure Get_Names_For (Absolute_Path : String) is
- Normed : constant String :=
- Normalize_Pathname
- (Absolute_Path,
- Resolve_Links => False,
- Case_Sensitive => True);
-
- Canonical_Path : constant String :=
- Normalize_Pathname
- (Normed,
- Resolve_Links => True,
- Case_Sensitive => False);
-
- begin
- Name_Len := Normed'Length;
- Name_Buffer (1 .. Name_Len) := Normed;
- Display := Name_Find;
-
- Name_Len := Canonical_Path'Length;
- Name_Buffer (1 .. Name_Len) := Canonical_Path;
- Dir := Name_Find;
- end Get_Names_For;
-
- -- Start of processing for Locate_Directory
-
begin
if Current_Verbosity = High then
Write_Str ("Locate_Directory (""");
if Is_Absolute_Path (The_Name) then
if Is_Directory (The_Name) then
- Get_Names_For (The_Name);
+ declare
+ Normed : constant String :=
+ Normalize_Pathname
+ (The_Name,
+ Resolve_Links => False,
+ Case_Sensitive => True);
+
+ Canonical_Path : constant String :=
+ Normalize_Pathname
+ (Normed,
+ Resolve_Links => True,
+ Case_Sensitive => False);
- elsif Kind /= "" and then Setup_Projects then
- Create_Directory (The_Name);
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+
+ Name_Len := Canonical_Path'Length;
+ Name_Buffer (1 .. Name_Len) := Canonical_Path;
+ Dir := Name_Find;
+ end;
end if;
else
begin
if Is_Directory (Full_Path) then
- Get_Names_For (Full_Path);
+ declare
+ Normed : constant String :=
+ Normalize_Pathname
+ (Full_Path,
+ Resolve_Links => False,
+ Case_Sensitive => True);
+
+ Canonical_Path : constant String :=
+ Normalize_Pathname
+ (Normed,
+ Resolve_Links => True,
+ Case_Sensitive => False);
- elsif Kind /= "" and then Setup_Projects then
- Create_Directory (Full_Path);
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+
+ Name_Len := Canonical_Path'Length;
+ Name_Buffer (1 .. Name_Len) := Canonical_Path;
+ Dir := Name_Find;
+ end;
end if;
end;
end if;
procedure Entity_Not_Defined (Id : RE_Id) is
begin
if No_Run_Time_Mode then
- RTE_Error_Msg ("|construct not allowed in no run time mode");
+
+ -- If the error occurs when compiling the body of a predefined
+ -- unit for inlining purposes, the body must be illegal in this
+ -- mode, and there is no point in continuing.
+
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Sloc (Current_Error_Node))))
+ then
+ Error_Msg_N
+ ("construct not allowed in no run time mode!",
+ Current_Error_Node);
+ raise Unrecoverable_Error;
+
+ else
+ RTE_Error_Msg ("|construct not allowed in no run time mode");
+ end if;
+
elsif Configurable_Run_Time_Mode then
RTE_Error_Msg ("|construct not allowed in this configuration>");
else
C : Node_Id;
Id : Node_Id;
+ procedure Set_Discriminant_Name (Id : Node_Id);
+ -- If the derived type has discriminants, they may rename discriminants
+ -- of the parent. When building the full view of the parent, we need to
+ -- recover the names of the original discriminants if the constraint is
+ -- given by named associations.
+
+ ---------------------------
+ -- Set_Discriminant_Name --
+ ---------------------------
+
+ procedure Set_Discriminant_Name (Id : Node_Id) is
+ Disc : Entity_Id;
+
+ begin
+ Set_Original_Discriminant (Id, Empty);
+
+ if Has_Discriminants (Typ) then
+ Disc := First_Discriminant (Typ);
+
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Id)
+ and then Present (Corresponding_Discriminant (Disc))
+ then
+ Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
+ end if;
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ end Set_Discriminant_Name;
+
+ -- Start of processing for Build_Underlying_Full_View
+
begin
if Nkind (N) = N_Full_Type_Declaration then
Constr := Constraint (Subtype_Indication (Type_Definition (N)));
- -- ??? ??? is this assert right, I assume so otherwise Constr
- -- would not be defined below (this used to be an elsif)
-
- else pragma Assert (Nkind (N) = N_Subtype_Declaration);
+ elsif Nkind (N) = N_Subtype_Declaration then
Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
- end if;
- -- If the constraint has discriminant associations, the discriminant
- -- entity is already set, but it denotes a discriminant of the new
- -- type, not the original parent, so it must be found anew.
+ elsif Nkind (N) = N_Component_Declaration then
+ Constr :=
+ New_Copy_Tree
+ (Constraint (Subtype_Indication (Component_Definition (N))));
- C := First (Constraints (Constr));
+ else
+ raise Program_Error;
+ end if;
+ C := First (Constraints (Constr));
while Present (C) loop
-
if Nkind (C) = N_Discriminant_Association then
Id := First (Selector_Names (C));
-
while Present (Id) loop
- Set_Original_Discriminant (Id, Empty);
+ Set_Discriminant_Name (Id);
Next (Id);
end loop;
end if;
Next (C);
end loop;
- Indic := Make_Subtype_Declaration (Loc,
- Defining_Identifier => Subt,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (Par, Loc),
- Constraint => New_Copy_Tree (Constr)));
+ Indic :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Par, Loc),
+ Constraint => New_Copy_Tree (Constr)));
-- If this is a component subtype for an outer itype, it is not
-- a list member, so simply set the parent link for analysis: if
-- the enclosing type does not need to be in a declarative list,
-- neither do the components.
- if Is_List_Member (N) then
+ if Is_List_Member (N)
+ and then Nkind (N) /= N_Component_Declaration
+ then
Insert_Before (N, Indic);
else
Set_Parent (Indic, Parent (N));
(Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
-- If the full base is itself derived from private, build a congruent
- -- subtype of its underlying type, for use by the back end. Do not
- -- do this for a constrained record component, where the back-end has
- -- the proper information and there is no place for the declaration.
+ -- subtype of its underlying type, for use by the back end. For a
+ -- constrained record component, the declaration cannot be placed on
+ -- the component list, but it must neverthess be built an analyzed, to
+ -- supply enough information for gigi to compute the size of component.
elsif Ekind (Full_Base) in Private_Kind
and then Is_Derived_Type (Full_Base)
and then Has_Discriminants (Full_Base)
- and then Nkind (Related_Nod) /= N_Component_Declaration
and then (Ekind (Current_Scope) /= E_Record_Subtype)
- and then
- Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
then
- Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
+ if not Is_Itype (Priv)
+ and then
+ Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View
+ (Parent (Priv), Full, Etype (Full_Base));
+
+ elsif Nkind (Related_Nod) = N_Component_Declaration then
+ Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
+ end if;
elsif Is_Record_Type (Full_Base) then
or else Scope (Opnd_Type) /= System_Aux_Id
or else Pack /= Scope (System_Aux_Id))
then
- Error := True;
+ if not Is_Overloaded (Right_Opnd (Op_Node)) then
+ Error := True;
+ else
+ Error := not Operand_Type_In_Scope (Pack);
+ end if;
elsif Pack = Standard_Standard
and then not Operand_Type_In_Scope (Standard_Standard)
git://gcc.gnu.org / gcc.git / commitdiff