[Ada] Improve finalization of global controlled objects

[Arnaud Charlet]

This patch is aimed at improving the finalization of global controlled objects.
It implements a ref-counting scheme for elaboration/finalization on a per-unit
basis and changes the way global objects are finalized in libraries.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Eric Botcazou  

* einfo.ads (Elaboration_Entity): Document new definition and use.
(Elaboration_Entity_Required): Adjust to above change.
* exp_attr.adb (Expand_N_Attribute_Reference): Likewise.
* exp_ch12.adb: And with and use for Snames.
(Expand_N_Generic_Instantiation): Test 'Elaborated attribute.
* exp_util.adb (Set_Elaboration_Flag): Likewise.
* sem_attr.adb (Analyze_Attribute) : Delete.
: Deal with N_Expanded_Name.
: Extend to all unit names.
* sem_elab.adb: And with and use for Uintp.
(Check_Internal_Call_Continue): Adjust to Elaboration_Entity change.
* sem_util.ads (Build_Elaboration_Entity): Adjust comment.
* sem_util.adb (Build_Elaboration_Entity): Change type to Integer.
* bindgen.adb (Gen_Elab_Externals_Ada): New local subprogram taken
from Gen_Adainit_Ada.
(Gen_Elab_Externals_C): Likewise, but taken from Gen_Adainit_C.
(Gen_Adafinal_Ada): Remove redundant test.  In the non-main program
case, do not call System.Standard_Library.Adafinal; instead call
finalize_library if needed.
(Gen_Adafinal_C): Likewise.
(Gen_Adainit_Ada): Do not set SSL.Finalize_Library_Objects in the
non-main program case.
(Gen_Adainit_C): Generate a couple of external declarations here.
In the main program case, set SSL.Finalize_Library_Objects.
(Gen_Elab_Calls_Ada): Adjust to Elaboration_Entity change.
(Gen_Elab_Calls_C): Likewise.
(Gen_Finalize_Library_Ada): Likewise.  Skip SAL interface units.
(Gen_Finalize_Library_C): Likewise.  Generate a full function.
(Gen_Main_C): Put back call to Ada_Final and don't finalize library
objects here.
(Gen_Output_File_Ada): Generate pragma Linker_Destructor for Ada_Final
if -a is specified.  Call Gen_Elab_Externals_Ada.  Move around call to
Gen_Adafinal_Ada.
(Gen_Output_File_C): Generate __attribute__((destructor)) for Ada_Final
if -a is specified.  Call Gen_Elab_Externals_C.  Remove useless couple
of external declarations.  Call Gen_Finalize_Library_C.

Index: exp_ch12.adb
===
--- exp_ch12.adb(revision 177274)
+++ exp_ch12.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- B o d y  --
 --  --
---  Copyright (C) 1997-2007, Free Software Foundation, Inc. --
+--  Copyright (C) 1997-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- --
@@ -29,6 +29,7 @@
 with Exp_Util; use Exp_Util;
 with Nmake;use Nmake;
 with Sinfo;use Sinfo;
+with Snames;   use Snames;
 with Stand;use Stand;
 with Tbuild;   use Tbuild;
 
@@ -59,7 +60,9 @@
  Condition =>
Make_Op_Not (Loc,
  Right_Opnd =>
-   New_Occurrence_Of (Elaboration_Entity (Ent), Loc)),
+   Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Elaborated,
+ Prefix => New_Occurrence_Of (Ent, Loc))),
  Reason => PE_Access_Before_Elaboration));
   end if;
end Expand_N_Generic_Instantiation;
Index: exp_util.adb
===
--- exp_util.adb(revision 177280)
+++ exp_util.adb(working copy)
@@ -6634,7 +6634,7 @@
 Asn :=
   Make_Assignment_Statement (Loc,
 Name   => New_Occurrence_Of (Ent, Loc),
-Expression => New_Occurrence_Of (Standard_True, Loc));
+Expression => Make_Integer_Literal (Loc, Uint_1));
 
 if Nkind (Parent (N)) = N_Subunit then
Insert_After (Corresponding_Stub (Parent (N)), Asn);
Index: exp_attr.adb
===
--- exp_attr.adb(revision 177274)
+++ exp_attr.adb(working copy)
@@ -1916,7 +1916,12 @@
   begin
  if Present (Elaboration_Entity (Ent)) then
 Rewrite (N,
-  New_Occurrence_Of (Elaboration_Entity (Ent), Loc));
+  Make_Op_Ne (Loc,
+Left_Opnd =>
+  New_Occurrence_Of (

[Ada] Finalization actions during abort

[Arnaud Charlet]

This patch adds a guard to the mechanism which determines whether finalization
was triggered by an abort.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Hristian Kirtchev  

* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Update the comment
on the generated code.
(Build_Finalize_Statements): Update the comment on the generated code.
(Build_Initialize_Statements): Update the comment on the generated code.
(Build_Object_Declarations): Add local variable Result. The object
declarations are now built in sequence.
* rtsfind.ads: Add RE_Exception_Occurrence_Access to tables RE_Id and
RE_Unit_Table.

Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 177283)
+++ exp_ch7.adb (working copy)
@@ -2897,6 +2897,7 @@
is
   A_Expr : Node_Id;
   E_Decl : Node_Id;
+  Result : List_Id;
 
begin
   if Restriction_Active (No_Exception_Propagation) then
@@ -2907,37 +2908,87 @@
   pragma Assert (Present (E_Id));
   pragma Assert (Present (Raised_Id));
 
-  --  Generate:
-  --Exception_Identity (Get_Current_Excep.all.all) =
-  --  Standard'Abort_Signal'Identity;
+  Result := New_List;
 
+  --  In certain scenarios, finalization can be triggered by an abort. If
+  --  the finalization itself fails and raises an exception, the resulting
+  --  Program_Error must be supressed and replaced by an abort signal. In
+  --  order to detect this scenario, save the state of entry into the
+  --  finalization code.
+
   if Abort_Allowed then
- A_Expr :=
-   Make_Op_Eq (Loc,
- Left_Opnd =>
-   Make_Function_Call (Loc,
- Name =>
-   New_Reference_To (RTE (RE_Exception_Identity), Loc),
-   Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
-   Prefix =>
- Make_Function_Call (Loc,
-   Name =>
- Make_Explicit_Dereference (Loc,
-   Prefix =>
- New_Reference_To
-   (RTE (RE_Get_Current_Excep), Loc)),
+ declare
+Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
 
- Right_Opnd =>
-   Make_Attribute_Reference (Loc,
- Prefix =>
-   New_Reference_To (Stand.Abort_Signal, Loc),
- Attribute_Name => Name_Identity));
+ begin
+--  Generate:
+--Temp : constant Exception_Occurrence_Access :=
+-- Get_Current_Excep.all;
+
+Append_To (Result,
+  Make_Object_Declaration (Loc,
+Defining_Identifier => Temp_Id,
+Constant_Present => True,
+Object_Definition =>
+  New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc),
+Expression =>
+  Make_Function_Call (Loc,
+Name =>
+  Make_Explicit_Dereference (Loc,
+Prefix =>
+  New_Reference_To
+(RTE (RE_Get_Current_Excep), Loc);
+
+--  Generate:
+--Temp /= null
+--  and then Exception_Identity (Temp.all) =
+-- Standard'Abort_Signal'Identity;
+
+A_Expr :=
+  Make_And_Then (Loc,
+Left_Opnd =>
+  Make_Op_Ne (Loc,
+Left_Opnd =>
+  New_Reference_To (Temp_Id, Loc),
+Right_Opnd =>
+  Make_Null (Loc)),
+
+Right_Opnd =>
+  Make_Op_Eq (Loc,
+Left_Opnd =>
+  Make_Function_Call (Loc,
+Name =>
+  New_Reference_To (RTE (RE_Exception_Identity), Loc),
+Parameter_Associations => New_List (
+  Make_Explicit_Dereference (Loc,
+Prefix =>
+  New_Reference_To (Temp_Id, Loc,
+
+Right_Opnd =>
+  Make_Attribute_Reference (Loc,
+Prefix =>
+  New_Reference_To (Stand.Abort_Signal, Loc),
+Attribute_Name => Name_Identity)));
+ end;
+
+  --  No abort
+
   else
  A_Expr := New_Reference_To (Standard_False, Loc);
   end if;
 
   --  Generate:
+  --Abort_Id : constant Boolean := ;
+
+  Append_To (Result,
+Make_Object_Declaration (Loc,
+  Defining_Identifier => Abort_Id,
+  Constant_Present => True,
+  Object_Definition =>
+New_Reference_

[Ada] Improve finalization of global controlled objects (2)

[Arnaud Charlet]

This changes the type of the elaboration counter from Integer to Short_Integer
to avoid wasting space in the data segment.  No functional changes.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Eric Botcazou  

* sem_elab.adb (Check_Internal_Call_Continue): Change the type of the
elaboration counter to Standard_Short_Integer.
* sem_util.adb (Build_Elaboration_Entity): Likewise.
* bindgen.adb (Gen_Elab_Externals_Ada): Adjust to above change.
(Gen_Elab_Externals_C): Likewise.

Index: bindgen.adb
===
--- bindgen.adb (revision 177320)
+++ bindgen.adb (working copy)
@@ -1241,9 +1241,9 @@
 
case VM_Target is
   when No_VM | JVM_Target =>
- Set_String (" : Integer; pragma Import (Ada, ");
+ Set_String (" : Short_Integer; pragma Import (Ada, ");
   when CLI_Target =>
- Set_String (" : Integer; pragma Import (CIL, ");
+ Set_String (" : Short_Integer; pragma Import (CIL, ");
end case;
 
Set_String ("E");
@@ -1320,7 +1320,7 @@
 (No_Run_Time_Mode
   and then Is_Predefined_File_Name (U.Sfile))
 then
-   Set_String ("extern int ");
+   Set_String ("extern short int ");
Get_Name_String (U.Uname);
Set_Unit_Name;
Set_String ("_E;");
Index: sem_util.adb
===
--- sem_util.adb(revision 177320)
+++ sem_util.adb(working copy)
@@ -954,7 +954,7 @@
   Name_Buffer (Name_Len + 2) := 'E';
   Name_Len := Name_Len + 2;
 
-  --  Create elaboration flag
+  --  Create elaboration counter
 
   Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
   Set_Elaboration_Entity (Spec_Id, Elab_Ent);
@@ -962,8 +962,10 @@
   Decl :=
 Make_Object_Declaration (Loc,
   Defining_Identifier => Elab_Ent,
-  Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
-  Expression  => Make_Integer_Literal (Loc, Uint_0));
+  Object_Definition   =>
+New_Occurrence_Of (Standard_Short_Integer, Loc),
+  Expression  =>
+Make_Integer_Literal (Loc, Uint_0));
 
   Push_Scope (Standard_Standard);
   Add_Global_Declaration (Decl);
Index: sem_elab.adb
===
--- sem_elab.adb(revision 177320)
+++ sem_elab.adb(working copy)
@@ -2158,7 +2158,7 @@
 Make_Object_Declaration (Loce,
   Defining_Identifier => Ent,
   Object_Definition   =>
-New_Occurrence_Of (Standard_Integer, Loce),
+New_Occurrence_Of (Standard_Short_Integer, Loce),
   Expression  =>
 Make_Integer_Literal (Loc, Uint_0)));
 

[Ada] Forbid anonymous access to subprogram in Compiler_Unit mode

[Arnaud Charlet]

This change adds a check that no anonymous access to subprogram types are used
in runtime units containing pragma Compiler_Unit, because such units are on
the bootstrap path and need to be compilable with Ada 95-only releases of GNAT.

The following compilation must be rejected with the given error message:

$ gcc -c -gnat05 comp_unit.ads
comp_unit.ads:3:22: use of construct not allowed in compiler

package Comp_Unit is
   pragma Compiler_Unit;
   procedure P (AP : access procedure); --  ERROR: anon access to subp
end Comp_Unit;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* sem_ch3.adb (Access_Definition): Anonymous access to subprogram types
are forbidden in Compiler_Unit mode.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 177278)
+++ sem_ch3.adb (working copy)
@@ -793,6 +793,13 @@
   --  the corresponding semantic routine
 
   if Present (Access_To_Subprogram_Definition (N)) then
+
+ --  Compiler runtime units are compiled in Ada 2005 mode when building
+ --  the runtime library but must also be compilable in Ada 95 mode
+ --  (when bootstrapping the compiler).
+
+ Check_Compiler_Unit (N);
+
  Access_Subprogram_Declaration
(T_Name => Anon_Type,
 T_Def  => Access_To_Subprogram_Definition (N));

[Ada] Add anonymous subtypes to ALFA

[Arnaud Charlet]

Mark anonymous subtypes of enumeration and integer kind as being in ALFA,
following the same rules as for source subtypes.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_ch3.adb (Constrain_Enumeration, Constrain_Integer): remove
constraint that subtype must come from source code to be in ALFA, so
that anonymous subtypes can be in ALFA too.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 177324)
+++ sem_ch3.adb (working copy)
@@ -11592,9 +11592,7 @@
   --  entity of its subtype mark is in ALFA. This is reversed later if the
   --  range of the subtype is not static.
 
-  if Nkind (Original_Node (Parent (Def_Id))) = N_Subtype_Declaration
-and then Is_In_ALFA (T)
-  then
+  if Is_In_ALFA (T) then
  Set_Is_In_ALFA (Def_Id);
   end if;
 
@@ -11824,9 +11822,7 @@
   --  entity of its subtype mark is in ALFA. This is reversed later if the
   --  range of the subtype is not static.
 
-  if Nkind (Original_Node (Parent (Def_Id))) = N_Subtype_Declaration
-and then Is_In_ALFA (T)
-  then
+  if Is_In_ALFA (T) then
  Set_Is_In_ALFA (Def_Id);
   end if;
 

[Ada] Mark generated subtypes and loop iteration entity as in ALFA

[Arnaud Charlet]

When permitted by the bounds/base type of the subtype, mark it as being in
ALFA, and similarly for the entity used to iterate over a loop.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_ch3.adb (Array_Type_Declaration): move test for type in ALFA
after index creation; mark unconstrained base array type generated as
being in/not in ALFA as well
(Make_Index): mark subtype created as in/not in ALFA
* sem_ch5.adb (Analyze_Iteration_Scheme): mark entity for iterating
over a loop as in/not in ALFA, depending on its type and form of loop
iteration.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 177325)
+++ sem_ch3.adb (working copy)
@@ -4678,12 +4678,6 @@
 Check_SPARK_Restriction ("subtype mark required", Index);
  end if;
 
- if Present (Etype (Index))
-   and then not Is_In_ALFA (Etype (Index))
- then
-T_In_ALFA := False;
- end if;
-
  --  Add a subtype declaration for each index of private array type
  --  declaration whose etype is also private. For example:
 
@@ -4738,6 +4732,12 @@
 
  Make_Index (Index, P, Related_Id, Nb_Index);
 
+ if Present (Etype (Index))
+   and then not Is_In_ALFA (Etype (Index))
+ then
+T_In_ALFA := False;
+ end if;
+
  --  Check error of subtype with predicate for index type
 
  Bad_Predicated_Subtype_Use
@@ -4878,6 +4878,7 @@
   Set_Component_Type (Base_Type (T), Element_Type);
   Set_Packed_Array_Type (T, Empty);
   Set_Is_In_ALFA (T, T_In_ALFA);
+  Set_Is_In_ALFA (Base_Type (T), T_In_ALFA);
 
   if Aliased_Present (Component_Definition (Def)) then
  Check_SPARK_Restriction
@@ -16538,6 +16539,19 @@
  then
 Set_Is_Non_Static_Subtype (Def_Id);
  end if;
+
+ --  By default, consider that the subtype is in ALFA if its base type
+ --  is in ALFA.
+
+ Set_Is_In_ALFA (Def_Id, Is_In_ALFA (Base_Type (Def_Id)));
+
+ --  In ALFA, all subtypes should have a static range
+
+ if Nkind (R) = N_Range
+   and then not Is_Static_Range (R)
+ then
+Set_Is_In_ALFA (Def_Id, False);
+ end if;
   end if;
 
   --  Final step is to label the index with this constructed type
Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 177274)
+++ sem_ch5.adb (working copy)
@@ -2082,6 +2082,17 @@
   Set_Etype (Id, Etype (DS));
end if;
 
+   --  The entity for iterating over a loop is always in ALFA if
+   --  its type is in ALFA, and it is not an iteration over
+   --  elements of a container using the OF syntax.
+
+   if Is_In_ALFA (Etype (Id))
+ and then (No (Iterator_Specification (N))
+   or else not Of_Present (Iterator_Specification (N)))
+   then
+  Set_Is_In_ALFA (Id);
+   end if;
+
--  Treat a range as an implicit reference to the type, to
--  inhibit spurious warnings.
 

[Ada] Use current process id to create temp filenames (windows)

[Arnaud Charlet]

This ensures unicity of temp filenames across processes under Windows.

Tested on i686-pc-mingw32, committed on trunk

2011-08-04  Pascal Obry  

* adaint.c (__gnat_tmp_name): Use current process id to create temp
filenames, this ensures unicity of filenames across processes.

Index: adaint.c
===
--- adaint.c(revision 177328)
+++ adaint.c(working copy)
@@ -1177,13 +1177,15 @@
 #elif defined (__MINGW32__)
   {
 char *pname;
+char prefix[25];
 
 /* tempnam tries to create a temporary file in directory pointed to by
TMP environment variable, in c:\temp if TMP is not set, and in
directory specified by P_tmpdir in stdio.h if c:\temp does not
exist. The filename will be created with the prefix "gnat-".  */
 
-pname = (char *) _tempnam ("c:\\temp", "gnat-");
+sprintf (prefix, "gnat-%d-", (int)getpid());
+pname = (char *) _tempnam ("c:\\temp", prefix);
 
 /* if pname is NULL, the file was not created properly, the disk is full
or there is no more free temporary files */

[Ada] Fix minor violation of B.1 (39) implementation advice

[Arnaud Charlet]

The RM B.1 (39) implementation advice says that the adainit/adafinal routines
generated to manage Ada libraries from foreign languages should be idempotent.
This adds an elaboration flag to the file generated by the binder and an early
return to the routines to ensure that this is the case.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Eric Botcazou  

* bindgen.adb (Gen_Adafinal_Ada): Generate an early return if the
library has already been finalized.
(Gen_Adafinal_C): Likewise.
(Gen_Adainit_Ada): Generate an early return if the library has
already been elaborated.
(Gen_Adainit_C): Likewise.
(Gen_Output_File_Ada): Generate an elaboration flag.
(Gen_Output_File_C): Likewise.

Index: bindgen.adb
===
--- bindgen.adb (revision 177329)
+++ bindgen.adb (working copy)
@@ -428,8 +428,20 @@
begin
   WBI ("   procedure " & Ada_Final_Name.all & " is");
 
+  if Bind_Main_Program and then VM_Target = No_VM then
+ WBI ("  procedure s_stalib_adafinal;");
+ Set_String ("  pragma Import (C, s_stalib_adafinal, ");
+ Set_String ("""system__standard_library__adafinal"");");
+ Write_Statement_Buffer;
+  end if;
+
+  WBI ("   begin");
+  WBI ("  if not Is_Elaborated then");
+  WBI (" return;");
+  WBI ("  end if;");
+  WBI ("  Is_Elaborated := False;");
+
   if not Bind_Main_Program then
- WBI ("   begin");
  if Lib_Final_Built then
 WBI ("  finalize_library;");
  else
@@ -439,17 +451,12 @@
   --  Main program case
 
   elsif VM_Target = No_VM then
- WBI ("  procedure s_stalib_adafinal;");
- WBI ("  pragma Import (C, s_stalib_adafinal, " &
-  """system__standard_library__adafinal"");");
- WBI ("   begin");
  WBI ("  s_stalib_adafinal;");
 
   --  Pragma Import C cannot be used on virtual machine targets, therefore
   --  call the runtime finalization routine directly.
 
   else
- WBI ("   begin");
  WBI ("  System.Standard_Library.Adafinal;");
   end if;
 
@@ -465,6 +472,10 @@
begin
   WBI ("void " & Ada_Final_Name.all & " (void) {");
 
+  WBI ("   if (!is_elaborated)");
+  WBI ("  return;");
+  WBI ("   is_elaborated = 0;");
+
   if not Bind_Main_Program then
  if Lib_Final_Built then
 WBI ("   finalize_library ();");
@@ -685,6 +696,11 @@
 
  WBI ("   begin");
 
+ WBI ("  if Is_Elaborated then");
+ WBI (" return;");
+ WBI ("  end if;");
+ WBI ("  Is_Elaborated := True;");
+
  Set_String ("  Main_Priority := ");
  Set_Int(Main_Priority);
  Set_Char   (';');
@@ -941,6 +957,10 @@
   WBI ("void " & Ada_Init_Name.all & " (void)");
   WBI ("{");
 
+  WBI ("   if (is_elaborated)");
+  WBI ("  return;");
+  WBI ("   is_elaborated = 1;");
+
   --  Standard library suppressed
 
   if Suppress_Standard_Library_On_Target then
@@ -3077,6 +3097,9 @@
  WBI ("");
   end if;
 
+  WBI ("   Is_Elaborated : Boolean := False;");
+  WBI ("");
+
   --  Generate the adafinal routine unless there is no finalization to do
 
   if not Cumulative_Restrictions.Set (No_Finalization) then
@@ -3300,6 +3323,9 @@
  WBI ("");
   end if;
 
+  WBI ("static char is_elaborated = 0;");
+  WBI ("");
+
   --  Generate the adafinal routine unless there is no finalization to do
 
   if not Cumulative_Restrictions.Set (No_Finalization) then

[Ada] Deallocation of a single allocated object (PR ada/47880)

[Arnaud Charlet]

This change fixes a seg fault when a local storage pool has a single allocated
object, and Unchecked_Deallocation is used to deallocate that object.

The following test case must compile and execute quietly:

$ gnatmake -q pooltest
$ ./pooltest

with System.Pool_Local;
with Ada.Unchecked_Deallocation;
procedure pooltest is

   type Node;
   type Treenode is access Node;
   type Node is record
  Left  : Treenode := null;
  Right : Treenode := null;
  Item  : Integer  := 0; 
   end record;

   P : System.Pool_Local.Unbounded_Reclaim_Pool;
   for Treenode'Storage_Pool use P;

   procedure Free is new Ada.Unchecked_Deallocation(Node, Treenode);
   TestNode : Treenode;
begin
   Testnode := new Node'(null, null, 1);
   Free(Testnode);   
end pooltest;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

PR ada/47880
* s-pooloc.adb (Deallocate): Fix the case of deallocating the only
allocated object.
Index: s-pooloc.adb
===
--- s-pooloc.adb(revision 177274)
+++ s-pooloc.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- B o d y  --
 --  --
---  Copyright (C) 1992-2009, 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- --
@@ -111,7 +111,10 @@
begin
   if Prev (Allocated).all = Null_Address then
  Pool.First := Next (Allocated).all;
- Prev (Pool.First).all := Null_Address;
+
+ if Pool.First /= Null_Address then
+Prev (Pool.First).all := Null_Address;
+ end if;
   else
  Next (Prev (Allocated).all).all := Next (Allocated).all;
   end if;

[Ada] Add special case for "ALFA" in error message similar to "RM"

[Arnaud Charlet]

Occurrences of "ALFA" in error messages are now left capitalized, which avoids
the need to clutter source code with occurrences of "'A'L'F'A".

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* errout.ads Change comments: remove 'R'M as an example where quotes
are needed; add ALFA as another case where quotes are not needed
* erroutc.adb (Set_Msg_Insertion_Reserved_Word): add ALFA as another
case where quotes are not needed.
* sem_ch11.adb, sem_ch13.adb, sem_ch2.adb, sem_ch3.adb, sem_ch4.adb,
sem_ch5.adb, sem_ch6.adb, sem_ch9.adb, sem_prag.adb, sem_res.adb:
Remove all occurrences of 'A'L'F'A

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 177334)
+++ sem_ch3.adb (working copy)
@@ -3053,9 +3053,9 @@
   --  not aliased.
 
   if not Is_In_ALFA (T) then
- Mark_Non_ALFA_Subprogram ("object type is not in 'A'L'F'A", N);
+ Mark_Non_ALFA_Subprogram ("object type is not in ALFA", N);
   elsif Aliased_Present (N) then
- Mark_Non_ALFA_Subprogram ("ALIASED is not in 'A'L'F'A", N);
+ Mark_Non_ALFA_Subprogram ("ALIASED is not in ALFA", N);
   else
  Set_Is_In_ALFA (Id);
   end if;
Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 177334)
+++ sem_ch5.adb (working copy)
@@ -1114,7 +1114,7 @@
 and then List_Length (Alternatives (N)) = 1
   then
  Mark_Non_ALFA_Subprogram
-   ("OTHERS as unique case alternative is not in 'A'L'F'A", N);
+   ("OTHERS as unique case alternative is not in ALFA", N);
  Check_SPARK_Restriction
("OTHERS as unique case alternative is not allowed", N);
   end if;
@@ -1198,7 +1198,7 @@
 if Has_Loop_In_Inner_Open_Scopes (U_Name) then
Mark_Non_ALFA_Subprogram
  ("exit label must name the closest enclosing loop"
-   & " in 'A'L'F'A", N);
+   & " in ALFA", N);
Check_SPARK_Restriction
  ("exit label must name the closest enclosing loop", N);
 end if;
@@ -1247,7 +1247,7 @@
  if Nkind (Parent (N)) /= N_Loop_Statement then
 Mark_Non_ALFA_Subprogram
   ("exit with when clause must be directly in loop"
-& " in 'A'L'F'A", N);
+& " in ALFA", N);
 Check_SPARK_Restriction
   ("exit with when clause must be directly in loop", N);
  end if;
@@ -1256,18 +1256,18 @@
  if Nkind (Parent (N)) /= N_If_Statement then
 if Nkind (Parent (N)) = N_Elsif_Part then
Mark_Non_ALFA_Subprogram
- ("exit must be in IF without ELSIF in 'A'L'F'A", N);
+ ("exit must be in IF without ELSIF in ALFA", N);
Check_SPARK_Restriction
  ("exit must be in IF without ELSIF", N);
 else
Mark_Non_ALFA_Subprogram
- ("exit must be directly in IF in 'A'L'F'A", N);
+ ("exit must be directly in IF in ALFA", N);
Check_SPARK_Restriction ("exit must be directly in IF", N);
 end if;
 
  elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
 Mark_Non_ALFA_Subprogram
-  ("exit must be in IF directly in loop in 'A'L'F'A", N);
+  ("exit must be in IF directly in loop in ALFA", N);
 Check_SPARK_Restriction
   ("exit must be in IF directly in loop", N);
 
@@ -1276,7 +1276,7 @@
 
  elsif Present (Else_Statements (Parent (N))) then
 Mark_Non_ALFA_Subprogram
-  ("exit must be in IF without ELSE in 'A'L'F'A", N);
+  ("exit must be in IF without ELSE in ALFA", N);
 Check_SPARK_Restriction ("exit must be in IF without ELSE", N);
 
 --  An exit in an ELSIF does not reach here, as it would have been
@@ -1284,7 +1284,7 @@
 
  elsif Present (Elsif_Parts (Parent (N))) then
 Mark_Non_ALFA_Subprogram
-  ("exit must be in IF without ELSIF in 'A'L'F'A", N);
+  ("exit must be in IF without ELSIF in ALFA", N);
 Check_SPARK_Restriction ("exit must be in IF without ELSIF", N);
  end if;
   end if;
@@ -1313,7 +1313,7 @@
   Label_Ent   : Entity_Id;
 
begin
-  Mark_Non_ALFA_Subprogram ("goto statement is not in 'A'L'F'A", N);
+  Mark_Non_ALFA_Subprogram ("goto statement is not in ALFA", N);
   Check_SPARK_Restriction ("goto statement is not allowed", N);
 
   --  Actual semantic checks
Index: sem_ch9.adb
===
--- sem_ch9.adb (revision 177328)
+++ sem_ch9.adb (working copy)
@@ -101,7 +101,7 @@
 
begin
   Tasking_Used := True;
-  Mark_Non_ALFA_Subprogram ("abort 

[Ada] Duplicated SCO for decision in pragma Debug

[Arnaud Charlet]

This change removes an annoying irregularity in N_Pragma nodes, which had
the last argument copied in two distinct syntactic descendents
(Pragma_Argument_Associations and Debug_Statement) for a pragma Debug.
This caused duplicated SCO information to be emitted for decisions occurring
in the actual parameters of the procedure call enclosed in such a pragma.

The Debug_Statement attribute is actually superfluous, and now removed.

The SCO information in the ALI file for the following compilation must
contain exactly one CX line:

$ gcc -c -gnateS dup_sco.adb
$ grep "^CX" dup_sco.ali
CX &7:28 c7:26-7:26 c7:37-7:37

pragma Debug_Policy (Check);
procedure Dup_SCO (A, B : Boolean) is
   procedure Assert (X : Boolean) is
   begin
  null;
   end Assert;
   pragma Debug (Assert (A and then B));
begin
   null;
end Dup_SCO;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* sinfo.ads, sinfo.adb (Debug_Statement, Set_Debug_Statement): Remove.
* tbuild.ads, tbuild.adb (Make_Pragma): Adjust accordingly.
* sinfo-cn.ads, sinfo-cn.adb (Change_Name_To_Procedure_Call_Statement):
New subprogram, moved here from...
* par.adb, par-ch5.adb (P_Statement_Name): ... here.
* par-prag.adb (Par.Prag, case Pragma_Debug): Do not perform any
rewriting of the last argument into a procedure call statement here...
* sem_prag.adb (Analyze_Pragma, case Pragma_Debug): ...do it there
instead.

Index: sinfo.adb
===
--- sinfo.adb   (revision 177275)
+++ sinfo.adb   (working copy)
@@ -661,14 +661,6 @@
   return Node5 (N);
end Dcheck_Function;
 
-   function Debug_Statement
-  (N : Node_Id) return Node_Id is
-   begin
-  pragma Assert (False
-or else NT (N).Nkind = N_Pragma);
-  return Node3 (N);
-   end Debug_Statement;
-
function Declarations
   (N : Node_Id) return List_Id is
begin
@@ -3712,14 +3704,6 @@
   Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Dcheck_Function;
 
-   procedure Set_Debug_Statement
-  (N : Node_Id; Val : Node_Id) is
-   begin
-  pragma Assert (False
-or else NT (N).Nkind = N_Pragma);
-  Set_Node3_With_Parent (N, Val);
-   end Set_Debug_Statement;
-
procedure Set_Declarations
   (N : Node_Id; Val : List_Id) is
begin
Index: sinfo.ads
===
--- sinfo.ads   (revision 177275)
+++ sinfo.ads   (working copy)
@@ -764,15 +764,6 @@
--This field is present in an N_Variant node, It references the entity
--for the discriminant checking function for the variant.
 
-   --  Debug_Statement (Node3)
-   --This field is present in an N_Pragma node. It is used only for a Debug
-   --pragma. The parameter is of the form of an expression, as required by
-   --the pragma syntax, but is actually a procedure call. To simplify
-   --semantic processing, the parser creates a copy of the argument
-   --rearranged into a procedure call statement and places it in the
-   --Debug_Statement field. Note that this field is considered syntactic
-   --field, since it is created by the parser.
-
--  Default_Expression (Node5-Sem)
--This field is Empty if there is no default expression. If there is a
--simple default expression (one with no side effects), then this field
@@ -2069,7 +2060,6 @@
   --  Sloc points to PRAGMA
   --  Next_Pragma (Node1-Sem)
   --  Pragma_Argument_Associations (List2) (set to No_List if none)
-  --  Debug_Statement (Node3) (set to Empty if not Debug)
   --  Pragma_Identifier (Node4)
   --  Next_Rep_Item (Node5-Sem)
   --  Pragma_Enabled (Flag5-Sem)
@@ -8201,9 +8191,6 @@
function Dcheck_Function
  (N : Node_Id) return Entity_Id;  -- Node5
 
-   function Debug_Statement
- (N : Node_Id) return Node_Id;-- Node3
-
function Declarations
  (N : Node_Id) return List_Id;-- List2
 
@@ -9173,9 +9160,6 @@
procedure Set_Dcheck_Function
  (N : Node_Id; Val : Entity_Id);  -- Node5
 
-   procedure Set_Debug_Statement
- (N : Node_Id; Val : Node_Id);-- Node3
-
procedure Set_Declarations
  (N : Node_Id; Val : List_Id);-- List2
 
@@ -10105,7 +10089,7 @@
  N_Pragma =>
(1 => False,   --  Next_Pragma (Node1-Sem)
 2 => True,--  Pragma_Argument_Associations (List2)
-3 => True,--  Debug_Statement (Node3)
+3 => False,   --  unused
 4 => True,--  Pragma_Identifier (Node4)
 5 => False),  --  Next_Rep_Item (Node5-Sem)
 
@@ -11732,7 +11716,6 @@
pragma Inline (Corresponding_Spec);
pragma Inline (Corresponding_Stub);
pragma Inline (Dcheck_Function);
-   pragma Inline (Debug_Statement);
pragma Inline (Declarations);
pragma Inline (Default_Expression);
pragma Inline (Default_Storage_Pool);

Re: PATCH: Add a testase for PR middle-end/47383

[Kirill Yukhin]

HJ, are you sure your Changlog entry is OK?

Thanks, K

On Wed, Aug 3, 2011 at 6:45 PM, H.J. Lu  wrote:
> Hi,
>
> I checked in this patch to add a testase for PR middle-end/47383.
>
> H.J.
> ---
> Index: gcc.dg/torture/pr47383.c
> ===
> --- gcc.dg/torture/pr47383.c    (revision 0)
> +++ gcc.dg/torture/pr47383.c    (revision 0)
> @@ -0,0 +1,30 @@
> +/* { dg-do run } */
> +
> +static int heap[2*(256 +1+29)+1];
> +static int heap_len;
> +static int heap_max;
> +void
> +__attribute__ ((noinline))
> +foo (int elems)
> +{
> +  int n, m;
> +  int max_code = -1;
> +  int node = elems;
> +  heap_len = 0, heap_max = (2*(256 +1+29)+1);
> +  for (n = 0; n < elems; n++)
> +    heap[++heap_len] = max_code = n;
> +  do {
> +    n = heap[1];
> +    heap[1] = heap[heap_len--];
> +    m = heap[1];
> +    heap[--heap_max] = n;
> +    heap[--heap_max] = m;
> +  } while (heap_len >= 2);
> +}
> +
> +int
> +main ()
> +{
> +  foo (286);
> +  return 0;
> +}
> Index: ChangeLog
> ===
> --- ChangeLog   (revision 177275)
> +++ ChangeLog   (working copy)
> @@ -1,3 +1,8 @@
> +2011-08-03  H.J. Lu  
> +
> +       PR middle-end/47383
> +       * gcc.dg/torture/pr47383.c: Likewise.
> +
>  2011-08-03  Arnaud Charlet  
>
>        * gnat.dg/specs/debug1.ads: Add missing -margs switch.
>

[Ada] Improve support of size and alignment clauses

[Arnaud Charlet]

This changes the way size and alignment clauses interact with each other.
Size clauses used to set the 'Size of a type in stone, although an alignment
clause could force the back-end to set different values for 'Object_Size
and 'Value_Size of the type, leading to an inconsistency when an object of
this type is declared with this same size clause and rejected.

'Object_Size and 'Value_Size are now decoupled and a size clause on a type
will only set the latter in stone; the former can now be increased by the
back-end to support a given alignment.

The following package must be rejected with the error:

badsize.ads:10:21: size for "RR1" too small, minimum allowed is 64

and the layout given by -gnatR1:

for r1'Object_Size use 64;
for r1'Value_Size use 40;
for r1'Alignment use 4;
for r1 use record
   i at 0 range  0 .. 31;
   b at 4 range  0 ..  7;
end record;


package badsize is
   type R1 is record
  I : Integer;
  B : Boolean;
   end record;
   for R1'Alignment use 4;
   for R1'Size use 40;

   RR1 : R1;
   for RR1'Size use 40;
end;


Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Eric Botcazou  

* layout.adb (Layout_Type): For composite types, do not set Esize.
* freeze.adb (Set_Small_Size): Remove test on alignment and do not
set Esize.
(Size_Known): Look at the RM size of components instead of the Esize.
(Freeze_Record_Type): Look at the RM size instead of the Esize to
issue warning and activate Implicit_Packing.
(Freeze_Entity): Likewise.  Do not issue a warning for alias/atomic
if the Esize is not known.
* sem_ch13.adb (Analyze_Attribute_Definition_Clause) : Set Esize
for elementary types only.
(Analyze_Record_Representation_Clause): Look at the RM size instead
of the Esize to issue errors.
* gcc-interface/decl.c (gnat_to_gnu_entity): Do not set Esize if it
is not known.
: Look at the RM size instead of the Esize.  Remove
obsolete block.  
Look at the RM size instead of the Esize for types if the latter is
not known.
(gnat_to_gnu_field): Use Known_Esize instead of Known_Static_Esize.

Index: layout.adb
===
--- layout.adb  (revision 177334)
+++ layout.adb  (working copy)
@@ -2574,27 +2574,11 @@
 end;
  end if;
 
- --  If RM_Size is known, set Esize if not known
-
- if Known_RM_Size (E) and then Unknown_Esize (E) then
-
---  If the alignment is known, we bump the Esize up to the next
---  alignment boundary if it is not already on one.
-
-if Known_Alignment (E) then
-   declare
-  A : constant Uint   := Alignment_In_Bits (E);
-  S : constant SO_Ref := RM_Size (E);
-   begin
-  Set_Esize (E, (S + A - 1) / A * A);
-   end;
-end if;
-
  --  If Esize is set, and RM_Size is not, RM_Size is copied from Esize.
  --  At least for now this seems reasonable, and is in any case needed
  --  for compatibility with old versions of gigi.
 
- elsif Known_Esize (E) and then Unknown_RM_Size (E) then
+ if Known_Esize (E) and then Unknown_RM_Size (E) then
 Set_RM_Size (E, Esize (E));
  end if;
 
Index: freeze.adb
===
--- freeze.adb  (revision 177320)
+++ freeze.adb  (working copy)
@@ -623,13 +623,6 @@
  if S > 32 then
 return;
 
- --  Don't bother if alignment clause with a value other than 1 is
- --  present, because size may be padded up to meet back end alignment
- --  requirements, and only the back end knows the rules!
-
- elsif Known_Alignment (T) and then Alignment (T) /= 1 then
-return;
-
  --  Check for bad size clause given
 
  elsif Has_Size_Clause (T) then
@@ -638,21 +631,12 @@
Error_Msg_NE
  ("size for& too small, minimum allowed is ^",
   Size_Clause (T), T);
-
-elsif Unknown_Esize (T) then
-   Set_Esize (T, S);
 end if;
 
- --  Set sizes if not set already
+ --  Set size if not set already
 
- else
-if Unknown_Esize (T) then
-   Set_Esize (T, S);
-end if;
-
-if Unknown_RM_Size (T) then
-   Set_RM_Size (T, S);
-end if;
+ elsif Unknown_RM_Size (T) then
+Set_RM_Size (T, S);
  end if;
   end Set_Small_Size;
 
@@ -836,7 +820,7 @@
   if not Is_Constrained (T)
 and then
   No (Discriminant_Default_Value (First_Discriminant (T)))
-and then Unknown_Esize (T)
+and then Unknown_RM_Size (T)
 

[Ada] Do not skip analysis of aspect X when X'Class aspect present (and reverse)

[Arnaud Charlet]

Compiling the following code now raises an error:

package P is
   procedure Proc (X : out Boolean)
 with Post'Class => X,
  Post => not X,
  Post => X;
end P;

$ gcc -c -gnat2012 p.ads
p.ads:5:11: aspect "Post" for "Proc" previously given at line 4

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_ch13.adb (Aspect_Loop): when an aspect X and its classwise
corresponding aspect X'Class are allowed, proceed with analysis of the
aspect instead of skipping it.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 177340)
+++ sem_ch13.adb(working copy)
@@ -854,7 +854,7 @@
  end if;
   end if;
 
-  goto Continue;
+  --  Allowed case of X and X'Class both specified
end if;
 
Next (Anod);

[Ada] Issue warning for missing -gnat2012 switch on aspect X'Class

[Arnaud Charlet]

When encountering aspect syntax in a mode where aspects are not allowed
(language version < Ada 2012), the compiler was issuing a useful warning in
most cases, but not on aspects X'Class. This is now fixed.

Compiling the following code raises the error:

$ gcc -c p.ads
p.ads:3:06: aspect specification is an Ada 2012 feature
p.ads:3:06: unit must be compiled with -gnat2012 switch

package P is
   procedure Proc (X : out Boolean)
 with Post'Class => X;
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* par-ch13.adb (Aspect_Specifications_Present): recognize
"with Identifier'Class =>" as an aspect, so that a meaningful warning
is issued in Strict mode.
* par.adb: Fix typos in comments.

Index: par-ch13.adb
===
--- par-ch13.adb(revision 177274)
+++ par-ch13.adb(working copy)
@@ -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- --
@@ -89,9 +89,9 @@
 Result := Token = Tok_Arrow;
  end if;
 
-  --  If earlier than Ada 2012, check for valid aspect identifier followed
-  --  by an arrow, and consider that this is still an aspect specification
-  --  so we give an appropriate message.
+  --  If earlier than Ada 2012, check for valid aspect identifier (possibly
+  --  completed with 'CLASS) followed by an arrow, and consider that this
+  --  is still an aspect specification so we give an appropriate message.
 
   else
  if Get_Aspect_Id (Token_Name) = No_Aspect then
@@ -100,10 +100,26 @@
  else
 Scan; -- past aspect name
 
-if Token /= Tok_Arrow then
-   Result := False;
+Result := False;
 
-else
+if Token = Tok_Arrow then
+   Result := True;
+
+elsif Token = Tok_Apostrophe then
+   Scan; -- past apostrophe
+
+   if Token = Tok_Identifier
+ and then Token_Name = Name_Class
+   then
+  Scan; -- past CLASS
+
+  if Token = Tok_Arrow then
+ Result := True;
+  end if;
+   end if;
+end if;
+
+if Result then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("|aspect specification is an Ada 2012 feature");
Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
Index: par.adb
===
--- par.adb (revision 177337)
+++ par.adb (working copy)
@@ -858,8 +858,8 @@
   --  attempt at an aspect specification. The default is more strict for
   --  Ada versions before Ada 2012 (where aspect specifications are not
   --  permitted). Note: this routine never checks the terminator token
-  --  for aspects so it does not matter whether the aspect speficiations
-  --  are terminated by semicolon or some other character
+  --  for aspects so it does not matter whether the aspect specifications
+  --  are terminated by semicolon or some other character.
 
   procedure P_Aspect_Specifications
 (Decl  : Node_Id;

[Ada] Improve error message on misplaced 'Result in Ada 2012 mode

[Arnaud Charlet]

In Ada 2012 mode, 'Result is allowed both in Postcondition pragma and in aspect
Post. The error message issued by GNAT was not mentioning aspect Post. This is
now fixed.

Compiling the following code in mode Ada 2012 raises the error:

$ gcc -c -gnat2012 p.adb
p.ads:3:18: "Result" attribute can only appear in function Postcondition pragma 
or Post aspect

---
package P is
   function F return Boolean
 with Pre => F'Result;
end P;
---
package body P is
   function F return Boolean is
   begin
  return True;
   end F;
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_attr.adb (Result): modify error message to take into account Post
aspect when compiling Ada 2012 (or newer) code.

Index: sem_attr.adb
===
--- sem_attr.adb(revision 177320)
+++ sem_attr.adb(working copy)
@@ -4102,9 +4102,15 @@
Analyze_And_Resolve (N, Etype (PS));
 
 else
-   Error_Attr
- ("% attribute can only appear" &
-   " in function Postcondition pragma", P);
+   if Ada_Version >= Ada_2012 then
+  Error_Attr
+("% attribute can only appear" &
+  " in function Postcondition pragma or Post aspect", P);
+   else
+  Error_Attr
+("% attribute can only appear" &
+  " in function Postcondition pragma", P);
+   end if;
 end if;
  end if;
   end Result;

[Ada] Intrinsic operators with real operands

[Arnaud Charlet]

If a function call resolves to an operator that is declared intrinsic, the
function call is replaced by an operator mode with the same operands. If the
result type is private the operands have to be converted to the underlying
predefined type (usually a numeric type). However, if an operand is a real
literal,  a conversion is not meaningful, and a qualified expression must be
used instead.

Execution of the following program must yield:

  1.40E+01

---
procedure Real_Test is
   package P is
  type T is private;
  C : constant T;
  function "*" (X : T; Y : Long_Float) return T;
  procedure Display (Obj : T);
   private
  type T is new Long_Float;
  pragma Import (Intrinsic, "*");
  C : constant T := 4.0;
   end P;

   package body P is
  procedure Display (Obj : T) is
  begin
 Put_Line (T'Image (Obj));
  end;
   end;
   use P;

   B : T;
begin
   B := C * 3.5;
   Display (B);
end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_res.adb (Resolve_Intrinsic_Operator): if the result type is
private and one of the operands is a real literal, use a qualified
expression rather than a conversion which is not meaningful to the
back-end.

Index: sem_res.adb
===
--- sem_res.adb (revision 177335)
+++ sem_res.adb (working copy)
@@ -5261,6 +5261,9 @@
  --  decrease false positives, without losing too many good
  --  warnings. The idea is that these previous statements
  --  may affect global variables the procedure depends on.
+ --  We also exclude raise statements, that may arise from
+ --  constraint checks and are probably unrelated to the
+ --  intended control flow.
 
  if Nkind (N) = N_Procedure_Call_Statement
and then Is_List_Member (N)
@@ -5270,7 +5273,10 @@
 begin
P := Prev (N);
while Present (P) loop
-  if Nkind (P) /= N_Assignment_Statement then
+  if not Nkind_In (P,
+N_Assignment_Statement,
+N_Raise_Constraint_Error)
+  then
  exit Scope_Loop;
   end if;
 
@@ -7026,6 +7032,28 @@
   Arg1: Node_Id;
   Arg2: Node_Id;
 
+  function Convert_Operand (Opnd : Node_Id) return Node_Id;
+  --  If the operand is a literal, it cannot be the expression in a
+  --  conversion. Use a qualified expression instead.
+
+  function Convert_Operand (Opnd : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Opnd);
+ Res : Node_Id;
+  begin
+ if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
+Res :=
+  Make_Qualified_Expression (Loc,
+Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+Expression   => Relocate_Node (Opnd));
+Analyze (Res);
+
+ else
+Res := Unchecked_Convert_To (Btyp, Opnd);
+ end if;
+
+ return Res;
+  end Convert_Operand;
+
begin
   --  We must preserve the original entity in a generic setting, so that
   --  the legality of the operation can be verified in an instance.
@@ -7048,12 +7076,13 @@
   --  type.
 
   if Is_Private_Type (Typ) then
- Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd  (N));
+ Arg1 := Convert_Operand (Left_Opnd (N));
+ --  Unchecked_Convert_To (Btyp, Left_Opnd  (N));
 
  if Nkind (N) = N_Op_Expon then
 Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
  else
-Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+Arg2 := Convert_Operand (Right_Opnd (N));
  end if;
 
  if Nkind (Arg1) = N_Type_Conversion then

[Ada] Box-initialized components of aggregates in allocators

[Arnaud Charlet]

Box-initialized components are replaced with calls to the corresponding
initialization procedures during resolution of the aggregate. This requires
that the type of the aggregate and that of all its components be frozen before 
resolution is completed. In addition, such an aggregate may be the designated
object of an access-to-constant object, and it can legally appear as an in-out
parameter in a call to the corresponding initialization procedure.

The following commands

  gnatmake -q -gnat05 main
  main

must yield:

3.141500E+00
3.141500E+00

---
with A;
with Text_IO; use Text_IO;

procedure Main is

   Instance_OK : A.T_Record_Access :=
 new A.T_Record'(My_Record => <>);

   Instance_KO : A.T_Record_Access_Constant :=
 new A.T_Record'(My_Record => <>);

begin
   Put_Line (Long_Float'Image (Instance_KO.My_Record.A_Value));
   Put_Line (Long_Float'Image (A.Local_Instance_OK.My_Record.A_Value));
end Main;
---
package A is

   type T_Inner_Record is record
  A_Value : Long_Float := 3.1415;
   end record;

   type T_Record is record
  My_Record  : T_Inner_Record;
   end record;

   type T_Record_Access_Constant is access constant T_Record;
   type T_Record_Access  is access  T_Record;

   Local_Instance_OK : T_Record_Access_Constant :=
 new T_Record'(My_Record => <>);
end A;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_aggr.adb (Resolve_Aggregate): If aggregate has box-initialized
components, freeze type before resolution, to ensure that default
initializations are present for all components.
* sem_res.adb (Resolve_Actuals): the designated object of an
accces-to-constant type is a legal actual in a call to an
initialization procedure.

Index: sem_aggr.adb
===
--- sem_aggr.adb(revision 177275)
+++ sem_aggr.adb(working copy)
@@ -978,6 +978,30 @@
  return;
   end if;
 
+  --  If the aggregate has box-initialized components, its type must be
+  --  frozen so that initialization procedures can properly be called
+  --  in the resolution that follows.  The replacement of boxes with
+  --  initialization calls is properly an expansion activity but it must
+  --  be done during revolution.
+
+  if Expander_Active
+and then  Present (Component_Associations (N))
+  then
+ declare
+Comp : Node_Id;
+
+ begin
+Comp := First (Component_Associations (N));
+while Present (Comp) loop
+   if Box_Present (Comp) then
+  Insert_Actions (N, Freeze_Entity (Typ, N));
+  exit;
+   end if;
+   Next (Comp);
+end loop;
+ end;
+  end if;
+
   --  An unqualified aggregate is restricted in SPARK to:
 
   --An aggregate item inside an aggregate for a multi-dimensional array
Index: sem_res.adb
===
--- sem_res.adb (revision 177342)
+++ sem_res.adb (working copy)
@@ -3736,7 +3736,13 @@
--  Is_OK_Variable_For_Out_Formal generates the required
--  reference in this case.
 
-   if not Is_OK_Variable_For_Out_Formal (A) then
+   --  A call to an initialization procedure for an aggregate
+   --  component may initialize a nested component of a constant
+   --  designated object. In this context the object is variable.
+
+   if not Is_OK_Variable_For_Out_Formal (A)
+ and then not Is_Init_Proc (Nam)
+   then
   Error_Msg_NE ("actual for& must be a variable", A, F);
end if;
 

Re: [PATCH][RFC] Fix PR49957 - build array index differently

[Richard Guenther]

On Wed, 3 Aug 2011, Mikael Morin wrote:

> Hello,
> 
> On Wednesday 03 August 2011 15:47:37 Richard Guenther wrote:
> > Comments?  Any idea why reversing the loop would break?
> 
> Yes, the list of scalarized expressions has to be created in the same order 
> it 
> is consumed. Here the scalarized expressions are array indexes to be 
> precomputed out of the loop.
> The attached patch seems to work (the interesting part is in 
> gfc_walk_variable_expr).

Ah, thanks.  I'll work from there to revise the patch.

Richard.

Re: [AVR] Fix target/34888

[Georg-Johann Lay]

Richard Henderson wrote:
> When a frame pointer is in use, we can optimize popping all
> queued parameters via a simple move from the frame pointer
> instead of an addition to the stack pointer.
> 
> The new sequence is 4 insns, the old sequence was 9 insns.
> 
> Committed.
> 
> r~

4 insns is odd. You cannot move atomically to SP and the sequence
finally emit should be something like fiddling with IRQ-Flag.

  *l = 5;
  return (AS2 (in,__tmp_reg__,__SREG__)  CR_TAB
  "cli"  CR_TAB
  AS2 (out,__SP_H__,%B1) CR_TAB
  AS2 (out,__SREG__,__tmp_reg__) CR_TAB
  AS2 (out,__SP_L__,%A1));

Johann

[PATCH] Fix g++ -E -C issue in gthr-posix.h

[Jakub Jelinek]

Hi!

echo '#include ' | ./g++ -E -C -xc++ - -o /tmp/i.ii
In file included from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/i686-pc-linux-gnu/bits/gthr.h:160:0,
 from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/ext/atomicity.h:34,
 from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/bits/ios_base.h:41,
 from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/ios:43,
 from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/ostream:40,
 from 
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/iostream:40,
 from :1:
/usr/src/gcc/obj771i/usr/local/bin/../lib/gcc/i686-pc-linux-gnu/4.7.0/../../../../include/c++/4.7.0/i686-pc-linux-gnu/bits/gthr-default.h:256:1:
error: pasting "__gthrw_" and "/* Android's C library does not provide
/ pthread_cancel, check for
   `pthread_create' instead.  */" does not give a valid preprocessing token

The following patch fixes it by avoiding the preprocessor conditionals
and comments inside of __gthrw_ macro arguments which then wants to
do token pasting with it.
Ok for trunk?

2011-08-04  Jakub Jelinek  

* gthr-posix.h (__gthread_active_p): Do not use preprocessor
conditionals and comments inside macro arguments.

--- gcc/gthr-posix.h.jj 2011-07-18 13:17:56.0 +0200
+++ gcc/gthr-posix.h2011-08-04 11:22:40.0 +0200
@@ -244,16 +244,15 @@ __gthread_active_p (void)
 static inline int
 __gthread_active_p (void)
 {
-  static void *const __gthread_active_ptr
-= __extension__ (void *) &__gthrw_(
 /* Android's C library does not provide pthread_cancel, check for
`pthread_create' instead.  */
 #ifndef __BIONIC__
-  pthread_cancel
+  static void *const __gthread_active_ptr
+= __extension__ (void *) &__gthrw_(pthread_cancel);
 #else
-  pthread_create
+  static void *const __gthread_active_ptr
+= __extension__ (void *) &__gthrw_(pthread_create);
 #endif
-  );
   return __gthread_active_ptr != 0;
 }
 


Jakub

[Ada] Detect misplaced 'Result when compiling spec file

[Arnaud Charlet]

A misplaced 'Result located in the precondition of a function was detected only
when compiling the body file, not when compiling the spec file. This is now
fixed.

Compiling the following code raises an error:

$ gcc -c -gnat2012 -gnatc p.adb
p.ads:3:18: "Result" attribute can only appear in postcondition of function

package P is
   function F return Boolean
 with Pre => F'Result;
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_attr.adb (Analyze_Attribute): add check during pre-analysis that
'Result only appears in postcondition of function.

Index: sem_attr.adb
===
--- sem_attr.adb(revision 177343)
+++ sem_attr.adb(working copy)
@@ -3990,6 +3990,9 @@
  --  source subprogram to which the postcondition applies. During
  --  pre-analysis, CS is the scope of the subprogram declaration.
 
+ Prag : Node_Id;
+ --  During pre-analysis, Prag is the enclosing pragma node if any
+
   begin
  --  Find enclosing scopes, excluding loops
 
@@ -4029,6 +4032,23 @@
Error_Attr;
 end if;
 
+--  Check in postcondition of function
+
+Prag := N;
+while not Nkind_In (Prag, N_Pragma, N_Function_Specification,
+N_Subprogram_Body)
+loop
+   Prag := Parent (Prag);
+end loop;
+
+if Nkind (Prag) /= N_Pragma
+  or else Get_Pragma_Id (Prag) /= Pragma_Postcondition
+then
+   Error_Attr
+ ("% attribute can only appear in postcondition of function",
+  P);
+end if;
+
 --  The attribute reference is a primary. If expressions follow,
 --  the attribute reference is really an indexable object, so
 --  rewrite and analyze as an indexed component.

[Ada] Improved runtime exception message for duplicated external tag

[Arnaud Charlet]

This change improves the exception message associated with PROGRAM_ERROR
for duplicated external tag by including the value of the offending
external tag.

The following compilation must raise Program_Error with the indicated
exception message:

$ gnatmake -z dup_ext_tag.ads
$ ./dup_ext_tag 

raised PROGRAM_ERROR : duplicated external tag foo

pragma Ada_2005;
package Dup_Ext_Tag is
   type T1 is tagged null record; for T1'External_Tag use "foo";
   type T2 is tagged null record; for T2'External_Tag use "foo";
end Dup_Ext_Tag;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* a-tags.adb (Check_TSD): When raising PROGRAM_ERROR for a duplicated
external tag, include the value of the external tag in the exception
message.

Index: a-tags.adb
===
--- a-tags.adb  (revision 177275)
+++ a-tags.adb  (working copy)
@@ -310,6 +310,13 @@
procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
   T : Tag;
 
+  E_Tag_Len : constant Integer := Length (TSD.External_Tag);
+  E_Tag : String (1 .. E_Tag_Len);
+  for E_Tag'Address use TSD.External_Tag.all'Address;
+  pragma Import (Ada, E_Tag);
+
+   --  Start of processing for Check_TSD
+
begin
   --  Verify that the external tag of this TSD is not registered in the
   --  runtime hash table.
@@ -317,7 +324,7 @@
   T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
 
   if T /= null then
- raise Program_Error with "duplicated external tag";
+ raise Program_Error with "duplicated external tag " & E_Tag;
   end if;
end Check_TSD;
 
@@ -718,6 +725,8 @@
-- Length --

 
+   --  Should this be reimplemented using the strlen GCC builtin???
+
function Length (Str : Cstring_Ptr) return Natural is
   Len : Integer;
 

[Ada] Use canonical case file name to check ALI file (-gnatc)

[Arnaud Charlet]

On Windows, if a source with a file name that includes capital letter is
compiled with -gnatc, gnatmake will always recompile the file if invoked
again with -gnatc. This patch fixes this.

The test for this is to invoke several times gnatmake on Windows to
compile, with -gnatc, sources from a project with file names that
include capital letters. The sources should not be recompiled.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Vincent Celier  

* make.adb (Check): When -gnatc is used, check for the source file
inside the ALI file with a canonical case file name.

Index: make.adb
===
--- make.adb(revision 177320)
+++ make.adb(working copy)
@@ -1622,10 +1622,14 @@
 
  if Operating_Mode = Check_Semantics then
 declare
-   File_Name : constant String := Get_Name_String (Source_File);
+   File_Name : String := Get_Name_String (Source_File);
OK: Boolean := False;
 
 begin
+   --  In the ALI file, the source file names are in canonical case
+
+   Canonical_Case_File_Name (File_Name);
+
for U in ALIs.Table (ALI).First_Unit ..
  ALIs.Table (ALI).Last_Unit
loop

[Ada] SCO for nested decision in pragma

[Arnaud Charlet]

The decision SCO for the boolean expression in a pragma Assert is emitted
only if assertion checking is enabled. This change ensures that this also
applies to any nested decision within that expression.

The following compilation must produce two decision SCOs (a CP and a CX)
when compiled with -gnata, and none without:

$ gcc -c -gnateS -gnata decision_in_assert.adb
$ grep "^C[PX]" decision_in_assert.ali
CP 6:4 c6:19-6:34
CX &6:25 c6:23-6:23 c6:34-6:34

$ gcc -c -gnateS decision_in_assert.adb
$ grep "^C[PX]" decision_in_assert.ali


procedure Decision_In_Assert (A, B : Boolean) is
   function Id (X : Boolean) return Boolean is
   begin
  return X;
   end Id;
   pragma Assert (Id (A and then B));
begin
   null;
end Decision_In_Assert;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* put_scos.adb (Put_SCOs): Do not emit decision SCO for an X decision
nested in a disabled pragma.
* scos.ads, scos.adb, par_sco.ads, par_sco.adb: Record sloc of
enclosing pragma, if any, for X decisions.

Index: par_sco.adb
===
--- par_sco.adb (revision 177344)
+++ par_sco.adb (working copy)
@@ -113,11 +113,12 @@
--  Calls above procedure for each element of the list L
 
procedure Set_Table_Entry
- (C1   : Character;
-  C2   : Character;
-  From : Source_Ptr;
-  To   : Source_Ptr;
-  Last : Boolean);
+ (C1  : Character;
+  C2  : Character;
+  From: Source_Ptr;
+  To  : Source_Ptr;
+  Last: Boolean;
+  Pragma_Sloc : Source_Ptr := No_Location);
--  Append an entry to SCO_Table with fields set as per arguments
 
procedure Traverse_Declarations_Or_Statements  (L : List_Id);
@@ -329,8 +330,11 @@
 
--  Version taking a node
 
+   Pragma_Sloc : Source_Ptr := No_Location;
+   --  While processing decisions within a pragma Assert/Debug/PPC, this is set
+   --  to the sloc of the pragma.
+
procedure Process_Decisions (N : Node_Id; T : Character) is
-
   Mark : Nat;
   --  This is used to mark the location of a decision sequence in the SCO
   --  table. We use it for backing out a simple decision in an expression
@@ -462,6 +466,11 @@
 
Loc := Sloc (Parent (Parent (N)));
 
+   --  Record sloc of pragma (pragmas don't nest)
+
+   pragma Assert (Pragma_Sloc = No_Location);
+   Pragma_Sloc := Loc;
+
 when 'X' =>
 
--  For an expression, no Sloc
@@ -475,11 +484,12 @@
  end case;
 
  Set_Table_Entry
-   (C1   => T,
-C2   => ' ',
-From => Loc,
-To   => No_Location,
-Last => False);
+   (C1  => T,
+C2  => ' ',
+From=> Loc,
+To  => No_Location,
+Last=> False,
+Pragma_Sloc => Pragma_Sloc);
 
  if T = 'P' then
 
@@ -491,7 +501,6 @@
 SCO_Table.Table (SCO_Table.Last).C2 := 'd';
 Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
  end if;
-
   end Output_Header;
 
   --
@@ -623,6 +632,12 @@
   end if;
 
   Traverse (N);
+
+  --  Reset Pragma_Sloc after full subtree traversal
+
+  if T = 'P' then
+ Pragma_Sloc := No_Location;
+  end if;
end Process_Decisions;
 
---
@@ -733,6 +748,31 @@
   Write_SCOs_To_ALI_File;
end SCO_Output;
 
+   -
+   -- SCO_Pragma_Disabled --
+   -
+
+   function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
+  Index : Nat;
+
+   begin
+  if Loc = No_Location then
+ return False;
+  end if;
+
+  Index := Condition_Pragma_Hash_Table.Get (Loc);
+
+  --  The test here for zero is to deal with possible previous errors
+
+  if Index /= 0 then
+ pragma Assert (SCO_Table.Table (Index).C1 = 'P');
+ return SCO_Table.Table (Index).C2 = 'd';
+
+  else
+ return False;
+  end if;
+   end SCO_Pragma_Disabled;
+

-- SCO_Record --

@@ -863,11 +903,12 @@
-
 
procedure Set_Table_Entry
- (C1   : Character;
-  C2   : Character;
-  From : Source_Ptr;
-  To   : Source_Ptr;
-  Last : Boolean)
+ (C1  : Character;
+  C2  : Character;
+  From: Source_Ptr;
+  To  : Source_Ptr;
+  Last: Boolean;
+  Pragma_Sloc : Source_Ptr := No_Location)
is
   function To_Source_Location (S : Source_Ptr) return Source_Location;
   --  Converts Source_Ptr value to Source_Location (line/col) format
@@ -891,11 +932,12 @@
 
begin
   Add_SCO
-(C1   => C1,
- C2   => C2,
- From => To_Source_Location (From),
- To   => To_So

Re: [PATCH, testsuite, i386] AVX2 support for GCC

[Jakub Jelinek]

On Thu, Aug 04, 2011 at 01:28:17PM +0400, Kirill Yukhin wrote:
> During last few months I was working on AVX2 support for GCC.
> 
> Here is a patch which conforms (hopefully) to Spec which can be found at [1]
> 
> I am attaching following files:
>  - avx2.gcc.patch.tar.bz2. Compressed changes to GCC

Please be careful with the dejagnu feature tests:
+# Return 1 if avx2 instructions can be compiled.   
   
+proc check_effective_target_avx2 { } { 
   
+return [check_no_compiler_messages avx2 object {   
   
+   void _mm256_andnot_si256 (void) 
   
+{  
   
+  long long x __attribute__ ((__vector_size__ (32)));  
   
+  x = __builtin_ia32_andnotsi256 (x,x);
   
+   }   
   
+} "-O0 -mavx2" ]   
   
+}  
   

is using uninitialized variable.  Much better to write it e.g. as
typedef long long __v4di __attribute__ ((__vector_size__ (32)));
__v4di
mm256_andnot_si256 (__v4di __X, __v4di __Y)
{
  return __builtin_ia32_andnotsi256 (__X, __Y);
}
where no uninitialized vars are used, and the compiler can't really optimize
it away, nor attempt to simplify it (x & ~x is always 0, right?).

>  - opt64.tmp.gcc.patch. Since we have exceeded number of possible keys
> in ix86_isa_flags this temporary patch allows AVX2 changes to work.

I don't think it is a good idea to bump the 31 check in the conditions
handling, that should be done only if the variable type is known to be
64-bit.

Jakub

[Ada] Clean-up: remove flag Pragma_Enabled

[Arnaud Charlet]

This change removes a historical flag that is not used anymore.
No behaviour change, no test.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* sinfo.adb, sinfo.ads, sem_prag.adb, sem_ch12.adb (Pragma_Enabled):
This flag of N_Pragma nodes is not used, remove it as well as all of
the associated circuitry.

Index: sinfo.adb
===
--- sinfo.adb   (revision 177337)
+++ sinfo.adb   (working copy)
@@ -2406,14 +2406,6 @@
   return List2 (N);
end Pragma_Argument_Associations;
 
-   function Pragma_Enabled
- (N : Node_Id) return Boolean is
-   begin
-  pragma Assert (False
-or else NT (N).Nkind = N_Pragma);
-  return Flag5 (N);
-   end Pragma_Enabled;
-
function Pragma_Identifier
   (N : Node_Id) return Node_Id is
begin
@@ -5440,14 +5432,6 @@
   Set_List2_With_Parent (N, Val);
end Set_Pragma_Argument_Associations;
 
-   procedure Set_Pragma_Enabled
- (N : Node_Id; Val : Boolean := True) is
-   begin
-  pragma Assert (False
-or else NT (N).Nkind = N_Pragma);
-  Set_Flag5 (N, Val);
-   end Set_Pragma_Enabled;
-
procedure Set_Pragma_Identifier
   (N : Node_Id; Val : Node_Id) is
begin
Index: sinfo.ads
===
--- sinfo.ads   (revision 177337)
+++ sinfo.ads   (working copy)
@@ -1587,12 +1587,6 @@
--package specification. This field is Empty for library bodies (the
--parent spec in this case can be found from the corresponding spec).
 
-   --  Pragma_Enabled (Flag5-Sem)
-   --Present in N_Pragma nodes. This flag is relevant only for pragmas
-   --Assert, Check, Precondition, and Postcondition. It is true if the
-   --check corresponding to the pragma type is enabled at the point where
-   --the pragma appears.
-
--  Present_Expr (Uint3-Sem)
--Present in an N_Variant node. This has a meaningful value only after
--Gigi has back annotated the tree with representation information. At
@@ -2062,7 +2056,6 @@
   --  Pragma_Argument_Associations (List2) (set to No_List if none)
   --  Pragma_Identifier (Node4)
   --  Next_Rep_Item (Node5-Sem)
-  --  Pragma_Enabled (Flag5-Sem)
   --  From_Aspect_Specification (Flag13-Sem)
   --  Is_Delayed_Aspect (Flag14-Sem)
   --  Import_Interface_Present (Flag16-Sem)
@@ -8734,9 +8727,6 @@
function Pragma_Argument_Associations
  (N : Node_Id) return List_Id;-- List2
 
-   function Pragma_Enabled
- (N : Node_Id) return Boolean;-- Flag5
-
function Pragma_Identifier
  (N : Node_Id) return Node_Id;-- Node4
 
@@ -9700,9 +9690,6 @@
procedure Set_Pragma_Argument_Associations
  (N : Node_Id; Val : List_Id);-- List2
 
-   procedure Set_Pragma_Enabled
- (N : Node_Id; Val : Boolean := True);-- Flag5
-
procedure Set_Pragma_Identifier
  (N : Node_Id; Val : Node_Id);-- Node4
 
@@ -11897,7 +11884,6 @@
pragma Inline (Parent_Spec);
pragma Inline (Position);
pragma Inline (Pragma_Argument_Associations);
-   pragma Inline (Pragma_Enabled);
pragma Inline (Pragma_Identifier);
pragma Inline (Pragmas_After);
pragma Inline (Pragmas_Before);
@@ -12216,7 +12202,6 @@
pragma Inline (Set_Parent_Spec);
pragma Inline (Set_Position);
pragma Inline (Set_Pragma_Argument_Associations);
-   pragma Inline (Set_Pragma_Enabled);
pragma Inline (Set_Pragma_Identifier);
pragma Inline (Set_Pragmas_After);
pragma Inline (Set_Pragmas_Before);
Index: sem_prag.adb
===
--- sem_prag.adb(revision 177347)
+++ sem_prag.adb(working copy)
@@ -1719,7 +1719,6 @@
  --  Record if pragma is enabled
 
  if Check_Enabled (Pname) then
-Set_Pragma_Enabled (N);
 Set_SCO_Pragma_Enabled (Loc);
  end if;
 
@@ -6695,8 +6694,6 @@
 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
 
 if Check_On then
-   Set_Pragma_Enabled (N);
-   Set_Pragma_Enabled (Original_Node (N));
Set_SCO_Pragma_Enabled (Loc);
 end if;
 
Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 177274)
+++ sem_ch12.adb(working copy)
@@ -12446,26 +12446,6 @@
--  All other cases than aggregates
 
else
-  --  For pragmas, we propagate the Enabled status for the
-  --  relevant pragmas to the original generic tree. This was
-  --  originally needed for SCO generation. It is no longer
-  --  needed there (since we use the Sloc value in calls to
-  --  Set_SCO_Pragma_Enabled), but it seems a generally good
-  --  idea to have this fl

[Ada] Improved error message on one-element positional aggregates

[Arnaud Charlet]

An illegal one-element positional aggregate is usually detected as a type
error. If the expected type is a one-component record, it is possible to
indicate what the proper syntax should be. A similar suggestion can be given
if the context specifies a nameable array type or the target of an assignment.
However, the suggestion is not as precise for subaggregates of multidimensional
arrays.

The following displays the improved error messages:

Compiling: p1.adb (source file time stamp: 2011-03-04 16:14:14)

 1. procedure P1 is
 2.type Sequence is array (integer range <>) of Float;
 3.
 4.type T_1 is record
 5.R_2: integer;
 6.end record;
 7.
 8.type Table is array (1..2, 1..1) of integer;
 9.T : Table := ((0), (0));
  |
>>> nested array aggregate expected
>>> if single-component aggregate is intended, write e.g. (1 => ...)

10.
11.V_D4 : array ( 1..1) of T_1 :=
12.  (1 => ( 1));
 |
>>> positional aggregate cannot have one component
>>> write instead "R_2 => ..."

13.
14.Thing : T_1 := (5);
   |
>>> positional aggregate cannot have one component
>>> write instead "R_2 => ..."

15.
16.It : Sequence := (3.1415);
 |
>>> positional aggregate cannot have one component
>>> write instead "Sequence'First => ..."

17.
18.subtype Yes is boolean range True .. True;
19.type Vacuous is array (Yes) of Float;
20.Oui : Vacuous := (1.0);
 |
>>> positional aggregate cannot have one component
>>> write instead "Vacuous'First => ..."

21.
22.subtype Name is String (1 .. 5);
23.That : name := "That ";
24.type Names is array (1..2, 1..5) of character;
25.Them : Names := ("this ", (that));
  |
>>> nested array aggregate expected
>>> if single-component aggregate is intended, write e.g. (1 => ...)

26.
27.Anon : array (1..1) of Boolean;
28.
29. begin
30. It := (2.7179);
   |
>>> positional aggregate cannot have one component
>>> write instead "Sequence'First => ..."

31.
32. Anon := (False);
 |
>>> positional aggregate cannot have one component
>>> write instead "Anon'First => ..."

33. end P1;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_util.adb:(Wrong_Type): Improve error message on a one-element
positional aggregate.

Index: sem_util.adb
===
--- sem_util.adb(revision 177328)
+++ sem_util.adb(working copy)
@@ -12478,9 +12478,13 @@

 
procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
-  Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
-  Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+  Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
+  Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
 
+  Matching_Field : Entity_Id;
+  --  Entity to give a more precise suggestion on how to write a one-
+  --  element positional aggregate.
+
   function Has_One_Matching_Field return Boolean;
   --  Determines if Expec_Type is a record type with a single component or
   --  discriminant whose type matches the found type or is one dimensional
@@ -12494,11 +12498,27 @@
  E : Entity_Id;
 
   begin
+ Matching_Field := Empty;
+
  if Is_Array_Type (Expec_Type)
and then Number_Dimensions (Expec_Type) = 1
and then
  Covers (Etype (Component_Type (Expec_Type)), Found_Type)
  then
+--  Use type name if available. This excludes multidimensional
+--  arrays and anonymous arrays.
+
+if Comes_From_Source (Expec_Type) then
+   Matching_Field := Expec_Type;
+
+--  For an assignment, use name of target.
+
+elsif Nkind (Parent (Expr)) = N_Assignment_Statement
+  and then Is_Entity_Name (Name (Parent (Expr)))
+then
+   Matching_Field := Entity (Name (Parent (Expr)));
+end if;
+
 return True;
 
  elsif not Is_Record_Type (Expec_Type) then
@@ -12529,6 +12549,7 @@
return False;
 
 else
+   Matching_Field := E;
return True;
 end if;
  end if;
@@ -12577,7 +12598,17 @@
 and then Has_One_Matching_Field
   then
  Error_Msg_N ("positional aggregate cannot have one component", Expr);
+ if Present (Matching_Field) then
+ 

[Ada] Fix obscure race condition in term alts

[Arnaud Charlet]

This patch is fixes an obscure race condition in the
implementation of terminate alternatives.
No small test case is available.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Bob Duff  

* s-tasren.adb (Task_Do_Or_Queue): Previous code was reading
Acceptor.Terminate_Alternative without locking Acceptor, which causes a
race condition whose symptom is to fail to lock Parent. That, in turn,
causes Parent.Awake_Count to be accessed without locking Parent, which
causes another race condition whose symptom is that Parent.Awake_Count
can be off by 1 (either too high or too low). The solution is to lock
Parent unconditionally, and then lock Acceptor, before reading
Acceptor.Terminate_Alternative.

Index: s-tasren.adb
===
--- s-tasren.adb(revision 177274)
+++ s-tasren.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- B o d y  --
 --  --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc.  --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc.  --
 --  --
 -- GNARL 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- --
@@ -1077,7 +1077,6 @@
   Old_State : constant Entry_Call_State := Entry_Call.State;
   Acceptor  : constant Task_Id := Entry_Call.Called_Task;
   Parent: constant Task_Id := Acceptor.Common.Parent;
-  Parent_Locked : Boolean := False;
   Null_Body : Boolean;
 
begin
@@ -1105,25 +1104,24 @@
   --  record for another call.
   --  We rely on the Caller's lock for call State mod's.
 
-  --  We can't lock Acceptor.Parent while holding Acceptor,
-  --  so lock it in advance if we expect to need to lock it.
+  --  If Acceptor.Terminate_Alternative is True, we need to lock Parent and
+  --  Acceptor, in that order; otherwise, we only need a lock on
+  --  Acceptor. However, we can't check Acceptor.Terminate_Alternative
+  --  until Acceptor is locked. Therefore, we need to lock both. Attempts
+  --  to avoid locking Parent tend to result in race conditions. It would
+  --  work to unlock Parent immediately upon finding
+  --  Acceptor.Terminate_Alternative to be False, but that violates the
+  --  rule of properly nested locking (see System.Tasking).
 
-  if Acceptor.Terminate_Alternative then
- STPO.Write_Lock (Parent);
- Parent_Locked := True;
-  end if;
-
+  STPO.Write_Lock (Parent);
   STPO.Write_Lock (Acceptor);
 
   --  If the acceptor is not callable, abort the call and return False
 
   if not Acceptor.Callable then
  STPO.Unlock (Acceptor);
+ STPO.Unlock (Parent);
 
- if Parent_Locked then
-STPO.Unlock (Parent);
- end if;
-
  pragma Assert (Entry_Call.State < Done);
 
  --  In case we are not the caller, set up the caller
@@ -1186,11 +1184,8 @@
 
   STPO.Wakeup (Acceptor, Acceptor_Sleep);
   STPO.Unlock (Acceptor);
+  STPO.Unlock (Parent);
 
-  if Parent_Locked then
- STPO.Unlock (Parent);
-  end if;
-
   STPO.Write_Lock (Entry_Call.Self);
   Initialization.Wakeup_Entry_Caller
 (Self_ID, Entry_Call, Done);
@@ -1207,10 +1202,7 @@
   end if;
 
   STPO.Unlock (Acceptor);
-
-  if Parent_Locked then
- STPO.Unlock (Parent);
-  end if;
+  STPO.Unlock (Parent);
end if;
 
return True;
@@ -1236,11 +1228,8 @@
 and then Entry_Call.Cancellation_Attempted)
   then
  STPO.Unlock (Acceptor);
+ STPO.Unlock (Parent);
 
- if Parent_Locked then
-STPO.Unlock (Parent);
- end if;
-
  STPO.Write_Lock (Entry_Call.Self);
 
  pragma Assert (Entry_Call.State >= Was_Abortable);
@@ -1261,11 +1250,8 @@
New_State (Entry_Call.With_Abort, Entry_Call.State);
 
  STPO.Unlock (Acceptor);
+ STPO.Unlock (Parent);
 
- if Parent_Locked then
-STPO.Unlock (Parent);
- end if;
-
  if Old_State /= Entry_Call.State
and then Entry_Call.State = Now_Abortable
and then Entry_Call.Mode /= Simple_Call

[Ada] Remove detection of entities in the ALFA subset for formal verification

[Arnaud Charlet]

The detection of entities in ALFA is best left in a back-end of the compiler,
so all the machinery for flagging entities as in ALFA, and the body of
subprograms as in ALFA, have been removed.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* alfa.adb, alfa.ads (Get_Entity_For_Decl): remove function, partial
duplicate of Defining_Entity
(Get_Unique_Entity_For_Decl): rename function into
Unique_Defining_Entity
* einfo.adb, einfo.ads (Is_In_ALFA, Body_Is_In_ALFA): remove flags
(Formal_Proof_On): remove synthesized flag
* cstand.adb, sem_ch11.adb, sem_ch2.adb, sem_ch3.adb, sem_ch4.adb,
sem_ch5.adb, sem_ch6.adb, sem_ch9.adb, sem_res.adb, sem_util.adb,
sem_util.ads, stand.ads: Remove treatment associated to entities in ALFA
* sem_prag.adb (Analyze_Pragma): remove special treatment for pragma
Annotate (Formal_Proof)

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 177340)
+++ sem_ch3.adb (working copy)
@@ -3057,17 +3057,6 @@
 
   Act_T := T;
 
-  --  The object is in ALFA if-and-only-if its type is in ALFA and it is
-  --  not aliased.
-
-  if not Is_In_ALFA (T) then
- Mark_Non_ALFA_Subprogram ("object type is not in ALFA", N);
-  elsif Aliased_Present (N) then
- Mark_Non_ALFA_Subprogram ("ALIASED is not in ALFA", N);
-  else
- Set_Is_In_ALFA (Id);
-  end if;
-
   --  These checks should be performed before the initialization expression
   --  is considered, so that the Object_Definition node is still the same
   --  as in source code.
@@ -4661,7 +4650,6 @@
   Nb_Index  : Nat;
   P : constant Node_Id := Parent (Def);
   Priv  : Entity_Id;
-  T_In_ALFA : Boolean := True;
 
begin
   if Nkind (Def) = N_Constrained_Array_Definition then
@@ -4742,12 +4730,6 @@
 
  Make_Index (Index, P, Related_Id, Nb_Index);
 
- if Present (Etype (Index))
-   and then not Is_In_ALFA (Etype (Index))
- then
-T_In_ALFA := False;
- end if;
-
  --  Check error of subtype with predicate for index type
 
  Bad_Predicated_Subtype_Use
@@ -4769,18 +4751,10 @@
 Check_SPARK_Restriction ("subtype mark required", Component_Typ);
  end if;
 
- if Present (Element_Type)
-   and then not Is_In_ALFA (Element_Type)
- then
-T_In_ALFA := False;
- end if;
-
   --  Ada 2005 (AI-230): Access Definition case
 
   else pragma Assert (Present (Access_Definition (Component_Def)));
 
- T_In_ALFA := False;
-
  --  Indicate that the anonymous access type is created by the
  --  array type declaration.
 
@@ -4857,12 +4831,6 @@
(Implicit_Base, Finalize_Storage_Only
 (Element_Type));
 
- --  Final check for static bounds on array
-
- if not Has_Static_Array_Bounds (T) then
-T_In_ALFA := False;
- end if;
-
   --  Unconstrained array case
 
   else
@@ -4887,8 +4855,6 @@
 
   Set_Component_Type (Base_Type (T), Element_Type);
   Set_Packed_Array_Type (T, Empty);
-  Set_Is_In_ALFA (T, T_In_ALFA);
-  Set_Is_In_ALFA (Base_Type (T), T_In_ALFA);
 
   if Aliased_Present (Component_Definition (Def)) then
  Check_SPARK_Restriction
@@ -11599,14 +11565,6 @@
   C : constant Node_Id   := Constraint (S);
 
begin
-  --  By default, consider that the enumeration subtype is in ALFA if the
-  --  entity of its subtype mark is in ALFA. This is reversed later if the
-  --  range of the subtype is not static.
-
-  if Is_In_ALFA (T) then
- Set_Is_In_ALFA (Def_Id);
-  end if;
-
   Set_Ekind (Def_Id, E_Enumeration_Subtype);
 
   Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
@@ -11829,14 +11787,6 @@
   C : constant Node_Id   := Constraint (S);
 
begin
-  --  By default, consider that the integer subtype is in ALFA if the
-  --  entity of its subtype mark is in ALFA. This is reversed later if the
-  --  range of the subtype is not static.
-
-  if Is_In_ALFA (T) then
- Set_Is_In_ALFA (Def_Id);
-  end if;
-
   Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
 
   if Is_Modular_Integer_Type (T) then
@@ -14586,12 +14536,6 @@
   Set_Enum_Esize  (T);
   Set_Enum_Pos_To_Rep (T, Empty);
 
-  --  Enumeration type is in ALFA only if it is not a character type
-
-  if not Is_Character_Type (T) then
- Set_Is_In_ALFA (T);
-  end if;
-
   --  Set Discard_Names if configuration pragma set, or if there is
   --  a parameterless pragma in the current declarative region
 
@@ -16550,19 +16494,6 @@
  then
 Set_Is_Non_Static_Sub

[Ada] Detect useless assignments to parts of objects

[Arnaud Charlet]

GNAT did not issue a warning when assigning to a part of an object, and not
referencing the object later on. Now it does so in some cases, similarly to
the existing warnings on assignment to elementary objects.

On the code below, GNAT now issues warnings:

$ gcc -c -gnatwa assign.adb
assign.adb:8:05: warning: useless assignment to "X", value never referenced
assign.adb:9:04: warning: useless assignment to "Y", value never referenced

---
procedure Assign is
   type T is record
  U : Integer;
   end record;
   X : T := T'(U => 0);
   Y : array (1..2) of Integer := (others => 0);
begin
   X.U   := X.U + 1;
   Y (2) := Y (1);
end Assign;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* checks.adb (Apply_Float_Conversion_Check): correct a typo where Lo_OK
was used instead of Hi_OK, which could cause a read of an uninitialized
value later on. Detected while working on the new warning.
* exp_ch9.adb (Expand_N_Entry_Declaration): remove useless assignment
to local variable.
* sem_ch5.adb (Analyze_Assignment): set the last assignment component
in more cases, in order to detect more unreferenced values.
* sem_util.adb, sem_util.ads (Get_Enclosing_Object): return enclosing
object for expression, if any.

Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 177353)
+++ sem_ch5.adb (working copy)
@@ -746,22 +746,17 @@
 if Safe_To_Capture_Value (N, Ent) then
 
--  If simple variable on left side, warn if this assignment
-   --  blots out another one (rendering it useless) and note
-   --  location of assignment in case no one references value. We
-   --  only do this for source assignments, otherwise we can
-   --  generate bogus warnings when an assignment is rewritten as
-   --  another assignment, and gets tied up with itself.
+   --  blots out another one (rendering it useless). We only do
+   --  this for source assignments, otherwise we can generate bogus
+   --  warnings when an assignment is rewritten as another
+   --  assignment, and gets tied up with itself.
 
-   --  Note: we don't use Record_Last_Assignment here, because we
-   --  have lots of other stuff to do under control of this test.
-
if Warn_On_Modified_Unread
  and then Is_Assignable (Ent)
  and then Comes_From_Source (N)
  and then In_Extended_Main_Source_Unit (Ent)
then
   Warn_On_Useless_Assignment (Ent, N);
-  Set_Last_Assignment (Ent, Lhs);
end if;
 
--  If we are assigning an access type and the left side is an
@@ -803,6 +798,28 @@
 end if;
  end;
   end if;
+
+  --  If assigning to an object in whole or in part, note location of
+  --  assignment in case no one references value. We only do this for
+  --  source assignments, otherwise we can generate bogus warnings when an
+  --  assignment is rewritten as another assignment, and gets tied up with
+  --  itself.
+
+  declare
+ Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
+
+  begin
+ if Present (Ent)
+   and then Safe_To_Capture_Value (N, Ent)
+   and then Nkind (N) = N_Assignment_Statement
+   and then Warn_On_Modified_Unread
+   and then Is_Assignable (Ent)
+   and then Comes_From_Source (N)
+   and then In_Extended_Main_Source_Unit (Ent)
+ then
+Set_Last_Assignment (Ent, Lhs);
+ end if;
+  end;
end Analyze_Assignment;
 
-
Index: exp_ch9.adb
===
--- exp_ch9.adb (revision 177344)
+++ exp_ch9.adb (working copy)
@@ -7330,7 +7330,6 @@
  Subtype_Indication => New_Reference_To (Rec_Ent, Loc)));
 
  Insert_After (Last_Decl, Decl);
- Last_Decl := Decl;
   end if;
end Expand_N_Entry_Declaration;
 
Index: checks.adb
===
--- checks.adb  (revision 177318)
+++ checks.adb  (working copy)
@@ -1690,7 +1690,7 @@
 
   if Truncate and then Ilast < 0 then
  Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
- Lo_OK := False;
+ Hi_OK := False;
 
   elsif Truncate then
  Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
Index: sem_util.adb
===
--- sem_util.adb(revision 177353)
+++ sem_util.adb(working copy)
@@ -4151,6 +4151,38 @@
   Strval => String_From_Name_Buffer);
end Get_Default_External_Name;
 
+   --
+   -- Get_Enclosing_Object --
+   

Re: [PATCH, ARM] Fix broken testcase, vfp-1.c, for Thumb

[Richard Earnshaw]

On 28/07/11 15:50, Ian Bolton wrote:
> This patch makes the vfp-1.c testcase work for Thumb.  It became broken when
> we
> restricted the negative offsets allowed for Thumb to fix up a Spec2K failure
> some months back.  (It was previously possible to generate illegal offsets.)
> 
> OK for trunk?
> 
> 
> Cheers,
> Ian
> 
> 
> 2011-07-28  Ian Bolton  
> 
> testsuite/
>   * gcc.target/arm/vfp-1.c: large negative offsets not possible on
> Thumb2.
> 
> 

OK.

R.

PR ada/49944, take 2 [4.5/4.6/4.7 regression] Bootstrapping on x86_64-pc-kfreebsd-gnu fails with "s-taprop.adb:856:10: "pthread_attr_setaffinity_np" is undefined (more references follow)"

[Ludovic Brenta]

Pursuant to Arno's comments on PR ada/49444, here is another patch that
allows GCC to compile with Ada support on Debian GNU/kFreeBSD.

2011-08-04  Ludovic Brenta 

* gcc/ada/gcc-interface/Makefile.in (kfreebsd%):
  - use s-taprop-posix.ad[bs] instead of s-taprop-linux.ad[bs]
  - use use s-tasinf.ad[bs] instead of s-tasinf-linux.ad[bs].
* s-osinte-kfreebsd-gnu.ads: allow the above by bringing the
  interface closer to s-osinte-freebsd.ads.

Index: b/src/gcc/ada/s-osinte-kfreebsd-gnu.ads
===
--- a/src/gcc/ada/s-osinte-kfreebsd-gnu.ads
+++ b/src/gcc/ada/s-osinte-kfreebsd-gnu.ads
@@ -200,8 +200,24 @@
-- Time --
--
 
+   Time_Slice_Supported : constant Boolean := True;
+   --  Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
type timespec is private;
 
+   function nanosleep (rqtp, rmtp : access timespec)  return int;
+   pragma Import (C, nanosleep, "nanosleep");
+
+   type clockid_t is private;
+
+   CLOCK_REALTIME : constant clockid_t;
+
+   function clock_gettime
+ (clock_id : clockid_t;
+  tp   : access timespec)
+  return int;
+   pragma Import (C, clock_gettime, "clock_gettime");
+
function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration);
 
@@ -263,6 +289,10 @@
type pthread_key_t   is private;
 
PTHREAD_CREATE_DETACHED : constant := 1;
+   PTHREAD_CREATE_JOINABLE : constant := 0;
+
+   PTHREAD_SCOPE_PROCESS : constant := 0;
+   PTHREAD_SCOPE_SYSTEM  : constant := 2;
 
---
-- Stack --
@@ -286,9 +316,32 @@
Alternate_Stack_Size : constant := 0;
--  No alternate signal stack is used on this platform
 
+   Stack_Base_Available : constant Boolean := False;
+   --  Indicates whether the stack base is available on this target. This
+   --  allows us to share s-osinte.adb between all the FSU run time. Note that
+   --  this value can only be true if pthread_t has a complete definition that
+   --  corresponds exactly to the C header files.
+
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
-   --  This is a dummy procedure to share some GNULLI files
+   --  returns the stack base of the specified thread. Only call this function
+   --  when Stack_Base_Available is True.
+
+   function Get_Page_Size return size_t;
+   function Get_Page_Size return Address;
+   pragma Import (C, Get_Page_Size, "getpagesize");
+   --  Returns the size of a page
+
+   PROT_NONE  : constant := 0;
+   PROT_READ  : constant := 1;
+   PROT_WRITE : constant := 2;
+   PROT_EXEC  : constant := 4;
+   PROT_ALL   : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+   PROT_ON: constant := PROT_NONE;
+   PROT_OFF   : constant := PROT_ALL;
+
+   function mprotect (addr : Address; len : size_t; prot : int) return int;
+   pragma Import (C, mprotect);
 
---
-- Nonstandard Thread Initialization --
@@ -377,6 +430,36 @@
-- POSIX.1c  Section 13 --
--
 
+   PTHREAD_PRIO_NONE: constant := 0;
+   PTHREAD_PRIO_PROTECT : constant := 2;
+   PTHREAD_PRIO_INHERIT : constant := 1;
+
+   function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+  protocol : int) return int;
+   pragma Import
+  (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+   function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+  protocol : access int) return int;
+   pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+   function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+  prioceiling : int) return int;
+   pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+  "pthread_mutexattr_setprioceiling");
+
+   function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+  prioceiling : access int) return int;
+   pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+  "pthread_mutexattr_getprioceiling");
+
type struct_sched_param is record
   sched_priority : int;  --  scheduling priority
end record;
@@ -388,6 +471,28 @@
   param  : access struct_sched_param) return int;
pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
 
+   function pthread_attr_setscope
+ (attr: access pthread_attr_t;
+  contentionscope : int) return int;
+   pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+   function pthread_attr_getscope
+ (attr: access pthread_attr_t;
+  contentionscope : access int) return int;
+   pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+   function pthread_attr_setinheritsched
+ (attr: access pthread_attr_t;
+  inheritsched : int) return int;
+   pragma Import
+ (C, pthread_attr_setinheri

Re: [Ada] Detect useless assignments to parts of objects

[Duncan Sands]

Hi Arnaud, this is a great feature.  How does it handle unchecked unions?  Will
it warn if you write to a field but only read the value via a different field?

Ciao, Duncan.


GNAT did not issue a warning when assigning to a part of an object, and not
referencing the object later on. Now it does so in some cases, similarly to
the existing warnings on assignment to elementary objects.

On the code below, GNAT now issues warnings:

$ gcc -c -gnatwa assign.adb
assign.adb:8:05: warning: useless assignment to "X", value never referenced
assign.adb:9:04: warning: useless assignment to "Y", value never referenced

---
procedure Assign is
type T is record
   U : Integer;
end record;
X : T := T'(U =>  0);
Y : array (1..2) of Integer := (others =>  0);
begin
X.U   := X.U + 1;
Y (2) := Y (1);
end Assign;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy

* checks.adb (Apply_Float_Conversion_Check): correct a typo where Lo_OK
was used instead of Hi_OK, which could cause a read of an uninitialized
value later on. Detected while working on the new warning.
* exp_ch9.adb (Expand_N_Entry_Declaration): remove useless assignment
to local variable.
* sem_ch5.adb (Analyze_Assignment): set the last assignment component
in more cases, in order to detect more unreferenced values.
* sem_util.adb, sem_util.ads (Get_Enclosing_Object): return enclosing
object for expression, if any.

Re: [Ada] Detect useless assignments to parts of objects

[Arnaud Charlet]

> Hi Arnaud, this is a great feature.  How does it handle unchecked unions?  
> Will
> it warn if you write to a field but only read the value via a different field?

It's a simple minded check, nothing fancy. It will warn when there are no
reference to the the object at all after the assignment, and isn't trying to
keep track of fields, so unchecked unions do not make any difference.

Arno

Re: PR ada/49944, take 2 [4.5/4.6/4.7 regression] Bootstrapping on x86_64-pc-kfreebsd-gnu fails with "s-taprop.adb:856:10: "pthread_attr_setaffinity_np" is undefined (more references follow)"

[Arnaud Charlet]

> Pursuant to Arno's comments on PR ada/49444, here is another patch that
> allows GCC to compile with Ada support on Debian GNU/kFreeBSD.
> 
> 2011-08-04  Ludovic Brenta 
> 
> * gcc/ada/gcc-interface/Makefile.in (kfreebsd%):
>   - use s-taprop-posix.ad[bs] instead of s-taprop-linux.ad[bs]
>   - use use s-tasinf.ad[bs] instead of s-tasinf-linux.ad[bs].
> * s-osinte-kfreebsd-gnu.ads: allow the above by bringing the
>   interface closer to s-osinte-freebsd.ads.

The above ChangeLog isn't quite in the proper format.
Also see below for a few stylistic issues to fix.

Once fixed, the patch is OK to commit, thanks.

Arno

> --- a/src/gcc/ada/s-osinte-kfreebsd-gnu.ads
> +++ b/src/gcc/ada/s-osinte-kfreebsd-gnu.ads
> @@ -200,8 +200,24 @@
> -- Time --
> --
>  
> +   Time_Slice_Supported : constant Boolean := True;
> +   --  Indicates whether time slicing is supported (i.e SCHED_RR is
> supported)
> +
> type timespec is private;
>  
> +   function nanosleep (rqtp, rmtp : access timespec)  return int;

remove extra blank here^

> @@ -286,9 +316,32 @@
> Alternate_Stack_Size : constant := 0;
> --  No alternate signal stack is used on this platform
>  
> +   Stack_Base_Available : constant Boolean := False;
> +   --  Indicates whether the stack base is available on this target. This
> +   --  allows us to share s-osinte.adb between all the FSU run time. Note 
> that
> +   --  this value can only be true if pthread_t has a complete definition 
> that
> +   --  corresponds exactly to the C header files.

The above comment is wrong/obsolete. Replace it simply by:

   --  Indicates whether the stack base is available on this target

Arno

Re: [PLUGIN] compile and install gengtype, install gtype.state

[Romain GEISSLER]

On 08/04/2011 12:21 PM, Romain Geissler wrote:

On Mon, Aug 01, 2011 at 02:27:49PM +0200, Romain Geissler wrote:

ping


I went ahead and bootstrapped/regtested/and make install tested your patch
(note your mailer wrapped it up so that it didn't apply cleanly), but now
that I think about it, it is wrong to put the gengtype binary into
$(libsubdir)/plugin/bin/
IMNSHO it should go into
$(libexecsubdir)/plugin/
directory instead, libexec is where binaries go...  So please change
plugin_bindir.

Jakub



Hi,

Find attached the final patch. I can't apply it by myself.

Romain Geissler.
2011-07-18  Romain Geissler  

* gengtype-state.c: Include "bconfig.h" if
GENERATOR_FILE is defined, "config.h" otherwise.
* gengtype.c: Likewise.
* gengtype-lex.l: Likewise.
* gengtype-parse.c: Likewise.
* Makefile.in (gengtype-lex.o-warn): New variable.
(plugin_resourcesdir): Likewise.
(plugin_bindir): Likewise.
(plugin_includedir): Use $(plugin_resourcesdir) as prefix base.
(MOSTLYCLEANFILES): Add gengtype$(exeext).
(native): Depend on gengtype$(exeext) is $enable_plugin
is set to "yes".
(gtype.state): Depend on s-gtype. Use temporary file.
(gengtype-lex.o): New rule.
(gengtype-parse.o): Likewise.
(gengtype-state.o): Likewise.
(gengtype$(exeext)): Likewise.
(install-gengtype): Likewise.
(gengtype.o): Likewise.
(build/gengtype.o): Depend on version.h.
(build/gengtype-state): Depend on double-int.h, version.h,
$(HASHTAB_H), $(OBSTACK_H), $(XREGEX_H) and build/errors.o.
(install-plugin): Depend on install-gengtype.
Index: gcc/gengtype-state.c
===
--- gcc/gengtype-state.c(revision 176740)
+++ gcc/gengtype-state.c(working copy)
@@ -23,7 +23,11 @@
and Basile Starynkevitch 
 */
 
+#ifdef GENERATOR_FILE
 #include "bconfig.h"
+#else
+#include "config.h"
+#endif
 #include "system.h"
 #include "errors.h"/* For fatal.  */
 #include "double-int.h"
Index: gcc/gengtype.c
===
--- gcc/gengtype.c  (revision 176740)
+++ gcc/gengtype.c  (working copy)
@@ -18,7 +18,11 @@
along with GCC; see the file COPYING3.  If not see
.  */
 
+#ifdef GENERATOR_FILE
 #include "bconfig.h"
+#else
+#include "config.h"
+#endif
 #include "system.h"
 #include "errors.h"/* for fatal */
 #include "getopt.h"
Index: gcc/gengtype-lex.l
===
--- gcc/gengtype-lex.l  (revision 176740)
+++ gcc/gengtype-lex.l  (working copy)
@@ -22,7 +22,11 @@ along with GCC; see the file COPYING3.
 %option noinput
 
 %{
+#ifdef GENERATOR_FILE
 #include "bconfig.h"
+#else
+#include "config.h"
+#endif
 #include "system.h"
 
 #define malloc xmalloc
Index: gcc/gengtype-parse.c
===
--- gcc/gengtype-parse.c(revision 176740)
+++ gcc/gengtype-parse.c(working copy)
@@ -17,7 +17,11 @@
along with GCC; see the file COPYING3.  If not see
.  */
 
+#ifdef GENERATOR_FILE
 #include "bconfig.h"
+#else
+#include "config.h"
+#endif
 #include "system.h"
 #include "gengtype.h"
 
Index: gcc/Makefile.in
===
--- gcc/Makefile.in (revision 176741)
+++ gcc/Makefile.in (working copy)
@@ -192,6 +192,7 @@ GCC_WARN_CXXFLAGS = $(LOOSE_WARN) $($(@D
 # be subject to -Werror:
 # flex output may yield harmless "no previous prototype" warnings
 build/gengtype-lex.o-warn = -Wno-error
+gengtype-lex.o-warn = -Wno-error
 # mips-tfile.c contains -Wcast-qual warnings.
 mips-tfile.o-warn = -Wno-error
 expmed.o-warn = -Wno-error
@@ -566,8 +567,12 @@ libexecdir = @libexecdir@
 libsubdir = $(libdir)/gcc/$(target_noncanonical)/$(version)
 # Directory in which the compiler finds executables
 libexecsubdir = $(libexecdir)/gcc/$(target_noncanonical)/$(version)
-# Directory in which plugin headers are installed
-plugin_includedir = $(libsubdir)/plugin/include
+# Directory in which all plugin resources are installed
+plugin_resourcesdir = $(libsubdir)/plugin
+ # Directory in which plugin headers are installed
+plugin_includedir = $(plugin_resourcesdir)/include
+# Directory in which plugin specific executables are installed
+plugin_bindir = $(libexecsubdir)/plugin
 # Used to produce a relative $(gcc_tooldir) in gcc.o
 unlibsubdir = ../../..
 # $(prefix), expressed as a path relative to $(libsubdir).
@@ -1531,8 +1536,8 @@ MOSTLYCLEANFILES = insn-flags.h insn-con
  $(EXTRA_PARTS) $(EXTRA_PROGRAMS) gcc-cross$(exeext) \
  $(SPECS) collect2$(exeext) lto-wrapper$(exeext) \
  gcov-iov$(build_exeext) gcov$(exeext) gcov-dump$(exeext) \
- *.[0-9][0-9].* *.[si] *-checksum.c libbackend.a libcommon-target.a \
- libco

Re: [patch tree-optimization]: Improve reassociation pass for bitwise-operations

[Kai Tietz]

2011/8/3 Richard Guenther :
> On Wed, Aug 3, 2011 at 3:32 PM, Kai Tietz  wrote:
>> 2011/8/3 Michael Matz :
>>> Hi,
>>>
>>> On Tue, 2 Aug 2011, Kai Tietz wrote:
>>>
 this patch improves the ability of reassociation pass to simplifiy
 more complex bitwise-binary
 operations with comparisons.  We break-up for this patch statements
 like (X | Y) != 0 to X != 0 | Y != 0,
 and (X | Y) == 0 to expanded X == 0 & Y == 0.
 Additionally we expand logical-not expressions like ~(A & B) -> ~A |
 ~B, ~(A & B) -> ~A | ~B, and
 ~(A ^ B) -> A ^ ~B.  These expansion are just temporary for this pass
 and getting later by fold
 reversed again back to their original form.
>>>
>>> Implement all of this in the normal reassoc machinery that already exists.
>>> Don't implement your own walker (which btw is superlinear because you
>>> recurse into both operands).  If no simplifications were possible you have
>>> to fold back the NOTs into the shorter sequences again, which conveniently
>>> reassoc already can do for negates and PLUS/MINUS chains.
>>>
>>> Hence extend the existing support for arithmetic operations to logical
>>> operations.
>>>
>>>
>>> Ciao,
>>> Michael.
>>
>> What you mean by existing machinery for negate expression here?  This
>> machinery doen't work in this case and additionally doesn't provide
>> the opportunity to do a complete reassociation rewrite of
>> bitwise-expression-chains.
>>
>> Eg: the case (~(a | c) & (b & ~d))  would be expanded (by code in
>> patch) to ~a & ~c & b & ~d.
>> This intermediate result is good to inspect doubles, or inverted 
>> optimizations.
>> On rebuilding of tree the result gets transformed (or should) to ~(a |
>> c | d) & b.
>
> It depends on the context whether a conjunctive or a disjunctive normal
> form is what you want.  As you are mixing two operation kinds reassoc
> isn't the perfect place to deal with this (yet).
>
> You don't seem to stop when single-use chains end (which is where
> reassoc will give up) and even visit stmts multiple times that way.
> You need to at least do this "unfolding" in a lot more controlled manner.
>
> Richard.

Hello,

This revised patch takes care that we don't visit statements, which
aren't modified, recursively.
Additionally it takes care that we just do normalize statements with single-use.

ChangeLog

2011-08-04  Kai Tietz  

* tree-ssa-reassoc.c (gimple build_and_add_sum): Add forwarder
declaration and add support for unary-expression.
(remove_visited_stmt_chain): Add forwarder declaration.
(make_new_tmp_statement): New helper function.
(expand_not_bitwise_binary): Likewise.
(break_up_bitwise_combined_stmt): Likeiwise.
(break_up_subtract_bb): Add call to break_up_bitwise_combined_stmt.


ChangeLog

2011-08-03  Kai Tietz  

* gcc.dg/tree-ssa/reassoc-24.c: New test.
* gcc.dg/tree-ssa/reassoc-25.c: New test.
* gcc.dg/tree-ssa/reassoc-26.c: New test.
* gcc.dg/tree-ssa/reassoc-27.c: New test.
* gcc.dg/tree-ssa/reassoc-28.c: New test.
* gcc.dg/tree-ssa/reassoc-29.c: New test.

Bootstrapped and regression tested for all languages (including Ada
and Obj-C++) on host x86_64-pc-linux-gnu.
Ok for apply?

Regards,
Kai

Index: gcc/gcc/tree-ssa-reassoc.c
===
--- gcc.orig/gcc/tree-ssa-reassoc.c
+++ gcc/gcc/tree-ssa-reassoc.c
@@ -41,6 +41,10 @@ along with GCC; see the file COPYING3.
 #include "cfgloop.h"
 #include "flags.h"

+/* Forwarders.  */
+static gimple build_and_add_sum (tree, tree, tree, enum tree_code);
+static void remove_visited_stmt_chain (tree);
+
 /*  This is a simple global reassociation pass.  It is, in part, based
 on the LLVM pass of the same name (They do some things more/less
 than we do, in different orders, etc).
@@ -48,7 +52,9 @@ along with GCC; see the file COPYING3.
 It consists of five steps:

 1. Breaking up subtract operations into addition + negate, where
-it would promote the reassociation of adds.
+it would promote the reassociation of adds.  Additionally breaking
+up combined expression made out of boolean-typed bitwise expressions
+for improving simplification.

 2. Left linearization of the expression trees, so that (A+B)+(C+D)
 becomes (((A+B)+C)+D), which is easier for us to rewrite later.
@@ -554,6 +560,232 @@ get_unary_op (tree name, enum tree_code
   return NULL_TREE;
 }

+/* Create a temorary register expression with type TYPE, tree code CODE, and
+   operands OP1 and OP2.  If REF_DEF is a valid gimple statement, we use its
+   location for new generated temporary.
+   Function returns left-hand-side of new generated temporary register.  */
+static tree
+make_new_tmp_statement (tree type, enum tree_code code, tree op1, tree op2,
+   gimple ref_def)
+{
+  gimple sum;
+  tree tmpvar = create_tmp_reg (type, NULL);
+  add_referenced_var (tmpvar);
+  sum = bu

Re: [PATCH][RFC] Fix PR49957 - build array index differently

[Richard Guenther]

On Thu, 4 Aug 2011, Richard Guenther wrote:

> On Wed, 3 Aug 2011, Mikael Morin wrote:
> 
> > Hello,
> > 
> > On Wednesday 03 August 2011 15:47:37 Richard Guenther wrote:
> > > Comments?  Any idea why reversing the loop would break?
> > 
> > Yes, the list of scalarized expressions has to be created in the same order 
> > it 
> > is consumed. Here the scalarized expressions are array indexes to be 
> > precomputed out of the loop.
> > The attached patch seems to work (the interesting part is in 
> > gfc_walk_variable_expr).
> 
> Ah, thanks.  I'll work from there to revise the patch.

The following is almost identical to your proposal.

Bootstrapped and tested on x86_64-unknown-linux-gnu, ok for trunk?

Thanks,
Richard.

2011-08-03  Richard Guenther  

PR fortran/49957
* trans-array.c (add_to_offset): New function.
(gfc_conv_array_ref): Build the array index expression in optimally
associated order.
(gfc_walk_variable_expr): Adjust for the backward walk.

* gfortran.dg/vect/O3-pr49957.f: New testcase.

Index: gcc/fortran/trans-array.c
===
--- gcc/fortran/trans-array.c   (revision 177357)
+++ gcc/fortran/trans-array.c   (working copy)
@@ -2622,6 +2622,22 @@ gfc_conv_tmp_array_ref (gfc_se * se)
   gfc_advance_se_ss_chain (se);
 }
 
+/* Add T to the offset pair *OFFSET, *CST_OFFSET.  */
+
+static void
+add_to_offset (tree *cst_offset, tree *offset, tree t)
+{
+  if (TREE_CODE (t) == INTEGER_CST)
+*cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
+  else
+{
+  if (!integer_zerop (*offset))
+   *offset = fold_build2_loc (input_location, PLUS_EXPR,
+  gfc_array_index_type, *offset, t);
+  else
+   *offset = t;
+}
+}
 
 /* Build an array reference.  se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
@@ -2634,7 +2650,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_arr
locus * where)
 {
   int n;
-  tree index;
+  tree offset, cst_offset;
   tree tmp;
   tree stride;
   gfc_se indexse;
@@ -2669,10 +2685,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_arr
   return;
 }
 
-  index = gfc_index_zero_node;
+  cst_offset = offset = gfc_index_zero_node;
+  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
 
-  /* Calculate the offsets from all the dimensions.  */
-  for (n = 0; n < ar->dimen; n++)
+  /* Calculate the offsets from all the dimensions.  Make sure to associate
+ the final offset so that we form a chain of loop invariant summands.  */
+  for (n = ar->dimen - 1; n >= 0; n--)
 {
   /* Calculate the index for this dimension.  */
   gfc_init_se (&indexse, se);
@@ -2741,19 +2759,17 @@ gfc_conv_array_ref (gfc_se * se, gfc_arr
 indexse.expr, stride);
 
   /* And add it to the total.  */
-  index = fold_build2_loc (input_location, PLUS_EXPR,
-  gfc_array_index_type, index, tmp);
+  add_to_offset (&cst_offset, &offset, tmp);
 }
 
-  tmp = gfc_conv_array_offset (se->expr);
-  if (!integer_zerop (tmp))
-index = fold_build2_loc (input_location, PLUS_EXPR,
-gfc_array_index_type, index, tmp);
+  if (!integer_zerop (cst_offset))
+offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, cst_offset);
 
   /* Access the calculated element.  */
   tmp = gfc_conv_array_data (se->expr);
   tmp = build_fold_indirect_ref (tmp);
-  se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
+  se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
 }
 
 
@@ -7575,7 +7591,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc
   switch (ar->type)
{
case AR_ELEMENT:
- for (n = 0; n < ar->dimen + ar->codimen; n++)
+ for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
{
  newss = gfc_get_ss ();
  newss->type = GFC_SS_SCALAR;
Index: gcc/testsuite/gfortran.dg/vect/O3-pr49957.f
===
--- gcc/testsuite/gfortran.dg/vect/O3-pr49957.f (revision 0)
+++ gcc/testsuite/gfortran.dg/vect/O3-pr49957.f (revision 0)
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-require-effective-target vect_double }
+  subroutine shell(nx,ny,nz,q,dq)
+  implicit none
+  integer i,j,k,l,nx,ny,nz
+  real*8 q(5,nx,ny),dq(5,nx,ny)
+ do j=1,ny
+do i=1,nx
+   do l=1,5
+  q(l,i,j)=q(l,i,j)+dq(l,i,j)
+   enddo
+enddo
+ enddo
+  return
+  end
+! { dg-final { scan-tree-dump "vectorized 1 loops" "vect" { xfail 
vect_no_align } } }

Adjust debug output from SMS's get_schdedule_window

[Richard Sandiford]

This patch adjusts the dump output from modulo-sched.c:get_schdedule_window.
Dump output is very much down to personal preference, so please feel free
just to reject the change.

Anyway, the current output for a typical scheduling window looks like this:

---
Processing edge:  [29 -(T,2,1)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 7 (29): the node is not scheduled

Processing edge:  [27 -(O,0,1)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 5 (27): pred st = 4; early_start 
= -8; latency: 0; end: 15

Processing edge:  [25 -(A,0,1)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 4 (25): pred st = 1; early_start 
= -8; latency: 0; end: 12

Processing edge:  [24 -(O,0,1)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 3 (24): pred st = 0; early_start 
= -8; latency: 0; end: 11

Processing edge:  [22 -(A,0,1)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 2 (22): the node is not scheduled

Processing edge:  [18 -(T,3,0)-> 21] 
Scheduling 1 (21) in psp_not_empty, checking p 0 (18): the node is not scheduled

Processing edge: [21 -(O,0,0)-> 40] 
Scheduling 1 (21) in pss_not_empty, checking s 9 (40): the node is not scheduled

Processing edge: [21 -(O,0,0)-> 27] 
Scheduling 1 (21) in pss_not_empty, checking s 5 (27): succ st = 4; late_start =
 4; latency = 0; start=-7
Processing edge: [21 -(T,0,1)-> 25] 
Scheduling 1 (21) in pss_not_empty, checking s 4 (25): succ st = 1; late_start =
 4; latency = 0; start=-7
Processing edge: [21 -(T,0,0)-> 25] 
Scheduling 1 (21) in pss_not_empty, checking s 4 (25): succ st = 1; late_start =
 1; latency = 0; start=-7
Processing edge: [21 -(O,0,0)-> 24] 
Scheduling 1 (21) in pss_not_empty, checking s 3 (24): succ st = 0; late_start =
 0; latency = 0; start=-7
Processing edge: [21 -(T,0,1)-> 22] 
Scheduling 1 (21) in pss_not_empty, checking s 2 (22): the node is not scheduled

Processing edge: [21 -(T,0,0)-> 22] 
Scheduling 1 (21) in pss_not_empty, checking s 2 (22): the node is not scheduled

Processing edge: [21 -(T,0,1)-> 18] 
Scheduling 1 (21) in pss_not_empty, checking s 0 (18): the node is not scheduled

Trying to schedule node 1 INSN = 21  in (0 .. -8) step 


I found this a bit difficult to read for a couple of reasons:

- There's no easy way of telling what the current value of ii is.

- The dump only gives the result of the mininum and maximum operations,
  so it's not always easy to tell what the limit calculated for each
  edge actually was.  E.g., in the output above, it's the first edge
  that sets the eventual early start of -8, so it's not obvious what
  (smaller) values were calculated for the other edges.

The output after the patch is:

---
Analyzing dependencies for node 1 (INSN 21); ii = 12

  start early start  late start end  time
=== === === === =
 -8  15 4 [27 -(O,0,1)-> 21] 
-11  12 1 [25 -(A,0,1)-> 21] 
-12  11 0 [24 -(O,0,1)-> 21] 
 -7   4 4 [21 -(O,0,0)-> 27] 
-10  13 1 [21 -(T,0,1)-> 25] 
-10   1 1 [21 -(T,0,0)-> 25] 
-11   0 0 [21 -(O,0,0)-> 24] 
--- --- --- --- -
 -7  -8   0  11   (max, max, min, min)
 -7   0   final window

Trying to schedule node 1 INSN = 21  in (0 .. -8) step -1
---

Tested in the same way as the previous patch.  OK to install?

Richard


gcc/
* modulo-sched.c (get_sched_window): Use a table for the debug output.
Print the current ii.

Index: gcc/modulo-sched.c
===
--- gcc/modulo-sched.c  2011-08-04 12:03:53.0 +0100
+++ gcc/modulo-sched.c  2011-08-04 12:11:43.0 +0100
@@ -1658,44 +1658,41 @@ get_sched_window (partial_schedule_ptr p
   count_preds = psp_not_empty;
   count_succs = pss_not_empty;
 
+  if (dump_file && (psp_not_empty || pss_not_empty))
+{
+  fprintf (dump_file, "\nAnalyzing dependencies for node %d (INSN %d)"
+  "; ii = %d\n\n", u_node->cuid, INSN_UID (u_node->insn), ii);
+  fprintf (dump_file, "%11s %11s %11s %11s %5s\n",
+  "start", "early start", "late start", "end", "time");
+  fprintf (dump_file, "=== === === ==="
+  " =\n");
+}
   /* Calculate early_start and limit end.  Both bounds are inclusive.  */
   if (psp_not_

Re: [PLUGIN] compile and install gengtype, install gtype.state

[Jakub Jelinek]

On Thu, Aug 04, 2011 at 12:41:05PM +0200, Romain GEISSLER wrote:
> Find attached the final patch. I can't apply it by myself.

Thanks, committed.

Jakub

Re: Adjust debug output from SMS's get_schdedule_window

[Revital1 Eres]

Hello Richard,

> This patch adjusts the dump output from
modulo-sched.c:get_schdedule_window.
> Dump output is very much down to personal preference, so please feel free
> just to reject the change.

The output format looks great to me although I cannot approve it.

Thanks,
Revital

[Ada] Save/restore value of pragma Normalize_Scalars

[Arnaud Charlet]

This patch adds the missing support to the frontend to save and restore
consistently the settings of pragma Normalize_Scalars. Required to have
consistent setting of its value when the compilation of a unit causes
implicit analysis of runtime units. Before applying this patch the
compilation of the following small test caused an assertion
failure in the frontend.

with Ada.Text_IO;
package ImpDef is end;

pragma Normalize_Scalars;
with Impdef;
package CXH1001_0 is end;

Command: gcc -c cxh1001_0.ads

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Javier Miranda  

* opt.ads
(Normalize_Scalars_Config): Value of the configuration switch set by
pragma Normalize_Scalars when it appears in the gnat.adc file.
(Normalize_Scalars): New field for record Config_Switches_Type. Used
to save and restore settings of this pragma.
* opt.adb
(Register_Opt_Config_Switches, Save_Opt_Config_Switches,
Restore_Opt_Config_Switches): Add missing support for Normalize_Scalars.

Index: opt.adb
===
--- opt.adb (revision 177274)
+++ opt.adb (working copy)
@@ -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- --
@@ -59,6 +59,7 @@
   Fast_Math_Config  := Fast_Math;
   Init_Or_Norm_Scalars_Config   := Init_Or_Norm_Scalars;
   Initialize_Scalars_Config := Initialize_Scalars;
+  Normalize_Scalars_Config  := Normalize_Scalars;
   Optimize_Alignment_Config := Optimize_Alignment;
   Persistent_BSS_Mode_Config:= Persistent_BSS_Mode;
   Polling_Required_Config   := Polling_Required;
@@ -93,6 +94,7 @@
   Fast_Math  := Save.Fast_Math;
   Init_Or_Norm_Scalars   := Save.Init_Or_Norm_Scalars;
   Initialize_Scalars := Save.Initialize_Scalars;
+  Normalize_Scalars  := Save.Normalize_Scalars;
   Optimize_Alignment := Save.Optimize_Alignment;
   Optimize_Alignment_Local   := Save.Optimize_Alignment_Local;
   Persistent_BSS_Mode:= Save.Persistent_BSS_Mode;
@@ -122,6 +124,7 @@
   Save.Fast_Math  := Fast_Math;
   Save.Init_Or_Norm_Scalars   := Init_Or_Norm_Scalars;
   Save.Initialize_Scalars := Initialize_Scalars;
+  Save.Normalize_Scalars  := Normalize_Scalars;
   Save.Optimize_Alignment := Optimize_Alignment;
   Save.Optimize_Alignment_Local   := Optimize_Alignment_Local;
   Save.Persistent_BSS_Mode:= Persistent_BSS_Mode;
@@ -189,6 +192,7 @@
  Fast_Math   := Fast_Math_Config;
  Init_Or_Norm_Scalars:= Init_Or_Norm_Scalars_Config;
  Initialize_Scalars  := Initialize_Scalars_Config;
+ Normalize_Scalars   := Normalize_Scalars_Config;
  Optimize_Alignment  := Optimize_Alignment_Config;
  Optimize_Alignment_Local:= False;
  Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
Index: opt.ads
===
--- opt.ads (revision 177356)
+++ opt.ads (working copy)
@@ -1730,6 +1730,13 @@
--  This switch is not set when the pragma appears ahead of a given
--  unit, so it does not affect the compilation of other units.
 
+   Normalize_Scalars_Config : Boolean;
+   --  GNAT
+   --  This is the value of the configuration switch that is set by the
+   --  pragma Normalize_Scalars when it appears in the gnat.adc file.
+   --  This switch is not set when the pragma appears ahead of a given
+   --  unit, so it does not affect the compilation of other units.
+
Optimize_Alignment_Config : Character;
--  GNAT
--  This is the value of the configuration switch that controls the
@@ -1911,6 +1918,7 @@
   Fast_Math  : Boolean;
   Init_Or_Norm_Scalars   : Boolean;
   Initialize_Scalars : Boolean;
+  Normalize_Scalars  : Boolean;
   Optimize_Alignment : Character;
   Optimize_Alignment_Local   : Boolean;
   Persistent_BSS_Mode: Boolean;

[Ada] Fix discrepancy between initialization and finalization of libraries

[Arnaud Charlet]

This adjusts the finalization code emitted in the binder-generated file so as
to make it symmetrical to the initialization code with regard to the handling
of the elaboration counter.  Both now increment or decrement the counter only
once per library unit, even though the elaboration or finalization of the spec
and the body requires two calls.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Eric Botcazou  

* bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate
the header of the finalization routine.
If the unit has no finalizer but is a body whose spec has one, then
generate the decrement of the elaboration entity only.
If the unit has a finalizer and is a spec, then do not generate the
decrement of the elaboration entity.
(Gen_Finalize_Library_C): Likewise.

Index: bindgen.adb
===
--- bindgen.adb (revision 177360)
+++ bindgen.adb (working copy)
@@ -1662,40 +1662,86 @@
   Uspec : Unit_Record;
   Unum  : Unit_Id;
 
+  procedure Gen_Header;
+  --  Generate the header of the finalization routine
+
+  procedure Gen_Header is
+  begin
+ WBI ("   procedure finalize_library is");
+
+ --  The following flag is used to check for library-level
+ --  exceptions raised during finalization. The symbol comes
+ --  from System.Soft_Links. VM targets use regular Ada to
+ --  reference the entity.
+
+ if VM_Target = No_VM then
+WBI ("  LE_Set : Boolean;");
+
+Set_String ("  pragma Import (Ada, LE_Set, ");
+Set_String ("""__gnat_library_exception_set"");");
+Write_Statement_Buffer;
+ end if;
+
+ WBI ("   begin");
+  end Gen_Header;
+
begin
   for E in reverse Elab_Order.First .. Elab_Order.Last loop
  Unum := Elab_Order.Table (E);
  U:= Units.Table (Unum);
 
+ --  Dealing with package bodies is a little complicated. In such
+ --  cases we must retrieve the package spec since it contains the
+ --  spec of the body finalizer.
+
+ if U.Utype = Is_Body then
+Unum  := Unum + 1;
+Uspec := Units.Table (Unum);
+ else
+Uspec := U;
+ end if;
+
+ Get_Name_String (Uspec.Uname);
+
  --  We are only interested in non-generic packages
 
- if U.Unit_Kind = 'p'
-   and then U.Has_Finalizer
-   and then not U.Is_Generic
-   and then not U.SAL_Interface
-   and then not U.No_Elab
- then
-if not Lib_Final_Built then
-   Lib_Final_Built := True;
+ if U.Unit_Kind /= 'p' or else U.Is_Generic then
+null;
 
-   WBI ("   procedure finalize_library is");
+ --  That aren't an interface to a stand alone library
 
-   --  The following flag is used to check for library-level
-   --  exceptions raised during finalization. The symbol comes
-   --  from System.Soft_Links. VM targets use regular Ada to
-   --  reference the entity.
+ elsif U.SAL_Interface then
+null;
 
-   if VM_Target = No_VM then
-  WBI ("  LE_Set : Boolean;");
+ --  Case of no finalization
 
-  Set_String ("  pragma Import (Ada, LE_Set, ");
-  Set_String ("""__gnat_library_exception_set"");");
-  Write_Statement_Buffer;
+ elsif not U.Has_Finalizer then
+
+--  The only case in which we have to do something is if this
+--  is a body, with a separate spec, where the separate spec
+--  has a finalizer. In that case, this is where we decrement
+--  the elaboration entity.
+
+if U.Utype = Is_Body and then Uspec.Has_Finalizer then
+   if not Lib_Final_Built then
+  Gen_Header;
+  Lib_Final_Built := True;
end if;
 
-   WBI ("   begin");
+   Set_String ("  E");
+   Set_Unit_Number (Unum);
+   Set_String (" := E");
+   Set_Unit_Number (Unum);
+   Set_String (" - 1;");
+   Write_Statement_Buffer;
 end if;
 
+ else
+if not Lib_Final_Built then
+   Gen_Header;
+   Lib_Final_Built := True;
+end if;
+
 --  Generate:
 --declare
 --   procedure F;
@@ -1732,19 +1778,6 @@
 Set_Int (Count);
 Set_String (", """);
 
---  Dealing with package bodies is a little complicated. In such
---  cases we must retrieve the package spec since it contains the
---  spec of the body finalizer.
-
-if U.Utype = Is_Body then
-   Unum  :

[Ada] Warning on premature task activation

[Arnaud Charlet]

An allocator for a local task in a package declaration will raise Program_Error
because the elaboration check on the body will fail. THis patch adds a warning 
for
this case.

Compiling the following must yield:

   tasking.ads:6:18: warning: cannot activate task before body seen
   tasking.ads:6:18: warning: Program_Error will be raised at run time

---
package Tasking is
   task type T;

   type T_Ptr is access T;

   TP : T_Ptr := new T;
   TT : T;  --  This is OK
end Tasking;
---
with Text_Io; use Text_IO;
package body Tasking is
   task body T is
   begin
  Put_Line ("Activated");
  null;
   end T;
end Tasking;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_res.adb (Resolve_Allocator): diagnose task allocator that will
raise program_error because body has not been seen yet.

Index: sem_res.adb
===
--- sem_res.adb (revision 177356)
+++ sem_res.adb (working copy)
@@ -4342,6 +4342,21 @@
 Set_Is_Static_Coextension  (N, False);
  end if;
   end if;
+
+  --  Report a simple error:  if the designated object is a local task,
+  --  its body has not been seen yet, and its activation will fail
+  --  an elaboration check.
+
+  if Is_Task_Type (Designated_Type (Typ))
+and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope
+and then Is_Compilation_Unit (Current_Scope)
+and then Ekind (Current_Scope) = E_Package
+and then not In_Package_Body (Current_Scope)
+  then
+ Error_Msg_N
+   ("cannot activate task before body seen?", N);
+ Error_Msg_N ("\Program_Error will be raised at run time", N);
+  end if;
end Resolve_Allocator;
 
---

[Ada] Remote types instance in private part of RCI spec

[Arnaud Charlet]

This change fixes a defect whereby instantiating a Remote_Types unit
specifying user-defined stream attributes for one of its types in the
private part of an RCI unit would cause undefined symbols in calling stubs.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for
instantiation in RCI.

Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 177356)
+++ sem_ch12.adb(working copy)
@@ -3379,18 +3379,18 @@
 end if;
  end;
 
- --  If we are generating calling stubs, we never need a body for an
- --  instantiation from source in the visible part, because in that
- --  case we'll be generating stubs for any subprogram in the instance.
- --  However normal processing occurs for instantiations in generated
- --  code or in the private part, since in those cases we do not
- --  generate stubs.
+ --  Note that we generate the instance body even when generating
+ --  calling stubs for an RCI unit: it may be required e.g. if it
+ --  provides stream attributes for some type used in the profile of a
+ --  remote subprogram. If the instantiation is within the visible part
+ --  of the RCI, then calling stubs for any relevant subprogram will
+ --  be inserted immediately after the subprogram declaration, and
+ --  will take precedence over the subsequent (original) body. (The
+ --  stub and original body will be complete homographs, but this is
+ --  permitted in an instance).
 
- if Distribution_Stub_Mode = Generate_Caller_Stub_Body
-  and then Comes_From_Source (N)
- then
-Needs_Body := False;
- end if;
+ --  Could we do better and remove the original subprogram body in that
+ --  case???
 
  if Needs_Body then
 

Re: [PATCH][RFC] Fix PR49957 - build array index differently

[Mikael Morin]

On Thursday 04 August 2011 13:12:04 Richard Guenther wrote:
> On Thu, 4 Aug 2011, Richard Guenther wrote:
> > On Wed, 3 Aug 2011, Mikael Morin wrote:
> > > Hello,
> > > 
> > > On Wednesday 03 August 2011 15:47:37 Richard Guenther wrote:
> > > > Comments?  Any idea why reversing the loop would break?
> > > 
> > > Yes, the list of scalarized expressions has to be created in the same
> > > order it is consumed. Here the scalarized expressions are array
> > > indexes to be precomputed out of the loop.
> > > The attached patch seems to work (the interesting part is in
> > > gfc_walk_variable_expr).
> > 
> > Ah, thanks.  I'll work from there to revise the patch.
> 
> The following is almost identical to your proposal.
> 
> Bootstrapped and tested on x86_64-unknown-linux-gnu, ok for trunk?
Yes, Thanks.

Mikael

[Ada] Add support for binder/linker in gnatmake in CodePeer mode

[Arnaud Charlet]

In this patch, we enable calls to the binder and linker in gnatmake in
CodePeer mode, to help support e.g. detection of global uninitialized variables
or e.g. environment task race conditions.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Arnaud Charlet  

* make.adb (Do_Codepeer_Globalize_Step): Removed. Use CodePeer_Mode
instead.
(CodePeer_Mode_String): New.
(Linking_Phase, Binding_Phase): Call gnatlink with -P switch in
CodePeer mode.
(Scan_Make_Arg): Do not disable binding/linking phase in CodePeer mode.
* bindgen.adb (Gen_Elab_Calls_Ada): Ignore subprograms in CodePeer
mode, since no useful elaboration subprogram is needed by CodePeer.
* gnatlink.adb (Gnatlink): Add support for -P switch (CodePeer mode).
In this mode, compile binder file with -gnatC and do stop after this
step.

Index: make.adb
===
--- make.adb(revision 177365)
+++ make.adb(working copy)
@@ -386,11 +386,9 @@
--  with the switches -c, -b and -l. These flags are reset to True for
--  each invocation of procedure Gnatmake.
 
-   Do_Codepeer_Globalize_Step : Boolean := False;
-   --  Flag to indicate whether the CodePeer globalizer should be called
-
Shared_String   : aliased String := "-shared";
Force_Elab_Flags_String : aliased String := "-F";
+   CodePeer_Mode_String: aliased String := "-P";
 
No_Shared_Switch : aliased Argument_List := (1 .. 0 => null);
Shared_Switch: aliased Argument_List := (1 => Shared_String'Access);
@@ -2927,7 +2925,7 @@
 then
--  If we compile with -gnatC, enable CodePeer globalize step
 
-   Do_Codepeer_Globalize_Step := True;
+   CodePeer_Mode := True;
 end if;
  end loop;
 
@@ -2968,7 +2966,7 @@
declare
   Str : String renames Args (Arg_Index).all;
begin
-  if Do_Codepeer_Globalize_Step
+  if CodePeer_Mode
 and then Str'Length > 2
 and then Str (Str'First .. Str'First + 1) = "-m"
   then
@@ -4399,7 +4397,13 @@
  end;
   end if;
 
-  --  Add switch -M to gnatlink if buider switch --create-map-file
+  if CodePeer_Mode then
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+   new String'(CodePeer_Mode_String);
+  end if;
+
+  --  Add switch -M to gnatlink if builder switch --create-map-file
   --  has been specified.
 
   if Map_File /= null then
@@ -4560,6 +4564,11 @@
  Args (Last_Arg) := Force_Elab_Flags_String'Access;
   end if;
 
+  if CodePeer_Mode then
+ Last_Arg := Last_Arg + 1;
+ Args (Last_Arg) := CodePeer_Mode_String'Access;
+  end if;
+
   if Main_Project /= No_Project then
 
  --  Put all the source directories in ADA_INCLUDE_PATH,
@@ -6313,10 +6322,9 @@
  end if;
   end loop Multiple_Main_Loop;
 
-  if Do_Codepeer_Globalize_Step then
+  if CodePeer_Mode then
  declare
 Success : Boolean := False;
-
  begin
 Globalize (Success);
 
@@ -7962,10 +7970,15 @@
 Add_Switch (Argv, Compiler, And_Save => And_Save);
 Operating_Mode   := Check_Semantics;
 Check_Object_Consistency := False;
-Compile_Only := True;
-Do_Bind_Step := False;
-Do_Link_Step := False;
 
+if not CodePeer_Mode
+  and then (Argv'Last < 7 or else Argv (7) /= 'C')
+then
+   Compile_Only := True;
+   Do_Bind_Step := False;
+   Do_Link_Step := False;
+end if;
+
  elsif Argv (2 .. Argv'Last) = "nostdlib" then
 
 --  Pass -nstdlib to gnatbind and gnatlink
Index: bindgen.adb
===
--- bindgen.adb (revision 177365)
+++ bindgen.adb (working copy)
@@ -1423,7 +1423,10 @@
 --  The uname_E increment is skipped if this is a separate spec,
 --  since it will be done when we process the body.
 
-else
+--  Ignore subprograms in CodePeer mode, since no useful
+--  elaboration subprogram is needed by CodePeer.
+
+elsif U.Unit_Kind /= 's' or else not CodePeer_Mode then
if Force_Checking_Of_Elaboration_Flags
  or Interface_Library_Unit
  or not Bind_Main_Program
Index: gnatlink.adb
===
--- gnatlink.adb(revision 177274)
+++ gnatlink.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- 

[Ada] Attributes on predicated subtypes

[Arnaud Charlet]

To prevent anomalies with enumeration types with holes and scalar types with
complex predicates, the attributes First, Last, and Range cannot be applied to
subtypes with predicates. This rule applies only to scalar types.

The following must compile quietly in Ada2012 mode:

package Pred is
   type A is array (Integer range <>) of Integer
 with Predicate => (for all J in A'Range =>
  (for all K in A'Range =>
 (if J /= K then A (J) /= A (K;
end Pred;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_attr.adb (Bad_Attribute_For_Predicate): flag illegal use of
attribute only if prefix type is scalar.

Index: sem_attr.adb
===
--- sem_attr.adb(revision 177351)
+++ sem_attr.adb(working copy)
@@ -217,6 +217,8 @@
   --  actual, then the message is a warning, and we generate code to raise
   --  program error with an appropriate reason. No error message is given
   --  for internally generated uses of the attributes.
+  --  The legality rule only applies to scalar types, even though the
+  --  current AI mentions all subtypes.
 
   procedure Check_Array_Or_Scalar_Type;
   --  Common procedure used by First, Last, Range attribute to check
@@ -840,7 +842,9 @@
 
   procedure Bad_Attribute_For_Predicate is
   begin
- if Comes_From_Source (N) then
+ if Is_Scalar_Type (P_Type)
+   and then  Comes_From_Source (N)
+ then
 Error_Msg_Name_1 := Aname;
 Bad_Predicated_Subtype_Use
   ("type& has predicates, attribute % not allowed", N, P_Type);

[Ada] Omit statement SCO for disabled pragma

[Arnaud Charlet]

This change ensures that no statement SCO is emitted for a disabled pragma.

For the following compilation, the CS line shall contain only one entry
(for the assignment statement), and no entry for the (disabled) pragma Assert.

$ gcc -c -gnateS plop.adb
$ grep ^C plop.ali
C 1 plop.adb
CS 8:4-8:15

and when using -gnata, a P statement entry shall be generated, and in addition
a CP decision line:

$ gcc -c -gnateS -gnata plop.adb
$ grep ^C plop.ali
C 3 plop.adb
CS P7:4-7:28 8:4-8:15
CP 7:4 c7:19-7:28

procedure Plop
  (X, Y : Integer;
   Sum  : out Integer;
   UB   : Integer)
is
begin
   pragma Assert (X + Y <= UB);
   Sum := X + Y; 
end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* par_sco.adb (Traverse_Declarations_Or_Statements.Set_Statement_Entry):
For a pragma (statement with C1 = 'P'), record the sloc of the pragma.
* scos.ads: Update documentation accordingly.
* put_scos.adb (Output_SCO_Line): Omit statement SCOs for disabled
pragmas.

Index: par_sco.adb
===
--- par_sco.adb (revision 177351)
+++ par_sco.adb (working copy)
@@ -765,7 +765,10 @@
 
   Index := Condition_Pragma_Hash_Table.Get (Loc);
 
-  --  The test here for zero is to deal with possible previous errors
+  --  The test here for zero is to deal with possible previous errors, and
+  --  for the case of pragma statement SCOs, for which we always set the
+  --  Pragma_Sloc even if the particular pragma cannot be specifically
+  --  disabled.
 
   if Index /= 0 then
  pragma Assert (SCO_Table.Table (Index).C1 = 'P');
@@ -1071,14 +1074,23 @@
 end if;
 
 declare
-   SCE : SC_Entry renames SC.Table (J);
+   SCE : SC_Entry renames SC.Table (J);
+   Pragma_Sloc : Source_Ptr := No_Location;
 begin
+   --  For the statement SCO for a pragma, set Pragma_Sloc so that
+   --  the SCO can be omitted if the pragma is disabled.
+
+   if SCE.Typ = 'P' then
+  Pragma_Sloc := SCE.From;
+   end if;
+
Set_Table_Entry
- (C1   => C1,
-  C2   => SCE.Typ,
-  From => SCE.From,
-  To   => SCE.To,
-  Last => (J = SC_Last));
+ (C1  => C1,
+  C2  => SCE.Typ,
+  From=> SCE.From,
+  To  => SCE.To,
+  Last=> (J = SC_Last),
+  Pragma_Sloc => Pragma_Sloc);
 end;
  end loop;
 
Index: scos.ads
===
--- scos.ads(revision 177347)
+++ scos.ads(working copy)
@@ -355,8 +355,9 @@
   Last : Boolean;
 
   Pragma_Sloc : Source_Ptr := No_Location;
-  --  For a SCO nested with a pragma Debug/Assert/PPC, location of pragma
-  --  (used for control of SCO output, value not recorded in ALI file).
+  --  For the statement SCO for a pragma, or for any expression SCO nested
+  --  in a pragma Debug/Assert/PPC, location of PRAGMA token (used for
+  --  control of SCO output, value not recorded in ALI file).
end record;
 
package SCO_Table is new GNAT.Table (
Index: put_scos.adb
===
--- put_scos.adb(revision 177347)
+++ put_scos.adb(working copy)
@@ -95,7 +95,8 @@
 pragma Assert (Start <= Stop);
 
 Output_SCO_Line : declare
-   T : SCO_Table_Entry renames SCO_Table.Table (Start);
+   T: SCO_Table_Entry renames SCO_Table.Table (Start);
+   Continuation : Boolean;
 
 begin
case T.C1 is
@@ -103,11 +104,26 @@
   --  Statements
 
   when 'S' =>
- Write_Info_Initiate ('C');
- Write_Info_Char ('S');
-
  Ctr := 0;
+ Continuation := False;
  loop
+if SCO_Table.Table (Start).C2 = 'P'
+ and then SCO_Pragma_Disabled
+(SCO_Table.Table (Start).Pragma_Sloc)
+then
+   goto Next_Statement;
+end if;
+
+if Ctr = 0 then
+   Write_Info_Initiate ('C');
+   if not Continuation then
+  Write_Info_Char ('S');
+  Continuation := True;
+   else
+  Write_Info_Char ('s');
+   end if;
+end if;
+
 Write_Info_Char (' ');
 
 

Re: Adjust debug output from SMS's get_schdedule_window

[Bernd Schmidt]

On 08/04/11 13:16, Richard Sandiford wrote:
> Tested in the same way as the previous patch.  OK to install?

You don't actually need to ask, and based on Revital's reaction, yes.


Bernd

[Ada] Change error message in Ada 2012 mode for misplaced "if" and "case"

[Arnaud Charlet]

GNAT was issuing a wrong message about a missing operand in some cases of
ill-parenthesized code in Ada 2012 mode. Now it issues a correct message about
the missing parentheses.

On the following code we get:

$ gcc -c -gnat2012 -gnaty3 pred.ads

pred.ads:5:30: conditional expression must be parenthesized
pred.ads:8:08: case expression must be parenthesized

---
package Pred is
   type A is array (Integer range <>) of Integer
 with Predicate => (for all J in A'Range =>
  (for all K in A'Range =>
 if J /= K then A (J) /= A (K)));
   function F (X : Integer) return Integer
 with Post =>
   case X is when 0 => F'Result > 0,
 when others => F'Result = 0;
end Pred;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* par-ch4.adb (P_Primary): preferentially issue an error message about
a missing parenthesis arount a conditional or case expression in Ada
2012 mode, if we detect that the alignment is not correct for a
statement.

Index: par-ch4.adb
===
--- par-ch4.adb (revision 177275)
+++ par-ch4.adb (working copy)
@@ -2445,9 +2445,16 @@
 
--  If this looks like a real if, defined as an IF appearing at
--  the start of a new line, then we consider we have a missing
-   --  operand.
+   --  operand. If in Ada 2012 and the IF is not properly indented
+   --  for a statement, we prefer to issue a message about an ill-
+   --  parenthesized conditional expression.
 
-   if Token_Is_At_Start_Of_Line then
+   if Token_Is_At_Start_Of_Line
+ and then not
+   (Ada_Version >= Ada_2012
+ and then Style_Check_Indentation /= 0
+ and then Start_Column rem Style_Check_Indentation /= 0)
+   then
   Error_Msg_AP ("missing operand");
   return Error;
 
@@ -2471,9 +2478,16 @@
 
--  If this looks like a real case, defined as a CASE appearing
--  the start of a new line, then we consider we have a missing
-   --  operand.
+   --  operand. If in Ada 2012 and the CASE is not properly
+   --  indented for a statement, we prefer to issue a message about
+   --  an ill-parenthesized case expression.
 
-   if Token_Is_At_Start_Of_Line then
+   if Token_Is_At_Start_Of_Line
+ and then not
+   (Ada_Version >= Ada_2012
+ and then Style_Check_Indentation /= 0
+ and then Start_Column rem Style_Check_Indentation /= 0)
+   then
   Error_Msg_AP ("missing operand");
   return Error;
 

[Ada] Correct order of evaluation of pre- and postcondition

[Arnaud Charlet]

GNAT was evaluating the right part of an AND-THEN pre- or postcondition before
the left part, which could cause a wrong exception to be raised in case of a
failing pre- or postcondition.

On the code attached, compiling and executing now raises a precondition
failure instead of a division by zero:

$ gcc -c -gnat2012 -gnata main.adb
$ gnatbind -x main.ali
$ gnatlink main.ali
$ ./main

raised SYSTEM.ASSERTIONS.ASSERT_FAILURE : failed precondition from check.ads:3

---
package Check is
   function Div (X : Integer) return Integer
  with Pre  => (X /= 0 and then 1/X > 0),
   Post => (Div'Result > 0);
end Check;
---
package body Check is
   function Div (X : Integer) return Integer is
   begin
  return X;
   end Div;
end Check;
---
with Check;
procedure Main is
   X : Integer;
begin
   X := Check.Div (0);
end Main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_ch13.adb (Analyze_Aspect_Specifications): correct order in which
the left-hand-side and right-hand-side of a conjunct are inserted when
translating a pre- or postcondition
* sem_ch6.adb: Correct typo in comment

Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 177353)
+++ sem_ch6.adb (working copy)
@@ -9189,8 +9189,8 @@
--  will be executed at the start of the procedure. Note that
--  this processing reverses the order of the list, which is
--  what we want since new entries were chained to the head of
-   --  the list. There can be more then one precondition when we
-   --  use pragma Precondition
+   --  the list. There can be more than one precondition when we
+   --  use pragma Precondition.
 
if not Class_Present (Prag) then
   Prepend (Grab_PPC, Declarations (N));
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 177344)
+++ sem_ch13.adb(working copy)
@@ -1086,6 +1086,12 @@
   --  we generate separate Pre/Post aspects for the separate
   --  clauses. Since we allow multiple pragmas, there is no
   --  problem in allowing multiple Pre/Post aspects internally.
+  --  These should be treated in reverse order (B first and
+  --  A second) since they are later inserted just after N in
+  --  the order they are treated. This way, the pragma for A
+  --  ends up preceding the pragma for B, which may have an
+  --  importance for the error raised (either constraint error
+  --  or precondition error).
 
   --  We do not do this for Pre'Class, since we have to put
   --  these conditions together in a complex OR expression
@@ -1095,12 +1101,12 @@
   then
  while Nkind (Expr) = N_And_Then loop
 Insert_After (Aspect,
-  Make_Aspect_Specification (Sloc (Right_Opnd (Expr)),
+  Make_Aspect_Specification (Sloc (Left_Opnd (Expr)),
 Identifier=> Identifier (Aspect),
-Expression=> Relocate_Node (Right_Opnd (Expr)),
+Expression=> Relocate_Node (Left_Opnd (Expr)),
 Class_Present => Class_Present (Aspect),
 Split_PPC => True));
-Rewrite (Expr, Relocate_Node (Left_Opnd (Expr)));
+Rewrite (Expr, Relocate_Node (Right_Opnd (Expr)));
 Eloc := Sloc (Expr);
  end loop;
   end if;

Re: [PLUGIN] compile and install gengtype, install gtype.state

[Richard Guenther]

On Thu, Aug 4, 2011 at 1:31 PM, Jakub Jelinek  wrote:
> On Thu, Aug 04, 2011 at 12:41:05PM +0200, Romain GEISSLER wrote:
>> Find attached the final patch. I can't apply it by myself.
>
> Thanks, committed.

This breaks bootstrap with a ./contrib/gcc_update updated tree because
gengtype-state.c cannot parse

(!version  "4.7.0 20110804 (experimental) [trunk revision 161655]")

please fix.

>        Jakub
>

Re: PATCH: Add a testase for PR middle-end/47383

[H.J. Lu]

On Thu, Aug 4, 2011 at 2:07 AM, Kirill Yukhin  wrote:
> HJ, are you sure your Changlog entry is OK?
>

It was fixed.


-- 
H.J.

Re: [Patch, Fortran] (Coarray) Fix constraint checks for LOCK_TYPE

[Mikael Morin]

On Wednesday 03 August 2011 17:55:00 Tobias Burnus wrote:
> > Though variables in the general case can be components, I don't think it
> > is the case here as only named variables are involved here.
> > Does that sound right?
> 
> The first part of the sentence sounds wrong: A component itself is not a
> variable. I think you mean a "structure-component" - and for "var%comp"
> both "var%comp" and "var" are variables
Yes, OK

> and I belief both "var%comp" and
> "var" are named.
My reading is that a named variable is a variable that is an object-name.
But either is fine w.r.t. your patch.

> 
> "R602 variable is designator or expr"
> "R601 designator is object-name or ... or structure-component"
> "R613 structure-component is data-ref"
> "R611 data-ref is part-ref [ % part-ref ]"
> "R612 part-ref is part-name [ ( section-subscript-list ) ] [
> image-selector ]"
> 

[...]
> 
> The question is: Should we bother? Is there some genuine interest in
> supporting valid but unusable type declarations? 
OK, I'm starting to understand the patch.

> The problem is that
> diagnosing the problem can get rather difficult. For instance:
> 
> type t
> type(lock_type) :: C
> end type
> type t2
> type(t), allocatable :: B
> end type t2
> type t3
> type(t2) :: D
> end type t3
> 
> is valid - however, it is invalid to use:
> type(t) :: x[*], y
> 
> However, how to write then the error message? "Error: Invalid
> declaration at (1) as constraint C642 is violated" is probably not very
> helpful, but should one really re-resolve the derived type?
I would write:
Variable at  shall be a coarray/have a codimension attribute as it has a 
non-coarray subcomponent of type LOCK_TYPE at 

Best would be to have the full reference y%d%b%c in the error message. 

> There are
> also many possible solutions:
> 
> "B" should be a coarray, "C" could be also allocatable and a coarray, or
> "B" could be not allocatable and "D" or "y" could be a coarray.
> 
> Thus, writing a nice and helpful message gets pretty complicated.
Thus, we should stick closely to the standard, point exactly what is 
prohibited, and not bother too much trying to provide some hints to the users. 
;-)

> And, as written, I do not see a compelling reason for not diagnosing it at
> type-declaration time - even if the type is formally correct.
Well, OK, but we should precise exactly why we reject it then.

> 
> 
> Regarding the check itself - if one assumes that one wants to have an
> error, I believe that part is correct. If there is a pointer, it cannot
> be valid. Example 1:
> 
> type t
> type(lock_type), pointer :: lock1
> end type t
> 
> I cannot write "lock1[:]" as in components, only allocatables are allowed:
> 
> "C442 (R436) If a coarray-spec appears, it shall be a
> deferred-coshape-spec-list and the component shall have the ALLOCATABLE
> attribute."
> 
> Turning the variable into a coarray as in
> type(t) :: x[*]
> does not help: the x%lock1 is not a coarray. "A subobject of a coarray
> is a coarray if it does not have any cosubscripts, vector subscripts,
> allocatable component selection, or pointer component selection." (Sect.
> 2.4.7)
> 
> On the other hand, if "type t" contains a noncoarray lock_type, one
> cannot do use "type(t), pointer :: ptrcomp" as "...%ptrcomp%lock"
> wouldn't be a coarray (cf. above) - and if "lock" in "...%ptrcomp%lock"
> were a coarray, it would be invalid as: "C444 A data component whose
> type has a coarray ultimate component shall be a nonpointer
> nonallocatable scalar and shall not be a coarray."
OK, it is starting to make sense now.
I'm not very fond of it, but if you want to keep this diagnostic, at the very 
least put all that information in a comment. Best would be to provide it (or 
some of it) in the error message too.

Currently there is a comment indicating that we check C1302. Fine.
One looks at C1302: OK, if a component is like that, that constraint on the 
variable. Fine. The error's on variables, and there is neither allocatable nor 
pointer crazy stuff.
One looks at the code then:
if (pointer)
  error ("Component blah pointer blah")

if (allocatable)
  error ("Component blah allocatable blah")

What the fuck?
Back to the standard then, is it a typo?
Check C3102, C1320, C1032. Nothing...
Err?

So, please make it explicit why you reject pointer, etc...

> 
> 
> Having said that, I just realized that the following program is not
> rejected but it should:
That's exactly the reason why I don't like it.
It's sufficiently difficult to get it right while sticking closely to the 
standard that one doesn't want to try picking one rule every 40 pages and see 
what is left after intersecting them.

[...]
> Here, something similar applies:
> 
> type t
> integer, allocatable :: caf_comp[:]
> type(lock_type) :: lock
> end type t
> type(t) :: x[*]
> 
> It is invalid to make "x" a coarray as "t" already has coarray
> components - but if I don't make "x" a coarray, x%lock is not a coarray,
> which is invalid.
Again, make it explicit in t

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Gabriel Dos Reis]

On Wed, Aug 3, 2011 at 1:14 PM, Jason Merrill  wrote:
> On 08/03/2011 08:46 AM, Richard Guenther wrote:
>>
>> If that's reasonable then adding the malloc attribute should be, too.
>> Finally.  Please.  Doesn't C++0x maybe "fix" the issue we were
>> discussing to death?
>
> Nope, as far as I can tell nobody raised it with the committee.  I have now.
>
> I think we ought to be able to assume that a program which accesses the
> allocated storage other than through the returned pointer has undefined
> behavior.

Hmm, how do you define "other than the returned pointer"?  Do you intend
to rule out garbage collectors?  Should not access as raw memory (e.g. through
char* or void*) be allowed?

> I think that would be enough for attribute malloc, and I don't
> think that would interfere with reasonable pool allocators.

I agree we ought to have a form of guarantee a la malloc attribute.

[Ada] Get rid of break_start

[Arnaud Charlet]

This could be used by the debugger to stop the execution before starting
the main subprogram, but no debugger use it.

No testcase as there is no functionnal change.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Tristan Gingold  

* bindgen.adb: Remove code the reference or create the
Break_Start/__gnat_break_start procedure.
* s-stalib.adb (Break_Start): Removed.

Index: bindgen.adb
===
--- bindgen.adb (revision 177366)
+++ bindgen.adb (working copy)
@@ -2301,7 +2301,6 @@
   WBI ("  " & Ada_Init_Name.all & ";");
 
   if not No_Main_Subprogram then
- WBI ("  Break_Start;");
 
  if CodePeer_Mode then
 
@@ -2477,7 +2476,6 @@
   WBI ("   " & Ada_Init_Name.all & " ();");
 
   if not No_Main_Subprogram then
- WBI ("   __gnat_break_start ();");
 
  --  Output main program name
 
@@ -3059,21 +3057,8 @@
 
   if Bind_Main_Program and then VM_Target = No_VM then
 
- --  If we have the standard library, then Break_Start is defined
- --  there, but when the standard library is suppressed, Break_Start
- --  is defined here.
-
  WBI ("");
- WBI ("   procedure Break_Start;");
 
- if Suppress_Standard_Library_On_Target then
-WBI ("   pragma Export (C, Break_Start, ""__gnat_break_start"");");
- else
-WBI ("   pragma Import (C, Break_Start, ""__gnat_break_start"");");
- end if;
-
- WBI ("");
-
  if Exit_Status_Supported_On_Target then
 Set_String ("   function ");
  else
@@ -3232,18 +3217,6 @@
   Gen_Adainit_Ada;
 
   if Bind_Main_Program and then VM_Target = No_VM then
-
- --  When suppressing the standard library then generate dummy body
- --  for Break_Start
-
- if Suppress_Standard_Library_On_Target then
-WBI ("");
-WBI ("   procedure Break_Start is");
-WBI ("   begin");
-WBI ("  null;");
-WBI ("   end;");
- end if;
-
  Gen_Main_Ada;
   end if;
 
@@ -3321,7 +3294,6 @@
 WBI ("extern void exit (int);");
  end if;
 
- WBI ("extern void __gnat_break_start (void);");
  Set_String ("extern ");
 
  if ALIs.Table (ALIs.First).Main_Program = Proc then
@@ -3417,14 +3389,6 @@
  WBI ("");
   end if;
 
-  --  When suppressing the standard library, the __gnat_break_start routine
-  --  (for the debugger to get initial control) is defined in this file.
-
-  if Suppress_Standard_Library_On_Target then
- WBI ("void __gnat_break_start (void) {}");
- WBI ("");
-  end if;
-
   --  Generate the __gnat_version and __gnat_ada_main_program_name info
   --  only for the main program. Otherwise, it can lead under some
   --  circumstances to a symbol duplication during the link (for instance
Index: s-stalib.adb
===
--- s-stalib.adb(revision 177274)
+++ s-stalib.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- B o d y  --
 --  --
---  Copyright (C) 1995-2009, Free Software Foundation, Inc. --
+--  Copyright (C) 1995-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- --
@@ -94,7 +94,8 @@
pragma Export (C, Break_Start, "__gnat_break_start");
--  This is a dummy procedure that is called at the start of execution.
--  Its sole purpose is to provide a well defined point for the placement
-   --  of a main program breakpoint.
+   --  of a main program breakpoint. This is not used anymore but kept for
+   --  bootstrapping issues (still referenced by old gnatbind generated files).
 
procedure Break_Start is
begin

Re: [PLUGIN] compile and install gengtype, install gtype.state

[Richard Guenther]

On Thu, Aug 4, 2011 at 2:30 PM, Richard Guenther
 wrote:
> On Thu, Aug 4, 2011 at 1:31 PM, Jakub Jelinek  wrote:
>> On Thu, Aug 04, 2011 at 12:41:05PM +0200, Romain GEISSLER wrote:
>>> Find attached the final patch. I can't apply it by myself.
>>
>> Thanks, committed.
>
> This breaks bootstrap with a ./contrib/gcc_update updated tree because
> gengtype-state.c cannot parse
>
> (!version  "4.7.0 20110804 (experimental) [trunk revision 161655]")
>
> please fix.

False alarm - I was confused by seeing libstdc++ build.  The above is
caused by a local VRP patch of mine.

Richard.

>>        Jakub
>>
>

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Richard Guenther]

On Thu, Aug 4, 2011 at 2:58 PM, Gabriel Dos Reis
 wrote:
> On Wed, Aug 3, 2011 at 1:14 PM, Jason Merrill  wrote:
>> On 08/03/2011 08:46 AM, Richard Guenther wrote:
>>>
>>> If that's reasonable then adding the malloc attribute should be, too.
>>> Finally.  Please.  Doesn't C++0x maybe "fix" the issue we were
>>> discussing to death?
>>
>> Nope, as far as I can tell nobody raised it with the committee.  I have now.
>>
>> I think we ought to be able to assume that a program which accesses the
>> allocated storage other than through the returned pointer has undefined
>> behavior.
>
> Hmm, how do you define "other than the returned pointer"?  Do you intend
> to rule out garbage collectors?  Should not access as raw memory (e.g. through
> char* or void*) be allowed?

No.  But "other than the returned pointer" should probably
"other than through a pointer derived from the returned pointer".

>> I think that would be enough for attribute malloc, and I don't
>> think that would interfere with reasonable pool allocators.
>
> I agree we ought to have a form of guarantee a la malloc attribute.

Indeed.  Otherwise we depend too much on TBAA with all its C++ issues.

Richard.

[Ada] Avoid the use of floating point in the front end

[Arnaud Charlet]

There was one use of floating point in the front end, in a function
to estimate the equivalent decimal exponent for a universal real.
While this use was probably OK, because a different estimate
shouldn't affect compilation results, in general we do not want
anything in the compiler that may produce different results
depending on the host system.

The easiest way to achieve that goal is avoiding floating point
arithmetic.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Geert Bosch  

* urealp.adb (Equivalent_Decimal_Exponent): Avoid the use of floating
point.

Index: urealp.adb
===
--- urealp.adb  (revision 177274)
+++ urealp.adb  (working copy)
@@ -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- --
@@ -128,7 +128,7 @@
--  U is a Ureal entry for which the base value is non-zero, the value
--  returned is the equivalent decimal exponent value, i.e. the value of
--  Den, adjusted as though the base were base 10. The value is rounded
-   --  to the nearest integer, and so can be one off.
+   --  toward zero (truncated), and so its value can be off by one.
 
function Is_Integer (Num, Den : Uint) return Boolean;
--  Return true if the real quotient of Num / Den is an integer value
@@ -244,29 +244,48 @@
 
function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
 
-  --  The following table is a table of logs to the base 10
+  type Ratio is record
+ Num : Nat;
+ Den : Nat;
+  end record;
 
-  Logs : constant array (Nat range 1 .. 16) of Long_Float := (
-1 => 0.000,
-2 => 0.301029995663981,
-3 => 0.477121254719662,
-4 => 0.602059991327962,
-5 => 0.698970004336019,
-6 => 0.778151250383644,
-7 => 0.845098040014257,
-8 => 0.903089986991944,
-9 => 0.954242509439325,
-   10 => 1.000,
-   11 => 1.041392685158230,
-   12 => 1.079181246047620,
-   13 => 1.113943352306840,
-   14 => 1.146128035678240,
-   15 => 1.176091259055680,
-   16 => 1.204119982655920);
+  --  The following table is a table of logs to the base 10. All values
+  --  have at least 15 digits of precision, and do not exceed the true
+  --  value. To avoid the use of floating point, and as a result potential
+  --  target dependency, each entry is represented as a fraction of two
+  --  integers.
 
+  Logs : constant array (Nat range 1 .. 16) of Ratio :=
+(1 => (Num =>   0, Den =>1),  -- 0
+ 2 => (Num =>  15_392_313, Den =>   51_132_157),  -- 0.301029995663981
+ 3 => (Num => 731_111_920, Den => 1532_339_867),  -- 0.477121254719662
+ 4 => (Num =>  30_784_626, Den =>   51_132_157),  -- 0.602059991327962
+ 5 => (Num => 111_488_153, Den =>  159_503_487),  -- 0.698970004336018
+ 6 => (Num =>  84_253_929, Den =>  108_274_489),  -- 0.778151250383643
+ 7 => (Num =>  35_275_468, Den =>   41_741_273),  -- 0.845098040014256
+ 8 => (Num =>  46_176_939, Den =>   51_132_157),  -- 0.903089986991943
+ 9 => (Num => 417_620_173, Den =>  437_645_744),  -- 0.954242509439324
+10 => (Num =>   1, Den =>1),  -- 1.000
+11 => (Num => 136_507_510, Den =>  131_081_687),  -- 1.041392685158225
+12 => (Num =>  26_797_783, Den =>   24_831_587),  -- 1.079181246047624
+13 => (Num =>  73_333_297, Den =>   65_832_160),  -- 1.113943352306836
+14 => (Num => 102_941_258, Den =>   89_816_543),  -- 1.146128035678238
+15 => (Num =>  53_385_559, Den =>   45_392_361),  -- 1.176091259055681
+16 => (Num =>  78_897_839, Den =>   65_523_237)); -- 1.204119982655924
+
+  function Scale (X : Int; R : Ratio) return Int;
+  --  Compute the value of X scaled by R
+
+  function Scale (X : Int; R : Ratio) return Int is
+ type Wide_Int is range -2**63 .. 2**63 - 1;
+
+  begin
+ return Int (Wide_Int (X) * Wide_Int (R.Num) / Wide_Int (R.Den));
+  end Scale;
+
begin
   pragma Assert (U.Rbase /= 0);
-  return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
+  

[Ada] In ALFA mode, do not generate fully qualified names in frontend

[Arnaud Charlet]

ALFA mode is for formal verification, which needs to postpone full name
qualification after some processing.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* frontend.adb (Frontend): only qualify names in non-ALFA mode

Index: frontend.adb
===
--- frontend.adb(revision 177274)
+++ frontend.adb(working copy)
@@ -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- --
@@ -370,11 +370,13 @@
end if;
 
--  Qualify all entity names in inner packages, package bodies, etc.,
-   --  except when compiling for the VM back-ends, which depend on
-   --  having unqualified names in certain cases and handles the
-   --  generation of qualified names when needed.
+   --  except when compiling for the VM back-ends, which depend on having
+   --  unqualified names in certain cases and handles the generation of
+   --  qualified names when needed, and when compiling for formal verification,
+   --  in which the back-end calls directly Qualify_All_Entity_Names after some
+   --  preprocessing which uses the non-qualified names.
 
-   if VM_Target = No_VM then
+   if VM_Target = No_VM and then not ALFA_Mode then
   Exp_Dbug.Qualify_All_Entity_Names;
end if;
 

[Ada] Name resolution of class-wide operations with prefix notation

[Arnaud Charlet]

When resolving a prefixed call with class-wide actuals, we iterate over the
class-wide operations of all ancestors of the controlling type. If the context
is a function call any overloading is resolved by context. if the context is
a procedure call there must be only one candidate interpretation, and functions
must be excluded from the list of candidates.

The following must compile quietly:
---
with P;
procedure Test is
   A : P.T;
begin
   if A.X then
  A.X;
   end if;
end Test;
---
package P is
   type T is tagged null record;

   function X (Self : T'Class) return Boolean;

   procedure X (Self : T'Class);
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_ch4.adb (Try_Class_Wide_Operation): if the context is a procedure
call, ignore functions.

Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 177353)
+++ sem_ch4.adb (working copy)
@@ -6866,6 +6866,16 @@
   (Designated_Type (Etype (First_Formal (Hom =
Cls_Type))
then
+  --  If the context is a procedure call, ignore functions
+  --  in the name of the call.
+
+  if Ekind (Hom) = E_Function
+and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+and then N = Name (Parent (N))
+  then
+ goto Next_Hom;
+  end if;
+
   Set_Etype (Call_Node, Any_Type);
   Set_Is_Overloaded (Call_Node, False);
   Success := False;
@@ -6907,7 +6917,8 @@
   end if;
end if;
 
-   Hom := Homonym (Hom);
+   <>
+  Hom := Homonym (Hom);
 end loop;
  end Traverse_Homonyms;
 

Re: [patch tree-optimization]: Improve reassociation pass for bitwise-operations

[Michael Matz]

Hi,

On Wed, 3 Aug 2011, Kai Tietz wrote:

> >> This machinery doen't work in this case
> >
> > That's why you have to extend it.
> 
> The issue about this machinery is that it assumes that the statement 
> itself gets transformed, but for normalized form of invert of bitwise 
> operations it is essential to perform invert operation on the operands, 
> too.

Yes, and that is what break_up_subtract_bb and friends do for negates.  In 
particular if the defining statement is of the right type itself (right 
now simply a PLUS) it propagates the negate into the operands of that 
operation.  Extend it to handle AND/IOR/NOT and you're a step further.

> >> Eg: the case (~(a | c) & (b & ~d))  would be expanded (by code in
> >> patch) to ~a & ~c & b & ~d.
> >
> > That's what I mean with better handling of mixed chains.  -(a+b) is
> > already (sometimes) rewritten into -a + -b (see negate_value).  That's
> > just slightly different from rewriting ~(a|b) into ~a & ~b.
> 
> Yes, it affects just one operand.

No, it doesn't.

> And its weakness is that a (which might be a more complex statement) 
> doesn't get folded for the negate operation here.  Eg.  a = 1 - d; c = - 
> (a + b); should become d - b - 1 and optimized form of (d - (b + 1)).

The folding you're talking about is done by undistribute_ops_list, 
optimize_ops_list and repropagate_negates.

I'm asking you to follow the same general scheme of tree-ssa-reassoc which 
is:
1) enabling transformations to make collecting operands easier
   (this possibly changes and adds statements, that's the breakup_subtract
   things)
2) collect operands of operation chains
   (this would sometimes require remembering some context like top
   level and second level operation in your case)
3) optimize that list of operands
4) transform this list into statements again
5) undo transformations done in 1) if they turned out to be
   unprofitable

I'm fairly certain that the transformations you want can be done with this 
scheme.

In particular (as said multiple times) you are missing step (5) even 
though you unconditionally do step (1).  And you don't do steps 2-4 at 
all.

> But AFAIR the code the thing is different what break_up_substract does.  
> It modifies (a - b) -> a + (-b), which is for sure worth to simplify and 
> ease arithmetic plus optimization.  But doesn't match the point you are 
> talking about.

I'm not sure what you think my point is.  It is: reuse existing schemes to 
do things, extending them as necessary to support your usecases.


> As I tried to pointed out before is the approach in reassoc only well
> working for single statements

That's completely wrong.  reassoc was precisely implemented to handle a 
chain of arithmetic operations, i.e. multiple statements.

> But for an invert the operands and the expression-codes are changing,
> too.

Right, that's why you (possibly) might want to handle chains of mixing 
AND/IOR operations, though I don't see those happening in your testcases.  
After the negates are folded into atomics (i.e. negates of AND and IOR are 
folded into operands) you always have a chain of either AND or IOR (with 
the atomics being negated or not).  That can trivially be handled with the 
currently implemented scheme.

> As later reassoc pass just walk the tree and combines simliar
> operation-codes in its vector by rank, and later optimization just
> happens within this range,  it is essential to feed this vector with
> proper (normalized) expression-codes.

That's step (1) above, and for arithmetics done by break_up_subtract.

> Actually it might be also a way to rewrite reassociation pass in a way
> that it just operates on normalized predicated trees made out of the
> orignal tree.  Operates on it, and then write it out in a denormalized
> form.  Such a tree would need information flags for inverted, negated,
> code, operands (maybe also altered), Which means that such a tree gets
> easily more complex.

Right, but ultimately it's the way forward.  Though, as I said, right now 
your testcase only have one common reducing operation.

> Nevertheless the creation of final result out of a normalized
> predicated tree would mean a re-write of tree anyway - even if there
> might be in some rare cases the opportunity to reuse present
> statements and avoid their rewriting.

The reusing of statements in tree-reassoc is merely an artifact, it's not 
an inherent design decision.


Ciao,
Michael.

[Ada] Extending library projects with no sources does not build

[Arnaud Charlet]

If a library project extending another one has no sources of its own,
and there is an exception name with capital letters in the project
being extended, then on platform with case-insensitive file names
(such a Windows, Darwin or VMS), the invocation of gnatmake to build
the library will fail.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Vincent Celier  

* prj-env.adb (For_All_Source_Dirs.For_Project): Check if project Prj
has Ada sources, not project Project, because if the root project
Project has no sources of its own, all projects will be deemed without
sources.

Index: prj-env.adb
===
--- prj-env.adb (revision 177367)
+++ prj-env.adb (working copy)
@@ -1281,7 +1281,7 @@
  --  If there are Ada sources, call action with the name of every
  --  source directory.
 
- if Has_Ada_Sources (Project) then
+ if Has_Ada_Sources (Prj) then
 while Current /= Nil_String loop
The_String := In_Tree.Shared.String_Elements.Table (Current);
Action (Get_Name_String (The_String.Display_Value));

[Ada] AI05-0115: aggregates with invisible components.

[Arnaud Charlet]

If a type has an ancestor derived from a private view of its parent, the
type may have invisible components and aggregates cannot be written for it.
This is an Ada2012 binding interpretation.

Compilation of pak1-pak3.adb below must yield:

   predicatek1-pak3.adb:6:15:
 no selector "C1" for type "T3" defined at pak1-pak3.ads:3
   pak1-pak3.adb:7:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:7:14: must use extension aggregate
   pak1-pak3.adb:8:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:8:14: must use extension aggregate
   pak1-pak3.adb:9:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:9:14: must use extension aggregate

---
package Pak1 is
type T1 is tagged private;
private
type T1 is tagged record
C1 : Integer;
end record;
end Pak1;
---
with Pak1;
package Pak2 is
type T2 is new Pak1.T1 with record
C2 : Integer;
end record;
end Pak2;
---
with Pak2;
package Pak1.Pak3 is
type T3 is new Pak2.T2 with record
C3 : Integer;
end record;
procedure Foo;
end Pak1.Pak3;
---
package body Pak1.Pak3 is
procedure Foo is
R : T3;
N : Integer;
begin
N := R.C1;-- (A: Error.)
R := (C1 => 1, C2 => 2, C3 => 3); -- (B: Legal? No.)
R := (C2 => 2, C3 => 3, others => 1); -- (C: Legal? No.)
R := (others => 4);   -- (D: Legal? No.)
end Foo;
end Pak1.Pak3;


date: 2011/03/21 11:29:58;  author: quinot;
TN is J701-202

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types.
Remove previous procedure with that name.
* sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor
when appropriate.
* sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a
subtype mark, the ancestor cannot have unknown discriminants.
(Resolve_Record_Aggregate): if the type has invisible components
because of a private ancestor, the aggregate is illegal.

Index: sem_aggr.adb
===
--- sem_aggr.adb(revision 177344)
+++ sem_aggr.adb(working copy)
@@ -45,6 +45,7 @@
 with Sem_Aux;  use Sem_Aux;
 with Sem_Cat;  use Sem_Cat;
 with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
@@ -2573,6 +2574,15 @@
 and then Is_Type (Entity (A))
   then
  Check_SPARK_Restriction ("ancestor part cannot be a type mark", A);
+
+ --  AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ --  must not have unknown discriminants.
+
+ if Has_Unknown_Discriminants (Root_Type (Typ)) then
+Error_Msg_NE
+  ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants", N, Typ);
+ end if;
   end if;
 
   if not Is_Tagged_Type (Typ) then
@@ -3405,6 +3415,18 @@
 Positional_Expr := Empty;
  end if;
 
+ --  AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ --  must npt have unknown discriminants.
+
+ if Is_Derived_Type (Typ)
+   and then Has_Unknown_Discriminants (Root_Type (Typ))
+   and then Nkind (N) /= N_Extension_Aggregate
+ then
+Error_Msg_NE
+  ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants ", N, Typ);
+ end if;
+
  if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
  then
@@ -3558,6 +3580,35 @@
  Errors_Found: Boolean := False;
  Dnode   : Node_Id;
 
+ function Find_Private_Ancestor return Entity_Id;
+ --  AI05-0115: Find earlier ancestor in the derivation chain that is
+ --  derived from a private view. Whether the aggregate is legal
+ --  depends on the current visibility of the type as well as that
+ --  of the parent of the ancestor.
+
+ ---
+ -- Find_Private_Ancestor --
+ ---
+
+ function Find_Private_Ancestor return Entity_Id is
+Par : Entity_Id;
+ begin
+Par := Typ;
+loop
+   if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+   then
+  return Par;
+
+   elsif not Is_Derived_Type (Par) then
+  return Empty;
+
+   else
+  Par := Etype (Base_Type (Par));
+   end if;
+end loop;
+ end Find_Private_Ancestor;
+
   begin
  if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then

[Ada] Legality rules for formal packages with box initialization

[Arnaud Charlet]

AI05-0025 specifies that a formal package is illegal if it includes a named box
initialization for an overloaded formal subprogram. This is an extension of an
existing rule for instantiations.

Compiling proc1.adb in Ada2005 mode  must yield the following:

   proc1.adb:10:05: instantiation abandoned
   proc1.adb:10:49: named association not allowed for overloaded formal
   proc1.adb:15:09: instantiation abandoned
   proc1.adb:16:35: named association not allowed for overloaded formal
   proc1.adb:33:09: instantiation abandoned
   proc1.adb:34:35: named association not allowed for overloaded formal
   proc1.adb:40:09: instantiation abandoned
   proc1.adb:41:35: named association not allowed for overloaded formal

---
procedure Proc1 is
generic
type T1 is private;
type T2 is private;
with function "=" (Left, Right : T1) return Boolean is <>;
with function "=" (Left, Right : T2) return Boolean is <>;
package GP1 is
end GP1;

package Inst1 is new GP1 (Integer, Integer, "=" => ">="); --  ERROR

generic
type T1 is private;
type T2 is private;
with package The_Pak1 is new GP1
 (T1 => T1, T2 => T2, "=" => <>, "=" => <>); --  ERROR
package GP2 is end GP2;

package P is
   type T0 is tagged null record;

   function Func (X, Y : T0) return Boolean;
end;
use P;

package body P is
   function Func (X, Y : T0) return Boolean is begin return False; end;
end P;

generic
type T1 is new T0 with private;
type T2 is new T0 with private;
with package The_Pak1 is new GP1
 (T1 => T1, T2 => T2, "=" => Func, "=" => Func);  --  ERROR
package GP3 is end GP3;

generic
type T1 is new T0 with private;
type T2 is new T0 with private;
with package The_Pak1 is new GP1
 (T1 => T1, T2 => T2, others => <>); --  ERROR
package GP4 is end GP4;

generic
type T1 is new T0 with private;
type T2 is new T0 with private;
with package The_Pak1 is new GP1 ( T1, T2, Func, Func);  --  OK
package GP5 is end GP5;

begin
   null;
end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_ch12.adb (Analyze_Associations): New routine
Check_Overloaded_Formal_Subprogram to reject a formal package when
there is a named association or a box initialisation for an overloaded
formal subprogram of the corresponding generic.

Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 177361)
+++ sem_ch12.adb(working copy)
@@ -888,7 +888,6 @@
   Actual  : Node_Id;
   Formal  : Node_Id;
   Next_Formal : Node_Id;
-  Temp_Formal : Node_Id;
   Analyzed_Formal : Node_Id;
   Match   : Node_Id;
   Named   : Node_Id;
@@ -910,9 +909,16 @@
   Num_Actuals: Int := 0;
 
   Others_Present : Boolean := False;
+  Others_Choice  : Node_Id := Empty;
   --  In Ada 2005, indicates partial parametrization of a formal
   --  package. As usual an other association must be last in the list.
 
+  procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
+  --  Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
+  --  cannot have a named association for it. AI05-0025 extends this rule
+  --  to formals of formal packages by AI05-0025, and it also applies to
+  --  box-initialized formals.
+
   function Matching_Actual
 (F   : Entity_Id;
  A_F : Entity_Id) return Node_Id;
@@ -946,6 +952,40 @@
   --  anonymous types, the presence a formal equality will introduce an
   --  implicit declaration for the corresponding inequality.
 
+  
+  -- Check_Overloaded_Formal_Subprogram --
+  
+
+  procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
+ Temp_Formal : Entity_Id;
+
+  begin
+ Temp_Formal := First (Formals);
+ while Present (Temp_Formal) loop
+if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
+  and then Temp_Formal /= Formal
+  and then
+Chars (Defining_Unit_Name (Specification (Formal))) =
+Chars (Defining_Unit_Name (Specification (Temp_Formal)))
+then
+   if Present (Found_Assoc) then
+  Error_Msg_N
+("named association not allowed for overloaded formal",
+ Found_Assoc);
+
+   else
+  Error_Msg_N
+("named association not allowed for overloaded formal",
+ Others_Choice);
+   end if;
+
+   Abandon_Instantiation (Instantiation_Node);
+end if;
+
+  

[Ada] Enrich ALFA cross references with the type of entity for parameters

[Arnaud Charlet]

In formal verification mode, in order to properly detect which parameters may
be read/written by a subprogram, a new information is added to ALFA cross
references.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* alfa.ads (ALFA_Xref_Record): add component for type of entity
* get_alfa.adb, put_alfa.adb: Read and write new component of
cross-reference.
* lib-xref-alfa.adb (Collect_ALFA): generate new component.

Index: alfa.ads
===
--- alfa.ads(revision 177361)
+++ alfa.ads(working copy)
@@ -133,10 +133,18 @@
--  entity-number and identity identify a scope entity in FS lines for
--  the file previously identified.
 
-   --line col entity ref*
+   --line typ col entity ref*
 
--  line is the line number of the referenced entity
 
+   --  typ is the type of the referenced entity, using a code similar to
+   --  the one used for cross-references:
+
+   --> = IN parameter
+   --< = OUT parameter
+   --= = IN OUT parameter
+   --* = all other cases
+
--  col is the column number of the referenced entity
 
--  entity is the name of the referenced entity as written in the source
@@ -186,6 +194,13 @@
   Entity_Line : Nat;
   --  Line number for the entity referenced
 
+  Etype : Character;
+  --  Indicates type of entity, using code used in ALI file:
+  --> = IN parameter
+  --< = OUT parameter
+  --= = IN OUT parameter
+  --* = all other cases
+
   Entity_Col : Nat;
   --  Column number for the entity referenced
 
Index: put_alfa.adb
===
--- put_alfa.adb(revision 177274)
+++ put_alfa.adb(working copy)
@@ -173,7 +173,7 @@
 Write_Info_Initiate ('F');
 Write_Info_Char (' ');
 Write_Info_Nat (R.Entity_Line);
-Write_Info_Char (' ');
+Write_Info_Char (R.Etype);
 Write_Info_Nat (R.Entity_Col);
 Write_Info_Char (' ');
 
Index: lib-xref-alfa.adb
===
--- lib-xref-alfa.adb   (revision 177324)
+++ lib-xref-alfa.adb   (working copy)
@@ -635,6 +635,9 @@
 --  Return scope entity which corresponds to index Cur_Scope_Idx in
 --  table ALFA_Scope_Table.
 
+function Get_Entity_Type (E : Entity_Id) return Character;
+--  Return a character representing the type of entity
+
 function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
 --  Check whether entity E is in ALFA_Scope_Table at index
 --  Cur_Scope_Idx or higher.
@@ -652,6 +655,22 @@
return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
 end Cur_Scope;
 
+-
+-- Get_Entity_Type --
+-
+
+function Get_Entity_Type (E : Entity_Id) return Character is
+   C : Character;
+begin
+   case Ekind (E) is
+  when E_Out_Parameter=> C := '<';
+  when E_In_Out_Parameter => C := '=';
+  when E_In_Parameter => C := '>';
+  when others => C := '*';
+   end case;
+   return C;
+end Get_Entity_Type;
+
 
 -- Is_Future_Scope_Entity --
 
@@ -729,6 +748,7 @@
 ALFA_Xref_Table.Append (
   (Entity_Name => Cur_Entity_Name,
Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
+   Etype   => Get_Entity_Type (XE.Ent),
Entity_Col  => Int (Get_Column_Number (XE.Def)),
File_Num=> Dependency_Num (XE.Lun),
Scope_Num   => Get_Scope_Num (XE.Ref_Scope),
Index: get_alfa.adb
===
--- get_alfa.adb(revision 177274)
+++ get_alfa.adb(working copy)
@@ -371,6 +371,7 @@
XR_Entity  : String_Ptr;
XR_Entity_Line : Nat;
XR_Entity_Col  : Nat;
+   XR_Entity_Typ  : Character;
 
XR_File : Nat;
--  Keeps track of the current file (changed by nn|)
@@ -383,7 +384,7 @@
XR_Scope := Cur_Scope;
 
XR_Entity_Line := Get_Nat;
-   Check (' ');
+   XR_Entity_Typ  := Getc;
XR_Entity_Col  := Get_Nat;
 
Skip_Spaces;
@@ -439,6 +440,7 @@
ALFA_Xref_Table.Append (
  (Entity_Name => XR_Entity,
   

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Richard Guenther]

On Thu, Aug 4, 2011 at 3:01 PM, Richard Guenther
 wrote:
> On Thu, Aug 4, 2011 at 2:58 PM, Gabriel Dos Reis
>  wrote:
>> On Wed, Aug 3, 2011 at 1:14 PM, Jason Merrill  wrote:
>>> On 08/03/2011 08:46 AM, Richard Guenther wrote:

 If that's reasonable then adding the malloc attribute should be, too.
 Finally.  Please.  Doesn't C++0x maybe "fix" the issue we were
 discussing to death?
>>>
>>> Nope, as far as I can tell nobody raised it with the committee.  I have now.
>>>
>>> I think we ought to be able to assume that a program which accesses the
>>> allocated storage other than through the returned pointer has undefined
>>> behavior.
>>
>> Hmm, how do you define "other than the returned pointer"?  Do you intend
>> to rule out garbage collectors?  Should not access as raw memory (e.g. 
>> through
>> char* or void*) be allowed?
>
> No.  But "other than the returned pointer" should probably
> "other than through a pointer derived from the returned pointer".

To make the point clearer, consider a C malloc implementation that
sets a global pointer to the last pointer it returned.  We "miscompile" then

extern int *last_malloc_result;
int main()
{
  int *p = malloc (4);
  *p = 0;
  *last_malloc_result = 1;
  return *p;
}

if malloc is declared with the malloc attribute.  Similar issues I can
see happening with C++ - but it's nothing special with C++ but
happens with C as well (given glibc malloc surely exposes interfaces
to get access to its pools behind our back).

Richard.

Re: [Patch, Fortran] (Coarray) Fix constraint checks for LOCK_TYPE

[Tobias Burnus]

On 08/04/2011 02:44 PM, Mikael Morin wrote:

and I belief both "var%comp" and
"var" are named.

My reading is that a named variable is a variable that is an object-name.


That's actually my problem with the standard - it never quite tells what 
a "named variable" exactly is. I think at least "ptrfunction()" is not a 
named variable but just a variable.



The problem is that
diagnosing the problem can get rather difficult. For instance:

type t
type(lock_type) :: C
end type
type t2
type(t), allocatable :: B
end type t2
type t3
type(t2) :: D
end type t3

is valid - however, it is invalid to use:
type(t) :: x[*], y

However, how to write then the error message? "Error: Invalid
declaration at (1) as constraint C642 is violated" is probably not very
helpful, but should one really re-resolve the derived type?

I would write:
Variable at  shall be a coarray/have a codimension attribute as it has a
non-coarray subcomponent of type LOCK_TYPE at


But that error message would be very surprising for me as a user if I 
had written:


  type(t) :: x[*]

because "x" *is* a coarray - only "x%D%B" is not a coarray, which were 
fine if B weren't an allocatable/pointer or if B%C were not of LOCK_TYPE 
or B%C were itself a coarray.



Best would be to have the full reference y%d%b%c in the error message.


I think that works not well in the current scheme as one would have to 
store this information somewhere. Either, one resolves from the outside 
to the inside: Resolve "x", which resolves "x%D", which resolves 
"x%D%B"  - and when resolving "B" the "x%D%" part is not available. Or 
one stores that "B" is invalid, then one propagates this information on 
to "D" and then to "x" - at that point one knows that "x" is invalid - 
but the information that it is due to "x%D%B" is lost.


Additionally, for the example above, should it be "x%D%B" or x%D%B%C or ...?

That's not unsolvable but requires quite some restructuring.


Thus, we should stick closely to the standard, point exactly what is
prohibited, and not bother too much trying to provide some hints to the users.
;-)


Exactly: "ERROR: C642"

Would be the most correct error message, without bothering with the 
error location, variable name - and it also contains the 42. Or even 
better "ERROR: Violating Fortran 2008 standard" ;-)


If we want to really stick close to the standard, I would propose to add 
an attr.lock_c642_violated to the derived types and check for it later 
in resolve_symbol :P.



OK, it is starting to make sense now.
I'm not very fond of it, but if you want to keep this diagnostic, at the very
least put all that information in a comment. Best would be to provide it (or
some of it) in the error message too.


I made three attempts to get the LOCK_TYPE diagnostics kind of right. I 
can also do a fourth attempt, if it is cleaner or for some other reason 
better. However, I only do it if I get a clear outline how it should be 
done, i.e. which information is stored where, where it is obtained and 
how the error message should roughly look like.


The problem with the wording is that the constraint itself is not 
directly checkable but that one has to do it in a slightly convoluted 
way. Actually, the standard does the same: Certain things are prohibited 
as one bumps into other constraints if one tries to sneak past the 
constraint.


I do not mind having something better, but coming up with some concise 
but still correct - and helpful! - comment is not that simple.



Having said that, I just realized that the following program is not
rejected but it should:

That's exactly the reason why I don't like it. It's sufficiently difficult to 
get it right while sticking closely to the standard that one doesn't want to 
try picking one rule every 40 pages and see what is left after intersecting 
them.


Sorry, I cannot follow. The standard does not have constraint C123456789 
saying that it is invalid. The invalidity comes the combination of 
several constrains and definitions. That makes it difficult to spot all 
the cases which are (in)valid, but I do not see how one can prevent it. 
Thus, I claim I am "sticking closely to the standard" by rejecting the 
invalid code.


I agree that the wording could be better - but it is also difficult to 
write it in such a way that it helps a user when debugging a code as 
there might be different reason for the mistake.


Furthermore, I have stared too long at the code to be apt to find good 
wordings, thus, I am happy for suggestions for better comments and error 
messages.



I'll review the revised patch later today.


Thanks.

Tobias

[Ada] Correct wrong generation of ALFA cross-references

[Arnaud Charlet]

There was a problem with generation of ALFA cross-references for formal
verification, which causes a reference to appear in two scopes. Now corrected.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* lib-xref-alfa.adb (Add_ALFA_Xrefs): correct definition of ranges of
xrefs in a scope.

Index: lib-xref-alfa.adb
===
--- lib-xref-alfa.adb   (revision 177378)
+++ lib-xref-alfa.adb   (working copy)
@@ -339,7 +339,6 @@

 
procedure Add_ALFA_Xrefs is
-  Prev_Scope_Idx  : Scope_Index;
   Cur_Scope_Idx   : Scope_Index;
   From_Xref_Idx   : Xref_Index;
   Cur_Entity  : Entity_Id;
@@ -613,13 +612,12 @@
 
   --  Initialize loop
 
-  Prev_Scope_Idx := 1;
   Cur_Scope_Idx  := 1;
   From_Xref_Idx  := 1;
   Cur_Entity := Empty;
 
-  if ALFA_Scope_Table.Last /= 0 then
- ALFA_Scope_Table.Table (1).From_Xref := 1;
+  if ALFA_Scope_Table.Last = 0 then
+ return;
   end if;
 
   --  Loop to output references
@@ -721,9 +719,15 @@
 
 pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
 
+--  Update the range of cross references to which the current scope
+--  refers to. This may be the empty range only for the first scope
+--  considered.
+
 if XE.Ent_Scope /= Cur_Scope then
ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
  From_Xref_Idx;
+   ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
+ ALFA_Xref_Table.Last;
From_Xref_Idx := ALFA_Xref_Table.Last + 1;
 end if;
 
@@ -732,14 +736,6 @@
pragma Assert (Cur_Scope_Idx <= ALFA_Scope_Table.Last);
 end loop;
 
-if Prev_Scope_Idx /= Cur_Scope_Idx
-  and then ALFA_Xref_Table.Last /= 0
-then
-   ALFA_Scope_Table.Table (Prev_Scope_Idx).To_Xref :=
- ALFA_Xref_Table.Last;
-   Prev_Scope_Idx := Cur_Scope_Idx;
-end if;
-
 if XE.Ent /= Cur_Entity then
Cur_Entity_Name :=
  new String'(Exact_Source_Name (Sloc (XE.Ent)));
@@ -758,6 +754,8 @@
  end Add_One_Xref;
   end loop;
 
+  --  Update the range of cross references to which the scope refers to
+
   ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx;
   ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref   := ALFA_Xref_Table.Last;
end Add_ALFA_Xrefs;

[Ada] Special expansion in ALFA for pragma check/precondition/postcondition

[Arnaud Charlet]

In ALFA mode, we modify expansion so that pragma check are kept in the code,
while pre- and postconditions are kept attached to entities rather than
being inserted in the code.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* exp_prag.adb (Expand_Pragma_Check): in ALFA mode, return without
performing expansion.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper,
Analyze_Generic_Subprogram_Body): protect call to Process_PCCs so that
it is not called in ALFA mode.

Index: exp_prag.adb
===
--- exp_prag.adb(revision 177274)
+++ exp_prag.adb(working copy)
@@ -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- --
@@ -321,6 +321,12 @@
   --  be an explicit conditional in the source, not an implicit if, so we
   --  do not call Make_Implicit_If_Statement.
 
+  --  In formal verification mode, we keep the pragma check in the code
+
+  if ALFA_Mode then
+ return;
+  end if;
+
   --  Case where we generate a direct raise
 
   if ((Debug_Flag_Dot_G
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 177371)
+++ sem_ch6.adb (working copy)
@@ -962,8 +962,16 @@
  end if;
 
  Set_Actual_Subtypes (N, Current_Scope);
- Process_PPCs (N, Gen_Id, Body_Id);
 
+ --  Deal with preconditions and postconditions. In formal verification
+ --  mode, we keep pre- and postconditions attached to entities rather
+ --  than inserted in the code, in order to facilitate a distinct
+ --  treatment for them.
+
+ if not ALFA_Mode then
+Process_PPCs (N, Gen_Id, Body_Id);
+ end if;
+
  --  If the generic unit carries pre- or post-conditions, copy them
  --  to the original generic tree, so that they are properly added
  --  to any instantiation.
@@ -2663,9 +2671,14 @@
   HSS := Handled_Statement_Sequence (N);
   Set_Actual_Subtypes (N, Current_Scope);
 
-  --  Deal with preconditions and postconditions
+  --  Deal with preconditions and postconditions. In formal verification
+  --  mode, we keep pre- and postconditions attached to entities rather
+  --  than inserted in the code, in order to facilitate a distinct
+  --  treatment for them.
 
-  Process_PPCs (N, Spec_Id, Body_Id);
+  if not ALFA_Mode then
+ Process_PPCs (N, Spec_Id, Body_Id);
+  end if;
 
   --  Add a declaration for the Protection object, renaming declarations
   --  for discriminals and privals and finally a declaration for the entry

[Ada] AI05-0020 : universal operators of fixed point and access types

[Arnaud Charlet]

This AI specifies that a user-defined equality on an anonymous access type
whose designated type is private does not lead to an ambiguity with the
universal access equality operator in the body or child units of the defining
package. The same is true for a multiplication operator on a private type
completed with a fixed-point-type.

The following must compile and execute quietly:

with P;
procedure AI20 is
begin
   null;
end;
---
package body P is
  function Compare (L, R : access T) return Boolean is
  begin
 return L = R;
  end;
  function "=" (L, R : access T) return Boolean is
  begin
 return True;
  end;

  function "*" (L, R : TF) return TF is
  begin
 return L + R;
  end;

  X, Y : access T := new T;
  Val1, Val2 : TF := 3.0;
begin
  if not Compare (X, Y) then raise Program_Error; end if;
  Val1 := Val1 * Val2;
  if Val1 /= 6.0 then
 raise Program_Error;
  end if;
end;
---
package P is
   type T is private;
   function "=" (L, R : access T) return Boolean;

   type TF is private;
   function "*" (L, R : TF) return TF;
private
   type T is null record;
   type TF is delta 1.0 range 0.0..42.0;
end P;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* sem_type.adb (Disambiguate): New subsidiary routine
In_Same_Declaration_List, to implement AI05-0020: a user-defined
equality on an anonymous access type whose designated type is private
does not lead to an ambiguity with the universal access equality
operator in the body or child units of the defining package. The same
is true for a multiplication operator on a private type completed with
a fixed-point-type.

Index: sem_type.adb
===
--- sem_type.adb(revision 177344)
+++ sem_type.adb(working copy)
@@ -1196,6 +1196,17 @@
   --  Determine whether one of the candidates is an operation inherited by
   --  a type that is derived from an actual in an instantiation.
 
+  function In_Same_Declaration_List
+(Typ : Entity_Id;
+ Op_Decl : Entity_Id) return Boolean;
+  --  AI05-0020: a spurious ambiguity may arise when equality on anonymous
+  --  access types is declared on the partial view of a designated type, so
+  --  that the type declaration and equality are not in the same list of
+  --  declarations. This AI gives a preference rule for the user-defined
+  --  operation. Same rule applies for arithmetic operations on private
+  --  types completed with fixed-point types: the predefined operation is
+  --  hidden;  this is already handled properly in GNAT.
+
   function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
   --  Determine whether a subprogram is an actual in an enclosing instance.
   --  An overloading between such a subprogram and one declared outside the
@@ -1255,6 +1266,26 @@
  end if;
   end Inherited_From_Actual;
 
+  --
+  -- In_Same_Declaration_List --
+  --
+
+  function In_Same_Declaration_List
+(Typ : Entity_Id;
+ Op_Decl : Entity_Id) return Boolean
+  is
+ Scop : constant Entity_Id := Scope (Typ);
+
+  begin
+ return In_Same_List (Parent (Typ), Op_Decl)
+   or else
+ (Ekind_In (Scop, E_Package, E_Generic_Package)
+and then List_Containing (Op_Decl) =
+  Visible_Declarations (Parent (Scop))
+and then List_Containing (Parent (Typ)) =
+  Private_Declarations (Parent (Scop)));
+  end In_Same_Declaration_List;
+
   --
   -- Is_Actual_Subprogram --
   --
@@ -1934,8 +1965,9 @@
   and then Etype (User_Subp) = Standard_Boolean
   and then Ekind (Operand_Type) = E_Anonymous_Access_Type
   and then
-In_Same_List (Parent (Designated_Type (Operand_Type)),
-  Unit_Declaration_Node (User_Subp))
+In_Same_Declaration_List
+  (Designated_Type (Operand_Type),
+ Unit_Declaration_Node (User_Subp))
 then
if It2.Nam = Predef_Subp then
   return It1;

[Ada] Save/restore value of pragma Normalize_Scalars

[Arnaud Charlet]

This patch reverses the previous patch which saved/restore the values of
pragma Normalize_Scalars because the value of Normalize_Scalars must not
be saved/restored because once set to true its value never changes. That
is, if a compilation unit has pragma Normalize_Scalars then it forces
that value for all with'ed units. After this patch the compilation
of the following small test must not cause an assertion failure
in the frontend.

with Ada.Text_IO;
package ImpDef is end;

pragma Normalize_Scalars;
with Impdef;
package CXH1001_0 is end;

Command: gcc -c cxh1001_0.ads

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Javier Miranda  

* opt.ads (Init_Or_Norm_Scalars_Config): Removed.
(Normalize_Scalars_Config): Removed.
* opt.adb
(Register_Opt_Config_Switches): Remove registering config values of
Init_Or_Norm_Scalars_Config and Normalize_Scalars_Config.
(Restore_Opt_Config_Switches): Remove code which restores the values of
Init_Or_Norm_Scalars and Normalize_Scalars. Recalculate value of
Init_Or_Norm_Scalars.
(Save_Opt_Config_Switches): Remove code which saves values of
Init_Or_Norm_Scalars and Normalize_Scalars.
(Set_Opt_Config_Switches): Remove code which restores config values of
Init_Or_Norm_Scalars and Normalize_Scalars. Recalculate value of
Init_Or_Norm_Scalars.

Index: opt.adb
===
--- opt.adb (revision 177360)
+++ opt.adb (working copy)
@@ -57,9 +57,7 @@
   External_Name_Exp_Casing_Config   := External_Name_Exp_Casing;
   External_Name_Imp_Casing_Config   := External_Name_Imp_Casing;
   Fast_Math_Config  := Fast_Math;
-  Init_Or_Norm_Scalars_Config   := Init_Or_Norm_Scalars;
   Initialize_Scalars_Config := Initialize_Scalars;
-  Normalize_Scalars_Config  := Normalize_Scalars;
   Optimize_Alignment_Config := Optimize_Alignment;
   Persistent_BSS_Mode_Config:= Persistent_BSS_Mode;
   Polling_Required_Config   := Polling_Required;
@@ -92,15 +90,20 @@
   External_Name_Exp_Casing   := Save.External_Name_Exp_Casing;
   External_Name_Imp_Casing   := Save.External_Name_Imp_Casing;
   Fast_Math  := Save.Fast_Math;
-  Init_Or_Norm_Scalars   := Save.Init_Or_Norm_Scalars;
   Initialize_Scalars := Save.Initialize_Scalars;
-  Normalize_Scalars  := Save.Normalize_Scalars;
   Optimize_Alignment := Save.Optimize_Alignment;
   Optimize_Alignment_Local   := Save.Optimize_Alignment_Local;
   Persistent_BSS_Mode:= Save.Persistent_BSS_Mode;
   Polling_Required   := Save.Polling_Required;
   Short_Descriptors  := Save.Short_Descriptors;
   Use_VADS_Size  := Save.Use_VADS_Size;
+
+  --  Update consistently the value of Init_Or_Norm_Scalars. The value of
+  --  Normalize_Scalars is not saved/restored because after set to True its
+  --  value is never changed. That is, if a compilation unit has pragma
+  --  Normalize_Scalars then it forces that value for all with'ed units.
+
+  Init_Or_Norm_Scalars := Initialize_Scalars or Normalize_Scalars;
end Restore_Opt_Config_Switches;
 
--
@@ -122,9 +125,7 @@
   Save.External_Name_Exp_Casing   := External_Name_Exp_Casing;
   Save.External_Name_Imp_Casing   := External_Name_Imp_Casing;
   Save.Fast_Math  := Fast_Math;
-  Save.Init_Or_Norm_Scalars   := Init_Or_Norm_Scalars;
   Save.Initialize_Scalars := Initialize_Scalars;
-  Save.Normalize_Scalars  := Normalize_Scalars;
   Save.Optimize_Alignment := Optimize_Alignment;
   Save.Optimize_Alignment_Local   := Optimize_Alignment_Local;
   Save.Persistent_BSS_Mode:= Persistent_BSS_Mode;
@@ -190,13 +191,19 @@
  External_Name_Exp_Casing:= External_Name_Exp_Casing_Config;
  External_Name_Imp_Casing:= External_Name_Imp_Casing_Config;
  Fast_Math   := Fast_Math_Config;
- Init_Or_Norm_Scalars:= Init_Or_Norm_Scalars_Config;
  Initialize_Scalars  := Initialize_Scalars_Config;
- Normalize_Scalars   := Normalize_Scalars_Config;
  Optimize_Alignment  := Optimize_Alignment_Config;
  Optimize_Alignment_Local:= False;
  Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
  Use_VADS_Size   := Use_VADS_Size_Config;
+
+ --  Update consistently the value of Init_Or_Norm_Scalars. The value
+ --  of Normalize_Scalars is not saved/restored because once set to
+ --  True its value is never changed. That is, if a com

[Ada] Use unique names in ALFA cross reference in ALI files

[Arnaud Charlet]

The formal verification backend relies on unique names for the variables named
in ALFA sections of ALI files. Thus, generate these unique names with a new
function.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* frontend.adb (Frontend): remove previous patch to avoid full
qualification in ALFA mode.
* lib-xref-alfa.adb (Add_ALFA_Xrefs): use unique name for variables.
* sem_util.adb, sem_util.ads (Unique_Name): new function to define a
unique name for an entity, which could be used to identify the entity
across compilation units.

Index: frontend.adb
===
--- frontend.adb(revision 177377)
+++ frontend.adb(working copy)
@@ -372,11 +372,9 @@
--  Qualify all entity names in inner packages, package bodies, etc.,
--  except when compiling for the VM back-ends, which depend on having
--  unqualified names in certain cases and handles the generation of
-   --  qualified names when needed, and when compiling for formal verification,
-   --  in which the back-end calls directly Qualify_All_Entity_Names after some
-   --  preprocessing which uses the non-qualified names.
+   --  qualified names when needed.
 
-   if VM_Target = No_VM and then not ALFA_Mode then
+   if VM_Target = No_VM then
   Exp_Dbug.Qualify_All_Entity_Names;
end if;
 
Index: sem_util.adb
===
--- sem_util.adb(revision 177361)
+++ sem_util.adb(working copy)
@@ -12201,6 +12201,22 @@
   end case;
end Unique_Defining_Entity;
 
+   -
+   -- Unique_Name --
+   -
+
+   function Unique_Name (E : Entity_Id) return String is
+  Name : constant String := Get_Name_String (Chars (E));
+   begin
+  if Has_Fully_Qualified_Name (E)
+or else E = Standard_Standard
+  then
+ return Name;
+  else
+ return Unique_Name (Scope (E)) & "__" & Name;
+  end if;
+   end Unique_Name;
+
--
-- Unit_Declaration_Node --
--
Index: sem_util.ads
===
--- sem_util.ads(revision 177361)
+++ sem_util.ads(working copy)
@@ -1372,6 +1372,10 @@
--  Return the entity which represents declaration N, so that matching
--  declaration and body have the same entity.
 
+   function Unique_Name (E : Entity_Id) return String;
+   --  Return a unique name for entity E, which could be used to identify E
+   --  across compilation units.
+
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
--  Unit_Id is the simple name of a program unit, this function returns the
--  corresponding xxx_Declaration node for the entity. Also applies to the
Index: lib-xref-alfa.adb
===
--- lib-xref-alfa.adb   (revision 177382)
+++ lib-xref-alfa.adb   (working copy)
@@ -738,7 +738,7 @@
 
 if XE.Ent /= Cur_Entity then
Cur_Entity_Name :=
- new String'(Exact_Source_Name (Sloc (XE.Ent)));
+ new String'(Unique_Name (XE.Ent));
 end if;
 
 ALFA_Xref_Table.Append (

[Ada] Set Entity for a created Identifier Node

[Arnaud Charlet]

The function Identifer_For, called from the code that generates the type
declarations for string types in the standard package, now also sets the
entity of the generated identifier.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Johannes Kanig  

* cstand.adb: Add Information to Identifier in Standard
(Identifer_For): Set Entity to the corresponding entity

Index: cstand.adb
===
--- cstand.adb  (revision 177353)
+++ cstand.adb  (working copy)
@@ -1651,6 +1651,7 @@
begin
   Ident_Node := New_Node (N_Identifier, Stloc);
   Set_Chars (Ident_Node, Chars (Standard_Entity (S)));
+  Set_Entity (Ident_Node, Standard_Entity (S));
   return Ident_Node;
end Identifier_For;
 

Re: [RFC PATCH 0/9] CFG aware dwarf2 cfi generation

[Jan Hubicka]

> Jan Hubicka  writes:
> >
> > Cool, will this also help to handle alternate entry points, so we can move 
> > ahead
> > on this area we got stuck years ago?  (i.e. add support for alternate entry 
> > points on
> > i386 skipping IP pointer load in PIC mode/using register passing 
> > conventions)
> 
> Also alternative entry points to skip x87 in favour of SSE 
> register passing for FP would be really nice.

Yep, there is quite some potential in this on x86. On x86-64 also stack
alignment prologues could be eliminated.

I guess the PIC tricks could do wonders for Mozilla. Additionally once this
works, we can move ahead with alternate entry points at gimple level possibly
re-implementing thunks/ctor clonning using them.

So if we finally get past the unwind info issues, I could start poking about
getting the PIC codegen working as a first experiment.

Honza
> 
> -Andi
> 
> -- 
> a...@linux.intel.com -- Speaking for myself only

[Ada] Correct placement and checking of Test_Case pragma

[Arnaud Charlet]

Follow-up of changes for Test_Case pragma. Pragma is not allowed inside
subprogram body, only after separate declaration. No two test cases with same
name allowed on same entity. Correct error in checking procedure.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* gnat_rm.texi: Document that Test_Case pragma can only appear on
separate declarations.
* sem_prag.adb (procedure Check_Identifier_Is_One_Of): new procedure to
check identifier of pragma argument.
(Chain_TC): check that no other test case associated to the same entity
share the same name.
(Check_Test_Case): disallow test case inside subprogram body
(Analyze_Pragma): correct call to check identifier and not argument
* sem_util.adb, sem_util.ads (Get_Name_From_Test_Case_Pragma): new
function gets name from test case pragma.

Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 177384)
+++ gnat_rm.texi(working copy)
@@ -5025,14 +5025,16 @@
 @end smallexample
 
 @noindent
-The @code{Test_Case} pragma applies to the same entities as pragmas
-@code{Precondition} and @code{Postcondition}. In particular, the
-placement and visibility rules are identical to those described for pre-
-and postconditions. But the presence of pragma @code{Test_Case} does not
-lead to any modification of the code generated by the compiler. Rather,
-its purpose is to document finer-grain specifications for use by testing
-and verification tools.
+The @code{Test_Case} pragma allows defining fine-grain specifications
+for use by testing and verification tools. The compiler only checks its
+validity but the presence of pragma @code{Test_Case} does not lead to
+any modification of the code generated by the compiler.
 
+@code{Test_Case} pragmas may only appear immediately following the
+(separate) declaration of a subprogram. Only other pragmas may intervene
+(that is appear between the subprogram declaration and its
+postconditions).
+
 The compiler checks that boolean expression given in @code{Requires} and
 @code{Ensures} are valid, where the rules for @code{Requires} are the
 same as the rule for an expression in @code{Precondition} and the rules
@@ -5053,14 +5055,6 @@
 end Math_Functions;
 @end smallexample
 
-@noindent
-@code{Test_Case} pragmas may appear either immediately following the
-(separate) declaration of a subprogram, or at the start of the
-declarations of a subprogram body. Only other pragmas may intervene
-(that is appear between the subprogram declaration and its test cases,
-or appear before the test case in the declaration sequence in a
-subprogram body).
-
 @node Pragma Thread_Local_Storage
 @unnumberedsec Pragma Thread_Local_Storage
 @findex Thread_Local_Storage
Index: sem_prag.adb
===
--- sem_prag.adb(revision 177384)
+++ sem_prag.adb(working copy)
@@ -423,8 +423,14 @@
   --  Checks that the given argument has an identifier, and if so, requires
   --  it to match the given identifier name. If there is no identifier, or
   --  a non-matching identifier, then an error message is given and
-  --  Error_Pragmas raised.
+  --  Pragma_Exit is raised.
 
+  procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+  --  Checks that the given argument has an identifier, and if so, requires
+  --  it to match one of the given identifier names. If there is no
+  --  identifier, or a non-matching identifier, then an error message is
+  --  given and Pragma_Exit is raised.
+
   procedure Check_In_Main_Program;
   --  Common checks for pragmas that appear within a main program
   --  (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
@@ -454,12 +460,12 @@
   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
   --  Checks if the given argument has an identifier, and if so, requires
   --  it to match the given identifier name. If there is a non-matching
-  --  identifier, then an error message is given and Error_Pragmas raised.
+  --  identifier, then an error message is given and Pragma_Exit is raised.
 
   procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
   --  Checks if the given argument has an identifier, and if so, requires
   --  it to match the given identifier name. If there is a non-matching
-  --  identifier, then an error message is given and Error_Pragmas raised.
+  --  identifier, then an error message is given and Pragma_Exit is raised.
   --  In this version of the procedure, the identifier name is given as
   --  a string with lower case letters.
 
@@ -1432,6 +1438,30 @@
  end if;
   end Check_Identifier;
 
+  
+  -- Check_Identifier_Is_One_Of --
+  

[Ada] Rewrite dynamic stack usage

[Arnaud Charlet]

The dynamic stack usage engine has been rewritten to slightly simplify it.
It now provides accurate results on machine where the stack base is known.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Tristan Gingold  

* s-tassta.adb (Task_Wrapper): Rewrite the dynamic stack usage part.
* s-stausa.adb, s-stausa.ads: Major rewrite. Now provides accurate
results if possible.
* s-stusta.adb (Print): Adjust after changes in s-stausa.
* gnat_ugn.texi: Update dynamic stack usage section.

Index: s-tassta.adb
===
--- s-tassta.adb(revision 177283)
+++ s-tassta.adb(working copy)
@@ -1027,32 +1027,11 @@
 
   Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
 
-  pragma Warnings (Off);
-  --  Why are warnings being turned off here???
-
   Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
   --  Address of secondary stack. In the fixed secondary stack case, this
   --  value is not modified, causing a warning, hence the bracketing with
   --  Warnings (Off/On). But why is so much *more* bracketed???
 
-  Small_Overflow_Guard : constant := 12 * 1024;
-  --  Note: this used to be 4K, but was changed to 12K, since smaller
-  --  values resulted in segmentation faults from dynamic stack analysis.
-
-  Big_Overflow_Guard   : constant := 16 * 1024;
-  Small_Stack_Limit: constant := 64 * 1024;
-  --  ??? These three values are experimental, and seems to work on most
-  --  platforms. They still need to be analyzed further. They also need
-  --  documentation, what are they???
-
-  Size : Natural :=
-   Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
-
-  Overflow_Guard : Natural;
-  --  Size of the overflow guard, used by dynamic stack usage analysis
-
-  pragma Warnings (On);
-
   SEH_Table : aliased SSE.Storage_Array (1 .. 8);
   --  Structured Exception Registration table (2 words)
 
@@ -1116,7 +1095,6 @@
  Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
Secondary_Stack'Address;
  SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
- Size := Size - Natural (Secondary_Stack_Size);
   end if;
 
   if Use_Alternate_Stack then
@@ -1136,24 +1114,64 @@
   --  Initialize dynamic stack usage
 
   if System.Stack_Usage.Is_Enabled then
- Overflow_Guard :=
-   (if Size < Small_Stack_Limit
-  then Small_Overflow_Guard
-  else Big_Overflow_Guard);
+ declare
+Guard_Page_Size  : constant := 12 * 1024;
+--  Part of the stack used as a guard page. This is an OS dependent
+--  value, so we need to use the maximum. This value is only used
+--  when the stack address is known, that is currently Windows.
 
- STPO.Lock_RTS;
- Initialize_Analyzer
-   (Self_ID.Common.Analyzer,
-Self_ID.Common.Task_Image
-  (1 .. Self_ID.Common.Task_Image_Len),
-Natural
-  (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size),
-Size - Overflow_Guard,
-SSE.To_Integer (Bottom_Of_Stack'Address),
-SSE.To_Integer
-  (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit));
- STPO.Unlock_RTS;
- Fill_Stack (Self_ID.Common.Analyzer);
+Small_Overflow_Guard : constant := 12 * 1024;
+--  Note: this used to be 4K, but was changed to 12K, since
+--  smaller values resulted in segmentation faults from dynamic
+--  stack analysis.
+
+Big_Overflow_Guard   : constant := 16 * 1024;
+Small_Stack_Limit: constant := 64 * 1024;
+--  ??? These three values are experimental, and seems to work on
+--  most platforms. They still need to be analyzed further. They
+--  also need documentation, what are they???
+
+Pattern_Size : Natural :=
+  Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
+--  Size of the pattern
+
+Stack_Base : Address;
+--  Address of the base of the stack
+ begin
+Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base;
+if Stack_Base = Null_Address then
+   --  On many platforms, we don't know the real stack base
+   --  address. Estimate it using an address in the frame.
+   Stack_Base := Bottom_Of_Stack'Address;
+
+   --  Also reduce the size of the stack to take into account the
+   --  secondary stack array declared in this frame. This is for
+   --  sure very conservative.
+   if not Parameters.Sec_Stack_Dynamic then
+  Pattern_Size :=
+Pattern_Size - N

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Jason Merrill]

On 08/04/2011 08:58 AM, Gabriel Dos Reis wrote:

Do you intend to rule out garbage collectors?


No, I suppose the rule should be that interleaved access through the 
returned pointer and other ways is undefined.



Should not access as raw memory (e.g. through char* or void*) be allowed?


No, accessing it as raw memory is no different.

Jason

[Ada] Improve support class-wide interface conversions in .NET

[Arnaud Charlet]

This patch improves the support for interface conversions in the .NET/JVM
compiler extending the current support for attribute 'tag and adding the
missing runtime checks required in interface conversions when the tag of
the source is unknown at compile time. After this patch the following test
compiles and executes well.

with GNAT.IO; use GNAT.IO;
procedure Main is
   package Pkg is
  type Iface is interface;
  procedure Print (Obj : in out Iface) is abstract;

  type Parent is tagged record
 Id : Natural := 1;
  end record;

  type Child is new Parent and Iface with null record;
  procedure Print (Obj : in out Child);

  function New_Child return Iface'Class;
   end Pkg;

   package body Pkg is
  procedure Print (Obj : in out Child) is
  begin
 Put_Line ("child" & Obj.Id'Img);
  end Print;

  function New_Child return Iface'Class is
  begin
 return Obj : Child do
Obj.Id := 3;
 end return;
  end New_Child;
   end Pkg;
   use Pkg;
   
   C : Iface'Class  := New_Child;
begin
   Print (C);
end Main;

Command: dotnet-gnatmake -gnat05 main; ./main.exe
 Output: child 3

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Javier Miranda  

* exp_ch7.adb (Expand_N_Package_Body, Expand_N_Package_Declaration):
Remove code which takes care of building TSDs.
* rtsfind.ads (RE_Check_Interface_Conversion): New entity.
* exp_ch4.adb (Apply_Accessibility_Check): Add support for generating
the accessibility check in VM targets.
* exp_disp.adb (Make_VM_TSD): Spec moved to exp_disp.ads
(Building_Static_DT): Now returns false for VM targets.
(Build_VM_TSDs): Removed.
(Expand_Interface_Conversion): Generate missing runtime check for
conversions to interface types whose target type is unknown at compile
time.
(Make_VM_TSD): Add missing code to disable the generation of calls to
Check_TSD if the tagged type is not defined at library level, or not
has a representation clause specifying its external tag, or -gnatdQ is
active.
* exp_disp.ads (Build_VM_TSDs): Removed.
(Make_VM_TSDs): Spec relocated from exp_disp.adb
* sem_disp.adb (Check_Dispatching_Operation): No code required to
register primitives in the dispatch tables in VM targets.
* exp_ch3.adb (Expand_N_Object_Declaration): Remove wrong expansion of
initialization of class-wide interface objects in VM targets.
(Expand_Freeze_Record_Type): For VM targets call Make_VM_TSD (instead
of Make_DT).

Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 177386)
+++ exp_ch7.adb (working copy)
@@ -1261,7 +1261,7 @@
   --  objects that need finalization. When flag Preprocess is set, the
   --  routine will simply count the total number of controlled objects in
   --  Decls. Flag Top_Level denotes whether the processing is done for
-  --  objects in nested package decparations or instances.
+  --  objects in nested package declarations or instances.
 
   procedure Process_Object_Declaration
 (Decl : Node_Id;
@@ -3810,24 +3810,10 @@
 
  --  Build dispatch tables of library level tagged types
 
- if Is_Library_Level_Entity (Spec_Ent) then
-if Tagged_Type_Expansion then
-   Build_Static_Dispatch_Tables (N);
-
---  In VM targets there is no need to build dispatch tables but
---  we must generate the corresponding Type Specific Data record.
-
-elsif Unit (Cunit (Main_Unit)) = N then
-
-   --  If the runtime package Ada_Tags has not been loaded then
-   --  this package does not have tagged type declarations and
-   --  there is no need to search for tagged types to generate
-   --  their TSDs.
-
-   if RTU_Loaded (Ada_Tags) then
-  Build_VM_TSDs (N);
-   end if;
-end if;
+ if Tagged_Type_Expansion
+   and then Is_Library_Level_Entity (Spec_Ent)
+ then
+Build_Static_Dispatch_Tables (N);
  end if;
 
  Build_Task_Activation_Call (N);
@@ -3948,42 +3934,12 @@
 
   --  Build dispatch tables of library level tagged types
 
-  if Is_Compilation_Unit (Id)
-or else (Is_Generic_Instance (Id)
-  and then Is_Library_Level_Entity (Id))
+  if Tagged_Type_Expansion
+and then (Is_Compilation_Unit (Id)
+or else (Is_Generic_Instance (Id)
+   and then Is_Library_Level_Entity (Id)))
   then
- if Tagged_Type_Expansion then
-Build_Static_Dispatch_Tables (N);
-
- --  In VM targets there is no need to build dispatch tables, but we
- --  must generate the corresponding Type Specif

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Gabriel Dos Reis]

On Thu, Aug 4, 2011 at 8:43 AM, Jason Merrill  wrote:
> On 08/04/2011 08:58 AM, Gabriel Dos Reis wrote:
>>
>> Do you intend to rule out garbage collectors?
>
> No, I suppose the rule should be that interleaved access through the
> returned pointer and other ways is undefined.

OK.

>> Should not access as raw memory (e.g. through char* or void*) be allowed?
>
> No, accessing it as raw memory is no different.

Hmm, maybe I misunderstand what you are saying.  But, I think a
scanning collector
should be allowed.

-- Gaby

Re: [RFC PATCH] Add alloc_size attribute to the default operator new and operator new[]

[Richard Guenther]

On Thu, Aug 4, 2011 at 3:50 PM, Gabriel Dos Reis
 wrote:
> On Thu, Aug 4, 2011 at 8:43 AM, Jason Merrill  wrote:
>> On 08/04/2011 08:58 AM, Gabriel Dos Reis wrote:
>>>
>>> Do you intend to rule out garbage collectors?
>>
>> No, I suppose the rule should be that interleaved access through the
>> returned pointer and other ways is undefined.
>
> OK.
>
>>> Should not access as raw memory (e.g. through char* or void*) be allowed?
>>
>> No, accessing it as raw memory is no different.
>
> Hmm, maybe I misunderstand what you are saying.  But, I think a
> scanning collector
> should be allowed.

But not interleaved with allocator users.  Problems will only arise if
you mix code using storage via the pointer returned from the allocator
and code that accesses the allocation pool by other means.
Where "mix" is, expose in one TU (actually expose partially, full
exposure is ok as well).

Richard.

> -- Gaby
>

[Ada] Allow static string expression as name of Test_Case pragma/aspect

[Arnaud Charlet]

Follow-up of implementation of Test_Case pragma/aspect.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* sem_prag.adb (Check_Arg_Is_String_Literal): remove useless procedure
(Analyze_Pragma): allow static string expression for name of Test_Case,
instead of simply string literals.
* sem_util.adb (Get_Name_From_Test_Case_Pragma): adapt to static string
expressions.

Index: sem_prag.adb
===
--- sem_prag.adb(revision 177388)
+++ sem_prag.adb(working copy)
@@ -335,10 +335,6 @@
   --  Check the specified argument Arg to make sure that it is an integer
   --  literal. If not give error and raise Pragma_Exit.
 
-  procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
-  --  Check the specified argument Arg to make sure that it is a string
-  --  literal. If not give error and raise Pragma_Exit.
-
   procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
   --  Check the specified argument Arg to make sure that it has the proper
   --  syntactic form for a local name and meets the semantic requirements
@@ -426,9 +422,9 @@
   --  Checks that the given argument has an identifier, and if so, requires
   --  it to match one of the given identifier names. If there is no
   --  identifier, or a non-matching identifier, then an error message is
-  --  given and Pragma_Exit is raised. ??? why is this needed, why isnt
-  --  Check_Arg_Is_One_Of good enough. At the very least explain this
-  --  odd apparent redundancy
+  --  given and Pragma_Exit is raised. This checks the optional identifier
+  --  of a pragma argument, not the argument itself like
+  --  Check_Arg_Is_One_Of does.
 
   procedure Check_In_Main_Program;
   --  Common checks for pragmas that appear within a main program
@@ -901,19 +897,6 @@
  end if;
   end Check_Arg_Is_Integer_Literal;
 
-  -
-  -- Check_Arg_Is_String_Literal --
-  -
-
-  procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-  begin
- if Nkind (Argx) /= N_String_Literal then
-Error_Pragma_Arg
-  ("argument for pragma% must be string literal", Argx);
- end if;
-  end Check_Arg_Is_String_Literal;
-
   ---
   -- Check_Arg_Is_Library_Level_Local_Name --
   ---
@@ -13264,17 +13247,12 @@
  -- Test_Case --
  ---
 
- --  pragma Test_Case ([Name =>] String_EXPRESSION
+ --  pragma Test_Case ([Name =>] static_string_EXPRESSION
  --   ,[Mode =>] (Normal | Robustness)
  --  [, Requires =>  Boolean_EXPRESSION]
  --  [, Ensures  =>  Boolean_EXPRESSION]);
 
- --  ??? Why is Name not static_string_EXPRESSION??? Seems very
- --  weird to require it to be a string literal, and if we DO want
- --  that restriction the grammar should make this clear.
-
  when Pragma_Test_Case => Test_Case : declare
-
  begin
 GNAT_Pragma;
 Check_At_Least_N_Arguments (3);
@@ -13283,7 +13261,7 @@
   ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
 
 Check_Optional_Identifier (Arg1, Name_Name);
-Check_Arg_Is_String_Literal (Arg1);
+Check_Arg_Is_Static_Expression (Arg1, Standard_String);
 Check_Optional_Identifier (Arg2, Name_Mode);
 Check_Arg_Is_One_Of (Arg2, Name_Normal, Name_Robustness);
 
@@ -13291,9 +13269,6 @@
Check_Identifier (Arg3, Name_Requires);
Check_Identifier (Arg4, Name_Ensures);
 else
-   --  ??? why not Check_Arg_Is_One_Of, very odd!!! At the very
-   --  least needs an explanation!
-
Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
 end if;
 
Index: sem_util.adb
===
--- sem_util.adb(revision 177385)
+++ sem_util.adb(working copy)
@@ -4336,9 +4336,10 @@

 
function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
+  Arg : constant Node_Id :=
+  Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
begin
-  return
-Strval (Get_Pragma_Arg (First (Pragma_Argument_Associations (N;
+  return Strval (Expr_Value_S (Arg));
end Get_Name_From_Test_Case_Pragma;
 
---

[Ada] Special cross references in ALFA mode for constants and formals

[Arnaud Charlet]

ALFA mode used for formal verification requires different cross references,
in which read of constants is absent, and formal is not referenced when used
as selector of parameter association.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Yannick Moy  

* lib-xref-alfa.adb (Is_Global_Constant): new function that detects
library-level constant.
(Add_ALFA_Xrefs): ignore global constants in ALFA xref.
* sem_res.adb (Resolve_Actuals): do not add cross-reference to Formal
used as selector of parameter association, in ALFA mode.

Index: sem_res.adb
===
--- sem_res.adb (revision 177365)
+++ sem_res.adb (working copy)
@@ -3971,9 +3971,14 @@
 Eval_Actual (A);
 
 --  If it is a named association, treat the selector_name as a
---  proper identifier, and mark the corresponding entity.
+--  proper identifier, and mark the corresponding entity. Ignore
+--  this reference in ALFA mode, as it refers to an entity not in
+--  scope at the point of reference, so the reference should be
+--  ignored for computing effects of subprograms.
 
-if Nkind (Parent (A)) = N_Parameter_Association then
+if Nkind (Parent (A)) = N_Parameter_Association
+  and then not ALFA_Mode
+then
Set_Entity (Selector_Name (Parent (A)), F);
Generate_Reference (F, Selector_Name (Parent (A)));
Set_Etype (Selector_Name (Parent (A)), F_Typ);
Index: lib-xref-alfa.adb
===
--- lib-xref-alfa.adb   (revision 177383)
+++ lib-xref-alfa.adb   (working copy)
@@ -524,6 +524,10 @@
  function Is_ALFA_Scope (E : Entity_Id) return Boolean;
  --  Return whether the entity or reference scope is adequate
 
+ function Is_Global_Constant (E : Entity_Id) return Boolean;
+ --  Return True if E is a global constant for which we should ignore
+ --  reads in ALFA.
+
  ---
  -- Is_ALFA_Scope --
  ---
@@ -536,6 +540,16 @@
   and then Get_Scope_Num (E) /= No_Scope;
  end Is_ALFA_Scope;
 
+ 
+ -- Is_Global_Constant --
+ 
+
+ function Is_Global_Constant (E : Entity_Id) return Boolean is
+ begin
+return Ekind (E) in E_Constant
+  and then Ekind_In (Scope (E), E_Package, E_Package_Body);
+ end Is_Global_Constant;
+
  --  Start of processing for Eliminate_Before_Sort
   begin
 
@@ -547,6 +561,7 @@
   and then ALFA_References (Xrefs.Table (Rnums (J)).Typ)
   and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
   and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
+  and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
 then
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (J);

[Ada] Default-initialize Nodes component

[Arnaud Charlet]

When manipulating bounded hash-table based container objects,
that do not otherwise have any explicit initialization expression,
the compiler would emit a warning about the object not being
initialized, because the Nodes component of the hash table
type had not been given an initialization expression.

This warning is a false positive, because the logical state of the
object is empty, and other components of the hash table record type
are initialized, in a manner that establishes the representation
invariant of the object.

In order to eliminate the warning, the Nodes component of the hash
table type was given an initialization expression.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Matthew Heaney  

* a-cohata.ads (Hash_Table_Type): default-initialize the Nodes
component.

Index: a-cohata.ads
===
--- a-cohata.ads(revision 177274)
+++ a-cohata.ads(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- S p e c  --
 --  --
---  Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+--  Copyright (C) 2004-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- --
@@ -66,7 +66,7 @@
  Busy: Natural := 0;
  Lock: Natural := 0;
  Free: Count_Type'Base := -1;
- Nodes   : Nodes_Type (1 .. Capacity);
+ Nodes   : Nodes_Type (1 .. Capacity) := (others => <>);
  Buckets : Buckets_Type (1 .. Modulus) := (others => 0);
   end record;
end Generic_Bounded_Hash_Table_Types;

[PATCH] Fix parts of PR49806

[Richard Guenther]

This patch fixes

FAIL: gcc.dg/tree-ssa/vrp47.c scan-tree-dump-times vrp1 "x[^ ]* \^ 1" 1
FAIL: gcc.target/i386/andor-2.c scan-assembler-not sete

by simplifying simplify_truth_ops_using_ranges and make it do its
job even if we need to insert some conversions (to be extended to
also cover A == B via tem = B ^ 1; A ^ tem; which should be profitable
as well).  To be extended to properly set value-ranges for inserted
statements to catch secondary effects (they are catched by vrp2 now).

Bootstrapped and tested on x86_64-unknown-linux-gnu, applied to trunk.

Richard.

2011-08-04  Richard Guenther  

PR tree-optimization/49806
* tree-vrp.c (op_with_boolean_value_range_p): New function.
(simplify_truth_ops_using_ranges): Simplify.  Allow inserting
a new statement for a final conversion to bool.

Index: gcc/tree-vrp.c
===
--- gcc/tree-vrp.c  (revision 177367)
+++ gcc/tree-vrp.c  (working copy)
@@ -1454,6 +1454,28 @@ op_with_constant_singleton_value_range (
   return NULL_TREE;
 }
 
+/* Return true if op is in a boolean [0, 1] value-range.  */
+
+static bool
+op_with_boolean_value_range_p (tree op)
+{
+  value_range_t *vr;
+
+  if (TYPE_PRECISION (TREE_TYPE (op)) == 1)
+return true;
+
+  if (integer_zerop (op)
+  || integer_onep (op))
+return true;
+
+  if (TREE_CODE (op) != SSA_NAME)
+return false;
+
+  vr = get_value_range (op);
+  return (vr->type == VR_RANGE
+ && integer_zerop (vr->min)
+ && integer_onep (vr->max));
+}
 
 /* Extract value range information from an ASSERT_EXPR EXPR and store
it in *VR_P.  */
@@ -6753,115 +6775,64 @@ static bool
 simplify_truth_ops_using_ranges (gimple_stmt_iterator *gsi, gimple stmt)
 {
   enum tree_code rhs_code = gimple_assign_rhs_code (stmt);
-  tree val = NULL;
-  tree op0, op1;
-  value_range_t *vr;
-  bool sop = false;
+  tree lhs, op0, op1;
   bool need_conversion;
 
   /* We handle only !=/== case here.  */
   gcc_assert (rhs_code == EQ_EXPR || rhs_code == NE_EXPR);
 
   op0 = gimple_assign_rhs1 (stmt);
-  if (TYPE_PRECISION (TREE_TYPE (op0)) != 1)
-{
-  if (TREE_CODE (op0) != SSA_NAME)
-   return false;
-  vr = get_value_range (op0);
-
-  val = compare_range_with_value (GE_EXPR, vr, integer_zero_node, &sop);
-  if (!val || !integer_onep (val))
-return false;
-
-  val = compare_range_with_value (LE_EXPR, vr, integer_one_node, &sop);
-  if (!val || !integer_onep (val))
-return false;
-}
+  if (!op_with_boolean_value_range_p (op0))
+return false;
 
   op1 = gimple_assign_rhs2 (stmt);
+  if (!op_with_boolean_value_range_p (op1))
+return false;
 
-  /* Reduce number of cases to handle.  */
-  if (is_gimple_min_invariant (op1))
-{
-  if (!integer_zerop (op1)
- && !integer_onep (op1)
- && !integer_all_onesp (op1))
-   return false;
-
-  /* Limit the number of cases we have to consider.  */
-  if (rhs_code == EQ_EXPR)
-   {
- rhs_code = NE_EXPR;
- /* OP1 is a constant.  */
- op1 = fold_unary (TRUTH_NOT_EXPR, TREE_TYPE (op1), op1);
-   }
-}
-  else
-{
-  /* Punt on A == B as there is no BIT_XNOR_EXPR.  */
-  if (rhs_code == EQ_EXPR)
-   return false;
-
-  if (TYPE_PRECISION (TREE_TYPE (op1)) != 1)
-   {
- vr = get_value_range (op1);
- val = compare_range_with_value (GE_EXPR, vr, integer_zero_node, &sop);
- if (!val || !integer_onep (val))
-   return false;
-
- val = compare_range_with_value (LE_EXPR, vr, integer_one_node, &sop);
- if (!val || !integer_onep (val))
-   return false;
-   }
-}
-
-  if (sop && issue_strict_overflow_warning (WARN_STRICT_OVERFLOW_MISC))
+  /* Reduce number of cases to handle to NE_EXPR.  As there is no
+ BIT_XNOR_EXPR we cannot replace A == B with a single statement.  */
+  if (rhs_code == EQ_EXPR)
 {
-  location_t location;
-
-  if (!gimple_has_location (stmt))
-   location = input_location;
+  if (TREE_CODE (op1) == INTEGER_CST)
+   op1 = int_const_binop (BIT_XOR_EXPR, op1, integer_one_node);
   else
-   location = gimple_location (stmt);
-
-  warning_at (location, OPT_Wstrict_overflow,
- _("assuming signed overflow does not occur when "
-   "simplifying ==, != or ! to identity or ^"));
+   return false;
 }
 
-  need_conversion =
-!useless_type_conversion_p (TREE_TYPE (gimple_assign_lhs (stmt)),
-   TREE_TYPE (op0));
+  lhs = gimple_assign_lhs (stmt);
+  need_conversion
+= !useless_type_conversion_p (TREE_TYPE (lhs), TREE_TYPE (op0));
 
-  /* Make sure to not sign-extend -1 as a boolean value.  */
+  /* Make sure to not sign-extend a 1-bit 1 when converting the result.  */
   if (need_conversion
   && !TYPE_UNSIGNED (TREE_TYPE (op0))
-  && TYPE_PRECISION (TREE_TYPE (op0)) =

Re: [Patch, Fortran] (Coarray) Fix constraint checks for LOCK_TYPE

[Mikael Morin]

On Thursday 04 August 2011 15:18:46 Tobias Burnus wrote:
> >> The problem is that
> >> diagnosing the problem can get rather difficult. For instance:
> >> 
> >> type t
> >> type(lock_type) :: C
> >> end type
> >> type t2
> >> type(t), allocatable :: B
> >> end type t2
> >> type t3
> >> type(t2) :: D
> >> end type t3
> >> 
> >> is valid - however, it is invalid to use:
> >> type(t) :: x[*], y
> >> 
> >> However, how to write then the error message? "Error: Invalid
> >> declaration at (1) as constraint C642 is violated" is probably not very
> >> helpful, but should one really re-resolve the derived type?
> > 
> > I would write:
> > Variable at  shall be a coarray/have a codimension attribute as it has
> > a non-coarray subcomponent of type LOCK_TYPE at
> 
> But that error message would be very surprising for me as a user if I
> had written:
> 
>type(t) :: x[*]
In that case you wouldn't have this error, but you could still have some other 
errors coming from other rules. 


> > Best would be to have the full reference y%d%b%c in the error message.
> 
> I think that works not well in the current scheme as one would have to
> store this information somewhere. Either, one resolves from the outside
> to the inside: Resolve "x", which resolves "x%D", which resolves
> "x%D%B"  - and when resolving "B" the "x%D%" part is not available. Or
> one stores that "B" is invalid, then one propagates this information on
> to "D" and then to "x" - at that point one knows that "x" is invalid -
> but the information that it is due to "x%D%B" is lost.
> 
> Additionally, for the example above, should it be "x%D%B" or x%D%B%C or
> ...?
> 
> That's not unsolvable but requires quite some restructuring.
Yes, it was just a thought.

> 
> > Thus, we should stick closely to the standard, point exactly what is
> > prohibited, and not bother too much trying to provide some hints to the
> > users. ;-)
> 
> Exactly: "ERROR: C642"
> 
> Would be the most correct error message, without bothering with the
> error location, variable name - and it also contains the 42. Or even
> better "ERROR: Violating Fortran 2008 standard" ;-)
> 
> If we want to really stick close to the standard, I would propose to add
> an attr.lock_c642_violated to the derived types and check for it later
> in resolve_symbol :P.
> 
> > OK, it is starting to make sense now.
> > I'm not very fond of it, but if you want to keep this diagnostic, at the
> > very least put all that information in a comment. Best would be to
> > provide it (or some of it) in the error message too.
> 
> I made three attempts to get the LOCK_TYPE diagnostics kind of right. I
> can also do a fourth attempt, if it is cleaner or for some other reason
> better. However, I only do it if I get a clear outline how it should be
> done, i.e. which information is stored where, where it is obtained and
> how the error message should roughly look like.
> 
> The problem with the wording is that the constraint itself is not
> directly checkable but that one has to do it in a slightly convoluted
> way. Actually, the standard does the same: Certain things are prohibited
> as one bumps into other constraints if one tries to sneak past the
> constraint.
My point is we should let the user bump himself into other constraints and 
figure out what is right. 

> 
> I do not mind having something better, but coming up with some concise
> but still correct - and helpful! - comment is not that simple.
> 
> >> Having said that, I just realized that the following program is not
> > 
> >> rejected but it should:
> > That's exactly the reason why I don't like it. It's sufficiently
> > difficult to get it right while sticking closely to the standard that
> > one doesn't want to try picking one rule every 40 pages and see what is
> > left after intersecting them.
> 
> Sorry, I cannot follow. The standard does not have constraint C123456789
> saying that it is invalid. The invalidity comes the combination of
> several constrains and definitions. 
My point is we should diagnose the constraints, not the combination of them...

> That makes it difficult to spot all the cases which are (in)valid,
...for exactly this reason.

> but I do not see how one can prevent it.
> Thus, I claim I am "sticking closely to the standard" by rejecting the
> invalid code.
> 
> I agree that the wording could be better - but it is also difficult to
> write it in such a way that it helps a user when debugging a code as
> there might be different reason for the mistake.
> 
> Furthermore, I have stared too long at the code to be apt to find good
> wordings, thus, I am happy for suggestions for better comments and error
> messages.
I'll propose some.

Mikael

Re: [RFC PATCH] Allow user specs files to add self_spec

[Joseph S. Myers]

On Wed, 3 Aug 2011, Jakub Jelinek wrote:

> 2011-08-03  Jakub Jelinek  
> 
>   * gcc.c (self_spec): New variable.
>   (static_specs): Add self_spec.
>   (main): Call do_self_spec on "self_spec" specs after reading
>   user specs files.  Move compare_debug handling right after that.

OK.

-- 
Joseph S. Myers
jos...@codesourcery.com

[Patch, Fortran] Coarrays: Add/fix check for no coarrays as result value

[Tobias Burnus]

This patch fixes the result check for coarrays / variables with coarray 
subcomponents. It was working with a separate RESULT() variable - but 
not if the function name was the result variable.


Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
2011-08-04  Tobias Burnus  

	* resolve.c (resolve_symbol): Fix coarray result-var check.

2011-08-04  Tobias Burnus  

	* gfortran.dg/coarray_26.f90: New.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b8a8ebb..4401ea5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -12440,10 +12440,10 @@ resolve_symbol (gfc_symbol *sym)
 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
 	   "INTENT(OUT)", sym->name, &sym->declared_at);
 
-  /* F2008, C526.  */
+  /* F2008, C525.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| sym->attr.codimension)
-  && sym->attr.result)
+  && (sym->attr.result || sym->result == sym))
 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
 	   "a coarray component", sym->name, &sym->declared_at);
 
--- /dev/null	2011-08-04 08:03:55.531886509 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_26.f90	2011-08-04 16:33:40.0 +0200
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Coarray declaration constraint checks
+!
+
+function foo3a() result(res)
+  implicit none
+  integer :: res
+  codimension :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" }
+end
+
+function foo2a() result(res)
+  integer :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" }
+end
+
+function fooa() result(res) ! { dg-error "shall not be a coarray or have a coarray component" }
+  implicit none
+  type t
+integer, allocatable :: A[:]
+  end type t
+  type(t):: res
+end
+
+function foo3() ! { dg-error "shall not be a coarray or have a coarray component" }
+  implicit none
+  integer :: foo3
+  codimension :: foo3[*]
+end
+
+function foo2() ! { dg-error "shall not be a coarray or have a coarray component" }
+  implicit none
+  integer :: foo2[*]
+end
+
+function foo() ! { dg-error "shall not be a coarray or have a coarray component" }
+  type t
+integer, allocatable :: A[:]
+  end type t
+  type(t):: foo
+end
+
+subroutine test()
+  use iso_c_binding
+  implicit none
+  type(c_ptr), save :: caf[*] ! { dg-error "shall not be a coarray" }
+end subroutine test
+
+subroutine test2()
+  use iso_c_binding
+  implicit none
+  type(c_funptr), save :: caf[*] ! { dg-error "shall not be a coarray" }
+end subroutine test2

[Ada] Detect generics as violation of the SPARK restriction

[Arnaud Charlet]

When the SPARK restriction was set, GNAT was not issuing violations on generic.
Now corrected.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Marc Sango  

* sem_ch12.adb (Analyze_Generic_Package_Declaration,
Analyze_Generic_Subprogram_Declaration, Analyze_Package_Instantiation,
Analyze_Subprogram_Instantiation): Check absence of generic in SPARK
mode.

Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 177384)
+++ sem_ch12.adb(working copy)
@@ -2690,6 +2690,8 @@
   Decl: Node_Id;
 
begin
+  Check_SPARK_Restriction ("generic is not allowed", N);
+
   --  We introduce a renaming of the enclosing package, to have a usable
   --  entity as the prefix of an expanded name for a local entity of the
   --  form Par.P.Q, where P is the generic package. This is because a local
@@ -2811,6 +2813,8 @@
   Typ : Entity_Id;
 
begin
+  Check_SPARK_Restriction ("generic is not allowed", N);
+
   --  Create copy of generic unit, and save for instantiation. If the unit
   --  is a child unit, do not copy the specifications for the parent, which
   --  are not part of the generic tree.
@@ -3051,6 +3055,8 @@
--  Start of processing for Analyze_Package_Instantiation
 
begin
+  Check_SPARK_Restriction ("generic is not allowed", N);
+
   --  Very first thing: apply the special kludge for Text_IO processing
   --  in case we are instantiating one of the children of [Wide_]Text_IO.
 
@@ -4195,6 +4201,8 @@
--  Start of processing for Analyze_Subprogram_Instantiation
 
begin
+  Check_SPARK_Restriction ("generic is not allowed", N);
+
   --  Very first thing: apply the special kludge for Text_IO processing
   --  in case we are instantiating one of the children of [Wide_]Text_IO.
   --  Of course such an instantiation is bogus (these are packages, not

[Ada] Remove C output of gnatbind

[Arnaud Charlet]

It is not possible anymore to generate the C version of
the binder file.  Switches -A and -C of gnatbind are now
removed.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Tristan Gingold  

* bindgen.adb (Gen_Adainit_C): Remove.
(Gen_Adafinal_C): Ditto.
(Gen_Elab_Externals_C): Ditto.
(Gen_Elab_Calls_C): Ditto.
(Gen_Elab_Order_C): Ditto.
(Gen_Elab_Defs_C): Ditto.
(Gen_Finalize_Library_C): Ditto.
(Gen_Finalize_Library_Defs_C): Ditto.
(Gen_Main_C): Ditto.
(Gen_Output_File_C): Ditto.
(Gen_Restrictions_C): Ditto.
(Gen_Versions_C): Ditto.
(Write_Info_Ada_C): Ditto.
(Gen_Object_Files_Options): Call WBI instead of Write_Info_Ada_C
(Gen_Output_File): Do not force Ada_Bind_File anymore.
Always call Gen_Output_File_Ada.
* gnatlink.adb (Begin_Info): Now a constant.
(End_Info): Ditto.
(Ada_Bind_File): Remove
(Process_Args): Do not handle -A/-C.  Remove not Ada_Bind_File cases.
* switch-b.adb (Scan_Binder_Switches): Do not handle -C.
* gnatbind.adb (Gnatbind): Remove not Ada_Bind_File cases.
opt.ads (Ada_Bind_File): Remove.

Index: bindgen.adb
===
--- bindgen.adb (revision 177388)
+++ bindgen.adb (working copy)
@@ -240,54 +240,27 @@
procedure Gen_Adainit_Ada;
--  Generates the Adainit procedure (Ada code case)
 
-   procedure Gen_Adainit_C;
-   --  Generates the Adainit procedure (C code case)
-
procedure Gen_Adafinal_Ada;
--  Generate the Adafinal procedure (Ada code case)
 
-   procedure Gen_Adafinal_C;
-   --  Generate the Adafinal procedure (C code case)
-
procedure Gen_Elab_Externals_Ada;
--  Generate sequence of external declarations for elaboration (Ada)
 
-   procedure Gen_Elab_Externals_C;
-   --  Generate sequence of external declarations for elaboration (C)
-
procedure Gen_Elab_Calls_Ada;
--  Generate sequence of elaboration calls (Ada code case)
 
-   procedure Gen_Elab_Calls_C;
-   --  Generate sequence of elaboration calls (C code case)
-
procedure Gen_Elab_Order_Ada;
--  Generate comments showing elaboration order chosen (Ada code case)
 
-   procedure Gen_Elab_Order_C;
-   --  Generate comments showing elaboration order chosen (C code case)
-
-   procedure Gen_Elab_Defs_C;
-   --  Generate sequence of definitions for elaboration routines (C code case)
-
procedure Gen_Finalize_Library_Ada;
--  Generate a sequence of finalization calls to elaborated packages (Ada)
 
-   procedure Gen_Finalize_Library_C;
-   --  Generate a sequence of finalization calls to elaborated packages (C)
-
-   procedure Gen_Finalize_Library_Defs_C;
-   --  Generate a sequence of defininitions for package finalizers (C case)
-
procedure Gen_CodePeer_Wrapper;
--  For CodePeer, generate wrapper which calls user-defined main subprogram
 
procedure Gen_Main_Ada;
--  Generate procedure main (Ada code case)
 
-   procedure Gen_Main_C;
-   --  Generate main() procedure (C code case)
-
procedure Gen_Object_Files_Options;
--  Output comments containing a list of the full names of the object
--  files to be linked and the list of linker options supplied by
@@ -296,21 +269,12 @@
procedure Gen_Output_File_Ada (Filename : String);
--  Generate output file (Ada code case)
 
-   procedure Gen_Output_File_C (Filename : String);
-   --  Generate output file (C code case)
-
procedure Gen_Restrictions_Ada;
--  Generate initialization of restrictions variable (Ada code case)
 
-   procedure Gen_Restrictions_C;
-   --  Generate initialization of restrictions variable (C code case)
-
procedure Gen_Versions_Ada;
--  Output series of definitions for unit versions (Ada code case)
 
-   procedure Gen_Versions_C;
-   --  Output series of definitions for unit versions (C code case)
-
function Get_Ada_Main_Name return String;
--  This function is used in the Ada main output case to compute a usable
--  name for the generated main program. The normal main program name is
@@ -400,10 +364,6 @@
--  up all output unit numbers nicely as required by the value, and
--  by the total number of units.
 
-   procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
-   --  For C code case, write C & Common, for Ada case write Ada & Common
-   --  to current binder output file using Write_Binder_Info.
-
procedure Write_Statement_Buffer;
--  Write out contents of statement buffer up to Last, and reset Last to 0
 
@@ -478,32 +438,6 @@
   WBI ("");
end Gen_Adafinal_Ada;
 
-   
-   -- Gen_Adafinal_C --
-   
-
-   procedure Gen_Adafinal_C is
-   begin
-  WBI ("void " & Ada_Final_Name.all & " (void) {");
-
-  WBI ("   if (!is_elaborated)");
-  WBI ("  return;");
-  WBI ("   is_elaborated = 0;");
-
-  if not Bind

[Ada] Implementation of AI05-0161 restriction No_Default_Stream_Attributes

[Arnaud Charlet]

This new restriction is intended to prevent the use of the predefined stream
attributes for elementary types. A consequence of this restriction is that
the default implementation of stream attributes for composite types cannot
be created if any of its elementary components lacks user-defined Read and
Write attributes. 

Given the following configuration file:

pragma Restrictions (No_Default_Stream_Attributes);

Then the following must compile quietly:
---
   with Stdarg;
   procedure Main is
   begin
  null;
   end Main;
---
and the following must execute quietly:

   with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
   procedure Stream_Test is
  --  Check that when restriction No_Default_Stream_Attributes is active,
  --  stream operations on composite types are usable if the type of their
  --  elementary components have user-defined stream operations.

  type Count is new Integer;
  procedure Dump_It
(S : not null access Ada.Streams.Root_Stream_Type'Class; It : Count);
  for Count'Write use Dump_It;

  procedure Grab_It
   (S : not null access Ada.Streams.Root_Stream_Type'Class; It : out Count);
  for Count'Read use Grab_It;
   
  type Rec is record
 Value : Count;
  end record;

  procedure Dump_It
(S : not null access Ada.Streams.Root_Stream_Type'Class; It : Count) is
  begin
 String'Output (S, Count'Image (It));
  end;

  procedure Grab_It
(S : not null access Ada.Streams.Root_Stream_Type'Class; It : out Count)
  is
  begin
 It := Count'Value (String'Input (S));
  end Grab_It;

  Rec_File : File_Type;
  S : Stream_Access;
  Obj : Rec := (Value => -1234);
  Recovered : Rec;
   begin
  Create (Rec_File, Name => "temp");
  S := Stream (Rec_File);
  Rec'Output (S, Obj);
  Close (Rec_File);

  Open (Rec_File, Name => "temp",  Mode => In_File);
  Recovered := Rec'Input (S);

  if Obj /= Recovered then
 raise Program_Error;
  end if;
   end;
---
After commenting out any of the attribute definitions above, compilation of
stream_test.adb must yield: 

stream_test.adb:39:07:
   violation of restriction "No_Default_Stream_Attributes" at gnat.adc:1

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Ed Schonberg  

* exp_ch3.adb (Stream_Operation_Ok): new predicate
Needs_Elementary_Stream_Operation, to determine whether user-defined
Read and Write attributes are available for the elementary components
of the given type. If only the predefined attributes are available,
then when restriction No_Default_Stream_Attributes is active the
predefined stream attributes for the composite type cannot be created.

Index: exp_ch3.adb
===
--- exp_ch3.adb (revision 177387)
+++ exp_ch3.adb (working copy)
@@ -8964,7 +8964,60 @@
is
   Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
 
+  function Needs_Elementary_Stream_Operation
+(T : Entity_Id) return Boolean;
+  --  AI05-0161 : if the restriction No_Default_Stream_Attributes is active
+  --  then we can generate stream subprograms for records that have scalar
+  --  subcomponents only if those subcomponents have user-defined stream
+  --  subprograms. For elementary types only 'Read and 'Write are needed.
+
+  ---
+  -- Needs_Elementary_Stream_Operation --
+  ---
+
+  function Needs_Elementary_Stream_Operation
+(T : Entity_Id) return Boolean
+  is
+  begin
+ if not Restriction_Active (No_Default_Stream_Attributes) then
+return False;
+
+ elsif Is_Elementary_Type (T) then
+return No (TSS (T, TSS_Stream_Read))
+  or else No (TSS (T, TSS_Stream_Write));
+
+ elsif Is_Array_Type (T) then
+return Needs_Elementary_Stream_Operation (Component_Type (T));
+
+ elsif Is_Record_Type (T) then
+declare
+   Comp : Entity_Id;
+
+begin
+   Comp := First_Component (T);
+   while Present (Comp) loop
+  if Needs_Elementary_Stream_Operation (Etype (Comp)) then
+ return True;
+  end if;
+  Next_Component (Comp);
+   end loop;
+   return False;
+end;
+
+ elsif Is_Private_Type (T)
+   and then Present (Full_View (T))
+ then
+return Needs_Elementary_Stream_Operation (Full_View (T));
+
+ else
+return False;
+ end if;
+  end Needs_Elementary_Stream_Operation;
+
+   --  Start processing for Stream_Operation_OK
+
begin
+
   --  Special case of a limited type extension: a default implementation
   --  of the stream attri

[Ada]Fix GNAT compilation error when SPARK restriction mode is set

[Arnaud Charlet]

GNAT compilation error when SPARK restriction mode was set with attribut 
reference violation is now correct.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Marc Sango  

* sem_attr.adb (Analyze_Attribute): Replace the message
"invisible attribute of}" of the spark restriction violation in
attribute reference by the simple message "invisible attribute of type".
Indeed, the node value Error_Msg_Node_1 used is in conflit with the
two insertion characters: '&' and '}'.

Index: sem_attr.adb
===
--- sem_attr.adb(revision 177384)
+++ sem_attr.adb(working copy)
@@ -2068,8 +2068,7 @@
 and then not In_Open_Scopes (Scope (P_Type))
 and then not In_Spec_Expression
   then
- Error_Msg_Node_1 := First_Subtype (P_Type);
- Check_SPARK_Restriction ("invisible attribute of}", N);
+ Check_SPARK_Restriction ("invisible attribute of type", N);
   end if;
 
   --  Remaining processing depends on attribute

[Ada] AI05-0069 : Holder container

[Arnaud Charlet]

This AI defines a package Ada.Containers.Indefinite_Holders in order
to create the ability to hold a single object of an indefinite type. 

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Vadim Godunko  

* impunit.adb (Non_Imp_File_Names_12): Add "a-coinho".
* a-coinho.ads, a-coinho.adb: New file.
* Makefile.rtl: Add Ada.Containers.Indefinite_Holders.

Index: a-coinho.adb
===
--- a-coinho.adb(revision 0)
+++ a-coinho.adb(revision 0)
@@ -0,0 +1,282 @@
+--
+--  --
+-- GNAT LIBRARY COMPONENTS  --
+--  --
+--   A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S--
+--  --
+-- B o d y  --
+--  --
+-- Copyright (C) 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+--  --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.   --
+--  --
+-- You should have received a copy of the GNU General Public License and--
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see--
+-- .  --
+--
+
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Indefinite_Holders is
+
+   procedure Free is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+   -
+   -- "=" --
+   -
+
+   function "=" (Left, Right : Holder) return Boolean is
+   begin
+  if Left.Element = null and Right.Element = null then
+ return True;
+
+  elsif Left.Element /= null and Right.Element /= null then
+ return Left.Element.all = Right.Element.all;
+
+  else
+ return False;
+  end if;
+   end "=";
+
+   
+   -- Adjust --
+   
+
+   overriding procedure Adjust (Container : in out Holder) is
+   begin
+  if Container.Element /= null then
+ Container.Element := new Element_Type'(Container.Element.all);
+  end if;
+
+  Container.Busy := 0;
+   end Adjust;
+
+   
+   -- Assign --
+   
+
+   procedure Assign (Target : in out Holder; Source : Holder) is
+   begin
+  if Target.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+  end if;
+
+  if Target.Element /= Source.Element then
+ Free (Target.Element);
+
+ if Source.Element /= null then
+Target.Element := new Element_Type'(Source.Element.all);
+ end if;
+  end if;
+   end Assign;
+
+   ---
+   -- Clear --
+   ---
+
+   procedure Clear (Container : in out Holder) is
+   begin
+  if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+  end if;
+
+  Free (Container.Element);
+   end Clear;
+
+   --
+   -- Copy --
+   --
+
+   function Copy (Source : Holder) return Holder is
+   begin
+  if Source.Element = null then
+ return (AF.Controlled with null, 0);
+
+  else
+ return (AF.Controlled with new Element_Type'(Source.Element.all), 0);
+  end if;
+   end Copy;
+
+   -
+   -- Element --
+   -
+
+   function Element (Container : Holder) return Element_Type is
+   begin
+  if Container.Element = null then
+ raise Constraint_Error with "container is empty";
+
+  else
+ return Container.Element.all;
+  end if;
+   end Element;
+
+   --
+   -- Finalize --
+   --
+

Re: [AVR] Fix target/34888

[Richard Henderson]

On 08/03/2011 11:09 PM, Denis Chertykov wrote:
> 2011/8/4 Richard Henderson :
>> When a frame pointer is in use, we can optimize popping all
>> queued parameters via a simple move from the frame pointer
>> instead of an addition to the stack pointer.
>>
>> The new sequence is 4 insns, the old sequence was 9 insns.
>>
>> Committed.
> 
> It seems strange for me:
> +;; Notice a special-case when adding N to SP where N results in a
> +;; zero REG_ARGS_SIZE.  This is equivalent to a move from FP.
> +(define_split
> +  [(set (reg:HI REG_SP) (match_operand:HI 0 "register_operand" ""))]
> +  "reload_completed
> +   && frame_pointer_needed
> +   && !cfun->calls_alloca
> +   && find_reg_note (insn, REG_ARGS_SIZE, const0_rtx)"
> +  [(set (reg:HI REG_SP) (reg:HI REG_Y))]
> +  "")
> 
> What is it ? ... It's a transition from SP = general-register to
> SP = REG_Y with set of conditions.
> Generally, it's seems wrong (SP = REG) isn't equal to (SP = REG_Y).

The old sequence is

(set tmp SP)
(set tmp (plus tmp const_int))
(set SP tmp)

Because of the REG_ARGS_SIZE note being 0, we know that
this is popping all arguments off the stack.

The other conditions, frame pointer existing, and no
calls to alloca, mean that we know exactly what the
result of the addition is -- the contents of FP.

So we transform to

(set tmp SP)
(set tmp (plus tmp const_int))
(set SP FP)

and let the first two insns be deleted as dead code.



r~

[Ada] Get gnatls project path from Prj.Env

[Arnaud Charlet]

This change removes circuitry in gnatls that tried to approximate what
is done in Prj.Env.Initialize_Default_Project_Path to set the project
search path, and instead uses that routine directly. This fixes an
inconsistency between gnatls' output and the actual behaviour of
other project aware tools, and ensures that no such inconsistency will
re-appear in the future.

Test case:

$ export GPR_PROJECT_PATH=titi
$ export ADA_PROJECT_PATH=toto
$ gnatls -v

The listed project search directories must be:

   
   /titi
   /toto
   //lib/gnat
   /share/gpr
   /lib/gnat

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Thomas Quinot  

* gnatls.adb: Use Prj.Env.Initialize_Default_Project_Path to retrieve
the project path.

Index: gnatls.adb
===
--- gnatls.adb  (revision 177400)
+++ gnatls.adb  (working copy)
@@ -36,6 +36,7 @@
 with Osint;   use Osint;
 with Osint.L; use Osint.L;
 with Output;  use Output;
+with Prj.Env; use Prj.Env;
 with Rident;  use Rident;
 with Sdefault;
 with Snames;
@@ -47,12 +48,6 @@
 procedure Gnatls is
pragma Ident (Gnat_Static_Version_String);
 
-   Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
-   Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
-   --  Names of the env. variables that contains path name(s) of directories
-   --  where project files may reside. If GPR_PROJECT_PATH is defined, its
-   --  value is used, otherwise ADA_PROJECT_PATH is used, if defined.
-
--  NOTE : The following string may be used by other tools, such as GPS. So
--  it can only be modified if these other uses are checked and coordinated.
 
@@ -60,7 +55,7 @@
--  Label displayed in verbose mode before the directories in the project
--  search path. Do not modify without checking NOTE above.
 
-   No_Project_Default_Dir : constant String := "-";
+   Prj_Path : Prj.Env.Project_Search_Path;
 
Max_Column : constant := 80;
 
@@ -223,7 +218,7 @@
   end if;
end Add_Lib_Dir;
 
-   -- -
+   
-- Add_Source_Dir --

 
@@ -1614,28 +1609,17 @@
   Write_Str ("   ");
   Write_Eol;
 
-  --  The code below reproduces Prj.Env.Initialize_Default_Project_Path,
-  --  shouldn't we reuse that instead???
+  Initialize_Default_Project_Path
+(Prj_Path, Target_Name => Sdefault.Target_Name.all);
 
   declare
- Project_Path : String_Access := Getenv (Gpr_Project_Path);
+ Project_Path : String_Access;
+ First: Natural;
+ Last : Natural;
 
- Lib : constant String :=
- Directory_Separator & "lib" & Directory_Separator;
-
- First : Natural;
- Last  : Natural;
-
- Add_Default_Dir : Boolean := True;
- Prefix_Name_Len : Integer;
-
   begin
- --  If there is a project path, display each directory in the path
+ Get_Path (Prj_Path, Project_Path);
 
- if Project_Path.all = "" then
-Project_Path := Getenv (Ada_Project_Path);
- end if;
-
  if Project_Path.all /= "" then
 First := Project_Path'First;
 loop
@@ -1654,87 +1638,23 @@
   Last := Last + 1;
end loop;
 
-   --  If the directory is No_Default_Project_Dir, set
-   --  Add_Default_Dir to False.
+   if First /= Last or else Project_Path (First) /= '.' then
 
-   if Project_Path (First .. Last) = No_Project_Default_Dir then
-  Add_Default_Dir := False;
-
-   elsif First /= Last or else Project_Path (First) /= '.' then
-
   --  If the directory is ".", skip it as it is the current
   --  directory and it is already the first directory in the
   --  project path.
 
   Write_Str ("   ");
   Write_Str
-(To_Host_Dir_Spec
-   (Project_Path (First .. Last), True).all);
+(Normalize_Pathname
+  (To_Host_Dir_Spec
+(Project_Path (First .. Last), True).all));
   Write_Eol;
end if;
 
First := Last + 1;
 end loop;
  end if;
-
- --  Add the default dir, except if "-" was one of the "directories"
- --  specified in ADA_PROJECT_DIR.
-
- if Add_Default_Dir then
-Name_Len := 0;
-Add_Str_To_Name_Buffer (Sdefault.Search_Dir_Prefix.all);
-
---  On Windows, make sure that all directory separators are '\'
-
-if Directory_Separator /= '/' then
-   for J in 1 .. Name_Len loop
-  if Name_Buffer (J) = '/' then
- Name_Buffer (J) := Directory_Separator;
-  end if;
-   end loop;
-   

Re: [PATCH 3/7] Emit macro expansion related diagnostics

[Dodji Seketeli]

Hello,

Below is an amended version of this patch after Jason's comments at
http://gcc.gnu.org/ml/gcc-patches/2011-08/msg00099.html.

From: Dodji Seketeli 
Date: Sat, 4 Dec 2010 16:31:35 +0100
Subject: [PATCH 3/7] Emit macro expansion related diagnostics

In this third instalment the diagnostic machinery -- when faced with
the virtual location of a token resulting from macro expansion -- uses
the new linemap APIs to unwind the stack of macro expansions that led
to that token and emits a [hopefully] more useful message than what we
have today.

diagnostic_report_current_module has been slightly changed to use the
location given by client code instead of the global input_location
variable. This results in more precise diagnostic locations in general
but then the patch adjusts some C++ tests which output changed as a
result of this.

Three new regression tests have been added.

The mandatory screenshot goes like this:

[dodji@adjoa gcc]$ cat -n test.c
 1#define OPERATE(OPRD1, OPRT, OPRD2) \
 2  OPRD1 OPRT OPRD2;
 3
 4#define SHIFTL(A,B) \
 5  OPERATE (A,<<,B)
 6
 7#define MULT(A) \
 8  SHIFTL (A,1)
 9
10void
11g ()
12{
13  MULT (1.0);/* 1.0 << 1; <-- so this is an error.  */
14}

[dodji@adjoa gcc]$ ./cc1 -quiet -ftrack-macro-expansion test.c
test.c: In function ‘g’:
test.c:5:14: erreur: invalid operands to binary << (have ‘double’ and ‘int’)
test.c:2:9: note: in expansion of macro 'OPERATE'
test.c:5:3: note: expanded from here
test.c:5:14: note: in expansion of macro 'SHIFTL'
test.c:8:3: note: expanded from here
test.c:8:3: note: in expansion of macro 'MULT2'
test.c:13:3: note: expanded from here

The combination of this patch and the previous ones boostrapped with
--enable-languages=all,ada and passed regression tests on
x86_64-unknown-linux-gnu.

gcc/
* gcc/diagnostic.h (diagnostic_report_current_module): Add a
location parameter.
* diagnostic.c (diagnostic_report_current_module): Add a location
parameter to the function definition.  Use it instead of
input_location.  Resolve the virtual location rather than just
looking up its map and risking to touch a resulting macro map.
(default_diagnostic_starter): Pass the relevant diagnostic
location to diagnostic_report_current_module.
* tree-diagnostic.c (maybe_unwind_expanded_macro_loc): New.
(virt_loc_aware_diagnostic_finalizer): Likewise.
(diagnostic_report_current_function): Pass the
relevant location to diagnostic_report_current_module.
* tree-diagnostic.h (virt_loc_aware_diagnostic_finalizer): Declare
new function.
* toplev.c (general_init): By default, use the new
virt_loc_aware_diagnostic_finalizer as diagnostic finalizer.

gcc/cp/

* error.c (cp_diagnostic_starter): Pass the relevant location to
diagnostic_report_current_module.
(cp_diagnostic_finalizer): Call virt_loc_aware_diagnostic_finalizer.

gcc/testsuite/

* gcc.dg/cpp/macro-exp-tracking-1.c: New test.
* gcc.dg/cpp/macro-exp-tracking-2.c: Likewise.
* gcc.dg/cpp/macro-exp-tracking-3.c: Likewise.
* gcc.dg/cpp/pragma-diagnostic-2.c: Likewise.
* g++.dg/cpp0x/initlist15.C: Discard errors pointing at multiple
levels of included files.
* g++.old-deja/g++.robertl/eb43.C: Likewise.
* g++.old-deja/g++.robertl/eb79.C: Likewise.
* gcc.target/i386/sse-vect-types.c: Likewise.
---
 gcc/Makefile.in |2 +-
 gcc/cp/error.c  |5 +-
 gcc/diagnostic.c|   14 ++-
 gcc/diagnostic.h|2 +-
 gcc/testsuite/g++.dg/cpp0x/initlist15.C |1 +
 gcc/testsuite/g++.old-deja/g++.robertl/eb43.C   |4 +
 gcc/testsuite/g++.old-deja/g++.robertl/eb79.C   |4 +
 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-1.c |   21 +++
 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-2.c |   21 +++
 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-3.c |   14 ++
 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-4.c |   14 ++
 gcc/testsuite/gcc.dg/cpp/pragma-diagnostic-2.c  |   34 +
 gcc/testsuite/gcc.target/i386/sse-vect-types.c  |6 +
 gcc/toplev.c|3 +
 gcc/tree-diagnostic.c   |  176 ++-
 gcc/tree-diagnostic.h   |3 +-
 16 files changed, 313 insertions(+), 11 deletions(-)
 create mode 100644 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-1.c
 create mode 100644 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-2.c
 create mode 100644 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-3.c
 create mode 100644 gcc/testsuite/gcc.dg/cpp/macro-exp-tracking-4.c
 create mode 100644 gcc/testsuite/gcc.dg/cpp/pragma-diagnostic-2.c

diff --git a/gcc/Makefile.in b/gcc/Makefile.in
index 116a70b..2dae39d 100644
--- a

Re: [trans-mem] New TM method: serial-irrevocable on first write

[Richard Henderson]

On 08/03/2011 03:56 AM, Torvald Riegel wrote:
> Add serialirr_onwrite_dispatch and use as new default method, for now.
> 
>   * retry.cc (GTM::gtm_transaction::decide_begin_dispatch): Use
>   serialirr_onwrite_dispatch as new default for now.
>   * method-serial.cc (serialirr_onwrite_dispatch): New.
>   (GTM::dispatch_serialirr_onwrite): New.
>   * libitm_i.h: Same.

Ok.


r~

[pph] Add initial support for including nested pph images (issue4847044)

[Diego Novillo]

This patch adds initial support for PPH images that include other PPH
images.  Currently, we support this but it is inefficient.  When a
parent image includes a child image, the parent embeds all the
contents of the child in its image.  This is a waste of space.

There is one other missing piece for this to work, however.  We need
to change the way references work.  Currently, they are simply an
offset into the streamer cache, which is created for every file we
open.  When we have images including other images, the references to
symbols in another file's symbol table should be 2-dimensional.

I am currently adding that support, but this will be more intrusive,
so I'm flushing this out first.

The main changes:

- Add a symbol table in every stream (field symtab in pph_stream).
  This supports efficient searches using a pointer set and has the
  symbols arranged in declaration order.

- Initialize PPH support before the parser starts.  This is needed to
  allow the parser to register symbols into the PPH symbol table for
  the image that we are currently generating.

- New stream flags to determine whether the stream is currently open,
  nested images and a table of included images.

There is a pretty big potential change in the order in which files are
included.  Suppose we have file parent.h:

 parent.h --
int X;
class A { ... };
#include "child.pph"
TypeFromChild L;


When parent and child are converted to pph images, the image child.pph
will be read *before* any of the contents of parent.pph.  We already
require child.pph to not depend on any content from the outside, but
child.pph could alter macros defined and used by parent.h before the
original inclusion.  The plan for now is to disallow this.

Tested on x86_64.


Diego.

cp/ChangeLog.pph

* parser.c (cp_lexer_new_main): Move call to pph_init ...
(c_parse_file): ... here.
Call pph_finish only if pph_enabled_p returns true.
* pph-streamer-in.c (pph_in_includes): New.
(pph_read_file_contents): Call it.
(pph_read_file): Call pph_add_include.
* pph-streamer-out.c (current_pph_file): Remove.  Update all users.
(decls_to_register_t) Likewise.
(decls_to_register): Likewise.
(pph_out_stream): Declare.
(pph_out_symtab_marker): Assert that the MARKER fits in an
unsigned char.
(pph_out_includes): New.
(pph_write_file): Make static.  Assume that STREAM is opened and
closed by the caller.
(pph_add_include): New.
(pph_writer_init): Open pph_out_file into pph_out_stream.
(pph_writer_finish): Close pph_out_stream.  Call pph_write_file
if no errors were found.
(pph_add_decl_to_symtab): Rename from pph_add_decl_to_register.
Update all users.
* pph-streamer.c (pph_stream_open): Tidy.
Initialize stream->symtab.
(pph_stream_close_1): Factor out of ...
(pph_stream_close): ... here.
Only call pph_stream_close_1 if STREAM is not nested in another
PPH file.
* pph-streamer.h (struct pph_symtab): Declare.
(pph_stream_ptr): Declare.
(struct pph_stream): Add fields open_p, nested_p, symtab
and includes.
(pph_add_decl_to_symtab): Declare.
(pph_add_include): Declare.
(pph_writer_init): Declare.
(pph_writer_finish): Declare.
* pph.c (pph_init): Call pph_writer_init if pph_out_file is set.
(pph_finish): Call pph_writer_finish if pph_out_file is set.
* pph.h (pph_enabled_p): New.

testsuite/ChangeLog.pph:

* g++.dg/pph/c1pr44948-1a.cc: Use the same flags as the header file.
Mark fixed.

diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c
index 5896688..3b312d3 100644
--- a/gcc/cp/decl.c
+++ b/gcc/cp/decl.c
@@ -5879,10 +5879,9 @@ cp_rest_of_decl_compilation (tree decl, int top_level, 
int at_end)
 {
   rest_of_decl_compilation (decl, top_level, at_end);
 
-  /* If we are generating a PPH image, add DECL to the list of
- declarations that need to be registered when this image is read.  */
+  /* If we are generating a PPH image, add DECL to its symbol table.  */
   if (pph_out_file)
-pph_add_decl_to_register (decl);
+pph_add_decl_to_symtab (decl);
 }
 
 
@@ -12815,10 +12814,9 @@ start_preparsed_function (tree decl1, tree attrs, int 
flags)
 
   store_parm_decls (current_function_parms);
 
-  /* If we are generating a PPH image, add DECL1 to the list of
- declarations that need to be registered when restoring the image.  */
+  /* If we are generating a PPH image, add DECL1 to its symbol table.  */
   if (pph_out_file)
-pph_add_decl_to_register (decl1);
+pph_add_decl_to_symtab (decl1);
 }
 
 
diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c
index c48807d..e069441 100644
--- a/gcc/cp/parser.c
+++ b/gcc/cp/parser.c
@@ -604,20 +604,19 @@ cp_lexer_new_main (void)
   cp_lexer *lexer;
   cp_token token;
 
-  if (pph_out_file != NULL || qu