Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ P R A G                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          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- --

-- 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.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Atree;    use Atree;

with Casing;   use Casing;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Exp_Ch11; use Exp_Ch11;

with Exp_Util; use Exp_Util;

with Expander; use Expander;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Stringt;  use Stringt;

with Stand;    use Stand;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Prag is

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Arg1 (N : Node_Id) return Node_Id;

   function Arg2 (N : Node_Id) return Node_Id;

   function Arg3 (N : Node_Id) return Node_Id;

   --  Obtain specified pragma argument expression

   procedure Expand_Pragma_Abort_Defer             (N : Node_Id);

   procedure Expand_Pragma_Check                   (N : Node_Id);

   procedure Expand_Pragma_Common_Object           (N : Node_Id);

   procedure Expand_Pragma_Import_Or_Interface     (N : Node_Id);

   procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);

   procedure Expand_Pragma_Inspection_Point        (N : Node_Id);

   procedure Expand_Pragma_Interrupt_Priority      (N : Node_Id);

   procedure Expand_Pragma_Psect_Object            (N : Node_Id);

   procedure Expand_Pragma_Relative_Deadline       (N : Node_Id);

   ----------

   -- Arg1 --

   ----------

   function Arg1 (N : Node_Id) return Node_Id is

      Arg : constant Node_Id := First (Pragma_Argument_Associations (N));

   begin

      if Present (Arg)

        and then Nkind (Arg) = N_Pragma_Argument_Association

      then

         return Expression (Arg);

      else

         return Arg;

      end if;

   end Arg1;

   ----------

   -- Arg2 --

   ----------

   function Arg2 (N : Node_Id) return Node_Id is

      Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));

   begin

      if No (Arg1) then

         return Empty;

      else

         declare

            Arg : constant Node_Id := Next (Arg1);

         begin

            if Present (Arg)

              and then Nkind (Arg) = N_Pragma_Argument_Association

            then

               return Expression (Arg);

            else

               return Arg;

            end if;

         end;

      end if;

   end Arg2;

   ----------

   -- Arg3 --

   ----------

   function Arg3 (N : Node_Id) return Node_Id is

      Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));

   begin

      if No (Arg1) then

         return Empty;

      else

         declare

            Arg : Node_Id := Next (Arg1);

         begin

            if No (Arg) then

               return Empty;

            else

               Next (Arg);

               if Present (Arg)

                 and then Nkind (Arg) = N_Pragma_Argument_Association

               then

                  return Expression (Arg);

               else

                  return Arg;

               end if;

            end if;

         end;

      end if;

   end Arg3;

   ---------------------

   -- Expand_N_Pragma --

   ---------------------

   procedure Expand_N_Pragma (N : Node_Id) is

      Pname : constant Name_Id := Pragma_Name (N);

   begin

      --  Note: we may have a pragma whose Pragma_Identifier field is not a

      --  recognized pragma, and we must ignore it at this stage.

      if Is_Pragma_Name (Pname) then

         case Get_Pragma_Id (Pname) is

            --  Pragmas requiring special expander action

            when Pragma_Abort_Defer =>

               Expand_Pragma_Abort_Defer (N);

            when Pragma_Check =>

               Expand_Pragma_Check (N);

            when Pragma_Common_Object =>

               Expand_Pragma_Common_Object (N);

            when Pragma_Export_Exception =>

               Expand_Pragma_Import_Export_Exception (N);

            when Pragma_Import =>

               Expand_Pragma_Import_Or_Interface (N);

            when Pragma_Import_Exception =>

               Expand_Pragma_Import_Export_Exception (N);

            when Pragma_Inspection_Point =>

               Expand_Pragma_Inspection_Point (N);

            when Pragma_Interface =>

               Expand_Pragma_Import_Or_Interface (N);

            when Pragma_Interrupt_Priority =>

               Expand_Pragma_Interrupt_Priority (N);

            when Pragma_Psect_Object =>

               Expand_Pragma_Psect_Object (N);

            when Pragma_Relative_Deadline =>

               Expand_Pragma_Relative_Deadline (N);

            --  All other pragmas need no expander action

            when others => null;

         end case;

      end if;

   end Expand_N_Pragma;

   -------------------------------

   -- Expand_Pragma_Abort_Defer --

   -------------------------------

   --  An Abort_Defer pragma appears as the first statement in a handled

   --  statement sequence (right after the begin). It defers aborts for

   --  the entire statement sequence, but not for any declarations or

   --  handlers (if any) associated with this statement sequence.

   --  The transformation is to transform

   --    pragma Abort_Defer;

   --    statements;

   --  into

   --    begin

   --       Abort_Defer.all;

   --       statements

   --    exception

   --       when all others =>

   --          Abort_Undefer.all;

   --          raise;

   --    at end

   --       Abort_Undefer_Direct;

   --    end;

   procedure Expand_Pragma_Abort_Defer (N : Node_Id) is

      Loc  : constant Source_Ptr := Sloc (N);

      Stm  : Node_Id;

      Stms : List_Id;

      HSS  : Node_Id;

      Blk  : constant Entity_Id :=

        New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');

   begin

      Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));

      loop

         Stm := Remove_Next (N);

         exit when No (Stm);

         Append (Stm, Stms);

      end loop;

      HSS :=

        Make_Handled_Sequence_Of_Statements (Loc,

          Statements => Stms,

          At_End_Proc =>

            New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));

      Rewrite (N,

        Make_Block_Statement (Loc,

          Handled_Statement_Sequence => HSS));

      Set_Scope (Blk, Current_Scope);

      Set_Etype (Blk, Standard_Void_Type);

      Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));

      Expand_At_End_Handler (HSS, Blk);

      Analyze (N);

   end Expand_Pragma_Abort_Defer;

   --------------------------

   -- Expand_Pragma_Check --

   --------------------------

   procedure Expand_Pragma_Check (N : Node_Id) is

      Cond : constant Node_Id    := Arg2 (N);

      Nam  : constant Name_Id    := Chars (Arg1 (N));

      Msg  : Node_Id;

      Loc  : constant Source_Ptr := Sloc (First_Node (Cond));

      --  Source location used in the case of a failed assertion. Note that

      --  the source location of the expression is not usually the best choice

      --  here. For example, it gets located on the last AND keyword in a

      --  chain of boolean expressiond AND'ed together. It is best to put the

      --  message on the first character of the assertion, which is the effect

      --  of the First_Node call here.

   begin

      --  We already know that this check is enabled, because otherwise the

      --  semantic pass dealt with rewriting the assertion (see Sem_Prag)

      --  Since this check is enabled, we rewrite the pragma into a

      --  corresponding if statement, and then analyze the statement

      --  The normal case expansion transforms:

      --    pragma Check (name, condition [,message]);

      --  into

      --    if not condition then

      --       System.Assertions.Raise_Assert_Failure (Str);

      --    end if;

      --  where Str is the message if one is present, or the default of

      --  name failed at file:line if no message is given (the "name failed

      --  at" is omitted for name = Assertion, since it is redundant, given

      --  that the name of the exception is Assert_Failure.)

      --  An alternative expansion is used when the No_Exception_Propagation

      --  restriction is active and there is a local Assert_Failure handler.

      --  This is not a common combination of circumstances, but it occurs in

      --  the context of Aunit and the zero footprint profile. In this case we

      --  generate:

      --    if not condition then

      --       raise Assert_Failure;

      --    end if;

      --  This will then be transformed into a goto, and the local handler will

      --  be able to handle the assert error (which would not be the case if a

      --  call is made to the Raise_Assert_Failure procedure).

      --  We also generate the direct raise if the Suppress_Exception_Locations

      --  is active, since we don't want to generate messages in this case.

      --  Note that the reason we do not always generate a direct raise is that

      --  the form in which the procedure is called allows for more efficient

      --  breakpointing of assertion errors.

      --  Generate the appropriate if statement. Note that we consider this to

      --  be an explicit conditional in the source, not an implicit if, so we

      --  do not call Make_Implicit_If_Statement.

      --  Case where we generate a direct raise

      if ((Debug_Flag_Dot_G

           or else Restriction_Active (No_Exception_Propagation))

          and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))

        or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))

      then

         Rewrite (N,

           Make_If_Statement (Loc,

             Condition =>

               Make_Op_Not (Loc,

                 Right_Opnd => Cond),

             Then_Statements => New_List (

               Make_Raise_Statement (Loc,

                 Name =>

                   New_Reference_To (RTE (RE_Assert_Failure), Loc)))));

      --  Case where we call the procedure

      else

         --  If we have a message given, use it

         if Present (Arg3 (N)) then

            Msg := Get_Pragma_Arg (Arg3 (N));

         --  Here we have no string, so prepare one

         else

            declare

               Msg_Loc : constant String := Build_Location_String (Loc);

            begin

               Name_Len := 0;

               --  For Assert, we just use the location

               if Nam = Name_Assertion then

                  null;

               --  For predicate, we generate the string "predicate failed

               --  at yyy". We prefer all lower case for predicate.

               elsif Nam = Name_Predicate then

                  Add_Str_To_Name_Buffer ("predicate failed at ");

               --  For special case of Precondition/Postcondition the string is

               --  "failed xx from yy" where xx is precondition/postcondition

               --  in all lower case. The reason for this different wording is

               --  that the failure is not at the point of occurrence of the

               --  pragma, unlike the other Check cases.

               elsif Nam = Name_Precondition

                       or else

                     Nam = Name_Postcondition

               then

                  Get_Name_String (Nam);

                  Insert_Str_In_Name_Buffer ("failed ", 1);

                  Add_Str_To_Name_Buffer (" from ");

               --  For all other checks, the string is "xxx failed at yyy"

               --  where xxx is the check name with current source file casing.

               else

                  Get_Name_String (Nam);

                  Set_Casing (Identifier_Casing (Current_Source_File));

                  Add_Str_To_Name_Buffer (" failed at ");

               end if;

               --  In all cases, add location string

               Add_Str_To_Name_Buffer (Msg_Loc);

               --  Build the message

               Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));

            end;

         end if;

         --  Now rewrite as an if statement

         Rewrite (N,

           Make_If_Statement (Loc,

             Condition =>

               Make_Op_Not (Loc,

                 Right_Opnd => Cond),

             Then_Statements => New_List (

               Make_Procedure_Call_Statement (Loc,

                 Name =>

                   New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),

                 Parameter_Associations => New_List (Relocate_Node (Msg))))));

      end if;

      Analyze (N);

      --  If new condition is always false, give a warning

      if Warn_On_Assertion_Failure

        and then Nkind (N) = N_Procedure_Call_Statement

        and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)

      then

         --  If original condition was a Standard.False, we assume that this is

         --  indeed intended to raise assert error and no warning is required.

         if Is_Entity_Name (Original_Node (Cond))

           and then Entity (Original_Node (Cond)) = Standard_False

         then

            return;

         elsif Nam = Name_Assertion then

            Error_Msg_N ("?assertion will fail at run time", N);

         else

            Error_Msg_N ("?check will fail at run time", N);

         end if;

      end if;

   end Expand_Pragma_Check;

   ---------------------------------

   -- Expand_Pragma_Common_Object --

   ---------------------------------

   --  Use a machine attribute to replicate semantic effect in DEC Ada

   --    pragma Machine_Attribute (intern_name, "common_object", extern_name);

   --  For now we do nothing with the size attribute ???

   --  Note: Psect_Object shares this processing

   procedure Expand_Pragma_Common_Object (N : Node_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      Internal : constant Node_Id := Arg1 (N);

      External : constant Node_Id := Arg2 (N);

      Psect : Node_Id;

      --  Psect value upper cased as string literal

      Iloc : constant Source_Ptr := Sloc (Internal);

      Eloc : constant Source_Ptr := Sloc (External);

      Ploc : Source_Ptr;

   begin

      --  Acquire Psect value and fold to upper case

      if Present (External) then

         if Nkind (External) = N_String_Literal then

            String_To_Name_Buffer (Strval (External));

         else

            Get_Name_String (Chars (External));

         end if;

         Set_All_Upper_Case;

         Psect :=

           Make_String_Literal (Eloc,

             Strval => String_From_Name_Buffer);

      else

         Get_Name_String (Chars (Internal));

         Set_All_Upper_Case;

         Psect :=

           Make_String_Literal (Iloc,

             Strval => String_From_Name_Buffer);

      end if;

      Ploc := Sloc (Psect);

      --  Insert the pragma

      Insert_After_And_Analyze (N,

         Make_Pragma (Loc,

           Chars => Name_Machine_Attribute,

           Pragma_Argument_Associations => New_List (

             Make_Pragma_Argument_Association (Iloc,

               Expression => New_Copy_Tree (Internal)),

             Make_Pragma_Argument_Association (Eloc,

               Expression =>

                 Make_String_Literal (Sloc => Ploc,

                   Strval => "common_object")),

             Make_Pragma_Argument_Association (Ploc,

               Expression => New_Copy_Tree (Psect)))));

   end Expand_Pragma_Common_Object;

   ---------------------------------------

   -- Expand_Pragma_Import_Or_Interface --

   ---------------------------------------

   --  When applied to a variable, the default initialization must not be

   --  done. As it is already done when the pragma is found, we just get rid

   --  of the call the initialization procedure which followed the object

   --  declaration. The call is inserted after the declaration, but validity

   --  checks may also have been inserted and the initialization call does

   --  not necessarily appear immediately after the object declaration.

   --  We can't use the freezing mechanism for this purpose, since we

   --  have to elaborate the initialization expression when it is first

   --  seen (i.e. this elaboration cannot be deferred to the freeze point).

   procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is

      Def_Id    : constant Entity_Id := Entity (Arg2 (N));

      Init_Call : Node_Id;

   begin

      if Ekind (Def_Id) = E_Variable then

         --  Find generated initialization call for object, if any

         Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);

         if Present (Init_Call) then

            Remove (Init_Call);

         end if;

         --  Any default initialization expression should be removed

         --  (e.g., null defaults for access objects, zero initialization

         --  of packed bit arrays). Imported objects aren't allowed to

         --  have explicit initialization, so the expression must have

         --  been generated by the compiler.

         if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then

            Set_Expression (Parent (Def_Id), Empty);

         end if;

      end if;

   end Expand_Pragma_Import_Or_Interface;

   -------------------------------------------

   -- Expand_Pragma_Import_Export_Exception --

   -------------------------------------------

   --  For a VMS exception fix up the language field with "VMS"

   --  instead of "Ada" (gigi needs this), create a constant that will be the

   --  value of the VMS condition code and stuff the Interface_Name field

   --  with the unexpanded name of the exception (if not already set).

   --  For a Ada exception, just stuff the Interface_Name field

   --  with the unexpanded name of the exception (if not already set).

   procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is

   begin

      --  This pragma is only effective on OpenVMS systems, it was ignored

      --  on non-VMS systems, and we need to ignore it here as well.

      if not OpenVMS_On_Target then

         return;

      end if;

      declare

         Id     : constant Entity_Id := Entity (Arg1 (N));

         Call   : constant Node_Id := Register_Exception_Call (Id);

         Loc    : constant Source_Ptr := Sloc (N);

      begin

         if Present (Call) then

            declare

               Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V');

               Export_Pragma  : Node_Id;

               Excep_Alias    : Node_Id;

               Excep_Object   : Node_Id;

               Excep_Image    : String_Id;

               Exdata         : List_Id;

               Lang_Char      : Node_Id;

               Code           : Node_Id;

            begin

               if Present (Interface_Name (Id)) then

                  Excep_Image := Strval (Interface_Name (Id));

               else

                  Get_Name_String (Chars (Id));

                  Set_All_Upper_Case;

                  Excep_Image := String_From_Name_Buffer;

               end if;

               Exdata := Component_Associations (Expression (Parent (Id)));

               if Is_VMS_Exception (Id) then

                  Lang_Char := Next (First (Exdata));

                  --  Change the one-character language designator to 'V'

                  Rewrite (Expression (Lang_Char),

                    Make_Character_Literal (Loc,

                      Chars => Name_uV,

                      Char_Literal_Value =>

                        UI_From_Int (Character'Pos ('V'))));

                  Analyze (Expression (Lang_Char));

                  if Exception_Code (Id) /= No_Uint then

                     Code :=

                       Make_Integer_Literal (Loc,

                         Intval => Exception_Code (Id));

                     Excep_Object :=

                       Make_Object_Declaration (Loc,

                         Defining_Identifier => Excep_Internal,

                         Object_Definition   =>

                           New_Reference_To (RTE (RE_Exception_Code), Loc));

                     Insert_Action (N, Excep_Object);

                     Analyze (Excep_Object);

                     Start_String;

                     Store_String_Int

                       (UI_To_Int (Exception_Code (Id)) / 8 * 8);

                     Excep_Alias :=

                       Make_Pragma

                         (Loc,

                          Name_Linker_Alias,

                          New_List

                            (Make_Pragma_Argument_Association

                               (Sloc => Loc,

                                Expression =>

                                  New_Reference_To (Excep_Internal, Loc)),

                             Make_Pragma_Argument_Association

                               (Sloc => Loc,

                                Expression =>

                                  Make_String_Literal

                                    (Sloc => Loc,

                                     Strval => End_String))));

                     Insert_Action (N, Excep_Alias);

                     Analyze (Excep_Alias);

                     Export_Pragma :=

                       Make_Pragma

                         (Loc,

                          Name_Export,

                          New_List

                            (Make_Pragma_Argument_Association (Loc,

                               Expression => Make_Identifier (Loc, Name_C)),

                             Make_Pragma_Argument_Association (Loc,

                               Expression =>

                                 New_Reference_To (Excep_Internal, Loc)),

                             Make_Pragma_Argument_Association (Loc,

                               Expression =>

                                 Make_String_Literal (Loc, Excep_Image)),

                             Make_Pragma_Argument_Association (Loc,

                                Expression =>

                                  Make_String_Literal (Loc, Excep_Image))));

                     Insert_Action (N, Export_Pragma);

                     Analyze (Export_Pragma);

                  else

                     Code :=

                        Unchecked_Convert_To (RTE (RE_Exception_Code),

                          Make_Function_Call (Loc,

                            Name =>

                              New_Reference_To (RTE (RE_Import_Value), Loc),

                            Parameter_Associations => New_List

                              (Make_String_Literal (Loc,

                                Strval => Excep_Image))));

                  end if;

                  Rewrite (Call,

                    Make_Procedure_Call_Statement (Loc,

                      Name => New_Reference_To

                                (RTE (RE_Register_VMS_Exception), Loc),

                      Parameter_Associations => New_List (

                        Code,

                        Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),

                          Make_Attribute_Reference (Loc,

                            Prefix         => New_Occurrence_Of (Id, Loc),

                            Attribute_Name => Name_Unrestricted_Access)))));

                  Analyze_And_Resolve (Code, RTE (RE_Exception_Code));

                  Analyze (Call);

               end if;

               if No (Interface_Name (Id)) then

                  Set_Interface_Name (Id,

                     Make_String_Literal

                       (Sloc => Loc,

                        Strval => Excep_Image));

               end if;

            end;

         end if;

      end;

   end Expand_Pragma_Import_Export_Exception;

   ------------------------------------

   -- Expand_Pragma_Inspection_Point --

   ------------------------------------

   --  If no argument is given, then we supply a default argument list that

   --  includes all objects declared at the source level in all subprograms

   --  that enclose the inspection point pragma.

   procedure Expand_Pragma_Inspection_Point (N : Node_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      A     : List_Id;

      Assoc : Node_Id;

      S     : Entity_Id;

      E     : Entity_Id;

   begin

      if No (Pragma_Argument_Associations (N)) then

         A := New_List;

         S := Current_Scope;

         while S /= Standard_Standard loop

            E := First_Entity (S);

            while Present (E) loop

               if Comes_From_Source (E)

                 and then Is_Object (E)

                 and then not Is_Entry_Formal (E)

                 and then Ekind (E) /= E_Component

                 and then Ekind (E) /= E_Discriminant

                 and then Ekind (E) /= E_Generic_In_Parameter

                 and then Ekind (E) /= E_Generic_In_Out_Parameter

               then

                  Append_To (A,

                    Make_Pragma_Argument_Association (Loc,

                      Expression => New_Occurrence_Of (E, Loc)));

               end if;

               Next_Entity (E);

            end loop;

            S := Scope (S);

         end loop;

         Set_Pragma_Argument_Associations (N, A);

      end if;

      --  Expand the arguments of the pragma. Expanding an entity reference

      --  is a noop, except in a protected operation, where a reference may

      --  have to be transformed into a reference to the corresponding prival.

      --  Are there other pragmas that may require this ???

      Assoc := First (Pragma_Argument_Associations (N));

      while Present (Assoc) loop

         Expand (Expression (Assoc));

         Next (Assoc);

      end loop;

   end Expand_Pragma_Inspection_Point;

   --------------------------------------

   -- Expand_Pragma_Interrupt_Priority --

   --------------------------------------

   --  Supply default argument if none exists (System.Interrupt_Priority'Last)

   procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is

      Loc : constant Source_Ptr := Sloc (N);

   begin

      if No (Pragma_Argument_Associations (N)) then