diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
| -rw-r--r-- | gcc/ada/a-ngelfu.ads | 178 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 3 | ||||
| -rw-r--r-- | gcc/ada/aspects.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_pakd.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/osint.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 4 |
10 files changed, 265 insertions, 71 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7ad79d3..34ab93d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2012-05-15 Yannick Moy <moy@adacore.com> + + * aspects.ads: Minor addition of comments to provide info on + how to add new aspects. + +2012-05-15 Thomas Quinot <quinot@adacore.com> + + * osint.ads: Minor reformatting. + +2012-05-15 Thomas Quinot <quinot@adacore.com> + + * exp_ch5.adb, exp_pakd.adb, sem_util.adb, sem_util.ads + (Expand_Assign_Array): Handle the case of a packed bit array within a + record with reverse storage order (assign element by element in that + case). + (In_Reverse_Storage_Order_Record): New subprogram, + code extracted from Exp_Pakd. + +2012-05-15 Yannick Moy <moy@adacore.com> + + * a-ngelfu.ads: Add postconditions using Ada 2012 + aspect syntax, reflecting some of the RM requirements for these + functions, from Annex A.5.1 or G.2.4. + +2012-05-15 Thomas Quinot <quinot@adacore.com> + + * adaint.c: Minor fix: move misplaced comment. + +2012-05-15 Doug Rupp <rupp@adacore.com> + + * vms_data.ads: Enhance help for /IMMEDIATE_ERRORS to discourage + use by customers. + 2012-05-15 Tristan Gingold <gingold@adacore.com> * a-exextr.adb: Add comment. diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads index d84828a..03aed54 100644 --- a/gcc/ada/a-ngelfu.ads +++ b/gcc/ada/a-ngelfu.ads @@ -6,10 +6,34 @@ -- -- -- S p e c -- -- -- +-- Copyright (C) 2012, Free Software Foundation, Inc. -- +-- -- -- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the Post aspects that have been added to the spec. -- +-- Except for these parts of the document, in accordance with the copyright -- +-- of that document, you can freely copy and modify this specification, -- +-- provided that if you redistribute a modified version, any changes that -- +-- you have made are clearly indicated. -- +-- -- +-- 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. -- -- -- ------------------------------------------------------------------------------ @@ -19,55 +43,141 @@ generic package Ada.Numerics.Generic_Elementary_Functions is pragma Pure; - function Sqrt (X : Float_Type'Base) return Float_Type'Base; - function Log (X : Float_Type'Base) return Float_Type'Base; - function Log (X, Base : Float_Type'Base) return Float_Type'Base; - function Exp (X : Float_Type'Base) return Float_Type'Base; - function "**" (Left, Right : Float_Type'Base) return Float_Type'Base; - - function Sin (X : Float_Type'Base) return Float_Type'Base; - function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base; - function Cos (X : Float_Type'Base) return Float_Type'Base; - function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base; - function Tan (X : Float_Type'Base) return Float_Type'Base; - function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base; - function Cot (X : Float_Type'Base) return Float_Type'Base; - function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base; - - function Arcsin (X : Float_Type'Base) return Float_Type'Base; - function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base; - function Arccos (X : Float_Type'Base) return Float_Type'Base; - function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Sqrt (X : Float_Type'Base) return Float_Type'Base + with + Post => Sqrt'Result >= 0.0 + and then (if X = 0.0 then Sqrt'Result = 0.0) + and then (if X = 1.0 then Sqrt'Result = 1.0); + + function Log (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 1.0 then Log'Result = 0.0); + + function Log (X, Base : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 1.0 then Log'Result = 0.0); + + function Exp (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Exp'Result = 1.0); + + function "**" (Left, Right : Float_Type'Base) return Float_Type'Base + with + Post => "**"'Result >= 0.0 + and then (if Right = 0.0 then "**"'Result = 1.0) + and then (if Right = 1.0 then "**"'Result = Left) + and then (if Left = 1.0 then "**"'Result = 1.0) + and then (if Left = 0.0 then "**"'Result = 0.0); + + function Sin (X : Float_Type'Base) return Float_Type'Base + with + Post => Sin'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Sin'Result = 0.0); + + function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base + with + Post => Sin'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Sin'Result = 0.0); + + function Cos (X : Float_Type'Base) return Float_Type'Base + with + Post => Cos'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Cos'Result = 1.0); + + function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base + with + Post => Cos'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Cos'Result = 1.0); + + function Tan (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Tan'Result = 0.0); + + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Tan'Result = 0.0); + + function Cot (X : Float_Type'Base) return Float_Type'Base; + + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base; + + function Arcsin (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Arcsin'Result = 0.0); + + function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Arcsin'Result = 0.0); + + function Arccos (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 1.0 then Arccos'Result = 0.0); + + function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 1.0 then Arccos'Result = 0.0); function Arctan (Y : Float_Type'Base; X : Float_Type'Base := 1.0) - return Float_Type'Base; + return Float_Type'Base + with + Post => (if X > 0.0 and Y = 0.0 then Arctan'Result = 0.0); function Arctan (Y : Float_Type'Base; X : Float_Type'Base := 1.0; Cycle : Float_Type'Base) - return Float_Type'Base; + return Float_Type'Base + with + Post => (if X > 0.0 and Y = 0.0 then Arctan'Result = 0.0); function Arccot (X : Float_Type'Base; Y : Float_Type'Base := 1.0) - return Float_Type'Base; + return Float_Type'Base + with + Post => (if X > 0.0 and Y = 0.0 then Arccot'Result = 0.0); function Arccot (X : Float_Type'Base; Y : Float_Type'Base := 1.0; Cycle : Float_Type'Base) - return Float_Type'Base; - - function Sinh (X : Float_Type'Base) return Float_Type'Base; - function Cosh (X : Float_Type'Base) return Float_Type'Base; - function Tanh (X : Float_Type'Base) return Float_Type'Base; - function Coth (X : Float_Type'Base) return Float_Type'Base; - function Arcsinh (X : Float_Type'Base) return Float_Type'Base; - function Arccosh (X : Float_Type'Base) return Float_Type'Base; - function Arctanh (X : Float_Type'Base) return Float_Type'Base; + return Float_Type'Base + with + Post => (if X > 0.0 and Y = 0.0 then Arccot'Result = 0.0); + + function Sinh (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Sinh'Result = 0.0); + + function Cosh (X : Float_Type'Base) return Float_Type'Base + with + Post => Cosh'Result >= 1.0 + and then (if X = 0.0 then Cosh'Result = 1.0); + + function Tanh (X : Float_Type'Base) return Float_Type'Base + with + Post => Tanh'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Tanh'Result = 0.0); + + function Coth (X : Float_Type'Base) return Float_Type'Base + with + Post => abs Coth'Result >= 1.0; + + function Arcsinh (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Arcsinh'Result = 0.0); + + function Arccosh (X : Float_Type'Base) return Float_Type'Base + with + Post => Arccosh'Result >= 0.0 + and then (if X = 1.0 then Arccosh'Result = 0.0); + + function Arctanh (X : Float_Type'Base) return Float_Type'Base + with + Post => (if X = 0.0 then Arctanh'Result = 0.0); + function Arccoth (X : Float_Type'Base) return Float_Type'Base; end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 34136ff..b76b3c6 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -350,7 +350,6 @@ int __gnat_vmsp = 0; /* Used for Ada bindings */ int __gnat_size_of_file_attributes = sizeof (struct file_attributes); -/* Reset the file attributes as if no system call had been performed */ void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr); /* The __gnat_max_path_len variable is used to export the maximum @@ -402,6 +401,8 @@ to_ptr32 (char **ptr64) static const char ATTR_UNSET = 127; +/* Reset the file attributes as if no system call had been performed */ + void __gnat_reset_attributes (struct file_attributes* attr) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 330f72a..bc5b9c6 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -34,6 +34,31 @@ -- aspect specifications from the tree. The semantic processing for aspect -- specifications is found in Sem_Ch13.Analyze_Aspect_Specifications. +-- In general, each aspect should have a corresponding pragma, so that the +-- newly developed functionality is available for Ada versions < Ada 2012. +-- When both are defined, it is convenient to first transform the aspect into +-- an equivalent pragma in Sem_Ch13.Analyze_Aspect_Specifications, and then +-- analyze the pragma in Sem_Prag.Analyze_Pragma. + +-- To add a new aspect: +-- * create a name in snames.ads-tmpl +-- * create a value in type Aspect_Id in this unit +-- * add a value for the aspect in the global arrays defined in this unit +-- * add code for analyzing the aspect in +-- Sem_Ch13.Analyze_Aspect_Specifications. This may involve adding some +-- nodes to the tree to perform additional treatments later. +-- * if the semantic analysis of expressions/names in the aspect should not +-- occur at the point the aspect is defined, add code in the adequate +-- semantic analysis procedure for the aspect. For example, this is the case +-- for aspects Pre and Post on subprograms, which are pre-analyzed at the +-- end of the list of declarations to which the subprogram belongs, and +-- fully analyzed (possibly with expansion) during the semantic analysis of +-- subprogram bodies. + +-- Additionally, to add a corresponding pragma for a new aspect: +-- * create a name for the pragma in snames.ads-tmpl +-- * add code for analyzing the pragma in Sem_Prag.Analyze_Pragma + with Namet; use Namet; with Snames; use Snames; with Types; use Types; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 82fc705..0acb74b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -344,7 +344,18 @@ package body Exp_Ch5 is elsif Has_Controlled_Component (L_Type) then Loop_Required := True; - -- If object is atomic, we cannot tolerate a loop + -- If changing scalar storage order and assigning a bit packed arrau, + -- force loop expansion. + + elsif Is_Bit_Packed_Array (L_Type) + and then + (In_Reverse_Storage_Order_Record (Rhs) + /= + In_Reverse_Storage_Order_Record (Lhs)) + then + Loop_Required := True; + + -- If object is atomic, we cannot tolerate a loop elsif Is_Atomic_Object (Act_Lhs) or else diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 233ce2f..73befd1 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -2622,14 +2622,9 @@ package body Exp_Pakd is Loc : constant Source_Ptr := Sloc (N); PAT : Entity_Id; Otyp : Entity_Id; - Pref : Node_Id; Csiz : Uint; Osiz : Uint; - In_Reverse_Storage_Order_Record : Boolean; - -- Set True if Obj is a [sub]component of a record that has reversed - -- scalar storage order. - begin Csiz := Component_Size (Atyp); @@ -2732,28 +2727,7 @@ package body Exp_Pakd is -- We also have to adjust if the storage order is reversed - Pref := Obj; - loop - case Nkind (Pref) is - when N_Selected_Component => - Pref := Prefix (Pref); - exit; - - when N_Indexed_Component => - Pref := Prefix (Pref); - - when others => - Pref := Empty; - exit; - end case; - end loop; - - In_Reverse_Storage_Order_Record := - Present (Pref) - and then Is_Record_Type (Etype (Pref)) - and then Reverse_Storage_Order (Etype (Pref)); - - if Bytes_Big_Endian xor In_Reverse_Storage_Order_Record then + if Bytes_Big_Endian xor In_Reverse_Storage_Order_Record (Obj) then Shift := Make_Op_Subtract (Loc, Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz), diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 48663f5..094fee3 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -763,7 +763,7 @@ private -- the need for either mapping the struct exactly or importing the sizeof -- from C, which would result in dynamic code). However, it does waste -- space (e.g. when a component of this type appears in a record, if it is - -- unnecessarily large. + -- unnecessarily large). type File_Attributes is array (1 .. File_Attributes_Size) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 21e16ac..522ea3c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3169,14 +3169,15 @@ package body Sem_Util is -- Enclosing_Lib_Unit_Entity -- ------------------------------- - function Enclosing_Lib_Unit_Entity return Entity_Id is - Unit_Entity : Entity_Id; + function Enclosing_Lib_Unit_Entity + (E : Entity_Id := Current_Scope) return Entity_Id + is + Unit_Entity : Entity_Id := E; begin -- Look for enclosing library unit entity by following scope links. -- Equivalent to, but faster than indexing through the scope stack. - Unit_Entity := Current_Scope; while (Present (Scope (Unit_Entity)) and then Scope (Unit_Entity) /= Standard_Standard) and not Is_Child_Unit (Unit_Entity) @@ -6267,6 +6268,37 @@ package body Sem_Util is return False; end In_Parameter_Specification; + ------------------------------------- + -- In_Reverse_Storage_Order_Record -- + ------------------------------------- + + function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean is + Pref : Node_Id; + begin + Pref := N; + + -- Climb up indexed components + + loop + case Nkind (Pref) is + when N_Selected_Component => + Pref := Prefix (Pref); + exit; + + when N_Indexed_Component => + Pref := Prefix (Pref); + + when others => + Pref := Empty; + exit; + end case; + end loop; + + return Present (Pref) + and then Is_Record_Type (Etype (Pref)) + and then Reverse_Storage_Order (Etype (Pref)); + end In_Reverse_Storage_Order_Record; + -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 73998a9..d6e0770 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -385,10 +385,12 @@ package Sem_Util is -- Returns the Node_Id associated with the innermost enclosing generic -- unit, if any. If none, then returns Empty. - function Enclosing_Lib_Unit_Entity return Entity_Id; - -- Returns the entity of enclosing N_Compilation_Unit Node which is the + function Enclosing_Lib_Unit_Entity + (E : Entity_Id := Current_Scope) return Entity_Id; + -- Returns the entity of enclosing library unit node which is the -- root of the current scope (which must not be Standard_Standard, and the - -- caller is responsible for ensuring this condition). + -- caller is responsible for ensuring this condition) or other specified + -- entity. function Enclosing_Package (E : Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the package enclosing @@ -740,6 +742,10 @@ package Sem_Util is function In_Parameter_Specification (N : Node_Id) return Boolean; -- Returns True if node N belongs to a parameter specification + function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean; + -- Returns True if N denotes a component or subcomponent in a record object + -- that has Reverse_Storage_Order. + function In_Subprogram_Or_Concurrent_Unit return Boolean; -- Determines if the current scope is within a subprogram compilation unit -- (inside a subprogram declaration, subprogram body, or generic diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index a71f231..1ebe8d3 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1779,7 +1779,9 @@ package VMS_Data is -- Causes errors to be displayed as soon as they are encountered, rather -- than after compilation is terminated. If GNAT terminates prematurely -- or goes into an infinite loop, the last error message displayed may - -- help to pinpoint the culprit. + -- help to pinpoint the culprit. Use with caution: This qualifier is + -- intended for use in debugging the compiler proper, and may cause + -- output of warnings suppressed by pragma. S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & |