For unconstrained types, Ada.Sequential_IO needs to encode length information
prior to actual object representation. This length information is now stored
with the same endianness as the object itself, which means that the same
representation is now generated, independent of platform endianness, if the
Scalar_Storage_Order aspect is specified for the actual type.
The following unit test must produce the indicated output:
$ gnatmake -q endian_io
$ endian_io
out_le: 8 0 0 0 0 0 0 0 123 0 0 0 200 1 0 0
out_be: 0 0 0 0 0 0 0 8 0 0 0 123 0 0 1 200
with System; use System;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions;
with Ada.Sequential_IO;
with Ada.Streams.Stream_IO;
procedure Endian_IO is
package Int_IO is new Ada.Sequential_IO (Integer);
pragma Unreferenced (Int_IO);
-- Check that Sequential_IO can be instantiated for a non-composite type
type Arr is array (Integer range <>) of Integer;
package Arr_IO is new Ada.Sequential_IO (Arr);
F : Arr_IO.File_Type;
type Arr_BE is new Arr
with Scalar_Storage_Order => High_Order_First;
package Arr_BE_IO is new Ada.Sequential_IO (Arr_BE);
F_BE : Arr_BE_IO.File_Type;
type Arr_LE is new Arr
with Scalar_Storage_Order => Low_Order_First;
package Arr_LE_IO is new Ada.Sequential_IO (Arr_LE);
F_LE : Arr_LE_IO.File_Type;
Val : constant Arr := (1 => 123, 2 => 456);
Val_BE : constant Arr_BE := Arr_BE (Val);
Val_LE : constant Arr_LE := Arr_LE (Val);
Rval : Arr (1 .. 2);
use Arr_IO, Arr_BE_IO, Arr_LE_IO;
DBO : System.Bit_Order renames System.Default_Bit_Order;
procedure Dump (FN : String) is
use Ada.Streams, Ada.Streams.Stream_IO;
F : Ada.Streams.Stream_IO.File_Type;
SEA : Stream_Element_Array (1 .. 32);
Last : Stream_Element_Offset;
begin
Open (F, In_File, FN);
Read (F, SEA, Last);
Put (FN & ":");
for J in SEA'First .. Last loop
Put (SEA (J)'Img);
end loop;
New_Line;
Close (F);
end Dump;
begin
Create (F, Out_File, "out");
Write (F, Val);
Close (F);
Create (F_BE, Out_File, "out_be");
Write (F_BE, Val_BE);
Close (F_BE);
Create (F_LE, Out_File, "out_le");
Write (F_LE, Val_LE);
Close (F_LE);
Open (F, In_File, (if DBO = High_Order_First
then "out_be"
else "out_le"));
begin
Read (F, Rval);
exception
when E : others =>
Rval := (others => 666);
Put_Line ("exception raised: "
& Ada.Exceptions.Exception_Information (E));
end;
Close (F);
if Rval /= Val then
Put_Line ("FAIL re-reading " & DBO'Img);
end if;
Dump ("out_le");
Dump ("out_be");
end Endian_IO;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Thomas Quinot <qui...@adacore.com>
* sem_attr.adb (Analyse_Attribute, case
Attribute_Scalar_Storage_Order): a 'Scalar_Storage_Order attribute
reference for a generic type is permitted in GNAT runtime mode.
* a-sequio.adb (Read, Write): Use the endianness of the actual
type to encode length information written to the file.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 203346)
+++ sem_attr.adb (working copy)
@@ -5040,23 +5040,43 @@
--------------------------
when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
+ declare
+ Ent : Entity_Id := Empty;
begin
Check_E0;
Check_Type;
- if not Is_Record_Type (P_Type) or else Is_Array_Type (P_Type) then
- Error_Attr_P
- ("prefix of % attribute must be record or array type");
- end if;
+ if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then
- if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
- Rewrite (N,
- New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
+ -- In GNAT mode, the attribute applies to generic types as well
+ -- as composite types, and for non-composite types always returns
+ -- the default bit order for the target.
+
+ if not (GNAT_Mode and then Is_Generic_Type (P_Type))
+ and then not In_Instance
+ then
+ Error_Attr_P
+ ("prefix of % attribute must be record or array type");
+
+ elsif not Is_Generic_Type (P_Type) then
+ if Bytes_Big_Endian then
+ Ent := RTE (RE_High_Order_First);
+ else
+ Ent := RTE (RE_Low_Order_First);
+ end if;
+ end if;
+
+ elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
+ Ent := RTE (RE_High_Order_First);
+
else
- Rewrite (N,
- New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
+ Ent := RTE (RE_Low_Order_First);
end if;
+ if Present (Ent) then
+ Rewrite (N, New_Occurrence_Of (Ent, Loc));
+ end if;
+
Set_Etype (N, RTE (RE_Bit_Order));
Resolve (N);
Index: a-sequio.adb
===================================================================
--- a-sequio.adb (revision 203342)
+++ a-sequio.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
@@ -34,13 +34,14 @@
-- in System.File_IO (for common file functions), or in System.Sequential_IO
-- (for specialized Sequential_IO functions)
-with Interfaces.C_Streams; use Interfaces.C_Streams;
+with Ada.Unchecked_Conversion;
with System;
with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
with System.Storage_Elements;
-with Ada.Unchecked_Conversion;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with GNAT.Byte_Swapping;
package body Ada.Sequential_IO is
@@ -57,8 +58,26 @@
function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
+ use type System.Bit_Order;
use type System.CRTL.size_t;
+ procedure Byte_Swap (Siz : in out size_t);
+ -- Byte swap Siz
+
+ ---------------
+ -- Byte_Swap --
+ ---------------
+
+ procedure Byte_Swap (Siz : in out size_t) is
+ use GNAT.Byte_Swapping;
+ begin
+ case Siz'Size is
+ when 32 => Swap4 (Siz'Address);
+ when 64 => Swap8 (Siz'Address);
+ when others => raise Program_Error;
+ end case;
+ end Byte_Swap;
+
-----------
-- Close --
-----------
@@ -170,6 +189,10 @@
FIO.Read_Buf
(AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit);
+ if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
+ Byte_Swap (Rsiz);
+ end if;
+
-- For a type with discriminants, we have to read into a temporary
-- buffer if Item is constrained, to check that the discriminants
-- are correct.
@@ -252,7 +275,11 @@
procedure Write (File : File_Type; Item : Element_Type) is
Siz : constant size_t := (Item'Size + SU - 1) / SU;
+ -- Size to be written, in native representation
+ Swapped_Siz : size_t := Siz;
+ -- Same, possibly byte swapped to account for Element_Type endianness
+
begin
FIO.Check_Write_Status (AP (File));
@@ -261,8 +288,12 @@
if not Element_Type'Definite
or else Element_Type'Has_Discriminants
then
+ if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
+ Byte_Swap (Swapped_Siz);
+ end if;
+
FIO.Write_Buf
- (AP (File), Siz'Address, size_t'Size / System.Storage_Unit);
+ (AP (File), Swapped_Siz'Address, size_t'Size / System.Storage_Unit);
end if;
FIO.Write_Buf (AP (File), Item'Address, Siz);
