+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
-- --
------------------------------------------------------------------------------
--- 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;
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;
-- 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");
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.
---------------------------
package Conversion_Operations is
+
function To_Ada_Time (Unix_Time : Long_Integer) return Time;
-- Unix to Ada Epoch conversion
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
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_
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;
-- --
-- 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- --
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 --
------------------------
-- --
-- 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 --
-- 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
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;
-- 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;");
-
- Set_String (" pragma Import (Ada, LE, ");
- Set_String ("""__gnat_library_exception"");");
- Write_Statement_Buffer;
-
- Set_String (" procedure Raise_From_Controlled_");
- Set_String ("Operation (X : Ada.Exceptions.Exception_");
- Set_String ("Occurrence);");
- Write_Statement_Buffer;
+ WBI (" declare");
+ WBI (" procedure Reraise_Library_Exception_If_Any;");
- Set_String (" pragma Import (Ada, Raise_From_");
- Set_String ("Controlled_Operation, ");
- Set_String ("""__gnat_raise_from_controlled_operation"");");
+ Set_String (" pragma Import (Ada, ");
+ Set_String ("Reraise_Library_Exception_If_Any, ");
+ Set_String ("""__gnat_reraise_library_exception_if_any"");");
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
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;
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}
-- --
-- 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- --
-------------------------------------
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.
-- 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;
-- 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
-- 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
projects / platform / upstream / gcc.git / commitdiff