+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Use_One_Type): If both clauses appear on the same unit,
+ the second is redundant, regardless of scopes.
+
+2009-04-15 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb (Get_Directories): Check for sources before checking
+ the object directory as when there are no sources, they may not be any
+ object directory.
+
+ * make.adb (Gnatmake): Do not attempt to get the path name of the exec
+ directory, when there are no exec directory.
+
+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_type.adb (Remove_Conversions): In order to resolve spurious
+ ambiguities, refine removal of universal interpretations from complex
+ expressions with literal arguments, when some numeric operators have
+ been declared abstract.
+
+2009-04-15 Ed Falis <falis@adacore.com>
+
+ * init.c: Map SIGSEGV to Storage_Error for all targets for uniformity
+ and backward compatibility for targets using probing for stack overflow
+
+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case 'Obsolescent): Pragma is legal
+ after any declaration, including renaming declarations.
+
2009-04-15 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies.
break;
case SIGSEGV:
exception = &storage_error;
- msg = "SIGSEGV: possible stack overflow";
+ msg = "SIGSEGV";
break;
case SIGBUS:
exception = &storage_error;
#else
/* VxWorks 6 kernel mode with probing. SIGBUS for guard page hit */
case SIGSEGV:
- exception = &program_error;
+ exception = &storage_error;
msg = "SIGSEGV";
break;
case SIGBUS:
msg = "SIGILL: possible stack overflow";
break;
case SIGSEGV:
- exception = &program_error;
+ exception = &storage_error;
msg = "SIGSEGV";
break;
case SIGBUS:
end if;
end if;
- if Main_Project /= No_Project then
+ if Main_Project /= No_Project
+ and then
+ Project_Tree.Projects.Table
+ (Main_Project).Exec_Directory /= No_Path_Information
+ then
declare
Exec_File_Name : constant String :=
Get_Name_String (Executable);
Write_Line ("Starting to look for directories");
end if;
- -- Check the object directory
-
- pragma Assert (Object_Dir.Kind = Single,
- "Object_Dir is not a single string");
-
- -- We set the object directory to its default
+ -- 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;
- if Object_Dir.Value /= Empty_String then
- Get_Name_String (Object_Dir.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Project, In_Tree,
- "Object_Dir cannot be empty",
- Object_Dir.Location);
-
- else
- -- We check that the specified object directory does exist
-
- Locate_Directory
- (Project,
- In_Tree,
- File_Name_Type (Object_Dir.Value),
- Data.Directory.Display_Name,
- Data.Object_Directory.Name,
- Data.Object_Directory.Display_Name,
- Create => "object",
- Location => Object_Dir.Location,
- Current_Dir => Current_Dir,
- Externally_Built => Data.Externally_Built);
-
- if Data.Object_Directory = No_Path_Information then
-
- -- The object directory does not exist, report an error if the
- -- project is not externally built.
-
- if not Data.Externally_Built then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Object_Dir.Value);
- Error_Msg
- (Project, In_Tree,
- "the object directory { cannot be found",
- Data.Location);
- end if;
-
- -- 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.
-
- Data.Object_Directory.Display_Name :=
- Path_Name_Type (Object_Dir.Value);
-
- if Osint.File_Names_Case_Sensitive then
- Data.Object_Directory.Name :=
- Path_Name_Type (Object_Dir.Value);
- else
- Get_Name_String (Object_Dir.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Data.Object_Directory.Name := Name_Find;
- end if;
- end if;
- end if;
-
- elsif Subdirs /= null then
- Name_Len := 1;
- Name_Buffer (1) := '.';
- Locate_Directory
- (Project,
- In_Tree,
- Name_Find,
- Data.Directory.Display_Name,
- Data.Object_Directory.Name,
- Data.Object_Directory.Display_Name,
- Create => "object",
- Location => Object_Dir.Location,
- Current_Dir => Current_Dir,
- Externally_Built => Data.Externally_Built);
- end if;
-
- if Current_Verbosity = High then
- if Data.Object_Directory = No_Path_Information then
- Write_Line ("No object directory");
- else
- Write_Str ("Object directory: """);
- Write_Str (Get_Name_String (Data.Object_Directory.Display_Name));
- Write_Line ("""");
- end if;
- end if;
-
- -- 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;
-
- if Exec_Dir.Value /= Empty_String then
- Get_Name_String (Exec_Dir.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Project, In_Tree,
- "Exec_Dir cannot be empty",
- Exec_Dir.Location);
-
- else
- -- We check that the specified exec directory does exist
-
- Locate_Directory
- (Project,
- In_Tree,
- File_Name_Type (Exec_Dir.Value),
- Data.Directory.Display_Name,
- Data.Exec_Directory.Name,
- Data.Exec_Directory.Display_Name,
- Create => "exec",
- Location => Exec_Dir.Location,
- Current_Dir => Current_Dir,
- Externally_Built => Data.Externally_Built);
-
- if Data.Exec_Directory = No_Path_Information then
- Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
- Error_Msg
- (Project, In_Tree,
- "the exec directory { cannot be found",
- Data.Location);
- end if;
- end if;
- end if;
-
- if Current_Verbosity = High then
- if Data.Exec_Directory = No_Path_Information then
- Write_Line ("No exec directory");
- else
- Write_Str ("Exec directory: """);
- Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name));
- Write_Line ("""");
- end if;
- end if;
-
-- Look for the source directories
if Current_Verbosity = High then
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);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project, In_Tree,
+ "Object_Dir cannot be empty",
+ Object_Dir.Location);
+
+ else
+ -- We check that the specified object directory does exist
+
+ Locate_Directory
+ (Project,
+ In_Tree,
+ File_Name_Type (Object_Dir.Value),
+ Data.Directory.Display_Name,
+ Data.Object_Directory.Name,
+ Data.Object_Directory.Display_Name,
+ Create => "object",
+ Location => Object_Dir.Location,
+ Current_Dir => Current_Dir,
+ Externally_Built => Data.Externally_Built);
+
+ if Data.Object_Directory = No_Path_Information then
+
+ -- The object directory does not exist, report an error if the
+ -- project is not externally built.
+
+ if not Data.Externally_Built then
+ Err_Vars.Error_Msg_File_1 :=
+ File_Name_Type (Object_Dir.Value);
+ Error_Msg
+ (Project, In_Tree,
+ "the object directory { cannot be found",
+ Data.Location);
+ end if;
+
+ -- 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.
+
+ Data.Object_Directory.Display_Name :=
+ Path_Name_Type (Object_Dir.Value);
+
+ if Osint.File_Names_Case_Sensitive then
+ Data.Object_Directory.Name :=
+ Path_Name_Type (Object_Dir.Value);
+ else
+ Get_Name_String (Object_Dir.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Data.Object_Directory.Name := Name_Find;
+ end if;
+ end if;
+ end if;
+
+ elsif Data.Object_Directory /= No_Path_Information and then
+ Subdirs /= null
+ then
+ Name_Len := 1;
+ Name_Buffer (1) := '.';
+ Locate_Directory
+ (Project,
+ In_Tree,
+ Name_Find,
+ Data.Directory.Display_Name,
+ Data.Object_Directory.Name,
+ Data.Object_Directory.Display_Name,
+ Create => "object",
+ Location => Object_Dir.Location,
+ Current_Dir => Current_Dir,
+ Externally_Built => Data.Externally_Built);
+ end if;
+
+ if Current_Verbosity = High then
+ if Data.Object_Directory = No_Path_Information then
+ Write_Line ("No object directory");
+ else
+ Write_Str ("Object directory: """);
+ Write_Str (Get_Name_String (Data.Object_Directory.Display_Name));
+ Write_Line ("""");
+ end if;
+ end if;
+
+ -- 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;
+
+ if Exec_Dir.Value /= Empty_String then
+ Get_Name_String (Exec_Dir.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project, In_Tree,
+ "Exec_Dir cannot be empty",
+ Exec_Dir.Location);
+
+ else
+ -- We check that the specified exec directory does exist
+
+ Locate_Directory
+ (Project,
+ In_Tree,
+ File_Name_Type (Exec_Dir.Value),
+ Data.Directory.Display_Name,
+ Data.Exec_Directory.Name,
+ Data.Exec_Directory.Display_Name,
+ Create => "exec",
+ Location => Exec_Dir.Location,
+ Current_Dir => Current_Dir,
+ Externally_Built => Data.Externally_Built);
+
+ if Data.Exec_Directory = No_Path_Information then
+ Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
+ Error_Msg
+ (Project, In_Tree,
+ "the exec directory { cannot be found",
+ Data.Location);
+ end if;
+ end if;
+ end if;
+
+ if Current_Verbosity = High then
+ if Data.Exec_Directory = No_Path_Information then
+ Write_Line ("No exec directory");
+ else
+ Write_Str ("Exec directory: """);
+ Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name));
+ Write_Line ("""");
+ end if;
+ end if;
end Get_Directories;
---------------
Prev_Use : Node_Id := Empty;
Redundant : Node_Id := Empty;
- -- The Use_Clause which is actually redundant. In the simplest case
- -- it is Pack itself, but when we compile a body we install its
- -- context before that of its spec, in which case it is the use_clause
- -- in the spec that will appear to be redundant, and we want the
- -- warning to be placed on the body. Similar complications appear when
- -- the redundancy is between a child unit and one of its ancestors.
+ -- The Use_Clause which is actually redundant. In the simplest case it
+ -- is Pack itself, but when we compile a body we install its context
+ -- before that of its spec, in which case it is the use_clause in the
+ -- spec that will appear to be redundant, and we want the warning to be
+ -- placed on the body. Similar complications appear when the redundancy
+ -- is between a child unit and one of its ancestors.
begin
Set_Redundant_Use (Clause, True);
if not Is_Compilation_Unit (Current_Scope) then
- -- If the use_clause is in an inner scope, it is made redundant
- -- by some clause in the current context, with one exception:
- -- If we're compiling a nested package body, and the use_clause
- -- comes from the corresponding spec, the clause is not necessarily
- -- fully redundant, so we should not warn. If a warning was
- -- warranted, it would have been given when the spec was processed.
+ -- If the use_clause is in an inner scope, it is made redundant by
+ -- some clause in the current context, with one exception: If we're
+ -- compiling a nested package body, and the use_clause comes from the
+ -- corresponding spec, the clause is not necessarily fully redundant,
+ -- so we should not warn. If a warning was warranted, it would have
+ -- been given when the spec was processed.
if Nkind (Parent (Decl)) = N_Package_Specification then
declare
elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
then
- -- Use_clause is in child unit of current unit, and the child
- -- unit appears in the context of the body of the parent, so it
- -- has been installed first, even though it is the redundant one.
- -- Depending on their placement in the context, the visible or the
- -- private parts of the two units, either might appear as redundant,
- -- but the message has to be on the current unit.
+ -- Use_clause is in child unit of current unit, and the child unit
+ -- appears in the context of the body of the parent, so it has been
+ -- installed first, even though it is the redundant one. Depending on
+ -- their placement in the context, the visible or the private parts
+ -- of the two units, either might appear as redundant, but the
+ -- message has to be on the current unit.
if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
Redundant := Cur_Use;
if Ekind (S) = E_Void then
null;
- -- Set scope depth if not a non-concurrent type, and we have not
- -- yet set the scope depth. This means that we have the first
- -- occurrence of the scope, and this is where the depth is set.
+ -- Set scope depth if not a non-concurrent type, and we have not yet set
+ -- the scope depth. This means that we have the first occurrence of the
+ -- scope, and this is where the depth is set.
elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
and then not Scope_Depth_Set (S)
Write_Eol;
end if;
- -- Deal with copying flags from the previous scope to this one. This
- -- is not necessary if either scope is standard, or if the new scope
- -- is a child unit.
+ -- Deal with copying flags from the previous scope to this one. This is
+ -- not necessary if either scope is standard, or if the new scope is a
+ -- child unit.
if S /= Standard_Standard
and then Scope (S) /= Standard_Standard
if not From_With_Type (E) then
Set_Is_Immediately_Visible (E,
Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
+
else
pragma Assert
(Nkind (Parent (E)) = N_Defining_Program_Unit_Name
elsif In_Open_Scopes (Scope (T)) then
null;
- -- A limited view cannot appear in a use_type clause. However, an
- -- access type whose designated type is limited has the flag but
- -- is not itself a limited view unless we only have a limited view
- -- of its enclosing package.
+ -- A limited view cannot appear in a use_type clause. However, an access
+ -- type whose designated type is limited has the flag but is not itself
+ -- a limited view unless we only have a limited view of its enclosing
+ -- package.
elsif From_With_Type (T)
and then From_With_Type (Scope (T))
-- as use visible. The analysis then reinstalls the spec along with
-- its context. The use clause P.T is now recognized as redundant,
-- but in the wrong context. Do not emit a warning in such cases.
- -- Do not emit a warning either if we are in an instance, there
- -- is no redundancy between an outer use_clause and one that appears
+ -- Do not emit a warning either if we are in an instance, there is
+ -- no redundancy between an outer use_clause and one that appears
-- within the generic.
and then not Spec_Reloaded_For_Body
-- Start of processing for Use_Clause_Known
begin
- -- If both current use type clause and the use type
- -- clause for the type are at the compilation unit level,
- -- one of the units must be an ancestor of the other, and
- -- the warning belongs on the descendant.
+ -- If both current use type clause and the use type clause
+ -- for the type are at the compilation unit level, one of
+ -- the units must be an ancestor of the other, and the
+ -- warning belongs on the descendant.
if Nkind (Parent (Clause1)) = N_Compilation_Unit
and then
Unit1 := Unit (Parent (Clause1));
Unit2 := Unit (Parent (Clause2));
+ -- If both clauses are on same unit, report redundancy
+
+ if Unit1 = Unit2 then
+ Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
+ Error_Msg_NE
+ ("& is already use-visible through previous "
+ & "use_type_clause #?", Clause1, T);
+ return;
+ end if;
+
-- There is a redundant use type clause in a child unit.
-- Determine which of the units is more deeply nested.
-- If a unit is a package instance, retrieve the entity
if Nkind (Decl) not in N_Declaration
and then Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) not in N_Generic_Declaration
+ and then Nkind (Decl) not in N_Renaming_Declaration
then
Error_Pragma
("pragma% misplaced, "
then
return True;
- -- An aggregate is compatible with an array or record type
+ -- An aggregate is compatible with an array or record type.
elsif T2 = Any_Composite
and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
end if;
elsif Is_Numeric_Type (Etype (F1))
- and then
- (Has_Abstract_Interpretation (Act1)
- or else Has_Abstract_Interpretation (Act2))
+ and then Has_Abstract_Interpretation (Act1)
then
- if It = Disambiguate.It1 then
- return Disambiguate.It2;
- elsif It = Disambiguate.It2 then
- return Disambiguate.It1;
- end if;
+
+ -- Current interpretation is not the right one because
+ -- it expects a numeric operand. Examine all the other
+ -- ones.
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Typ) loop
+ if
+ not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
+ then
+ if No (Act2)
+ or else not Has_Abstract_Interpretation (Act2)
+ or else not Is_Numeric_Type
+ (Etype (Next_Formal (First_Formal (It.Nam))))
+ then
+ return It;
+ end if;
+ end if;
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return No_Interp;
+ end;
end if;
end if;
OSDN Git Service
