exp_dist.adb (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist spec...

2005-03-17  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist
	spec, to make this predicate available to other units.

	* rtsfind.adb (Check_RPC): Use Sem_Dist.Get_PCS_Name instead of
	reimplementing it.

	* sem_ch8.adb: Disable expansion of remote access-to-subprogram types
	when no distribution runtime library is available.

	* sem_res.adb, sem_dist.adb: Disable expansion of remote
	access-to-subprogram types when no distribution runtime library is
	available.
	(Get_PCS_Name): Move from Exp_Dist body to Sem_Dist spec, to make this
	predicate available to other units.

	* sem_dist.ads (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist
	spec, to make this predicate available to other units.

From-SVN: r96668

gcc/ada/exp_dist.adb

@@ -152,11 +152,6 @@ package body Exp_Dist is
    pragma Warnings (Off, Get_Subprogram_Id);
    --  One homonym only is unreferenced (specific to the GARLIC version)
 
-   function Get_PCS_Name return PCS_Names;
-   --  Return the name of a literal of type
-   --    System.Partition_Interface.DSA_Implementation_Type
-   --  indicating what PCS is currently in use.
-
    procedure Add_RAS_Dereference_TSS (N : Node_Id);
    --  Add a subprogram body for RAS Dereference TSS
 
@@ -4785,18 +4780,6 @@ package body Exp_Dist is
                Selector_Name => Make_Identifier (Loc, Selector_Name));
    end Make_Selected_Component;
 
-   ------------------
-   -- Get_PCS_Name --
-   ------------------
-
-   function Get_PCS_Name return PCS_Names is
-      PCS_Name : constant PCS_Names :=
-                   Chars (Entity (Expression
-                                    (Parent (RTE (RE_DSA_Implementation)))));
-   begin
-      return PCS_Name;
-   end Get_PCS_Name;
-
    -----------------------
    -- Get_Subprogram_Id --
    -----------------------

gcc/ada/rtsfind.adb

@@ -43,6 +43,7 @@ with Opt;      use Opt;
 with Restrict; use Restrict;
 with Sem;      use Sem;
 with Sem_Ch7;  use Sem_Ch7;
+with Sem_Dist; use Sem_Dist;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Stand;    use Stand;
@@ -838,20 +839,12 @@ package body Rtsfind is
                      E = RE_Params_Stream_Type
                        or else
                      E = RE_Request_Access)
+           and then Get_PCS_Name = Name_No_DSA
          then
-            declare
-               DSA_Implementation : constant Entity_Id :=
-                                      RTE (RE_DSA_Implementation);
-            begin
-               if Chars (Entity (Expression
-                                  (Parent (DSA_Implementation)))) = Name_No_DSA
-               then
-                  Set_Standard_Error;
-                  Write_Str ("distribution feature not supported");
-                  Write_Eol;
-                  raise Unrecoverable_Error;
-               end if;
-            end;
+            Set_Standard_Error;
+            Write_Str ("distribution feature not supported");
+            Write_Eol;
+            raise Unrecoverable_Error;
          end if;
       end Check_RPC;
 

gcc/ada/sem_ch8.adb

@@ -50,6 +50,7 @@ with Sem_Ch4;  use Sem_Ch4;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch12; use Sem_Ch12;
 with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Type; use Sem_Type;
@@ -3235,6 +3236,7 @@ package body Sem_Ch8 is
          if Comes_From_Source (N)
            and then Is_Remote_Access_To_Subprogram_Type (E)
            and then Expander_Active
+           and then Get_PCS_Name /= Name_No_DSA
          then
             Rewrite (N,
               New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
@@ -3540,7 +3542,7 @@ package body Sem_Ch8 is
                              and then Chars (P) = Chars (Selector)
                            then
                               Id := S;
-                              goto found;
+                              goto Found;
                            end if;
                         end if;
 
@@ -3610,10 +3612,16 @@ package body Sem_Ch8 is
          end if;
       end if;
 
-      <<found>>
+      <<Found>>
       if Comes_From_Source (N)
         and then Is_Remote_Access_To_Subprogram_Type (Id)
+        and then Present (Equivalent_Type (Id))
       then
+         --  If we are not actually generating distribution code (i.e.
+         --  the current PCS is the dummy non-distributed version), then
+         --  the Equivalent_Type will be missing, and Id should be treated
+         --  as a regular access-to-subprogram type.
+
          Id := Equivalent_Type (Id);
          Set_Chars (Selector, Chars (Id));
       end if;

gcc/ada/sem_dist.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2005, 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- --
@@ -199,6 +199,18 @@ package body Sem_Dist is
       return End_String;
    end Full_Qualified_Name;
 
+   ------------------
+   -- Get_PCS_Name --
+   ------------------
+
+   function Get_PCS_Name return PCS_Names is
+      PCS_Name : constant PCS_Names :=
+                   Chars (Entity (Expression
+                                    (Parent (RTE (RE_DSA_Implementation)))));
+   begin
+      return PCS_Name;
+   end Get_PCS_Name;
+
    ------------------------
    -- Is_All_Remote_Call --
    ------------------------
@@ -341,7 +353,7 @@ package body Sem_Dist is
 
       Remote_Subp := Entity (Prefix (N));
 
-      if not Expander_Active then
+      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
          return;
       end if;
 
@@ -429,6 +441,33 @@ package body Sem_Dist is
       Fat_Type_Decl  : Node_Id;
 
    begin
+      Is_Degenerate := False;
+      Parameter := First (Parameter_Specifications (Type_Def));
+      while Present (Parameter) loop
+         if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
+            Error_Msg_N ("formal parameter& has anonymous access type?",
+              Defining_Identifier (Parameter));
+            Is_Degenerate := True;
+            exit;
+         end if;
+
+         Next (Parameter);
+      end loop;
+
+      if Is_Degenerate then
+         Error_Msg_NE (
+           "remote access-to-subprogram type& can only be null?",
+           Defining_Identifier (Parameter), User_Type);
+         --  The only legal value for a RAS with a formal parameter of an
+         --  anonymous access type is null, because it cannot be
+         --  subtype-Conformant with any legal remote subprogram declaration.
+         --  In this case, we cannot generate a corresponding primitive
+         --  operation.
+      end if;
+
+      if Get_PCS_Name = Name_No_DSA then
+         return;
+      end if;
 
       --  The tagged private type, primitive operation and RACW
       --  type associated with a RAS need to all be declared in
@@ -457,29 +496,7 @@ package body Sem_Dist is
               Null_Present     => True,
               Component_List   => Empty)));
 
-      Is_Degenerate := False;
-      Parameter := First (Parameter_Specifications (Type_Def));
-      Parameters : while Present (Parameter) loop
-         if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
-            Error_Msg_N ("formal parameter& has anonymous access type?",
-              Defining_Identifier (Parameter));
-            Is_Degenerate := True;
-            exit Parameters;
-         end if;
-         Next (Parameter);
-      end loop Parameters;
-
-      if Is_Degenerate then
-         Error_Msg_NE (
-           "remote access-to-subprogram type& can only be null?",
-           Defining_Identifier (Parameter), User_Type);
-         --  The only legal value for a RAS with a formal parameter of an
-         --  anonymous access type is null, because it cannot be
-         --  subtype-Conformant with any legal remote subprogram declaration.
-         --  In this case, we cannot generate a corresponding primitive
-         --  operation.
-
-      else
+      if not Is_Degenerate then
          Append_To (Vis_Decls,
            Make_Abstract_Subprogram_Declaration (Loc,
              Specification => Build_RAS_Primitive_Specification (
@@ -595,7 +612,7 @@ package body Sem_Dist is
          return;
       end if;
 
-      if not Expander_Active then
+      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
          return;
       end if;
 
@@ -685,7 +702,7 @@ package body Sem_Dist is
       Target_Type : Entity_Id;
 
    begin
-      if not Expander_Active then
+      if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
          return False;
 
       elsif Ekind (Typ) = E_Access_Subprogram_Type

gcc/ada/sem_dist.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005 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- --
@@ -26,15 +26,20 @@
 
 --  Semantic processing for distribution annex facilities
 
-with Types; use Types;
+with Snames; use Snames;
+with Types;  use Types;
 
 package Sem_Dist is
 
+   function Get_PCS_Name return PCS_Names;
+   --  Return the name of a literal of type System.Partition_Interface.
+   --  DSA_Implementation_Type indicating what PCS is currently in use.
+
    procedure Add_Stub_Constructs (N : Node_Id);
    --  Create the stubs constructs for a remote call interface package
-   --  specification or body or for a shared passive specification. For
-   --  caller stubs, expansion takes place directly in the specification and
-   --  no additional compilation unit is created.
+   --  specification or body or for a shared passive specification. For caller
+   --  stubs, expansion takes place directly in the specification and no
+   --  additional compilation unit is created.
 
    function Build_RAS_Primitive_Specification
      (Subp_Spec          : Node_Id;
@@ -59,35 +64,33 @@ package Sem_Dist is
    --  whose return type is New_Type.
 
    procedure Process_Remote_AST_Declaration (N : Node_Id);
-   --  Given N, an access to subprogram type declaration node in RCI or
-   --  remote types unit, build a new record (fat pointer) type declaration
-   --  using the old Defining_Identifier of N and a link to the old
-   --  declaration node N whose Defining_Identifier is changed.
-   --  We also construct declarations of two subprograms in the unit
-   --  specification which handle remote access to subprogram type
-   --  (fat pointer) dereference and the unit receiver that handles
-   --  remote calls (from remote access to subprogram type values.)
+   --  Given N, an access to subprogram type declaration node in RCI or remote
+   --  types unit, build a new record (fat pointer) type declaration using the
+   --  old Defining_Identifier of N and a link to the old declaration node N
+   --  whose Defining_Identifier is changed. We also construct declarations of
+   --  two subprograms in the unit specification which handle remote access to
+   --  subprogram type (fat pointer) dereference and the unit receiver that
+   --  handles remote calls (from remote access to subprogram type values.)
 
    function Remote_AST_E_Dereference (P : Node_Id) return Boolean;
    --  If the prefix of an explicit dereference is a record type that
-   --  represent the fat pointer for an Remote access to subprogram, in
-   --  the context of a call, rewrite the enclosing call node into a
-   --  remote call, the first actual of which is the fat pointer. Return
-   --  true if the context is correct and the transformation took place.
+   --  represent the fat pointer for an Remote access to subprogram, in the
+   --  context of a call, rewrite the enclosing call node into remote call,
+   --  the first actual of which is the fat pointer. Return true if the
+   --  context is correct and the transformation took place.
 
    function Remote_AST_I_Dereference (P : Node_Id) return Boolean;
    --  If P is a record type that represents the fat pointer for a remote
-   --  access to subprogram, and P is the prefix of a call, insert an
-   --  explicit dereference and perform the transformation described for
-   --  the previous function.
+   --  access to subprogram, and P is the prefix of a call, insert an explicit
+   --  dereference and perform the transformation described for the previous
+   --  function.
 
    function Remote_AST_Null_Value
      (N   : Node_Id;
       Typ : Entity_Id) return Boolean;
-   --  If N is a null value and Typ a remote access to subprogram type,
-   --  this function will check if null needs to be replaced with an
-   --  aggregate and will return True in this case. Otherwise, it will
-   --  return False.
+   --  If N is a null value and Typ a remote access to subprogram type, this
+   --  function will check if null needs to be replaced with an aggregate and
+   --  will return True in this case. Otherwise, it will return False.
 
    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
    --  Return the N_Package_Specification corresponding to a scope E

gcc/ada/sem_res.adb

@@ -168,7 +168,7 @@ package body Sem_Res is
    --  by other node rewriting procedures.
 
    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-   --  Resolve actuals of call, and add default expressions for missing ones.
+   --  Resolve actuals of call, and add default expressions for missing ones
 
    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
    --  Called from Resolve_Call, when the prefix denotes an entry or element
@@ -182,7 +182,7 @@ package body Sem_Res is
    --  to the corresponding predefined operator, with suitable conversions.
 
    procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-   --  Ditto, for unary operators (only arithmetic ones).
+   --  Ditto, for unary operators (only arithmetic ones)
 
    procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
    --  If an operator node resolves to a call to a user-defined operator,
@@ -371,14 +371,14 @@ package body Sem_Res is
       D    : Node_Id;
 
    begin
-      --  Any use in a default expression is legal.
+      --  Any use in a default expression is legal
 
       if In_Default_Expression then
          null;
 
       elsif Nkind (PN) = N_Range then
 
-         --  Discriminant cannot be used to constrain a scalar type.
+         --  Discriminant cannot be used to constrain a scalar type
 
          P := Parent (PN);
 
@@ -1320,7 +1320,7 @@ package body Sem_Res is
       Full_Analysis := Save_Full_Analysis;
    end Pre_Analyze_And_Resolve;
 
-   --  Version without context type.
+   --  Version without context type
 
    procedure Pre_Analyze_And_Resolve (N : Node_Id) is
       Save_Full_Analysis : constant Boolean := Full_Analysis;
@@ -1534,17 +1534,9 @@ package body Sem_Res is
             Is_Remote : Boolean := True;
 
          begin
-            --  Check that Typ is a fat pointer with a reference to a RAS as
-            --  original access type.
+            --  Check that Typ is a remote access-to-subprogram type
 
-            if
-              (Ekind (Typ) = E_Access_Subprogram_Type
-                 and then Present (Equivalent_Type (Typ)))
-              or else
-                (Ekind (Typ) = E_Record_Type
-                   and then Present (Corresponding_Remote_Type (Typ)))
-
-            then
+            if Is_Remote_Access_To_Subprogram_Type (Typ) then
                --  Prefix (N) must statically denote a remote subprogram
                --  declared in a package specification.
 
@@ -1581,6 +1573,7 @@ package body Sem_Res is
                     or else Attr = Attribute_Unchecked_Access
                     or else Attr = Attribute_Unrestricted_Access)
                  and then Expander_Active
+                 and then Get_PCS_Name /= Name_No_DSA
                then
                   Check_Subtype_Conformant
                     (New_Id  => Entity (Prefix (N)),
@@ -2020,7 +2013,7 @@ package body Sem_Res is
 
                      elsif Nkind (Name (N)) = N_Selected_Component then
 
-                        --  Protected operation: retrieve operation name.
+                        --  Protected operation: retrieve operation name
 
                         Subp_Name := Selector_Name (Name (N));
                      else
@@ -2411,7 +2404,7 @@ package body Sem_Res is
             else
                Set_Parent (Actval, N);
 
-               --  See note above concerning aggregates.
+               --  See note above concerning aggregates
 
                if Nkind (Actval) = N_Aggregate
                  and then Has_Discriminants (Etype (Actval))
@@ -3131,13 +3124,13 @@ package body Sem_Res is
          elsif Etype (N) = T
            and then B_Typ /= Universal_Fixed
          then
-            --  Not a mixed-mode operation. Resolve with context.
+            --  Not a mixed-mode operation, resolve with context
 
             Resolve (N, B_Typ);
 
          elsif Etype (N) = Any_Fixed then
 
-            --  N may itself be a mixed-mode operation, so use context type.
+            --  N may itself be a mixed-mode operation, so use context type
 
             Resolve (N, B_Typ);
 
@@ -4512,7 +4505,7 @@ package body Sem_Res is
 
       if Nkind (Entry_Name) = N_Selected_Component then
 
-         --  Simple entry call.
+         --  Simple entry call
 
          Nam := Entity (Selector_Name (Entry_Name));
          Obj := Prefix (Entry_Name);
@@ -4520,7 +4513,7 @@ package body Sem_Res is
 
       else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
 
-         --  Call to member of entry family.
+         --  Call to member of entry family
 
          Nam := Entity (Selector_Name (Prefix (Entry_Name)));
          Obj := Prefix (Prefix (Entry_Name));
@@ -4941,7 +4934,7 @@ package body Sem_Res is
          Array_Type := Designated_Type (Array_Type);
       end if;
 
-      --  If name was overloaded, set component type correctly now.
+      --  If name was overloaded, set component type correctly now
 
       Set_Etype (N, Component_Type (Array_Type));
 
@@ -5247,7 +5240,7 @@ package body Sem_Res is
          return;
       end if;
 
-      --  The null literal takes its type from the context.
+      --  The null literal takes its type from the context
 
       Set_Etype (N, Typ);
    end Resolve_Null;
@@ -6347,11 +6340,14 @@ package body Sem_Res is
            and then (Etype (Right_Opnd (Operand)) = Universal_Real
                      or else Etype (Left_Opnd (Operand)) = Universal_Real)
          then
+            --  Return if expression is ambiguous
+
             if Unique_Fixed_Point_Type (N) = Any_Type then
-               return;    --  expression is ambiguous.
-            else
-               --  If nothing else, the available fixed type is Duration.
+               return;
 
+            --  If nothing else, the available fixed type is Duration
+
+            else
                Set_Etype (Operand, Standard_Duration);
             end if;
 
@@ -6548,7 +6544,7 @@ package body Sem_Res is
       Opnd_Type : constant Entity_Id := Etype (Operand);
 
    begin
-      --  Resolve operand using its own type.
+      --  Resolve operand using its own type
 
       Resolve (Operand, Opnd_Type);
       Eval_Unchecked_Conversion (N);
@@ -6770,7 +6766,11 @@ package body Sem_Res is
       Scop : Entity_Id;
 
       procedure Fixed_Point_Error;
-      --  If true ambiguity, give details.
+      --  If true ambiguity, give details
+
+      -----------------------
+      -- Fixed_Point_Error --
+      -----------------------
 
       procedure Fixed_Point_Error is
       begin
@@ -6779,6 +6779,8 @@ package body Sem_Res is
          Error_Msg_NE ("\possible interpretation as}", N, T2);
       end Fixed_Point_Error;
 
+   --  Start of processing for Unique_Fixed_Point_Type
+
    begin
       --  The operations on Duration are visible, so Duration is always a
       --  possible interpretation.
@@ -6810,7 +6812,7 @@ package body Sem_Res is
          Scop := Scope (Scop);
       end loop;
 
-      --  Look for visible fixed type declarations in the context.
+      --  Look for visible fixed type declarations in the context
 
       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
       while Present (Item) loop
@@ -6896,15 +6898,15 @@ package body Sem_Res is
          Opnd_Type   : Entity_Id) return Boolean
       is
       begin
-         --  Upward conversions are allowed (RM 4.6(22)).
+         --  Upward conversions are allowed (RM 4.6(22))
 
          if Covers (Target_Type, Opnd_Type)
            or else Is_Ancestor (Target_Type, Opnd_Type)
          then
             return True;
 
-         --  Downward conversion are allowed if the operand is
-         --  is class-wide (RM 4.6(23)).
+         --  Downward conversion are allowed if the operand is class-wide
+         --  (RM 4.6(23)).
 
          elsif Is_Class_Wide_Type (Opnd_Type)
               and then Covers (Opnd_Type, Target_Type)
@@ -7285,7 +7287,7 @@ package body Sem_Res is
       elsif Is_Tagged_Type (Target_Type) then
          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
 
-      --  Types derived from the same root type are convertible.
+      --  Types derived from the same root type are convertible
 
       elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
          return True;