g-table.adb, [...]: Fix comment typos.
[platform/upstream/gcc.git] / gcc / ada / par.adb
index 1a1d975..a76ee25 100644 (file)
@@ -6,18 +6,17 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2008, 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- --
+-- 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 COPYING.  If not, write --
--- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
--- MA 02111-1307, USA.                                                      --
+-- 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.      --
@@ -50,8 +49,9 @@ with Tbuild;   use Tbuild;
 -- Par --
 ---------
 
-function Par (Configuration_Pragmas : Boolean) return List_Id is
-
+function Par
+  (Configuration_Pragmas : Boolean) return List_Id
+is
    Num_Library_Units : Natural := 0;
    --  Count number of units parsed (relevant only in syntax check only mode,
    --  since in semantics check mode only a single unit is permitted anyway)
@@ -92,7 +92,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --  an entry in the scope stack, invalidating the contents of the stack.
 
    Error_Resync : exception;
-   --  Exception raised on error that is not handled locally, see above.
+   --  Exception raised on error that is not handled locally, see above
 
    Last_Resync_Point : Source_Ptr;
    --  The resynchronization routines in Par.Sync run a risk of getting
@@ -140,7 +140,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --  whose body is required and has not yet been found. The prefix SIS
    --  stands for "Subprogram IS" handling.
 
-   SIS_Entry_Active : Boolean;
+   SIS_Entry_Active : Boolean := False;
    --  Set True to indicate that an entry is active (i.e. that a subprogram
    --  declaration has been encountered, and no body for this subprogram has
    --  been encountered). The remaining fields are valid only if this is True.
@@ -182,12 +182,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --   of such a nested region. Again, like case 2, this causes us to miss
    --   some nested cases, but it doesn't seen worth the effort to stack and
    --   unstack the SIS information. Maybe we will reconsider this if we ever
-   --   get a complaint about a missed case :-)
+   --   get a complaint about a missed case.
 
    --   4. We encounter a valid pragma INTERFACE or IMPORT that effectively
    --   supplies the missing body. In this case we reset the entry.
 
-   --   5. We encounter the end of the declarative region without encoutering
+   --   5. We encounter the end of the declarative region without encountering
    --   a BEGIN first. In this situation we simply reset the entry. We know
    --   that there is a missing body, but it seems more reasonable to let the
    --   later semantic checking discover this.
@@ -197,7 +197,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    ----------------------------------------------------
 
    --  Note: throughout the parser, the terms reserved word and keyword
-   --  are used interchangably to refer to the same set of reserved
+   --  are used interchangeably to refer to the same set of reserved
    --  keywords (including until, protected, etc).
 
    --  If a reserved word is used in place of an identifier, the parser
@@ -213,14 +213,14 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --  further confirmation.
 
    --  In the case of an identifier appearing in the identifier list of a
-   --  declaration, the appearence of a comma or colon right after the
+   --  declaration, the appearance of a comma or colon right after the
    --  keyword on the same line is taken as confirmation. For an enumeration
    --  literal, a comma or right paren right after the identifier is also
    --  treated as adequate confirmation.
 
    --  The following type is used in calls to Is_Reserved_Identifier and
    --  also to P_Defining_Identifier and P_Identifier. The default for all
-   --  these functins is that reserved words in reserved word case are not
+   --  these functions is that reserved words in reserved word case are not
    --  considered to be reserved identifiers. The Id_Check value indicates
    --  tokens, which if they appear immediately after the identifier, are
    --  taken as confirming that the use of an identifier was expected
@@ -282,7 +282,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --    end;
 
    --  The trouble is that the section of text from PROCEDURE B through END;
-   --  consitutes a valid procedure body, and the danger is that we find out
+   --  constitutes a valid procedure body, and the danger is that we find out
    --  far too late that something is wrong (indeed most compilers will behave
    --  uncomfortably on the above example).
 
@@ -296,7 +296,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    --  reserve the END; for the outer level.) For more details on this aspect
    --  of the handling, see package Par.Endh.
 
-   --  If we can avoid eating up the END; then the result in the absense of
+   --  If we can avoid eating up the END; then the result in the absence of
    --  any additional steps would be to post a missing END referring back to
    --  the subprogram with the bogus IS. Similarly, if the enclosing package
    --  has no BEGIN, then the result is a missing BEGIN message, which again
@@ -395,6 +395,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    SS_Whtm           : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F);
    SS_Unco           : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T);
 
+   Goto_List : Elist_Id;
+   --  List of goto nodes appearing in the current compilation. Used to
+   --  recognize natural loops and convert them into bona fide loops for
+   --  optimization purposes.
+
    Label_List : Elist_Id;
    --  List of label nodes for labels appearing in the current compilation.
    --  Used by Par.Labl to construct the corresponding implicit declarations.
@@ -426,6 +431,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
        E_If,              -- END IF;
        E_Loop,            -- END LOOP;
        E_Record,          -- END RECORD;
+       E_Return,          -- END RETURN;
        E_Select,          -- END SELECT;
        E_Name,            -- END [name];
        E_Suspicious_Is,   -- END [name]; (case of suspicious IS)
@@ -524,7 +530,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    -------------
 
    package Ch2 is
-      function P_Pragma                               return Node_Id;
+      function P_Pragma (Skipping : Boolean := False) return Node_Id;
+      --  Scan out a pragma. If Skipping is True, then the caller is skipping
+      --  the pragma in the context of illegal placement (this is used to avoid
+      --  some junk cascaded messages).
 
       function P_Identifier (C : Id_Check := None) return Node_Id;
       --  Scans out an identifier. The parameter C determines the treatment
@@ -557,8 +566,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       --  variable, then the caller can change it to an appropriate missing
       --  begin message if indeed the BEGIN is missing.
 
-      function P_Access_Definition                    return Node_Id;
-      function P_Access_Type_Definition               return Node_Id;
       function P_Array_Type_Definition                return Node_Id;
       function P_Basic_Declarative_Items              return List_Id;
       function P_Constraint_Opt                       return Node_Id;
@@ -576,6 +583,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       function P_Subtype_Mark_Resync                  return Node_Id;
       function P_Unknown_Discriminant_Part_Opt        return Boolean;
 
+      function P_Access_Definition
+        (Null_Exclusion_Present : Boolean) return Node_Id;
+      --  Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part
+      --  and indicates if it was present
+
+      function P_Access_Type_Definition
+        (Header_Already_Parsed : Boolean := False) return Node_Id;
+      --  Ada 2005 (AI-254): The formal is used to indicate if the caller has
+      --  parsed the null_exclusion part. In this case the caller has also
+      --  removed the ACCESS token
+
       procedure P_Component_Items (Decls : List_Id);
       --  Scan out one or more component items and append them to the
       --  given list. Only scans out more than one declaration in the
@@ -587,13 +605,27 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       --  treatment of errors in case a reserved word is scanned. See the
       --  declaration of this type for details.
 
-      function P_Null_Exclusion return Boolean;
-      --  Ada 0Y (AI-231): Parse the null-excluding part. True indicates
-      --  that the null-excluding part was present.
+      function P_Interface_Type_Definition
+        (Abstract_Present : Boolean) return Node_Id;
+      --  Ada 2005 (AI-251): Parse the interface type definition part. Abstract
+      --  Present indicates if the reserved word "abstract" has been previously
+      --  found. It is used to report an error message because interface types
+      --  are by definition abstract tagged. We generate a record_definition
+      --  node if the list of interfaces is empty; otherwise we generate a
+      --  derived_type_definition node (the first interface in this list is the
+      --  ancestor interface).
+
+      function P_Null_Exclusion
+        (Allow_Anonymous_In_95 : Boolean := False) return Boolean;
+      --  Ada 2005 (AI-231): Parse the null-excluding part. A True result
+      --  indicates that the null-excluding part was present.
+      --  Allow_Anonymous_In_95 is True if we are in a context that allows
+      --  anonymous access types in Ada 95, in which case "not null" is legal
+      --  if it precedes "access".
 
       function P_Subtype_Indication
         (Not_Null_Present : Boolean := False) return Node_Id;
-      --  Ada 0Y (AI-231): The flag Not_Null_Present indicates that the
+      --  Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
       --  null-excluding part has been scanned out and it was present.
 
       function Init_Expr_Opt (P : Boolean := False) return Node_Id;
@@ -605,7 +637,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       --  allowed).
 
       procedure Skip_Declaration (S : List_Id);
-      --  Used when scanning statements to skip past a mispaced declaration
+      --  Used when scanning statements to skip past a misplaced declaration
       --  The declaration is scanned out and appended to the given list.
       --  Token is known to be a declaration token (in Token_Class_Declk)
       --  on entry, so there definition is a declaration to be scanned.
@@ -615,7 +647,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
          Not_Null_Present : Boolean := False) return Node_Id;
       --  This version of P_Subtype_Indication is called when the caller has
       --  already scanned out the subtype mark which is passed as a parameter.
-      --  Ada 0Y (AI-231): The flag Not_Null_Present indicates that the
+      --  Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
       --  null-excluding part has been scanned out and it was present.
 
       function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id;
@@ -882,7 +914,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       --  Used if an error occurs while scanning a parenthesized list of items
       --  separated by semicolons. The scan pointer is advanced to the next
       --  semicolon or right parenthesis at the outer parenthesis level, or
-      --  to the next is or RETURN keyword occurence, whichever comes first.
+      --  to the next is or RETURN keyword occurrence, whichever comes first.
 
       procedure Resync_Cunit;
       --  Synchronize to next token which could be the start of a compilation
@@ -936,7 +968,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       procedure T_When;
       procedure T_With;
 
-      --  Procedures have names of the form TF_xxx, where Tok_xxx is a token
+      --  Procedures having names of the form TF_xxx, where Tok_xxx is a token
       --  name check that the current token matches the required token, and
       --  if so, scan past it. If not, an error message is issued indicating
       --  that the required token is not present (xxx expected).
@@ -958,6 +990,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       procedure TF_Semicolon;
       procedure TF_Then;
       procedure TF_Use;
+
+      --  Procedures with names of the form U_xxx, where Tok_xxx is a token
+      --  name, are just like the corresponding T_xxx procedures except that
+      --  an error message, if given, is unconditional.
+
+      procedure U_Left_Paren;
+      procedure U_Right_Paren;
    end Tchk;
 
    --------------
@@ -1052,16 +1091,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       --  conditions are met, an error message is issued, and the merge is
       --  carried out, modifying the Chars field of Prev.
 
+      function Next_Token_Is (Tok : Token_Type) return Boolean;
+      --  Looks at token after current one and returns True if the token type
+      --  matches Tok. The scan is unconditionally restored on return.
+
       procedure No_Constraint;
       --  Called in a place where no constraint is allowed, but one might
       --  appear due to a common error (e.g. after the type mark in a procedure
       --  parameter. If a constraint is present, an error message is posted,
       --  and the constraint is scanned and discarded.
 
-      function No_Right_Paren (Expr : Node_Id) return Node_Id;
-      --  Function to check for no right paren at end of expression, returns
-      --  its argument if no right paren, else flags paren and returns Error.
-
       procedure Push_Scope_Stack;
       pragma Inline (Push_Scope_Stack);
       --  Push a new entry onto the scope stack. Scope.Last (the stack pointer)
@@ -1194,7 +1233,6 @@ begin
 
    if Configuration_Pragmas then
       declare
-         Ecount  : constant Int     := Serious_Errors_Detected;
          Pragmas : constant List_Id := Empty_List;
          P_Node  : Node_Id;
 
@@ -1210,20 +1248,29 @@ begin
             else
                P_Node := P_Pragma;
 
-               if Serious_Errors_Detected > Ecount then
-                  return Error_List;
-               end if;
+               if Nkind (P_Node) = N_Pragma then
 
-               if Chars (P_Node) > Last_Configuration_Pragma_Name
-                 and then Chars (P_Node) /= Name_Source_Reference
-               then
-                  Error_Msg_SC
-                    ("only configuration pragmas allowed " &
-                     "in configuration file");
-                  return Error_List;
-               end if;
+                  --  Give error if bad pragma
+
+                  if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node))
+                    and then Pragma_Name (P_Node) /= Name_Source_Reference
+                  then
+                     if Is_Pragma_Name (Pragma_Name (P_Node)) then
+                        Error_Msg_N
+                          ("only configuration pragmas allowed " &
+                           "in configuration file", P_Node);
+                     else
+                        Error_Msg_N
+                          ("unrecognized pragma in configuration file",
+                           P_Node);
+                     end if;
 
-               Append (P_Node, Pragmas);
+                  --  Pragma is OK config pragma, so collect it
+
+                  else
+                     Append (P_Node, Pragmas);
+                  end if;
+               end if;
             end if;
          end loop;
       end;
@@ -1233,38 +1280,6 @@ begin
    else
       Save_Opt_Config_Switches (Save_Config_Switches);
 
-      --  Special processing for language defined units. For this purpose
-      --  we do NOT consider the renamings in annex J as predefined. That
-      --  allows users to compile their own versions of these files, and
-      --  in particular, in the VMS implementation, the DEC versions can
-      --  be substituted for the standard Ada 95 versions.
-
-      if Is_Predefined_File_Name
-           (Fname => File_Name (Current_Source_File),
-            Renamings_Included => False)
-      then
-         Set_Opt_Config_Switches
-           (Is_Internal_File_Name (File_Name (Current_Source_File)));
-
-         --  If this is the main unit, disallow compilation unless the -gnatg
-         --  (GNAT mode) switch is set (from a user point of view, the rule is
-         --  that language defined units cannot be recompiled).
-
-         --  However, an exception is s-rpc, and its children. We test this
-         --  by looking at the characters after the minus. The rule is that
-         --  only s-rpc and its children have names starting s-rp.
-
-         Get_Name_String (File_Name (Current_Source_File));
-
-         if (Name_Len < 5 or else Name_Buffer (1 .. 4) /= "s-rp")
-           and then Current_Source_Unit = Main_Unit
-           and then not GNAT_Mode
-           and then Operating_Mode = Generate_Code
-         then
-            Error_Msg_SC ("language defined units may not be recompiled");
-         end if;
-      end if;
-
       --  The following loop runs more than once in syntax check mode
       --  where we allow multiple compilation units in the same file
       --  and in Multiple_Unit_Per_file mode where we skip units till
@@ -1272,7 +1287,8 @@ begin
 
       for Ucount in Pos loop
          Set_Opt_Config_Switches
-           (Is_Internal_File_Name (File_Name (Current_Source_File)));
+           (Is_Internal_File_Name (File_Name (Current_Source_File)),
+            Current_Source_Unit = Main_Unit);
 
          --  Initialize scope table and other parser control variables
 
@@ -1283,6 +1299,7 @@ begin
          SIS_Entry_Active := False;
          Last_Resync_Point := No_Location;
 
+         Goto_List  := New_Elmt_List;
          Label_List := New_Elmt_List;
 
          --  If in multiple unit per file mode, skip past ignored unit
@@ -1298,10 +1315,14 @@ begin
                Save_Operating_Mode : constant Operating_Mode_Type :=
                                        Operating_Mode;
 
+               Save_Style_Check : constant Boolean := Style_Check;
+
             begin
                Operating_Mode := Check_Syntax;
+               Style_Check := False;
                Discard_Node (P_Compilation_Unit);
                Operating_Mode := Save_Operating_Mode;
+               Style_Check := Save_Style_Check;
 
                --  If we are at an end of file, and not yet at the right
                --  unit, then we have a fatal error. The unit is missing.
@@ -1312,12 +1333,85 @@ begin
                end if;
             end;
 
-            --  Here if we are not skipping a file in multiple unit per file
-            --  mode. Parse the unit that we are interested in. Note that in
-            --  check syntax mode we are interested in all units in the file.
+         --  Here if we are not skipping a file in multiple unit per file
+         --  mode. Parse the unit that we are interested in. Note that in
+         --  check syntax mode we are interested in all units in the file.
 
          else
-            Discard_Node (P_Compilation_Unit);
+            declare
+               Comp_Unit_Node : constant Node_Id := P_Compilation_Unit;
+
+            begin
+               --  If parsing was successful and we are not in check syntax
+               --  mode, check that language defined units are compiled in
+               --  GNAT mode. For this purpose we do NOT consider renamings
+               --  in annex J as predefined. That allows users to compile
+               --  their own versions of these files, and in particular,
+               --  in the VMS implementation, the DEC versions can be
+               --  substituted for the standard Ada 95 versions. Another
+               --  exception is System.RPC and its children. This allows
+               --  a user to supply their own communication layer.
+
+               if Comp_Unit_Node /= Error
+                 and then Operating_Mode = Generate_Code
+                 and then Current_Source_Unit = Main_Unit
+                 and then not GNAT_Mode
+               then
+                  declare
+                     Uname : constant String :=
+                               Get_Name_String
+                                 (Unit_Name (Current_Source_Unit));
+                     Name  : String (1 .. Uname'Length - 2);
+
+                  begin
+                     --  Because Unit_Name includes "%s" or "%b", we need to
+                     --  strip the last two characters to get the real unit
+                     --  name.
+
+                     Name := Uname (Uname'First .. Uname'Last - 2);
+
+                     if Name = "ada"         or else
+                        Name = "interfaces"  or else
+                        Name = "system"
+                     then
+                        Error_Msg
+                          ("language defined units may not be recompiled",
+                           Sloc (Unit (Comp_Unit_Node)));
+
+                     elsif Name'Length > 4
+                       and then
+                         Name (Name'First .. Name'First + 3) = "ada."
+                     then
+                        Error_Msg
+                          ("descendents of package Ada " &
+                             "may not be compiled",
+                           Sloc (Unit (Comp_Unit_Node)));
+
+                     elsif Name'Length > 11
+                       and then
+                         Name (Name'First .. Name'First + 10) = "interfaces."
+                     then
+                        Error_Msg
+                          ("descendents of package Interfaces " &
+                             "may not be compiled",
+                           Sloc (Unit (Comp_Unit_Node)));
+
+                     elsif Name'Length > 7
+                       and then Name (Name'First .. Name'First + 6) = "system."
+                       and then Name /= "system.rpc"
+                       and then
+                         (Name'Length < 11
+                            or else Name (Name'First .. Name'First + 10) /=
+                                                                 "system.rpc.")
+                     then
+                        Error_Msg
+                          ("descendents of package System " &
+                             "may not be compiled",
+                           Sloc (Unit (Comp_Unit_Node)));
+                     end if;
+                  end;
+               end if;
+            end;
 
             --  All done if at end of file