mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 08:00:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Robert Dewar 2014-07-30 13:48:04 +00:00 committed by Arnaud Charlet
parent 274d2584e5
commit 3aac555130
17 changed files with 170 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
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.

67
gcc/ada/a-suenco.adb
View File

@ -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

44
gcc/ada/a-tasatt.adb
View File

@ -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;

40
gcc/ada/a-tasatt.ads
View File

@ -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;

13
gcc/ada/exp_ch7.adb
View File

@ -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;

18
gcc/ada/exp_smem.adb
View File

@ -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));
-- Already in a transient scope. Make sure that we insert Vde outside
-- that scope.
if In_Transient then
-- Already in a transient scope: make sure we insert Vde outside
-- that scope.
Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde);
-- Not in a transient scope yet: insert Vde as an action on N prior to
-- establishing one.
else
-- Not in a transient scope yet: insert Vde as an action on N prio
-- to establishing one.
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;

2
gcc/ada/inline.adb
View File

@ -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;

2
gcc/ada/s-parame-hpux.ads
View File

@ -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 --

2
gcc/ada/s-parame-vms-alpha.ads
View File

@ -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 --

2
gcc/ada/s-parame-vms-ia64.ads
View File

@ -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 --

2
gcc/ada/s-parame-vxworks.ads
View File

@ -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 --

2
gcc/ada/s-parame.ads
View File

@ -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 --

1
gcc/ada/s-tasini.adb
View File

@ -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);

6
gcc/ada/s-tasini.ads
View File

@ -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 --

6
gcc/ada/s-taskin.ads
View File

@ -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

24
gcc/ada/s-tataat.adb
View File

@ -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);

17
gcc/ada/s-tataat.ads
View File

@ -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