+2014-01-22 Thomas Quinot <quinot@adacore.com>
+
+ * rtsfind.adb: Update comment.
+
+2014-01-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aux.ads, sem_aux.adb (Is_Body): New routine.
+ * sem_ch3.adb (Analyze_Declarations): Add local variable
+ Body_Seen. Generate the spec of a late controlled
+ primitive body that is about to freeze its related type.
+ (Handle_Late_Controlled_Primitive): New routine.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * a-stream.adb: Minor reformatting.
+
+2014-01-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (From_Actual_Package): Introduce a recursive
+ sub-procedure Declared_In_Actual to handle properly the visibility
+ of actuals in actual packages, that are themselves actuals to a
+ actual package of the current instance. This mimics properly the
+ visibility of formals of formal packages declared with a box,
+ within the corresponding generic unit.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * checks.adb: Do not assume that a volatile variable is valid.
+
+2014-01-22 Thomas Quinot <quinot@adacore.com>
+
+ * g-catiio.ads (Image, Value): Clarify that these functions
+ operate in the local time zone. Minor documentation update.
+
+2014-01-22 Thomas Quinot <quinot@adacore.com>
+
+ * csets.adb, csets.ads, opt.ads: Minor documentation fixes.
+
2014-01-22 Robert Dewar <dewar@adacore.com>
* sem_aux.adb, sem_aux.ads, sem_ch3.adb (Has_Unconstrained_Elements):
V : out Stream_Element_Array)
is
Last : Stream_Element_Offset;
+
begin
Read (S.all, V, Last);
+
if Last /= V'Last then
raise Ada.IO_Exceptions.End_Error;
end if;
elsif Is_Entity_Name (Expr)
and then Is_Known_Valid (Entity (Expr))
+
+ -- Exclude volatile variables
+
+ and then not Treat_As_Volatile (Entity (Expr))
then
return True;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
others => ' ');
- ---------------------------------------------------
- -- Definitions for Latin-5 (Cyrillic ISO-8859-5) --
- ---------------------------------------------------
+ -------------------------------------------
+ -- Definitions for Cyrillic (ISO-8859-5) --
+ -------------------------------------------
- Fold_Latin_5 : constant Translate_Table := Translate_Table'(
+ Fold_Cyrillic : constant Translate_Table := Translate_Table'(
'a' => 'A', X_D0 => X_B0, X_E0 => X_C0,
'b' => 'B', X_D1 => X_B1, X_E1 => X_C1, X_F1 => X_A1,
others => ' ');
- ------------------------------------------
- -- Definitions for Latin-9 (ISO 8859-9) --
- ------------------------------------------
+ -------------------------------------------
+ -- Definitions for Latin-9 (ISO 8859-15) --
+ -------------------------------------------
Fold_Latin_9 : constant Translate_Table := Translate_Table'(
Fold_Upper := Fold_Latin_4;
elsif Identifier_Character_Set = '5' then
- Fold_Upper := Fold_Latin_5;
+ Fold_Upper := Fold_Cyrillic;
elsif Identifier_Character_Set = 'p' then
Fold_Upper := Fold_IBM_PC_437;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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 character set in use is specified by the value stored in
-- Opt.Identifier_Character_Set, which has the following settings:
- -- '1' Latin-1 (ISO-8859-1)
- -- '2' Latin-2 (ISO-8859-2)
- -- '3' Latin-3 (ISO-8859-3)
- -- '4' Latin-4 (ISO-8859-4)
- -- '5' Latin-5 (ISO-8859-5, Cyrillic)
- -- 'p' IBM PC (code page 437)
- -- '8' IBM PC (code page 850)
- -- '9' Latin-9 (ISO-9959-9)
+ -- '1' Latin-1 (ISO-8859-1)
+ -- '2' Latin-2 (ISO-8859-2)
+ -- '3' Latin-3 (ISO-8859-3)
+ -- '4' Latin-4 (ISO-8859-4)
+ -- '5' Cyrillic (ISO-8859-5)
+ -- 'p' IBM PC (code page 437)
+ -- '8' IBM PC (code page 850)
+ -- '9' Latin-9 (ISO-8859-15)
-- 'f' Full upper set (all distinct)
-- 'n' No upper characters (Ada/83 rules)
-- 'w' Latin-1 plus wide characters also allowed
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2010, AdaCore --
+-- Copyright (C) 1999-2013, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Image
(Date : Ada.Calendar.Time;
Picture : Picture_String) return String;
- -- Return Date as a string with format Picture. Raise Picture_Error if
- -- picture string is null or has an incorrect format.
+ -- Return Date, as interpreted in the current local time zone, as a string
+ -- with format Picture. Raise Picture_Error if picture string is null or
+ -- has an incorrect format.
function Value (Date : String) return Ada.Calendar.Time;
- -- Parse the string Date and return its equivalent as a Time value. The
+ -- Parse the string Date, interpreted as a time representation in the
+ -- current local time zone, and return the corresponding Time value. The
-- following time format is supported:
--
-- hh:mm:ss - Date is the current date
-- GNAT
-- This variable indicates the character set to be used for identifiers.
-- The possible settings are:
- -- '1' Latin-5 (ISO-8859-1)
- -- '2' Latin-5 (ISO-8859-2)
- -- '3' Latin-5 (ISO-8859-3)
- -- '4' Latin-5 (ISO-8859-4)
- -- '5' Latin-5 (ISO-8859-5, Cyrillic)
- -- '9' Latin-5 (ISO-8859-9)
+ -- '1' Latin-1 (ISO-8859-1)
+ -- '2' Latin-2 (ISO-8859-2)
+ -- '3' Latin-3 (ISO-8859-3)
+ -- '4' Latin-4 (ISO-8859-4)
+ -- '5' Latin-Cyrillic (ISO-8859-5)
+ -- '9' Latin-9 (ISO-8859-15)
-- 'p' PC (US, IBM page 437)
-- '8' PC (European, IBM page 850)
-- 'f' Full upper set (all distinct)
-- If the entity being referenced is defined in the current scope,
-- using it is always fine as such usage can never introduce any
- -- dependency on an additional unit.
- -- Why do we need to do this test ???
+ -- dependency on an additional unit. The presence of this test
+ -- helps generating meaningful error messages for CRT violations.
and then Scope (Eid) /= Current_Scope
then
Obsolescent_Warnings.Init;
end Initialize;
+ -------------
+ -- Is_Body --
+ -------------
+
+ function Is_Body (N : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (N) in N_Body_Stub
+ or else Nkind_In (N, N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body);
+ end Is_Body;
+
---------------------
-- Is_By_Copy_Type --
---------------------
-- or subtype. This is true if Suppress_Initialization is set either for
-- the subtype itself, or for the corresponding base type.
+ function Is_Body (N : Node_Id) return Boolean;
+ -- Determine whether an arbitrary node denotes a body
+
function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by copy, as defined in (RM 6.2(3)).
-- (They have the sloc of the label as found in the source, and that
-- is ahead of the current declarative part).
+ procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
+ -- Determine whether Body_Decl denotes the body of a late controlled
+ -- primitive (either Initialize, Adjust or Finalize). If this is the
+ -- case, add a proper spec if the body lacks one. The spec is inserted
+ -- before Body_Decl and immedately analyzed.
+
procedure Remove_Visible_Refinements (Spec_Id : Entity_Id);
-- Spec_Id is the entity of a package that may define abstract states.
-- If the states have visible refinement, remove the visibility of each
end loop;
end Adjust_Decl;
+ --------------------------------------
+ -- Handle_Late_Controlled_Primitive --
+ --------------------------------------
+
+ procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is
+ Body_Spec : constant Node_Id := Specification (Body_Decl);
+ Body_Id : constant Entity_Id := Defining_Entity (Body_Spec);
+ Loc : constant Source_Ptr := Sloc (Body_Id);
+ Params : constant List_Id :=
+ Parameter_Specifications (Body_Spec);
+ Spec : Node_Id;
+ Spec_Id : Entity_Id;
+
+ Dummy : Entity_Id;
+ pragma Unreferenced (Dummy);
+ -- A dummy variable used to capture the unused result of subprogram
+ -- spec analysis.
+
+ begin
+ -- Consider only procedure bodies whose name matches one of type
+ -- [Limited_]Controlled's primitives.
+
+ if Nkind (Body_Spec) /= N_Procedure_Specification
+ or else not Nam_In (Chars (Body_Id), Name_Adjust,
+ Name_Finalize,
+ Name_Initialize)
+ then
+ return;
+
+ -- A controlled primitive must have exactly one formal whose type
+ -- derives from [Limited_]Controlled.
+
+ elsif List_Length (Params) /= 1 then
+ return;
+ end if;
+
+ Dummy := Analyze_Subprogram_Specification (Body_Spec);
+
+ if not Is_Controlled (Etype (Defining_Entity (First (Params)))) then
+ return;
+ end if;
+
+ Spec_Id := Find_Corresponding_Spec (Body_Decl, Post_Error => False);
+
+ -- The body has a matching spec, therefore it cannot be a late
+ -- primitive.
+
+ if Present (Spec_Id) then
+ return;
+ end if;
+
+ -- At this point the body is known to be a late controlled primitive.
+ -- Generate a matching spec and insert it before the body.
+
+ Spec := New_Copy_Tree (Body_Spec);
+
+ Set_Defining_Unit_Name
+ (Spec, Make_Defining_Identifier (Loc, Chars (Body_Id)));
+
+ Insert_Before_And_Analyze (Body_Decl,
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec));
+ end Handle_Late_Controlled_Primitive;
+
--------------------------------
-- Remove_Visible_Refinements --
--------------------------------
Prag : Node_Id;
Spec_Id : Entity_Id;
+ Body_Seen : Boolean := False;
+ -- Flag set when the first body [stub] is encountered
+
In_Package_Body : Boolean := False;
-- Flag set when the current declaration list belongs to a package body
-- care to attach the bodies at a proper place in the tree so as to
-- not cause unwanted freezing at that point.
- elsif not Analyzed (Next_Decl)
- and then (Nkind_In (Next_Decl, N_Subprogram_Body,
- N_Entry_Body,
- N_Package_Body,
- N_Protected_Body,
- N_Task_Body)
- or else
- Nkind (Next_Decl) in N_Body_Stub)
- then
+ elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
+
+ -- When a controlled type is frozen, the expander generates stream
+ -- and controlled type support routines. If the freeze is caused
+ -- by the stand alone body of Initialize, Adjust and Finalize, the
+ -- expander will end up using the wrong version of these routines
+ -- as the body has not been processed yet. To remedy this, detect
+ -- a late controlled primitive and create a proper spec for it.
+ -- This ensures that the primitive will override its inherited
+ -- counterpart before the freeze takes place.
+
+ -- ??? a cleaner approach may be possible and/or this solution
+ -- could be extended to general-purpose late primitives, TBD.
+
+ if not Body_Seen and then not Is_Body (Decl) then
+ Body_Seen := True;
+
+ if Nkind (Next_Decl) = N_Subprogram_Body then
+ Handle_Late_Controlled_Primitive (Next_Decl);
+ end if;
+ end if;
+
Adjust_Decl;
Freeze_All (Freeze_From, Decl);
Freeze_From := Last_Entity (Current_Scope);
-- generate the precise error message.
function From_Actual_Package (E : Entity_Id) return Boolean;
- -- Returns true if the entity is declared in a package that is
+ -- Returns true if the entity is an actual for a package that is itself
-- an actual for a formal package of the current instance. Such an
- -- entity requires special handling because it may be use-visible
- -- but hides directly visible entities defined outside the instance.
+ -- entity requires special handling because it may be use-visible but
+ -- hides directly visible entities defined outside the instance, because
+ -- the corresponding formal did so in the generic.
function Is_Actual_Parameter return Boolean;
-- This function checks if the node N is an identifier that is an actual
function From_Actual_Package (E : Entity_Id) return Boolean is
Scop : constant Entity_Id := Scope (E);
- Act : Entity_Id;
+ -- Declared scope of candidate entity
+
+ Act : Entity_Id;
+
+ function Declared_In_Actual (Pack : Entity_Id) return Boolean;
+ -- Recursive function that does the work and examines actuals of
+ -- actual packages of current instance.
+
+ ------------------------
+ -- Declared_In_Actual --
+ ------------------------
+
+ function Declared_In_Actual (Pack : Entity_Id) return Boolean is
+ Act : Entity_Id;
+
+ begin
+ if No (Associated_Formal_Package (Pack)) then
+ return False;
+
+ else
+ Act := First_Entity (Pack);
+ while Present (Act) loop
+ if Renamed_Object (Pack) = Scop then
+ return True;
+
+ -- Check for end of list of actuals.
+
+ elsif Ekind (Act) = E_Package
+ and then Renamed_Object (Act) = Pack
+ then
+ return False;
+
+ elsif Ekind (Act) = E_Package
+ and then Declared_In_Actual (Act)
+ then
+ return True;
+ end if;
+
+ Next_Entity (Act);
+ end loop;
+
+ return False;
+ end if;
+ end Declared_In_Actual;
+
+ -- Start of processing for From_Actual_Package
begin
if not In_Instance then
return False;
+
else
Inst := Current_Scope;
while Present (Inst)
Act := First_Entity (Inst);
while Present (Act) loop
- if Ekind (Act) = E_Package then
-
- -- Check for end of actuals list
-
- if Renamed_Object (Act) = Inst then
- return False;
-
- elsif Present (Associated_Formal_Package (Act))
- and then Renamed_Object (Act) = Scop
- then
- -- Entity comes from (instance of) formal package
-
- return True;
-
- else
- Next_Entity (Act);
- end if;
-
- else
- Next_Entity (Act);
+ if Ekind (Act) = E_Package
+ and then Declared_In_Actual (Act)
+ then
+ return True;
end if;
+
+ Next_Entity (Act);
end loop;
return False;
projects / thirdparty / gcc.git / commitdiff
