+2012-04-02 Robert Dewar <dewar@adacore.com>
+
+ * s-atopri.ads: Minor reformatting.
+
+2012-04-02 Thomas Quinot <quinot@adacore.com>
+
+ * sem_util.adb: Minor reformatting, minor code cleanup.
+
+2012-04-02 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-xref.adb (Generate_Reference): For a reference to an
+ operator symbol, set the sloc to point to the first character
+ of the operator name, and not to the initial quaote.
+ (Output_References): Ditto for the definition of an operator
+ symbol.
+
+2012-04-02 Vincent Celier <celier@adacore.com>
+
+ * ali.adb (Scan_Ali): Recognize Z lines. Set
+ Implicit_With_From_Instantiation to True in the With_Record for
+ Z lines.
+ * ali.ads (With_Record): New Boolean component
+ Implicit_With_From_Instantiation, defaulted to False.
+ * csinfo.adb: Indicate that Implicit_With_From_Instantiation
+ is special
+ * lib-writ.adb (Write_ALI): New array Implicit_With.
+ (Collect_Withs): Set Implicit_With for the unit is it is not Yes.
+ (Write_With_Lines): Write a Z line instead of a W line if
+ Implicit_With is Yes for the unit.
+ * sem_ch12.adb (Inherit_Context): Only add a unit in the context
+ if it is not there yet.
+ * sinfo.ads: New flag Implicit_With_From_Instantiation (Flag12)
+ added.
+
2012-04-02 Yannick Moy <moy@adacore.com>
* osint.adb, osint.ads (Add_Default_Search_Dirs): Add library
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
'X' => True, -- xref
'S' => True, -- specific dispatching
'Y' => True, -- limited_with
+ 'Z' => True, -- implicit with from instantiation
'C' => True, -- SCO information
'F' => True, -- Alfa information
others => False);
-- Acquire lines to be ignored
if Read_Xref then
- Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True);
+ Ignore :=
+ ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
-- Read_Lines parameter given
With_Loop : loop
Check_Unknown_Line;
- exit With_Loop when C /= 'W' and then C /= 'Y';
+ exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
if Ignore ('W') then
Skip_Line;
Withs.Table (Withs.Last).Elab_All_Desirable := False;
Withs.Table (Withs.Last).SAL_Interface := False;
Withs.Table (Withs.Last).Limited_With := (C = 'Y');
+ Withs.Table (Withs.Last).Implicit_With_From_Instantiation
+ := (C = 'Z');
-- Generic case with no object file available
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
Limited_With : Boolean := False;
-- True if unit is named in a limited_with_clause
+
+ Implicit_With_From_Instantiation : Boolean := False;
+ -- True if this is an implicit with from a generic instantiation
end record;
package Withs is new Table.Table (
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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 (Special, "Has_Dynamic_Range_Check", True);
Set (Special, "Has_Dynamic_Length_Check", True);
Set (Special, "Has_Private_View", True);
+ Set (Special, "Implicit_With_From_Instantiation", True);
Set (Special, "Is_Controlling_Actual", True);
Set (Special, "Is_Overloaded", True);
Set (Special, "Is_Static_Expression", True);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
-- Array of flags to show which units have Elaborate_All_Desirable set
+ type Yes_No is (Unknown, Yes, No);
+
+ Implicit_With : array (Units.First .. Last_Unit) of Yes_No;
+
Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));
-- Sorted table of source dependencies. One extra entry in case we
-- have to add a dummy entry for System.
else
Set_From_With_Type (Cunit_Entity (Unum));
end if;
+
+ if Implicit_With (Unum) /= Yes then
+ if Implicit_With_From_Instantiation (Item) then
+ Implicit_With (Unum) := Yes;
+
+ else
+ Implicit_With (Unum) := No;
+ end if;
+ end if;
end if;
Next (Item);
Elab_All_Flags (J) := False;
Elab_Des_Flags (J) := False;
Elab_All_Des_Flags (J) := False;
+ Implicit_With (J) := Unknown;
end loop;
Collect_Withs (Unode);
Uname := Units.Table (Unum).Unit_Name;
Fname := Units.Table (Unum).Unit_File_Name;
- if Ekind (Cunit_Entity (Unum)) = E_Package
+ if Implicit_With (Unum) = Yes then
+ Write_Info_Initiate ('Z');
+
+ elsif 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;
Ref := Original_Location (Sloc (Nod));
Def := Original_Location (Sloc (Ent));
+ -- If this is an operator symbol, skip the initial
+ -- quote, for navigation purposes.
+
+ if Nkind (N) = N_Defining_Operator_Symbol
+ or else Nkind (Nod) = N_Operator_Symbol
+ then
+ Ref := Ref + 1;
+ end if;
+
Add_Entry
((Ent => Ent,
Loc => Ref,
-- since at the time the reference or definition is made, private
-- types may be swapped, and the Sloc value may be incorrect. We
-- also set up the pointer vector for the sort.
+ -- For user-defined operators we need to skip the initial
+ -- quote and point to the first character of the name, for
+ -- navigation purposes.
for J in 1 .. Nrefs loop
- Rnums (J) := J;
- Xrefs.Table (J).Def :=
- Original_Location (Sloc (Xrefs.Table (J).Key.Ent));
+ declare
+ E : constant Entity_Id := Xrefs.Table (J).Key.Ent;
+ Loc : constant Source_Ptr := Original_Location (Sloc (E));
+
+ begin
+ Rnums (J) := J;
+
+ if Nkind (E) = N_Defining_Operator_Symbol then
+ Xrefs.Table (J).Def := Loc + 1;
+ else
+ Xrefs.Table (J).Def := Loc;
+ end if;
+ end;
end loop;
-- Sort the references
-- --
------------------------------------------------------------------------------
+-- ??? Need header saying what this unit is!!!
+
package System.Atomic_Primitives is
pragma Preelaborate;
Item : Node_Id;
New_I : Node_Id;
+ Clause : Node_Id;
+ OK : Boolean;
+
begin
if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
- -- Take care to prevent direct cyclic with's, which can happen
- -- if the generic body with's the current unit. Such a case
- -- would result in binder errors (or run-time errors if the
- -- -gnatE switch is in effect), but we want to prevent it here,
- -- because Sem.Walk_Library_Items doesn't like cycles. Note
- -- that we don't bother to detect indirect cycles.
+ -- Take care to prevent direct cyclic with's.
if Library_Unit (Item) /= Current_Unit then
- New_I := New_Copy (Item);
- Set_Implicit_With (New_I, True);
- Append (New_I, Current_Context);
+ -- Do not add a unit if it is already in the context
+
+ Clause := First (Current_Context);
+ OK := True;
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause and then
+ Chars (Name (Clause)) = Chars (Name (Item))
+ then
+ OK := False;
+ exit;
+ end if;
+
+ Next (Clause);
+ end loop;
+
+ if OK then
+ New_I := New_Copy (Item);
+ Set_Implicit_With (New_I, True);
+ Set_Implicit_With_From_Instantiation (New_I, True);
+ Append (New_I, Current_Context);
+ end if;
end if;
end if;
Bas := Base_Type (T);
- -- If T is non-private but its base type is private, this is
- -- the completion of a subtype declaration whose parent type
- -- is private (see Complete_Private_Subtype in sem_ch3). The
- -- proper discriminants are to be found in the full view of
- -- the base.
+ -- If T is non-private but its base type is private, this is the
+ -- completion of a subtype declaration whose parent type is private
+ -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
+ -- are to be found in the full view of the base.
if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
Bas := Full_View (Bas);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Act,
- Subtype_Indication =>
+ Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Bas, Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints)));
-- of the prefix.
function Build_Discriminal_Record_Constraint return List_Id;
- -- Similar to previous one, for discriminated components constrained
- -- by the discriminant of the enclosing object.
+ -- Similar to previous one, for discriminated components constrained by
+ -- the discriminant of the enclosing object.
----------------------------------------
-- Build_Discriminal_Array_Constraint --
-- and thus will not have the unit name automatically prepended.
Set_Package_Name (Spec_Id);
-
- -- Append _E
-
- Name_Buffer (Name_Len + 1) := '_';
- Name_Buffer (Name_Len + 2) := 'E';
- Name_Len := Name_Len + 2;
+ Add_Str_To_Name_Buffer ("_E");
-- Create elaboration counter
Set_Current_Value (Elab_Ent, Empty);
Set_Last_Assignment (Elab_Ent, Empty);
- -- We do not want any further qualification of the name (if we did
- -- not do this, we would pick up the name of the generic package
- -- in the case of a library level generic instantiation).
+ -- We do not want any further qualification of the name (if we did not
+ -- do this, we would pick up the name of the generic package in the case
+ -- of a library level generic instantiation).
Set_Has_Qualified_Name (Elab_Ent);
Set_Has_Fully_Qualified_Name (Elab_Ent);
then
return False;
else
- return
- Cannot_Raise_Constraint_Error (Expression (Expr));
+ return Cannot_Raise_Constraint_Error (Expression (Expr));
end if;
when N_Unchecked_Type_Conversion =>
if Do_Overflow_Check (Expr) then
return False;
else
- return
- Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
+ return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when N_Op_Divide |
-- Check_Implicit_Dereference --
--------------------------------
- procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id)
- is
+ procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
Disc : Entity_Id;
Desig : Entity_Id;
return Flag16 (N);
end Implicit_With;
+ function Implicit_With_From_Instantiation
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag12 (N);
+ end Implicit_With_From_Instantiation;
+
function Interface_List
(N : Node_Id) return List_Id is
begin
Set_Flag16 (N, Val);
end Set_Implicit_With;
+ procedure Set_Implicit_With_From_Instantiation
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag12 (N, Val);
+ end Set_Implicit_With_From_Instantiation;
+
procedure Set_Interface_List
(N : Node_Id; Val : List_Id) is
begin
-- 'Address or 'Tag attribute. ???There are other implicit with clauses
-- as well.
+ -- Implicit_With_From_Instantiation (Flag12-Sem)
+ -- Set in N_With_Clause nodes from generic instantiations.
+
-- Import_Interface_Present (Flag16-Sem)
-- This flag is set in an Interface or Import pragma if a matching
-- pragma of the other kind is also present. This is used to avoid
-- Elaborate_Desirable (Flag11-Sem)
-- Private_Present (Flag15) set if with_clause has private keyword
-- Implicit_With (Flag16-Sem)
+ -- Implicit_With_From_Instantiation (Flag12-Sem)
-- Limited_Present (Flag17) set if LIMITED is present
-- Limited_View_Installed (Flag18-Sem)
-- Unreferenced_In_Spec (Flag7-Sem)
function Implicit_With
(N : Node_Id) return Boolean; -- Flag16
+ function Implicit_With_From_Instantiation
+ (N : Node_Id) return Boolean; -- Flag12
+
function Import_Interface_Present
(N : Node_Id) return Boolean; -- Flag16
procedure Set_Implicit_With
(N : Node_Id; Val : Boolean := True); -- Flag16
+ procedure Set_Implicit_With_From_Instantiation
+ (N : Node_Id; Val : Boolean := True); -- Flag12
+
procedure Set_Import_Interface_Present
(N : Node_Id; Val : Boolean := True); -- Flag16
pragma Inline (High_Bound);
pragma Inline (Identifier);
pragma Inline (Implicit_With);
+ pragma Inline (Implicit_With_From_Instantiation);
pragma Inline (Interface_List);
pragma Inline (Interface_Present);
pragma Inline (Includes_Infinities);
projects / platform / upstream / gcc.git / commitdiff