Skip to content

R
riscv-gcc-1
Commit 3aac5551 by Robert Dewar Committed by Arnaud Charlet
Options

exp_ch7.adb, [...]: Minor reformatting. 

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.

From-SVN: r213268
parent 274d2584
Showing with 170 additions and 87 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/a-suenco.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -42,7 +42,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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
......@@ -50,7 +50,8 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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)),
......@@ -159,7 +160,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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
......@@ -173,7 +174,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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
......@@ -183,7 +184,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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
......@@ -201,7 +202,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is
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
......@@ -212,24 +213,50 @@ package body Ada.Strings.UTF_Encoding.Conversions is
-- 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
......
gcc/ada/a-tasatt.adb
......@@ -70,13 +70,14 @@ package body Ada.Task_Attributes is
-- 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
......@@ -84,21 +85,25 @@ package body Ada.Task_Attributes is
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
......@@ -109,15 +114,15 @@ package body Ada.Task_Attributes is
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
--------------
......@@ -126,11 +131,13 @@ package body Ada.Task_Attributes is
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);
......@@ -168,9 +175,8 @@ package body Ada.Task_Attributes is
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;
......@@ -184,7 +190,7 @@ package body Ada.Task_Attributes is
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
......@@ -235,8 +241,11 @@ package body Ada.Task_Attributes is
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);
......@@ -264,7 +273,7 @@ package body Ada.Task_Attributes is
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
......@@ -276,14 +285,18 @@ package body Ada.Task_Attributes is
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);
......@@ -306,7 +319,7 @@ package body Ada.Task_Attributes is
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
......@@ -319,20 +332,23 @@ package body Ada.Task_Attributes is
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;
......
gcc/ada/a-tasatt.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
......@@ -41,28 +41,52 @@ generic
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;
gcc/ada/exp_ch7.adb
......@@ -5022,13 +5022,14 @@ package body Exp_Ch7 is
-- 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;
......
gcc/ada/exp_smem.adb
......@@ -189,25 +189,24 @@ package body Exp_Smem is
-- 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;
......@@ -216,6 +215,7 @@ package body Exp_Smem is
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;
......
gcc/ada/inline.adb
......@@ -1698,7 +1698,7 @@ package body Inline is
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;
......
gcc/ada/s-parame-hpux.ads
......@@ -181,7 +181,7 @@ package System.Parameters is
---------------------
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 --
......
gcc/ada/s-parame-vms-alpha.ads
......@@ -184,7 +184,7 @@ package System.Parameters is
---------------------
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 --
......
gcc/ada/s-parame-vms-ia64.ads
......@@ -184,7 +184,7 @@ package System.Parameters is
---------------------
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 --
......
gcc/ada/s-parame-vxworks.ads
......@@ -183,7 +183,7 @@ package System.Parameters is
---------------------
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 --
......
gcc/ada/s-parame.ads
......@@ -183,7 +183,7 @@ package System.Parameters is
---------------------
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 --
......
gcc/ada/s-tasini.adb
......@@ -814,6 +814,7 @@ package body System.Tasking.Initialization is
procedure Finalize_Attributes (T : Task_Id) is
Attr : Atomic_Address;
begin
for J in T.Attributes'Range loop
Attr := T.Attributes (J);
......
gcc/ada/s-tasini.ads
......@@ -38,9 +38,9 @@ package System.Tasking.Initialization is
-- 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 --
......
gcc/ada/s-taskin.ads
......@@ -942,9 +942,9 @@ package System.Tasking is
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
......
gcc/ada/s-tataat.adb
......@@ -34,19 +34,21 @@ with System.Tasking.Initialization; use System.Tasking.Initialization;
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;
......@@ -79,6 +81,10 @@ package body System.Tasking.Task_Attributes is
Task_Unlock (Self_Id);
end Finalize;
--------------------------
-- Require_Finalization --
--------------------------
function Require_Finalization (Index : Integer) return Boolean is
begin
pragma Assert (Index in Index_Array'Range);
......
gcc/ada/s-tataat.ads
......@@ -50,17 +50,16 @@ package System.Tasking.Task_Attributes is
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment