Clean up various issues found while working on VAST.
Fix uses of Token_Node, which was used in cases where it was documented
as undefined, leading to strange behavior with respect to setting Parent
nodes.
Obey the comment about Validate_Subprogram_Calls in frontend.adb,
"this work will be done by VAST". Remove conditionals on
Debug_Flag_Underscore_XX.
gcc/ada/ChangeLog:
* debug.adb: Remove doc for gnatd_X; no longer used.
* einfo.ads: Minor comment improvement.
* exp_ch3.adb: Minor reformatting.
* exp_ch6.adb (Check_BIP_Actuals): Export.
(Validate_Subprogram_Calls): Move to Vast.
* exp_ch6.ads (Check_BIP_Actuals): Export.
* exp_ch7.adb (Make_Init_Call): Remove obsolete Set_Assignment_OK.
* frontend.adb: Move Validate_Subprogram_Calls call to VAST,
as the comment suggested.
* par.adb: Minor comment improvements.
* par-ch13.adb (Get_Aspect_Specifications):
Misc cleanup, including removal of redundant setting
of Aspects, and changing multiple 'if's to 'case'.
* par-ch4.adb (P_Simple_Name_Resync): Do not refer to Token_Node
when it is documented as not defined.
* par-ch6.adb: Minor comment improvement.
* par-util.adb (Bad_Spelling_Of): After setting Token from
identifier to keyword, destroy Token_Node, so it doesn't get
accidentally used.
* scans.adb (Save_Scan_State, Restore_Scan_State):
Put these in logical order. Make sure we're not saving
and restoring bogus information in Token_Node.
* scans.ads: Fix incorrect comment.
* scn.ads: Minor comment improvements. Do not duplicate (wrong)
information from Scans.
* scng.adb: Set Token_Node to Empty initially, so we don't
accidentally refer to bogus information from previous tokens.
* scng.ads: Minor comment improvement (remove information
about one actual from comment on the formal).
* sem_aux.ads (Initialization_Suppressed):
Minor comment improvement.
* sem_ch6.adb: Remove usage of Debug_Flag_Underscore_XX.
This code is pretty well tested by now, and anyway, it's
only called from within pragmas Assert.
* sem_util.adb (Enter_Name): Minor cleanup.
* sprint.adb (Dump_Generated_Only): Fix incorrect comment.
* vast.adb: Misc cleanup. Enable assertion about
Errout.Compilation_Errors (should be False if back end
is enabled).
(Validate_Subprogram_Calls): Move here from frontend.adb.
Move call to it here from frontend.adb.
-- d_U Disable prepending messages with "error:".
-- d_V Enable VAST (verifications on the expanded tree)
-- d_W Enable VAST in verbose mode
- -- d_X Disable assertions to check matching of extra formals
+ -- d_X
-- d_Y
-- d_Z
-- d_W Same as d_V, but also prints lots of tracing/debugging output
-- as it walks the tree.
- -- d_X Disable assertions to check matching of extra formals; switch added
- -- temporarily to disable these checks until this work is complete if
- -- they cause unexpected assertion failures.
-
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
-- if the type would normally require initialization. Set by use of
-- pragma Suppress_Initialization and also for internal entities where
-- we know that no initialization is required. For example, enumeration
--- image table entities set it.
+-- image table entities set it. This is unrelated to pragma Import.
-- Suppress_Style_Checks
-- Defined in all entities. Suppresses any style checks specifically
else
pragma Assert
- (Extra_Formals_Match_OK
- (E => Subp,
- Ref_E => Ovr_Subp));
+ (Extra_Formals_Match_OK (E => Subp, Ref_E => Ovr_Subp));
end if;
end if;
-- access discriminants do not require secondary stack use. Note we must
-- always use the secondary stack for dispatching-on-result calls.
- function Check_BIP_Actuals
- (Subp_Call : Node_Id;
- Subp_Id : Entity_Id) return Boolean;
- -- Given a subprogram call to the given subprogram return True if the
- -- names of BIP extra actual and formal parameters match, and the number
- -- of actuals (including extra actuals) matches the number of formals.
-
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
return Unqual_BIP_Function_Call (Expr);
end Unqual_BIP_Iface_Function_Call;
- -------------------------------
- -- Validate_Subprogram_Calls --
- -------------------------------
-
- procedure Validate_Subprogram_Calls (N : Node_Id) is
-
- function Process_Node (Nod : Node_Id) return Traverse_Result;
- -- Function to traverse the subtree of N using Traverse_Proc.
-
- ------------------
- -- Process_Node --
- ------------------
-
- function Process_Node (Nod : Node_Id) return Traverse_Result is
- begin
- case Nkind (Nod) is
- when N_Entry_Call_Statement
- | N_Procedure_Call_Statement
- | N_Function_Call
- =>
- declare
- Call_Node : Node_Id renames Nod;
- Subp : constant Entity_Id := Get_Called_Entity (Nod);
-
- begin
- pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
-
- -- Build-in-place function calls return their result by
- -- reference.
-
- pragma Assert (not Is_Build_In_Place_Function (Subp)
- or else Returns_By_Ref (Subp));
- end;
-
- -- Skip generic bodies
-
- when N_Package_Body =>
- if Ekind (Unique_Defining_Entity (Nod)) = E_Generic_Package then
- return Skip;
- end if;
-
- when N_Subprogram_Body =>
- if Ekind (Unique_Defining_Entity (Nod)) in E_Generic_Function
- | E_Generic_Procedure
- then
- return Skip;
- end if;
-
- -- Nodes we want to ignore
-
- -- Skip calls placed in the full declaration of record types since
- -- the call will be performed by their Init Proc; for example,
- -- calls initializing default values of discriminants or calls
- -- providing the initial value of record type components. Other
- -- full type declarations are processed because they may have
- -- calls that must be checked. For example:
-
- -- type T is array (1 .. Some_Function_Call (...)) of Some_Type;
-
- -- ??? More work needed here to handle the following case:
-
- -- type Rec is record
- -- F : String (1 .. <some complicated expression>);
- -- end record;
-
- when N_Full_Type_Declaration =>
- if Is_Record_Type (Defining_Entity (Nod)) then
- return Skip;
- end if;
-
- -- Skip calls placed in unexpanded initialization expressions
-
- when N_Object_Declaration =>
- if No_Initialization (Nod) then
- return Skip;
- end if;
-
- -- Skip calls placed in subprogram specifications since function
- -- calls initializing default parameter values will be processed
- -- when the call to the subprogram is found (if the default actual
- -- parameter is required), and calls found in aspects will be
- -- processed when their corresponding pragma is found, or in the
- -- specific case of class-wide pre-/postconditions, when their
- -- helpers are found.
-
- when N_Procedure_Specification
- | N_Function_Specification
- =>
- return Skip;
-
- when N_Abstract_Subprogram_Declaration
- | N_Aspect_Specification
- | N_At_Clause
- | N_Call_Marker
- | N_Empty
- | N_Enumeration_Representation_Clause
- | N_Enumeration_Type_Definition
- | N_Function_Instantiation
- | N_Freeze_Generic_Entity
- | N_Generic_Function_Renaming_Declaration
- | N_Generic_Package_Renaming_Declaration
- | N_Generic_Procedure_Renaming_Declaration
- | N_Generic_Package_Declaration
- | N_Generic_Subprogram_Declaration
- | N_Itype_Reference
- | N_Number_Declaration
- | N_Package_Instantiation
- | N_Package_Renaming_Declaration
- | N_Pragma
- | N_Procedure_Instantiation
- | N_Protected_Type_Declaration
- | N_Record_Representation_Clause
- | N_Validate_Unchecked_Conversion
- | N_Variable_Reference_Marker
- | N_Use_Package_Clause
- | N_Use_Type_Clause
- | N_With_Clause
- =>
- return Skip;
-
- when others =>
- null;
- end case;
-
- return OK;
- end Process_Node;
-
- procedure Check_Calls is new Traverse_Proc (Process_Node);
-
- -- Start of processing for Validate_Subprogram_Calls
-
- begin
- -- No action if we are not generating code (including if we have
- -- errors).
-
- if Operating_Mode /= Generate_Code then
- return;
- end if;
-
- pragma Assert (Serious_Errors_Detected = 0);
-
- -- Do not attempt to verify the return type in CodePeer_Mode
- -- as CodePeer_Mode is missing some expansion code that
- -- results in trees that would be considered malformed for
- -- GCC but aren't for GNAT2SCIL.
-
- if not CodePeer_Mode then
- Check_Calls (N);
- end if;
- end Validate_Subprogram_Calls;
-
--------------
-- Warn_BIP --
--------------
-- to reference the secondary dispatch table of an interface; otherwise
-- return Empty.
- procedure Validate_Subprogram_Calls (N : Node_Id);
- -- Check that the number of actuals (including extra actuals) of calls in
- -- the subtree N match their corresponding formals; check also that the
- -- names of BIP extra actuals and formals match.
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean;
+ -- Given a subprogram call to the given subprogram return True if the
+ -- names of BIP extra actual and formal parameters match, and the number
+ -- of actuals (including extra actuals) matches the number of formals.
private
pragma Inline (Is_Build_In_Place_Return_Object);
then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref);
-
- -- The following is to prevent problems with UC see 1.156 RH ???
-
- Set_Assignment_OK (Ref);
end if;
-- If the underlying_type is a subtype, then we are dealing with the
with CStand;
with Debug; use Debug;
with Elists;
-with Exp_Ch6;
with Exp_Dbug;
with Exp_Unst;
with Fmap;
null;
end if;
- -- Validate all the subprogram calls; this work will be done by VAST; in
- -- the meantime it is done to check extra formals and it can be disabled
- -- using -gnatd_X (which also disables all the other assertions on extra
- -- formals). It is invoked using pragma Debug to avoid adding any cost
- -- when the compiler is built with assertions disabled.
-
- if not Debug_Flag_Underscore_XX then
- pragma Debug (Exp_Ch6.Validate_Subprogram_Calls (Cunit (Main_Unit)));
- end if;
-
-- Dump the source now. Note that we do this as soon as the analysis
-- of the tree is complete, because it is not just a dump in the case
-- of -gnatD, where it rewrites all source locations in the tree.
function Get_Aspect_Specifications (Semicolon : Boolean) return List_Id is
A_Id : Aspect_Id;
Aspect : Node_Id;
- Aspects : List_Id := Empty_List;
+ Aspects : constant List_Id := Empty_List;
OK : Boolean;
Opt : Boolean;
end if;
Scan; -- past WITH (or possible WHEN after error)
- Aspects := Empty_List;
-- Loop to scan aspects
end if;
end if;
- -- Note if inside Depends or Refined_Depends aspect
+ -- Set some aspect-dependent flags
- if A_Id = Aspect_Depends
- or else A_Id = Aspect_Refined_Depends
- then
- Inside_Depends := True;
- elsif A_Id = Aspect_Abstract_State then
- Inside_Abstract_State := True;
- end if;
+ case A_Id is
+ when Aspect_Depends | Aspect_Refined_Depends =>
+ Inside_Depends := True;
+ when Aspect_Abstract_State =>
+ Inside_Abstract_State := True;
+ when Aspect_Import =>
+ SIS_Aspect_Import_Seen := True;
+ -- This matters only while parsing a subprogram.
- -- Note that we have seen an Import aspect specification.
- -- This matters only while parsing a subprogram.
-
- if A_Id = Aspect_Import then
- SIS_Aspect_Import_Seen := True;
- -- Should do it only for subprograms
- end if;
+ when others => null;
+ end case;
-- Parse the aspect definition depending on the expected
-- argument kind.
if Token in Tok_Identifier | Tok_Operator_Symbol | Tok_Others then
Save_Scan_State (Scan_State_Id); -- at Id
- Ident_Node := Token_Node;
+
+ if Token = Tok_Others then
+ Ident_Node := Empty; -- used below only in case of syntax error
+ else
+ Ident_Node := Token_Node;
+ end if;
+
Scan; -- past Id
-- Deal with => (allow := as incorrect substitute)
Append (Def_Ids, P_Defining_Identifier (C_Comma_Colon));
end loop Ident_Loop;
- -- Fall through the loop on encountering a colon, or deciding
- -- that there is a missing colon.
+ -- We exited from the above loop upon encountering a colon or
+ -- deciding that there is a missing colon.
T_Colon;
---------------------
function Bad_Spelling_Of (T : Token_Type) return Boolean is
- Tname : constant String := Token_Type'Image (T);
- -- Characters of token name
- S : String (1 .. Tname'Last - 4);
- -- Characters of token name folded to lower case, omitting TOK_ at start
+ function Bad_Spelling_Helper return Boolean;
+ -- This does all the work, except setting of Token and Token_Node
- M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
- M2 : String (1 .. 44) := "illegal abbreviation of keyword ************";
- -- Buffers used to construct error message
+ function Bad_Spelling_Helper return Boolean is
+ Tname : constant String := Token_Type'Image (T);
+ -- Characters of token name
- P1 : constant := 30;
- P2 : constant := 32;
- -- Starting subscripts in M1, M2 for keyword name
+ S : String (1 .. Tname'Last - 4);
+ -- Characters of token name folded to lower case, omitting TOK_ at
+ -- start.
- SL : constant Natural := S'Length;
- -- Length of expected token name excluding TOK_ at start
+ M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
+ M2 : String (1 .. 44) :=
+ "illegal abbreviation of keyword ************";
+ -- Buffers used to construct error message
- begin
- if Token /= Tok_Identifier then
- return False;
- end if;
+ P1 : constant := 30;
+ P2 : constant := 32;
+ -- Starting subscripts in M1, M2 for keyword name
- for J in S'Range loop
- S (J) := Fold_Lower (Tname (J + 4));
- end loop;
+ SL : constant Natural := S'Length;
+ -- Length of expected token name excluding TOK_ at start
- Get_Name_String (Token_Name);
+ begin
+ if Token /= Tok_Identifier then
+ return False;
+ end if;
- -- A special check for case of PROGRAM used for PROCEDURE
+ for J in S'Range loop
+ S (J) := Fold_Lower (Tname (J + 4));
+ end loop;
- if T = Tok_Procedure
- and then Name_Len = 7
- and then Name_Buffer (1 .. 7) = "program"
- then
- Error_Msg_SC -- CODEFIX
- ("PROCEDURE expected");
- Token := T;
- return True;
+ Get_Name_String (Token_Name);
- -- A special check for an illegal abbreviation
+ -- A special check for case of PROGRAM used for PROCEDURE
- elsif Name_Len < S'Length
- and then Name_Len >= 4
- and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
- then
- for J in 1 .. S'Last loop
- M2 (P2 + J - 1) := Fold_Upper (S (J));
- end loop;
+ if T = Tok_Procedure
+ and then Name_Len = 7
+ and then Name_Buffer (1 .. 7) = "program"
+ then
+ Error_Msg_SC -- CODEFIX
+ ("PROCEDURE expected");
+ return True;
- Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
- Token := T;
- return True;
- end if;
+ -- A special check for an illegal abbreviation
- -- Now we go into the full circuit to check for a misspelling
+ elsif Name_Len < S'Length
+ and then Name_Len >= 4
+ and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
+ then
+ for J in 1 .. S'Last loop
+ M2 (P2 + J - 1) := Fold_Upper (S (J));
+ end loop;
- -- Never consider something a misspelling if either the actual or
- -- expected string is less than 3 characters (before this check we
- -- used to consider i to be a misspelled if in some cases).
+ Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
+ return True;
+ end if;
- if SL < 3 or else Name_Len < 3 then
- return False;
+ -- Now we go into the full circuit to check for a misspelling
- -- Special case: prefix matches, i.e. the leading characters of the
- -- token that we have exactly match the required keyword. If there
- -- are at least two characters left over, assume that we have a case
- -- of two keywords joined together which should not be joined.
+ -- Never consider something a misspelling if either the actual or
+ -- expected string is less than 3 characters (before this check we
+ -- used to consider i to be a misspelled if in some cases).
- elsif Name_Len > SL + 1
- and then S = Name_Buffer (1 .. SL)
- then
- Scan_Ptr := Token_Ptr + S'Length;
- Error_Msg_S ("|missing space");
- Token := T;
- return True;
- end if;
+ if SL < 3 or else Name_Len < 3 then
+ return False;
- if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
- for J in 1 .. S'Last loop
- M1 (P1 + J - 1) := Fold_Upper (S (J));
- end loop;
+ -- Special case: prefix matches, i.e. the leading characters of the
+ -- token that we have exactly match the required keyword. If there
+ -- are at least two characters left over, assume that we have a case
+ -- of two keywords joined together which should not be joined.
- Error_Msg_SC -- CODFIX
- (M1 (1 .. P1 - 1 + S'Last));
- Token := T;
- return True;
+ elsif Name_Len > SL + 1
+ and then S = Name_Buffer (1 .. SL)
+ then
+ Scan_Ptr := Token_Ptr + S'Length;
+ Error_Msg_S ("|missing space");
+ return True;
+ end if;
- else
- return False;
- end if;
+ if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+ for J in 1 .. S'Last loop
+ M1 (P1 + J - 1) := Fold_Upper (S (J));
+ end loop;
+
+ Error_Msg_SC -- CODFIX
+ (M1 (1 .. P1 - 1 + S'Last));
+ return True;
+
+ else
+ return False;
+ end if;
+ end Bad_Spelling_Helper;
+
+ begin
+ return Result : constant Boolean := Bad_Spelling_Helper do
+ if Result then
+ Token := T;
+ Token_Node := Empty;
+ end if;
+ end return;
end Bad_Spelling_Of;
----------------------
-- do not set SIS_Entry_Active, because the Import means there is no body.
-- Set False at the start of P_Subprogram, set True when an Import aspect
-- specification is seen, and used when P_Subprogram finds a subprogram
- -- declaration. This is necessary because the aspects are parsed before
+ -- declaration. This is necessary because the aspects are parsed before
-- we know we have a subprogram declaration.
SIS_Labl : Node_Id;
function Init_Expr_Opt (P : Boolean := False) return Node_Id;
-- If an initialization expression is present (:= expression), then
- -- it is scanned out and returned, otherwise Empty is returned if no
- -- initialization expression is present. This procedure also handles
- -- certain common error cases cleanly. The parameter P indicates if
- -- a right paren can follow the expression (default = no right paren
- -- allowed).
+ -- it is scanned out and returned; otherwise Empty is returned. This
+ -- procedure also handles certain common error cases. P=True indicates
+ -- that a right paren can follow the expression.
procedure Skip_Declaration (S : List_Id);
-- Used when scanning statements to skip past a misplaced declaration
package Util is
function Bad_Spelling_Of (T : Token_Type) return Boolean;
- -- This function is called in an error situation. It checks if the
- -- current token is an identifier whose name is a plausible bad
- -- spelling of the given keyword token, and if so, issues an error
- -- message, sets Token from T, and returns True. Otherwise Token is
- -- unchanged, and False is returned.
+ -- This function is called in an error situation. Returns True if the
+ -- current token is an identifier whose name is a plausible misspelling
+ -- of the given keyword token. In the True case, sets Token to T, and
+ -- Token_Node becomes invalid.
procedure Check_Bad_Layout;
-- Check for bad indentation in RM checking mode. Used for statements
return Name_Find (Name);
end Keyword_Name;
+ ---------------------
+ -- Save_Scan_State --
+ ---------------------
+
+ procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is
+ begin
+ Saved_State.Save_Scan_Ptr := Scan_Ptr;
+ Saved_State.Save_Token := Token;
+ Saved_State.Save_Token_Ptr := Token_Ptr;
+ Saved_State.Save_Current_Line_Start := Current_Line_Start;
+ Saved_State.Save_Start_Column := Start_Column;
+ Saved_State.Save_Checksum := Checksum;
+ Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location;
+
+ -- Check that we're not saving a bogus Token_Node
+
+ pragma Assert
+ ((Token_Node /= Empty) = (Token in Token_Class_Lit_Or_Name));
+ Saved_State.Save_Token_Node := Token_Node;
+
+ Saved_State.Save_Token_Name := Token_Name;
+ Saved_State.Save_Prev_Token := Prev_Token;
+ Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr;
+ end Save_Scan_State;
+
------------------------
-- Restore_Scan_State --
------------------------
+ -- use Output, VAST, Atree;
+
procedure Restore_Scan_State (Saved_State : Saved_Scan_State) is
begin
- Scan_Ptr := Saved_State.Save_Scan_Ptr;
- Token := Saved_State.Save_Token;
- Token_Ptr := Saved_State.Save_Token_Ptr;
- Current_Line_Start := Saved_State.Save_Current_Line_Start;
- Start_Column := Saved_State.Save_Start_Column;
- Checksum := Saved_State.Save_Checksum;
+ Scan_Ptr := Saved_State.Save_Scan_Ptr;
+ Token := Saved_State.Save_Token;
+ Token_Ptr := Saved_State.Save_Token_Ptr;
+ Current_Line_Start := Saved_State.Save_Current_Line_Start;
+ Start_Column := Saved_State.Save_Start_Column;
+ Checksum := Saved_State.Save_Checksum;
First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location;
- Token_Node := Saved_State.Save_Token_Node;
- Token_Name := Saved_State.Save_Token_Name;
- Prev_Token := Saved_State.Save_Prev_Token;
- Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr;
- end Restore_Scan_State;
- ---------------------
- -- Save_Scan_State --
- ---------------------
+ Token_Node := Saved_State.Save_Token_Node;
+ pragma Assert
+ ((Token_Node /= Empty) = (Token in Token_Class_Lit_Or_Name));
- procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is
- begin
- Saved_State.Save_Scan_Ptr := Scan_Ptr;
- Saved_State.Save_Token := Token;
- Saved_State.Save_Token_Ptr := Token_Ptr;
- Saved_State.Save_Current_Line_Start := Current_Line_Start;
- Saved_State.Save_Start_Column := Start_Column;
- Saved_State.Save_Checksum := Checksum;
- Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location;
- Saved_State.Save_Token_Node := Token_Node;
- Saved_State.Save_Token_Name := Token_Name;
- Saved_State.Save_Prev_Token := Prev_Token;
- Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr;
- end Save_Scan_State;
+ Token_Name := Saved_State.Save_Token_Name;
+ Prev_Token := Saved_State.Save_Prev_Token;
+ Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr;
+ end Restore_Scan_State;
end Scans;
-- is stored in Start_Column).
Token_Node : Node_Id := Empty;
- -- Node table Id for the current token. This is set only if the current
- -- token is one for which the scanner constructs a node (i.e. it is an
- -- identifier, operator symbol, or literal). For other token types,
+ -- Node_Id for the current token. This is set only if the current token is
+ -- one for which the scanner constructs a node (i.e. it is an identifier,
+ -- operator symbol, literal, or target name). For other token types,
-- Token_Node is undefined.
Token_Name : Name_Id := No_Name;
-- keyword or an identifier. See also package Casing.
procedure Post_Scan;
- -- Create nodes for tokens: Char_Literal, Identifier, Real_Literal,
- -- Integer_Literal, String_Literal and Operator_Symbol.
+ -- Sets Token_Node as specified in Scans.
+ -- Also checks for obsolescent features.
procedure Scan_Reserved_Identifier (Force_Msg : Boolean);
- -- This procedure is called to convert the current token, which the caller
- -- has checked is for a reserved word, to an equivalent identifier. This is
- -- of course only used in error situations where the parser can detect that
- -- a reserved word is being used as an identifier. An appropriate error
- -- message, pointing to the token, is also issued if either this is the
- -- first occurrence of misuse of this identifier, or if Force_Msg is True.
+ -- Converts the current token, which is a reserved word, to an equivalent
+ -- identifier. This is used only in error situations where the parser can
+ -- detect that a reserved word is being used as an identifier. An error
+ -- message pointing to the token is also issued if either this is the first
+ -- occurrence of misuse of this identifier, or if Force_Msg is True.
-------------
-- Scanner --
-- This is the procedure for scanning out numeric literals. On entry,
-- Scan_Ptr points to the digit that starts the numeric literal (the
-- checksum for this character has not been accumulated yet). On return
- -- Scan_Ptr points past the last character of the numeric literal, Token
- -- and Token_Node are set appropriately, and the checksum is updated.
+ -- Scan_Ptr points past the last character of the numeric literal, and
+ -- the checksum is updated.
procedure Slit;
-- This is the procedure for scanning out string literals. On entry,
-- Scan_Ptr points to the opening string quote (the checksum for this
-- character has not been accumulated yet). On return Scan_Ptr points
- -- past the closing quote of the string literal, Token and Token_Node
- -- are set appropriately, and the checksum is updated.
+ -- past the closing quote of the string literal, and the checksum is
+ -- updated.
procedure Skip_Other_Format_Characters;
-- Skips past any "other format" category characters at the current
-- Procedure used to distinguish between string and operator symbol.
-- On entry the string has been scanned out, and its characters start
-- at Token_Ptr and end one character before Scan_Ptr. On exit Token
- -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate,
- -- and Token_Node is appropriately initialized. In addition, in the
- -- operator symbol case, Token_Name is appropriately set, and the
- -- flags [Wide_]Wide_Character_Found are set appropriately.
+ -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate.
---------------------------
-- Error_Bad_String_Char --
begin
Prev_Token := Token;
Prev_Token_Ptr := Token_Ptr;
+ Token_Node := Empty;
Token_Name := Error_Name;
if Inside_Interpolated_String_Literal
with procedure Post_Scan;
-- Procedure called by Scan for the following tokens: Tok_Char_Literal,
-- Tok_Identifier, Tok_Real_Literal, Tok_Real_Literal, Tok_Integer_Literal,
- -- Tok_String_Literal, Tok_Operator_Symbol, and Tok_Vertical_Bar. Used to
- -- build Token_Node and also check for obsolescent features.
+ -- Tok_String_Literal, Tok_Operator_Symbol, and Tok_Vertical_Bar.
with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
-- Output a message at specified location
function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
pragma Inline (Initialization_Suppressed);
- -- Returns True if initialization should be suppressed for the given type
- -- or subtype. This is true if Suppress_Initialization is set either for
- -- the subtype itself, or for the corresponding base type.
+ -- True if Suppress_Initialization is set either for Typ or for its base
+ -- type. This is unrelated to pragma Import.
function Is_Body (N : Node_Id) return Boolean with Inline;
-- Determine whether an arbitrary node denotes a body
-- formals (see exp_ch9.Build_Wrapper_Specs) which will be
-- checked later.
- if Debug_Flag_Underscore_XX
- or else not Expander_Active
+ if not Expander_Active
or else
(Is_Predefined_Dispatching_Operation (E)
and then (not Has_Reliable_Extra_Formals (E)
Has_Extra_Formals : Boolean := False;
begin
- -- No check required if explicitly disabled
-
- if Debug_Flag_Underscore_XX then
- return True;
-
-- No check required if expansion is disabled because extra
-- formals are only generated when we are generating code.
-- See Create_Extra_Formals.
- elsif not Expander_Active then
+ if not Expander_Active then
return True;
end if;
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
end if;
- -- If entity is in standard, then we are in trouble, because it
- -- means that we have a library package with a duplicated name.
- -- That's hard to recover from, so abort.
+ -- Abort for duplicated root library unit, which is hard to
+ -- recover from.
if S = Standard_Standard then
raise Unrecoverable_Error;
-
- -- Otherwise we continue with the declaration. Having two
- -- identical declarations should not cause us too much trouble.
-
- else
- null;
end if;
end if;
end if;
-- Set True if the -gnatdo (dump original tree) flag is set
Dump_Generated_Only : Boolean;
- -- Set True if the -gnatdG (dump generated tree) debug flag is set
+ -- Set True if the -gnatdg (dump generated tree) debug flag is set
-- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
Dump_Freeze_Null : Boolean;
with Atree; use Atree;
with Debug;
with Einfo.Entities; use Einfo.Entities;
--- with Errout;
+with Einfo.Utils; use Einfo.Utils;
+with Errout;
+with Exp_Ch6;
with Exp_Tss;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Output;
+with Sem_Aux;
with Sem_Util;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinput;
Print_And_Continue); -- Print a message
pragma Warnings (Off, "Status*could be declared constant");
+ -- Status is variable so we can modify it in gdb, for example
Status : array (Check_Enum) of Check_Status :=
(Check_Other => Enabled,
Check_Sloc => Disabled,
Check : Check_Enum := Check_Other;
Detail : String := "");
-- Check that the Condition is True. Status determines action on failure.
+ -- Note: This procedure is used to detect errors in the tree, whereas
+ -- pragma Assert is used to detect errors in VAST itself.
function To_Mixed (A : String) return String;
-- Copied from System.Case_Util; old versions of that package do not have
procedure Check_Scope (N : Node_Id);
-- Check that the Scope of N makes sense
+ procedure Validate_Subprogram_Calls (N : Node_Id);
+ -- Check that the number of actuals (including extra actuals) of all calls
+ -- within N match their corresponding formals; check also that the names
+ -- of BIP extra actuals and formals match.
+
--------------
-- To_Mixed --
--------------
procedure Do_Node_Pass_2 (N : Node_Id) is
begin
- -- Check Sloc:
+ -- Check Sloc
case Nkind (N) is
-- ???Some nodes, including exception handlers, have no Sloc;
end case;
-- All reachable nodes should have been analyzed by the time we get
- -- here:
+ -- here.
Assert (Analyzed (N), Check_Analyzed);
- -- Misc checks based on node/entity kind:
+ -- Misc checks based on node/entity kind
case Nkind (N) is
when N_Unused_At_Start | N_Unused_At_End =>
null; -- more to be done here
end case;
- -- Check that N has a Parent, except in certain cases:
+ -- Check that N has a Parent, except in certain cases
case Nkind (N) is
when N_Empty =>
Msg : constant String :=
"VAST for unit" & U'Img & " " & U_Name_S & Predef & Is_Main;
- Is_Preprocessing_Dependency : constant Boolean :=
- U_Name = No_Unit_Name;
+ Is_Preprocessing_Dependency : constant Boolean := U_Name = No_Unit_Name;
-- True if this is a bogus unit added by Add_Preprocessing_Dependency.
- -- ???Not sure what that's about, but these units have no name and
- -- no associated tree, so we had better not try to walk those trees.
+ -- These units have no name and no associated tree; we had better not
+ -- try to walk nonexistent trees.
Root : constant Node_Id := Cunit (U);
begin
begin
Put_Line ("VAST");
- -- Operating_Mode = Generate_Code implies there are no legality errors:
+ -- Operating_Mode = Generate_Code implies there are no legality errors
pragma Assert (Serious_Errors_Detected = 0);
- -- ????pragma Assert (not Errout.Compilation_Errors);
+ pragma Assert (not Errout.Compilation_Errors);
Put_Line ("VAST checking" & Last_Unit'Img & " units");
end loop;
end loop;
- -- We shouldn't have allocated any new nodes during VAST:
+ -- Validate subprogram calls; check "extra formals". This works only
+ -- for the main unit.
+
+ Validate_Subprogram_Calls (Cunit (Main_Unit));
+
+ -- We shouldn't have allocated any new nodes during VAST
pragma Assert (Node_Offsets.Last = Last_Node);
Free (Nodes_Info);
VAST;
end VAST_If_Enabled;
+ -------------------------------
+ -- Validate_Subprogram_Calls --
+ -------------------------------
+
+ procedure Validate_Subprogram_Calls (N : Node_Id) is
+ use Sem_Aux, Sem_Util;
+
+ function Process_Node (Nod : Node_Id) return Traverse_Result;
+ -- Function to traverse the subtree of N using Traverse_Proc.
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ function Process_Node (Nod : Node_Id) return Traverse_Result is
+ begin
+ case Nkind (Nod) is
+ when N_Entry_Call_Statement
+ | N_Procedure_Call_Statement
+ | N_Function_Call
+ =>
+ declare
+ Call_Node : Node_Id renames Nod;
+ Subp : constant Entity_Id := Get_Called_Entity (Nod);
+
+ begin
+ pragma Assert (Exp_Ch6.Check_BIP_Actuals (Call_Node, Subp));
+
+ -- Build-in-place function calls return their result by
+ -- reference.
+
+ pragma Assert (not Exp_Ch6.Is_Build_In_Place_Function (Subp)
+ or else Returns_By_Ref (Subp));
+ end;
+
+ -- Skip generic bodies
+
+ when N_Package_Body =>
+ if Ekind (Unique_Defining_Entity (Nod)) = E_Generic_Package then
+ return Skip;
+ end if;
+
+ when N_Subprogram_Body =>
+ if Ekind (Unique_Defining_Entity (Nod)) in E_Generic_Function
+ | E_Generic_Procedure
+ then
+ return Skip;
+ end if;
+
+ -- Nodes we want to ignore
+
+ -- Skip calls placed in the full declaration of record types since
+ -- the call will be performed by their Init Proc; for example,
+ -- calls initializing default values of discriminants or calls
+ -- providing the initial value of record type components. Other
+ -- full type declarations are processed because they may have
+ -- calls that must be checked. For example:
+
+ -- type T is array (1 .. Some_Function_Call (...)) of Some_Type;
+
+ -- ??? More work needed here to handle the following case:
+
+ -- type Rec is record
+ -- F : String (1 .. <some complicated expression>);
+ -- end record;
+
+ when N_Full_Type_Declaration =>
+ if Is_Record_Type (Defining_Entity (Nod)) then
+ return Skip;
+ end if;
+
+ -- Skip calls placed in unexpanded initialization expressions
+
+ when N_Object_Declaration =>
+ if No_Initialization (Nod) then
+ return Skip;
+ end if;
+
+ -- Skip calls placed in subprogram specifications since function
+ -- calls initializing default parameter values will be processed
+ -- when the call to the subprogram is found (if the default actual
+ -- parameter is required), and calls found in aspects will be
+ -- processed when their corresponding pragma is found, or in the
+ -- specific case of class-wide pre-/postconditions, when their
+ -- helpers are found.
+
+ when N_Procedure_Specification
+ | N_Function_Specification
+ =>
+ return Skip;
+
+ when N_Abstract_Subprogram_Declaration
+ | N_Aspect_Specification
+ | N_At_Clause
+ | N_Call_Marker
+ | N_Empty
+ | N_Enumeration_Representation_Clause
+ | N_Enumeration_Type_Definition
+ | N_Function_Instantiation
+ | N_Freeze_Generic_Entity
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Itype_Reference
+ | N_Number_Declaration
+ | N_Package_Instantiation
+ | N_Package_Renaming_Declaration
+ | N_Pragma
+ | N_Procedure_Instantiation
+ | N_Protected_Type_Declaration
+ | N_Record_Representation_Clause
+ | N_Validate_Unchecked_Conversion
+ | N_Variable_Reference_Marker
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
+ | N_With_Clause
+ =>
+ return Skip;
+
+ when others =>
+ null;
+ end case;
+
+ return OK;
+ end Process_Node;
+
+ procedure Check_Calls is new Traverse_Proc (Process_Node);
+
+ -- Start of processing for Validate_Subprogram_Calls
+
+ begin
+ -- No action if we are not generating code (including if we have
+ -- errors).
+
+ if Operating_Mode /= Generate_Code then
+ return;
+ end if;
+
+ pragma Assert (Serious_Errors_Detected = 0);
+
+ -- Do not attempt to verify the return type in CodePeer_Mode
+ -- as CodePeer_Mode is missing some expansion code that
+ -- results in trees that would be considered malformed for
+ -- GCC but aren't for GNAT2SCIL.
+
+ if not CodePeer_Mode then
+ Check_Calls (N);
+ end if;
+ end Validate_Subprogram_Calls;
+
----------------
-- Is_FE_Only --
----------------
projects / thirdparty / gcc.git / commitdiff
