+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
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
-
+with Interfaces.C;
with System.OS_Primitives;
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 --
-----------------
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.
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 --
----------
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;
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;
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;
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;
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;
-- 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
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.
-- 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 :=
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
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);
-- --
-- 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- --
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
-- --
-- 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- --
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.
-- --
-- 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- --
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);
-- 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
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;
-- 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
-- --
-- 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- --
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
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);
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
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);
-----------------
-- 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;
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
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 + $;
projects / platform / upstream / gcc.git / commitdiff