From ef2c20e73c8989e83863bdb05af0bf629faf5ff2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 5 Feb 2015 12:22:39 +0100 Subject: [PATCH] 015-02-05 Robert Dewar * sem_ch13.adb (Add_Invariants): Don't assume invariant is standard Boolean. * sem_prag.adb (Analyze_Pragma, case Check): Don't assume condition is standard Boolean, it can be non-standard derived Boolean. 2015-02-05 Robert Dewar * checks.adb (Enable_Range_Check): Disconnect attempted optimization for the case of range check for subscript of unconstrained array. 2015-02-05 Robert Dewar * par-ch13.adb (With_Present): New function (Aspect_Specifications_Present): Handle WHEN in place of WITH (Get_Aspect_Specifications): Comment update. * par.adb: Comment updates. 2015-02-05 Robert Dewar * errout.adb (Handle_Serious_Error): New setting of Fatal_Error. * frontend.adb (Frontend): New setting of Fatal_Error. * lib-load.adb (Create_Dummy_Package_Unit): New setting of Fatal_Error. (Load_Main_Source): New setting of Fatal_Error (Load_Unit): New setting of Fatal_Error. * lib-writ.adb (Add_Preprocessing_Dependency): New setting of Fatal_Error. (Ensure_System_Dependency): New setting of Fatal_Error. * lib.adb (Fatal_Error): New setting of Fatal_Error (Set_Fatal_Error): New setting of Fatal_Error. * lib.ads: New definition of Fatal_Error and associated routines. * par-ch10.adb (P_Compilation_Unit): New setting of Fatal_Error. * par-load.adb (Load): New setting of Fatal_Error. * rtsfind.adb (Load_RTU): New setting of Fatal_Error. * sem_ch10.adb (Analyze_Compilation_Unit): New setting of Fatal_Error. (Optional_Subunit): New setting of Fatal_Error. (Analyze_Proper_Body): New setting of Fatal_Error. (Load_Needed_Body): New setting of Fatal_Error. 2015-02-05 Ed Schonberg * sem_res.adb (Resolve_Call): If the function being called has out parameters do not check for language version if the function comes from a predefined unit, as those are always compiled in Ada 2012 mode. 2015-02-05 Ed Schonberg * sem_ch3.adb (Process_Full_View): Verify that the full view of a type extension must carry an explicit limited keyword if the partial view does (RM 7.3 (10.1)). From-SVN: r220446 --- gcc/ada/ChangeLog | 57 ++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/checks.adb | 12 ++++++---- gcc/ada/errout.adb | 17 ++++++++++--- gcc/ada/frontend.adb | 6 ++--- gcc/ada/lib-load.adb | 26 +++++++++++++------- gcc/ada/lib-writ.adb | 4 ++-- gcc/ada/lib.adb | 8 +++---- gcc/ada/lib.ads | 55 +++++++++++++++++++++++++++--------------- gcc/ada/par-ch10.adb | 8 +++---- gcc/ada/par-ch13.adb | 52 ++++++++++++++++++++++++++++++++++++---- gcc/ada/par-load.adb | 4 ++-- gcc/ada/par.adb | 25 +++++++++++-------- gcc/ada/rtsfind.adb | 6 ++--- gcc/ada/sem_ch10.adb | 15 +++++++----- gcc/ada/sem_ch13.adb | 2 +- gcc/ada/sem_ch3.adb | 22 +++++++++++++---- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 5 +++- 18 files changed, 245 insertions(+), 81 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index acadafe214c..bd6f02ad88d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,60 @@ +2015-02-05 Robert Dewar + + * sem_ch13.adb (Add_Invariants): Don't assume invariant is + standard Boolean. + * sem_prag.adb (Analyze_Pragma, case Check): Don't assume + condition is standard Boolean, it can be non-standard derived + Boolean. + +2015-02-05 Robert Dewar + + * checks.adb (Enable_Range_Check): Disconnect attempted + optimization for the case of range check for subscript of + unconstrained array. + +2015-02-05 Robert Dewar + + * par-ch13.adb (With_Present): New function + (Aspect_Specifications_Present): Handle WHEN in place of WITH + (Get_Aspect_Specifications): Comment update. + * par.adb: Comment updates. + +2015-02-05 Robert Dewar + + * errout.adb (Handle_Serious_Error): New setting of Fatal_Error. + * frontend.adb (Frontend): New setting of Fatal_Error. + * lib-load.adb (Create_Dummy_Package_Unit): New setting of + Fatal_Error. + (Load_Main_Source): New setting of Fatal_Error + (Load_Unit): New setting of Fatal_Error. + * lib-writ.adb (Add_Preprocessing_Dependency): New setting of + Fatal_Error. + (Ensure_System_Dependency): New setting of Fatal_Error. + * lib.adb (Fatal_Error): New setting of Fatal_Error + (Set_Fatal_Error): New setting of Fatal_Error. + * lib.ads: New definition of Fatal_Error and associated routines. + * par-ch10.adb (P_Compilation_Unit): New setting of Fatal_Error. + * par-load.adb (Load): New setting of Fatal_Error. + * rtsfind.adb (Load_RTU): New setting of Fatal_Error. + * sem_ch10.adb (Analyze_Compilation_Unit): New setting of + Fatal_Error. + (Optional_Subunit): New setting of Fatal_Error. + (Analyze_Proper_Body): New setting of Fatal_Error. + (Load_Needed_Body): New setting of Fatal_Error. + +2015-02-05 Ed Schonberg + + * sem_res.adb (Resolve_Call): If the function being called has + out parameters do not check for language version if the function + comes from a predefined unit, as those are always compiled in + Ada 2012 mode. + +2015-02-05 Ed Schonberg + + * sem_ch3.adb (Process_Full_View): Verify that the full view + of a type extension must carry an explicit limited keyword if + the partial view does (RM 7.3 (10.1)). + 2015-02-05 Robert Dewar * g-rannum.adb, g-rannum.ads, s-rannum.adb, s-rannum.ads, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index e822db30b3e..87c39956ed0 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -5521,10 +5521,14 @@ package body Checks is return; end if; - -- Ditto if the prefix is an explicit dereference whose designated - -- type is unconstrained. + -- Ditto if prefix is simply an unconstrained array. We used + -- to think this case was OK, if the prefix was not an explicit + -- dereference, but we have now seen a case where this is not + -- true, so it is safer to just suppress the optimization in this + -- case. The back end is getting better at eliminating redundant + -- checks in any case, so the loss won't be important. - elsif Nkind (Prefix (P)) = N_Explicit_Dereference + elsif Is_Array_Type (Atyp) and then not Is_Constrained (Atyp) then Activate_Range_Check (N); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index e48956b4218..df0fa96387d 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -753,12 +753,23 @@ package body Errout is end if; -- Set the fatal error flag in the unit table unless we are in - -- Try_Semantics mode. This stops the semantics from being performed + -- Try_Semantics mode (in which case we set ignored mode if not + -- currently set. This stops the semantics from being performed -- if we find a serious error. This is skipped if we are currently -- dealing with the configuration pragma file. - if not Try_Semantics and then Current_Source_Unit /= No_Unit then - Set_Fatal_Error (Get_Source_Unit (Sptr)); + if Current_Source_Unit /= No_Unit then + declare + U : constant Unit_Number_Type := Get_Source_Unit (Sptr); + begin + if Try_Semantics then + if Fatal_Error (U) = None then + Set_Fatal_Error (U, Error_Ignored); + end if; + else + Set_Fatal_Error (U, Error_Detected); + end if; + end; end if; end Handle_Serious_Error; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 51ea9e89a18..adee97df2fe 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -338,7 +338,7 @@ begin -- unit failed to load, to avoid cascaded inconsistencies that can lead -- to a compiler crash. - and then not Fatal_Error (Main_Unit) + and then Fatal_Error (Main_Unit) /= Error_Detected then -- Pragmas that require some semantic activity, such as Interrupt_State, -- cannot be processed until the main unit is installed, because they @@ -388,7 +388,7 @@ begin -- Following steps are skipped if we had a fatal error during parsing - if not Fatal_Error (Main_Unit) then + if Fatal_Error (Main_Unit) /= Error_Detected then -- Reset Operating_Mode to Check_Semantics for subunits. We cannot -- actually generate code for subunits, so we suppress expansion. diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 34b20cc780b..fc52f84f4ef 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -212,7 +212,7 @@ package body Lib.Load is Dynamic_Elab => False, Error_Location => Sloc (With_Node), Expected_Unit => Spec_Name, - Fatal_Error => True, + Fatal_Error => Error_Detected, Generate_Code => False, Has_RACW => False, Filler => False, @@ -319,7 +319,7 @@ package body Lib.Load is Dynamic_Elab => False, Error_Location => No_Location, Expected_Unit => No_Unit_Name, - Fatal_Error => False, + Fatal_Error => None, Generate_Code => False, Has_RACW => False, Filler => False, @@ -683,7 +683,7 @@ package body Lib.Load is Dynamic_Elab => False, Error_Location => Sloc (Error_Node), Expected_Unit => Uname_Actual, - Fatal_Error => False, + Fatal_Error => None, Generate_Code => False, Has_RACW => False, Filler => False, @@ -742,10 +742,20 @@ package body Lib.Load is -- If loaded unit had a fatal error, then caller inherits it - if Units.Table (Unum).Fatal_Error - and then Present (Error_Node) - then - Units.Table (Calling_Unit).Fatal_Error := True; + if Present (Error_Node) then + case Units.Table (Unum).Fatal_Error is + when None => + null; + + when Error_Detected => + Units.Table (Calling_Unit).Fatal_Error := Error_Detected; + + when Error_Ignored => + if Units.Table (Calling_Unit).Fatal_Error = None then + Units.Table (Calling_Unit).Fatal_Error := + Error_Ignored; + end if; + end case; end if; -- Remove load stack entry and return the entry in the file table diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index b4667342753..5a3dcc4d155 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -81,7 +81,7 @@ package body Lib.Writ is Cunit_Entity => Empty, Dependency_Num => 0, Dynamic_Elab => False, - Fatal_Error => False, + Fatal_Error => None, Generate_Code => False, Has_RACW => False, Filler => False, @@ -139,7 +139,7 @@ package body Lib.Writ is Cunit_Entity => Empty, Dependency_Num => 0, Dynamic_Elab => False, - Fatal_Error => False, + Fatal_Error => None, Generate_Code => False, Has_RACW => False, Filler => False, diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 609a03c5592..08866b2fb55 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -106,7 +106,7 @@ package body Lib is return Units.Table (U).Expected_Unit; end Expected_Unit; - function Fatal_Error (U : Unit_Number_Type) return Boolean is + function Fatal_Error (U : Unit_Number_Type) return Fatal_Type is begin return Units.Table (U).Fatal_Error; end Fatal_Error; @@ -196,9 +196,9 @@ package body Lib is Units.Table (U).Error_Location := W; end Set_Error_Location; - procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is + procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type) is begin - Units.Table (U).Fatal_Error := B; + Units.Table (U).Fatal_Error := V; end Set_Fatal_Error; procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 8cac209ffd2..4e9471c43fd 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -302,7 +302,7 @@ package Lib is -- No_Name for the main unit. -- Fatal_Error - -- A flag that is initialized to False, and gets set to True if a fatal + -- A flag that is initialized to None and gets set to Errorif a fatal -- error occurs during the processing of a unit. A fatal error is one -- defined as serious enough to stop the next phase of the compiler -- from running (i.e. fatal error during parsing stops semantics, @@ -310,6 +310,7 @@ package Lib is -- currently, errors of any kind cause Fatal_Error to be set, but -- eventually perhaps only errors labeled as fatal errors should be -- this severe if we decide to try Sem on sources with minor errors. + -- There are three settings (see declaration of Fatal_Type). -- Generate_Code -- This flag is set True for all units in the current file for which @@ -401,13 +402,29 @@ package Lib is Default_Main_CPU : constant Int := -1; -- Value used in Main_CPU field to indicate default main affinity + -- The following defines settings for the Fatal_Error field + + type Fatal_Type is ( + None, + -- No error detected for this unit + + Error_Detected, + -- Fatal error detected that prevents moving to the next phase. For + -- example, a fatal error during parsing inhibits semantic analysis. + + Error_Ignored); + -- A fatal error was detected, but we are in Try_Semantics mode (as set + -- by -gnatq or -gnatQ). This does not stop the compiler from proceding, + -- but tools can use this status (e.g. ASIS looking at the generated + -- tree) to know that a fatal error was detected. + function Cunit (U : Unit_Number_Type) return Node_Id; function Cunit_Entity (U : Unit_Number_Type) return Entity_Id; function Dependency_Num (U : Unit_Number_Type) return Nat; function Dynamic_Elab (U : Unit_Number_Type) return Boolean; function Error_Location (U : Unit_Number_Type) return Source_Ptr; function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type; - function Fatal_Error (U : Unit_Number_Type) return Boolean; + function Fatal_Error (U : Unit_Number_Type) return Fatal_Type; function Generate_Code (U : Unit_Number_Type) return Boolean; function Ident_String (U : Unit_Number_Type) return Node_Id; function Has_RACW (U : Unit_Number_Type) return Boolean; @@ -422,20 +439,20 @@ package Lib is function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; -- Get value of named field from given units table entry - procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id); - procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id); - procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr); - procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); - procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Main_CPU (U : Unit_Number_Type; P : Int); - procedure Set_No_Elab_Code_All (U : Unit_Number_Type; B : Boolean := True); - procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); - procedure Set_OA_Setting (U : Unit_Number_Type; C : Character); - procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id); + procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id); + procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr); + procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type); + procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); + procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Main_CPU (U : Unit_Number_Type; P : Int); + procedure Set_No_Elab_Code_All (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character); + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); -- Set value of named field for given units table entry. Note that we -- do not have an entry for each possible field, since some of the fields -- can only be set by specialized interfaces (defined below). @@ -606,7 +623,7 @@ package Lib is function Is_Loaded (Uname : Unit_Name_Type) return Boolean; -- Determines if unit with given name is already loaded, i.e. there is -- already an entry in the file table with this unit name for which the - -- corresponding file was found and parsed. Note that the Fatal_Error flag + -- corresponding file was found and parsed. Note that the Fatal_Error value -- of this entry must be checked before proceeding with further processing. function Last_Unit return Unit_Number_Type; @@ -767,7 +784,7 @@ private Serial_Number : Nat; Version : Word; Error_Location : Source_Ptr; - Fatal_Error : Boolean; + Fatal_Error : Fatal_Type; Generate_Code : Boolean; Has_RACW : Boolean; Dynamic_Elab : Boolean; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 2cb424102a7..551173066a0 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -596,7 +596,7 @@ package body Ch10 is else Cunit_Error_Flag := True; - Set_Fatal_Error (Current_Source_Unit); + Set_Fatal_Error (Current_Source_Unit, Error_Detected); end if; -- Clear away any missing semicolon indication, we are done with that @@ -726,7 +726,7 @@ package body Ch10 is -- cascaded messages in some situations. else - if not Fatal_Error (Current_Source_Unit) then + if Fatal_Error (Current_Source_Unit) /= Error_Detected then if Token in Token_Class_Cunit then Error_Msg_SC ("end of file expected, " & @@ -758,7 +758,7 @@ package body Ch10 is -- An error resync is a serious bomb, so indicate result unit no good when Error_Resync => - Set_Fatal_Error (Current_Source_Unit); + Set_Fatal_Error (Current_Source_Unit, Error_Detected); return Error; end P_Compilation_Unit; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 5d4f7d2e03c..fc8874bfd58 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,6 +48,10 @@ package body Ch13 is function Possible_Misspelled_Aspect return Boolean; -- Returns True, if Token_Name is a misspelling of some aspect name + function With_Present return Boolean; + -- Returns True if WITH is present, indicating presence of aspect + -- specifications. Also allows incorrect use of WHEN in place of WITH. + -------------------------------- -- Possible_Misspelled_Aspect -- -------------------------------- @@ -63,6 +67,43 @@ package body Ch13 is return False; end Possible_Misspelled_Aspect; + ------------------ + -- With_Present -- + ------------------ + + function With_Present return Boolean is + begin + if Token = Tok_With then + return True; + + -- Check for WHEN used in place of WITH + + elsif Token = Tok_When then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past WHEN + + if Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + Error_Msg_SC ("WHEN should be WITH"); + Restore_Scan_State (Scan_State); + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end; + + else + return False; + end if; + end With_Present; + -- Start of processing for Aspect_Specifications_Present begin @@ -79,14 +120,15 @@ package body Ch13 is -- be too expensive. Instead we pick up the aspect specifications later -- as a bogus declaration, and diagnose the semicolon at that point. - if Token /= Tok_With then + if not With_Present then return False; end if; - -- Have a WITH, see if it looks like an aspect specification + -- Have a WITH or some token that we accept as a legitimate bad attempt + -- at writing WITH. See if it looks like an aspect specification Save_Scan_State (Scan_State); - Scan; -- past WITH + Scan; -- past WITH (or WHEN or other bad keyword) -- If no identifier, then consider that we definitely do not have an -- aspect specification. @@ -193,7 +235,7 @@ package body Ch13 is return Aspects; end if; - Scan; -- past WITH + Scan; -- past WITH (or possible WHEN after error) Aspects := Empty_List; -- Loop to scan aspects diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index 7415253ee43..ebd5709ed33 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -127,7 +127,7 @@ procedure Load is begin -- Don't do any loads if we already had a fatal error - if Fatal_Error (Cur_Unum) then + if Fatal_Error (Cur_Unum) = Error_Detected then return; end if; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 83f320b324e..76f6e53128d 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -951,6 +951,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- permitted). Note: this routine never checks the terminator token -- for aspects so it does not matter whether the aspect specifications -- are terminated by semicolon or some other character. + -- + -- Note: This function also handles the case of WHEN used where WITH + -- was intended, and in that case posts an error and returns True. procedure P_Aspect_Specifications (Decl : Node_Id; @@ -960,15 +963,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- argument is False, the scan pointer is left pointing past the aspects -- and the caller must check for a proper terminator. -- - -- P_Aspect_Specifications is called with the current token pointing to - -- either a WITH keyword starting an aspect specification, or an - -- instance of the terminator token. In the former case, the aspect - -- specifications are scanned out including the terminator token if it - -- it is a semicolon, and the Has_Aspect_Specifications flag is set in - -- the given declaration node. A list of aspects is built and stored for - -- this declaration node using a call to Set_Aspect_Specifications. If - -- no WITH keyword is present, then this call has no effect other than - -- scanning out the terminator if it is a semicolon. + -- P_Aspect_Specifications is called with the current token pointing + -- to either a WITH keyword starting an aspect specification, or an + -- instance of what shpould be a terminator token. In the former case, + -- the aspect specifications are scanned out including the terminator + -- token if it it is a semicolon, and the Has_Aspect_Specifications + -- flag is set in the given declaration node. A list of aspects + -- is built and stored for this declaration node using a call to + -- Set_Aspect_Specifications. If no WITH keyword is present, then this + -- call has no effect other than scanning out the terminator if it is a + -- semicolon (with the exception that it detects WHEN used in place of + -- WITH). -- If Decl is Error on entry, any scanned aspect specifications are -- ignored and a message is output saying aspect specifications not diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 29ca1fa68d4..c96e708872e 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -979,7 +979,7 @@ package body Rtsfind is if U.Unum = No_Unit then Load_Fail ("not found", U_Id, Id); - elsif Fatal_Error (U.Unum) then + elsif Fatal_Error (U.Unum) = Error_Detected then Load_Fail ("had parser errors", U_Id, Id); end if; @@ -1025,7 +1025,7 @@ package body Rtsfind is Semantics (Cunit (U.Unum)); Restore_Private_Visibility; - if Fatal_Error (U.Unum) then + if Fatal_Error (U.Unum) = Error_Detected then Load_Fail ("had semantic errors", U_Id, Id); end if; end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 5e66316cdf5..d7df7eb9bbb 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -936,7 +936,7 @@ package body Sem_Ch10 is and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body or else Distribution_Stub_Mode = Generate_Caller_Stub_Body) - and then not Fatal_Error (Main_Unit) + and then Fatal_Error (Main_Unit) /= Error_Detected then if Is_RCI_Pkg_Spec_Or_Body (N) then @@ -1096,7 +1096,7 @@ package body Sem_Ch10 is elsif not Analyzed (Cunit (Un)) and then Un /= Main_Unit - and then not Fatal_Error (Un) + and then Fatal_Error (Un) /= Error_Detected then Style_Check := False; Semantics (Cunit (Un)); @@ -1623,7 +1623,8 @@ package body Sem_Ch10 is -- All done if we successfully loaded the subunit if Unum /= No_Unit - and then (not Fatal_Error (Unum) or else Try_Semantics) + and then (Fatal_Error (Unum) /= Error_Detected + or else Try_Semantics) then Comp_Unit := Cunit (Unum); @@ -1860,7 +1861,9 @@ package body Sem_Ch10 is -- Analyze the unit if semantics active - if not Fatal_Error (Unum) or else Try_Semantics then + if Fatal_Error (Unum) /= Error_Detected + or else Try_Semantics + then Analyze_Subunit (Comp_Unit); end if; end if; @@ -5442,7 +5445,7 @@ package body Sem_Ch10 is else Compiler_State := Analyzing; -- reset after load - if not Fatal_Error (Unum) or else Try_Semantics then + if Fatal_Error (Unum) /= Error_Detected or else Try_Semantics then if Debug_Flag_L then Write_Str ("*** Loaded generic body"); Write_Eol; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 10b0062f3b3..7d0ca02d6fc 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7770,7 +7770,7 @@ package body Sem_Ch13 is -- at the end of the private part and has the wrong visibility. Set_Parent (Exp, N); - Preanalyze_Assert_Expression (Exp, Standard_Boolean); + Preanalyze_Assert_Expression (Exp, Any_Boolean); -- A class-wide invariant may be inherited in a separate unit, -- where the corresponding expression cannot be resolved by diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7699a6fc80f..5aa5fe0475c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19420,15 +19420,27 @@ package body Sem_Ch3 is begin if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then not Limited_Present (Parent (Priv_T)) - and then not Synchronized_Present (Parent (Priv_T)) and then Nkind (Orig_Decl) = N_Full_Type_Declaration and then Nkind (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition - and then Limited_Present (Type_Definition (Orig_Decl)) then - Error_Msg_N - ("full view of non-limited extension cannot be limited", N); + if not Limited_Present (Parent (Priv_T)) + and then not Synchronized_Present (Parent (Priv_T)) + and then Limited_Present (Type_Definition (Orig_Decl)) + then + Error_Msg_N + ("full view of non-limited extension cannot be limited", N); + + -- Conversely, if the partial view carries the limited keyword, + -- the full view must as well, even if it may be redundant. + + elsif Limited_Present (Parent (Priv_T)) + and then not Limited_Present (Type_Definition (Orig_Decl)) + then + Error_Msg_N + ("full view of limited extension must be explicitly limited", + N); + end if; end if; end; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8951059c98b..0567c176b9a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11783,7 +11783,7 @@ package body Sem_Prag is Make_If_Statement (Eloc, Condition => Make_And_Then (Eloc, - Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), + Left_Opnd => Make_Identifier (Eloc, Name_False), Right_Opnd => Expr), Then_Statements => New_List ( Make_Null_Statement (Eloc)))); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5096c6a6264..b51a2806e14 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6310,11 +6310,14 @@ package body Sem_Res is -- Check for calling a function with OUT or IN OUT parameter when the -- calling context (us right now) is not Ada 2012, so does not allow - -- OUT or IN OUT parameters in function calls. + -- OUT or IN OUT parameters in function calls. Functions declared in + -- a predefined unit are OK, as they may be called indirectly from a + -- user-declared instantiation. if Ada_Version < Ada_2012 and then Ekind (Nam) = E_Function and then Has_Out_Or_In_Out_Parameter (Nam) + and then not In_Predefined_Unit (Nam) then Error_Msg_NE ("& has at least one OUT or `IN OUT` parameter", N, Nam); Error_Msg_N ("\call to this function only allowed in Ada 2012", N);