+2015-02-05 Robert Dewar <dewar@adacore.com>
+
+ * 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 <dewar@adacore.com>
+
+ * checks.adb (Enable_Range_Check): Disconnect attempted
+ optimization for the case of range check for subscript of
+ unconstrained array.
+
+2015-02-05 Robert Dewar <dewar@adacore.com>
+
+ * 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 <dewar@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <dewar@adacore.com>
* g-rannum.adb, g-rannum.ads, s-rannum.adb, s-rannum.ads,
-- --
-- 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- --
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);
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;
-- --
-- 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- --
-- 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
-- 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.
-- --
-- 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- --
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,
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,
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,
-- 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
Cunit_Entity => Empty,
Dependency_Num => 0,
Dynamic_Elab => False,
- Fatal_Error => False,
+ Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
Filler => False,
Cunit_Entity => Empty,
Dependency_Num => 0,
Dynamic_Elab => False,
- Fatal_Error => False,
+ Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
Filler => False,
-- --
-- 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- --
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;
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
-- --
-- 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- --
-- 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,
-- 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
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;
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).
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;
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;
-- --
-- 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- --
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
-- 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, " &
-- 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;
-- --
-- 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- --
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 --
--------------------------------
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
-- 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.
return Aspects;
end if;
- Scan; -- past WITH
+ Scan; -- past WITH (or possible WHEN after error)
Aspects := Empty_List;
-- Loop to scan aspects
-- --
-- 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- --
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;
-- --
-- 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- --
-- 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;
-- 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
-- --
-- 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- --
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;
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;
-- --
-- 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- --
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
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));
-- 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);
-- 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;
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;
-- 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
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;
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))));
-- 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);
projects / thirdparty / gcc.git / commitdiff
