OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2012-05-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb (Subtypes_Statically_Match): In Ada 2012, static
	matching requires matching of static subtype predicates as well.

2012-05-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_case.adb (Analyze_Choices): If the subtype of the
	expression has a non-static predicate, the case alternatives
	must cover the base type.

2012-05-15  Tristan Gingold  <gingold@adacore.com>

	* a-calend-vms.ads: Add pragma export to Split and Time_Of.
	Merge comments from a-calend.ads to minimize differences.

2012-05-15  Sergey Rybin  <rybin@adacore.com frybin>

	* gnat_ugn.texi: gnatmetric: add a small example that demonstrates
	the difference between control coupling and unit coupling.

2012-05-15  Tristan Gingold  <gingold@adacore.com>

	* bindgen.adb (Gen_Header): Remove code to emit LE_Set.
	(Gen_Finalize_Library): Replace test with
	a call to __gnat_reraise_library_exception_if_any.
	* s-soflin.ads (Library_Exception): Do not export.
	(Library_Exception_Set): Likewise.
	* a-except-2005.ads, a-except-2005.adb
	(Reraise_Library_Exception_If_Any): New procedure.

From-SVN: r187509
This commit is contained in:
Arnaud Charlet 2012-05-15 11:37:57 +02:00
parent c4c768dded
commit bb9c600b57
9 changed files with 233 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2012-05-15 Ed Schonberg <schonberg@adacore.com>
* sem_eval.adb (Subtypes_Statically_Match): In Ada 2012, static
matching requires matching of static subtype predicates as well.
2012-05-15 Ed Schonberg <schonberg@adacore.com>
* sem_case.adb (Analyze_Choices): If the subtype of the
expression has a non-static predicate, the case alternatives
must cover the base type.
2012-05-15 Tristan Gingold <gingold@adacore.com>
* a-calend-vms.ads: Add pragma export to Split and Time_Of.
Merge comments from a-calend.ads to minimize differences.
2012-05-15 Sergey Rybin <rybin@adacore.com frybin>
* gnat_ugn.texi: gnatmetric: add a small example that demonstrates
the difference between control coupling and unit coupling.
2012-05-15 Tristan Gingold <gingold@adacore.com>
* bindgen.adb (Gen_Header): Remove code to emit LE_Set.
(Gen_Finalize_Library): Replace test with
a call to __gnat_reraise_library_exception_if_any.
* s-soflin.ads (Library_Exception): Do not export.
(Library_Exception_Set): Likewise.
* a-except-2005.ads, a-except-2005.adb
(Reraise_Library_Exception_If_Any): New procedure.
2012-05-15 Geert Bosch <bosch@adacore.com>
* sem_ch9.adb (Allows_Lock_Free_Implementation): out or in out

57
gcc/ada/a-calend-vms.ads
View File

@ -33,28 +33,31 @@
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version
-- This is the OpenVMS version
with System.OS_Primitives;
package Ada.Calendar is
package OSP renames System.OS_Primitives;
type Time is private;
-- Declarations representing limits of allowed local time values. Note
-- that these do NOT constrain the possible stored values of time which
-- may well permit a larger range of times (this is explicitly allowed
-- in Ada 95).
-- Declarations representing limits of allowed local time values. Note that
-- these do NOT constrain the possible stored values of time which may well
-- permit a larger range of times (this is explicitly allowed in Ada 95).
subtype Year_Number is Integer range 1901 .. 2399;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
-- A Day_Duration value of 86_400.0 designates a new day
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
function Clock return Time;
-- The returned time value is the number of nanoseconds since the start
-- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled,
-- the result will contain all elapsed leap seconds since the start of
-- Ada time until now.
function Year (Date : Time) return Year_Number;
function Month (Date : Time) return Month_Number;
@ -67,17 +70,39 @@ package Ada.Calendar is
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration);
-- Break down a time value into its date components set in the current
-- time zone. If Split is called on a time value created using Ada 2005
-- Time_Of in some arbitrary time zone, the input value will always be
-- interpreted as relative to the local time zone.
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0) return Time;
-- GNAT Note: Normally when procedure Split is called on a Time value
-- result of a call to function Time_Of, the out parameters of procedure
-- Split are identical to the in parameters of function Time_Of. However,
-- when a non-existent time of day is specified, the values for Seconds
-- may or may not be different. This may happen when Daylight Saving Time
-- (DST) is in effect, on the day when switching to DST, if Seconds
-- specifies a time of day in the hour that does not exist. For example,
-- in New York:
--
-- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0)
--
-- will return a Time value T. If Split is called on T, the resulting
-- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being
-- a time that not exist).
function "+" (Left : Time; Right : Duration) return Time;
function "+" (Left : Duration; Right : Time) return Time;
function "-" (Left : Time; Right : Duration) return Time;
function "-" (Left : Time; Right : Time) return Duration;
-- The first three functions will raise Time_Error if the resulting time
-- value is less than the start of Ada time in UTC or greater than the
-- end of Ada time in UTC. The last function will raise Time_Error if the
-- resulting difference cannot fit into a duration value.
function "<" (Left, Right : Time) return Boolean;
function "<=" (Left, Right : Time) return Boolean;
@ -121,10 +146,11 @@ private
-- Relative Time is positive, whereas relative OS_Time is negative,
-- but this declaration makes for easier conversion.
type Time is new OSP.OS_Time;
type Time is new System.OS_Primitives.OS_Time;
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
-- Days in month for non-leap year, leap year case is adjusted in code
Invalid_Time_Zone_Offset : Long_Integer;
pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff");
@ -132,8 +158,13 @@ private
function Is_Leap (Year : Year_Number) return Boolean;
-- Determine whether a given year is leap
-- The following packages provide a target independent interface to the
-- children of Calendar - Arithmetic, Formatting and Time_Zones.
----------------------------------------------------------
-- Target-Independent Interface to Children of Calendar --
----------------------------------------------------------
-- The following packages provide a target-independent interface to the
-- children of Calendar - Arithmetic, Conversions, Delays, Formatting and
-- Time_Zones.
-- NOTE: Delays does not need a target independent interface because
-- VMS already has a target specific file for that package.
@ -168,6 +199,7 @@ private
---------------------------
package Conversion_Operations is
function To_Ada_Time (Unix_Time : Long_Integer) return Time;
-- Unix to Ada Epoch conversion
@ -231,6 +263,7 @@ private
Use_TZ : Boolean;
Is_Historic : Boolean;
Time_Zone : Long_Integer);
pragma Export (Ada, Split, "__gnat_split");
-- Split a time value into its components. If flag Is_Historic is set,
-- this routine would try to use to the best of the OS's abilities the
-- time zone offset that was or will be in effect on Date. Set Use_TZ
@ -251,6 +284,7 @@ private
Use_TZ : Boolean;
Is_Historic : Boolean;
Time_Zone : Long_Integer) return Time;
pragma Export (Ada, Time_Of, "__gnat_time_of");
-- Given all the components of a date, return the corresponding time
-- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the
-- day duration will be calculated from Hour, Minute, Second and Sub_
@ -269,7 +303,8 @@ private
package Time_Zones_Operations is
function UTC_Time_Offset (Date : Time) return Long_Integer;
-- Return the offset in seconds from UTC
-- Return (in seconds) the difference between the local time zone and
-- UTC time at a specific historic date.
end Time_Zones_Operations;

15
gcc/ada/a-except-2005.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -1287,6 +1287,19 @@ package body Ada.Exceptions is
Raise_Current_Excep (Excep.Id);
end Reraise;
--------------------------------------
-- Reraise_Library_Exception_If_Any --
--------------------------------------
procedure Reraise_Library_Exception_If_Any is
LE : Exception_Occurrence;
begin
if Library_Exception_Set then
LE := Library_Exception;
Raise_From_Controlled_Operation (LE);
end if;
end Reraise_Library_Exception_If_Any;
------------------------
-- Reraise_Occurrence --
------------------------

9
gcc/ada/a-except-2005.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -236,6 +236,13 @@ private
-- Raise Program_Error, providing information about X (an exception raised
-- during a controlled operation) in the exception message.
procedure Reraise_Library_Exception_If_Any;
pragma Export
(Ada, Reraise_Library_Exception_If_Any,
"__gnat_reraise_library_exception_if_any");
-- If there was an exception raised during library-level finalization,
-- reraise the exception.
procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_Always);
-- This differs from Raise_Occurrence only in that the caller guarantees

42
gcc/ada/bindgen.adb
View File

@ -1357,19 +1357,6 @@ package body Bindgen is
procedure Gen_Header is
begin
WBI (" procedure finalize_library is");
-- The following flag is used to check for library-level exceptions
-- raised during finalization. Symbol comes from System.Soft_Links.
-- VM targets use regular Ada to reference the entity.
if VM_Target = No_VM then
WBI (" LE_Set : Boolean;");
Set_String (" pragma Import (Ada, LE_Set, ");
Set_String ("""__gnat_library_exception_set"");");
Write_Statement_Buffer;
end if;
WBI (" begin");
end Gen_Header;
@ -1569,27 +1556,17 @@ package body Bindgen is
-- and the routine necessary to raise it.
if VM_Target = No_VM then
WBI (" if LE_Set then");
WBI (" declare");
WBI (" LE : Ada.Exceptions.Exception_Occurrence;");
WBI (" declare");
WBI (" procedure Reraise_Library_Exception_If_Any;");
Set_String (" pragma Import (Ada, LE, ");
Set_String ("""__gnat_library_exception"");");
Set_String (" pragma Import (Ada, ");
Set_String ("Reraise_Library_Exception_If_Any, ");
Set_String ("""__gnat_reraise_library_exception_if_any"");");
Write_Statement_Buffer;
Set_String (" procedure Raise_From_Controlled_");
Set_String ("Operation (X : Ada.Exceptions.Exception_");
Set_String ("Occurrence);");
Write_Statement_Buffer;
Set_String (" pragma Import (Ada, Raise_From_");
Set_String ("Controlled_Operation, ");
Set_String ("""__gnat_raise_from_controlled_operation"");");
Write_Statement_Buffer;
WBI (" begin");
WBI (" Raise_From_Controlled_Operation (LE);");
WBI (" end;");
WBI (" begin");
WBI (" Reraise_Library_Exception_If_Any;");
WBI (" end;");
-- VM-specific code, use regular Ada to produce the desired behavior
@ -1599,9 +1576,10 @@ package body Bindgen is
Set_String (" Ada.Exceptions.Reraise_Occurrence (");
Set_String ("System.Soft_Links.Library_Exception);");
Write_Statement_Buffer;
WBI (" end if;");
end if;
WBI (" end if;");
WBI (" end finalize_library;");
WBI ("");
end if;

78
gcc/ada/gnat_ugn.texi
View File

@ -14954,14 +14954,88 @@ upon units that define subprograms are counted, so control fan-out coupling
is reported for all units, but control fan-in coupling - only for the units
that define subprograms.
The following simple example illustrates the difference between unit coupling
and control coupling metrics:
@smallexample @c ada
package Lib_1 is
function F_1 (I : Integer) return Integer;
end Lib_1;
package Lib_2 is
type T_2 is new Integer;
end Lib_2;
package body Lib_1 is
function F_1 (I : Integer) return Integer is
begin
return I + 1;
end F_1;
end Lib_1;
with Lib_2; use Lib_2;
package Pack is
Var : T_2;
function Fun (I : Integer) return Integer;
end Pack;
with Lib_1; use Lib_1;
package body Pack is
function Fun (I : Integer) return Integer is
begin
return F_1 (I);
end Fun;
end Pack;
@end smallexample
@noindent
if we apply @command{gnatmetric} with @code{--coupling-all} option to these
units, the result will be:
@smallexample
Coupling metrics:
=================
Unit Lib_1 (C:\customers\662\L406-007\lib_1.ads)
control fan-out coupling : 0
control fan-in coupling : 1
unit fan-out coupling : 0
unit fan-in coupling : 1
Unit Pack (C:\customers\662\L406-007\pack.ads)
control fan-out coupling : 1
control fan-in coupling : 0
unit fan-out coupling : 2
unit fan-in coupling : 0
Unit Lib_2 (C:\customers\662\L406-007\lib_2.ads)
control fan-out coupling : 0
unit fan-out coupling : 0
unit fan-in coupling : 1
@end smallexample
@noindent
The result does not contain values for object-oriented
coupling because none of the argument unit contains a tagged type and
therefore none of these units can be treated as a class.
@code{Pack} (considered as a program unit, that is spec+body) depends on two
units - @code{Lib_1} @code{and Lib_2}, therefore it has unit fan-out coupling
equals to 2. And nothing depend on it, so its unit fan-in coupling is 0 as
well as control fan-in coupling. Only one of the units @code{Pack} depends
upon defines a subprogram, so its control fan-out coupling is 1.
@code{Lib_2} depends on nothing, so fan-out metrics for it are 0. It does
not define a subprogram, so control fan-in metric cannot be applied to it,
and there is one unit that depends on it (@code{Pack}), so it has
unit fan-in coupling equals to 1.
@code{Lib_1} is similar to @code{Lib_2}, but it does define a subprogram.
So it has control fan-in coupling equals to 1 (because there is a unit
depending on it).
When computing coupling metrics, @command{gnatmetric} counts only
dependencies between units that are arguments of the gnatmetric call.
Coupling metrics are program-wide (or project-wide) metrics, so to
dependencies between units that are arguments of the @command{gnatmetric}
call. Coupling metrics are program-wide (or project-wide) metrics, so to
get a valid result, you should call @command{gnatmetric} for
the whole set of sources that make up your program. It can be done
by calling @command{gnatmetric} from the GNAT driver with @option{-U}

4
gcc/ada/s-soflin.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -289,12 +289,10 @@ package System.Soft_Links is
-------------------------------------
Library_Exception : EO;
pragma Export (Ada, Library_Exception, "__gnat_library_exception");
-- Library-level finalization routines use this common reference to store
-- the first library-level exception which occurs during finalization.
Library_Exception_Set : Boolean := False;
pragma Export (Ada, Library_Exception_Set, "__gnat_library_exception_set");
-- Used in conjunction with Library_Exception, set when an exception has
-- been stored.

12
gcc/ada/sem_case.adb
View File

@ -803,8 +803,18 @@ package body Sem_Case is
-- bounds of its base type to determine the values covered by the
-- discrete choices.
-- In Ada 2012, if the subtype has a non-static predicate the full
-- range of the base type must be covered as well.
if Is_OK_Static_Subtype (Subtyp) then
Bounds_Type := Subtyp;
if not Has_Predicates (Subtyp)
or else Present (Static_Predicate (Subtyp))
then
Bounds_Type := Subtyp;
else
Bounds_Type := Choice_Type;
end if;
else
Bounds_Type := Choice_Type;
end if;

37
gcc/ada/sem_eval.adb
View File

@ -4664,6 +4664,41 @@ package body Sem_Eval is
-- values match (RM 4.9.1(1)).
function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
function Predicates_Match return Boolean;
-- In Ada 2012, subtypes statically match if their static predicates
-- match as well.
function Predicates_Match return Boolean is
Pred1 : Node_Id;
Pred2 : Node_Id;
begin
if Ada_Version < Ada_2012 then
return True;
elsif Has_Predicates (T1) /= Has_Predicates (T2) then
return False;
else
Pred1 := Get_Rep_Item_For_Entity (T1, Name_Static_Predicate);
Pred2 := Get_Rep_Item_For_Entity (T2, Name_Static_Predicate);
-- Subtypes statically match if the predicate comes from the
-- same declaration, which can only happen if one is a subtype
-- of the other and has no explicit predicate.
-- Suppress warnings on order of actuals, which is otherwise
-- triggered by one of the two calls below.
pragma Warnings (Off);
return Pred1 = Pred2
or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
pragma Warnings (On);
end if;
end Predicates_Match;
begin
-- A type always statically matches itself
@ -4736,7 +4771,7 @@ package body Sem_Eval is
-- If the bounds are the same tree node, then match
if LB1 = LB2 and then HB1 = HB2 then
return True;
return Predicates_Match;
-- Otherwise bounds must be static and identical value