https://gcc.gnu.org/g:90f219e4de740428b8189e627b50b5012d9c5314
commit r16-6619-g90f219e4de740428b8189e627b50b5012d9c5314 Author: Bob Duff <[email protected]> Date: Thu Dec 11 14:22:50 2025 -0500 ada: Tech debt: clean up miscellaneous VAST issues 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. Diff: --- gcc/ada/debug.adb | 6 +- gcc/ada/einfo.ads | 2 +- gcc/ada/exp_ch3.adb | 4 +- gcc/ada/exp_ch6.adb | 158 ------------------------------------------ gcc/ada/exp_ch6.ads | 10 +-- gcc/ada/exp_ch7.adb | 4 -- gcc/ada/frontend.adb | 11 --- gcc/ada/par-ch13.adb | 29 ++++---- gcc/ada/par-ch4.adb | 8 ++- gcc/ada/par-ch6.adb | 4 +- gcc/ada/par-util.adb | 152 +++++++++++++++++++++------------------- gcc/ada/par.adb | 19 +++-- gcc/ada/scans.adb | 68 ++++++++++-------- gcc/ada/scans.ads | 6 +- gcc/ada/scn.ads | 15 ++-- gcc/ada/scng.adb | 14 ++-- gcc/ada/scng.ads | 3 +- gcc/ada/sem_aux.ads | 5 +- gcc/ada/sem_ch6.adb | 10 +-- gcc/ada/sem_util.adb | 11 +-- gcc/ada/sprint.adb | 2 +- gcc/ada/vast.adb | 191 +++++++++++++++++++++++++++++++++++++++++++++++---- 22 files changed, 363 insertions(+), 369 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 7b36426ed3e9..4c0435e0bd52 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -188,7 +188,7 @@ package body Debug is -- 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 @@ -1075,10 +1075,6 @@ package body Debug is -- 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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 43b0e8cb89a8..357634a7ed51 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4694,7 +4694,7 @@ package Einfo is -- 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 diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 78e4f44c1919..54352127cfec 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6397,9 +6397,7 @@ package body Exp_Ch3 is 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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index e4c110b44c91..9501150652a7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -202,13 +202,6 @@ package body Exp_Ch6 is -- 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; @@ -10523,157 +10516,6 @@ package body Exp_Ch6 is 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 -- -------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 15804eaf0acc..2878a90edf41 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -316,10 +316,12 @@ package Exp_Ch6 is -- 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); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 3ee397a6df44..650b4ae9f572 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -8476,10 +8476,6 @@ package body Exp_Ch7 is 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 diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index f9292d808b4f..3441cf5c0c8d 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -30,7 +30,6 @@ with Checks; with CStand; with Debug; use Debug; with Elists; -with Exp_Ch6; with Exp_Dbug; with Exp_Unst; with Fmap; @@ -517,16 +516,6 @@ begin 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. diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 00b780bb0df3..8d806958bacf 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -197,7 +197,7 @@ package body Ch13 is 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; @@ -215,7 +215,6 @@ package body Ch13 is end if; Scan; -- past WITH (or possible WHEN after error) - Aspects := Empty_List; -- Loop to scan aspects @@ -497,23 +496,19 @@ package body Ch13 is 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. diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 979fef06adc1..dc6beee10738 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1168,7 +1168,13 @@ package body Ch4 is 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) diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 5097dbb4aa5d..06d83b304556 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1514,8 +1514,8 @@ package body Ch6 is 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; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 6a6afd0ebb2d..9c0cef09c304 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -55,96 +55,108 @@ package body Util is --------------------- 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; ---------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 6fc4bed530be..13f5349c8080 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -177,7 +177,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- 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; @@ -794,11 +794,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is 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 @@ -1317,11 +1315,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is 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 diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb index d1f3321aaa92..aaeee7b716a8 100644 --- a/gcc/ada/scans.adb +++ b/gcc/ada/scans.adb @@ -163,42 +163,54 @@ package body Scans is 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; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index c91bc0952ca2..af94e03772cc 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -411,9 +411,9 @@ package Scans is -- 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; diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads index 213e08e65e5e..6f4fb68e5be0 100644 --- a/gcc/ada/scn.ads +++ b/gcc/ada/scn.ads @@ -48,16 +48,15 @@ package Scn is -- 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 -- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index a4304f8e7b29..a68e724d4baf 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -295,15 +295,15 @@ package body Scng is -- 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 @@ -825,10 +825,7 @@ package body Scng is -- 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 -- @@ -1297,6 +1294,7 @@ package body Scng is begin Prev_Token := Token; Prev_Token_Ptr := Token_Ptr; + Token_Node := Empty; Token_Name := Error_Name; if Inside_Interpolated_String_Literal diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index 65acf381fa23..cbbc9fb4b613 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -35,8 +35,7 @@ generic 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 diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 1a298a9a33fb..bca90ca9fbc7 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -271,9 +271,8 @@ package Sem_Aux is 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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 33f5e1c67ac8..154aa96dde43 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9804,8 +9804,7 @@ package body Sem_Ch6 is -- 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) @@ -9889,16 +9888,11 @@ package body Sem_Ch6 is 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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 42ab46dd32a2..ade2227ff007 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8320,18 +8320,11 @@ package body Sem_Util is 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; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 8c49864b87af..ee9013e38ade 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -73,7 +73,7 @@ package body Sprint is -- 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; diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index 429eeaf8c294..004ad79dd2bc 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -36,13 +36,16 @@ with System.Case_Util; 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; @@ -81,6 +84,7 @@ package body VAST is 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, @@ -138,6 +142,8 @@ package body VAST is 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 @@ -245,6 +251,11 @@ package body VAST is 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 -- -------------- @@ -521,7 +532,7 @@ package body VAST is 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; @@ -535,11 +546,11 @@ package body VAST is 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 => @@ -563,7 +574,7 @@ package body VAST is 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 => @@ -768,11 +779,10 @@ package body VAST is 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 @@ -801,10 +811,10 @@ package body VAST is 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"); @@ -835,7 +845,12 @@ package body VAST is 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); @@ -880,6 +895,158 @@ package body VAST is 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 -- ----------------
