From 83553466ec17627d218830d7f32050b9cc9e2c82 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 10 Oct 2013 14:13:03 +0200 Subject: [PATCH] [multiple changes] 2013-10-10 Hristian Kirtchev * 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 * 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. From-SVN: r203356 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/a-sequio.adb | 39 +++++++++++++++++++++++++++++++++++---- gcc/ada/sem_attr.adb | 38 +++++++++++++++++++++++++++++--------- gcc/ada/sem_prag.adb | 21 ++++++++++++++++----- 4 files changed, 94 insertions(+), 18 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be5c54763d6..df6f31c0914 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2013-10-10 Hristian Kirtchev + + * 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 + + * 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 * par-ch13.adb (Aspect_Specifications_Present)): In earlier than diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb index 397a778f36f..b9442e913d4 100644 --- a/gcc/ada/a-sequio.adb +++ b/gcc/ada/a-sequio.adb @@ -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 @@ 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 -- ----------- @@ -170,6 +189,10 @@ package body Ada.Sequential_IO is 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,6 +275,10 @@ package body Ada.Sequential_IO is 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 @@ package body Ada.Sequential_IO is 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); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a46e057c034..bc5139ff1e8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5040,21 +5040,41 @@ package body Sem_Attr is -------------------------- 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)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9d8f590ab9e..fa189aad969 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15964,17 +15964,28 @@ package body Sem_Prag is 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. -- 2.30.2