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> 2014-07-30 Robert Dewar <dewar@adacore.com>
* sem_ch3.ads, prj.ads, prj-nmsc.adb: Minor reformatting. * 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 (Archive_Name);
Canonical_Case_File_Name (DLL_Name); Canonical_Case_File_Name (DLL_Name);
Change_Dir (Lib_Directory); if Is_Directory (Lib_Directory) then
Open (Direc, "."); Change_Dir (Lib_Directory);
Open (Direc, ".");
-- For each regular file in the directory, if switch -n has not -- For each regular file in the directory, if switch -n has not
-- been specified, make it writable and delete the file if it is -- not been specified, make it writable and delete the file if
-- the library file. -- it is the library file.
loop loop
Read (Direc, Name, Last); Read (Direc, Name, Last);
exit when Last = 0; exit when Last = 0;
declare declare
Filename : constant String := Name (1 .. Last); Filename : constant String := Name (1 .. Last);
begin begin
if Is_Regular_File (Filename) if Is_Regular_File (Filename)
or else Is_Symbolic_Link (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))
then then
if not Do_Nothing then Canonical_Case_File_Name (Name (1 .. Last));
Set_Writable (Filename); 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; end if;
Delete (Lib_Directory, Filename);
end if; end if;
end if; end;
end; end loop;
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); Change_Dir (Lib_ALI_Directory);
Open (Direc, "."); Open (Direc, ".");
@ -860,7 +867,10 @@ package body Clean is
Processed_Projects.Increment_Last; Processed_Projects.Increment_Last;
Processed_Projects.Table (Processed_Projects.Last) := Project; 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 declare
Obj_Dir : constant String := Obj_Dir : constant String :=
Get_Name_String (Project.Object_Directory.Display_Name); Get_Name_String (Project.Object_Directory.Display_Name);
@ -1188,7 +1198,10 @@ package body Clean is
end; end;
end if; 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 Delete_Binder_Generated_Files
(Get_Name_String (Project.Object_Directory.Display_Name), (Get_Name_String (Project.Object_Directory.Display_Name),
Strip_Suffix (Main_Source_File)); 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 procedure Make_Index
(I : Node_Id; (N : Node_Id;
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty; Related_Id : Entity_Id := Empty;
Suffix_Index : Nat := 1; Suffix_Index : Nat := 1;
In_Iter_Schm : Boolean := False) In_Iter_Schm : Boolean := False)
is is
R : Node_Id; R : Node_Id;
T : Entity_Id; T : Entity_Id;
@ -17164,13 +17164,13 @@ package body Sem_Ch3 is
-- Character literals also have a universal type in the absence of -- Character literals also have a universal type in the absence of
-- of additional context, and are resolved to Standard_Character. -- 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 -- The index is given by a range constraint. The bounds are known
-- to be of a consistent type. -- to be of a consistent type.
if not Is_Overloaded (I) then if not Is_Overloaded (N) then
T := Etype (I); T := Etype (N);
-- For universal bounds, choose the specific predefined type -- For universal bounds, choose the specific predefined type
@ -17178,7 +17178,7 @@ package body Sem_Ch3 is
T := Standard_Integer; T := Standard_Integer;
elsif T = Any_Character then elsif T = Any_Character then
Ambiguous_Character (Low_Bound (I)); Ambiguous_Character (Low_Bound (N));
T := Standard_Character; T := Standard_Character;
end if; end if;
@ -17187,7 +17187,7 @@ package body Sem_Ch3 is
-- are available, but if a universal interpretation exists it is -- are available, but if a universal interpretation exists it is
-- also the selected one. -- also the selected one.
elsif Universal_Interpretation (I) = Universal_Integer then elsif Universal_Interpretation (N) = Universal_Integer then
T := Standard_Integer; T := Standard_Integer;
else else
@ -17198,7 +17198,7 @@ package body Sem_Ch3 is
It : Interp; It : Interp;
begin begin
Get_First_Interp (I, Ind, It); Get_First_Interp (N, Ind, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Is_Discrete_Type (It.Typ) then 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 (It.Typ, T)
and then not Covers (T, It.Typ) and then not Covers (T, It.Typ)
then then
Error_Msg_N ("ambiguous bounds in discrete range", I); Error_Msg_N ("ambiguous bounds in discrete range", N);
exit; exit;
else else
T := It.Typ; T := It.Typ;
@ -17218,8 +17218,8 @@ package body Sem_Ch3 is
end loop; end loop;
if T = Any_Type then if T = Any_Type then
Error_Msg_N ("discrete type required for range", I); Error_Msg_N ("discrete type required for range", N);
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
elsif T = Universal_Integer then elsif T = Universal_Integer then
@ -17229,70 +17229,70 @@ package body Sem_Ch3 is
end if; end if;
if not Is_Discrete_Type (T) then if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I); Error_Msg_N ("discrete type required for range", N);
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
if Nkind (Low_Bound (I)) = N_Attribute_Reference if Nkind (Low_Bound (N)) = N_Attribute_Reference
and then Attribute_Name (Low_Bound (I)) = Name_First and then Attribute_Name (Low_Bound (N)) = Name_First
and then Is_Entity_Name (Prefix (Low_Bound (I))) and then Is_Entity_Name (Prefix (Low_Bound (N)))
and then Is_Type (Entity (Prefix (Low_Bound (I)))) and then Is_Type (Entity (Prefix (Low_Bound (N))))
and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N))))
then then
-- The type of the index will be the type of the prefix, as long -- The type of the index will be the type of the prefix, as long
-- as the upper bound is 'Last of the same type. -- 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 if Nkind (High_Bound (N)) /= N_Attribute_Reference
or else Attribute_Name (High_Bound (I)) /= Name_Last or else Attribute_Name (High_Bound (N)) /= Name_Last
or else not Is_Entity_Name (Prefix (High_Bound (I))) or else not Is_Entity_Name (Prefix (High_Bound (N)))
or else Entity (Prefix (High_Bound (I))) /= Def_Id or else Entity (Prefix (High_Bound (N))) /= Def_Id
then then
Def_Id := Empty; Def_Id := Empty;
end if; end if;
end if; end if;
R := I; R := N;
Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); 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 -- 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 if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I); Error_Msg_N ("discrete type required for range", N);
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
R := Range_Expression (Constraint (I)); R := Range_Expression (Constraint (N));
Resolve (R, T); Resolve (R, T);
Process_Range_Expr_In_Decl 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 -- The parser guarantees that the attribute is a RANGE attribute
-- If the node denotes the range of a type mark, that is also the -- 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. -- resulting type, and we do no need to create an Itype for it.
if Is_Entity_Name (Prefix (I)) if Is_Entity_Name (Prefix (N))
and then Comes_From_Source (I) and then Comes_From_Source (N)
and then Is_Type (Entity (Prefix (I))) and then Is_Type (Entity (Prefix (N)))
and then Is_Discrete_Type (Entity (Prefix (I))) and then Is_Discrete_Type (Entity (Prefix (N)))
then then
Def_Id := Entity (Prefix (I)); Def_Id := Entity (Prefix (N));
end if; end if;
Analyze_And_Resolve (I); Analyze_And_Resolve (N);
T := Etype (I); T := Etype (N);
R := I; R := N;
-- If none of the above, must be a subtype. We convert this to a -- If none of the above, must be a subtype. We convert this to a
-- range attribute reference because in the case of declared first -- range attribute reference because in the case of declared first
@ -17306,9 +17306,9 @@ package body Sem_Ch3 is
-- original index for instantiation purposes. -- original index for instantiation purposes.
else else
if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
Error_Msg_N ("invalid subtype mark in discrete range ", I); Error_Msg_N ("invalid subtype mark in discrete range ", N);
Set_Etype (I, Any_Integer); Set_Etype (N, Any_Integer);
return; return;
else else
@ -17316,31 +17316,31 @@ package body Sem_Ch3 is
-- now that we can get the full view, previous analysis does -- now that we can get the full view, previous analysis does
-- not look specifically for a type mark. -- not look specifically for a type mark.
Set_Entity (I, Get_Full_View (Entity (I))); Set_Entity (N, Get_Full_View (Entity (N)));
Set_Etype (I, Entity (I)); Set_Etype (N, Entity (N));
Def_Id := Entity (I); Def_Id := Entity (N);
if not Is_Discrete_Type (Def_Id) then if not Is_Discrete_Type (Def_Id) then
Error_Msg_N ("discrete type required for index", I); Error_Msg_N ("discrete type required for index", N);
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
end if; end if;
if Expander_Active then if Expander_Active then
Rewrite (I, Rewrite (N,
Make_Attribute_Reference (Sloc (I), Make_Attribute_Reference (Sloc (N),
Attribute_Name => Name_Range, Attribute_Name => Name_Range,
Prefix => Relocate_Node (I))); Prefix => Relocate_Node (N)));
-- The original was a subtype mark that does not freeze. This -- The original was a subtype mark that does not freeze. This
-- means that the rewritten version must not freeze either. -- means that the rewritten version must not freeze either.
Set_Must_Not_Freeze (I); Set_Must_Not_Freeze (N);
Set_Must_Not_Freeze (Prefix (I)); Set_Must_Not_Freeze (Prefix (N));
Analyze_And_Resolve (I); Analyze_And_Resolve (N);
T := Etype (I); T := Etype (N);
R := I; R := N;
-- If expander is inactive, type is legal, nothing else to construct -- If expander is inactive, type is legal, nothing else to construct
@ -17350,12 +17350,12 @@ package body Sem_Ch3 is
end if; end if;
if not Is_Discrete_Type (T) then if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I); Error_Msg_N ("discrete type required for range", N);
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
elsif T = Any_Type then elsif T = Any_Type then
Set_Etype (I, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
@ -17401,8 +17401,8 @@ package body Sem_Ch3 is
-- new subtype is non-static, then the subtype we create is non- -- new subtype is non-static, then the subtype we create is non-
-- static, even if its bounds are static. -- static, even if its bounds are static.
if Nkind (I) = N_Subtype_Indication if Nkind (N) = N_Subtype_Indication
and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (I))) and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
then then
Set_Is_Non_Static_Subtype (Def_Id); Set_Is_Non_Static_Subtype (Def_Id);
end if; end if;
@ -17410,7 +17410,7 @@ package body Sem_Ch3 is
-- Final step is to label the index with this constructed type -- Final step is to label the index with this constructed type
Set_Etype (I, Def_Id); Set_Etype (N, Def_Id);
end Make_Index; end Make_Index;
------------------------------ ------------------------------

2
gcc/ada/sem_ch3.ads
View File

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