+2017-04-25 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb, exp_ch4.adb: Minor reformatting.
+
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb: Code clean up in various routines.
+ (Generate_Range_Check): Do not generate a range check when the
+ expander is not active or when index/range checks are suppressed
+ on the target type.
+ (Insert_List_After_And_Analyze, Insert_List_Before_And_Analyze):
+ Remove variants that include a Supress parameter. These routines
+ are never used, and were introduced before the current scope-based
+ check suppression method.
+
+2017-04-25 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * prj-part.adb, cstreams.c, osint.adb, osint.ads: Remove VMS specific
+ code and some subprogram calls that are now noop.
+
2017-04-25 Arnaud Charlet <charlet@adacore.com>
* exp_ch4.adb (Expand_N_Case_Expression): Take
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Static_Sloc : Source_Ptr;
Flag_Node : Node_Id)
is
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (Suppress_Typ)
+ or else
+ not Range_Checks_Suppressed (Suppress_Typ);
+
Internal_Flag_Node : constant Node_Id := Flag_Node;
Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
- Checks_On : constant Boolean :=
- (not Index_Checks_Suppressed (Suppress_Typ))
- or else (not Range_Checks_Suppressed (Suppress_Typ));
-
begin
- -- For now we just return if Checks_On is false, however this should
- -- be enhanced to check for an always True value in the condition
- -- and to generate a compilation warning???
+ -- For now we just return if Checks_On is false, however this should be
+ -- enhanced to check for an always True value in the condition and to
+ -- generate a compilation warning???
if not Checks_On then
return;
Source_Typ : Entity_Id;
Do_Static : Boolean)
is
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (Target_Typ)
+ or else
+ not Length_Checks_Suppressed (Target_Typ);
+
+ Loc : constant Source_Ptr := Sloc (Ck_Node);
+
Cond : Node_Id;
- R_Result : Check_Result;
R_Cno : Node_Id;
-
- Loc : constant Source_Ptr := Sloc (Ck_Node);
- Checks_On : constant Boolean :=
- (not Index_Checks_Suppressed (Target_Typ))
- or else (not Length_Checks_Suppressed (Target_Typ));
+ R_Result : Check_Result;
begin
-- Only apply checks when generating code
Source_Typ : Entity_Id;
Do_Static : Boolean)
is
- Loc : constant Source_Ptr := Sloc (Ck_Node);
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Target_Typ)
or else
not Range_Checks_Suppressed (Target_Typ);
+ Loc : constant Source_Ptr := Sloc (Ck_Node);
+
Cond : Node_Id;
R_Cno : Node_Id;
R_Result : Check_Result;
Set_Etype (N, Target_Base_Type);
end Convert_And_Check_Range;
+ -- Local variables
+
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (Target_Type)
+ or else
+ not Range_Checks_Suppressed (Target_Type);
+
-- Start of processing for Generate_Range_Check
begin
+ if not Expander_Active or not Checks_On then
+ return;
+ end if;
+
-- First special case, if the source type is already within the range
-- of the target type, then no check is needed (probably we should have
-- stopped Do_Range_Check from being set in the first place, but better
Flag_Node : Node_Id := Empty;
Do_Before : Boolean := False)
is
+ Checks_On : constant Boolean :=
+ not Index_Checks_Suppressed (Suppress_Typ)
+ or else
+ not Range_Checks_Suppressed (Suppress_Typ);
+
+ Check_Node : Node_Id;
Internal_Flag_Node : Node_Id := Flag_Node;
Internal_Static_Sloc : Source_Ptr := Static_Sloc;
- Check_Node : Node_Id;
- Checks_On : constant Boolean :=
- (not Index_Checks_Suppressed (Suppress_Typ))
- or else (not Range_Checks_Suppressed (Suppress_Typ));
-
begin
-- For now we just return if Checks_On is false, however this should be
-- enhanced to check for an always True value in the condition and to
* *
* Auxiliary C functions for Interfaces.C.Streams *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
extern "C" {
#endif
-#ifdef VMS
-#include <unixlib.h>
-#endif
-
#ifdef __linux__
/* Don't use macros on GNU/Linux since they cause incompatible changes between
glibc 2.0 and 2.1 */
getcwd approach instead. */
realpath (nam, buffer);
-#elif defined (VMS)
- strncpy (buffer, __gnat_to_canonical_file_spec (nam), __gnat_max_path_len);
-
- if (buffer[0] == '/' || strchr (buffer, '!')) /* '!' means decnet node */
- strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len);
- else
- {
- char *nambuffer = alloca (__gnat_max_path_len);
-
- strncpy (nambuffer, buffer, __gnat_max_path_len);
- strncpy
- (buffer, getcwd (buffer, __gnat_max_path_len, 0), __gnat_max_path_len);
- strncat (buffer, "/", __gnat_max_path_len);
- strncat (buffer, nambuffer, __gnat_max_path_len);
- strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len);
- }
-
#elif defined (__vxworks)
/* On VxWorks systems, an absolute path can be represented (depending on
------------------------------
procedure Expand_N_Case_Expression (N : Node_Id) is
+
function Is_Copy_Type (Typ : Entity_Id) return Boolean;
-- Return True if we can copy objects of this type when expanding a case
-- expression.
function Is_Copy_Type (Typ : Entity_Id) return Boolean is
begin
- -- if Minimize_Expression_With_Actions is True, we can afford to copy
+ -- If Minimize_Expression_With_Actions is True, we can afford to copy
-- large objects, as long as they are constrained and not limited.
return
-- This approach avoids extra copies of potentially large objects. It
-- also allows handling of values of limited or unconstrained types.
- -- Note that we do the copy also for constrained, non limited types
+ -- Note that we do the copy also for constrained, nonlimited types
-- when minimizing expressions with actions (e.g. when generating C
-- code) since it allows us to do the optimization below in more cases.
Target_Typ := Typ;
-- ??? Do not perform the optimization when the return statement is
- -- within a predicate function as this causes spurious errors. Could
+ -- within a predicate function, as this causes spurious errors. Could
-- this be a possible mismatch in handling this case somewhere else
-- in semantic analysis?
end if;
-- Fall through here for either the limited expansion, or the case of
- -- inserting actions for non-limited types. In both these cases, we must
+ -- inserting actions for nonlimited types. In both these cases, we must
-- move the SLOC of the parent If statement to the newly created one and
-- change it to the SLOC of the expression which, after expansion, will
-- correspond to what is being evaluated.
Calls_OK : Boolean := False;
-- This flag is set to True when expression Expr contains at least one
- -- call to a non-dispatching primitive function of Typ.
+ -- call to a nondispatching primitive function of Typ.
function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
-- Search for nondispatching calls to primitive functions of type Typ
Subp : Entity_Id;
begin
- -- Detect a function call which could denote a non-dispatching
+ -- Detect a function call that could denote a nondispatching
-- primitive of the input type.
if Nkind (N) = N_Function_Call
then
Subp := Entity (Name (N));
- -- Do not consider function calls with a controlling argument as
+ -- Do not consider function calls with a controlling argument, as
-- those are always dispatching calls.
if Is_Dispatching_Operation (Subp)
then
Calls_OK := True;
- -- There is no need to continue the traversal as one such
+ -- There is no need to continue the traversal, as one such
-- call suffices.
return Abandon;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
if Additional_Source_Dir then
Search_Path := Getenv (Ada_Include_Path);
- if Search_Path'Length > 0 then
- Search_Path := To_Canonical_Path_Spec (Search_Path.all);
- end if;
-
else
Search_Path := Getenv (Ada_Objects_Path);
- if Search_Path'Length > 0 then
- Search_Path := To_Canonical_Path_Spec (Search_Path.all);
- end if;
end if;
Get_Next_Dir_In_Path_Init (Search_Path);
Default_Suffix_Dir := new String'("adalib");
end if;
- Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
+ Norm_Search_Dir := Local_Search_Dir;
if Is_Absolute_Path (Norm_Search_Dir.all) then
return Name;
end Strip_Suffix;
- ---------------------------
- -- To_Canonical_Dir_Spec --
- ---------------------------
-
- function To_Canonical_Dir_Spec
- (Host_Dir : String;
- Prefix_Style : Boolean) return String_Access
- is
- function To_Canonical_Dir_Spec
- (Host_Dir : Address;
- Prefix_Flag : Integer) return Address;
- pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
-
- C_Host_Dir : String (1 .. Host_Dir'Length + 1);
- Canonical_Dir_Addr : Address;
- Canonical_Dir_Len : CRTL.size_t;
-
- begin
- C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
- C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
-
- if Prefix_Style then
- Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
- else
- Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
- end if;
-
- Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
-
- if Canonical_Dir_Len = 0 then
- return null;
- else
- return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
- end if;
-
- exception
- when others =>
- Fail ("invalid directory spec: " & Host_Dir);
- return null;
- end To_Canonical_Dir_Spec;
-
---------------------------
-- To_Canonical_File_List --
---------------------------
end;
end To_Canonical_File_List;
- ----------------------------
- -- To_Canonical_File_Spec --
- ----------------------------
-
- function To_Canonical_File_Spec
- (Host_File : String) return String_Access
- is
- function To_Canonical_File_Spec (Host_File : Address) return Address;
- pragma Import
- (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
-
- C_Host_File : String (1 .. Host_File'Length + 1);
- Canonical_File_Addr : Address;
- Canonical_File_Len : CRTL.size_t;
-
- begin
- C_Host_File (1 .. Host_File'Length) := Host_File;
- C_Host_File (C_Host_File'Last) := ASCII.NUL;
-
- Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
- Canonical_File_Len := C_String_Length (Canonical_File_Addr);
-
- if Canonical_File_Len = 0 then
- return null;
- else
- return To_Path_String_Access
- (Canonical_File_Addr, Canonical_File_Len);
- end if;
-
- exception
- when others =>
- Fail ("invalid file spec: " & Host_File);
- return null;
- end To_Canonical_File_Spec;
-
- ----------------------------
- -- To_Canonical_Path_Spec --
- ----------------------------
-
- function To_Canonical_Path_Spec
- (Host_Path : String) return String_Access
- is
- function To_Canonical_Path_Spec (Host_Path : Address) return Address;
- pragma Import
- (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
-
- C_Host_Path : String (1 .. Host_Path'Length + 1);
- Canonical_Path_Addr : Address;
- Canonical_Path_Len : CRTL.size_t;
-
- begin
- C_Host_Path (1 .. Host_Path'Length) := Host_Path;
- C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
-
- Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
- Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
-
- -- Return a null string (vice a null) for zero length paths, for
- -- compatibility with getenv().
-
- return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
-
- exception
- when others =>
- Fail ("invalid path spec: " & Host_Path);
- return null;
- end To_Canonical_Path_Spec;
-
----------------------
-- To_Host_Dir_Spec --
----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- a list of valid Unix syntax file or directory specs. If Only_Dirs is
-- True, then only return directories.
- function To_Canonical_Dir_Spec
- (Host_Dir : String;
- Prefix_Style : Boolean) return String_Access;
- -- Convert a host syntax directory specification to canonical (Unix)
- -- syntax. If Prefix_Style then make it a valid file specification prefix.
- -- A file specification prefix is a directory specification that can be
- -- appended with a simple file specification to yield a valid absolute
- -- or relative path to a file. On a conversion to Unix syntax this simply
- -- means the spec has a trailing slash ("/").
-
- function To_Canonical_File_Spec
- (Host_File : String) return String_Access;
- -- Convert a host syntax file specification to canonical (Unix) syntax
-
- function To_Canonical_Path_Spec
- (Host_Path : String) return String_Access;
- -- Convert a host syntax Path specification to canonical (Unix) syntax
-
function To_Host_Dir_Spec
(Canonical_Dir : String;
Prefix_Style : Boolean) return String_Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Dummy : Boolean;
pragma Warnings (Off, Dummy);
- Real_Project_File_Name : String_Access :=
- Osint.To_Canonical_File_Spec
- (Project_File_Name);
Path_Name_Id : Path_Name_Type;
begin
(Env.Project_Path, Target_Name);
end if;
- if Real_Project_File_Name = null then
- Real_Project_File_Name := new String'(Project_File_Name);
- end if;
-
Project := Empty_Node;
Find_Project (Env.Project_Path,
- Project_File_Name => Real_Project_File_Name.all,
+ Project_File_Name => Project_File_Name,
Directory => Current_Directory,
Path => Path_Name_Id);
- Free (Real_Project_File_Name);
if Errout_Handling /= Never_Finalize then
Prj.Err.Initialize;
end if;
end Insert_List_After_And_Analyze;
- -- Version with check(s) suppressed
-
- procedure Insert_List_After_And_Analyze
- (N : Node_Id; L : List_Id; Suppress : Check_Id)
- is
- begin
- if Suppress = All_Checks then
- declare
- Svs : constant Suppress_Array := Scope_Suppress.Suppress;
- begin
- Scope_Suppress.Suppress := (others => True);
- Insert_List_After_And_Analyze (N, L);
- Scope_Suppress.Suppress := Svs;
- end;
-
- else
- declare
- Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
- begin
- Scope_Suppress.Suppress (Suppress) := True;
- Insert_List_After_And_Analyze (N, L);
- Scope_Suppress.Suppress (Suppress) := Svg;
- end;
- end if;
- end Insert_List_After_And_Analyze;
-
------------------------------------
-- Insert_List_Before_And_Analyze --
------------------------------------
end if;
end Insert_List_Before_And_Analyze;
- -- Version with check(s) suppressed
-
- procedure Insert_List_Before_And_Analyze
- (N : Node_Id; L : List_Id; Suppress : Check_Id)
- is
- begin
- if Suppress = All_Checks then
- declare
- Svs : constant Suppress_Array := Scope_Suppress.Suppress;
- begin
- Scope_Suppress.Suppress := (others => True);
- Insert_List_Before_And_Analyze (N, L);
- Scope_Suppress.Suppress := Svs;
- end;
-
- else
- declare
- Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
- begin
- Scope_Suppress.Suppress (Suppress) := True;
- Insert_List_Before_And_Analyze (N, L);
- Scope_Suppress.Suppress (Suppress) := Svg;
- end;
- end if;
- end Insert_List_Before_And_Analyze;
-
----------
-- Lock --
----------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Insert_List_After_And_Analyze
(N : Node_Id; L : List_Id);
- procedure Insert_List_After_And_Analyze
- (N : Node_Id; L : List_Id; Suppress : Check_Id);
-- Inserts list L after node N using Nlists.Insert_List_After, and then,
-- after this insertion is complete, analyzes all the nodes in the list,
-- including any additional nodes generated by this analysis. If the list
- -- is empty or No_List, the call has no effect. If the Suppress argument is
- -- present, then the analysis is done with the specified check suppressed
- -- (can be All_Checks to suppress all checks).
+ -- is empty or No_List, the call has no effect.
procedure Insert_List_Before_And_Analyze
(N : Node_Id; L : List_Id);
- procedure Insert_List_Before_And_Analyze
- (N : Node_Id; L : List_Id; Suppress : Check_Id);
-- Inserts list L before node N using Nlists.Insert_List_Before, and then,
-- after this insertion is complete, analyzes all the nodes in the list,
-- including any additional nodes generated by this analysis. If the list
- -- is empty or No_List, the call has no effect. If the Suppress argument is
- -- present, then the analysis is done with the specified check suppressed
- -- (can be All_Checks to suppress all checks).
+ -- is empty or No_List, the call has no effect.
procedure Insert_After_And_Analyze
(N : Node_Id; M : Node_Id);
projects / gcc.git / commitdiff