-- --
-- 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- --
'D' => True, -- dependency
'X' => True, -- xref
'S' => True, -- specific dispatching
+ 'Y' => True, -- limited_with
others => False);
--------------------
-- 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
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,
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
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 ");
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
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;
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
-- --
-- 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- --
-- 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.
-- 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 (
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 (
-- 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
-- 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
-- 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
-- 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
-- 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
-- --
-- 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- --
-----------------------
-- 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;
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);
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;
-- 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;
-- 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;
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
(" { (count = at least #)");
else
Consistency_Error_Msg
- (" % (count = #)");
+ (" { (count = #)");
end if;
end if;
end if;
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 --
---------------------------------------------------
-- 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
* *
* 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- *
/* 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
-- --
-- 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- --
-- 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)
-- 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
-- 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
-- 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;
-- 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;
-- --
-- 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- --
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);
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;
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
-- --
-- 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- --
Munit_Index => 0,
Serial_Number => 0,
Version => 0,
- Error_Location => No_Location);
+ Error_Location => No_Location,
+ OA_Setting => 'O');
end Add_Preprocessing_Dependency;
------------------------------
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.
-- 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;
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;
end case;
end if;
- if Initialize_Scalars then
+ if Initialize_Scalars or else Invalid_Value_Used then
Write_Info_Str (" IS");
end if;
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);
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;
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;
-- --
-- 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- --
-- 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:
--
-- 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).
-- 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
-- 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
-- --
-- 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- --
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;
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;
-- --
-- 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- --
-- 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
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;
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
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);
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);
Is_Compiler_Unit : Boolean;
Dynamic_Elab : Boolean;
Loading : Boolean;
+ OA_Setting : Character;
end record;
-- The following representation clause ensures that the above record
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 (
-- --
-- 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- --
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;
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;
---------------------------------
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;
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;
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;
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;
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.
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;
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);
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);
-- 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
-- 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
-- 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
-- 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
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
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
-- 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
-- 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
-- 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 --
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;
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;
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;
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
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);
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;
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
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));
-- 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;
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
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
("\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))));
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));
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));
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;
-- 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 --
-----------------------------
-- 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;
-- 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;
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
-- 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);
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;
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);
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);
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;
-- 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 ???
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
-- 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
(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
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.
-- 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
-- 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;
-- 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;
-- 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
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
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
-- 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
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;
-----------------------------
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.
-----------------
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;
-- 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);
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.
"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;
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
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
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
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);
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 --
-------------------------------------------
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;
end if;
end if;
+ Set_Optimize_Alignment_Flags (Id);
Check_Eliminated (Id);
end Analyze_Subtype_Declaration;
Set_Is_Descendent_Of_Address (Prev);
end if;
+ Set_Optimize_Alignment_Flags (Def_Id);
Check_Eliminated (Def_Id);
end Analyze_Type_Declaration;
end if;
end Process_Declarations;
- -- Variables local to Analyze_Case_Statement
+ -- Local Variables
Discr_Name : Node_Id;
Discr_Type : Entity_Id;
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;
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);
("the type of a component cannot be abstract",
Subtype_Indication (Component_Def));
end if;
-
end Array_Type_Declaration;
------------------------------------------------------
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
-- 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
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);
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)
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)
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
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))))
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
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));
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.
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);
function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is
Elmt : Elmt_Id;
+
begin
Elmt := First_Elmt (L);
while Present (Elmt) loop
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
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);
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);
-- 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
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.
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
return Result;
end Search_Derivation_Levels;
+ -- Local Variables
+
Result : Node_Or_Entity_Id;
-- Start of processing for Get_Discriminant_Value
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 --
------------------------------
Ancestor := Etype (Ancestor);
end loop;
-
- return True;
end;
end if;
end Is_Visible_Component;
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)));
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
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);
-- 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
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
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
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
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 --
-----------------------------
-- --
-- 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- --
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
-- 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
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
-- 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);
-- 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)
("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.
-- 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
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)
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 --
---------------
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 --
--------------------
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);
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
-- 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
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;
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
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
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));
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;
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)
-- 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,
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.
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;
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 --
--------------------------------------
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
T := Base_Type (Etyp);
end loop;
end if;
-
- raise Program_Error;
end Is_Descendent_Of;
--------------
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;
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
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
-- 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));
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;
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
-- 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;
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 --
-----------------------
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
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;
-- 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
-- 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.
-- 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;
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).
-- 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
-- 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
-- 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.
-- 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
projects / gcc.git / commitdiff