OSDN Git Service

2012-01-23 Ed Schonberg <schonberg@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 23 Jan 2012 08:55:13 +0000 (08:55 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 23 Jan 2012 08:55:13 +0000 (08:55 +0000)
* sem_ch6.adb (Analyze_Subprogram_Declaration): Do not set the
Corresponding_Body on a defaulted null formal subprogram.
* sem_ch12.adb (Check_Formal_Package_Instance): No check needed
on a defaulted formal subprogram that is a null procedure.

2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

* exp_ch9.adb: Update the comments involving pragma Implemented.
* sem_ch3.adb (Check_Pragma_Implemented (Entity_Id)): Add local
constant Subp_Alias and local variable Impl_Subp. Properly
handle aliases of synchronized wrappers. Code cleanup.
(Check_Pragma_Implemented (Entity_Id; Entity_Id)): Add
Name_Optional as part of the condition.
* sem_prag.adb (Analyze_Pragma): Add "Optional" as one of the
valid choices of implementation kind.
(Check_Arg_Is_One_Of): New routine.
* snames.ads-tmlp: Add Name_Optional.

2012-01-23  Ed Schonberg  <schonberg@adacore.com>

* par-ch13.adb: Better error recovery in illegal aspect
specification.

2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

* a-calend.adb: Add with clause for Interfaces.C. Add constant
Unix_Max.
(Day_Of_Week): Call the internal UTC_Time_Offset.
(Split): Call the internal UTC_Time_Offset.
(Time_Of): Call the internal UTC_Time_Offset.
(Time_Zone_Operations.UTC_Time_Offset): Call internal UTC_Time_Offset.
(UTC_Time_Offset): New library-level routine.
* a-calend.ads (UTC_Time_Offset): Remove parameter
Is_Historic. Update related comment on usage.
* a-catizo.adb (UTC_Time_Offset): Removed.
(UTC_Time_Offset (Time)): Call Time_Zone_Operations.UTC_Time_Offset.
* a-caltizo.ads (UTC_Time_Offset): Removed.
(UTC_Time_Offset (Time)): Add back the default expression of parameter
Date.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183414 138bc75d-0d04-0410-961f-82ee72b054a4

12 files changed:
gcc/ada/ChangeLog
gcc/ada/a-calend.adb
gcc/ada/a-calend.ads
gcc/ada/a-catizo.adb
gcc/ada/a-catizo.ads
gcc/ada/exp_ch9.adb
gcc/ada/par-ch13.adb
gcc/ada/sem_ch12.adb
gcc/ada/sem_ch3.adb
gcc/ada/sem_ch6.adb
gcc/ada/sem_prag.adb
gcc/ada/snames.ads-tmpl

index f433549..511afc0 100644 (file)
@@ -1,3 +1,45 @@
+2012-01-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch6.adb (Analyze_Subprogram_Declaration): Do not set the
+       Corresponding_Body on a defaulted null formal subprogram.
+       * sem_ch12.adb (Check_Formal_Package_Instance): No check needed
+       on a defaulted formal subprogram that is a null procedure.
+
+2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch9.adb: Update the comments involving pragma Implemented.
+       * sem_ch3.adb (Check_Pragma_Implemented (Entity_Id)): Add local
+       constant Subp_Alias and local variable Impl_Subp. Properly
+       handle aliases of synchronized wrappers. Code cleanup.
+       (Check_Pragma_Implemented (Entity_Id; Entity_Id)): Add
+       Name_Optional as part of the condition.
+       * sem_prag.adb (Analyze_Pragma): Add "Optional" as one of the
+       valid choices of implementation kind.
+       (Check_Arg_Is_One_Of): New routine.
+       * snames.ads-tmlp: Add Name_Optional.
+
+2012-01-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * par-ch13.adb: Better error recovery in illegal aspect
+       specification.
+
+2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * a-calend.adb: Add with clause for Interfaces.C. Add constant
+       Unix_Max.
+       (Day_Of_Week): Call the internal UTC_Time_Offset.
+       (Split): Call the internal UTC_Time_Offset.
+       (Time_Of): Call the internal UTC_Time_Offset.
+       (Time_Zone_Operations.UTC_Time_Offset): Call internal UTC_Time_Offset.
+       (UTC_Time_Offset): New library-level routine.
+       * a-calend.ads (UTC_Time_Offset): Remove parameter
+       Is_Historic. Update related comment on usage.
+       * a-catizo.adb (UTC_Time_Offset): Removed.
+       (UTC_Time_Offset (Time)): Call Time_Zone_Operations.UTC_Time_Offset.
+       * a-caltizo.ads (UTC_Time_Offset): Removed.
+       (UTC_Time_Offset (Time)): Add back the default expression of parameter
+       Date.
+
 2012-01-23  Robert Dewar  <dewar@adacore.com>
 
        * sprint.ads, sprint.adb (Sprint_Node_List): Add New_Lines parameter
index f5fbbd5..731c4ed 100644 (file)
@@ -30,7 +30,7 @@
 ------------------------------------------------------------------------------
 
 with Ada.Unchecked_Conversion;
-
+with Interfaces.C;
 with System.OS_Primitives;
 
 package body Ada.Calendar is
@@ -109,6 +109,21 @@ package body Ada.Calendar is
      new Ada.Unchecked_Conversion (Time_Rep, Duration);
    --  Convert a time representation value into a duration value
 
+   function UTC_Time_Offset
+     (Date        : Time;
+      Is_Historic : Boolean) return Long_Integer;
+   --  This routine acts as an Ada wrapper around __gnat_localtime_tzoff which
+   --  in turn utilizes various OS-dependent mechanisms to calculate the time
+   --  zone offset of a date. Formal parameter Date represents an arbitrary
+   --  time stamp, either in the past, now, or in the future. If flag
+   --  Is_Historic is set, this routine would try to calculate to the best of
+   --  the OS's abilities the time zone offset that was or will be in effect
+   --  on Date. If the flag is set to False, the routine returns the current
+   --  time zone with Date effectively set to Clock.
+   --  NOTE: Targets which support localtime_r will aways return a historic
+   --  time zone even if flag Is_Historic is set to False because this is how
+   --  localtime_r operates.
+
    -----------------
    -- Local Types --
    -----------------
@@ -176,6 +191,13 @@ package body Ada.Calendar is
    Unix_Min : constant Time_Rep :=
                 Ada_Low + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day;
 
+   --  The Unix upper time bound expressed as nonoseconds since the start of
+   --  Ada time in UTC.
+
+   Unix_Max : constant Time_Rep :=
+                Ada_Low + Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day +
+                          Time_Rep (Leap_Seconds_Count) * Nano;
+
    Epoch_Offset : constant Time_Rep := (136 * 365 + 44 * 366) * Nanos_In_Day;
    --  The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in
    --  nanoseconds. Note that year 2100 is non-leap.
@@ -626,6 +648,110 @@ package body Ada.Calendar is
            Time_Zone    => 0);
    end Time_Of;
 
+   ---------------------
+   -- UTC_Time_Offset --
+   ---------------------
+
+   function UTC_Time_Offset
+     (Date        : Time;
+      Is_Historic : Boolean) return Long_Integer
+   is
+      --  The following constants denote February 28 during non-leap centennial
+      --  years, the units are nanoseconds.
+
+      T_2100_2_28 : constant Time_Rep := Ada_Low +
+                      (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day +
+                       Time_Rep (Leap_Seconds_Count)) * Nano;
+
+      T_2200_2_28 : constant Time_Rep := Ada_Low +
+                      (Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day +
+                       Time_Rep (Leap_Seconds_Count)) * Nano;
+
+      T_2300_2_28 : constant Time_Rep := Ada_Low +
+                      (Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day +
+                       Time_Rep (Leap_Seconds_Count)) * Nano;
+
+      --  56 years (14 leap years + 42 non-leap years) in nanoseconds:
+
+      Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day;
+
+      type int_Pointer  is access all Interfaces.C.int;
+      type long_Pointer is access all Interfaces.C.long;
+
+      type time_t is
+        range -(2 ** (Standard'Address_Size - Integer'(1))) ..
+              +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
+      type time_t_Pointer is access all time_t;
+
+      procedure localtime_tzoff
+        (timer       : time_t_Pointer;
+         is_historic : int_Pointer;
+         off         : long_Pointer);
+      pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
+      --  This routine is a interfacing wrapper around the library function
+      --  __gnat_localtime_tzoff. Parameter 'timer' represents a Unix-based
+      --  time equivalent of the input date. If flag 'is_historic' is set, this
+      --  routine would try to calculate to the best of the OS's abilities the
+      --  time zone offset that was or will be in effect on 'timer'. If the
+      --  flag is set to False, the routine returns the current time zone
+      --  regardless of what 'timer' designates. Parameter 'off' captures the
+      --  UTC offset of 'timer'.
+
+      Adj_Cent : Integer;
+      Date_N   : Time_Rep;
+      Flag     : aliased Interfaces.C.int;
+      Offset   : aliased Interfaces.C.long;
+      Secs_T   : aliased time_t;
+
+   --  Start of processing for UTC_Time_Offset
+
+   begin
+      Date_N := Time_Rep (Date);
+
+      --  Dates which are 56 years apart fall on the same day, day light saving
+      --  and so on. Non-leap centennial years violate this rule by one day and
+      --  as a consequence, special adjustment is needed.
+
+      Adj_Cent :=
+        (if    Date_N <= T_2100_2_28 then 0
+         elsif Date_N <= T_2200_2_28 then 1
+         elsif Date_N <= T_2300_2_28 then 2
+         else                             3);
+
+      if Adj_Cent > 0 then
+         Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day;
+      end if;
+
+      --  Shift the date within bounds of Unix time
+
+      while Date_N < Unix_Min loop
+         Date_N := Date_N + Nanos_In_56_Years;
+      end loop;
+
+      while Date_N >= Unix_Max loop
+         Date_N := Date_N - Nanos_In_56_Years;
+      end loop;
+
+      --  Perform a shift in origins from Ada to Unix
+
+      Date_N := Date_N - Unix_Min;
+
+      --  Convert the date into seconds
+
+      Secs_T := time_t (Date_N / Nano);
+
+      --  Determine whether to treat the input date as historical or not
+
+      Flag := (if Is_Historic then 1 else 0);
+
+      localtime_tzoff
+        (Secs_T'Unchecked_Access,
+         Flag'Unchecked_Access,
+         Offset'Unchecked_Access);
+
+      return Long_Integer (Offset);
+   end UTC_Time_Offset;
+
    ----------
    -- Year --
    ----------
@@ -1024,11 +1150,7 @@ package body Ada.Calendar is
 
       function Day_Of_Week (Date : Time) return Integer is
          Date_N    : constant Time_Rep := Time_Rep (Date);
-         Time_Zone : constant Long_Integer :=
-                       Time_Zones_Operations.UTC_Time_Offset
-                         (Date        => Date,
-                          Is_Historic => False);
-
+         Time_Zone : constant Long_Integer := UTC_Time_Offset (Date, True);
          Ada_Low_N : Time_Rep;
          Day_Count : Long_Integer;
          Day_Dur   : Time_Dur;
@@ -1141,9 +1263,8 @@ package body Ada.Calendar is
          else
             declare
                Off : constant Long_Integer :=
-                       Time_Zones_Operations.UTC_Time_Offset
-                         (Date        => Time (Date_N),
-                          Is_Historic => False);
+                       UTC_Time_Offset (Time (Date_N), False);
+
             begin
                Date_N := Date_N + Time_Rep (Off) * Nano;
             end;
@@ -1364,15 +1485,12 @@ package body Ada.Calendar is
          else
             declare
                Current_Off   : constant Long_Integer :=
-                                 Time_Zones_Operations.UTC_Time_Offset
-                                   (Date        => Time (Res_N),
-                                    Is_Historic => False);
+                                 UTC_Time_Offset (Time (Res_N), False);
                Current_Res_N : constant Time_Rep :=
                                  Res_N - Time_Rep (Current_Off) * Nano;
                Off           : constant Long_Integer :=
-                                 Time_Zones_Operations.UTC_Time_Offset
-                                   (Date        => Time (Current_Res_N),
-                                    Is_Historic => False);
+                                 UTC_Time_Offset (Time (Current_Res_N), False);
+
             begin
                Res_N := Res_N - Time_Rep (Off) * Nano;
             end;
@@ -1416,115 +1534,13 @@ package body Ada.Calendar is
 
    package body Time_Zones_Operations is
 
-      --  The Unix time bounds in nanoseconds: 1970/1/1 .. 2037/1/1
-
-      Unix_Min : constant Time_Rep := Ada_Low +
-                   Time_Rep (17 * 366 +  52 * 365) * Nanos_In_Day;
-
-      Unix_Max : constant Time_Rep := Ada_Low +
-                   Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day +
-                   Time_Rep (Leap_Seconds_Count) * Nano;
-
-      --  The following constants denote February 28 during non-leap
-      --  centennial years, the units are nanoseconds.
-
-      T_2100_2_28 : constant Time_Rep := Ada_Low +
-                      (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day +
-                       Time_Rep (Leap_Seconds_Count)) * Nano;
-
-      T_2200_2_28 : constant Time_Rep := Ada_Low +
-                      (Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day +
-                       Time_Rep (Leap_Seconds_Count)) * Nano;
-
-      T_2300_2_28 : constant Time_Rep := Ada_Low +
-                      (Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day +
-                       Time_Rep (Leap_Seconds_Count)) * Nano;
-
-      --  56 years (14 leap years + 42 non leap years) in nanoseconds:
-
-      Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day;
-
-      subtype long is Long_Integer;
-      subtype int  is Integer;
-      type long_Pointer is access all long;
-      type int_Pointer  is access all int;
-
-      type time_t is
-        range -(2 ** (Standard'Address_Size - Integer'(1))) ..
-              +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
-      type time_t_Pointer is access all time_t;
-
-      procedure localtime_tzoff
-        (timer       : time_t_Pointer;
-         is_historic : int_Pointer;
-         off         : long_Pointer);
-      pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
-      --  This is a lightweight wrapper around the system library function
-      --  localtime_r. Parameter 'off' captures the UTC offset which is either
-      --  retrieved from the tm struct or calculated from the 'timezone' extern
-      --  and the tm_isdst flag in the tm struct. Flag 'is_historic' denotes
-      --  whether 'timer' is a historical time stamp. If this is not the case,
-      --  the routine returns the offset of the local time zone.
-
       ---------------------
       -- UTC_Time_Offset --
       ---------------------
 
-      function UTC_Time_Offset
-        (Date        : Time;
-         Is_Historic : Boolean := True) return Long_Integer
-      is
-         Adj_Cent : Integer;
-         Date_N   : Time_Rep;
-         Flag     : aliased int;
-         Offset   : aliased long;
-         Secs_T   : aliased time_t;
-
+      function UTC_Time_Offset (Date : Time) return Long_Integer is
       begin
-         Date_N := Time_Rep (Date);
-
-         --  Dates which are 56 years apart fall on the same day, day light
-         --  saving and so on. Non-leap centennial years violate this rule by
-         --  one day and as a consequence, special adjustment is needed.
-
-         Adj_Cent :=
-           (if    Date_N <= T_2100_2_28 then 0
-            elsif Date_N <= T_2200_2_28 then 1
-            elsif Date_N <= T_2300_2_28 then 2
-            else                             3);
-
-         if Adj_Cent > 0 then
-            Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day;
-         end if;
-
-         --  Shift the date within bounds of Unix time
-
-         while Date_N < Unix_Min loop
-            Date_N := Date_N + Nanos_In_56_Years;
-         end loop;
-
-         while Date_N >= Unix_Max loop
-            Date_N := Date_N - Nanos_In_56_Years;
-         end loop;
-
-         --  Perform a shift in origins from Ada to Unix
-
-         Date_N := Date_N - Unix_Min;
-
-         --  Convert the date into seconds
-
-         Secs_T := time_t (Date_N / Nano);
-
-         --  Determine whether to treat the input date as historical or not
-
-         Flag := (if Is_Historic then 1 else 0);
-
-         localtime_tzoff
-           (Secs_T'Unchecked_Access,
-            Flag'Unchecked_Access,
-            Offset'Unchecked_Access);
-
-         return Offset;
+         return UTC_Time_Offset (Date, True);
       end UTC_Time_Offset;
 
    end Time_Zones_Operations;
index 240e62c..6178019 100644 (file)
@@ -350,12 +350,9 @@ private
 
    package Time_Zones_Operations is
 
-      function UTC_Time_Offset
-        (Date        : Time;
-         Is_Historic : Boolean := True) return Long_Integer;
-      --  Return the offset in seconds from UTC of an arbitrary date. If flag
-      --  Is_Historic is set to False, then return the local time zone offset
-      --  regardless of what Date designates.
+      function UTC_Time_Offset (Date : Time) return Long_Integer;
+      --  Return (in seconds), the difference between the local time zone and
+      --  UTC time at a specific historic date.
 
    end Time_Zones_Operations;
 
index b8f74b3..a0eb02d 100644 (file)
@@ -42,41 +42,9 @@ package body Ada.Calendar.Time_Zones is
    -- UTC_Time_Offset --
    ---------------------
 
-   function UTC_Time_Offset return Time_Offset is
+   function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is
       Offset_L : constant Long_Integer :=
-                   Time_Zones_Operations.UTC_Time_Offset
-                     (Date        => Clock,
-                      Is_Historic => False);
-      Offset   : Time_Offset;
-
-   begin
-      if Offset_L = Invalid_Time_Zone_Offset then
-         raise Unknown_Zone_Error;
-      end if;
-
-      --  The offset returned by Time_Zones_Operations.UTC_Time_Offset is in
-      --  seconds, the returned value needs to be in minutes.
-
-      Offset := Time_Offset (Offset_L / 60);
-
-      --  Validity checks
-
-      if not Offset'Valid then
-         raise Unknown_Zone_Error;
-      end if;
-
-      return Offset;
-   end UTC_Time_Offset;
-
-   ---------------------
-   -- UTC_Time_Offset --
-   ---------------------
-
-   function UTC_Time_Offset (Date : Time) return Time_Offset is
-      Offset_L : constant Long_Integer :=
-                   Time_Zones_Operations.UTC_Time_Offset
-                     (Date        => Date,
-                      Is_Historic => True);
+                   Time_Zones_Operations.UTC_Time_Offset (Date);
       Offset   : Time_Offset;
 
    begin
index cbd952d..feb0402 100644 (file)
@@ -26,12 +26,7 @@ package Ada.Calendar.Time_Zones is
 
    Unknown_Zone_Error : exception;
 
-   function UTC_Time_Offset return Time_Offset;
-   --  Returns (in minutes), the difference between the implementation-defined
-   --  time zone of Calendar, and UTC time. If the time zone of the Calendar
-   --  implementation is unknown, raises Unknown_Zone_Error.
-
-   function UTC_Time_Offset (Date : Time) return Time_Offset;
+   function UTC_Time_Offset (Date : Time := Clock) return Time_Offset;
    --  Returns (in minutes), the difference between the implementation-defined
    --  time zone of Calendar, and UTC time, at the time Date. If the time zone
    --  of the Calendar implementation is unknown, raises Unknown_Zone_Error.
index 1909d55..a20254b 100644 (file)
@@ -8878,7 +8878,8 @@ package body Exp_Ch9 is
    --    Target.Primitive (Param1, ..., ParamN);
 
    --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
-   --  marked by pragma Implemented (XXX, By_Any) or not marked at all.
+   --  marked by pragma Implemented (XXX, By_Any | Optional) or not marked
+   --  at all.
 
    --    declare
    --       S : constant Offset_Index :=
@@ -8923,9 +8924,9 @@ package body Exp_Ch9 is
       function Build_Dispatching_Requeue_To_Any return Node_Id;
       --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
       --  the form Concval.Ename. Ename is either marked by pragma Implemented
-      --  (XXX, By_Any) or not marked at all. Create a block which determines
-      --  at runtime whether Ename denotes an entry or a procedure and perform
-      --  the appropriate kind of dispatching select.
+      --  (XXX, By_Any | Optional) or not marked at all. Create a block which
+      --  determines at runtime whether Ename denotes an entry or a procedure
+      --  and perform the appropriate kind of dispatching select.
 
       function Build_Normal_Requeue return Node_Id;
       --  N denotes a non-dispatching requeue statement to either a task or a
@@ -9445,9 +9446,10 @@ package body Exp_Ch9 is
                Analyze (N);
 
             --  The procedure_or_entry_NAME's implementation kind is either
-            --  By_Any or pragma Implemented was not applied at all. In this
-            --  case a runtime test determines whether Ename denotes an entry
-            --  or a protected procedure and performs the appropriate call.
+            --  By_Any, Optional, or pragma Implemented was not applied at all.
+            --  In this case a runtime test determines whether Ename denotes an
+            --  entry or a protected procedure and performs the appropriate
+            --  call.
 
             else
                Rewrite (N, Build_Dispatching_Requeue_To_Any);
index 82e96ce..107426f 100644 (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- --
@@ -514,12 +514,24 @@ package body Ch13 is
 
             if Token = Tok_Comma
               or else Token = Tok_Semicolon
-              or else (not Semicolon and then Token /= Tok_Arrow)
+
             then
+               --  or else (not Semicolon and then Token /= Tok_Arrow)
                if Aspect_Argument (A_Id) /= Optional then
-                  Error_Msg_Node_1 := Aspect;
+                  Error_Msg_Node_1 := Identifier (Aspect);
                   Error_Msg_AP ("aspect& requires an aspect definition");
                   OK := False;
+
+               end if;
+
+            elsif not Semicolon and then Token /= Tok_Arrow then
+               if Aspect_Argument (A_Id) /= Optional then
+
+                  --  The name or expression may be there, but the arrow is
+                  --  missing. Skip to the end of the declaration.
+
+                  T_Arrow;
+                  Resync_To_Semicolon;
                end if;
 
             --  Here we have an aspect definition
index cbc8b4d..31c9293 100644 (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- --
@@ -5104,6 +5104,15 @@ package body Sem_Ch12 is
             then
                null;
 
+            --  No check needed if subprogram is a defaulted null procedure
+
+            elsif No (Alias (E2))
+              and then Ekind (E2) = E_Procedure
+              and then
+                Null_Present (Specification (Unit_Declaration_Node (E2)))
+            then
+               null;
+
             --  Otherwise the actual in the formal and the actual in the
             --  instantiation of the formal must match, up to renamings.
 
index 88ef267..9e31930 100644 (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- --
@@ -8897,17 +8897,27 @@ package body Sem_Ch3 is
       procedure Check_Pragma_Implemented (Subp : Entity_Id) is
          Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
          Impl_Kind   : constant Name_Id   := Implementation_Kind (Iface_Alias);
+         Subp_Alias  : constant Entity_Id := Alias (Subp);
          Contr_Typ   : Entity_Id;
+         Impl_Subp   : Entity_Id;
 
       begin
          --  Subp must have an alias since it is a hidden entity used to link
          --  an interface subprogram to its overriding counterpart.
 
-         pragma Assert (Present (Alias (Subp)));
+         pragma Assert (Present (Subp_Alias));
+
+         --  Handle aliases to synchronized wrappers
+
+         Impl_Subp := Subp_Alias;
+
+         if Is_Primitive_Wrapper (Impl_Subp) then
+            Impl_Subp := Wrapped_Entity (Impl_Subp);
+         end if;
 
          --  Extract the type of the controlling formal
 
-         Contr_Typ := Etype (First_Formal (Alias (Subp)));
+         Contr_Typ := Etype (First_Formal (Subp_Alias));
 
          if Is_Concurrent_Record_Type (Contr_Typ) then
             Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
@@ -8917,12 +8927,12 @@ package body Sem_Ch3 is
          --  be implemented by an entry.
 
          if Impl_Kind = Name_By_Entry
-           and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
+           and then Ekind (Impl_Subp) /= E_Entry
          then
             Error_Msg_Node_2 := Iface_Alias;
             Error_Msg_NE
               ("type & must implement abstract subprogram & with an entry",
-               Alias (Subp), Contr_Typ);
+               Subp_Alias, Contr_Typ);
 
          elsif Impl_Kind = Name_By_Protected_Procedure then
 
@@ -8934,19 +8944,17 @@ package body Sem_Ch3 is
                Error_Msg_Node_2 := Contr_Typ;
                Error_Msg_NE
                  ("interface subprogram & cannot be implemented by a " &
-                  "primitive procedure of task type &", Alias (Subp),
+                  "primitive procedure of task type &", Subp_Alias,
                   Iface_Alias);
 
             --  An interface subprogram whose implementation kind is By_
             --  Protected_Procedure must be implemented by a procedure.
 
-            elsif Is_Primitive_Wrapper (Alias (Subp))
-              and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
-            then
+            elsif Ekind (Impl_Subp) /= E_Procedure then
                Error_Msg_Node_2 := Iface_Alias;
                Error_Msg_NE
                  ("type & must implement abstract subprogram & with a " &
-                  "procedure", Alias (Subp), Contr_Typ);
+                  "procedure", Subp_Alias, Contr_Typ);
             end if;
          end if;
       end Check_Pragma_Implemented;
@@ -8966,10 +8974,11 @@ package body Sem_Ch3 is
          --  Ada 2012 (AI05-0030): The implementation kinds of an overridden
          --  and overriding subprogram are different. In general this is an
          --  error except when the implementation kind of the overridden
-         --  subprograms is By_Any.
+         --  subprograms is By_Any or Optional.
 
          if Iface_Kind /= Subp_Kind
            and then Iface_Kind /= Name_By_Any
+           and then Iface_Kind /= Name_Optional
          then
             if Iface_Kind = Name_By_Entry then
                Error_Msg_N
index 4286c0d..cd65caa 100644 (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- --
@@ -3138,7 +3138,6 @@ package body Sem_Ch6 is
 
          Set_Defining_Unit_Name (Specification (Null_Body),
            Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
-         Set_Corresponding_Body (N, Defining_Entity (Null_Body));
 
          Form := First (Parameter_Specifications (Specification (Null_Body)));
          while Present (Form) loop
@@ -3192,7 +3191,13 @@ package body Sem_Ch6 is
       then
          Set_Has_Completion (Designator);
 
-         if Present (Null_Body) then
+         --  Null procedures are always inlined, but generic formal subprograms
+         --  which appear as such in the internal instance of formal packages,
+         --  need no completion and are not marked Inline.
+
+         if Present (Null_Body)
+           and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration
+         then
             Set_Corresponding_Body (N, Defining_Entity (Null_Body));
             Set_Body_To_Inline (N, Null_Body);
             Set_Is_Inlined (Designator);
index d1e20b6..59640de 100644 (file)
@@ -473,6 +473,9 @@ package body Sem_Prag is
          N1, N2, N3         : Name_Id);
       procedure Check_Arg_Is_One_Of
         (Arg                : Node_Id;
+         N1, N2, N3, N4     : Name_Id);
+      procedure Check_Arg_Is_One_Of
+        (Arg                : Node_Id;
          N1, N2, N3, N4, N5 : Name_Id);
       --  Check the specified argument Arg to make sure that it is an
       --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
@@ -1178,6 +1181,24 @@ package body Sem_Prag is
 
       procedure Check_Arg_Is_One_Of
         (Arg                : Node_Id;
+         N1, N2, N3, N4     : Name_Id)
+      is
+         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+      begin
+         Check_Arg_Is_Identifier (Argx);
+
+         if Chars (Argx) /= N1
+           and then Chars (Argx) /= N2
+           and then Chars (Argx) /= N3
+           and then Chars (Argx) /= N4
+         then
+            Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+         end if;
+      end Check_Arg_Is_One_Of;
+
+      procedure Check_Arg_Is_One_Of
+        (Arg                : Node_Id;
          N1, N2, N3, N4, N5 : Name_Id)
       is
          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
@@ -9325,7 +9346,11 @@ package body Sem_Prag is
          -----------------
 
          --  pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
-         --  implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
+         --  implementation_kind ::=
+         --    By_Entry | By_Protected_Procedure | By_Any | Optional
+
+         --  "By_Any" and "Optional" are treated as synonyms in order to
+         --  support Ada 2012 aspect Synchronization.
 
          when Pragma_Implemented => Implemented : declare
             Proc_Id : Entity_Id;
@@ -9337,8 +9362,11 @@ package body Sem_Prag is
             Check_No_Identifiers;
             Check_Arg_Is_Identifier (Arg1);
             Check_Arg_Is_Local_Name (Arg1);
-            Check_Arg_Is_One_Of
-              (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+            Check_Arg_Is_One_Of (Arg2,
+              Name_By_Any,
+              Name_By_Entry,
+              Name_By_Protected_Procedure,
+              Name_Optional);
 
             --  Extract the name of the local procedure
 
index 6afd6c3..a091047 100644 (file)
@@ -678,6 +678,7 @@ package Snames is
    Name_No_Task_Attributes_Package     : constant Name_Id := N + $;
    Name_Nominal                        : constant Name_Id := N + $;
    Name_On                             : constant Name_Id := N + $;
+   Name_Optional                       : constant Name_Id := N + $;
    Name_Policy                         : constant Name_Id := N + $;
    Name_Parameter_Types                : constant Name_Id := N + $;
    Name_Reference                      : constant Name_Id := N + $;