OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2012-07-12  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb, exp_ch9.adb, sem_ch9.adb, exp_aggr.adb: Minor
	reformatting.

2012-07-12  Vincent Pucci  <pucci@adacore.com>

	* sem_dim.adb (Analyze_Dimension_Function_Call): Reformatting of error
	msgs for elementary functions.

2012-07-12  Vincent Pucci  <pucci@adacore.com>

	* sem_attr.adb (Eval_Attribute): Minor reformatting.

2012-07-12  Pascal Obry  <obry@adacore.com>

	* prj-nmsc.adb (Check_Library_Attributes): Allow the same library
	project in different project tree (different aggregated projects).

2012-07-12  Thomas Quinot  <quinot@adacore.com>

	* s-bytswa.adb, g-bytswa.adb, g-bytswa.ads, s-bytswa.ads: Further
	reorganization of byte swapping routines.

2012-07-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Check_Dispatching_Context): Refine legality
	checks on tagg indeterminate calls to abstract operations,
	that appear in the context of other calls.

From-SVN: r189436
This commit is contained in:
Arnaud Charlet 2012-07-12 12:37:17 +02:00
parent 1e4b91fc4f
commit 8926d36939
13 changed files with 440 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/ChangeLog
View File

@ -1,3 +1,33 @@
2012-07-12 Robert Dewar <dewar@adacore.com>
* exp_attr.adb, exp_ch9.adb, sem_ch9.adb, exp_aggr.adb: Minor
reformatting.
2012-07-12 Vincent Pucci <pucci@adacore.com>
* sem_dim.adb (Analyze_Dimension_Function_Call): Reformatting of error
msgs for elementary functions.
2012-07-12 Vincent Pucci <pucci@adacore.com>
* sem_attr.adb (Eval_Attribute): Minor reformatting.
2012-07-12 Pascal Obry <obry@adacore.com>
* prj-nmsc.adb (Check_Library_Attributes): Allow the same library
project in different project tree (different aggregated projects).
2012-07-12 Thomas Quinot <quinot@adacore.com>
* s-bytswa.adb, g-bytswa.adb, g-bytswa.ads, s-bytswa.ads: Further
reorganization of byte swapping routines.
2012-07-12 Ed Schonberg <schonberg@adacore.com>
* sem_disp.adb (Check_Dispatching_Context): Refine legality
checks on tagg indeterminate calls to abstract operations,
that appear in the context of other calls.
2012-07-12 Thomas Quinot <quinot@adacore.com>
* s-bytswa.adb (Swapped2.Bswap16): Remove local function,

19
gcc/ada/exp_aggr.adb
View File

@ -294,8 +294,8 @@ package body Exp_Aggr is
-- The normal limit is 5000, but we increase this limit to 2**24 (about
-- 16 million) if Restrictions (No_Elaboration_Code) or Restrictions
-- (No_Implicit_Loops) is specified, since in either case we are at risk
-- of declaring the program illegal because of this limit. We also
-- (No_Implicit_Loops) is specified, since in either case we are at
-- risk of declaring the program illegal because of this limit. We also
-- increase the limit when Static_Elaboration_Desired, given that this
-- means that objects are intended to be placed in data memory.
@ -3517,9 +3517,9 @@ package body Exp_Aggr is
-- Check for maximum others replication. Note that
-- we skip this test if either of the restrictions
-- No_Elaboration_Code or No_Implicit_Loops is
-- active, if this is a preelaborable unit or a
-- predefined unit, or if the unit must be placed
-- in data memory. This also ensures that
-- active, if this is a preelaborable unit or
-- a predefined unit, or if the unit must be
-- placed in data memory. This also ensures that
-- predefined units get the same level of constant
-- folding in Ada 95 and Ada 2005, where their
-- categorization has changed.
@ -3537,7 +3537,8 @@ package body Exp_Aggr is
or else
(Ekind (Current_Scope) = E_Package
and then
Static_Elaboration_Desired (Current_Scope))
Static_Elaboration_Desired
(Current_Scope))
or else Is_Preelaborated (P)
or else (Ekind (P) = E_Package_Body
and then
@ -3746,11 +3747,13 @@ package body Exp_Aggr is
and then Ekind (Entity (Expr)) = E_Enumeration_Literal)
then
null;
else
Error_Msg_N ("non-static object "
& " requires elaboration code?", N);
Error_Msg_N
("non-static object requires elaboration code?", N);
exit;
end if;
Next (Expr);
end loop;

6
gcc/ada/exp_attr.adb
View File

@ -816,9 +816,9 @@ package body Exp_Attr is
if Is_Protected_Self_Reference (Pref)
and then not
(Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
N_Discriminant_Association)
and then Nkind (Parent (Parent (Parent (Parent (N))))) =
(Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
N_Discriminant_Association)
and then Nkind (Parent (Parent (Parent (Parent (N))))) =
N_Component_Definition)
-- No action needed for these attributes since the current instance

32
gcc/ada/exp_ch9.adb
View File

@ -3084,7 +3084,7 @@ package body Exp_Ch9 is
-- protected component.
if Present (Comp) then
declare
Protected_Component_Ref : declare
Comp_Decl : constant Node_Id := Parent (Comp);
Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
Comp_Type : constant Entity_Id := Etype (Comp);
@ -3220,7 +3220,6 @@ package body Exp_Ch9 is
procedure Process_Stmts (Stmts : List_Id) is
Stmt : Node_Id;
begin
Stmt := First (Stmts);
while Present (Stmt) loop
@ -3229,6 +3228,8 @@ package body Exp_Ch9 is
end loop;
end Process_Stmts;
-- Start of processing for Protected_Component_Ref
begin
-- Get the type size
@ -3436,23 +3437,24 @@ package body Exp_Ch9 is
-- end loop;
if Is_Procedure then
Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)),
Make_Loop_Statement (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts))),
End_Label => Empty));
Stmts :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)),
Make_Loop_Statement (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts))),
End_Label => Empty));
end if;
Hand_Stmt_Seq :=
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
end;
end Protected_Component_Ref;
end if;
-- Make an unprotected version of the subprogram for use within the same

89
gcc/ada/g-bytswa.adb
View File

@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . B Y T E _ S W A P P I N G --
-- G N A T . B Y T E _ S W A P P I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 1995-2012, AdaCore --
-- Copyright (C) 2006-2012, AdaCore --
-- --
-- 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- --
@ -29,8 +29,85 @@
-- --
------------------------------------------------------------------------------
-- This package does not require a body, since it is a package renaming. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
-- This is a general implementation that uses GCC intrinsics to take
-- advantage of any machine-specific instructions.
pragma No_Body;
with Ada.Unchecked_Conversion; use Ada;
with System.Byte_Swapping; use System.Byte_Swapping;
package body GNAT.Byte_Swapping is
--------------
-- Swapped2 --
--------------
function Swapped2 (Input : Item) return Item is
function As_U16 is new Unchecked_Conversion (Item, U16);
function As_Item is new Unchecked_Conversion (U16, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2,
"storage size must be 2 bytes");
begin
return As_Item (Bswap_16 (As_U16 (Input)));
end Swapped2;
--------------
-- Swapped4 --
--------------
function Swapped4 (Input : Item) return Item is
function As_U32 is new Unchecked_Conversion (Item, U32);
function As_Item is new Unchecked_Conversion (U32, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 4,
"storage size must be 4 bytes");
begin
return As_Item (Bswap_32 (As_U32 (Input)));
end Swapped4;
--------------
-- Swapped8 --
--------------
function Swapped8 (Input : Item) return Item is
function As_U64 is new Unchecked_Conversion (Item, U64);
function As_Item is new Unchecked_Conversion (U64, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 8,
"storage size must be 8 bytes");
begin
return As_Item (Bswap_64 (As_U64 (Input)));
end Swapped8;
-----------
-- Swap2 --
-----------
procedure Swap2 (Location : System.Address) is
X : U16;
for X'Address use Location;
begin
X := Bswap_16 (X);
end Swap2;
-----------
-- Swap4 --
-----------
procedure Swap4 (Location : System.Address) is
X : U32;
for X'Address use Location;
begin
X := Bswap_32 (X);
end Swap4;
-----------
-- Swap8 --
-----------
procedure Swap8 (Location : System.Address) is
X : U64;
for X'Address use Location;
begin
X := Bswap_64 (X);
end Swap8;
end GNAT.Byte_Swapping;

176
gcc/ada/g-bytswa.ads
View File

@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . B Y T E _ S W A P P I N G --
-- G N A T . B Y T E _ S W A P P I N G --
-- --
-- S p e c --
-- --
@ -31,8 +31,176 @@
-- Simple routines for swapping the bytes of 16-, 32-, and 64-bit objects
-- See file s-bytswa.ads for full documentation of the interface
-- The generic functions should be instantiated with types that are of a size
-- in bytes corresponding to the name of the generic. For example, a 2-byte
-- integer type would be compatible with Swapped2, 4-byte integer with
-- Swapped4, and so on. Failure to do so will result in a warning when
-- compiling the instantiation; this warning should be heeded. Ignoring this
-- warning can result in unexpected results.
with System.Byte_Swapping;
-- An example of proper usage follows:
package GNAT.Byte_Swapping renames System.Byte_Swapping;
-- declare
-- type Short_Integer is range -32768 .. 32767;
-- for Short_Integer'Size use 16; -- for confirmation
-- X : Short_Integer := 16#7FFF#;
-- function Swapped is new Byte_Swapping.Swapped2 (Short_Integer);
-- begin
-- Put_Line (X'Img);
-- X := Swapped (X);
-- Put_Line (X'Img);
-- end;
-- Note that the generic actual types need not be scalars, but must be
-- 'definite' types. They can, for example, be constrained subtypes of
-- unconstrained array types as long as the size is correct. For instance,
-- a subtype of String with length of 4 would be compatible with the
-- Swapped4 generic:
-- declare
-- subtype String4 is String (1 .. 4);
-- function Swapped is new Byte_Swapping.Swapped4 (String4);
-- S : String4 := "ABCD";
-- for S'Alignment use 4;
-- begin
-- Put_Line (S);
-- S := Swapped (S);
-- Put_Line (S);
-- end;
-- Similarly, a constrained array type is also acceptable:
-- declare
-- type Mask is array (0 .. 15) of Boolean;
-- for Mask'Alignment use 2;
-- for Mask'Component_Size use Boolean'Size;
-- X : Mask := (0 .. 7 => True, others => False);
-- function Swapped is new Byte_Swapping.Swapped2 (Mask);
-- begin
-- ...
-- X := Swapped (X);
-- ...
-- end;
-- A properly-sized record type will also be acceptable, and so forth
-- However, as described, a size mismatch must be avoided. In the following we
-- instantiate one of the generics with a type that is too large. The result
-- of the function call is undefined, such that assignment to an object can
-- result in garbage values.
-- Wrong: declare
-- subtype String16 is String (1 .. 16);
-- function Swapped is new Byte_Swapping.Swapped8 (String16);
-- -- Instantiation generates a compiler warning about
-- -- mismatched sizes
-- S : String16;
-- begin
-- S := "ABCDEFGHDEADBEEF";
--
-- Put_Line (S);
--
-- -- the following assignment results in garbage in S after the
-- -- first 8 bytes
--
-- S := Swapped (S);
--
-- Put_Line (S);
-- end Wrong;
-- When the size of the type is larger than 8 bytes, the use of the non-
-- generic procedures is an alternative because no function result is
-- involved; manipulation of the object is direct.
-- The procedures are passed the address of an object to manipulate. They will
-- swap the first N bytes of that object corresponding to the name of the
-- procedure. For example:
-- declare
-- S2 : String := "AB";
-- for S2'Alignment use 2;
-- S4 : String := "ABCD";
-- for S4'Alignment use 4;
-- S8 : String := "ABCDEFGH";
-- for S8'Alignment use 8;
-- begin
-- Swap2 (S2'Address);
-- Put_Line (S2);
-- Swap4 (S4'Address);
-- Put_Line (S4);
-- Swap8 (S8'Address);
-- Put_Line (S8);
-- end;
-- If an object of a type larger than N is passed, the remaining bytes of the
-- object are undisturbed. For example:
-- declare
-- subtype String16 is String (1 .. 16);
-- S : String16;
-- for S'Alignment use 8;
-- begin
-- S := "ABCDEFGHDEADBEEF";
-- Put_Line (S);
-- Swap8 (S'Address);
-- Put_Line (S);
-- end;
with System;
package GNAT.Byte_Swapping is
pragma Pure;
-- NB: all the routines in this package treat the application objects as
-- unsigned (modular) types of a size in bytes corresponding to the routine
-- name. For example, the generic function Swapped2 manipulates the object
-- passed to the formal parameter Input as a value of an unsigned type that
-- is 2 bytes long. Therefore clients are responsible for the compatibility
-- of application types manipulated by these routines and these modular
-- types, in terms of both size and alignment. This requirement applies to
-- the generic actual type passed to the generic formal type Item in the
-- generic functions, as well as to the type of the object implicitly
-- designated by the address passed to the non-generic procedures. Use of
-- incompatible types can result in implementation- defined effects.
generic
type Item is limited private;
function Swapped2 (Input : Item) return Item;
-- Return the 2-byte value of Input with the bytes swapped
generic
type Item is limited private;
function Swapped4 (Input : Item) return Item;
-- Return the 4-byte value of Input with the bytes swapped
generic
type Item is limited private;
function Swapped8 (Input : Item) return Item;
-- Return the 8-byte value of Input with the bytes swapped
procedure Swap2 (Location : System.Address);
-- Swap the first 2 bytes of the object starting at the address specified
-- by Location.
procedure Swap4 (Location : System.Address);
-- Swap the first 4 bytes of the object starting at the address specified
-- by Location.
procedure Swap8 (Location : System.Address);
-- Swap the first 8 bytes of the object starting at the address specified
-- by Location.
pragma Inline (Swap2, Swap4, Swap8, Swapped2, Swapped4, Swapped8);
end GNAT.Byte_Swapping;

9
gcc/ada/prj-nmsc.adb
View File

@ -165,6 +165,7 @@ package body Prj.Nmsc is
type Lib_Data is record
Name : Name_Id;
Proj : Project_Id;
Tree : Project_Tree_Ref;
end record;
package Lib_Data_Table is new GNAT.Table
@ -3639,7 +3640,9 @@ package body Prj.Nmsc is
-- Check if the same library name is used in an other library project
for J in 1 .. Lib_Data_Table.Last loop
if Lib_Data_Table.Table (J).Name = Project.Library_Name then
if Lib_Data_Table.Table (J).Name = Project.Library_Name
and then Lib_Data_Table.Table (J).Tree = Data.Tree
then
Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
Error_Msg
(Data.Flags,
@ -3656,7 +3659,9 @@ package body Prj.Nmsc is
-- Record the library name
Lib_Data_Table.Append
((Name => Project.Library_Name, Proj => Project));
((Name => Project.Library_Name,
Proj => Project,
Tree => Data.Tree));
end if;
end Check_Library_Attributes;

124
gcc/ada/s-bytswa.adb
View File

@ -1,124 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . B Y T E _ S W A P P I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is a general implementation that uses GCC intrinsics to take
-- advantage of any machine-specific instructions.
with Ada.Unchecked_Conversion; use Ada;
package body System.Byte_Swapping is
type U16 is mod 2**16;
type U32 is mod 2**32;
type U64 is mod 2**64;
function Bswap_16 (X : U16) return U16;
pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16");
function Bswap_32 (X : U32) return U32;
pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32");
function Bswap_64 (X : U64) return U64;
pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64");
--------------
-- Swapped2 --
--------------
function Swapped2 (Input : Item) return Item is
function As_U16 is new Unchecked_Conversion (Item, U16);
function As_Item is new Unchecked_Conversion (U16, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2,
"storage size must be 2 bytes");
begin
return As_Item (Bswap_16 (As_U16 (Input)));
end Swapped2;
--------------
-- Swapped4 --
--------------
function Swapped4 (Input : Item) return Item is
function As_U32 is new Unchecked_Conversion (Item, U32);
function As_Item is new Unchecked_Conversion (U32, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 4,
"storage size must be 4 bytes");
begin
return As_Item (Bswap_32 (As_U32 (Input)));
end Swapped4;
--------------
-- Swapped8 --
--------------
function Swapped8 (Input : Item) return Item is
function As_U64 is new Unchecked_Conversion (Item, U64);
function As_Item is new Unchecked_Conversion (U64, Item);
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 8,
"storage size must be 8 bytes");
begin
return As_Item (Bswap_64 (As_U64 (Input)));
end Swapped8;
-----------
-- Swap2 --
-----------
procedure Swap2 (Location : System.Address) is
X : U16;
for X'Address use Location;
begin
X := Bswap_16 (X);
end Swap2;
-----------
-- Swap4 --
-----------
procedure Swap4 (Location : System.Address) is
X : U32;
for X'Address use Location;
begin
X := Bswap_32 (X);
end Swap4;
-----------
-- Swap8 --
-----------
procedure Swap8 (Location : System.Address) is
X : U64;
for X'Address use Location;
begin
X := Bswap_64 (X);
end Swap8;
end System.Byte_Swapping;

178
gcc/ada/s-bytswa.ads
View File

@ -29,178 +29,24 @@
-- --
------------------------------------------------------------------------------
-- Simple routines for swapping the bytes of 16-, 32-, and 64-bit objects
-- The generic functions should be instantiated with types that are of a size
-- in bytes corresponding to the name of the generic. For example, a 2-byte
-- integer type would be compatible with Swapped2, 4-byte integer with
-- Swapped4, and so on. Failure to do so will result in a warning when
-- compiling the instantiation; this warning should be heeded. Ignoring this
-- warning can result in unexpected results.
-- An example of proper usage follows:
-- declare
-- type Short_Integer is range -32768 .. 32767;
-- for Short_Integer'Size use 16; -- for confirmation
-- X : Short_Integer := 16#7FFF#;
-- function Swapped is new Byte_Swapping.Swapped2 (Short_Integer);
-- begin
-- Put_Line (X'Img);
-- X := Swapped (X);
-- Put_Line (X'Img);
-- end;
-- Note that the generic actual types need not be scalars, but must be
-- 'definite' types. They can, for example, be constrained subtypes of
-- unconstrained array types as long as the size is correct. For instance,
-- a subtype of String with length of 4 would be compatible with the
-- Swapped4 generic:
-- declare
-- subtype String4 is String (1 .. 4);
-- function Swapped is new Byte_Swapping.Swapped4 (String4);
-- S : String4 := "ABCD";
-- for S'Alignment use 4;
-- begin
-- Put_Line (S);
-- S := Swapped (S);
-- Put_Line (S);
-- end;
-- Similarly, a constrained array type is also acceptable:
-- declare
-- type Mask is array (0 .. 15) of Boolean;
-- for Mask'Alignment use 2;
-- for Mask'Component_Size use Boolean'Size;
-- X : Mask := (0 .. 7 => True, others => False);
-- function Swapped is new Byte_Swapping.Swapped2 (Mask);
-- begin
-- ...
-- X := Swapped (X);
-- ...
-- end;
-- A properly-sized record type will also be acceptable, and so forth
-- However, as described, a size mismatch must be avoided. In the following we
-- instantiate one of the generics with a type that is too large. The result
-- of the function call is undefined, such that assignment to an object can
-- result in garbage values.
-- Wrong: declare
-- subtype String16 is String (1 .. 16);
-- function Swapped is new Byte_Swapping.Swapped8 (String16);
-- -- Instantiation generates a compiler warning about
-- -- mismatched sizes
-- S : String16;
-- begin
-- S := "ABCDEFGHDEADBEEF";
--
-- Put_Line (S);
--
-- -- the following assignment results in garbage in S after the
-- -- first 8 bytes
--
-- S := Swapped (S);
--
-- Put_Line (S);
-- end Wrong;
-- When the size of the type is larger than 8 bytes, the use of the non-
-- generic procedures is an alternative because no function result is
-- involved; manipulation of the object is direct.
-- The procedures are passed the address of an object to manipulate. They will
-- swap the first N bytes of that object corresponding to the name of the
-- procedure. For example:
-- declare
-- S2 : String := "AB";
-- for S2'Alignment use 2;
-- S4 : String := "ABCD";
-- for S4'Alignment use 4;
-- S8 : String := "ABCDEFGH";
-- for S8'Alignment use 8;
-- begin
-- Swap2 (S2'Address);
-- Put_Line (S2);
-- Swap4 (S4'Address);
-- Put_Line (S4);
-- Swap8 (S8'Address);
-- Put_Line (S8);
-- end;
-- If an object of a type larger than N is passed, the remaining bytes of the
-- object are undisturbed. For example:
-- declare
-- subtype String16 is String (1 .. 16);
-- S : String16;
-- for S'Alignment use 8;
-- begin
-- S := "ABCDEFGHDEADBEEF";
-- Put_Line (S);
-- Swap8 (S'Address);
-- Put_Line (S);
-- end;
with System;
-- Supporting routines for GNAT.Byte_Swapping, also used directly by
-- expended code.
package System.Byte_Swapping is
pragma Pure;
-- NB: all the routines in this package treat the application objects as
-- unsigned (modular) types of a size in bytes corresponding to the routine
-- name. For example, the generic function Swapped2 manipulates the object
-- passed to the formal parameter Input as a value of an unsigned type that
-- is 2 bytes long. Therefore clients are responsible for the compatibility
-- of application types manipulated by these routines and these modular
-- types, in terms of both size and alignment. This requirement applies to
-- the generic actual type passed to the generic formal type Item in the
-- generic functions, as well as to the type of the object implicitly
-- designated by the address passed to the non-generic procedures. Use of
-- incompatible types can result in implementation- defined effects.
type U16 is mod 2**16;
type U32 is mod 2**32;
type U64 is mod 2**64;
generic
type Item is limited private;
function Swapped2 (Input : Item) return Item;
-- Return the 2-byte value of Input with the bytes swapped
function Bswap_16 (X : U16) return U16;
pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16");
generic
type Item is limited private;
function Swapped4 (Input : Item) return Item;
-- Return the 4-byte value of Input with the bytes swapped
function Bswap_32 (X : U32) return U32;
pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32");
generic
type Item is limited private;
function Swapped8 (Input : Item) return Item;
-- Return the 8-byte value of Input with the bytes swapped
procedure Swap2 (Location : System.Address);
-- Swap the first 2 bytes of the object starting at the address specified
-- by Location.
procedure Swap4 (Location : System.Address);
-- Swap the first 4 bytes of the object starting at the address specified
-- by Location.
procedure Swap8 (Location : System.Address);
-- Swap the first 8 bytes of the object starting at the address specified
-- by Location.
pragma Inline (Swap2, Swap4, Swap8, Swapped2, Swapped4, Swapped8);
function Bswap_64 (X : U64) return U64;
pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64");
end System.Byte_Swapping;

9
gcc/ada/sem_attr.adb
View File

@ -6322,11 +6322,12 @@ package body Sem_Attr is
Attribute_Iterator_Element |
Attribute_Variable_Indexing => null;
-- Atributes related to Ada 2012 aspects
-- Internal attributes used to deal with Ada 2012 delayed aspects.
-- These were already rejected by the parser. Thus they shouldn't
-- appear here.
when Attribute_CPU |
Attribute_Dispatching_Domain |
Attribute_Interrupt_Priority => null;
when Internal_Attribute_Id =>
raise Program_Error;
--------------
-- Adjacent --

8
gcc/ada/sem_ch9.adb
View File

@ -175,7 +175,6 @@ package body Sem_Ch9 is
begin
Par := First (Par_Specs);
while Present (Par) loop
if Out_Present (Par)
and then not Is_Elementary_Type
@ -183,10 +182,9 @@ package body Sem_Ch9 is
then
if Complain then
Error_Msg_NE
("non-elementary out parameter& not allowed " &
"when Lock_Free given",
Par,
Defining_Identifier (Par));
("non-elementary out parameter& not allowed "
& "when Lock_Free given",
Par, Defining_Identifier (Par));
end if;
return False;

3
gcc/ada/sem_dim.adb
View File

@ -1585,8 +1585,7 @@ package body Sem_Dim is
Dims_Of_Actual := Dimensions_Of (Actual);
if Exists (Dims_Of_Actual) then
Error_Msg_NE ("parameter should be dimensionless for " &
"elementary function&",
Error_Msg_NE ("parameter of& must be dimensionless",
Actual, Name_Call);
Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
Actual);

116
gcc/ada/sem_disp.adb
View File

@ -493,8 +493,34 @@ package body Sem_Disp is
procedure Check_Dispatching_Context is
Subp : constant Entity_Id := Entity (Name (N));
Typ : constant Entity_Id := Etype (Subp);
Par : Node_Id;
procedure Abstract_Context_Error;
-- Indicate that the abstract call that dispatches on result is not
-- dispatching.
-----------------------------
-- Bastract_Context_Error --
-----------------------------
procedure Abstract_Context_Error is
begin
if Ekind (Subp) = E_Function then
Error_Msg_N
("call to abstract function must be dispatching", N);
-- This error can occur for a procedure in the case of a
-- call to an abstract formal procedure with a statically
-- tagged operand.
else
Error_Msg_N
("call to abstract procedure must be dispatching",
N);
end if;
end Abstract_Context_Error;
begin
if Is_Abstract_Subprogram (Subp)
and then No (Controlling_Argument (N))
@ -510,15 +536,78 @@ package body Sem_Disp is
return;
else
-- We need to determine whether the context of the call
-- provides a tag to make the call dispatching. This requires
-- the call to be the actual in an enclosing call, and that
-- actual must be controlling. If the call is an operand of
-- equality, the other operand must not ve abstract.
if not Is_Tagged_Type (Typ)
and then not
(Ekind (Typ) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (Typ)))
then
Abstract_Context_Error;
return;
end if;
Par := Parent (N);
if Nkind (Par) = N_Parameter_Association then
Par := Parent (Par);
end if;
while Present (Par) loop
if Nkind_In (Par, N_Function_Call,
N_Procedure_Call_Statement,
N_Assignment_Statement,
N_Op_Eq,
N_Op_Ne)
and then Is_Tagged_Type (Etype (Subp))
if Nkind_In (Par,
N_Function_Call,
N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par))
then
declare
A : Node_Id;
F : Entity_Id;
begin
-- Find formal for which call is the actual.
F := First_Formal (Entity (Name (Par)));
A := First_Actual (Par);
while Present (F) loop
if Is_Controlling_Formal (F)
and then
(N = A or else Parent (N) = A)
then
return;
end if;
Next_Formal (F);
Next_Actual (A);
end loop;
Error_Msg_N
("call to abstract function must be dispatching", N);
return;
end;
-- For equalitiy operators, one of the operands must
-- be statically or dynamically tagged.
elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
if N = Right_Opnd (Par)
and then Is_Tag_Indeterminate (Left_Opnd (Par))
then
Abstract_Context_Error;
elsif N = Left_Opnd (Par)
and then Is_Tag_Indeterminate (Right_Opnd (Par))
then
Abstract_Context_Error;
end if;
return;
elsif Nkind (Par) = N_Assignment_Statement then
return;
elsif Nkind (Par) = N_Qualified_Expression
@ -527,20 +616,7 @@ package body Sem_Disp is
Par := Parent (Par);
else
if Ekind (Subp) = E_Function then
Error_Msg_N
("call to abstract function must be dispatching", N);
-- This error can occur for a procedure in the case of a
-- call to an abstract formal procedure with a statically
-- tagged operand.
else
Error_Msg_N
("call to abstract procedure must be dispatching",
N);
end if;
Abstract_Context_Error;
return;
end if;
end loop;