home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_ch11.adb < prev    next >
Text File  |  1996-09-28  |  9KB  |  254 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             S E M _ C H 1 1                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.47 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Einfo;    use Einfo;
  27. with Errout;   use Errout;
  28. with Features; use Features;
  29. with Lib;      use Lib;
  30. with Namet;    use Namet;
  31. with Nlists;   use Nlists;
  32. with Opt;      use Opt;
  33. with Rtsfind;  use Rtsfind;
  34. with Sem;      use Sem;
  35. with Sem_Ch5;  use Sem_Ch5;
  36. with Sem_Ch8;  use Sem_Ch8;
  37. with Sem_Dist; use Sem_Dist;
  38. with Sem_Util; use Sem_Util;
  39. with Sinfo;    use Sinfo;
  40. with Stand;    use Stand;
  41.  
  42. package body Sem_Ch11 is
  43.  
  44.    -----------------------------------
  45.    -- Analyze_Exception_Declaration --
  46.    -----------------------------------
  47.  
  48.    procedure Analyze_Exception_Declaration (N : Node_Id) is
  49.       Id : constant Entity_Id := Defining_Identifier (N);
  50.       PF : constant Boolean   := Is_Pure (Current_Scope);
  51.  
  52.    begin
  53.       Enter_Name (Id);
  54.       Set_Ekind (Id, E_Exception);
  55.       Set_Etype (Id, Standard_Exception_Type);
  56.  
  57.       --  Entities declared in Pure unit should be set Is_Pure
  58.       --  Since 'Partition_Id cannot be applied to such an entity
  59.  
  60.       Set_Is_Pure (Id, PF);
  61.  
  62.    end Analyze_Exception_Declaration;
  63.  
  64.    --------------------------------
  65.    -- Analyze_Handled_Statements --
  66.    --------------------------------
  67.  
  68.    procedure Analyze_Handled_Statements (N : Node_Id) is
  69.       Handlers : constant List_Id := Exception_Handlers (N);
  70.  
  71.    begin
  72.       Analyze_Statements (Statements (N));
  73.  
  74.       if Present (Handlers) then
  75.          Analyze_Exception_Handlers (Handlers);
  76.  
  77.       elsif Present (Identifier (N)) then
  78.          Analyze (Identifier (N));
  79.       end if;
  80.    end Analyze_Handled_Statements;
  81.  
  82.    --------------------------------
  83.    -- Analyze_Exception_Handlers --
  84.    --------------------------------
  85.  
  86.    procedure Analyze_Exception_Handlers (L : List_Id) is
  87.       Handler : Node_Id;
  88.       Choice  : Entity_Id;
  89.       Id      : Node_Id;
  90.  
  91.       procedure Check_Duplication (Id : Node_Id);
  92.       --  Iterate through the identifiers in each handler to find duplicates
  93.  
  94.       procedure Check_Duplication (Id : Node_Id) is
  95.          Handler : Node_Id;
  96.          Id1     : Node_Id;
  97.  
  98.       begin
  99.          Handler := First (L);
  100.          while Present (Handler) loop
  101.             Id1 := First (Exception_Choices (Handler));
  102.  
  103.             while Present (Id1) loop
  104.  
  105.                --  Only check against the exception choices which precede
  106.                --  Id in the handler, since the ones that follow Id have not
  107.                --  been analyzed yet and will be checked in a subsequent call.
  108.  
  109.                if Id = Id1 then
  110.                   return;
  111.  
  112.                elsif Nkind (Id1) /= N_Others_Choice
  113.                  and then Entity (Id) = Entity (Id1)
  114.                then
  115.                   if Handler /= Parent (Id) then
  116.                      Error_Msg_N ("duplicate exception choice&", Id);
  117.  
  118.                   else
  119.                      Note_Feature (Exception_Choices, Sloc (Id));
  120.  
  121.                      if Ada_83 and then Comes_From_Source (Id) then
  122.                         Error_Msg_N
  123.                           ("(Ada 83): duplicate exception choice&", Id);
  124.                      end if;
  125.                   end if;
  126.                end if;
  127.  
  128.                Id1 := Next (Id1);
  129.             end loop;
  130.  
  131.             Handler := Next (Handler);
  132.          end loop;
  133.       end Check_Duplication;
  134.  
  135.    --  Start processing for Analyze_Exception_Handlers
  136.  
  137.    begin
  138.       Handler := First (L);
  139.  
  140.       while Present (Handler) loop
  141.          Id := First (Exception_Choices (Handler));
  142.  
  143.          while Present (Id) loop
  144.             if Nkind (Id) = N_Others_Choice then
  145.                if Present (Next (Id))
  146.                  or else Present (Next (Handler))
  147.                  or else Present (Prev (Id))
  148.                then
  149.                   Error_Msg_N ("OTHERS must appear alone and last", Id);
  150.                end if;
  151.  
  152.             else
  153.                Analyze (Id);
  154.  
  155.                if Is_Entity_Name (Id)
  156.                   and then Present (Renamed_Object (Entity (Id)))
  157.                then
  158.                   Set_Entity (Id, Renamed_Object (Entity (Id)));
  159.                end if;
  160.  
  161.                if not Is_Entity_Name (Id)
  162.                  or else Ekind (Entity (Id)) /= E_Exception
  163.                then
  164.                   Error_Msg_N ("exception name expected", Id);
  165.                else
  166.                   Check_Duplication (Id);
  167.                end if;
  168.             end if;
  169.  
  170.             Id := Next (Id);
  171.          end loop;
  172.  
  173.          Choice := Choice_Parameter (Handler);
  174.          if Present (Choice) then
  175.             Enter_Name (Choice);
  176.             Set_Ekind (Choice, E_Variable);
  177.             Set_Etype (Choice, RTE (RE_Exception_Occurrence));
  178.          end if;
  179.  
  180.          Analyze_Statements (Statements (Handler));
  181.  
  182.          Handler := Next (Handler);
  183.       end loop;
  184.    end Analyze_Exception_Handlers;
  185.  
  186.    -----------------------------
  187.    -- Analyze_Raise_Statement --
  188.    -----------------------------
  189.  
  190.    procedure Analyze_Raise_Statement (N : Node_Id) is
  191.       Exception_Id   : constant Node_Id := Name (N);
  192.       Exception_Name : Entity_Id := Empty;
  193.       P              : Node_Id;
  194.       Nkind_P        : Node_Kind;
  195.  
  196.    begin
  197.       --  Reraise statement
  198.  
  199.       if No (Exception_Id) then
  200.  
  201.          P := Parent (N);
  202.          Nkind_P := Nkind (P);
  203.  
  204.          while Nkind_P /= N_Exception_Handler
  205.            and then Nkind_P /= N_Subprogram_Body
  206.            and then Nkind_P /= N_Package_Body
  207.            and then Nkind_P /= N_Task_Body
  208.            and then Nkind_P /= N_Entry_Body
  209.          loop
  210.             P := Parent (P);
  211.             Nkind_P := Nkind (P);
  212.          end loop;
  213.  
  214.          if Nkind (P) /= N_Exception_Handler then
  215.             Error_Msg_N
  216.               ("reraise statement must appear directly in a handler", N);
  217.          end if;
  218.  
  219.       --  Normal case with exception id present
  220.  
  221.       else
  222.          Analyze (Exception_Id);
  223.  
  224.          if Is_Entity_Name (Exception_Id) then
  225.             Exception_Name := Entity (Exception_Id);
  226.  
  227.             if Present (Renamed_Object (Exception_Name)) then
  228.                Set_Entity (Exception_Id, Renamed_Object (Exception_Name));
  229.             end if;
  230.          end if;
  231.  
  232.          if No (Exception_Name)
  233.            or else Ekind (Exception_Name) /= E_Exception
  234.          then
  235.             Error_Msg_N
  236.               ("exception name expected in raise statement", Exception_Id);
  237.          end if;
  238.  
  239.          --  If raise appears in System-Finalization_Implementation, then
  240.          --  set the No_Defer flag. The reason is that we already deferred
  241.          --  abort on entering the finalization routine, and we must not
  242.          --  do an additional defer as the result of raising program error.
  243.  
  244.          Get_Name_String (Unit_Name (Get_Sloc_Unit_Number (Sloc (N))));
  245.  
  246.          if Name_Buffer (1 .. 24) = "system.finalization_impl" then
  247.             Set_No_Defer (N);
  248.          end if;
  249.  
  250.       end if;
  251.    end Analyze_Raise_Statement;
  252.  
  253. end Sem_Ch11;
  254.