[multiple changes]

2009-09-16  Thomas Quinot  <quinot@adacore.com>

	* freeze.adb, exp_intr.adb (Expand_Intrinsic_Call): Leave calls to
	intrinsics untouched (to be expanded later on by gigi) if an external
	name has been specified.
	(Freeze_Entity): Do not generate a default external name for
	imported subprograms with convention Intrinsic (so that the above code
	can identify the case where an external name has been explicitly
	provided).

	* s-oscons-tmplt.c: Quote TARGET_OS early so that it is not erroneously
	replaced by something else due to an existing #define clause.

2009-09-16  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb (Is_Accessibility_Actual): New flag on
	Parameter_Association node, created for the extra actual generated for
	an access parameter of a function that dispatches on result, to prevent
	double generation of such actuals when the call is rewritten is a
	dispatching call.
	* exp_ch6.adb (Expand_Call): Set Is_Accessibility_Actual when needed.
	* exp_disp.adb (Expand_Dispatching_Call): Do not transfer extra actuals
	that carry this flag when rewriting the original call as a dispatching
	call, after propagating the controlling tag.

2009-09-16  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb (Add_Source): New parameter Source_Dir_Rank to be put
	in the source data.
	(Check_File): New parameter Source_Dir_Rank, to check if a duplicate
	source is allowed.
	(Find_Source_Dirs): New parameter Rank to be recorded with the source
	directories.
	(Search_Directories): Call Check_File with the rank of the directory
	* prj.adb (Project_Empty): Add new component Source_Dir_Ranks
	(Free): Free also Number_Lists
	(Reset): Init also Number_Lists
	* prj.ads (Number_List_Table): New dynamic table for lists of numbers
	(Source_Data): New component Source_Dir_Rank. Remove component
	Known_Order_Of_Source_Dirs, no longer needed.
	(Project_Data): New component Source_Dir_Ranks
	(Project_Tree_Data): New components Number_Lists

From-SVN: r151749

gcc/ada/ChangeLog

+2009-09-16  Thomas Quinot  <quinot@adacore.com>
+
+	* freeze.adb, exp_intr.adb (Expand_Intrinsic_Call): Leave calls to
+	intrinsics untouched (to be expanded later on by gigi) if an external
+	name has been specified.
+	(Freeze_Entity): Do not generate a default external name for
+	imported subprograms with convention Intrinsic (so that the above code
+	can identify the case where an external name has been explicitly
+	provided).
+
+	* s-oscons-tmplt.c: Quote TARGET_OS early so that it is not erroneously
+	replaced by something else due to an existing #define clause.
+
+2009-09-16  Ed Schonberg  <schonberg@adacore.com>
+
+	* sinfo.ads, sinfo.adb (Is_Accessibility_Actual): New flag on
+	Parameter_Association node, created for the extra actual generated for
+	an access parameter of a function that dispatches on result, to prevent
+	double generation of such actuals when the call is rewritten is a
+	dispatching call.
+	* exp_ch6.adb (Expand_Call): Set Is_Accessibility_Actual when needed.
+	* exp_disp.adb (Expand_Dispatching_Call): Do not transfer extra actuals
+	that carry this flag when rewriting the original call as a dispatching
+	call, after propagating the controlling tag.
+
+2009-09-16  Vincent Celier  <celier@adacore.com>
+
+	* prj-nmsc.adb (Add_Source): New parameter Source_Dir_Rank to be put
+	in the source data.
+	(Check_File): New parameter Source_Dir_Rank, to check if a duplicate
+	source is allowed.
+	(Find_Source_Dirs): New parameter Rank to be recorded with the source
+	directories.
+	(Search_Directories): Call Check_File with the rank of the directory
+	* prj.adb (Project_Empty): Add new component Source_Dir_Ranks
+	(Free): Free also Number_Lists
+	(Reset): Init also Number_Lists
+	* prj.ads (Number_List_Table): New dynamic table for lists of numbers
+	(Source_Data): New component Source_Dir_Rank. Remove component
+	Known_Order_Of_Source_Dirs, no longer needed.
+	(Project_Data): New component Source_Dir_Ranks
+	(Project_Tree_Data): New components Number_Lists
+
 2009-09-16  Vincent Celier  <celier@adacore.com>
 
 	* gprep.adb (Yes_No): New global constant

gcc/ada/exp_ch6.adb

@@ -496,6 +496,7 @@ package body Exp_Ch6 is
       declare
          Activation_Chain_Actual : Node_Id;
          Activation_Chain_Formal : Node_Id;
+
       begin
          --  Locate implicit activation chain parameter in the called function
 
@@ -1807,6 +1808,10 @@ package body Exp_Ch6 is
                Make_Identifier (Loc, Chars (EF))));
 
          Analyze_And_Resolve (Expr, Etype (EF));
+
+         if Nkind (N) = N_Function_Call then
+            Set_Is_Accessibility_Actual (Parent (Expr));
+         end if;
       end Add_Extra_Actual;
 
       ---------------------------
@@ -2282,31 +2287,15 @@ package body Exp_Ch6 is
                   when N_Attribute_Reference =>
                      case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
 
-                        --  For X'Access, pass on the level of the prefix X.
-                        --  If the call is a rewritten attribute reference to
-                        --  'Input and the prefix is a tagged type, prevent
-                        --  double expansion (once as a function call and once
-                        --  as a dispatching call)
+                        --  For X'Access, pass on the level of the prefix X
 
                         when Attribute_Access =>
-                           declare
-                              Onode : constant Node_Id :=
-                                        Original_Node (Parent (N));
-                           begin
-                              if Nkind (Onode) = N_Attribute_Reference
-                                and then Attribute_Name (Onode) = Name_Input
-                                and then Is_Tagged_Type (Etype (Subp))
-                              then
-                                 null;
-                              else
-                                 Add_Extra_Actual
-                                   (Make_Integer_Literal (Loc,
-                                      Intval =>
-                                        Object_Access_Level
-                                          (Prefix (Prev_Orig))),
+                           Add_Extra_Actual
+                             (Make_Integer_Literal (Loc,
+                               Intval =>
+                                 Object_Access_Level
+                                   (Prefix (Prev_Orig))),
                                     Extra_Accessibility (Formal));
-                              end if;
-                           end;
 
                         --  Treat the unchecked attributes as library-level
 

gcc/ada/exp_disp.adb

@@ -692,7 +692,9 @@ package body Exp_Disp is
                Append_To (New_Params,
                  Duplicate_Subexpr_Move_Checks (Param));
 
-            else
+            elsif Nkind (Parent (Param)) /= N_Parameter_Association
+              or else not Is_Accessibility_Actual (Parent (Param))
+            then
                Append_To (New_Params, Relocate_Node (Param));
             end if;
 

gcc/ada/exp_intr.adb

@@ -394,6 +394,13 @@ package body Exp_Intr is
       Nam : Name_Id;
 
    begin
+      --  If an external name is specified for the intrinsic, it is handled
+      --  by the back-end: leave the call node unchanged for now.
+
+      if Present (Interface_Name (E)) then
+         return;
+      end if;
+
       --  If the intrinsic subprogram is generic, gets its original name
 
       if Present (Parent (E))

gcc/ada/freeze.adb

@@ -2443,11 +2443,16 @@ package body Freeze is
          --  If entity is exported or imported and does not have an external
          --  name, now is the time to provide the appropriate default name.
          --  Skip this if the entity is stubbed, since we don't need a name
-         --  for any stubbed routine.
+         --  for any stubbed routine. For the case on intrinsics, if no
+         --  external name is specified, then calls will be handled in
+         --  Exp_Intr.Expand_Intrinsic_Call, and no name is needed; if
+         --  an external name is provided, then Expand_Intrinsic_Call leaves
+         --  calls in place for expansion by GIGI.
 
          if (Is_Imported (E) or else Is_Exported (E))
            and then No (Interface_Name (E))
            and then Convention (E) /= Convention_Stubbed
+           and then Convention (E) /= Convention_Intrinsic
          then
             Set_Encoded_Interface_Name
               (E, Get_Default_External_Name (E));
@@ -3335,9 +3340,7 @@ package body Freeze is
 
                --  For bit-packed arrays, check the size
 
-               if Is_Bit_Packed_Array (E)
-                 and then Known_RM_Size (E)
-               then
+               if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then
                   declare
                      SizC : constant Node_Id := Size_Clause (E);
 

gcc/ada/prj.adb

@@ -89,7 +89,7 @@ package body Prj is
                       Include_Path                   => null,
                       Include_Data_Set               => False,
                       Source_Dirs                    => Nil_String,
-                      Known_Order_Of_Source_Dirs     => True,
+                      Source_Dir_Ranks               => No_Number_List,
                       Object_Directory               => No_Path_Information,
                       Library_TS                     => Empty_Time_Stamp,
                       Exec_Directory                 => No_Path_Information,
@@ -841,6 +841,7 @@ package body Prj is
    begin
       if Tree /= null then
          Name_List_Table.Free (Tree.Name_Lists);
+         Number_List_Table.Free (Tree.Number_Lists);
          String_Element_Table.Free (Tree.String_Elements);
          Variable_Element_Table.Free (Tree.Variable_Elements);
          Array_Element_Table.Free (Tree.Array_Elements);
@@ -868,6 +869,7 @@ package body Prj is
       --  Visible tables
 
       Name_List_Table.Init          (Tree.Name_Lists);
+      Number_List_Table.Init        (Tree.Number_Lists);
       String_Element_Table.Init     (Tree.String_Elements);
       Variable_Element_Table.Init   (Tree.Variable_Elements);
       Array_Element_Table.Init      (Tree.Array_Elements);

gcc/ada/prj.ads

@@ -314,7 +314,23 @@ package Prj is
       Table_Low_Bound      => 1,
       Table_Initial        => 10,
       Table_Increment      => 100);
-   --  The table for lists of names used in package Language_Processing
+   --  The table for lists of names
+
+   type Number_List_Index is new Nat;
+   No_Number_List : constant Number_List_Index := 0;
+
+   type Number_Node is record
+      Number : Natural           := 0;
+      Next   : Number_List_Index := No_Number_List;
+   end record;
+
+   package Number_List_Table is new GNAT.Dynamic_Tables
+     (Table_Component_Type => Number_Node,
+      Table_Index_Type     => Number_List_Index,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 10,
+      Table_Increment      => 100);
+   --  The table for lists of numbers
 
    package Mapping_Files_Htable is new Simple_HTable
      (Header_Num => Header_Num,
@@ -623,6 +639,12 @@ package Prj is
       Project                : Project_Id          := No_Project;
       --  Project of the source
 
+      Source_Dir_Rank        : Natural             := 0;
+      --  The rank of the source directory in list declared with attribute
+      --  Source_Dirs. Two source files with the same name cannot appears in
+      --  different directory with the same rank. That can happen when the
+      --  recursive notation <dir>/** is used in attribute Source_Dirs.
+
       Language               : Language_Ptr        := No_Language_Index;
       --  Index of the language. This is an index into
       --  Project_Tree.Languages_Data.
@@ -717,6 +739,7 @@ package Prj is
 
    No_Source_Data : constant Source_Data :=
                       (Project                => No_Project,
+                       Source_Dir_Rank        => 0,
                        Language               => No_Language_Index,
                        In_Interfaces          => True,
                        Declared_In_Interfaces => False,
@@ -1155,10 +1178,7 @@ package Prj is
       Source_Dirs : String_List_Id := Nil_String;
       --  The list of all the source directories
 
-      Known_Order_Of_Source_Dirs : Boolean := True;
-      --  False, if there is any /** in the Source_Dirs, because in this case
-      --  the ordering of the source subdirs depend on the OS. If True,
-      --  duplicate file names in the same project file are allowed.
+      Source_Dir_Ranks : Number_List_Index := No_Number_List;
 
       Ada_Include_Path : String_Access := null;
       --  The cached value of source search path for this project file. Set by
@@ -1273,6 +1293,7 @@ package Prj is
    type Project_Tree_Data is
       record
          Name_Lists        : Name_List_Table.Instance;
+         Number_Lists      : Number_List_Table.Instance;
          String_Elements   : String_Element_Table.Instance;
          Variable_Elements : Variable_Element_Table.Instance;
          Array_Elements    : Array_Element_Table.Instance;

gcc/ada/s-oscons-tmplt.c

@@ -231,13 +231,13 @@ TXT("   Target_Name : constant String := " STR(TARGET) ";")
    type Target_OS_Type is (Windows, VMS, Other_OS);
 */
 #if defined (__MINGW32__)
-# define TARGET_OS Windows
+# define TARGET_OS "Windows"
 #elif defined (__VMS)
-# define TARGET_OS VMS
+# define TARGET_OS "VMS"
 #else
-# define TARGET_OS Other_OS
+# define TARGET_OS "Other_OS"
 #endif
-TXT("   Target_OS : constant Target_OS_Type := " STR(TARGET_OS) ";")
+TXT("   Target_OS : constant Target_OS_Type := " TARGET_OS ";")
 /*
 
    -------------------

gcc/ada/sinfo.adb

@@ -1583,6 +1583,14 @@ package body Sinfo is
       return Uint3 (N);
    end Intval;
 
+   function Is_Accessibility_Actual
+     (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      return Flag12 (N);
+   end Is_Accessibility_Actual;
+
    function Is_Asynchronous_Call_Block
       (N : Node_Id) return Boolean is
    begin
@@ -4435,6 +4443,14 @@ package body Sinfo is
       Set_Uint3 (N, Val);
    end Set_Intval;
 
+   procedure Set_Is_Accessibility_Actual
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Parameter_Association);
+      Set_Flag12 (N, Val);
+   end Set_Is_Accessibility_Actual;
+
    procedure Set_Is_Asynchronous_Call_Block
       (N : Node_Id; Val : Boolean := True) is
    begin

gcc/ada/sinfo.ads

@@ -1179,6 +1179,13 @@ package Sinfo is
    --    to the node for the spec of the instance, inserted as part of the
    --    semantic processing for instantiations in Sem_Ch12.
 
+   --  Is_Accessibility_Actual (Flag12-Sem)
+   --    Present in N_Parameter_Association nodes. True if the parameter is
+   --    an extra actual that carries the accessibility level of the actual
+   --    for an access parameter, in a function that dispatches on result and
+   --    is called in a dispatching context. Used to prevent a formal/actual
+   --    mismatch when the call is rewritten as a dispatching call.
+
    --  Is_Asynchronous_Call_Block (Flag7-Sem)
    --    A flag set in a Block_Statement node to indicate that it is the
    --    expansion of an asynchronous entry call. Such a block needs cleanup
@@ -4450,6 +4457,7 @@ package Sinfo is
       --  Selector_Name (Node2) (always non-Empty)
       --  Explicit_Actual_Parameter (Node3)
       --  Next_Named_Actual (Node4-Sem)
+      --  Is_Accessibility_Actual (Flag12-Sem)
 
       ---------------------------
       -- 6.4  Actual Parameter --
@@ -8070,6 +8078,9 @@ package Sinfo is
    function Intval
      (N : Node_Id) return Uint;       -- Uint3
 
+   function Is_Accessibility_Actual
+     (N : Node_Id) return Boolean;    -- Flag12
+
    function Is_Asynchronous_Call_Block
      (N : Node_Id) return Boolean;    -- Flag7
 
@@ -8979,6 +8990,9 @@ package Sinfo is
    procedure Set_Intval
      (N : Node_Id; Val : Uint);               -- Uint3
 
+   procedure Set_Is_Accessibility_Actual
+     (N : Node_Id; Val : Boolean := True);    -- Flag12
+
    procedure Set_Is_Asynchronous_Call_Block
      (N : Node_Id; Val : Boolean := True);    -- Flag7
 
@@ -11246,6 +11260,7 @@ package Sinfo is
    pragma Inline (In_Present);
    pragma Inline (Instance_Spec);
    pragma Inline (Intval);
+   pragma Inline (Is_Accessibility_Actual);
    pragma Inline (Is_Asynchronous_Call_Block);
    pragma Inline (Is_Component_Left_Opnd);
    pragma Inline (Is_Component_Right_Opnd);
@@ -11545,6 +11560,7 @@ package Sinfo is
    pragma Inline (Set_In_Present);
    pragma Inline (Set_Instance_Spec);
    pragma Inline (Set_Intval);
+   pragma Inline (Set_Is_Accessibility_Actual);
    pragma Inline (Set_Is_Asynchronous_Call_Block);
    pragma Inline (Set_Is_Component_Left_Opnd);
    pragma Inline (Set_Is_Component_Right_Opnd);