+2013-04-24 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Process_Convention): Move Stdcall tests to
+ Set_Convention_From_Pragma so that they are applied to each
+ entry of a homonym set.
+ (Process_Convention): Don't try to set convention if already set.
+
+2013-04-24 Robert Dewar <dewar@adacore.com>
+
+ * gnatbind.adb: Minor reformatting.
+
+2013-04-24 Vincent Celier <celier@adacore.com>
+
+ * clean.adb (Gnatclean): Add the default project search
+ directories in the project search path after scanning the
+ switches on the command line.
+ (Initialize): Do not put the default project search directories in the
+ project search path.
+ * gnatcmd.adb (GNATcmd): Add the default project search
+ directories in the project search path after scanning the switches
+ on the command line.
+ * make.adb (Initialize): Add the default project search
+ directories in the project search path after scanning the switches
+ on the command line.
+
+2013-04-24 Yannick Moy <moy@adacore.com>
+
+ * restrict.ads (Restriction_Warnings): Initialize with all False value.
+
+2013-04-24 Robert Dewar <dewar@adacore.com>
+
+ * checks.ads, checks.adb (Predicate_Checks_Suppressed): New function.
+ * exp_util.ads, exp_util.adb (Make_Predicate_Check): Check setting of
+ Predicate_Check.
+ * snames.ads-tmpl (Name_Predicate_Check): New check name.
+ * types.ads (Predicate_Check): New definition.
+ * gnat_rm.texi: Add documentation for Predicate_Check.
+
2013-04-24 Ed Schonberg <schonberg@adacore.com>
* exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): If this
end if;
end Overflow_Checks_Suppressed;
+ ---------------------------------
+ -- Predicate_Checks_Suppressed --
+ ---------------------------------
+
+ function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
+ begin
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Predicate_Check);
+ else
+ return Scope_Suppress.Suppress (Predicate_Check);
+ end if;
+ end Predicate_Checks_Suppressed;
+
-----------------------------
-- Range_Checks_Suppressed --
-----------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
+ function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
Parse_Cmd_Line;
+ -- Add the default project search directories now, after the directories
+ -- that have been specified by switches -aP<dir>.
+
+ Prj.Env.Initialize_Default_Project_Path
+ (Root_Environment.Project_Path,
+ Target_Name => Sdefault.Target_Name.all);
+
if Verbose_Mode then
Display_Copyright;
end if;
Snames.Initialize;
Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
- Prj.Env.Initialize_Default_Project_Path
- (Root_Environment.Project_Path,
- Target_Name => Sdefault.Target_Name.all);
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
begin
pragma Assert
(Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
-
- if Check_Kind (Name_Invariant) = Name_Check then
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
-
- else
- return
- Make_Null_Statement (Loc);
- end if;
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Invariant_Call;
------------------------
Nam : Name_Id;
begin
+ -- If predicate checks are suppressed, then return a null statement.
+ -- For this call, we check only the scope setting. If the caller wants
+ -- to check a specific entity's setting, they must do it manually.
+
+ if Predicate_Checks_Suppressed (Empty) then
+ return Make_Null_Statement (Loc);
+ end if;
+
-- Compute proper name to use, we need to get this right so that the
-- right set of check policies apply to the Check pragma we are making.
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id;
-- Typ is a type with Predicate_Function set. This routine builds a Check
- -- pragma whose first argument is Predicate, and the second argument is a
- -- call to the this predicate function with Expr as the argument.
+ -- pragma whose first argument is Predicate, and the second argument is
+ -- a call to the predicate function of Typ with Expr as the argument. If
+ -- Predicate_Check is suppressed then a null statement is returned instead.
function Make_Subtype_From_Expr
(E : Node_Id;
@noindent
This is a standard pragma, and supports all the check names required in
-the RM. It is included here because GNAT recognizes one additional check
-name: @code{Alignment_Check} which can be used to suppress alignment checks
+the RM. It is included here because GNAT recognizes some additional check
+names that are implementation defined (as permitted by the RM):
+
+@itemize @bullet
+
+@item
+@code{Alignment_Check} can be used to suppress alignment checks
on addresses used in address clauses. Such checks can also be suppressed
by suppressing range checks, but the specific use of @code{Alignment_Check}
allows suppression of alignment checks without suppressing other range checks.
+@item
+@code{Predicate_Check} can be used to control whether predicate checks are
+active. It is applicable only to predicates for which the policy is
+@code{Check}. Unlike @code{Assertion_Policy}, which determines if a given
+predicate is ignored or checked for the whole program, the use of
+@code{Suppress} and @code{Unsuppress} with this check name allows a given
+predicate to be turned on and off at specific points in the program.
+
+@item
+@code{Validity_Check} can be used specifically to control validity checks.
+If @code{Suppress} is used to suppress validity checks, then no validity
+checks are performed, including those specified by the appropriate compiler
+switch or the @code{Validity_Checks} pragma.
+
+@item
+Additional check names previously introduced by use of the @code{Check_Name}
+pragma are also allowed.
+
+@end itemize
+
+@noindent
Note that pragma Suppress gives the compiler permission to omit
checks, but does not require the compiler to omit checks. The compiler
will generate checks if they are essentially free, even when they are
This pragma is standard in Ada 2005. It is available in all earlier versions
of Ada as an implementation-defined pragma.
+Note that in addition to the checks defined in the Ada RM, GNAT recogizes
+a number of implementation-defined check names. See description of pragma
+@code{Suppress} for full details.
+
@node Pragma Use_VADS_Size
@unnumberedsec Pragma Use_VADS_Size
@cindex @code{Size}, VADS compatibility
address clause values for proper alignment (that is, the address supplied
must be consistent with the alignment of the type).
+The implementation defined check name Predicate_Check controls whether
+predicate checks are generated.
+
+The implementation defined check name Validity_Check controls whether
+validity checks are generated.
+
In addition, a user program can add implementation-defined check names
by means of the pragma Check_Name.
procedure Generic_Scan_Bind_Args is
Next_Arg : Positive := 1;
+
begin
- -- Use low level argument routines to avoid dragging in the secondary
- -- stack
+ -- Use low level argument routines to avoid dragging in secondary stack
while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
+
begin
Fill_Arg (Next_Argv'Address, Next_Arg);
end loop;
end Generic_Scan_Bind_Args;
+ ---------------
+ -- Write_Arg --
+ ---------------
+
procedure Write_Arg (S : String) is
begin
Write_Str (" " & S);
-- Start of processing for Gnatbind
begin
-
-- Set default for Shared_Libgnat option
declare
Snames.Initialize;
Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
- Prj.Env.Initialize_Default_Project_Path
- (Root_Environment.Project_Path,
- Target_Name => Sdefault.Target_Name.all);
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
end Inspect_Switches;
end if;
+ -- Add the default project search directories now, after the directories
+ -- that have been specified by switches -aP<dir>.
+
+ Prj.Env.Initialize_Default_Project_Path
+ (Root_Environment.Project_Path,
+ Target_Name => Sdefault.Target_Name.all);
+
-- If there is a project file specified, parse it, get the switches
-- for the tool and setup PATH environment variables.
-- the command line switches
Prj.Tree.Initialize (Env, Gnatmake_Flags);
- Prj.Env.Initialize_Default_Project_Path
- (Env.Project_Path, Target_Name => Sdefault.Target_Name.all);
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
Usage;
end if;
+ -- Add the default project search directories now, after the directories
+ -- that have been specified by switches -aP<dir>.
+
+ Prj.Env.Initialize_Default_Project_Path
+ (Env.Project_Path, Target_Name => Sdefault.Target_Name.all);
+
-- Test for trailing -P switch
if Project_File_Name_Present and then Project_File_Name = null then
-- since we want the binder to be able to accurately diagnose inter-unit
-- restriction violations.
- Restriction_Warnings : Rident.Restriction_Flags;
+ Restriction_Warnings : Rident.Restriction_Flags := (others => False);
-- If one of these flags is set, then it means that violation of the
-- corresponding restriction results only in a warning message, not
-- in an error message, and the restriction is not otherwise enforced.
& "operation", Arg1);
end if;
+ -- Special checks for Convention_Stdcall
+
+ if C = Convention_Stdcall then
+
+ -- A dispatching call is not allowed. A dispatching subprogram
+ -- cannot be used to interface to the Win32 API, so in fact
+ -- this check does not impose any effective restriction.
+
+ if Is_Dispatching_Operation (E) then
+ Error_Msg_Sloc := Sloc (E);
+
+ -- Note: make this unconditional so that if there is more
+ -- than one call to which the pragma applies, we get a
+ -- message for each call. Also don't use Error_Pragma,
+ -- so that we get multiple messages!
+
+ Error_Msg_N
+ ("dispatching subprogram# cannot use Stdcall convention!",
+ Arg1);
+
+ -- Subprogram is allowed, but not a generic subprogram
+
+ elsif not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+
+ -- A variable is OK
+
+ and then Ekind (E) /= E_Variable
+
+ -- An access to subprogram is also allowed
+
+ and then not
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+
+ -- Allow internal call to set convention of subprogram type
+
+ and then not (Ekind (E) = E_Subprogram_Type)
+ then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be subprogram (type)",
+ Arg2);
+ end if;
+ end if;
+
-- Set the convention
Set_Convention (E, C);
("second argument of pragma% must be a subprogram", Arg2);
end if;
- -- Stdcall case
-
- if C = Convention_Stdcall then
-
- -- A dispatching call is not allowed. A dispatching subprogram
- -- cannot be used to interface to the Win32 API, so in fact this
- -- check does not impose any effective restriction.
-
- if Is_Dispatching_Operation (E) then
-
- Error_Pragma
- ("dispatching subprograms cannot use Stdcall convention");
-
- -- Subprogram is allowed, but not a generic subprogram, and not a
- -- dispatching operation.
-
- elsif not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
-
- -- A variable is OK
-
- and then Ekind (E) /= E_Variable
-
- -- An access to subprogram is also allowed
-
- and then not
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
- then
- Error_Pragma_Arg
- ("second argument of pragma% must be subprogram (type)",
- Arg2);
- end if;
- end if;
+ -- Deal with non-subprogram cases
if not Is_Subprogram (E)
and then not Is_Generic_Subprogram (E)
Check_First_Subtype (Arg2);
Set_Convention_From_Pragma (Base_Type (E));
- -- For subprograms, we must set the convention on the
+ -- For access subprograms, we must set the convention on the
-- internally generated directly designated type as well.
if Ekind (E) = E_Access_Subprogram_Type then
E1 := Homonym (E1);
exit when No (E1) or else Scope (E1) /= Current_Scope;
+ -- Ignore entry for which convention is already set
+
+ if Has_Convention_Pragma (E1) then
+ goto Continue;
+ end if;
+
-- Do not set the pragma on inherited operations or on formal
-- subprograms.
Generate_Reference (E1, Id, 'b');
end if;
end if;
+
+ <<Continue>>
+ null;
end loop;
end if;
end Process_Convention;
Name_Index_Check : constant Name_Id := N + $;
Name_Length_Check : constant Name_Id := N + $;
Name_Overflow_Check : constant Name_Id := N + $;
+ Name_Predicate_Check : constant Name_Id := N + $; -- GNAT
Name_Range_Check : constant Name_Id := N + $;
Name_Storage_Check : constant Name_Id := N + $;
Name_Tag_Check : constant Name_Id := N + $;
Index_Check : constant := 8;
Length_Check : constant := 9;
Overflow_Check : constant := 10;
- Range_Check : constant := 11;
- Storage_Check : constant := 12;
- Tag_Check : constant := 13;
- Validity_Check : constant := 14;
+ Predicate_Check : constant := 11;
+ Range_Check : constant := 12;
+ Storage_Check : constant := 13;
+ Tag_Check : constant := 14;
+ Validity_Check : constant := 15;
-- Values used to represent individual predefined checks (including the
-- setting of Atomic_Synchronization, which is implemented internally using
- -- a "check" whose name is Atomic_Synchronization.
+ -- a "check" whose name is Atomic_Synchronization).
- All_Checks : constant := 15;
+ All_Checks : constant := 16;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
projects / platform / upstream / linaro-gcc.git / commitdiff