From: Bob Duff <[email protected]>
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.
Tested on x86_64-pc-linux-gnu (before the recent bootstrap breakage), committed
on master.
---
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 | 180 +++++++++++++++++++++-------------------
gcc/ada/par.adb | 19 ++---
gcc/ada/scans.adb | 70 +++++++++-------
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, 378 insertions(+), 384 deletions(-)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 7b36426ed3e..4c0435e0bd5 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 43b0e8cb89a..357634a7ed5 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 78e4f44c191..54352127cfe 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 e4c110b44c9..9501150652a 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 15804eaf0ac..2878a90edf4 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 3ee397a6df4..650b4ae9f57 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 f9292d808b4..3441cf5c0c8 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 00b780bb0df..8d806958bac 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 979fef06adc..dc6beee1073 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 5097dbb4aa5..06d83b30455 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 6a6afd0ebb2..9c0cef09c30 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
+
+ P1 : constant := 30;
+ P2 : constant := 32;
+ -- Starting subscripts in M1, M2 for keyword name
+
+ SL : constant Natural := S'Length;
+ -- Length of expected token name excluding TOK_ at start
+
+ begin
+ if Token /= Tok_Identifier then
+ return False;
+ end if;
+
+ for J in S'Range loop
+ S (J) := Fold_Lower (Tname (J + 4));
+ end loop;
+
+ Get_Name_String (Token_Name);
+
+ -- A special check for case of PROGRAM used for PROCEDURE
+
+ 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;
+
+ -- A special check for an illegal abbreviation
+
+ 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;
+
+ Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
+ return True;
+ end if;
+
+ -- Now we go into the full circuit to check for a misspelling
+
+ -- 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).
+
+ if SL < 3 or else Name_Len < 3 then
+ return False;
+
+ -- 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.
+
+ 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;
+
+ 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
- if Token /= Tok_Identifier then
- return False;
- end if;
-
- for J in S'Range loop
- S (J) := Fold_Lower (Tname (J + 4));
- end loop;
-
- Get_Name_String (Token_Name);
-
- -- A special check for case of PROGRAM used for PROCEDURE
-
- 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;
-
- -- A special check for an illegal abbreviation
-
- 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;
-
- Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
- Token := T;
- return True;
- end if;
-
- -- Now we go into the full circuit to check for a misspelling
-
- -- 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).
-
- if SL < 3 or else Name_Len < 3 then
- return False;
-
- -- 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.
-
- 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 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));
- Token := T;
- return True;
-
- else
- return False;
- end if;
+ 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 6fc4bed530b..13f5349c808 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 d1f3321aaa9..aaeee7b716a 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;
- ------------------------
- -- Restore_Scan_State --
- ------------------------
-
- 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;
- 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 --
---------------------
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_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;
+
+ -- 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;
+ First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location;
+
+ Token_Node := Saved_State.Save_Token_Node;
+ pragma Assert
+ ((Token_Node /= Empty) = (Token in Token_Class_Lit_Or_Name));
+
+ 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 c91bc0952ca..af94e03772c 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 213e08e65e5..6f4fb68e5be 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 a4304f8e7b2..a68e724d4ba 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 65acf381fa2..cbbc9fb4b61 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 1a298a9a33f..bca90ca9fbc 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 33f5e1c67ac..154aa96dde4 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 42ab46dd32a..ade2227ff00 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 8c49864b87a..ee9013e38ad 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 429eeaf8c29..004ad79dd2b 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 --
----------------
--
2.51.0
