gcc/gcc/ada/sem_ch11.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ C H 1 1                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          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- --
-- ware  Foundation;  either version 2,  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 COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- 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 Checks;   use Checks;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Lib;      use Lib;
with Lib.Xref; use Lib.Xref;
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_Ch5;  use Sem_Ch5;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Res;  use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Uintp;    use Uintp;

package body Sem_Ch11 is

   -----------------------------------
   -- Analyze_Exception_Declaration --
   -----------------------------------

   procedure Analyze_Exception_Declaration (N : Node_Id) is
      Id : constant Entity_Id := Defining_Identifier (N);
      PF : constant Boolean   := Is_Pure (Current_Scope);

   begin
      Generate_Definition (Id);
      Enter_Name          (Id);
      Set_Ekind           (Id, E_Exception);
      Set_Exception_Code  (Id, Uint_0);
      Set_Etype           (Id, Standard_Exception_Type);

      Set_Is_Statically_Allocated (Id);
      Set_Is_Pure (Id, PF);
   end Analyze_Exception_Declaration;

   --------------------------------
   -- Analyze_Exception_Handlers --
   --------------------------------

   procedure Analyze_Exception_Handlers (L : List_Id) is
      Handler : Node_Id;
      Choice  : Entity_Id;
      Id      : Node_Id;
      H_Scope : Entity_Id := Empty;

      procedure Check_Duplication (Id : Node_Id);
      --  Iterate through the identifiers in each handler to find duplicates

      function Others_Present return Boolean;
      --  Returns True if others handler is present

      -----------------------
      -- Check_Duplication --
      -----------------------

      procedure Check_Duplication (Id : Node_Id) is
         Handler   : Node_Id;
         Id1       : Node_Id;
         Id_Entity : Entity_Id := Entity (Id);

      begin
         if Present (Renamed_Entity (Id_Entity)) then
            Id_Entity := Renamed_Entity (Id_Entity);
         end if;

         Handler := First_Non_Pragma (L);
         while Present (Handler) loop
            Id1 := First (Exception_Choices (Handler));
            while Present (Id1) loop

               --  Only check against the exception choices which precede
               --  Id in the handler, since the ones that follow Id have not
               --  been analyzed yet and will be checked in a subsequent call.

               if Id = Id1 then
                  return;

               elsif Nkind (Id1) /= N_Others_Choice
                 and then
                   (Id_Entity = Entity (Id1)
                      or else (Id_Entity = Renamed_Entity (Entity (Id1))))
               then
                  if Handler /= Parent (Id) then
                     Error_Msg_Sloc := Sloc (Id1);
                     Error_Msg_NE
                       ("exception choice duplicates &#", Id, Id1);

                  else
                     if Ada_Version = Ada_83
                       and then Comes_From_Source (Id)
                     then
                        Error_Msg_N
                          ("(Ada 83): duplicate exception choice&", Id);
                     end if;
                  end if;
               end if;

               Next_Non_Pragma (Id1);
            end loop;

            Next (Handler);
         end loop;
      end Check_Duplication;

      --------------------
      -- Others_Present --
      --------------------

      function Others_Present return Boolean is
         H : Node_Id;

      begin
         H := First (L);
         while Present (H) loop
            if Nkind (H) /= N_Pragma
              and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
            then
               return True;
            end if;

            Next (H);
         end loop;

         return False;
      end Others_Present;

   --  Start processing for Analyze_Exception_Handlers

   begin
      Handler := First (L);
      Check_Restriction (No_Exceptions, Handler);
      Check_Restriction (No_Exception_Handlers, Handler);

      --  Kill current remembered values, since we don't know where we were
      --  when the exception was raised.

      Kill_Current_Values;

      --  Loop through handlers (which can include pragmas)

      while Present (Handler) loop

         --  If pragma just analyze it

         if Nkind (Handler) = N_Pragma then
            Analyze (Handler);

         --  Otherwise we have a real exception handler

         else
            --  Deal with choice parameter. The exception handler is
            --  a declarative part for it, so it constitutes a scope
            --  for visibility purposes. We create an entity to denote
            --  the whole exception part, and use it as the scope of all
            --  the choices, which may even have the same name without
            --  conflict. This scope plays no other role in expansion or
            --  or code generation.

            Choice := Choice_Parameter (Handler);

            if Present (Choice) then
               if No (H_Scope) then
                  H_Scope := New_Internal_Entity
                    (E_Block, Current_Scope, Sloc (Choice), 'E');
               end if;

               New_Scope (H_Scope);
               Set_Etype (H_Scope, Standard_Void_Type);

               --  Set the Finalization Chain entity to Error means that it
               --  should not be used at that level but the parent one
               --  should be used instead.

               --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
               --  ??? using Error for this non-error condition is nasty ???

               Set_Finalization_Chain_Entity (H_Scope, Error);

               Enter_Name (Choice);
               Set_Ekind (Choice, E_Variable);
               Set_Etype (Choice, RTE (RE_Exception_Occurrence));
               Generate_Definition (Choice);

               --  Set source assigned flag, since in effect this field
               --  is always assigned an initial value by the exception.

               Set_Never_Set_In_Source (Choice, False);
            end if;

            Id := First (Exception_Choices (Handler));
            while Present (Id) loop
               if Nkind (Id) = N_Others_Choice then
                  if Present (Next (Id))
                    or else Present (Next (Handler))
                    or else Present (Prev (Id))
                  then
                     Error_Msg_N ("OTHERS must appear alone and last", Id);
                  end if;

               else
                  Analyze (Id);

                  if not Is_Entity_Name (Id)
                    or else Ekind (Entity (Id)) /= E_Exception
                  then
                     Error_Msg_N ("exception name expected", Id);

                  else
                     if Present (Renamed_Entity (Entity (Id))) then
                        if Entity (Id) = Standard_Numeric_Error then
                           Check_Restriction (No_Obsolescent_Features, Id);

                           if Warn_On_Obsolescent_Feature then
                              Error_Msg_N
                                ("Numeric_Error is an " &
                                 "obsolescent feature ('R'M 'J.6(1))?", Id);
                              Error_Msg_N
                                ("\use Constraint_Error instead?", Id);
                           end if;
                        end if;
                     end if;

                     Check_Duplication (Id);

                     --  Check for exception declared within generic formal
                     --  package (which is illegal, see RM 11.2(8))

                     declare
                        Ent  : Entity_Id := Entity (Id);
                        Scop : Entity_Id;

                     begin
                        if Present (Renamed_Entity (Ent)) then
                           Ent := Renamed_Entity (Ent);
                        end if;

                        Scop := Scope (Ent);
                        while Scop /= Standard_Standard
                          and then Ekind (Scop) = E_Package
                        loop
                           --  If the exception is declared in an inner
                           --  instance, nothing else to check.

                           if Is_Generic_Instance (Scop) then
                              exit;

                           elsif Nkind (Declaration_Node (Scop)) =
                                           N_Package_Specification
                             and then
                               Nkind (Original_Node (Parent
                                 (Declaration_Node (Scop)))) =
                                           N_Formal_Package_Declaration
                           then
                              Error_Msg_NE
                                ("exception& is declared in "  &
                                 "generic formal package", Id, Ent);
                              Error_Msg_N
                                ("\and therefore cannot appear in " &
                                 "handler ('R'M 11.2(8))", Id);
                              exit;
                           end if;

                           Scop := Scope (Scop);
                        end loop;
                     end;
                  end if;
               end if;

               Next (Id);
            end loop;

            --  Check for redundant handler (has only raise statement) and
            --  is either an others handler, or is a specific handler when
            --  no others handler is present.

            if Warn_On_Redundant_Constructs
              and then List_Length (Statements (Handler)) = 1
              and then Nkind (First (Statements (Handler))) = N_Raise_Statement
              and then No (Name (First (Statements (Handler))))
              and then (not Others_Present
                          or else Nkind (First (Exception_Choices (Handler))) =
                                              N_Others_Choice)
            then
               Error_Msg_N
                 ("useless handler contains only a reraise statement?",
                  Handler);
            end if;

            --  Now analyze the statements of this handler

            Analyze_Statements (Statements (Handler));

            --  If a choice was present, we created a special scope for it,
            --  so this is where we pop that special scope to get rid of it.

            if Present (Choice) then
               End_Scope;
            end if;
         end if;

         Next (Handler);
      end loop;
   end Analyze_Exception_Handlers;

   --------------------------------
   -- Analyze_Handled_Statements --
   --------------------------------

   procedure Analyze_Handled_Statements (N : Node_Id) is
      Handlers : constant List_Id := Exception_Handlers (N);

   begin
      if Present (Handlers) then
         Kill_All_Checks;
      end if;

      Analyze_Statements (Statements (N));

      if Present (Handlers) then
         Analyze_Exception_Handlers (Handlers);

      elsif Present (At_End_Proc (N)) then
         Analyze (At_End_Proc (N));
      end if;
   end Analyze_Handled_Statements;

   -----------------------------
   -- Analyze_Raise_Statement --
   -----------------------------

   procedure Analyze_Raise_Statement (N : Node_Id) is
      Exception_Id   : constant Node_Id := Name (N);
      Exception_Name : Entity_Id        := Empty;
      P              : Node_Id;
      Nkind_P        : Node_Kind;

   begin
      Check_Unreachable_Code (N);

      --  Check exception restrictions on the original source

      if Comes_From_Source (N) then
         Check_Restriction (No_Exceptions, N);
      end if;

      --  Check for useless assignment to OUT or IN OUT scalar
      --  immediately preceding the raise. Right now we only look
      --  at assignment statements, we could do more.

      if Is_List_Member (N) then
         declare
            P : Node_Id;
            L : Node_Id;

         begin
            P := Prev (N);

            if Present (P)
              and then Nkind (P) = N_Assignment_Statement
            then
               L := Name (P);

               if Is_Scalar_Type (Etype (L))
                 and then Is_Entity_Name (L)
                 and then Is_Formal (Entity (L))
               then
                  Error_Msg_N
                    ("?assignment to pass-by-copy formal may have no effect",
                      P);
                  Error_Msg_N
                    ("\?RAISE statement may result in abnormal return" &
                     " ('R'M 6.4.1(17))", P);
               end if;
            end if;
         end;
      end if;

      --  Reraise statement

      if No (Exception_Id) then

         P := Parent (N);
         Nkind_P := Nkind (P);

         while Nkind_P /= N_Exception_Handler
           and then Nkind_P /= N_Subprogram_Body
           and then Nkind_P /= N_Package_Body
           and then Nkind_P /= N_Task_Body
           and then Nkind_P /= N_Entry_Body
         loop
            P := Parent (P);
            Nkind_P := Nkind (P);
         end loop;

         if Nkind (P) /= N_Exception_Handler then
            Error_Msg_N
              ("reraise statement must appear directly in a handler", N);
         end if;

      --  Normal case with exception id present

      else
         Analyze (Exception_Id);

         if Is_Entity_Name (Exception_Id) then
            Exception_Name := Entity (Exception_Id);
         end if;

         if No (Exception_Name)
           or else Ekind (Exception_Name) /= E_Exception
         then
            Error_Msg_N
              ("exception name expected in raise statement", Exception_Id);
         end if;

         if Present (Expression (N)) then
            Analyze_And_Resolve (Expression (N), Standard_String);
         end if;
      end if;
   end Analyze_Raise_Statement;

   -----------------------------
   -- Analyze_Raise_xxx_Error --
   -----------------------------

   --  Normally, the Etype is already set (when this node is used within
   --  an expression, since it is copied from the node which it rewrites).
   --  If this node is used in a statement context, then we set the type
   --  Standard_Void_Type. This is used both by Gigi and by the front end
   --  to distinguish the statement use and the subexpression use.

   --  The only other required processing is to take care of the Condition
   --  field if one is present.

   procedure Analyze_Raise_xxx_Error (N : Node_Id) is
   begin
      if No (Etype (N)) then
         Set_Etype (N, Standard_Void_Type);
      end if;

      if Present (Condition (N)) then
         Analyze_And_Resolve (Condition (N), Standard_Boolean);
      end if;

      --  Deal with static cases in obvious manner

      if Nkind (Condition (N)) = N_Identifier then
         if Entity (Condition (N)) = Standard_True then
            Set_Condition (N, Empty);

         elsif Entity (Condition (N)) = Standard_False then
            Rewrite (N, Make_Null_Statement (Sloc (N)));
         end if;
      end if;
   end Analyze_Raise_xxx_Error;

   -----------------------------
   -- Analyze_Subprogram_Info --
   -----------------------------

   procedure Analyze_Subprogram_Info (N : Node_Id) is
   begin
      Set_Etype (N, RTE (RE_Code_Loc));
   end Analyze_Subprogram_Info;

end Sem_Ch11;