-- --
-- 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. --
-- 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)
-- 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
-- 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.
-- 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.
----------------------------------------------------
-- 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
-- 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
-- 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).
-- 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
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.
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)
-------------
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
-- 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;
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
-- 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;
-- 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.
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;
-- 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
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).
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;
--------------
-- 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)
if Configuration_Pragmas then
declare
- Ecount : constant Int := Serious_Errors_Detected;
Pragmas : constant List_Id := Empty_List;
P_Node : Node_Id;
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;
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
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
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
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.
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