OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-07-30  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, sem_ch3.ads: Minor code reorganization.

2014-07-30  Pascal Obry  <obry@adacore.com>

	* clean.adb (Clean_Project): Properly check for directory
	existence before trying to enter it.

From-SVN: r213284
This commit is contained in:
Arnaud Charlet 2014-07-30 16:26:55 +02:00
parent 2e471ec764
commit c98b825308
4 changed files with 124 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2014-07-30 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_ch3.ads: Minor code reorganization.
2014-07-30 Pascal Obry <obry@adacore.com>
* clean.adb (Clean_Project): Properly check for directory
existence before trying to enter it.
2014-07-30 Robert Dewar <dewar@adacore.com>
* sem_ch3.ads, prj.ads, prj-nmsc.adb: Minor reformatting.

91
gcc/ada/clean.adb
View File

@ -666,51 +666,58 @@ package body Clean is
Canonical_Case_File_Name (Archive_Name);
Canonical_Case_File_Name (DLL_Name);
Change_Dir (Lib_Directory);
Open (Direc, ".");
if Is_Directory (Lib_Directory) then
Change_Dir (Lib_Directory);
Open (Direc, ".");
-- For each regular file in the directory, if switch -n has not
-- been specified, make it writable and delete the file if it is
-- the library file.
-- For each regular file in the directory, if switch -n has not
-- not been specified, make it writable and delete the file if
-- it is the library file.
loop
Read (Direc, Name, Last);
exit when Last = 0;
loop
Read (Direc, Name, Last);
exit when Last = 0;
declare
Filename : constant String := Name (1 .. Last);
declare
Filename : constant String := Name (1 .. Last);
begin
if Is_Regular_File (Filename)
or else Is_Symbolic_Link (Filename)
then
Canonical_Case_File_Name (Name (1 .. Last));
Delete_File := False;
if (Project.Library_Kind = Static
and then Name (1 .. Last) = Archive_Name)
or else
((Project.Library_Kind = Dynamic
or else
Project.Library_Kind = Relocatable)
and then
(Name (1 .. Last) = DLL_Name
or else
Name (1 .. Last) = Minor.all
or else
Name (1 .. Last) = Major.all))
begin
if Is_Regular_File (Filename)
or else Is_Symbolic_Link (Filename)
then
if not Do_Nothing then
Set_Writable (Filename);
Canonical_Case_File_Name (Name (1 .. Last));
Delete_File := False;
if (Project.Library_Kind = Static
and then Name (1 .. Last) = Archive_Name)
or else
((Project.Library_Kind = Dynamic
or else
Project.Library_Kind = Relocatable)
and then
(Name (1 .. Last) = DLL_Name
or else
Name (1 .. Last) = Minor.all
or else
Name (1 .. Last) = Major.all))
then
if not Do_Nothing then
Set_Writable (Filename);
end if;
Delete (Lib_Directory, Filename);
end if;
Delete (Lib_Directory, Filename);
end if;
end if;
end;
end loop;
end;
end loop;
Close (Direc);
Close (Direc);
end if;
if not Is_Directory (Lib_ALI_Directory) then
-- Nothing more to do, return now
return;
end if;
Change_Dir (Lib_ALI_Directory);
Open (Direc, ".");
@ -860,7 +867,10 @@ package body Clean is
Processed_Projects.Increment_Last;
Processed_Projects.Table (Processed_Projects.Last) := Project;
if Project.Object_Directory /= No_Path_Information then
if Project.Object_Directory /= No_Path_Information
and then Is_Directory
(Get_Name_String (Project.Object_Directory.Display_Name))
then
declare
Obj_Dir : constant String :=
Get_Name_String (Project.Object_Directory.Display_Name);
@ -1188,7 +1198,10 @@ package body Clean is
end;
end if;
if Project.Object_Directory /= No_Path_Information then
if Project.Object_Directory /= No_Path_Information
and then Is_Directory
(Get_Name_String (Project.Object_Directory.Display_Name))
then
Delete_Binder_Generated_Files
(Get_Name_String (Project.Object_Directory.Display_Name),
Strip_Suffix (Main_Source_File));

124
gcc/ada/sem_ch3.adb
View File

@ -17139,11 +17139,11 @@ package body Sem_Ch3 is
----------------
procedure Make_Index
(I : Node_Id;
(N : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
Suffix_Index : Nat := 1;
In_Iter_Schm : Boolean := False)
Suffix_Index : Nat := 1;
In_Iter_Schm : Boolean := False)
is
R : Node_Id;
T : Entity_Id;
@ -17164,13 +17164,13 @@ package body Sem_Ch3 is
-- Character literals also have a universal type in the absence of
-- of additional context, and are resolved to Standard_Character.
if Nkind (I) = N_Range then
if Nkind (N) = N_Range then
-- The index is given by a range constraint. The bounds are known
-- to be of a consistent type.
if not Is_Overloaded (I) then
T := Etype (I);
if not Is_Overloaded (N) then
T := Etype (N);
-- For universal bounds, choose the specific predefined type
@ -17178,7 +17178,7 @@ package body Sem_Ch3 is
T := Standard_Integer;
elsif T = Any_Character then
Ambiguous_Character (Low_Bound (I));
Ambiguous_Character (Low_Bound (N));
T := Standard_Character;
end if;
@ -17187,7 +17187,7 @@ package body Sem_Ch3 is
-- are available, but if a universal interpretation exists it is
-- also the selected one.
elsif Universal_Interpretation (I) = Universal_Integer then
elsif Universal_Interpretation (N) = Universal_Integer then
T := Standard_Integer;
else
@ -17198,7 +17198,7 @@ package body Sem_Ch3 is
It : Interp;
begin
Get_First_Interp (I, Ind, It);
Get_First_Interp (N, Ind, It);
while Present (It.Typ) loop
if Is_Discrete_Type (It.Typ) then
@ -17206,7 +17206,7 @@ package body Sem_Ch3 is
and then not Covers (It.Typ, T)
and then not Covers (T, It.Typ)
then
Error_Msg_N ("ambiguous bounds in discrete range", I);
Error_Msg_N ("ambiguous bounds in discrete range", N);
exit;
else
T := It.Typ;
@ -17218,8 +17218,8 @@ package body Sem_Ch3 is
end loop;
if T = Any_Type then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
Error_Msg_N ("discrete type required for range", N);
Set_Etype (N, Any_Type);
return;
elsif T = Universal_Integer then
@ -17229,70 +17229,70 @@ package body Sem_Ch3 is
end if;
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
Error_Msg_N ("discrete type required for range", N);
Set_Etype (N, Any_Type);
return;
end if;
if Nkind (Low_Bound (I)) = N_Attribute_Reference
and then Attribute_Name (Low_Bound (I)) = Name_First
and then Is_Entity_Name (Prefix (Low_Bound (I)))
and then Is_Type (Entity (Prefix (Low_Bound (I))))
and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I))))
if Nkind (Low_Bound (N)) = N_Attribute_Reference
and then Attribute_Name (Low_Bound (N)) = Name_First
and then Is_Entity_Name (Prefix (Low_Bound (N)))
and then Is_Type (Entity (Prefix (Low_Bound (N))))
and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N))))
then
-- The type of the index will be the type of the prefix, as long
-- as the upper bound is 'Last of the same type.
Def_Id := Entity (Prefix (Low_Bound (I)));
Def_Id := Entity (Prefix (Low_Bound (N)));
if Nkind (High_Bound (I)) /= N_Attribute_Reference
or else Attribute_Name (High_Bound (I)) /= Name_Last
or else not Is_Entity_Name (Prefix (High_Bound (I)))
or else Entity (Prefix (High_Bound (I))) /= Def_Id
if Nkind (High_Bound (N)) /= N_Attribute_Reference
or else Attribute_Name (High_Bound (N)) /= Name_Last
or else not Is_Entity_Name (Prefix (High_Bound (N)))
or else Entity (Prefix (High_Bound (N))) /= Def_Id
then
Def_Id := Empty;
end if;
end if;
R := I;
R := N;
Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
elsif Nkind (I) = N_Subtype_Indication then
elsif Nkind (N) = N_Subtype_Indication then
-- The index is given by a subtype with a range constraint
T := Base_Type (Entity (Subtype_Mark (I)));
T := Base_Type (Entity (Subtype_Mark (N)));
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
Error_Msg_N ("discrete type required for range", N);
Set_Etype (N, Any_Type);
return;
end if;
R := Range_Expression (Constraint (I));
R := Range_Expression (Constraint (N));
Resolve (R, T);
Process_Range_Expr_In_Decl
(R, Entity (Subtype_Mark (I)), In_Iter_Schm => In_Iter_Schm);
(R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm);
elsif Nkind (I) = N_Attribute_Reference then
elsif Nkind (N) = N_Attribute_Reference then
-- The parser guarantees that the attribute is a RANGE attribute
-- If the node denotes the range of a type mark, that is also the
-- resulting type, and we do no need to create an Itype for it.
if Is_Entity_Name (Prefix (I))
and then Comes_From_Source (I)
and then Is_Type (Entity (Prefix (I)))
and then Is_Discrete_Type (Entity (Prefix (I)))
if Is_Entity_Name (Prefix (N))
and then Comes_From_Source (N)
and then Is_Type (Entity (Prefix (N)))
and then Is_Discrete_Type (Entity (Prefix (N)))
then
Def_Id := Entity (Prefix (I));
Def_Id := Entity (Prefix (N));
end if;
Analyze_And_Resolve (I);
T := Etype (I);
R := I;
Analyze_And_Resolve (N);
T := Etype (N);
R := N;
-- If none of the above, must be a subtype. We convert this to a
-- range attribute reference because in the case of declared first
@ -17306,9 +17306,9 @@ package body Sem_Ch3 is
-- original index for instantiation purposes.
else
if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
Error_Msg_N ("invalid subtype mark in discrete range ", I);
Set_Etype (I, Any_Integer);
if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
Error_Msg_N ("invalid subtype mark in discrete range ", N);
Set_Etype (N, Any_Integer);
return;
else
@ -17316,31 +17316,31 @@ package body Sem_Ch3 is
-- now that we can get the full view, previous analysis does
-- not look specifically for a type mark.
Set_Entity (I, Get_Full_View (Entity (I)));
Set_Etype (I, Entity (I));
Def_Id := Entity (I);
Set_Entity (N, Get_Full_View (Entity (N)));
Set_Etype (N, Entity (N));
Def_Id := Entity (N);
if not Is_Discrete_Type (Def_Id) then
Error_Msg_N ("discrete type required for index", I);
Set_Etype (I, Any_Type);
Error_Msg_N ("discrete type required for index", N);
Set_Etype (N, Any_Type);
return;
end if;
end if;
if Expander_Active then
Rewrite (I,
Make_Attribute_Reference (Sloc (I),
Rewrite (N,
Make_Attribute_Reference (Sloc (N),
Attribute_Name => Name_Range,
Prefix => Relocate_Node (I)));
Prefix => Relocate_Node (N)));
-- The original was a subtype mark that does not freeze. This
-- means that the rewritten version must not freeze either.
Set_Must_Not_Freeze (I);
Set_Must_Not_Freeze (Prefix (I));
Analyze_And_Resolve (I);
T := Etype (I);
R := I;
Set_Must_Not_Freeze (N);
Set_Must_Not_Freeze (Prefix (N));
Analyze_And_Resolve (N);
T := Etype (N);
R := N;
-- If expander is inactive, type is legal, nothing else to construct
@ -17350,12 +17350,12 @@ package body Sem_Ch3 is
end if;
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
Error_Msg_N ("discrete type required for range", N);
Set_Etype (N, Any_Type);
return;
elsif T = Any_Type then
Set_Etype (I, Any_Type);
Set_Etype (N, Any_Type);
return;
end if;
@ -17401,8 +17401,8 @@ package body Sem_Ch3 is
-- new subtype is non-static, then the subtype we create is non-
-- static, even if its bounds are static.
if Nkind (I) = N_Subtype_Indication
and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (I)))
if Nkind (N) = N_Subtype_Indication
and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
then
Set_Is_Non_Static_Subtype (Def_Id);
end if;
@ -17410,7 +17410,7 @@ package body Sem_Ch3 is
-- Final step is to label the index with this constructed type
Set_Etype (I, Def_Id);
Set_Etype (N, Def_Id);
end Make_Index;
------------------------------

2
gcc/ada/sem_ch3.ads
View File

@ -193,7 +193,7 @@ package Sem_Ch3 is
-- C is automatically visible.
procedure Make_Index
(I : Node_Id;
(N : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
Suffix_Index : Nat := 1;