diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-04-08 06:45:42 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-04-08 06:45:42 +0000 |
| commit | 3a2db8abb826ba557346f732bd7604511002a208 (patch) | |
| tree | 364bb5359429fa617f70c71d9d19558946d8121d | |
| parent | d55c93e01d022e1db25688345ef53ab282c1f1b1 (diff) | |
| download | gcc-3a2db8abb826ba557346f732bd7604511002a208.tar.gz | |
2008-04-08 Robert Dewar <dewar@adacore.com>
Gary Dismukes <dismukes@adacore.com>
Javier Miranda <miranda@adacore.com>
Ed Schonberg <schonberg@adacore.com>
* fe.h: Remove global Optimize_Alignment flag, no longer used
* layout.adb: Test Optimize_Alignment flags rather than global switch
* lib.ads, lib.adb: New OA_Setting field in library record
* lib-load.adb: New OA_Setting field in library record
* lib-writ.ads, lib-writ.adb (Collect_Withs, Write_With_Lines): Place
units mentioned in limited_with_ clauses in the ali file, with an
'Y' marker.
New Ox fields in U line
* opt.adb: New flag Optimize_Alignment_Local
(Check_Policy_List[_Config]): New flags
* opt.ads (Invalid_Value_Used): New flag
New switch Optimize_Alignment_Local
(Warn_On_Parameter_Order): New flag
(Check_Policy_List[_Config]): New flags
* ali.ads, ali.adb: Add indicator 'Y' to mark mark the presence of
limited_with clauses.
New data structures for Optimize_Alignment
* bcheck.adb (Check_Consistent_Restriction_No_Default_Initialization):
New procedure
(Check_Consistent_Optimize_Alignment): Rework for new structure
(Check_Consistent_Restrictions): Fix incorrect error message
sem_ch10.adb (Decorate_Tagged_Type): Set the Parent field of a newly
created class-wide type (to the Parent field of the specific type).
(Install_Siblings): Handle properly private_with_clauses on subprogram
bodies and on generic units.
(Analyze_With_Clause, Install_Limited_Withed_Unit): Guard against an
illegal limited_with_clause that names a non-existent package.
(Check_Body_Required): Determine whether a unit named a limited_with
clause needs a body.
(Analyze_Context): A limited_with_clause is illegal on a unit_renaming.
Capture Optimize_Alignment settings to set new OA_Setting field in
library record.
(Build_Limited_Views): Include task and protected type declarations.
* sem_ch3.ads, sem_ch3.adb (Analyze_Object_Declaration): Handle the
case of a possible constant redeclaration where the current object is
an entry index constant.
(Analyze_Object_Declaration): Generate an error in case of CPP
class-wide object initialization.
(Analyze_Object_Declaration): Add extra information on warnings for
declaration of unconstrained objects.
(Access_Type_Declaration): Set Associated_Final_Chain to Empty, to avoid
conflicts with the setting of Stored_Constraint in the case where the
access type entity has already been created as an E_Incomplete_Type due
to a limited with clause.
Use new Is_Standard_Character_Type predicate
(Analyze_Object_Declaration): Apply access_constant check only after
expression has been resolved, given that it may be overloaded with
several access types.
(Constant_Redeclaration): Additional legality checks for deferred
constant declarations tha involve anonymous access types and/or null
exclusion indicators.
(Analyze_Type_Declaration): Set Optimize_Alignment flags
(Analyze_Subtype_Declaration): Ditto
(Analyze_Object_Declaration): Ditto
(Analyze_Object_Declaration): Don't count tasks in generics
Change name In_Default_Expression => In_Spec_Expression
Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve
(Process_Discriminants): Additional check for illegal use of default
expressions in access discriminant specifications in a type that is not
explicitly limited.
(Check_Abstract_Overriding): If an inherited function dispaches on an
access result, it must be overridden, even if the type is a null
extension.
(Derive_Subprogram): The formals of the derived subprogram have the
names and defaults of the parent subprogram, even if the type is
obtained from the actual subprogram.
(Derive_Subprogram): In the presence of interfaces, a formal of an
inherited operation has the derived type not only if it descends from
the type of the formal of the parent operation, but also if it
implements it. This is relevant for the renamings created for the
primitive operations of the actual for a formal derived type.
(Is_Progenitor): New predicate, to determine whether the type of a
formal in the parent operation must be replaced by the derived type.
* sem_util.ads, sem_util.adb (Has_Overriding_Initialize): Make
predicate recursive to handle components that have a user-defined
Initialize procedure. Handle controlled derived types whose ancestor
has a user-defined Initialize procedured.
(Note_Possible_Modification): Add Sure parameter, generate warning if
sure modification of constant
Use new Is_Standard_Character_Type predicate
(Find_Parameter_Type): when determining whether a protected operation
implements an interface operation, retrieve the type of the formal from
the entity when the formal is an access parameter or an
anonymous-access-to-subprogram.
Move Copy_Parameter_List to sem_util, for use when building stubbed
subprogram bodies.
(Has_Access_Values): Tagged types now return False
(Within_HSS_Or_If): New procedure
(Set_Optimize_Alignment_Flags): New procedure
Change name In_Default_Expression => In_Spec_Expression
Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@134011 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/ali.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/ali.ads | 47 | ||||
| -rw-r--r-- | gcc/ada/bcheck.adb | 130 | ||||
| -rw-r--r-- | gcc/ada/fe.h | 6 | ||||
| -rw-r--r-- | gcc/ada/layout.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/lib-load.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 90 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.ads | 28 | ||||
| -rw-r--r-- | gcc/ada/lib.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/lib.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/opt.adb | 44 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 46 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 349 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 476 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 455 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 54 |
17 files changed, 1371 insertions, 453 deletions
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 96624d6a835..31695a386ac 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -53,6 +53,7 @@ package body ALI is 'D' => True, -- dependency 'X' => True, -- xref 'S' => True, -- specific dispatching + 'Y' => True, -- limited_with others => False); -------------------- @@ -772,7 +773,7 @@ package body ALI is -- Acquire lines to be ignored if Read_Xref then - Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True); + Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given @@ -818,7 +819,6 @@ package body ALI is No_Object => False, Normalize_Scalars => False, Ofile_Full_Name => Full_Object_File_Name, - Optimize_Alignment_Setting => 'O', Queuing_Policy => ' ', Restrictions => No_Restrictions, SAL_Interface => False, @@ -1041,11 +1041,6 @@ package body ALI is Fatal_Error_Ignore; end if; - -- Processing for Ox - - elsif C = 'O' then - ALIs.Table (Id).Optimize_Alignment_Setting := Getc; - -- Processing for Qx elsif C = 'Q' then @@ -1424,6 +1419,7 @@ package body ALI is UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; + UL.Optimize_Alignment := 'O'; if Debug_Flag_U then Write_Str (" ----> reading unit "); @@ -1626,6 +1622,19 @@ package body ALI is Check_At_End_Of_Field; + -- OL/OO/OS/OT parameters + + elsif C = 'O' then + C := Getc; + + if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then + Units.Table (Units.Last).Optimize_Alignment := C; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + -- RC/RT parameters elsif C = 'R' then @@ -1678,7 +1687,7 @@ package body ALI is With_Loop : loop Check_Unknown_Line; - exit With_Loop when C /= 'W'; + exit With_Loop when C /= 'W' and then C /= 'Y'; if Ignore ('W') then Skip_Line; @@ -1693,6 +1702,7 @@ package body ALI is Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; + Withs.Table (Withs.Last).Limited_With := (C = 'Y'); -- Generic case with no object file available diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index c632c659045..dd3b6cd6577 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -176,11 +176,6 @@ package ALI is -- Set to True if file was compiled with Normalize_Scalars. Not set if -- 'P' appears in Ignore_Lines. - Optimize_Alignment_Setting : Character; - -- Optimize_Alignment setting. Set to S/T if OS/OT parameters present, - -- otherwise set to 'O' (S/T/O = Space/Time/Off). Not set if 'P' appears - -- in Ignore_Lines. - Unit_Exception_Table : Boolean; -- Set to True if unit exception table pointer generated. Not set if 'P' -- appears in Ignore_Lines. @@ -358,6 +353,9 @@ package ALI is -- for the body right after the call for the spec, or at least as close -- together as possible. + Optimize_Alignment : Character; + -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present + end record; package Units is new Table.Table ( @@ -539,6 +537,8 @@ package ALI is SAL_Interface : Boolean := False; -- True if the Unit is an Interface of a Stand-Alone Library + Limited_With : Boolean := False; + -- True if unit is named in a limited_with_clause end record; package Withs is new Table.Table ( @@ -669,8 +669,8 @@ package ALI is -- Sdep (Source Dependency) Table -- ------------------------------------ - -- Each source dependency (D line) in an ALI file generates an - -- entry in the Sdep table. + -- Each source dependency (D line) in an ALI file generates an entry in the + -- Sdep table. -- Note: there will be no entries in this table if 'D' lines are ignored @@ -678,9 +678,9 @@ package ALI is -- Special value indicating no Sdep table entry First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; - -- Id of first Sdep entry for current ali file. This is initialized to - -- the first Sdep entry in the table, and then incremented appropriately - -- as successive ALI files are scanned. + -- Id of first Sdep entry for current ali file. This is initialized to the + -- first Sdep entry in the table, and then incremented appropriately as + -- successive ALI files are scanned. type Sdep_Record is record @@ -688,24 +688,23 @@ package ALI is -- Name of source file Stamp : Time_Stamp_Type; - -- Time stamp value. Note that this will be all zero characters - -- for the dummy entries for missing or non-dependent files. + -- Time stamp value. Note that this will be all zero characters for the + -- dummy entries for missing or non-dependent files. Checksum : Word; - -- Checksum value. Note that this will be all zero characters - -- for the dummy entries for missing or non-dependent files + -- Checksum value. Note that this will be all zero characters for the + -- dummy entries for missing or non-dependent files Dummy_Entry : Boolean; - -- Set True for dummy entries that correspond to missing files - -- or files where no dependency relationship exists. + -- Set True for dummy entries that correspond to missing files or files + -- where no dependency relationship exists. Subunit_Name : Name_Id; -- Name_Id for subunit name if present, else No_Name Rfile : File_Name_Type; - -- Reference file name. Same as Sfile unless a Source_Reference - -- pragma was used, in which case it reflects the name used in - -- the pragma. + -- Reference file name. Same as Sfile unless a Source_Reference pragma + -- was used, in which case it reflects the name used in the pragma. Start_Line : Nat; -- Starting line number in file. Always 1, unless a Source_Reference @@ -726,8 +725,8 @@ package ALI is -- Use of Name Table Info -- ---------------------------- - -- All unit names and file names are entered into the Names table. The - -- Info fields of these entries are used as follows: + -- All unit names and file names are entered into the Names table. The Info + -- fields of these entries are used as follows: -- Unit name Info field has Unit_Id of unit table entry -- ALI file name Info field has ALI_Id of ALI table entry @@ -737,8 +736,8 @@ package ALI is -- Cross-Reference Data -- -------------------------- - -- The following table records cross-reference sections, there is one - -- entry for each X header line in the ALI file for an xref section. + -- The following table records cross-reference sections, there is one entry + -- for each X header line in the ALI file for an xref section. -- Note: there will be no entries in this table if 'X' lines are ignored diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index c397cc8dc92..3332d2083f8 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -43,7 +43,7 @@ package body Bcheck is ----------------------- -- The following checking subprograms make up the parts of the - -- configuration consistency check. + -- configuration consistency check. See bodies for details of checks. procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dynamic_Elaboration_Checking; @@ -54,6 +54,7 @@ package body Bcheck is procedure Check_Consistent_Optimize_Alignment; procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Restrictions; + procedure Check_Consistent_Restriction_No_Default_Initialization; procedure Check_Consistent_Zero_Cost_Exception_Handling; procedure Consistency_Error_Msg (Msg : String); @@ -90,6 +91,7 @@ package body Bcheck is Check_Consistent_Optimize_Alignment; Check_Consistent_Dynamic_Elaboration_Checking; Check_Consistent_Restrictions; + Check_Consistent_Restriction_No_Default_Initialization; Check_Consistent_Interrupt_States; Check_Consistent_Dispatching_Policy; end Check_Configuration_Consistency; @@ -700,34 +702,40 @@ package body Bcheck is -- Check_Consistent_Optimize_Alignment -- ----------------------------------------- - -- The rule is that all units other than internal units must be compiled - -- with the same setting for Optimize_Alignment. We can exclude internal - -- units since they are forced to compile with Optimize_Alignment (Off). + -- The rule is that all units which depend on the global default setting + -- of Optimize_Alignment must be compiled with the same settinng for this + -- default. Units which specify an explicit local value for this setting + -- are exempt from the consistency rule (this includes all internal units). procedure Check_Consistent_Optimize_Alignment is OA_Setting : Character := ' '; - -- Reset when we find a non-internal unit + -- Reset when we find a unit that depends on the default and does + -- not have a local specification of the Optimize_Alignment setting. - OA_Unit : ALI_Id; + OA_Unit : Unit_Id; -- Id of unit from which OA_Setting was set + C : Character; + begin - for A in ALIs.First .. ALIs.Last loop - if not Is_Internal_File_Name (ALIs.Table (A).Afile) then + for U in First_Unit_Entry .. Units.Last loop + C := Units.Table (U).Optimize_Alignment; + + if C /= 'L' then if OA_Setting = ' ' then - OA_Setting := ALIs.Table (A).Optimize_Alignment_Setting; - OA_Unit := A; + OA_Setting := C; + OA_Unit := U; - elsif OA_Setting = ALIs.Table (A).Optimize_Alignment_Setting then + elsif OA_Setting = C then null; else - Error_Msg_File_1 := ALIs.Table (OA_Unit).Sfile; - Error_Msg_File_2 := ALIs.Table (A).Sfile; + Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; + Error_Msg_Unit_2 := Units.Table (U).Uname; Consistency_Error_Msg - ("{ and { compiled with different " - & "Optimize_Alignment settings"); + ("$ and $ compiled with different " + & "default Optimize_Alignment settings"); return; end if; end if; @@ -775,10 +783,9 @@ package body Bcheck is -- Check_Consistent_Restrictions -- ----------------------------------- - -- The rule is that if a restriction is specified in any unit, - -- then all units must obey the restriction. The check applies - -- only to restrictions which require partition wide consistency, - -- and not to internal units. + -- The rule is that if a restriction is specified in any unit, then all + -- units must obey the restriction. The check applies only to restrictions + -- which require partition wide consistency, and not to internal units. procedure Check_Consistent_Restrictions is Restriction_File_Output : Boolean; @@ -811,7 +818,7 @@ package body Bcheck is declare M1 : constant String := "{ has restriction "; S : constant String := Restriction_Id'Image (R); - M2 : String (1 .. 200); -- big enough! + M2 : String (1 .. 2000); -- big enough! P : Integer; begin @@ -902,7 +909,7 @@ package body Bcheck is (" { (count = at least #)"); else Consistency_Error_Msg - (" % (count = #)"); + (" { (count = #)"); end if; end if; end if; @@ -950,6 +957,75 @@ package body Bcheck is end loop; end Check_Consistent_Restrictions; + ------------------------------------------------------------ + -- Check_Consistent_Restriction_No_Default_Initialization -- + ------------------------------------------------------------ + + -- The Restriction (No_Default_Initialization) has special consistency + -- rules. The rule is that no unit compiled without this restriction + -- that violates the restriction can WITH a unit that is compiled with + -- the restriction. + + procedure Check_Consistent_Restriction_No_Default_Initialization is + begin + -- Nothing to do if no one set this restriction + + if not Cumulative_Restrictions.Set (No_Default_Initialization) then + return; + end if; + + -- Nothing to do if no one violates the restriction + + if not Cumulative_Restrictions.Violated (No_Default_Initialization) then + return; + end if; + + -- Otherwise we go into a full scan to find possible problems + + for U in Units.First .. Units.Last loop + declare + UTE : Unit_Record renames Units.Table (U); + ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); + + begin + if ATE.Restrictions.Violated (No_Default_Initialization) then + for W in UTE.First_With .. UTE.Last_With loop + declare + AFN : constant File_Name_Type := Withs.Table (W).Afile; + + begin + -- The file name may not be present for withs of certain + -- generic run-time files. The test can be safely left + -- out in such cases anyway. + + if AFN /= No_File then + declare + WAI : constant ALI_Id := + ALI_Id (Get_Name_Table_Info (AFN)); + WTE : ALIs_Record renames ALIs.Table (WAI); + + begin + if WTE.Restrictions.Set + (No_Default_Initialization) + then + Error_Msg_Unit_1 := UTE.Uname; + Consistency_Error_Msg + ("unit $ compiled without restriction " + & "No_Default_Initialization"); + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Consistency_Error_Msg + ("withs unit $, compiled with restriction " + & "No_Default_Initialization"); + end if; + end; + end if; + end; + end loop; + end if; + end; + end loop; + end Check_Consistent_Restriction_No_Default_Initialization; + --------------------------------------------------- -- Check_Consistent_Zero_Cost_Exception_Handling -- --------------------------------------------------- @@ -1056,15 +1132,7 @@ package body Bcheck is -- If consistency errors are tolerated, -- output the message as a warning. - declare - Warning_Msg : String (1 .. Msg'Length + 1); - - begin - Warning_Msg (1) := '?'; - Warning_Msg (2 .. Warning_Msg'Last) := Msg; - - Error_Msg (Warning_Msg); - end; + Error_Msg ('?' & Msg); -- Otherwise the consistency error is a true error diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 09dd2792063..2a038d58ffe 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, 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- * @@ -46,11 +46,11 @@ extern char Fold_Lower[], Fold_Upper[]; /* debug: */ -#define Debug_Flag_XX debug__debug_flag_xx #define Debug_Flag_NN debug__debug_flag_nn +#define Debug_Flag_Dot_A debug__debug_flag_dot_a -extern Boolean Debug_Flag_XX; extern Boolean Debug_Flag_NN; +extern Boolean Debug_Flag_Dot_A; /* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, Alignment for types and objects, Component_Size for array types, and diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 45cc66247bb..c6dec0aa379 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, 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- -- @@ -2807,7 +2807,7 @@ package body Layout is -- have an alignment of 1. But don't do anything for atomic records -- since we may need higher alignment for indivisible access. - if Optimize_Alignment = 'S' + if Optimize_Alignment_Space (E) and then Is_Record_Type (E) and then Is_Packed (E) and then not Is_Atomic (E) @@ -2848,7 +2848,7 @@ package body Layout is -- alignment matches the size, for example, if the size is 17 -- bytes then we want an alignment of 1 for the type. - elsif Optimize_Alignment = 'S' then + elsif Optimize_Alignment_Space (E) then if Siz mod (8 * System_Storage_Unit) = 0 then Align := 8; elsif Siz mod (4 * System_Storage_Unit) = 0 then @@ -2864,7 +2864,7 @@ package body Layout is -- alignment of 4. Note that this matches the old VMS behavior -- in versions of GNAT prior to 6.1.1. - elsif Optimize_Alignment = 'T' + elsif Optimize_Alignment_Time (E) and then Siz > System_Storage_Unit and then Siz <= 8 * System_Storage_Unit then @@ -2902,7 +2902,7 @@ package body Layout is -- since conceivably we may be able to do better. if Align > System_Word_Size / System_Storage_Unit - and then Optimize_Alignment /= 'T' + and then not Optimize_Alignment_Time (E) then Align := System_Word_Size / System_Storage_Unit; end if; @@ -2912,7 +2912,7 @@ package body Layout is -- we have Optimize_Alignment set to Space. Note that that covers -- the case of packed records, where we already set alignment to 1. - if Optimize_Alignment /= 'S' then + if not Optimize_Alignment_Space (E) then declare Comp : Entity_Id; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index f439926b4cb..d928b79a3a9 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -224,7 +224,8 @@ package body Lib.Load is Source_Index => No_Source_File, Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), Unit_Name => Spec_Name, - Version => 0); + Version => 0, + OA_Setting => 'O'); Set_Comes_From_Source_Default (Save_CS); Set_Error_Posted (Cunit_Entity); @@ -327,7 +328,8 @@ package body Lib.Load is Source_Index => Main_Source_File, Unit_File_Name => Fname, Unit_Name => No_Unit_Name, - Version => Version); + Version => Version, + OA_Setting => 'O'); end if; end Load_Main_Source; @@ -647,7 +649,8 @@ package body Lib.Load is Source_Index => Src_Ind, Unit_File_Name => Fname, Unit_Name => Uname_Actual, - Version => Source_Checksum (Src_Ind)); + Version => Source_Checksum (Src_Ind), + OA_Setting => 'O'); -- Parse the new unit diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 68a5a74c0df..7ebfc7d3d51 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -87,7 +87,8 @@ package body Lib.Writ is Munit_Index => 0, Serial_Number => 0, Version => 0, - Error_Location => No_Location); + Error_Location => No_Location, + OA_Setting => 'O'); end Add_Preprocessing_Dependency; ------------------------------ @@ -141,7 +142,8 @@ package body Lib.Writ is Munit_Index => 0, Serial_Number => 0, Version => 0, - Error_Location => No_Location); + Error_Location => No_Location, + OA_Setting => 'O'); -- Parse system.ads so that the checksum is set right -- Style checks are not applied. @@ -236,28 +238,33 @@ package body Lib.Writ is -- Process with clause -- Ada 2005 (AI-50217): limited with_clauses do not create - -- dependencies + -- dependencies, but must be recorded as components of the + -- partition, in case there is no regular with_clause for + -- the unit anywhere else. - if Nkind (Item) = N_With_Clause - and then not (Limited_Present (Item)) - then + if Nkind (Item) = N_With_Clause then Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); With_Flags (Unum) := True; - if Elaborate_Present (Item) then - Elab_Flags (Unum) := True; - end if; + if not Limited_Present (Item) then + if Elaborate_Present (Item) then + Elab_Flags (Unum) := True; + end if; - if Elaborate_All_Present (Item) then - Elab_All_Flags (Unum) := True; - end if; + if Elaborate_All_Present (Item) then + Elab_All_Flags (Unum) := True; + end if; - if Elaborate_All_Desirable (Item) then - Elab_All_Des_Flags (Unum) := True; - end if; + if Elaborate_All_Desirable (Item) then + Elab_All_Des_Flags (Unum) := True; + end if; - if Elaborate_Desirable (Item) then - Elab_Des_Flags (Unum) := True; + if Elaborate_Desirable (Item) then + Elab_Des_Flags (Unum) := True; + end if; + + else + Set_From_With_Type (Cunit_Entity (Unum)); end if; end if; @@ -441,6 +448,9 @@ package body Lib.Writ is Write_Info_Str (" NE"); end if; + Write_Info_Str (" O"); + Write_Info_Char (OA_Setting (Unit_Num)); + if Is_Preelaborated (Uent) then Write_Info_Str (" PR"); end if; @@ -512,7 +522,7 @@ package body Lib.Writ is end case; end if; - if Initialize_Scalars then + if Initialize_Scalars or else Invalid_Value_Used then Write_Info_Str (" IS"); end if; @@ -696,7 +706,14 @@ package body Lib.Writ is Uname := Units.Table (Unum).Unit_Name; Fname := Units.Table (Unum).Unit_File_Name; - Write_Info_Initiate ('W'); + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + Write_Info_Initiate ('Y'); + else + Write_Info_Initiate ('W'); + end if; + Write_Info_Char (' '); Write_Info_Name (Uname); @@ -750,20 +767,26 @@ package body Lib.Writ is Write_With_File_Names (Fname, Munit_Index (Unum)); end if; - if Elab_Flags (Unum) then - Write_Info_Str (" E"); - end if; + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + null; + else + if Elab_Flags (Unum) then + Write_Info_Str (" E"); + end if; - if Elab_All_Flags (Unum) then - Write_Info_Str (" EA"); - end if; + if Elab_All_Flags (Unum) then + Write_Info_Str (" EA"); + end if; - if Elab_Des_Flags (Unum) then - Write_Info_Str (" ED"); - end if; + if Elab_Des_Flags (Unum) then + Write_Info_Str (" ED"); + end if; - if Elab_All_Des_Flags (Unum) then - Write_Info_Str (" AD"); + if Elab_All_Des_Flags (Unum) then + Write_Info_Str (" AD"); + end if; end if; end if; @@ -971,11 +994,6 @@ package body Lib.Writ is Write_Info_Str (" NS"); end if; - if Optimize_Alignment /= 'O' then - Write_Info_Str (" O"); - Write_Info_Char (Optimize_Alignment); - end if; - if Sec_Stack_Used then Write_Info_Str (" SS"); end if; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 316a494185e..f152742bfa7 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -167,7 +167,7 @@ package Lib.Writ is -- P <<parameters>> -- Indicates various information that applies to the compilation - -- of the corresponding source unit. Parameters is a sequence of + -- of the corresponding source file. Parameters is a sequence of -- zero or more two letter codes that indicate configuration -- pragmas and other parameters that apply: -- @@ -211,10 +211,6 @@ package Lib.Writ is -- NS Normalize_Scalars pragma in effect for all units in -- this file. -- - -- OS Optimize_Alignment (Space) active for all units in this file - -- - -- OT Optimize_Alignment (Time) active for all units in this file - -- -- Qx A valid Queueing_Policy pragma applies to all the units -- in this file, where x is the first character (upper case) -- of the policy name (e.g. 'P' for Priority_Queueing). @@ -462,7 +458,8 @@ package Lib.Writ is -- case usage is detected, or the compiler cannot determine -- the style, then no I parameter will appear. -- - -- IS Initialize_Scalars pragma applies to this unit + -- IS Initialize_Scalars pragma applies to this unit, or else there + -- is at least one use of the Invalid_Value attribute. -- -- KM Unit source uses a style with keywords in mixed case -- KU (KM) or all upper case (KU). If the standard lower-case @@ -475,6 +472,23 @@ package Lib.Writ is -- elaboration code is required. Set if N_Compilation_Unit -- node has flag Has_No_Elaboration_Code set. -- + -- OL The units in this file are commpiled with a local pragma + -- Optimize_Alignment, so no consistency requirement applies + -- to these units. All internal units have this status since + -- they have an automatic default of Optimize_Alignment (Off). + -- + -- OO Optimize_Alignment (Off) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OS Optimize_Alignment (Space) is the default settinng for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OT Optimize_Alignment (Time) is the default settinng for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- -- PK Unit is package, rather than a subprogram -- -- PU Unit has pragma Pure diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index d39723a85e4..dd0e24552bf 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -145,6 +145,11 @@ package body Lib is return Units.Table (U).Munit_Index; end Munit_Index; + function OA_Setting (U : Unit_Number_Type) return Character is + begin + return Units.Table (U).OA_Setting; + end OA_Setting; + function Source_Index (U : Unit_Number_Type) return Source_File_Index is begin return Units.Table (U).Source_Index; @@ -223,6 +228,11 @@ package body Lib is Units.Table (U).Main_Priority := P; end Set_Main_Priority; + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is + begin + Units.Table (U).OA_Setting := C; + end Set_OA_Setting; + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is begin Units.Table (U).Unit_Name := N; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 746b2c87c7e..672396e52b0 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -344,6 +344,10 @@ package Lib is -- that the default priority is to be used (and is also used for -- entries that do not correspond to possible main programs). + -- OA_Setting + -- This is a character field containing L if Optimize_Alignment mode + -- was set locally, and O/T/S for Off/Time/Space default if not. + -- Serial_Number -- This field holds a serial number used by New_Internal_Name to -- generate unique temporary numbers on a unit by unit basis. The @@ -385,6 +389,7 @@ package Lib is function Loading (U : Unit_Number_Type) return Boolean; function Main_Priority (U : Unit_Number_Type) return Int; function Munit_Index (U : Unit_Number_Type) return Nat; + function OA_Setting (U : Unit_Number_Type) return Character; function Source_Index (U : Unit_Number_Type) return Source_File_Index; function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; @@ -401,6 +406,7 @@ package Lib is procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); procedure Set_Loading (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 @@ -630,6 +636,7 @@ private pragma Inline (Loading); pragma Inline (Main_Priority); pragma Inline (Munit_Index); + pragma Inline (OA_Setting); pragma Inline (Set_Cunit); pragma Inline (Set_Cunit_Entity); pragma Inline (Set_Fatal_Error); @@ -637,6 +644,7 @@ private pragma Inline (Set_Has_RACW); pragma Inline (Set_Loading); pragma Inline (Set_Main_Priority); + pragma Inline (Set_OA_Setting); pragma Inline (Set_Unit_Name); pragma Inline (Source_Index); pragma Inline (Unit_File_Name); @@ -662,6 +670,7 @@ private Is_Compiler_Unit : Boolean; Dynamic_Elab : Boolean; Loading : Boolean; + OA_Setting : Character; end record; -- The following representation clause ensures that the above record @@ -686,11 +695,12 @@ private Generate_Code at 53 range 0 .. 7; Has_RACW at 54 range 0 .. 7; Dynamic_Elab at 55 range 0 .. 7; - Is_Compiler_Unit at 56 range 0 .. 31; - Loading at 60 range 0 .. 31; + Is_Compiler_Unit at 56 range 0 .. 7; + OA_Setting at 57 range 0 .. 7; + Loading at 58 range 0 .. 15; end record; - for Unit_Record'Size use 64 * 8; + for Unit_Record'Size use 60 * 8; -- This ensures that we did not leave out any fields package Units is new Table.Table ( diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 64460f60ff6..859a4170ead 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -49,6 +49,7 @@ package body Opt is Ada_Version_Config := Ada_Version; Ada_Version_Explicit_Config := Ada_Version_Explicit; Assertions_Enabled_Config := Assertions_Enabled; + Check_Policy_List_Config := Check_Policy_List; Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; @@ -60,6 +61,12 @@ package body Opt is Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Polling_Required_Config := Polling_Required; Use_VADS_Size_Config := Use_VADS_Size; + + -- Reset the indication that Optimize_Alignment was set locally, since + -- if we had a pragma in the config file, it would set this flag True, + -- but that's not a local setting. + + Optimize_Alignment_Local := False; end Register_Opt_Config_Switches; --------------------------------- @@ -71,6 +78,7 @@ package body Opt is Ada_Version := Save.Ada_Version; Ada_Version_Explicit := Save.Ada_Version_Explicit; Assertions_Enabled := Save.Assertions_Enabled; + Check_Policy_List := Save.Check_Policy_List; Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; @@ -79,6 +87,7 @@ package body Opt is External_Name_Imp_Casing := Save.External_Name_Imp_Casing; Fast_Math := Save.Fast_Math; Optimize_Alignment := Save.Optimize_Alignment; + Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; Polling_Required := Save.Polling_Required; Use_VADS_Size := Save.Use_VADS_Size; @@ -93,6 +102,7 @@ package body Opt is Save.Ada_Version := Ada_Version; Save.Ada_Version_Explicit := Ada_Version_Explicit; Save.Assertions_Enabled := Assertions_Enabled; + Save.Check_Policy_List := Check_Policy_List; Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; @@ -101,6 +111,7 @@ package body Opt is Save.External_Name_Imp_Casing := External_Name_Imp_Casing; Save.Fast_Math := Fast_Math; Save.Optimize_Alignment := Optimize_Alignment; + Save.Optimize_Alignment_Local := Optimize_Alignment_Local; Save.Persistent_BSS_Mode := Persistent_BSS_Mode; Save.Polling_Required := Polling_Required; Save.Use_VADS_Size := Use_VADS_Size; @@ -131,6 +142,7 @@ package body Opt is Optimize_Alignment := 'O'; Persistent_BSS_Mode := False; Use_VADS_Size := False; + Optimize_Alignment_Local := True; -- For an internal unit, assertions/debug pragmas are off unless this -- is the main unit and they were explicitly enabled. @@ -138,26 +150,30 @@ package body Opt is if Main_Unit then Assertions_Enabled := Assertions_Enabled_Config; Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; + Check_Policy_List := Check_Policy_List_Config; else Assertions_Enabled := False; Debug_Pragmas_Enabled := False; + Check_Policy_List := Empty; end if; -- Case of non-internal unit else - Ada_Version := Ada_Version_Config; - Ada_Version_Explicit := Ada_Version_Explicit_Config; - Assertions_Enabled := Assertions_Enabled_Config; - Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; - Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; - Extensions_Allowed := Extensions_Allowed_Config; - External_Name_Exp_Casing := External_Name_Exp_Casing_Config; - External_Name_Imp_Casing := External_Name_Imp_Casing_Config; - Fast_Math := Fast_Math_Config; - Optimize_Alignment := Optimize_Alignment_Config; - Persistent_BSS_Mode := Persistent_BSS_Mode_Config; - Use_VADS_Size := Use_VADS_Size_Config; + Ada_Version := Ada_Version_Config; + Ada_Version_Explicit := Ada_Version_Explicit_Config; + Assertions_Enabled := Assertions_Enabled_Config; + Check_Policy_List := Check_Policy_List_Config; + Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; + Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; + Extensions_Allowed := Extensions_Allowed_Config; + External_Name_Exp_Casing := External_Name_Exp_Casing_Config; + External_Name_Imp_Casing := External_Name_Imp_Casing_Config; + Fast_Math := Fast_Math_Config; + Optimize_Alignment := Optimize_Alignment_Config; + Optimize_Alignment_Local := False; + Persistent_BSS_Mode := Persistent_BSS_Mode_Config; + Use_VADS_Size := Use_VADS_Size_Config; end if; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; @@ -192,6 +208,7 @@ package body Opt is Tree_Read_Int (Assertions_Enabled_Config_Val); Tree_Read_Bool (All_Errors_Mode); Tree_Read_Bool (Assertions_Enabled); + Tree_Read_Int (Int (Check_Policy_List)); Tree_Read_Bool (Debug_Pragmas_Enabled); Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Full_List); @@ -256,6 +273,7 @@ package body Opt is Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config)); Tree_Write_Bool (All_Errors_Mode); Tree_Write_Bool (Assertions_Enabled); + Tree_Write_Int (Int (Check_Policy_List)); Tree_Write_Bool (Debug_Pragmas_Enabled); Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 5d28a344d33..65a9bb4bd8d 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -214,6 +214,12 @@ package Opt is -- GNATBIND -- Set to True to do checks only, no output of binder file + Check_Policy_List : Node_Id := Empty; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. + Check_Readonly_Files : Boolean := False; -- GNATMAKE -- Set to True to check readonly files during the make process @@ -400,7 +406,7 @@ package Opt is -- message routines generates one line of output as a separate message. -- If it is set to a non-zero value, then continuation lines are folded -- to make a single long message, and then this message is split up into - -- multiple lines not exceeding the specified length. Set by -gnatLnnn. + -- multiple lines not exceeding the specified length. Set by -gnatj=nn. Exception_Locations_Suppressed : Boolean := False; -- GNAT @@ -620,6 +626,10 @@ package Opt is -- generate code even in case of unsupported construct, so that the byte -- code can be used by static analysis tools. + Invalid_Value_Used : Boolean := False; + -- GNAT + -- Set True if a valid Invalid_Value attribute is encountered + Follow_Links_For_Files : Boolean := False; -- PROJECT MANAGER -- Set to True (-eL) to process the project files in trusted mode @@ -862,6 +872,14 @@ package Opt is -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can -- be modified by use of pragma Optimize_Alignment. + Optimize_Alignment_Local : Boolean := False; + -- Set True if Optimize_Alignment mode is set by a local configuration + -- pragma that overrides the gnat.adc (or other configuration file) default + -- so that the unit is not dependent on the default setting. Also always + -- set True for internal units, since these always have a default setting + -- of Optimize_Alignment (Off) that is enforced (essentially equivalent to + -- them all having such an explicit pragma in each unit). + Original_Operating_Mode : Operating_Mode_Type := Generate_Code; -- GNAT -- Indicates the original operating mode of the compiler as set by @@ -870,7 +888,7 @@ package Opt is Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); - -- This constant reflects the optimization level (0,1,2 for -O0,-O1,-O2) + -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) Output_File_Name_Present : Boolean := False; -- GNATBIND, GNAT, GNATMAKE, GPRMAKE @@ -1133,7 +1151,7 @@ package Opt is Upper_Half_Encoding : Boolean := False; -- GNAT, GNATBIND - -- Normally set False, indicating that upper half ASCII characters are + -- Normally set False, indicating that upper half ISO 8859-1 characters are -- used in the normal way to represent themselves. If the wide character -- encoding method uses the upper bit for this encoding, then this flag is -- set True, and upper half characters in the source indicate the start of @@ -1190,6 +1208,12 @@ package Opt is -- including warnings on Ada 2005 obsolescent features used in Ada 2005 -- mode. Set False by -gnatwY. + Warn_On_Parameter_Order : Boolean := False; + -- GNAT + -- Set to True to generate warnings for cases where the argument list for + -- a call is a sequence of identifiers that match the formal identifiers, + -- but are in the wrong order. + Warn_On_Assertion_Failure : Boolean := True; -- GNAT -- Set to True to activate warnings on assertions that can be determined @@ -1374,6 +1398,13 @@ package Opt is -- mode, as possibly set by the command line switch -gnata, and possibly -- modified by the use of the configuration pragma Assertion_Policy. + Check_Policy_List_Config : Node_Id; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. This + -- list includes only those pragmas in configuration pragma files. + Debug_Pragmas_Enabled_Config : Boolean; -- GNAT -- This is the value of the configuration switch for debug pragmas enabled @@ -1485,9 +1516,10 @@ package Opt is -- call to Save_Opt_Switches. procedure Register_Opt_Config_Switches; - -- This procedure is called after processing the gnat.adc file to record - -- the values of the Config switches, as possibly modified by the use of - -- command line switches and configuration pragmas. + -- This procedure is called after processing the gnat.adc file and other + -- configuration pragma files to record the values of the Config switches, + -- as possibly modified by the use of command line switches and pragmas + -- appearing in these files. ------------------------ -- Other Global Flags -- @@ -1564,6 +1596,7 @@ private Ada_Version : Ada_Version_Type; Ada_Version_Explicit : Ada_Version_Type; Assertions_Enabled : Boolean; + Check_Policy_List : Node_Id; Debug_Pragmas_Enabled : Boolean; Dynamic_Elaboration_Checks : Boolean; Exception_Locations_Suppressed : Boolean; @@ -1572,6 +1605,7 @@ private External_Name_Imp_Casing : External_Casing_Type; Fast_Math : Boolean; Optimize_Alignment : Character; + Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; Polling_Required : Boolean; Use_VADS_Size : Boolean; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 665c1efb861..bd9b5746f3c 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -28,6 +28,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; +with Elists; use Elists; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; @@ -1247,6 +1248,16 @@ package body Sem_Ch10 is Next (Item); end loop; + -- This is the point at which we capture the configuration settings + -- for the unit. At the moment only the Optimize_Alignment setting + -- needs to be captured. Probably more later ??? + + if Optimize_Alignment_Local then + Set_OA_Setting (Current_Sem_Unit, 'L'); + else + Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment); + end if; + -- Loop through actual context items. This is done in two passes: -- a) The first pass analyzes non-limited with-clauses and also any @@ -1305,14 +1316,12 @@ package body Sem_Ch10 is if not Implicit_With (Item) then - -- Check compilation unit containing the limited-with clause + -- Verify that the illegal contexts given in 10.1.2 (18/2) + -- are properly rejected, including renaming declarations. if not Nkind_In (Ukind, N_Package_Declaration, - N_Subprogram_Declaration, - N_Package_Renaming_Declaration, - N_Subprogram_Renaming_Declaration) + N_Subprogram_Declaration) and then Ukind not in N_Generic_Declaration - and then Ukind not in N_Generic_Renaming_Declaration and then Ukind not in N_Generic_Instantiation then Error_Msg_N ("limited with_clause not allowed here", Item); @@ -2221,12 +2230,21 @@ package body Sem_Ch10 is Cunit_Boolean_Restrictions_Save; begin + U := Unit (Library_Unit (N)); + + -- Several actions are skipped for dummy packages (those supplied for + -- with's where no matching file could be found). Such packages are + -- identified by the Sloc value being set to No_Location. + if Limited_Present (N) then -- Ada 2005 (AI-50217): Build visibility structures but do not -- analyze the unit. - Build_Limited_Views (N); + if Sloc (U) /= No_Location then + Build_Limited_Views (N); + end if; + return; end if; @@ -2256,13 +2274,8 @@ package body Sem_Ch10 is Semantics (Library_Unit (N)); end if; - U := Unit (Library_Unit (N)); Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); - -- Following checks are skipped for dummy packages (those supplied for - -- with's where no matching file could be found). Such packages are - -- identified by the Sloc value being set to No_Location - if Sloc (U) /= No_Location then -- Check restrictions, except that we skip the check if this is an @@ -2529,6 +2542,7 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) + and then not Limited_Present (Item) and then Is_Private_Descendant (Entity (Name (Item))) then Priv_Child := Entity (Name (Item)); @@ -3166,7 +3180,11 @@ package body Sem_Ch10 is -- Check that if a limited_with clause of a given compilation_unit -- mentions a descendant of a private child of some library unit, -- then the given compilation_unit shall be the declaration of a - -- private descendant of that library unit. + -- private descendant of that library unit, or a public descendant + -- of such. The code is analogous to that of Check_Private_Child_Unit + -- but we cannot use entities on the limited with_clauses because + -- their units have not been analyzed, so we have to climb the tree + -- of ancestors looking for private keywords. procedure Expand_Limited_With_Clause (Comp_Unit : Node_Id; @@ -3277,11 +3295,12 @@ package body Sem_Ch10 is procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is Curr_Parent : Node_Id; Child_Parent : Node_Id; + Curr_Private : Boolean; begin -- Compilation unit of the parent of the withed library unit - Child_Parent := Parent_Spec (Unit (Library_Unit (Item))); + Child_Parent := Library_Unit (Item); -- If the child unit is a public child, then locate its nearest -- private ancestor, if any; Child_Parent will then be set to @@ -3297,18 +3316,21 @@ package body Sem_Ch10 is if No (Child_Parent) then return; end if; - - Child_Parent := Parent_Spec (Unit (Child_Parent)); end if; + Child_Parent := Parent_Spec (Unit (Child_Parent)); + -- Traverse all the ancestors of the current compilation -- unit to check if it is a descendant of named library unit. Curr_Parent := Parent (Item); + Curr_Private := Private_Present (Curr_Parent); + while Present (Parent_Spec (Unit (Curr_Parent))) and then Curr_Parent /= Child_Parent loop Curr_Parent := Parent_Spec (Unit (Curr_Parent)); + Curr_Private := Curr_Private or else Private_Present (Curr_Parent); end loop; if Curr_Parent /= Child_Parent then @@ -3318,12 +3340,18 @@ package body Sem_Ch10 is ("\current unit must also have parent&!", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); - elsif not Private_Present (Parent (Item)) - and then not Private_Present (Item) - and then not Nkind_In (Unit (Parent (Item)), N_Package_Body, + elsif Private_Present (Parent (Item)) + or else Curr_Private + or else Private_Present (Item) + or else Nkind_In (Unit (Parent (Item)), N_Package_Body, N_Subprogram_Body, N_Subunit) then + -- Current unit is private, of descendant of a private unit. + + null; + + else Error_Msg_NE ("current unit must also be private descendant of&", Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); @@ -3722,16 +3750,20 @@ package body Sem_Ch10 is Item := First (Context_Items (N)); while Present (Item) loop - -- Do not install private_with_clauses if the unit is a package - -- declaration, unless it is itself a private child unit. + -- Do not install private_with_clauses declaration, unless + -- unit is itself a private child unit, or is a body. + -- Note that for a subprogram body the private_with_clause does + -- not take effect until after the specification. - if Nkind (Item) = N_With_Clause - and then not Implicit_With (Item) - and then not Limited_Present (Item) - and then - (not Private_Present (Item) - or else Nkind (Unit (N)) /= N_Package_Declaration - or else Private_Present (N)) + if Nkind (Item) /= N_With_Clause + or else Implicit_With (Item) + or else Limited_Present (Item) + then + null; + + elsif not Private_Present (Item) + or else Private_Present (N) + or else Nkind (Unit (N)) = N_Package_Body then Id := Entity (Name (Item)); @@ -3792,15 +3824,26 @@ package body Sem_Ch10 is end loop; end; end if; + + -- If the item is a private with-clause on a child unit, the parent + -- may have been installed already, but the child unit must remain + -- invisible until installed in a private part or body. + + elsif Private_Present (Item) then + Id := Entity (Name (Item)); + + if Is_Child_Unit (Id) then + Set_Is_Visible_Child_Unit (Id, False); + end if; end if; Next (Item); end loop; end Install_Siblings; - ------------------------------- - -- Install_Limited_With_Unit -- - ------------------------------- + --------------------------------- + -- Install_Limited_Withed_Unit -- + --------------------------------- procedure Install_Limited_Withed_Unit (N : Node_Id) is P_Unit : constant Entity_Id := Unit (Library_Unit (N)); @@ -3810,6 +3853,14 @@ package body Sem_Ch10 is Lim_Header : Entity_Id; Lim_Typ : Entity_Id; + procedure Check_Body_Required; + -- A unit mentioned in a limited with_clause may not be mentioned in + -- a regular with_clause, but must still be included in the current + -- partition. We need to determine whether the unit needs a body, so + -- that the binder can determine the name of the file to be compiled. + -- Checking whether a unit needs a body can be done without semantic + -- analysis, by examining the nature of the declarations in the package. + function Has_Limited_With_Clause (C_Unit : Entity_Id; Pack : Entity_Id) return Boolean; @@ -3828,6 +3879,157 @@ package body Sem_Ch10 is -- Check if some package installed though normal with-clauses has a -- renaming declaration of package P. AARM 10.1.2(21/2). + ------------------------- + -- Check_Body_Required -- + ------------------------- + + -- ??? misses pragma Import on subprograms + -- ??? misses pragma Import on renamed subprograms + + procedure Check_Body_Required is + PA : constant List_Id := + Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); + + procedure Check_Declarations (Spec : Node_Id); + -- Recursive procedure that does the work and checks nested packages + + ------------------------ + -- Check_Declarations -- + ------------------------ + + procedure Check_Declarations (Spec : Node_Id) is + Decl : Node_Id; + Incomplete_Decls : constant Elist_Id := New_Elmt_List; + + begin + -- Search for Elaborate Body pragma + + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) + and then Nkind (Decl) = N_Pragma + loop + if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next (Decl); + end loop; + + -- Look for declarations that require the presence of a body + + while Present (Decl) loop + + -- Subprogram that comes from source means body required + -- This is where a test for Import is missing ??? + + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration)) + then + Set_Body_Required (Library_Unit (N)); + return; + + -- Package declaration of generic package declaration. We need + -- to recursively examine nested declarations. + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + end if; + + Next (Decl); + end loop; + + -- Same set of tests for private part. In addition to subprograms + -- detect the presence of Taft Amendment types (incomplete types + -- completed in the body). + + Decl := First (Private_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration)) + then + Set_Body_Required (Library_Unit (N)); + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + + -- Collect incomplete type declarations for separate pass + + elsif Nkind (Decl) = N_Incomplete_Type_Declaration then + Append_Elmt (Decl, Incomplete_Decls); + end if; + + Next (Decl); + end loop; + + -- Now check incomplete declarations to locate Taft amendment + -- types. This can be done by examing the defining identifiers + -- of type declarations without real semantic analysis. + + declare + Inc : Elmt_Id; + + begin + Inc := First_Elmt (Incomplete_Decls); + while Present (Inc) loop + Decl := Next (Node (Inc)); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Defining_Identifier (Node (Inc))) + then + exit; + end if; + + Next (Decl); + end loop; + + -- If no completion, this is a TAT, and a body is needed + + if No (Decl) then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next_Elmt (Inc); + end loop; + end; + end Check_Declarations; + + -- Start of processing for Check_Body_Required + + begin + -- If this is an imported package (Java and CIL usage) no body is + -- needed. Scan list of pragmas that may follow a compilation unit + -- to look for a relevant pragma Import. + + if Present (PA) then + declare + Prag : Node_Id; + + begin + Prag := First (PA); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma + and then Get_Pragma_Id (Prag) = Pragma_Import + then + return; + end if; + + Next (Prag); + end loop; + end; + end if; + + Check_Declarations (Specification (P_Unit)); + end Check_Body_Required; + ----------------------------- -- Has_Limited_With_Clause -- ----------------------------- @@ -4017,9 +4219,12 @@ package body Sem_Ch10 is -- In case of limited with_clause on subprograms, generics, instances, -- or renamings, the corresponding error was previously posted and we - -- have nothing to do here. + -- have nothing to do here. If the file is missing altogether, it has + -- no source location. - if Nkind (P_Unit) /= N_Package_Declaration then + if Nkind (P_Unit) /= N_Package_Declaration + or else Sloc (P_Unit) = No_Location + then return; end if; @@ -4105,39 +4310,11 @@ package body Sem_Ch10 is -- view of X supersedes its limited view. if Analyzed (P_Unit) - and then (Is_Immediately_Visible (P) - or else (Is_Child_Package - and then Is_Visible_Child_Unit (P))) + and then + (Is_Immediately_Visible (P) + or else + (Is_Child_Package and then Is_Visible_Child_Unit (P))) then - -- Ada 2005 (AI-262): Install the private declarations of P - - if Private_Present (N) - and then not In_Private_Part (P) - then - declare - Id : Entity_Id; - - begin - Id := First_Private_Entity (P); - while Present (Id) loop - if not Is_Internal (Id) - and then not Is_Child_Unit (Id) - then - if not In_Chain (Id) then - Set_Homonym (Id, Current_Entity (Id)); - Set_Current_Entity (Id); - end if; - - Set_Is_Immediately_Visible (Id); - end if; - - Next_Entity (Id); - end loop; - - Set_In_Private_Part (P); - end; - end if; - return; end if; @@ -4296,6 +4473,13 @@ package body Sem_Ch10 is Set_Is_Immediately_Visible (P); Set_Limited_View_Installed (N); + -- If unit has not been analyzed in some previous context, check + -- (imperfectly ???) whether it might need a body. + + if not Analyzed (P_Unit) then + Check_Body_Required; + end if; + -- If the package in the limited_with clause is a child unit, the -- clause is unanalyzed and appears as a selected component. Recast -- it as an expanded name so that the entity can be properly set. Use @@ -4674,12 +4858,24 @@ package body Sem_Ch10 is -- Build corresponding class_wide type, if not previously done - -- Warning: The class-wide entity is shared by the limited-view + -- Note: The class-wide entity is shared by the limited-view -- and the full-view. if No (Class_Wide_Type (T)) then CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + -- Set parent to be the same as the parent of the tagged type. + -- We need a parent field set, and it is supposed to point to + -- the declaration of the type. The tagged type declaration + -- essentially declares two separate types, the tagged type + -- itself and the corresponding class-wide type, so it is + -- reasonable for the parent fields to point to the declaration + -- in both cases. + + Set_Parent (CW, Parent (T)); + + -- Set remaining fields of classwide type + Set_Ekind (CW, E_Class_Wide_Type); Set_Etype (CW, T); Set_Scope (CW, Scop); @@ -4691,6 +4887,8 @@ package body Sem_Ch10 is Set_Equivalent_Type (CW, Empty); Set_From_With_Type (CW, From_With_Type (T)); + -- Link type to its class-wide type + Set_Class_Wide_Type (T, CW); end if; end Decorate_Tagged_Type; @@ -4807,12 +5005,19 @@ package body Sem_Ch10 is Set_Non_Limited_View (Lim_Typ, Comp_Typ); elsif Nkind_In (Decl, N_Private_Type_Declaration, - N_Incomplete_Type_Declaration) + N_Incomplete_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) then Comp_Typ := Defining_Identifier (Decl); + Is_Tagged := + Nkind_In (Decl, N_Private_Type_Declaration, + N_Incomplete_Type_Declaration) + and then Tagged_Present (Decl); + if not Analyzed_Unit then - if Tagged_Present (Decl) then + if Is_Tagged then Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); else Decorate_Incomplete_Type (Comp_Typ, Scope); @@ -4828,7 +5033,7 @@ package body Sem_Ch10 is Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); - if Tagged_Present (Decl) then + if Is_Tagged then Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); else Decorate_Incomplete_Type (Lim_Typ, Scope); @@ -4902,13 +5107,11 @@ package body Sem_Ch10 is begin pragma Assert (Limited_Present (N)); - -- A library_item mentioned in a limited_with_clause shall - -- be a package_declaration, not a subprogram_declaration, - -- generic_declaration, generic_instantiation, or - -- package_renaming_declaration + -- A library_item mentioned in a limited_with_clause is a package + -- declaration, not a subprogram declaration, generic declaration, + -- generic instantiation, or package renaming declaration. case Nkind (Unit (Library_Unit (N))) is - when N_Package_Declaration => null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 87e256a349d..00e471abf66 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -236,6 +236,7 @@ package body Sem_Ch3 is -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. + -- -- A related mechanism is used during expansion, for itypes created in -- branches of conditionals. See Ensure_Defined in exp_util. -- Could both mechanisms be merged ??? @@ -341,11 +342,11 @@ package body Sem_Ch3 is Constraints : Elist_Id); -- Build the list of entities for a constrained discriminated record -- subtype. If a component depends on a discriminant, replace its subtype - -- using the discriminant values in the discriminant constraint. Subt is - -- the defining identifier for the subtype whose list of constrained - -- entities we will create. Decl_Node is the type declaration node where we - -- will attach all the itypes created. Typ is the base discriminated type - -- for the subtype Subt. Constraints is the list of discriminant + -- using the discriminant values in the discriminant constraint. Subt + -- is the defining identifier for the subtype whose list of constrained + -- entities we will create. Decl_Node is the type declaration node where + -- we will attach all the itypes created. Typ is the base discriminated + -- type for the subtype Subt. Constraints is the list of discriminant -- constraints for Typ. function Constrain_Component_Type @@ -362,6 +363,7 @@ package body Sem_Ch3 is -- Constrained_Typ is the final constrained subtype to which the -- constrained Compon_Type belongs. Related_Node is the node where we will -- attach all the itypes created. + -- -- Above description is confused, what is Compon_Type??? procedure Constrain_Access @@ -504,12 +506,11 @@ package body Sem_Ch3 is (T : Entity_Id; N : Node_Id; Is_Completion : Boolean); - -- Process a derived type declaration. This routine will invoke - -- Build_Derived_Type to process the actual derived type definition. - -- Parameters N and Is_Completion have the same meaning as in - -- Build_Derived_Type. T is the N_Defining_Identifier for the entity - -- defined in the N_Full_Type_Declaration node N, that is T is the derived - -- type. + -- Process a derived type declaration. Build_Derived_Type is invoked + -- to process the actual derived type definition. Parameters N and + -- Is_Completion have the same meaning as in Build_Derived_Type. + -- T is the N_Defining_Identifier for the entity defined in the + -- N_Full_Type_Declaration node N, that is T is the derived type. procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Insert each literal in symbol table, as an overloadable identifier. Each @@ -521,7 +522,7 @@ package body Sem_Ch3 is function Expand_To_Stored_Constraint (Typ : Entity_Id; Constraint : Elist_Id) return Elist_Id; - -- Given a Constraint (i.e. a list of expressions) on the discriminants of + -- Given a constraint (i.e. a list of expressions) on the discriminants of -- Typ, expand it into a constraint on the stored discriminants and return -- the new list of expressions constraining the stored discriminants. @@ -532,7 +533,7 @@ package body Sem_Ch3 is -- implicit types generated to Related_Nod procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); - -- Create a new float, and apply the constraint to obtain subtype of it + -- Create a new float and apply the constraint to obtain subtype of it function Has_Range_Constraint (N : Node_Id) return Boolean; -- Given an N_Subtype_Indication node N, return True if a range constraint @@ -582,6 +583,14 @@ package body Sem_Ch3 is -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether type Typ implements interface Iface. This requires + -- traversing the list of abstract interfaces of the type, as well as that + -- of the ancestor types. The predicate is used to determine when a formal + -- in the signature of an inherited operation must carry the derived type. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; @@ -632,16 +641,16 @@ package body Sem_Ch3 is -- Similarly, access_to_subprogram types may have a parameter or a return -- type that is an incomplete type, and that must be replaced with the -- full type. - + -- -- If the full type is tagged, subprogram with access parameters that -- designated the incomplete may be primitive operations of the full type, -- and have to be processed accordingly. procedure Process_Real_Range_Specification (Def : Node_Id); - -- Given the type definition for a real type, this procedure processes - -- and checks the real range specification of this type definition if - -- one is present. If errors are found, error messages are posted, and - -- the Real_Range_Specification of Def is reset to Empty. + -- Given the type definition for a real type, this procedure processes and + -- checks the real range specification of this type definition if one is + -- present. If errors are found, error messages are posted, and the + -- Real_Range_Specification of Def is reset to Empty. procedure Record_Type_Declaration (T : Entity_Id; @@ -655,14 +664,14 @@ package body Sem_Ch3 is -- cross-referencing. Otherwise Prev = T. procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); - -- This routine is used to process the actual record type definition - -- (both for untagged and tagged records). Def is a record type - -- definition node. This procedure analyzes the components in this - -- record type definition. Prev_T is the entity for the enclosing record - -- type. It is provided so that its Has_Task flag can be set if any of - -- the component have Has_Task set. If the declaration is the completion - -- of an incomplete type declaration, Prev_T is the original incomplete - -- type, whose full view is the record type. + -- This routine is used to process the actual record type definition (both + -- for untagged and tagged records). Def is a record type definition node. + -- This procedure analyzes the components in this record type definition. + -- Prev_T is the entity for the enclosing record type. It is provided so + -- that its Has_Task flag can be set if any of the component have Has_Task + -- set. If the declaration is the completion of an incomplete type + -- declaration, Prev_T is the original incomplete type, whose full view is + -- the record type. procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); -- Subsidiary to Build_Derived_Record_Type. For untagged records, we @@ -809,8 +818,20 @@ package body Sem_Ch3 is Set_Directly_Designated_Type (Anon_Type, Desig_Type); Set_Etype (Anon_Type, Anon_Type); - Init_Size_Align (Anon_Type); + + -- Make sure the anonymous access type has size and alignment fields + -- set, as required by gigi. This is necessary in the case of the + -- Task_Body_Procedure. + + if not Has_Private_Component (Desig_Type) then + Layout_Type (Anon_Type); + end if; + + -- ???The following makes no sense, because Anon_Type is an access type + -- and therefore cannot have components, private or otherwise. Hence + -- the assertion. Not sure what was meant, here. Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); + pragma Assert (not Depends_On_Private (Anon_Type)); -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if @@ -1232,6 +1253,13 @@ package body Sem_Ch3 is Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); + -- Initialize Associated_Final_Chain explicitly to Empty, to avoid + -- problems where an incomplete view of this entity has been previously + -- established by a limited with and an overlaid version of this field + -- (Stored_Constraint) was initialized for the incomplete view. + + Set_Associated_Final_Chain (T, Empty); + -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant -- attributes @@ -1619,7 +1647,7 @@ package body Sem_Ch3 is -- package Sem). if Present (E) then - Analyze_Per_Use_Expression (E, T); + Preanalyze_Spec_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_05 @@ -2011,6 +2039,17 @@ package body Sem_Ch3 is Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); Set_Is_Task_Interface (CW, Is_Task_Interface (T)); end if; + + -- Check runtime support for synchronized interfaces + + if VM_Target = No_VM + and then (Is_Task_Interface (T) + or else Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T)) + and then not RTE_Available (RE_Select_Specific_Data) + then + Error_Msg_CRT ("synchronized interfaces", T); + end if; end Analyze_Interface_Declaration; ----------------------------- @@ -2178,11 +2217,11 @@ package body Sem_Ch3 is Prev_Entity : Entity_Id := Empty; function Count_Tasks (T : Entity_Id) return Uint; - -- This function is called when a library level object of type is - -- declared. It's function is to count the static number of tasks - -- declared within the type (it is only called if Has_Tasks is set for - -- T). As a side effect, if an array of tasks with non-static bounds or - -- a variant record type is encountered, Check_Restrictions is called + -- This function is called when a non-generic library level object of a + -- task type is declared. Its function is to count the static number of + -- tasks declared within the type (it is only called if Has_Tasks is set + -- for T). As a side effect, if an array of tasks with non-static bounds + -- or a variant record type is encountered, Check_Restrictions is called -- indicating the count is unknown. ----------------- @@ -2259,12 +2298,23 @@ package body Sem_Ch3 is if Constant_Present (N) then Prev_Entity := Current_Entity_In_Scope (Id); - -- If homograph is an implicit subprogram, it is overridden by the - -- current declaration. + -- If the homograph is an implicit subprogram, it is overridden by + -- the current declaration. if Present (Prev_Entity) - and then Is_Overloadable (Prev_Entity) - and then Is_Inherited_Operation (Prev_Entity) + and then + ((Is_Overloadable (Prev_Entity) + and then Is_Inherited_Operation (Prev_Entity)) + + -- The current object is a discriminal generated for an entry + -- family index. Even though the index is a constant, in this + -- particular context there is no true contant redeclaration. + -- Enter_Name will handle the visibility. + + or else + (Is_Discriminal (Id) + and then Ekind (Discriminal_Link (Id)) = + E_Entry_Index_Parameter)) then Prev_Entity := Empty; end if; @@ -2425,6 +2475,19 @@ package body Sem_Ch3 is -- Process initialization expression if present and not in error if Present (E) and then E /= Error then + + -- Generate an error in case of CPP class-wide object initialization. + -- Required because otherwise the expansion of the class-wide + -- assignment would try to use 'size to initialize the object + -- (primitive that is not available in CPP tagged types). + + if Is_Class_Wide_Type (Act_T) + and then Convention (Act_T) = Convention_CPP + then + Error_Msg_N + ("predefined assignment not available in CPP tagged types", E); + end if; + Mark_Coextensions (N, E); Analyze (E); @@ -2441,6 +2504,18 @@ package body Sem_Ch3 is Set_Is_True_Constant (Id, True); + -- If we are analyzing a constant declaration, set its completion + -- flag after analyzing and resolving the expression. + + if Constant_Present (N) then + Set_Has_Completion (Id); + end if; + + -- Set type and resolve (type may be overridden later on) + + Set_Etype (Id, T); + Resolve (E, T); + -- If the object is an access to variable, the initialization -- expression cannot be an access to constant. @@ -2454,16 +2529,6 @@ package body Sem_Ch3 is "with an access-to-constant expression", E); end if; - -- If we are analyzing a constant declaration, set its completion - -- flag after analyzing the expression. - - if Constant_Present (N) then - Set_Has_Completion (Id); - end if; - - Set_Etype (Id, T); -- may be overridden later on - Resolve (E, T); - if not Assignment_OK (N) then Check_Initialization (T, E); end if; @@ -2556,6 +2621,21 @@ package body Sem_Ch3 is Error_Msg_N ("unconstrained subtype not allowed (need initialization)", Object_Definition (N)); + + if Is_Record_Type (T) and then Has_Discriminants (T) then + Error_Msg_N + ("\provide initial value or explicit discriminant values", + Object_Definition (N)); + + Error_Msg_NE + ("\or give default discriminant values for type&", + Object_Definition (N), T); + + elsif Is_Array_Type (T) then + Error_Msg_N + ("\provide initial value or explicit array bounds", + Object_Definition (N)); + end if; end if; -- Case of initialization present but in error. Set initial @@ -2685,7 +2765,10 @@ package body Sem_Ch3 is Remove_Side_Effects (E); end if; - if T = Standard_Wide_Character or else T = Standard_Wide_Wide_Character + -- Check No_Wide_Characters restriction + + if T = Standard_Wide_Character + or else T = Standard_Wide_Wide_Character or else Root_Type (T) = Standard_Wide_String or else Root_Type (T) = Standard_Wide_Wide_String then @@ -2730,10 +2813,11 @@ package body Sem_Ch3 is end if; end if; - -- Initialize alignment and size + -- Initialize alignment and size and capture alignment setting - Init_Alignment (Id); - Init_Esize (Id); + Init_Alignment (Id); + Init_Esize (Id); + Set_Optimize_Alignment_Flags (Id); -- Deal with aliased case @@ -2853,8 +2937,22 @@ package body Sem_Ch3 is if Has_Task (Etype (Id)) then Check_Restriction (No_Tasking, N); - if Is_Library_Level_Entity (Id) then + -- Deal with counting max tasks + + -- Nothing to do if inside a generic + + if Inside_A_Generic then + null; + + -- If library level entity, then count tasks + + elsif Is_Library_Level_Entity (Id) then Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); + + -- If not library level entity, then indicate we don't know max + -- tasks and also check task hierarchy restriction and blocking + -- operation (since starting a task is definitely blocking!) + else Check_Restriction (Max_Tasks, N); Check_Restriction (No_Task_Hierarchy, N); @@ -2980,18 +3078,6 @@ package body Sem_Ch3 is null; end Analyze_Others_Choice; - -------------------------------- - -- Analyze_Per_Use_Expression -- - -------------------------------- - - procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expression : constant Boolean := In_Default_Expression; - begin - In_Default_Expression := True; - Pre_Analyze_And_Resolve (N, T); - In_Default_Expression := Save_In_Default_Expression; - end Analyze_Per_Use_Expression; - ------------------------------------------- -- Analyze_Private_Extension_Declaration -- ------------------------------------------- @@ -3383,7 +3469,8 @@ package body Sem_Ch3 is Set_Stored_Constraint_From_Discriminant_Constraint (Id); -- This would seem semantically correct, but apparently - -- confuses the back-end (4412-009). To be explained ??? + -- confuses the back-end. To be explained and checked with + -- current version ??? -- Set_Has_Discriminants (Id); end if; @@ -3575,6 +3662,7 @@ package body Sem_Ch3 is end if; end if; + Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); end Analyze_Subtype_Declaration; @@ -3886,6 +3974,7 @@ package body Sem_Ch3 is Set_Is_Descendent_Of_Address (Prev); end if; + Set_Optimize_Alignment_Flags (Def_Id); Check_Eliminated (Def_Id); end Analyze_Type_Declaration; @@ -3938,7 +4027,7 @@ package body Sem_Ch3 is end if; end Process_Declarations; - -- Variables local to Analyze_Case_Statement + -- Local Variables Discr_Name : Node_Id; Discr_Type : Entity_Id; @@ -3960,13 +4049,15 @@ package body Sem_Ch3 is Discr_Name := Name (N); Analyze (Discr_Name); - if Etype (Discr_Name) = Any_Type then - - -- Prevent cascaded errors + -- If Discr_Name bad, get out (prevent cascaded errors) + if Etype (Discr_Name) = Any_Type then return; + end if; - elsif Ekind (Entity (Discr_Name)) /= E_Discriminant then + -- Check invalid discriminant in variant part + + if Ekind (Entity (Discr_Name)) /= E_Discriminant then Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); end if; @@ -4136,7 +4227,6 @@ package body Sem_Ch3 is Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); - Init_Size_Align (Implicit_Base); Set_Etype (Implicit_Base, Implicit_Base); Set_Scope (Implicit_Base, Current_Scope); Set_Has_Delayed_Freeze (Implicit_Base); @@ -4281,7 +4371,6 @@ package body Sem_Ch3 is ("the type of a component cannot be abstract", Subtype_Indication (Component_Def)); end if; - end Array_Type_Declaration; ------------------------------------------------------ @@ -4624,9 +4713,13 @@ package body Sem_Ch3 is begin Set_Stored_Constraint (Derived_Type, No_Elist); + -- Copy Storage_Size and Relative_Deadline variables if task case + if Is_Task_Type (Parent_Type) then Set_Storage_Size_Variable (Derived_Type, Storage_Size_Variable (Parent_Type)); + Set_Relative_Deadline_Variable (Derived_Type, + Relative_Deadline_Variable (Parent_Type)); end if; if Present (Discriminant_Specifications (N)) then @@ -4795,10 +4888,7 @@ package body Sem_Ch3 is -- and we construct the same skeletal representation as for the generic -- parent type. - if Root_Type (Parent_Type) = Standard_Character - or else Root_Type (Parent_Type) = Standard_Wide_Character - or else Root_Type (Parent_Type) = Standard_Wide_Wide_Character - then + if Is_Standard_Character_Type (Parent_Type) then Derived_Standard_Character (N, Parent_Type, Derived_Type); elsif Is_Generic_Type (Root_Type (Parent_Type)) then @@ -5232,9 +5322,7 @@ package body Sem_Ch3 is if Ekind (Parent_Type) in Record_Kind or else (Ekind (Parent_Type) in Enumeration_Kind - and then Root_Type (Parent_Type) /= Standard_Character - and then Root_Type (Parent_Type) /= Standard_Wide_Character - and then Root_Type (Parent_Type) /= Standard_Wide_Wide_Character + and then not Is_Standard_Character_Type (Parent_Type) and then not Is_Generic_Type (Root_Type (Parent_Type))) then Full_N := New_Copy_Tree (N); @@ -6463,7 +6551,10 @@ package body Sem_Ch3 is if Limited_Present (Type_Def) then Set_Is_Limited_Record (Derived_Type); - elsif Is_Limited_Record (Parent_Type) then + elsif Is_Limited_Record (Parent_Type) + or else (Present (Full_View (Parent_Type)) + and then Is_Limited_Record (Full_View (Parent_Type))) + then if not Is_Interface (Parent_Type) or else Is_Synchronized_Interface (Parent_Type) or else Is_Protected_Interface (Parent_Type) @@ -8031,16 +8122,17 @@ package body Sem_Ch3 is and then Present (Alias (Subp)) and then not Comes_From_Source (Subp) and then not Is_Abstract_Subprogram (Alias (Subp)) + and then not Is_Access_Type (Etype (Subp)) then null; elsif (Is_Abstract_Subprogram (Subp) - or else Requires_Overriding (Subp) - or else - (Has_Controlling_Result (Subp) - and then Present (Alias_Subp) - and then not Comes_From_Source (Subp) - and then Sloc (Subp) = Sloc (First_Subtype (T)))) + or else Requires_Overriding (Subp) + or else + (Has_Controlling_Result (Subp) + and then Present (Alias_Subp) + and then not Comes_From_Source (Subp) + and then Sloc (Subp) = Sloc (First_Subtype (T)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) @@ -8061,10 +8153,10 @@ package body Sem_Ch3 is if Present (Alias_Subp) then -- Only perform the check for a derived subprogram when the - -- type has an explicit record extension. This avoids - -- incorrectly flagging abstract subprograms for the case of a - -- type without an extension derived from a formal type with a - -- tagged actual (can occur within a private part). + -- type has an explicit record extension. This avoids incorect + -- flagging of abstract subprograms for the case of a type + -- without an extension that is derived from a formal type + -- with a tagged actual (can occur within a private part). -- Ada 2005 (AI-391): In the case of an inherited function with -- a controlling result of the type, the rule does not apply if @@ -9049,6 +9141,12 @@ package body Sem_Ch3 is and then (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type + or else Is_Access_Constant (Etype (New_T)) /= + Is_Access_Constant (Etype (Prev)) + or else Can_Never_Be_Null (Etype (New_T)) /= + Can_Never_Be_Null (Etype (Prev)) + or else Null_Exclusion_Present (Parent (Prev)) /= + Null_Exclusion_Present (Parent (Id)) or else not Subtypes_Statically_Match (Designated_Type (Etype (Prev)), Designated_Type (Etype (New_T)))) @@ -9058,6 +9156,15 @@ package body Sem_Ch3 is Set_Full_View (Prev, Id); Set_Etype (Id, Any_Type); + elsif + Null_Exclusion_Present (Parent (Prev)) + and then not Null_Exclusion_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("null-exclusion does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); + -- If so, process the full constant declaration else @@ -9922,7 +10029,6 @@ package body Sem_Ch3 is begin Set_Etype (T_Sub, Corr_Rec); - Init_Size_Align (T_Sub); Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); Set_Is_Constrained (T_Sub, True); Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); @@ -11120,12 +11226,12 @@ package body Sem_Ch3 is Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); - -- Set size to zero for now, size will be set at freeze time. We have - -- to do this for ordinary fixed-point, because the size depends on - -- the specified small, and we might as well do the same for decimal - -- fixed-point. + -- Note: We leave size as zero for now, size will be set at freeze + -- time. We have to do this for ordinary fixed-point, because the size + -- depends on the specified small, and we might as well do the same for + -- decimal fixed-point. - Init_Size_Align (Implicit_Base); + pragma Assert (Esize (Implicit_Base) = Uint_0); -- If there are bounds given in the declaration use them as the -- bounds of the first named subtype. @@ -11224,7 +11330,6 @@ package body Sem_Ch3 is Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Elmt := First_Elmt (Primitive_Operations (Node (Iface_Elmt))); - while Present (Elmt) loop Prim := Node (Elmt); @@ -11247,6 +11352,7 @@ package body Sem_Ch3 is function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is Elmt : Elmt_Id; + begin Elmt := First_Elmt (L); while Present (Elmt) loop @@ -11410,19 +11516,28 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Actual_Subp : Entity_Id := Empty) is - Formal : Entity_Id; - New_Formal : Entity_Id; + Formal : Entity_Id; + -- Formal parameter of parent primitive operation + + Formal_Of_Actual : Entity_Id; + -- Formal parameter of actual operation, when the derivation is to + -- create a renaming for a primitive operation of an actual in an + -- instantiation. + + New_Formal : Entity_Id; + -- Formal of inherited operation + Visible_Subp : Entity_Id := Parent_Subp; function Is_Private_Overriding return Boolean; - -- If Subp is a private overriding of a visible operation, the in- - -- herited operation derives from the overridden op (even though - -- its body is the overriding one) and the inherited operation is - -- visible now. See sem_disp to see the details of the handling of - -- the overridden subprogram, which is removed from the list of - -- primitive operations of the type. The overridden subprogram is - -- saved locally in Visible_Subp, and used to diagnose abstract - -- operations that need overriding in the derived type. + -- If Subp is a private overriding of a visible operation, the inherited + -- operation derives from the overridden op (even though its body is the + -- overriding one) and the inherited operation is visible now. See + -- sem_disp to see the full details of the handling of the overridden + -- subprogram, which is removed from the list of primitive operations of + -- the type. The overridden subprogram is saved locally in Visible_Subp, + -- and used to diagnose abstract operations that need overriding in the + -- derived type. procedure Replace_Type (Id, New_Id : Entity_Id); -- When the type is an anonymous access type, create a new access type @@ -11583,6 +11698,7 @@ package body Sem_Ch3 is elsif Is_Interface (Etype (Id)) and then not Is_Class_Wide_Type (Etype (Id)) + and then Is_Progenitor (Etype (Id), Derived_Type) then Set_Etype (New_Id, Derived_Type); @@ -11671,10 +11787,29 @@ package body Sem_Ch3 is end if; Set_Parent (New_Subp, Parent (Derived_Type)); - Replace_Type (Parent_Subp, New_Subp); + + if Present (Actual_Subp) then + Replace_Type (Actual_Subp, New_Subp); + else + Replace_Type (Parent_Subp, New_Subp); + end if; + Conditional_Delay (New_Subp, Parent_Subp); + -- If we are creating a renaming for a primitive operation of an + -- actual of a generic derived type, we must examine the signature + -- of the actual primive, not that of the generic formal, which for + -- example may be an interface. However the name and initial value + -- of the inherited operation are those of the formal primitive. + Formal := First_Formal (Parent_Subp); + + if Present (Actual_Subp) then + Formal_Of_Actual := First_Formal (Actual_Subp); + else + Formal_Of_Actual := Empty; + end if; + while Present (Formal) loop New_Formal := New_Copy (Formal); @@ -11684,19 +11819,24 @@ package body Sem_Ch3 is -- original formal's parameter specification in this case. Set_Parent (New_Formal, Parent (Formal)); - Append_Entity (New_Formal, New_Subp); - Replace_Type (Formal, New_Formal); + if Present (Formal_Of_Actual) then + Replace_Type (Formal_Of_Actual, New_Formal); + Next_Formal (Formal_Of_Actual); + else + Replace_Type (Formal, New_Formal); + end if; + Next_Formal (Formal); end loop; -- If this derivation corresponds to a tagged generic actual, then -- primitive operations rename those of the actual. Otherwise the - -- primitive operations rename those of the parent type, If the - -- parent renames an intrinsic operator, so does the new subprogram. - -- We except concatenation, which is always properly typed, and does - -- not get expanded as other intrinsic operations. + -- primitive operations rename those of the parent type, If the parent + -- renames an intrinsic operator, so does the new subprogram. We except + -- concatenation, which is always properly typed, and does not get + -- expanded as other intrinsic operations. if No (Actual_Subp) then if Is_Intrinsic_Subprogram (Parent_Subp) then @@ -11786,10 +11926,10 @@ package body Sem_Ch3 is Set_Is_Abstract_Subprogram (New_Subp); -- Finally, if the parent type is abstract we must verify that all - -- inherited operations are either non-abstract or overridden, or - -- that the derived type itself is abstract (this check is performed - -- at the end of a package declaration, in Check_Abstract_Overriding). - -- A private overriding in the parent type will not be visible in the + -- inherited operations are either non-abstract or overridden, or that + -- the derived type itself is abstract (this check is performed at the + -- end of a package declaration, in Check_Abstract_Overriding). A + -- private overriding in the parent type will not be visible in the -- derivation if we are not in an inner package or in a child unit of -- the parent type, in which case the abstractness of the inherited -- operation is carried to the new subprogram. @@ -13066,6 +13206,8 @@ package body Sem_Ch3 is Typ := Entity (S); end if; + -- Check No_Wide_Characters restriction + if Typ = Standard_Wide_Character or else Typ = Standard_Wide_Wide_Character or else Typ = Standard_Wide_String @@ -13407,6 +13549,8 @@ package body Sem_Ch3 is return Result; end Search_Derivation_Levels; + -- Local Variables + Result : Node_Or_Entity_Id; -- Start of processing for Get_Discriminant_Value @@ -13816,6 +13960,58 @@ package body Sem_Ch3 is end if; end Is_Null_Extension; + -------------------- + -- Is_Progenitor -- + -------------------- + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + I_Name : Entity_Id; + + begin + if No (Abstract_Interfaces (Typ)) then + return False; + + else + Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + while Present (Iface_Elmt) loop + I_Name := Node (Iface_Elmt); + if Base_Type (I_Name) = Base_Type (Iface) then + return True; + + elsif Is_Derived_Type (I_Name) + and then Is_Ancestor (Iface, I_Name) + then + return True; + + else + Next_Elmt (Iface_Elmt); + end if; + end loop; + + -- For concurrent record types, they have the interfaces of the + -- parent synchronized type. However these have no ancestors that + -- implement anything, so assume it is a progenitor. + -- Should be cleaned up in Collect_Abstract_Interfaces??? + + if Is_Concurrent_Record_Type (Typ) then + return Present (Abstract_Interfaces (Typ)); + end if; + + -- If type is a derived type, check recursively its ancestors + + if Is_Derived_Type (Typ) then + return Etype (Typ) = Iface + or else Is_Progenitor (Iface, Etype (Typ)); + else + return False; + end if; + end if; + end Is_Progenitor; + ------------------------------ -- Is_Valid_Constraint_Kind -- ------------------------------ @@ -14006,8 +14202,6 @@ package body Sem_Ch3 is Ancestor := Etype (Ancestor); end loop; - - return True; end; end if; end Is_Visible_Component; @@ -14059,7 +14253,6 @@ package body Sem_Ch3 is Set_Is_Abstract_Type (CW_Type, False); Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); - Init_Size_Align (CW_Type); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); @@ -14548,7 +14741,6 @@ package body Sem_Ch3 is function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is begin - -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in -- case of limited aggregates (including extension aggregates), and -- function calls. The function call may have been give in prefixed @@ -14697,8 +14889,6 @@ package body Sem_Ch3 is Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); Set_Fixed_Range (T, Loc, Low_Val, High_Val); - Init_Size_Align (Implicit_Base); - -- Complete definition of first subtype Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); @@ -14850,7 +15040,7 @@ package body Sem_Ch3 is -- Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then - Analyze_Per_Use_Expression (Expression (Discr), Discr_Type); + Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); if Nkind (N) = N_Formal_Type_Declaration then Error_Msg_N @@ -14915,7 +15105,11 @@ package body Sem_Ch3 is end if; -- Ada 2005 (AI-402): access discriminants of nonlimited types - -- can't have defaults + -- can't have defaults. Synchronized types, or types that are + -- explicitly limited are fine, but special tests apply to derived + -- types in generics: in a generic body we have to assume the + -- worst, and therefore defaults are not allowed if the parent is + -- a generic formal private type (see ACATS B370001). if Is_Access_Type (Discr_Type) then if Ekind (Discr_Type) /= E_Anonymous_Access_Type @@ -14925,7 +15119,19 @@ package body Sem_Ch3 is or else Is_Concurrent_Record_Type (Current_Scope) or else Ekind (Current_Scope) = E_Limited_Private_Type then - null; + if not Is_Derived_Type (Current_Scope) + or else not Is_Generic_Type (Etype (Current_Scope)) + or else not In_Package_Body (Scope (Etype (Current_Scope))) + or else Limited_Present + (Type_Definition (Parent (Current_Scope))) + then + null; + + else + Error_Msg_N ("access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; elsif Present (Expression (Discr)) then Error_Msg_N @@ -16290,8 +16496,8 @@ package body Sem_Ch3 is return; else - Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); - Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); -- Type has already been inserted into the current scope. -- Remove it, and add incomplete declaration for type, so @@ -16589,6 +16795,18 @@ package body Sem_Ch3 is end if; end Check_Anonymous_Access_Components; + -------------------------------- + -- Preanalyze_Spec_Expression -- + -------------------------------- + + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Spec_Expression; + ----------------------------- -- Record_Type_Declaration -- ----------------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 3afb0a2b2ab..0dff777a654 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -71,14 +71,6 @@ package Sem_Ch3 is procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id); -- Analyze an interface declaration or a formal interface declaration - procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id); - -- Default and per object expressions do not freeze their components, - -- and must be analyzed and resolved accordingly. The analysis is - -- done by calling the Pre_Analyze_And_Resolve routine and setting - -- the global In_Default_Expression flag. See the documentation section - -- entitled "Handling of Default and Per-Object Expressions" in sem.ads - -- for details. N is the expression to be analyzed, T is the expected type. - procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id); -- Process an array type declaration. If the array is constrained, we -- create an implicit parent array type, with the same index types and @@ -204,6 +196,14 @@ package Sem_Ch3 is -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); + -- Default and per object expressions do not freeze their components, and + -- must be analyzed and resolved accordingly. The analysis is done by + -- calling the Preanalyze_And_Resolve routine and setting the global + -- In_Default_Expression flag. See the documentation section entitled + -- "Handling of Default and Per-Object Expressions" in sem.ads for full + -- details. N is the expression to be analyzed, T is the expected type. + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c36805838e6..54925d7b600 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -205,8 +205,10 @@ package body Sem_Util is Rep : Boolean := True; Warn : Boolean := False) is - Stat : constant Boolean := Is_Static_Expression (N); - Rtyp : Entity_Id; + Stat : constant Boolean := Is_Static_Expression (N); + R_Stat : constant Node_Id := + Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); + Rtyp : Entity_Id; begin if No (Typ) then @@ -225,10 +227,9 @@ package body Sem_Util is -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. - Rewrite (N, - Make_Raise_Constraint_Error (Sloc (N), - Reason => Reason)); + Rewrite (N, R_Stat); Set_Analyzed (N, True); + Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); @@ -486,9 +487,13 @@ package body Sem_Util is -- Start of processing for Build_Actual_Subtype_Of_Component begin - if In_Default_Expression then + -- Why the test for Spec_Expression mode here??? + + if In_Spec_Expression then return Empty; + -- More commments for the rest of this body would be good ??? + elsif Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) @@ -1010,11 +1015,12 @@ package body Sem_Util is ("premature usage of incomplete}", N, First_Subtype (T)); end if; + -- Need comments for these tests ??? + elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) - and then not In_Default_Expression + and then not In_Spec_Expression then - -- Special case: if T is the anonymous type created for a single -- task or protected object, use the name of the source object. @@ -1045,6 +1051,8 @@ package body Sem_Util is -- Currently only enabled for VM back-ends for efficiency, should we -- enable it more systematically ??? + -- Check for Is_Imported needs commenting below ??? + if VM_Target /= No_VM and then (Ekind (Ent) = E_Variable or else @@ -1053,6 +1061,7 @@ package body Sem_Util is Ekind (Ent) = E_Loop_Parameter) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) + and then not Is_Imported (Ent) then if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) @@ -1103,6 +1112,117 @@ package body Sem_Util is end loop; end Check_Potentially_Blocking_Operation; + ------------------------------ + -- Check_Unprotected_Access -- + ------------------------------ + + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id) + is + Cont_Encl_Typ : Entity_Id; + Pref_Encl_Typ : Entity_Id; + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; + -- Check whether Obj is a private component of a protected object. + -- Return the protected type where the component resides, Empty + -- otherwise. + + function Is_Public_Operation return Boolean; + -- Verify that the enclosing operation is callable from outside the + -- protected object, to minimize false positives. + + ------------------------------ + -- Enclosing_Protected_Type -- + ------------------------------ + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is + begin + if Is_Entity_Name (Obj) then + declare + Ent : Entity_Id := Entity (Obj); + + begin + -- The object can be a renaming of a private component, use + -- the original record component. + + if Is_Prival (Ent) then + Ent := Prival_Link (Ent); + end if; + + if Is_Protected_Type (Scope (Ent)) then + return Scope (Ent); + end if; + end; + end if; + + -- For indexed and selected components, recursively check the prefix + + if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + return Enclosing_Protected_Type (Prefix (Obj)); + + -- The object does not denote a protected component + + else + return Empty; + end if; + end Enclosing_Protected_Type; + + ------------------------- + -- Is_Public_Operation -- + ------------------------- + + function Is_Public_Operation return Boolean is + S : Entity_Id; + E : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Pref_Encl_Typ + loop + if Scope (S) = Pref_Encl_Typ then + E := First_Entity (Pref_Encl_Typ); + while Present (E) + and then E /= First_Private_Entity (Pref_Encl_Typ) + loop + if E = S then + return True; + end if; + Next_Entity (E); + end loop; + end if; + + S := Scope (S); + end loop; + + return False; + end Is_Public_Operation; + + -- Start of processing for Check_Unprotected_Access + + begin + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Unchecked_Access + then + Cont_Encl_Typ := Enclosing_Protected_Type (Context); + Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); + + -- Check whether we are trying to export a protected component to a + -- context with an equal or lower access level. + + if Present (Pref_Encl_Typ) + and then No (Cont_Encl_Typ) + and then Is_Public_Operation + and then Scope_Depth (Pref_Encl_Typ) >= + Object_Access_Level (Context) + then + Error_Msg_N + ("?possible unprotected access to protected data", Expr); + end if; + end if; + end Check_Unprotected_Access; + --------------- -- Check_VMS -- --------------- @@ -1772,6 +1892,42 @@ package body Sem_Util is end if; end Conditional_Delay; + ------------------------- + -- Copy_Parameter_List -- + ------------------------- + + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Subp_Id); + Plist : List_Id; + Formal : Entity_Id; + + begin + if No (First_Formal (Subp_Id)) then + return No_List; + else + Plist := New_List; + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Append + (Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Plist); + + Next_Formal (Formal); + end loop; + end if; + + return Plist; + end Copy_Parameter_List; + -------------------- -- Current_Entity -- -------------------- @@ -2259,26 +2415,6 @@ package body Sem_Util is E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; - function Is_Private_Component_Renaming (N : Node_Id) return Boolean; - -- Recognize a renaming declaration that is introduced for private - -- components of a protected type. We treat these as weak declarations - -- so that they are overridden by entities with the same name that - -- come from source, such as formals or local variables of a given - -- protected declaration. - - ----------------------------------- - -- Is_Private_Component_Renaming -- - ----------------------------------- - - function Is_Private_Component_Renaming (N : Node_Id) return Boolean is - begin - return not Comes_From_Source (N) - and then not Comes_From_Source (Current_Scope) - and then Nkind (N) = N_Object_Renaming_Declaration; - end Is_Private_Component_Renaming; - - -- Start of processing for Enter_Name - begin Generate_Definition (Def_Id); @@ -2402,7 +2538,29 @@ package body Sem_Util is then return; - elsif Is_Private_Component_Renaming (Parent (Def_Id)) then + -- If the homograph is a protected component renaming, it should not + -- be hiding the current entity. Such renamings are treated as weak + -- declarations. + + elsif Is_Prival (E) then + Set_Is_Immediately_Visible (E, False); + + -- In this case the current entity is a protected component renaming. + -- Perform minimal decoration by setting the scope and return since + -- the prival should not be hiding other visible entities. + + elsif Is_Prival (Def_Id) then + Set_Scope (Def_Id, Current_Scope); + return; + + -- Analogous to privals, the discriminal generated for an entry + -- index parameter acts as a weak declaration. Perform minimal + -- decoration to avoid bogus errors. + + elsif Is_Discriminal (Def_Id) + and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter + then + Set_Scope (Def_Id, Current_Scope); return; -- In the body or private part of an instance, a type extension @@ -2411,7 +2569,7 @@ package body Sem_Util is -- of the full type with two components of the same name are not -- clear at this point ??? - elsif In_Instance_Not_Visible then + elsif In_Instance_Not_Visible then null; -- When compiling a package body, some child units may have become @@ -2446,21 +2604,19 @@ package body Sem_Util is and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration then Error_Msg_N - ("incomplete type cannot be completed" & - " with a private declaration", - Parent (Def_Id)); + ("incomplete type cannot be completed with a private " & + "declaration", Parent (Def_Id)); Set_Is_Immediately_Visible (E, False); Set_Full_View (E, Def_Id); + -- An inherited component of a record conflicts with a new + -- discriminant. The discriminant is inserted first in the scope, + -- but the error should be posted on it, not on the component. + elsif Ekind (E) = E_Discriminant and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then - -- An inherited component of a record conflicts with - -- a new discriminant. The discriminant is inserted first - -- in the scope, but the error should be posted on it, not - -- on the component. - Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_N ("& conflicts with declaration#", E); return; @@ -2490,8 +2646,8 @@ package body Sem_Util is end if; end if; - if Nkind (Parent (Parent (Def_Id))) - = N_Generic_Subprogram_Declaration + if Nkind (Parent (Parent (Def_Id))) = + N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then @@ -2922,7 +3078,14 @@ package body Sem_Util is begin Iface_Param := First (Iface_Params); - Iface_Typ := Find_Parameter_Type (Iface_Param); + + if Nkind (Parameter_Type (Iface_Param)) = N_Access_Definition then + Iface_Typ := + Designated_Type (Etype (Defining_Identifier (Iface_Param))); + else + Iface_Typ := Etype (Defining_Identifier (Iface_Param)); + end if; + Prim_Param := First (Prim_Params); -- The first parameter of the potentially overriden subprogram @@ -3126,8 +3289,12 @@ package body Sem_Util is if Nkind (Param) /= N_Parameter_Specification then return Empty; + -- For an access parameter, obtain the type from the formal entity + -- itself, because access to subprogram nodes do not carry a type. + -- Shouldn't we always use the formal entity ??? + elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then - return Etype (Subtype_Mark (Parameter_Type (Param))); + return Etype (Defining_Identifier (Param)); else return Etype (Parameter_Type (Param)); @@ -3293,7 +3460,7 @@ package body Sem_Util is begin Res := Internal_Full_Qualified_Name (E); - Store_String_Char (Get_Char_Code (ASCII.nul)); + Store_String_Char (Get_Char_Code (ASCII.NUL)); return End_String; end Full_Qualified_Name; @@ -3541,9 +3708,9 @@ package body Sem_Util is and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then - -- Nothing to do if in default expression + -- Nothing to do if in spec expression (why not???) - if In_Default_Expression then + if In_Spec_Expression then return Typ; elsif Is_Private_Type (Typ) @@ -3661,10 +3828,7 @@ package body Sem_Util is -- literals to search. Instead, an N_Character_Literal node is created -- with the appropriate Char_Code and Chars fields. - if Root_Type (T) = Standard_Character - or else Root_Type (T) = Standard_Wide_Character - or else Root_Type (T) = Standard_Wide_Wide_Character - then + if Is_Standard_Character_Type (T) then Set_Character_Literal_Name (UI_To_CC (Pos)); return Make_Character_Literal (Loc, @@ -3902,7 +4066,7 @@ package body Sem_Util is function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is begin -- Note: A task type may be the completion of a private type with - -- discriminants. when performing elaboration checks on a task + -- discriminants. When performing elaboration checks on a task -- declaration, the current view of the type may be the private one, -- and the procedure that holds the body of the task is held in its -- underlying type. @@ -4018,9 +4182,17 @@ package body Sem_Util is Comp : Entity_Id; begin + -- Loop to Check components + Comp := First_Component_Or_Discriminant (Typ); while Present (Comp) loop - if Has_Access_Values (Etype (Comp)) then + + -- Check for access component, tag field does not count, even + -- though it is implemented internally using an access type. + + if Has_Access_Values (Etype (Comp)) + and then Chars (Comp) /= Name_uTag + then return True; end if; @@ -4526,6 +4698,59 @@ package body Sem_Util is end if; end Has_Null_Extension; + ------------------------------- + -- Has_Overriding_Initialize -- + ------------------------------- + + function Has_Overriding_Initialize (T : Entity_Id) return Boolean is + BT : constant Entity_Id := Base_Type (T); + Comp : Entity_Id; + P : Elmt_Id; + + begin + if Is_Controlled (BT) then + + -- For derived types, check immediate ancestor, excluding + -- Controlled itself. + + if Is_Derived_Type (BT) + and then not In_Predefined_Unit (Etype (BT)) + and then Has_Overriding_Initialize (Etype (BT)) + then + return True; + + elsif Present (Primitive_Operations (BT)) then + P := First_Elmt (Primitive_Operations (BT)); + while Present (P) loop + if Chars (Node (P)) = Name_Initialize + and then Comes_From_Source (Node (P)) + then + return True; + end if; + + Next_Elmt (P); + end loop; + end if; + + return False; + + elsif Has_Controlled_Component (BT) then + Comp := First_Component (BT); + while Present (Comp) loop + if Has_Overriding_Initialize (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Overriding_Initialize; + -------------------------------------- -- Has_Preelaborable_Initialization -- -------------------------------------- @@ -4810,24 +5035,9 @@ package body Sem_Util is if Has_PE and then Is_Controlled (E) - and then Present (Primitive_Operations (E)) + and then Has_Overriding_Initialize (E) then - declare - P : Elmt_Id; - - begin - P := First_Elmt (Primitive_Operations (E)); - while Present (P) loop - if Chars (Node (P)) = Name_Initialize - and then Comes_From_Source (Node (P)) - then - Has_PE := False; - exit; - end if; - - Next_Elmt (P); - end loop; - end; + Has_PE := False; end if; -- Record type has PI if it is non private and all components have PI @@ -5757,8 +5967,6 @@ package body Sem_Util is T := Base_Type (Etyp); end loop; end if; - - raise Program_Error; end Is_Descendent_Of; -------------- @@ -5920,13 +6128,13 @@ package body Sem_Util is or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) - -- Special VM case for uTag component, which needs to be - -- defined in this case, but is never initialized as VMs + -- Special VM case for tag components, which need to be + -- defined in this case, but are never initialized as VMs -- are using other dispatching mechanisms. Ignore this - -- uninitialized case. + -- uninitialized case. Note that this applies both to the + -- uTag entry and the main vtable pointer (CPP_Class case). - and then (VM_Target = No_VM - or else Chars (Ent) /= Name_uTag) + and then (VM_Target = No_VM or else not Is_Tag (Ent)) then return False; end if; @@ -6176,7 +6384,7 @@ package body Sem_Util is function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is begin - Note_Possible_Modification (AV); + Note_Possible_Modification (AV, Sure => True); -- We must reject parenthesized variable names. The check for -- Comes_From_Source is present because there are currently @@ -6220,7 +6428,7 @@ package body Sem_Util is if Is_Variable (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 then - Note_Possible_Modification (Expression (AV)); + Note_Possible_Modification (Expression (AV), Sure => True); return True; -- We also allow a non-parenthesized expression that raises @@ -7877,7 +8085,7 @@ package body Sem_Util is -- Note_Possible_Modification -- -------------------------------- - procedure Note_Possible_Modification (N : Node_Id) is + procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is Modification_Comes_From_Source : constant Boolean := Comes_From_Source (Parent (N)); @@ -7993,6 +8201,35 @@ package body Sem_Util is end if; Kill_Checks (Ent); + + -- If we are sure this is a modification from source, and we know + -- this modifies a constant, then give an appropriate warning. + + if Overlays_Constant (Ent) + and then Modification_Comes_From_Source + and then Sure + then + declare + A : constant Node_Id := Address_Clause (Ent); + begin + if Present (A) then + declare + Exp : constant Node_Id := Expression (A); + begin + if Nkind (Exp) = N_Attribute_Reference + and then Attribute_Name (Exp) = Name_Address + and then Is_Entity_Name (Prefix (Exp)) + then + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE + ("constant& may be modified via address clause#?", + N, Entity (Prefix (Exp))); + end if; + end; + end if; + end; + end if; + return; end if; end loop; @@ -8045,6 +8282,10 @@ package body Sem_Util is if Is_Entity_Name (Obj) then E := Entity (Obj); + if Is_Prival (E) then + E := Prival_Link (E); + end if; + -- If E is a type then it denotes a current instance. For this case -- we add one to the normal accessibility level of the type to ensure -- that current instances are treated as always being deeper than @@ -8881,7 +9122,7 @@ package body Sem_Util is -- Scope_Is_Transient -- ------------------------ - function Scope_Is_Transient return Boolean is + function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; @@ -9113,6 +9354,19 @@ package body Sem_Util is end if; end Set_Next_Actual; + ---------------------------------- + -- Set_Optimize_Alignment_Flags -- + ---------------------------------- + + procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is + begin + if Optimize_Alignment = 'S' then + Set_Optimize_Alignment_Space (E); + elsif Optimize_Alignment = 'T' then + Set_Optimize_Alignment_Time (E); + end if; + end Set_Optimize_Alignment_Flags; + ----------------------- -- Set_Public_Status -- ----------------------- @@ -9120,6 +9374,34 @@ package body Sem_Util is procedure Set_Public_Status (Id : Entity_Id) is S : constant Entity_Id := Current_Scope; + function Within_HSS_Or_If (E : Entity_Id) return Boolean; + -- Determines if E is defined within handled statement sequence or + -- an if statement, returns True if so, False otherwise. + + ---------------------- + -- Within_HSS_Or_If -- + ---------------------- + + function Within_HSS_Or_If (E : Entity_Id) return Boolean is + N : Node_Id; + begin + N := Declaration_Node (E); + loop + N := Parent (N); + + if No (N) then + return False; + + elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, + N_If_Statement) + then + return True; + end if; + end loop; + end Within_HSS_Or_If; + + -- Start of processing for Set_Public_Status + begin -- Everything in the scope of Standard is public @@ -9131,14 +9413,15 @@ package body Sem_Util is elsif not Is_Public (S) then return; - -- An object declaration that occurs in a handled sequence of statements - -- is the declaration for a temporary object generated by the expander. - -- It never needs to be made public and furthermore, making it public - -- can cause back end problems if it is of variable size. + -- An object or function declaration that occurs in a handled sequence + -- of statements or within an if statement is the declaration for a + -- temporary object or local subprogram generated by the expander. It + -- never needs to be made public and furthermore, making it public can + -- cause back end problems. - elsif Nkind (Parent (Id)) = N_Object_Declaration - and then - Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements + elsif Nkind_In (Parent (Id), N_Object_Declaration, + N_Function_Specification) + and then Within_HSS_Or_If (Id) then return; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b48c8a95446..c47af51cb12 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -139,6 +139,13 @@ package Sem_Util is -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id); + -- Check whether the expression is a pointer to a protected component, + -- and the context is external to the protected operation, to warn against + -- a possible unlocked access to data. + procedure Check_VMS (Construct : Node_Id); -- Check that this the target is OpenVMS, and if so, return with -- no effect, otherwise post an error noting this can only be used @@ -196,6 +203,12 @@ package Sem_Util is -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; + -- Utility to create a parameter profile for a new subprogram spec, + -- when the subprogram has a body that acts as spec. This is done for + -- some cases of inlining, and for private protected ops. Also used + -- to create bodies for stubbed subprograms. + function Current_Entity (N : Node_Id) return Entity_Id; -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. @@ -474,11 +487,13 @@ package Sem_Util is -- declaration. function Has_Access_Values (T : Entity_Id) return Boolean; - -- Returns true if type or subtype T is an access type, or has a - -- component (at any recursive level) that is an access type. This - -- is a conservative predicate, if it is not known whether or not - -- T contains access values (happens for generic formals in some - -- cases), then False is returned. + -- Returns true if type or subtype T is an access type, or has a component + -- (at any recursive level) that is an access type. This is a conservative + -- predicate, if it is not known whether or not T contains access values + -- (happens for generic formals in some cases), then False is returned. + -- Note that tagged types return False. Even though the tag is implemented + -- as an access type internally, this function tests only for access types + -- known to the programmer. See also Has_Tagged_Component. function Has_Abstract_Interfaces (T : Entity_Id; @@ -527,6 +542,10 @@ package Sem_Util is function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion + function Has_Overriding_Initialize (T : Entity_Id) return Boolean; + -- Predicate to determine whether a controlled type has a user-defined + -- initialize procedure, which makes the type not preelaborable. + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; -- Return True iff type E has preelaborable initialiation as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). @@ -544,8 +563,11 @@ package Sem_Util is -- if there is no underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; - -- Typ must be a composite type (array or record). This function is used - -- to check if '=' has to be expanded into a bunch component comparaisons. + -- Returns True if Typ is a composite type (array or record) which is + -- either itself a tagged type, or has a component (recursively) which is + -- a tagged type. Returns False for non-composite type, or if no tagged + -- component is present. to check if '=' has to be expanded into a bunch + -- component comparisons. function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance @@ -801,10 +823,10 @@ package Sem_Util is -- set if you want to clear only the Last_Assignment field (see above). procedure Kill_Size_Check_Code (E : Entity_Id); - -- Called when an address clause or pragma Import is applied to an - -- entity. If the entity is a variable or a constant, and size check - -- code is present, this size check code is killed, since the object - -- will not be allocated by the program. + -- Called when an address clause or pragma Import is applied to an entity. + -- If the entity is a variable or a constant, and size check code is + -- present, this size check code is killed, since the object will not + -- be allocated by the program. function Known_To_Be_Assigned (N : Node_Id) return Boolean; -- The node N is an entity reference. This function determines whether the @@ -900,13 +922,17 @@ package Sem_Util is -- in Success indicates sucess of reordering. For more details, see body. -- Errors are reported only if Report is set to True. - procedure Note_Possible_Modification (N : Node_Id); + procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean); -- This routine is called if the sub-expression N maybe the target of -- an assignment (e.g. it is the left side of an assignment, used as -- an out parameters, or used as prefixes of access attributes). It -- sets May_Be_Modified in the associated entity if there is one, -- taking into account the rule that in the case of renamed objects, -- it is the flag in the renamed object that must be set. + -- + -- The parameter Sure is set True if the modification is sure to occur + -- (e.g. target of assignment, or out parameter), and to False if the + -- modification is only potential (e.g. address of entity taken). function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. @@ -1057,6 +1083,10 @@ package Sem_Util is -- parameters are already members of a list, and do not need to be -- chained separately. See also First_Actual and Next_Actual. + procedure Set_Optimize_Alignment_Flags (E : Entity_Id); + pragma Inline (Set_Optimize_Alignment_Flags); + -- Sets Optimize_Aliignment_Space/Time flags in E from current settings + procedure Set_Public_Status (Id : Entity_Id); -- If an entity (visible or otherwise) is defined in a library -- package, or a package that is itself public, then this subprogram |