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

[multiple changes] 

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* exp_ch9.adb, exp_sel.adb, restrict.ads, exp_disp.adb, erroutc.ads,
	exp_ch3.adb: Minor reformatting.

2011-08-02  Emmanuel Briot  <briot@adacore.com>

	* adaint.c (__gnat_locate_exec_on_path): only returns executable
	files, not any regular file.
	(__gnat_locate_file_with_predicate): new subprogram.

2011-08-02  Yannick Moy  <moy@adacore.com>

	* sinfo.adb, sinfo.ads: Restrict the use of flags
	Has_Dynamic_Length_Check and Has_Dynamic_Range_Check to expression
	nodes, plus N_Subtype_Declaration for the 2nd one.

From-SVN: r177180
This commit is contained in:
Arnaud Charlet 2011-08-02 17:25:25 +02:00
parent 4fbad0ba4c
commit 052e0603b1
10 changed files with 3329 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3209
gcc/ada/ChangeLog
View File

File diff suppressed because it is too large Load Diff

35
gcc/ada/adaint.c
View File

@ -2700,10 +2700,11 @@ __gnat_os_exit (int status)
exit (status);
}
/* Locate a regular file, give a Path value. */
/* Locate file on path, that matches a predicate */
char *
__gnat_locate_regular_file (char *file_name, char *path_val)
__gnat_locate_file_with_predicate
(char *file_name, char *path_val, int (*predicate)(char*))
{
char *ptr;
char *file_path = (char *) alloca (strlen (file_name) + 1);
@ -2733,7 +2734,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
if (absolute)
{
if (__gnat_is_regular_file (file_path))
if (predicate (file_path))
return xstrdup (file_path);
return 0;
@ -2746,7 +2747,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
if (*ptr != 0)
{
if (__gnat_is_regular_file (file_name))
if (predicate (file_name))
return xstrdup (file_name);
}
@ -2787,7 +2788,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
strcpy (++ptr, file_name);
if (__gnat_is_regular_file (file_path))
if (predicate (file_path))
return xstrdup (file_path);
if (*path_val == 0)
@ -2802,6 +2803,24 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
return 0;
}
/* Locate an executable file, give a Path value. */
char *
__gnat_locate_executable_file (char *file_name, char *path_val)
{
return __gnat_locate_file_with_predicate
(file_name, path_val, &__gnat_is_executable_file);
}
/* Locate a regular file, give a Path value. */
char *
__gnat_locate_regular_file (char *file_name, char *path_val)
{
return __gnat_locate_file_with_predicate
(file_name, path_val, &__gnat_is_regular_file);
}
/* Locate an executable given a Path argument. This routine is only used by
gnatbl and should not be used otherwise. Use locate_exec_on_path
instead. */
@ -2818,14 +2837,14 @@ __gnat_locate_exec (char *exec_name, char *path_val)
strcpy (full_exec_name, exec_name);
strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
ptr = __gnat_locate_regular_file (full_exec_name, path_val);
ptr = __gnat_locate_executable_file (full_exec_name, path_val);
if (ptr == 0)
return __gnat_locate_regular_file (exec_name, path_val);
return __gnat_locate_executable_file (exec_name, path_val);
return ptr;
}
else
return __gnat_locate_regular_file (exec_name, path_val);
return __gnat_locate_executable_file (exec_name, path_val);
}
/* Locate an executable using the Systems default PATH. */

70
gcc/ada/erroutc.ads
View File

@ -219,33 +219,33 @@ package Erroutc is
-- error message table, since messages are not always inserted in sequence.
Last_Error_Msg : Error_Msg_Id;
-- The last entry on the list of error messages. Note that this is not
-- the same as the physically last entry in the error message table, since
-- messages are not always inserted in sequence.
-- The last entry on the list of error messages. Note: this is not the same
-- as the physically last entry in the error message table, since messages
-- are not always inserted in sequence.
--------------------------
-- Warning Mode Control --
--------------------------
-- Pragma Warnings allows warnings to be turned off for a specified
-- region of code, and the following tables are the data structures used
-- to keep track of these regions.
-- Pragma Warnings allows warnings to be turned off for a specified region
-- of code, and the following tables are the data structures used to keep
-- track of these regions.
-- The first table is used for the basic command line control, and for
-- the forms of Warning with a single ON or OFF parameter.
-- The first table is used for the basic command line control, and for the
-- forms of Warning with a single ON or OFF parameter.
-- It contains pairs of source locations, the first being the start
-- location for a warnings off region, and the second being the end
-- location. When a pragma Warnings (Off) is encountered, a new entry
-- is established extending from the location of the pragma to the
-- end of the current source file. A subsequent pragma Warnings (On)
-- adjusts the end point of this entry appropriately.
-- location. When a pragma Warnings (Off) is encountered, a new entry is
-- established extending from the location of the pragma to the end of the
-- current source file. A subsequent pragma Warnings (On) adjusts the end
-- point of this entry appropriately.
-- If all warnings are suppressed by command switch, then there is a
-- dummy entry (put there by Errout.Initialize) at the start of the
-- table which covers all possible Source_Ptr values. Note that the
-- source pointer values in this table always reference the original
-- template, not an instantiation copy, in the generic case.
-- If all warnings are suppressed by command switch, then there is a dummy
-- entry (put there by Errout.Initialize) at the start of the table which
-- covers all possible Source_Ptr values. Note that the source pointer
-- values in this table always reference the original template, not an
-- instantiation copy, in the generic case.
type Warnings_Entry is record
Start : Source_Ptr;
@ -280,9 +280,9 @@ package Erroutc is
-- Set to True if entry has been used to suppress a warning
Config : Boolean;
-- True if pragma is configuration pragma (in which case no matching
-- Off pragma is required, and it is not required that a specific
-- warning be suppressed).
-- True if pragma is configuration pragma (in which case no matching Off
-- pragma is required, and it is not required that a specific warning be
-- suppressed).
end record;
package Specific_Warnings is new Table.Table (
@ -304,10 +304,10 @@ package Erroutc is
-- end Mumble;
-- The trouble is that the first pragma is technically a configuration
-- pragma, and yet it is clearly being used in the context of thinking
-- of it as a specific case. To deal with this, what we do is that the
-- On entry can match a configuration pragma from the same file, and if
-- we find such an On entry, we cancel the indication of it being the
-- pragma, and yet it is clearly being used in the context of thinking of
-- it as a specific case. To deal with this, what we do is that the On
-- entry can match a configuration pragma from the same file, and if we
-- find such an On entry, we cancel the indication of it being the
-- configuration case. This seems to handle all cases we run into ok.
-----------------
@ -336,16 +336,16 @@ package Erroutc is
-- output giving node number (of node N) if the debug X switch is set.
procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
-- This function is passed the Id values of two error messages. If
-- either M1 or M2 is a continuation message, or is already deleted,
-- the call is ignored. Otherwise a check is made to see if M1 and M2
-- are duplicated or redundant. If so, the message to be deleted and
-- all its continuations are marked with the Deleted flag set to True.
-- This function is passed the Id values of two error messages. If either
-- M1 or M2 is a continuation message, or is already deleted, the call is
-- ignored. Otherwise a check is made to see if M1 and M2 are duplicated or
-- redundant. If so, the message to be deleted and all its continuations
-- are marked with the Deleted flag set to True.
procedure Output_Error_Msgs (E : in out Error_Msg_Id);
-- Output source line, error flag, and text of stored error message and
-- all subsequent messages for the same line and unit. On return E is
-- set to be one higher than the last message output.
-- Output source line, error flag, and text of stored error message and all
-- subsequent messages for the same line and unit. On return E is set to be
-- one higher than the last message output.
procedure Output_Line_Number (L : Logical_Line_Number);
-- Output a line number as six digits (with leading zeroes suppressed),
@ -366,9 +366,9 @@ package Erroutc is
-- including the end points) will be deleted from the error listing.
function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
-- See if two messages have the same text. Returns true if the text
-- of the two messages is identical, or if one of them is the same
-- as the other with an appended "instance at xxx" tag.
-- See if two messages have the same text. Returns true if the text of the
-- two messages is identical, or if one of them is the same as the other
-- with an appended "instance at xxx" tag.
procedure Set_Msg_Blank;
-- Sets a single blank in the message if the preceding character is a

14
gcc/ada/exp_ch3.adb
View File

@ -8459,15 +8459,15 @@ package body Exp_Ch3 is
-- they may be ancestors of synchronized interface types).
elsif (not Is_Interface (Tag_Typ)
and then Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
and then Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else
(Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Interfaces (Tag_Typ))
and then Has_Interfaces (Tag_Typ))
or else
(not Tagged_Type_Expansion
and then not Is_Interface (Tag_Typ)
and then Tag_Typ = Root_Type (Tag_Typ))
and then not Is_Interface (Tag_Typ)
and then Tag_Typ = Root_Type (Tag_Typ))
then
Append_To (Res,
Make_Subprogram_Declaration (Loc,
@ -8944,10 +8944,10 @@ package body Exp_Ch3 is
and then not Is_Interface (Tag_Typ)
and then
((Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else
(Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Interfaces (Tag_Typ))
and then Has_Interfaces (Tag_Typ))
or else
(not Tagged_Type_Expansion
and then Tag_Typ = Root_Type (Tag_Typ)))

12
gcc/ada/exp_ch9.adb
View File

@ -8698,9 +8698,7 @@ package body Exp_Ch9 is
if Tagged_Type_Expansion then
Prepend_To (Params,
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag), Concval),
Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
@ -8710,20 +8708,20 @@ package body Exp_Ch9 is
else
Prepend_To (Params,
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
-- Obj_Typ
Make_Attribute_Reference (Loc,
Prefix => Concval,
Prefix => Concval,
Attribute_Name => Name_Tag),
-- Tag_Typ
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Etype (Concval), Loc),
Prefix => New_Reference_To (Etype (Concval), Loc),
Attribute_Name => Name_Tag),
-- Position

4
gcc/ada/exp_disp.adb
View File

@ -6627,7 +6627,7 @@ package body Exp_Disp is
-- Iface_Tag
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Iface, Loc),
Prefix => New_Reference_To (Iface, Loc),
Attribute_Name => Name_Tag),
-- OSD
@ -6648,7 +6648,7 @@ package body Exp_Disp is
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Interface_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint
Constraint => Make_Index_Or_Discriminant_Constraint
(Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Num_Ifaces)))),

7
gcc/ada/exp_sel.adb
View File

@ -156,7 +156,7 @@ package body Exp_Sel is
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => Obj,
Prefix => Obj,
Attribute_Name => Name_Tag);
end if;
@ -205,7 +205,7 @@ package body Exp_Sel is
if Tagged_Type_Expansion then
return
Make_Assignment_Statement (Loc,
Name => New_Reference_To (S, Loc),
Name => New_Reference_To (S, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
@ -218,10 +218,11 @@ package body Exp_Sel is
else
return
Make_Assignment_Statement (Loc,
Name => New_Reference_To (S, Loc),
Name => New_Reference_To (S, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
-- Obj_Typ

18
gcc/ada/restrict.ads
View File

@ -185,6 +185,10 @@ package Restrict is
-- The table contains pairs of source locations, the first being the start
-- location for hidden region, and the second being the end location.
-- Note that the start location is included in the hidden region, while
-- the end location is excluded from it. (It typically corresponds to the
-- next token during scanning.)
type SPARK_Hide_Entry is record
Start : Source_Ptr;
Stop : Source_Ptr;
@ -310,8 +314,8 @@ package Restrict is
function Get_Restriction_Id
(N : Name_Id) return Restriction_Id;
-- Given an identifier name, determines if it is a valid restriction
-- identifier, and if so returns the corresponding Restriction_Id
-- value, otherwise returns Not_A_Restriction_Id.
-- identifier, and if so returns the corresponding Restriction_Id value,
-- otherwise returns Not_A_Restriction_Id.
function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
-- Determine if given location is covered by a hidden region range in the
@ -358,9 +362,9 @@ package Restrict is
function Restricted_Profile return Boolean;
-- Tests if set of restrictions corresponding to Profile (Restricted) is
-- currently in effect (set by pragma Profile, or by an appropriate set
-- of individual Restrictions pragmas). Returns True only if all the
-- required restrictions are set.
-- currently in effect (set by pragma Profile, or by an appropriate set of
-- individual Restrictions pragmas). Returns True only if all the required
-- restrictions are set.
procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr);
-- Insert a new hidden region range in the SPARK hides table
@ -394,8 +398,8 @@ package Restrict is
(Unit : Node_Id;
Warn : Boolean;
Profile : Profile_Name := No_Profile);
-- Sets given No_Dependence restriction in table if not there already.
-- Warn is True if from Restriction_Warnings, or for Restrictions if flag
-- Sets given No_Dependence restriction in table if not there already. Warn
-- is True if from Restriction_Warnings, or for Restrictions if the flag
-- Treat_Restrictions_As_Warnings is set. False if from Restrictions and
-- this flag is not set. Profile is set to a non-default value if the
-- No_Dependence restriction comes from a Profile pragma.

13
gcc/ada/sinfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -1440,11 +1440,17 @@ package body Sinfo is
function Has_Dynamic_Length_Check
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind in N_Subexpr);
return Flag10 (N);
end Has_Dynamic_Length_Check;
function Has_Dynamic_Range_Check
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subtype_Declaration
or else NT (N).Nkind in N_Subexpr);
return Flag12 (N);
end Has_Dynamic_Range_Check;
@ -4484,12 +4490,17 @@ package body Sinfo is
procedure Set_Has_Dynamic_Length_Check
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind in N_Subexpr);
Set_Flag10 (N, Val);
end Set_Has_Dynamic_Length_Check;
procedure Set_Has_Dynamic_Range_Check
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subtype_Declaration
or else NT (N).Nkind in N_Subexpr);
Set_Flag12 (N, Val);
end Set_Has_Dynamic_Range_Check;

30
gcc/ada/sinfo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -424,6 +424,8 @@ package Sinfo is
-- Raises_Constraint_Error (Flag7-Sem) evaluation raises CE
-- Must_Not_Freeze (Flag8-Sem) set if must not freeze
-- Do_Range_Check (Flag9-Sem) set if a range check needed
-- Has_Dynamic_Length_Check (Flag10-Sem) set if length check inserted
-- Has_Dynamic_Range_Check (Flag12-Sem) set if range check inserted
-- Assignment_OK (Flag15-Sem) set if modification is OK
-- Is_Controlling_Actual (Flag16-Sem) set for controlling argument
@ -485,18 +487,6 @@ package Sinfo is
-- refers to a node or is posted on its source location, and has the
-- effect of inhibiting further messages involving this same node.
-- Has_Dynamic_Length_Check (Flag10-Sem)
-- This flag is present on all nodes. It is set to indicate that one of
-- the routines in unit Checks has generated a length check action which
-- has been inserted at the flagged node. This is used to avoid the
-- generation of duplicate checks.
-- Has_Dynamic_Range_Check (Flag12-Sem)
-- This flag is present on all nodes. It is set to indicate that one of
-- the routines in unit Checks has generated a range check action which
-- has been inserted at the flagged node. This is used to avoid the
-- generation of duplicate checks.
------------------------------------
-- Description of Semantic Fields --
------------------------------------
@ -1125,6 +1115,19 @@ package Sinfo is
-- handler is deleted during optimization. For further details on why
-- this is required, see Exp_Ch11.Remove_Handler_Entries.
-- Has_Dynamic_Length_Check (Flag10-Sem)
-- This flag is present on all expression nodes. It is set to indicate
-- that one of the routines in unit Checks has generated a length check
-- action which has been inserted at the flagged node. This is used to
-- avoid the generation of duplicate checks.
-- Has_Dynamic_Range_Check (Flag12-Sem)
-- This flag is present in N_Subtype_Declaration nodes and on all
-- expression nodes. It is set to indicate that one of the routines in
-- unit Checks has generated a range check action which has been inserted
-- at the flagged node. This is used to avoid the generation of duplicate
-- checks.
-- Has_Local_Raise (Flag8-Sem)
-- Present in exception handler nodes. Set if the handler can be entered
-- via a local raise that gets transformed to a goto statement. This will
@ -2217,6 +2220,7 @@ package Sinfo is
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-- Exception_Junk (Flag8-Sem)
-- Has_Dynamic_Range_Check (Flag12-Sem)
-------------------------------
-- 3.2.2 Subtype Indication --