+2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Provide a
+ more precise error message when pragma Refined_Pre applies to
+ an expression function that is not a completion.
+
+2013-10-10 Thomas Quinot <quinot@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.
+
2013-10-10 Ed Schonberg <schonberg@adacore.com>
* par-ch13.adb (Aspect_Specifications_Present)): In earlier than
-- --
-- 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- --
-- 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
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 --
-----------
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.
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));
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);
--------------------------
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
+
+ -- 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);
- if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
- Rewrite (N,
- New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
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));
Error_Msg_N ("pragma % duplicates pragma declared #", N);
end if;
- -- Skip internally generated code
-
- elsif not Comes_From_Source (Stmt) then
- null;
-
-- The pragma applies to a subprogram body stub
elsif Nkind (Stmt) = N_Subprogram_Body_Stub then
Body_Decl := Stmt;
exit;
+ -- The pragma applies to an expression function that does not
+ -- act as a completion of a previous function declaration.
+
+ elsif Nkind (Stmt) = N_Subprogram_Declaration
+ and then Nkind (Original_Node (Stmt)) = N_Expression_Function
+ and then not
+ Has_Completion (Defining_Unit_Name (Specification (Stmt)))
+ then
+ Error_Pragma ("pragma % cannot apply to a stand alone body");
+ return;
+
+ -- Skip internally generated code
+
+ elsif not Comes_From_Source (Stmt) then
+ null;
+
-- The pragma does not apply to a legal construct, issue an
-- error and stop the analysis.
projects / gcc.git / commitdiff