[multiple changes]
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. From-SVN: r206930
This commit is contained in:
Arnaud Charlet
parent
b2834fbd22
commit
fba9ebfc51
12 changed files with 246 additions and 63 deletions
|
|
@ -1,3 +1,41 @@
|
|||
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):
|
||||
|
|
|
|||
|
|
@ -46,8 +46,10 @@ package body Ada.Streams is
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -5257,6 +5257,10 @@ package body Checks is
|
|||
|
||||
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;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
|
@ -464,11 +464,11 @@ package body Csets is
|
|||
|
||||
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,
|
||||
|
|
@ -539,9 +539,9 @@ package body Csets is
|
|||
|
||||
others => ' ');
|
||||
|
||||
------------------------------------------
|
||||
-- Definitions for Latin-9 (ISO 8859-9) --
|
||||
------------------------------------------
|
||||
-------------------------------------------
|
||||
-- Definitions for Latin-9 (ISO 8859-15) --
|
||||
-------------------------------------------
|
||||
|
||||
Fold_Latin_9 : constant Translate_Table := Translate_Table'(
|
||||
|
||||
|
|
@ -1112,7 +1112,7 @@ package body Csets is
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
|
@ -60,14 +60,14 @@ package Csets is
|
|||
-- 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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
|
@ -111,11 +111,13 @@ package GNAT.Calendar.Time_IO is
|
|||
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
|
||||
|
|
|
|||
|
|
@ -702,12 +702,12 @@ package Opt is
|
|||
-- 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)
|
||||
|
|
|
|||
|
|
@ -233,8 +233,8 @@ package body Rtsfind is
|
|||
|
||||
-- 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
|
||||
|
|
|
|||
|
|
@ -698,6 +698,21 @@ package body Sem_Aux is
|
|||
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 --
|
||||
---------------------
|
||||
|
|
|
|||
|
|
@ -259,6 +259,9 @@ package Sem_Aux is
|
|||
-- 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)).
|
||||
|
|
|
|||
|
|
@ -2075,6 +2075,12 @@ package body Sem_Ch3 is
|
|||
-- (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
|
||||
|
|
@ -2099,6 +2105,70 @@ package body Sem_Ch3 is
|
|||
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 --
|
||||
--------------------------------
|
||||
|
|
@ -2200,6 +2270,9 @@ package body Sem_Ch3 is
|
|||
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
|
||||
|
||||
|
|
@ -2294,15 +2367,28 @@ package body Sem_Ch3 is
|
|||
-- 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);
|
||||
|
|
|
|||
|
|
@ -4168,10 +4168,11 @@ package body Sem_Ch8 is
|
|||
-- 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
|
||||
|
|
@ -4214,11 +4215,57 @@ package body Sem_Ch8 is
|
|||
|
||||
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)
|
||||
|
|
@ -4234,27 +4281,13 @@ package body Sem_Ch8 is
|
|||
|
||||
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;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue