+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch7.adb, s-tataat.adb, s-tataat.ads, s-parame-vms-alpha.ads,
+ inline.adb, s-parame-hpux.ads, exp_smem.adb, s-tasini.adb,
+ s-tasini.ads, s-parame-vms-ia64.ads, s-parame.ads, s-taskin.ads,
+ s-parame-vxworks.ads, a-tasatt.adb, a-tasatt.ads: Minor reformatting.
+ * a-suenco.adb (Convert): Handle overlong encodings in UTF8-UTF8
+ conversion.
+
2014-07-30 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb: Improve error recovery.
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2014, 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- --
is
begin
-- Nothing to do if identical schemes, but for UTF_8 we need to
- -- exclude overlong encodings, so need to do the full conversion.
+ -- handle overlong encodings, so need to do the full conversion.
if Input_Scheme = Output_Scheme
and then Input_Scheme /= UTF_8
return Item;
-- For remaining cases, one or other of the operands is UTF-16BE/LE
- -- encoded, so go through UTF-16 intermediate.
+ -- encoded, or we have the UTF-8 to UTF-8 case where we must handle
+ -- overlong encodings. In all cases, go through UTF-16 intermediate.
else
return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)),
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
- -- Codes in the range 16#00# - 16#7F#
+ -- Codes in the range 16#00# .. 16#7F#
-- UTF-8: 0xxxxxxx
-- UTF-16: 00000000_0xxxxxxx
elsif C <= 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
- -- Codes in the range 16#80# - 16#7FF#
+ -- Codes in the range 16#80# .. 16#7FF#
-- UTF-8: 110yyyxx 10xxxxxx
-- UTF-16: 00000yyy_xxxxxxxx
Len := Len + 1;
Result (Len) := Wide_Character'Val (R);
- -- Codes in the range 16#800# - 16#FFFF#
+ -- Codes in the range 16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#
-- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx
-- UTF-16: yyyyyyyy_xxxxxxxx
Raise_Encoding_Error (Iptr - 3);
end if;
- -- Codes in the range 16#10000# - 16#10FFFF#
+ -- Codes in the range 16#10000# .. 16#10FFFF#
-- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
-- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx
-- Note: zzzz in the output is input zzzzz - 1
-- R now has zzzzzyyyy
- R := R - 2#0000_1_0000#;
+ -- At this stage, we check for the case where we have an overlong
+ -- encoding, and the encoded value in fact lies in the single word
+ -- range (16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#). This means
+ -- that the result fits in a single result word.
- -- R now has zzzzyyyy (zzzz minus one for the output)
+ if R <= 2#1111# then
+ Get_Continuation;
+ Get_Continuation;
- Get_Continuation;
+ -- Make sure we are not in the forbidden surrogate range
- -- R now has zzzzyyyyyyyyxx
+ if R in 16#D800# .. 16#DF00# then
+ Raise_Encoding_Error (Iptr - 3);
+ end if;
- Len := Len + 1;
- Result (Len) :=
- Wide_Character'Val
- (2#110110_00_0000_0000# or Shift_Right (R, 4));
+ -- Otherwise output a single UTF-16 value
- R := R and 2#1111#;
- Get_Continuation;
- Len := Len + 1;
- Result (Len) :=
- Wide_Character'Val (2#110111_00_0000_0000# or R);
+ Len := Len + 1;
+ Result (Len) := Wide_Character'Val (R);
+
+ -- Here for normal case (code value > 16#FFFF and zzzzz non-zero)
+
+ else
+ -- Subtract 1 from input zzzzz value to get output zzzz value
+
+ R := R - 2#0000_1_0000#;
+
+ -- R now has zzzzyyyy (zzzz minus one for the output)
+
+ Get_Continuation;
+
+ -- R now has zzzzyy_yyyyyyxx
+
+ Len := Len + 1;
+ Result (Len) :=
+ Wide_Character'Val
+ (2#110110_00_0000_0000# or Shift_Right (R, 4));
+
+ R := R and 2#1111#;
+ Get_Continuation;
+ Len := Len + 1;
+ Result (Len) :=
+ Wide_Character'Val (2#110111_00_0000_0000# or R);
+ end if;
-- Any other code is an error
-- Each value in the task control block's Attributes array is either
-- mapped to the attribute value directly if Fast_Path is True, or
-- is in effect a Real_Attribute_Access.
+ --
-- Note: the Deallocator field must be first, for compatibility with
-- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked
-- conversions between Attribute_Access and Real_Attribute_Access.
function New_Attribute (Val : Attribute) return Atomic_Address;
- -- Create a new Real_Attribute using Val, and return its address.
- -- The returned value can be converted via To_Real_Attribute.
+ -- Create a new Real_Attribute using Val, and return its address. The
+ -- returned value can be converted via To_Real_Attribute.
procedure Deallocate (Ptr : Atomic_Address);
-- Free memory associated with Ptr, a Real_Attribute_Access in reality
function To_Real_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access);
- -- Kill warning about possible size mismatch
pragma Warnings (Off);
+ -- Kill warning about possible size mismatch
+
function To_Address is new
Ada.Unchecked_Conversion (Attribute, Atomic_Address);
function To_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Attribute);
+
pragma Warnings (On);
function To_Address is new
Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
- -- Kill warning about possible aliasing
pragma Warnings (Off);
+ -- Kill warning about possible aliasing
+
function To_Handle is new
Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
+
pragma Warnings (On);
function To_Task_Id is new Ada.Unchecked_Conversion
Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
Fast_Path : constant Boolean :=
- Attribute'Size <= Atomic_Address'Size and then
- To_Address (Initial_Value) = 0;
+ Attribute'Size <= Atomic_Address'Size
+ and then To_Address (Initial_Value) = 0;
-- If the attribute fits in an Atomic_Address and Initial_Value is 0 (or
-- null), then we will map the attribute directly into
-- ATCB.Attributes (Index), otherwise we will create a level of indirection
-- and instead use Attributes (Index) as a Real_Attribute_Access.
Index : constant Integer :=
- Next_Index (Require_Finalization => not Fast_Path);
+ Next_Index (Require_Finalization => not Fast_Path);
-- Index in the task control block's Attributes array
--------------
procedure Finalize (Cleanup : in out Attribute_Cleanup) is
pragma Unreferenced (Cleanup);
+
begin
STPO.Lock_RTS;
declare
C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
+
begin
while C /= null loop
STPO.Write_Lock (C);
function New_Attribute (Val : Attribute) return Atomic_Address is
Tmp : Real_Attribute_Access;
begin
- Tmp := new Real_Attribute'
- (Free => Deallocate'Unrestricted_Access,
- Value => Val);
+ Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access,
+ Value => Val);
return To_Address (Tmp);
end New_Attribute;
is
Self_Id : Task_Id;
TT : constant Task_Id := To_Task_Id (T);
- Error_Message : constant String := "Trying to get the reference of a ";
+ Error_Message : constant String := "trying to get the reference of a ";
Result : Attribute_Handle;
begin
end if;
if Fast_Path then
+
-- No finalization needed, simply reset to Initial_Value
+
TT.Attributes (Index) := To_Address (Initial_Value);
+
else
Self_Id := STPO.Self;
Task_Lock (Self_Id);
is
Self_Id : Task_Id;
TT : constant Task_Id := To_Task_Id (T);
- Error_Message : constant String := "Trying to Set the Value of a ";
+ Error_Message : constant String := "trying to set the value of a ";
begin
if TT = null then
end if;
if Fast_Path then
+
-- No finalization needed, simply set to Val
+
TT.Attributes (Index) := To_Address (Val);
+
else
Self_Id := STPO.Self;
Task_Lock (Self_Id);
declare
Attr : Atomic_Address renames TT.Attributes (Index);
+
begin
if Attr /= 0 then
Deallocate (Attr);
is
Self_Id : Task_Id;
TT : constant Task_Id := To_Task_Id (T);
- Error_Message : constant String := "Trying to get the Value of a ";
+ Error_Message : constant String := "trying to get the value of a ";
begin
if TT = null then
if Fast_Path then
return To_Attribute (TT.Attributes (Index));
+
else
Self_Id := STPO.Self;
Task_Lock (Self_Id);
declare
Attr : Atomic_Address renames TT.Attributes (Index);
+
begin
if Attr = 0 then
Task_Unlock (Self_Id);
return Initial_Value;
+
else
declare
Result : constant Attribute :=
- To_Real_Attribute (Attr).Value;
+ To_Real_Attribute (Attr).Value;
begin
Task_Unlock (Self_Id);
return Result;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2014, 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 --
package Ada.Task_Attributes is
+ -- Note that this package will use an efficient implementation with no
+ -- locks and no extra dynamic memory allocation if Attribute can fit in a
+ -- System.Address type, and Initial_Value is 0 (null for an access type).
+
+ -- Other types and initial values are supported, but will require
+ -- the use of locking and a level of indirection (meaning extra dynamic
+ -- memory allocation).
+
+ -- The maximum number of task attributes supported by this implementation
+ -- is determined by the constant System.Parameters.Max_Attribute_Count.
+ -- If you exceed this number, Storage_Error will be raised during the
+ -- elaboration of the instantiation of this package.
+
type Attribute_Handle is access all Attribute;
function Value
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return Attribute;
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return Attribute;
+ -- Return the value of the corresponding attribute of T. Tasking_Error
+ -- is raised if T is terminated and Program_Error will be raised if T
+ -- is Null_Task_Id.
function Reference
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return Attribute_Handle;
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return Attribute_Handle;
+ -- Return an access value that designates the corresponding attribute of
+ -- T. Tasking_Error is raised if T is terminated and Program_Error will be
+ -- raised if T is Null_Task_Id.
procedure Set_Value
(Val : Attribute;
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task);
+ -- Finalize the old value of the attribute of T and assign Val to that
+ -- attribute. Tasking_Error is raised if T is terminated and Program_Error
+ -- will be raised if T is Null_Task_Id.
procedure Reinitialize
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task);
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task);
+ -- Same as Set_Value (Initial_Value, T). Tasking_Error is raised if T is
+ -- terminated and Program_Error will be raised if T is Null_Task_Id.
private
pragma Inline (Value);
+ pragma Inline (Reference);
pragma Inline (Set_Value);
pragma Inline (Reinitialize);
-
end Ada.Task_Attributes;
-- Reset the action lists
- Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped (Before) := No_List;
- Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped (After) := No_List;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
+
if Clean then
- Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped (Cleanup) := No_List;
+ Scope_Stack.Table
+ (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
end if;
end;
end Insert_Actions_In_Scope_Around;
-- subtypes in transient scopes.
Vid := Make_Temporary (Loc, 'N', Obj);
- Vde := Make_Object_Declaration (Loc,
+ Vde :=
+ Make_Object_Declaration (Loc,
Defining_Identifier => Vid,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression => Make_String_Literal (Loc, Vnm));
- if In_Transient then
-
- -- Already in a transient scope: make sure we insert Vde outside
- -- that scope.
+ -- Already in a transient scope. Make sure that we insert Vde outside
+ -- that scope.
+ if In_Transient then
Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde);
- else
- -- Not in a transient scope yet: insert Vde as an action on N prio
- -- to establishing one.
+ -- Not in a transient scope yet: insert Vde as an action on N prior to
+ -- establishing one.
+ else
Insert_Action (N, Vde);
-
Establish_Transient_Scope (N, Sec_Stack => False);
end if;
declare
Locked_Shared_Objects : Elist_Id renames
Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects;
+
begin
if Locked_Shared_Objects = No_Elist then
Locked_Shared_Objects := New_Elmt_List;
elsif Present (Body_Id)
and then (No (SPARK_Pragma (Body_Id))
or else
- Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Body_Id)) /= On)
+ Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Body_Id)) /= On)
then
return False;
---------------------
Max_Attribute_Count : constant := 32;
- -- Number of task attributes stored in the task control block.
+ -- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
---------------------
Max_Attribute_Count : constant := 32;
- -- Number of task attributes stored in the task control block.
+ -- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
---------------------
Max_Attribute_Count : constant := 32;
- -- Number of task attributes stored in the task control block.
+ -- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
---------------------
Max_Attribute_Count : constant := 16;
- -- Number of task attributes stored in the task control block.
+ -- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
---------------------
Max_Attribute_Count : constant := 32;
- -- Number of task attributes stored in the task control block.
+ -- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
procedure Finalize_Attributes (T : Task_Id) is
Attr : Atomic_Address;
+
begin
for J in T.Attributes'Range loop
Attr := T.Attributes (J);
-- Remove T from All_Tasks_List. Call this function with RTS_Lock taken
procedure Finalize_Attributes (T : Task_Id);
- -- Finalize all attributes from T
- -- This is to be called just before the ATCB is deallocated.
- -- It relies on the caller holding T.L write-lock on entry.
+ -- Finalize all attributes from T. This is to be called just before the
+ -- ATCB is deallocated. It relies on the caller holding T.L write-lock
+ -- on entry.
---------------------------------
-- Tasking-Specific Soft Links --
pragma Atomic (Atomic_Address);
type Attribute_Array is
array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address;
- -- Array of task attributes.
- -- The value (Atomic_Address) will either be converted to a task
- -- attribute if it fits, or to a pointer to a record by Ada.Task_Attributes
+ -- Array of task attributes. The value (Atomic_Address) will either be
+ -- converted to a task attribute if it fits, or to a pointer to a record
+ -- by Ada.Task_Attributes.
type Task_Serial_Number is mod 2 ** 64;
-- Used to give each task a unique serial number
package body System.Tasking.Task_Attributes is
- ----------------
- -- Next_Index --
- ----------------
-
type Index_Info is record
- Used, Require_Finalization : Boolean;
+ Used : Boolean;
+ -- Used is True if a given index is used by an instantiation of
+ -- Ada.Task_Attributes, False otherwise.
+
+ Require_Finalization : Boolean;
+ -- Require_Finalization is True if the attribute requires finalization
end record;
- -- Used is True if a given index is used by an instantiation of
- -- Ada.Task_Attributes, False otherwise.
- -- Require_Finalization is True if the attribute requires finalization.
Index_Array : array (1 .. Max_Attribute_Count) of Index_Info :=
- (others => (False, False));
+ (others => (False, False));
+
+ -- Note that this package will use an efficient implementation with no
+ -- locks and no extra dynamic memory allocation if Attribute can fit in a
+ -- System.Address type and Initial_Value is 0 (or null for an access type).
function Next_Index (Require_Finalization : Boolean) return Integer is
Self_Id : constant Task_Id := Self;
Task_Unlock (Self_Id);
end Finalize;
+ --------------------------
+ -- Require_Finalization --
+ --------------------------
+
function Require_Finalization (Index : Integer) return Boolean is
begin
pragma Assert (Index in Index_Array'Range);
Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access);
function Next_Index (Require_Finalization : Boolean) return Integer;
- -- Return the next attribute index available.
- -- Require_Finalization is True if the attribute requires finalization
- -- and in particular its deallocator (Free field in Attribute_Record)
- -- should be called.
- -- Raise Storage_Error if no index is available.
+ -- Return the next attribute index available. Require_Finalization is True
+ -- if the attribute requires finalization and in particular its deallocator
+ -- (Free field in Attribute_Record) should be called. Raise Storage_Error
+ -- if no index is available.
function Require_Finalization (Index : Integer) return Boolean;
- -- Return True if a given attribute index requires call to Free.
- -- This call is not protected against concurrent access, should only
- -- be called during finalization of the corresponding instantiation of
- -- Ada.Task_Attributes, or during finalization of a task.
+ -- Return True if a given attribute index requires call to Free. This call
+ -- is not protected against concurrent access, should only be called during
+ -- finalization of the corresponding instantiation of Ada.Task_Attributes,
+ -- or during finalization of a task.
procedure Finalize (Index : Integer);
-- Finalize given Index, possibly allowing future reuse
projects / gcc.git / commitdiff