+2011-08-02 Vincent Celier <celier@adacore.com>
+
+ * link.c: Only import "auto-host.h" when building the gnattools.
+
+2011-08-02 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb: Inter-unit inlining does not work for a subprogram
+ which calls a local subprogram, so extract subprogram
+ from Mark_Non_ALFA_Subprogram_Body.
+
+2011-08-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch9.adb
+ (Extract_Dispatching_Call): If the type of the dispatching object is an
+ access type then return an explicit dereference in the Object out-mode
+ parameter.
+
+2011-08-02 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Generate range
+ compatibility checks for all indexes of an array subtype, not just the
+ first. Reset Has_Dynamic_Range_Check on the subtype before each
+ potential check to ensure that Insert_Range_Checks will not elide any
+ of the dynamic checks.
+
+2011-08-02 Yannick Moy <moy@adacore.com>
+
+ * par-prag.ad (Process_Restrictions_Or_Restriction_Warnings): recognize
+ SPARK restriction at parsing time.
+ * scng.adb (Scan): Generate a token Tok_SPARK_Hide for a SPARK HIDE
+ directive only if the SPARK restriction is set for this unit.
+
2011-08-02 Yannick Moy <moy@adacore.com>
* sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_util.adb, sem_util.ads,
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
- -- its object parameter, its actual parameters and the formal parameters
- -- of the overridden interface-level version.
+ -- its actual dispatching object, its actual parameters and the formal
+ -- parameters of the overridden interface-level version. If the type of
+ -- the dispatching object is an access type then an explicit dereference
+ -- is returned in Object.
procedure Extract_Entry
(N : Node_Id;
if Present (Original_Node (Object)) then
Object := Original_Node (Object);
end if;
+
+ -- If the type of the dispatching object is an access type then return
+ -- an explicit dereference
+
+ if Is_Access_Type (Etype (Object)) then
+ Object := Make_Explicit_Dereference (Sloc (N), Object);
+ Analyze (Object);
+ end if;
end Extract_Dispatching_Call;
-------------------
#endif
#include <string.h>
+
+#ifdef IN_GCC
#include "auto-host.h"
+#endif
/* objlist_file_supported is set to 1 when the system linker allows */
/* response file, that is a file that contains the list of object files. */
-- --
-- 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- --
procedure Process_Restrictions_Or_Restriction_Warnings;
-- Common processing for Restrictions and Restriction_Warnings pragmas.
- -- This routine only processes the case of No_Obsolescent_Features, which
- -- is the only restriction that has syntactic effects. No general error
- -- checking is done, since this will be done in Sem_Prag. The other case
- -- processed is pragma Restrictions No_Dependence, since otherwise this is
- -- done too late.
+ -- This routine processes the cases of No_Obsolescent_Features and SPARK,
+ -- which are the only restriction that have syntactic effects. In the case
+ -- of SPARK, it controls whether the scanner generates a token
+ -- Tok_SPARK_Hide for HIDE directives formatted as Ada comments. No general
+ -- error checking is done, since this will be done in Sem_Prag. The other
+ -- case processed is pragma Restrictions No_Dependence, since otherwise
+ -- this is done too late.
----------
-- Arg1 --
Set_Restriction (No_Obsolescent_Features, Pragma_Node);
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
+ when SPARK =>
+ Set_Restriction (SPARK, Pragma_Node);
+ Restriction_Warnings (SPARK) :=
+ Prag_Id = Pragma_Restriction_Warnings;
when others =>
null;
end case;
with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Scans; use Scans;
with Sinput; use Sinput;
with Snames; use Snames;
return;
end if;
- if Source (Start_Of_Comment) = '#' then
+ -- Generate a token Tok_SPARK_Hide for a SPARK HIDE directive
+ -- only if the SPARK restriction is set for this unit.
+
+ if Restriction_Check_Required (SPARK)
+ and then Source (Start_Of_Comment) = '#'
+ then
declare
Scan_SPARK_Ptr : Source_Ptr;
Conditional_Delay (Id, T);
end if;
- -- Check that constraint_error is raised for a scalar subtype
- -- indication when the lower or upper bound of a non-null range
- -- lies outside the range of the type mark.
+ -- Check that Constraint_Error is raised for a scalar subtype indication
+ -- when the lower or upper bound of a non-null range lies outside the
+ -- range of the type mark.
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
if Is_Scalar_Type (Etype (Id))
(Scalar_Range (Id),
Etype (Subtype_Mark (Subtype_Indication (N))));
+ -- In the array case, check compatibility for each index
+
elsif Is_Array_Type (Etype (Id))
and then Present (First_Index (Id))
then
-- This really should be a subprogram that finds the indications
-- to check???
- if ((Nkind (First_Index (Id)) = N_Identifier
- and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
- or else Nkind (First_Index (Id)) = N_Subtype_Indication)
- and then
- Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
- then
- declare
- Target_Typ : constant Entity_Id :=
- Etype
- (First_Index (Etype
- (Subtype_Mark (Subtype_Indication (N)))));
- begin
- R_Checks :=
- Get_Range_Checks
- (Scalar_Range (Etype (First_Index (Id))),
- Target_Typ,
- Etype (First_Index (Id)),
- Defining_Identifier (N));
-
- Insert_Range_Checks
- (R_Checks,
- N,
- Target_Typ,
- Sloc (Defining_Identifier (N)));
- end;
- end if;
+ declare
+ Subt_Index : Node_Id := First_Index (Id);
+ Target_Index : Node_Id :=
+ First_Index (Etype
+ (Subtype_Mark (Subtype_Indication (N))));
+ Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N);
+
+ begin
+ while Present (Subt_Index) loop
+ if ((Nkind (Subt_Index) = N_Identifier
+ and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
+ or else Nkind (Subt_Index) = N_Subtype_Indication)
+ and then
+ Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
+ then
+ declare
+ Target_Typ : constant Entity_Id :=
+ Etype (Target_Index);
+ begin
+ R_Checks :=
+ Get_Range_Checks
+ (Scalar_Range (Etype (Subt_Index)),
+ Target_Typ,
+ Etype (Subt_Index),
+ Defining_Identifier (N));
+
+ -- Reset Has_Dynamic_Range_Check on the subtype to
+ -- prevent elision of the index check due to a dynamic
+ -- check generated for a preceding index (needed since
+ -- Insert_Range_Checks tries to avoid generating
+ -- redundant checks on a given declaration).
+
+ Set_Has_Dynamic_Range_Check (N, False);
+
+ Insert_Range_Checks
+ (R_Checks,
+ N,
+ Target_Typ,
+ Sloc (Defining_Identifier (N)));
+
+ -- Record whether this index involved a dynamic check
+
+ Has_Dyn_Chk :=
+ Has_Dyn_Chk or else Has_Dynamic_Range_Check (N);
+ end;
+ end if;
+
+ Next_Index (Subt_Index);
+ Next_Index (Target_Index);
+ end loop;
+
+ -- Finally, mark whether the subtype involves dynamic checks
+
+ Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk);
+ end;
end if;
end if;
-- T is a derived tagged type. Check whether the type extension is null.
-- If the parent type is fully initialized, T can be treated as such.
+ procedure Mark_Non_ALFA_Subprogram_Body_Unconditional;
+ -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the
+ -- latter to be small and inlined.
+
------------------------------
-- Abstract_Interface_List --
------------------------------
-----------------------------------
procedure Mark_Non_ALFA_Subprogram_Body is
-
- procedure Unconditional_Mark;
+ begin
-- Isolate marking of the current subprogram body so that the body of
-- Mark_Non_ALFA_Subprogram_Body is small and inlined.
- ------------------------
- -- Unconditional_Mark --
- ------------------------
+ if ALFA_Mode then
+ Mark_Non_ALFA_Subprogram_Body_Unconditional;
+ end if;
+ end Mark_Non_ALFA_Subprogram_Body;
- procedure Unconditional_Mark is
- Cur_Subp : constant Entity_Id := Current_Subprogram;
- begin
- if Present (Cur_Subp)
- and then (Is_Subprogram (Cur_Subp)
- or else Is_Generic_Subprogram (Cur_Subp))
- then
- Set_Body_Is_In_ALFA (Cur_Subp, False);
- end if;
- end Unconditional_Mark;
+ -------------------------------------------------
+ -- Mark_Non_ALFA_Subprogram_Body_Unconditional --
+ -------------------------------------------------
+ procedure Mark_Non_ALFA_Subprogram_Body_Unconditional is
+ Cur_Subp : constant Entity_Id := Current_Subprogram;
begin
- if ALFA_Mode then
- Unconditional_Mark;
+ if Present (Cur_Subp)
+ and then (Is_Subprogram (Cur_Subp)
+ or else Is_Generic_Subprogram (Cur_Subp))
+ then
+ Set_Body_Is_In_ALFA (Cur_Subp, False);
end if;
- end Mark_Non_ALFA_Subprogram_Body;
+ end Mark_Non_ALFA_Subprogram_Body_Unconditional;
---------------------
-- Defining_Entity --
projects / gcc.git / commitdiff