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 / par-ch7.adb < prev    next >
Text File  |  1996-09-28  |  10KB  |  262 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              P A R . C H 7                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.24 $                             --
  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. separate (Par)
  26. package body Ch7 is
  27.  
  28.    ---------------------------------------------
  29.    -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
  30.    ---------------------------------------------
  31.  
  32.    --  This routine scans out a package declaration, package body, or a
  33.    --  renaming declaration or generic instantiation starting with PACKAGE
  34.  
  35.    --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
  36.  
  37.    --  PACKAGE_SPECIFICATION ::=
  38.    --    package DEFINING_PROGRAM_UNIT_NAME is
  39.    --      {BASIC_DECLARATIVE_ITEM}
  40.    --    [private
  41.    --      {BASIC_DECLARATIVE_ITEM}]
  42.    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  43.  
  44.    --  PACKAGE_BODY ::=
  45.    --    package body DEFINING_PROGRAM_UNIT_NAME is
  46.    --      DECLARATIVE_PART
  47.    --    [begin
  48.    --      HANDLED_SEQUENCE_OF_STATEMENTS]
  49.    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  50.  
  51.    --  PACKAGE_RENAMING_DECLARATION ::=
  52.    --    package DEFINING_IDENTIFIER renames package_NAME;
  53.  
  54.    --  PACKAGE_BODY_STUB ::=
  55.    --    package body DEFINING_IDENTIFIER is separate;
  56.  
  57.    --  The value in Pf_Flags indicates which of these possible declarations
  58.    --  is acceptable to the caller:
  59.  
  60.    --    Pf_Flags.Spcn                 Set if specification OK
  61.    --    Pf_Flags.Decl                 Set if declaration OK
  62.    --    Pf_Flags.Gins                 Set if generic instantiation OK
  63.    --    Pf_Flags.Pbod                 Set if proper body OK
  64.    --    Pf_Flags.Rnam                 Set if renaming declaration OK
  65.    --    Pf_Flags.Stub                 Set if body stub OK
  66.  
  67.    --  If an inappropriate form is encountered, it is scanned out but an
  68.    --  error message indicating that it is appearing in an inappropriate
  69.    --  context is issued. The only possible settings for Pf_Flags are those
  70.    --  defined as constants in package Par.
  71.  
  72.    --  Note: in all contexts where a package specification is required, there
  73.    --  is a terminating semicolon. This semicolon is scanned out in the case
  74.    --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
  75.    --  of the package specification (it's just too much trouble, and really
  76.    --  quite unnecessary, to deal with scanning out an END where the semicolon
  77.    --  after the END is not considered to be part of the END.
  78.  
  79.    --  The caller has checked that the initial token is PACKAGE
  80.  
  81.    --  Error recovery: cannot raise Error_Resync
  82.  
  83.    function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
  84.       Package_Node       : Node_Id;
  85.       Specification_Node : Node_Id;
  86.       Name_Node          : Node_Id;
  87.       Package_Sloc       : Source_Ptr;
  88.  
  89.    begin
  90.       Push_Scope_Stack;
  91.       Scope.Table (Scope.Last).Etyp := E_Name;
  92.       Scope.Table (Scope.Last).Ecol := Start_Column;
  93.       Scope.Table (Scope.Last).Lreq := False;
  94.  
  95.       Package_Sloc := Token_Ptr;
  96.       Scan; -- past PACKAGE
  97.  
  98.       if Token = Tok_Type then
  99.          Error_Msg_SC ("TYPE not allowed here");
  100.          Scan; -- past TYPE
  101.       end if;
  102.  
  103.       --  Case of package body. Note that we demand a package body if that
  104.       --  is the only possibility (even if the BODY keyword is not present)
  105.  
  106.       if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
  107.          if not Pf_Flags.Pbod then
  108.             Error_Msg_SC ("package body cannot appear here!");
  109.          end if;
  110.  
  111.          T_Body;
  112.          Name_Node := P_Defining_Program_Unit_Name;
  113.          Scope.Table (Scope.Last).Labl := Name_Node;
  114.          TF_Is;
  115.  
  116.          if Separate_Present then
  117.             if not Pf_Flags.Stub then
  118.                Error_Msg_SC ("body stub cannot appear here!");
  119.             end if;
  120.  
  121.             Scan; -- past SEPARATE
  122.             TF_Semicolon;
  123.             Pop_Scope_Stack;
  124.  
  125.             Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
  126.             Set_Defining_Identifier (Package_Node, Name_Node);
  127.  
  128.          else
  129.             Package_Node := New_Node (N_Package_Body, Package_Sloc);
  130.             Set_Defining_Unit_Name (Package_Node, Name_Node);
  131.             Parse_Decls_Begin_End (Package_Node);
  132.          end if;
  133.  
  134.          return Package_Node;
  135.  
  136.       --  Cases other than Package_Body
  137.  
  138.       else
  139.          Name_Node := P_Defining_Program_Unit_Name;
  140.          Scope.Table (Scope.Last).Labl := Name_Node;
  141.  
  142.          --  Case of renaming declaration
  143.  
  144.          if Token = Tok_Renames then
  145.             if not Pf_Flags.Rnam then
  146.                Error_Msg_SC ("renaming declaration cannot appear here!");
  147.             end if;
  148.  
  149.             Scan; -- past RENAMES;
  150.  
  151.             Package_Node :=
  152.               New_Node (N_Package_Renaming_Declaration, Package_Sloc);
  153.             Set_Defining_Unit_Name (Package_Node, Name_Node);
  154.             Set_Name (Package_Node, P_Qualified_Simple_Name);
  155.  
  156.             No_Constraint;
  157.             TF_Semicolon;
  158.             Pop_Scope_Stack;
  159.             return Package_Node;
  160.  
  161.          else
  162.             TF_Is;
  163.  
  164.             --  Case of generic instantiation
  165.  
  166.             if Token = Tok_New then
  167.                if not Pf_Flags.Gins then
  168.                   Error_Msg_SC
  169.                      ("generic instantiation cannot appear here!");
  170.                end if;
  171.  
  172.                Scan; -- past NEW
  173.  
  174.                Package_Node :=
  175.                   New_Node (N_Package_Instantiation, Package_Sloc);
  176.                Set_Defining_Unit_Name (Package_Node, Name_Node);
  177.                Set_Name (Package_Node, P_Qualified_Simple_Name);
  178.                Set_Generic_Associations
  179.                  (Package_Node, P_Generic_Actual_Part_Opt);
  180.                TF_Semicolon;
  181.                Pop_Scope_Stack;
  182.  
  183.             --  Case of package declaration or package specification
  184.  
  185.             else
  186.                Specification_Node :=
  187.                  New_Node (N_Package_Specification, Package_Sloc);
  188.  
  189.                Set_Defining_Unit_Name (Specification_Node, Name_Node);
  190.                Set_Visible_Declarations
  191.                  (Specification_Node, P_Basic_Declarative_Items);
  192.  
  193.                if Token = Tok_Private then
  194.                   Scan; -- past PRIVATE
  195.                   Set_Private_Declarations
  196.                     (Specification_Node, P_Basic_Declarative_Items);
  197.  
  198.                   --  Deal gracefully with multiple PRIVATE parts
  199.  
  200.                   while Token = Tok_Private loop
  201.                      Error_Msg_SC
  202.                        ("only one private part allowed per package");
  203.                      Scan; -- past PRIVATE
  204.                      Append_List (P_Basic_Declarative_Items,
  205.                        Private_Declarations (Specification_Node));
  206.                   end loop;
  207.                end if;
  208.  
  209.                if Pf_Flags = Pf_Spcn then
  210.                   Package_Node := Specification_Node;
  211.                else
  212.                   Package_Node :=
  213.                     New_Node (N_Package_Declaration, Package_Sloc);
  214.                   Set_Specification (Package_Node, Specification_Node);
  215.                end if;
  216.  
  217.                if Token = Tok_Begin then
  218.                   Error_Msg_SC ("begin block not allowed in package spec");
  219.                   Scan; -- past BEGIN
  220.                   Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
  221.                end if;
  222.  
  223.                End_Statements;
  224.             end if;
  225.  
  226.             return Package_Node;
  227.          end if;
  228.       end if;
  229.    end P_Package;
  230.  
  231.    ------------------------------
  232.    -- 7.1  Package Declaration --
  233.    ------------------------------
  234.  
  235.    --  Parsed by P_Package (7.1)
  236.  
  237.    --------------------------------
  238.    -- 7.1  Package Specification --
  239.    --------------------------------
  240.  
  241.    --  Parsed by P_Package (7.1)
  242.  
  243.    -----------------------
  244.    -- 7.1  Package Body --
  245.    -----------------------
  246.  
  247.    --  Parsed by P_Package (7.1)
  248.  
  249.    -----------------------------------
  250.    -- 7.3  Private Type Declaration --
  251.    -----------------------------------
  252.  
  253.    --  Parsed by P_Type_Declaration (3.2.1)
  254.  
  255.    ----------------------------------------
  256.    -- 7.3  Private Extension Declaration --
  257.    ----------------------------------------
  258.  
  259.    --  Parsed by P_Type_Declaration (3.2.1)
  260.  
  261. end Ch7;
  262.