diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2016-04-27 15:05:41 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2016-04-27 15:05:41 +0200 |
commit | 680d5f6190bf5c90e600f47ee8c9e604d80b2f7b (patch) | |
tree | ced0897ff6a0f85f50870e91078f0df69a7eedf0 | |
parent | 14f3895c40cd3f074ca17823c30a6cbf665836b5 (diff) | |
download | gcc-680d5f6190bf5c90e600f47ee8c9e604d80b2f7b.zip gcc-680d5f6190bf5c90e600f47ee8c9e604d80b2f7b.tar.gz gcc-680d5f6190bf5c90e600f47ee8c9e604d80b2f7b.tar.bz2 |
[multiple changes]
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_util.ads, sem_util.adb (Is_Null_Record_Type): New predicate
to determine whether a record type is a null record.
* sem_ch3.adb (Analyze_Object_Declaration): If the type is a
null record and there is no expression in the declaration,
no predicate check applies to the object.
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch7.adb (Analyze_Package_Body_Helper): The body of an
instantiated package should not cause freezing of previous contracts.
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension): Handle subtype declarations
that do not come from source.
(Analyze_Dimension_Subtype_Declaration): Allow confirming
dimensions on subtype entity, either inherited from base type
or provided by aspect specification.
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* s-gearop.ads (Matrix_Vector_Solution, Matrix_Matrix_Solution):
Add scalar formal object Zero, to allow detection and report
when the matrix is singular.
* s-gearop.adb (Matrix_Vector_Solution, Matrix_Matrix_Solution):
Raise Constraint_Error if the Forward_Eliminate pass has
determined that determinant is Zero.o
* s-ngrear.adb (Solve): Add actual for Zero in corresponding
instantiations.
* s-ngcoar.adb (Solve): Ditto.
From-SVN: r235499
-rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
-rw-r--r-- | gcc/ada/a-ngcoar.adb | 11 | ||||
-rw-r--r-- | gcc/ada/a-ngrear.adb | 9 | ||||
-rw-r--r-- | gcc/ada/s-gearop.adb | 14 | ||||
-rw-r--r-- | gcc/ada/s-gearop.ads | 4 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sem_ch7.adb | 65 | ||||
-rw-r--r-- | gcc/ada/sem_dim.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 14 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 4 |
10 files changed, 134 insertions, 52 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 39ec57e..0aee0a8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2016-04-27 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb (Is_Null_Record_Type): New predicate + to determine whether a record type is a null record. + * sem_ch3.adb (Analyze_Object_Declaration): If the type is a + null record and there is no expression in the declaration, + no predicate check applies to the object. + +2016-04-27 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch7.adb (Analyze_Package_Body_Helper): The body of an + instantiated package should not cause freezing of previous contracts. + +2016-04-27 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Analyze_Dimension): Handle subtype declarations + that do not come from source. + (Analyze_Dimension_Subtype_Declaration): Allow confirming + dimensions on subtype entity, either inherited from base type + or provided by aspect specification. + +2016-04-27 Ed Schonberg <schonberg@adacore.com> + + * s-gearop.ads (Matrix_Vector_Solution, Matrix_Matrix_Solution): + Add scalar formal object Zero, to allow detection and report + when the matrix is singular. + * s-gearop.adb (Matrix_Vector_Solution, Matrix_Matrix_Solution): + Raise Constraint_Error if the Forward_Eliminate pass has + determined that determinant is Zero.o + * s-ngrear.adb (Solve): Add actual for Zero in corresponding + instantiations. + * s-ngcoar.adb (Solve): Ditto. + 2016-04-27 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch3.adb: Minor reformatting. diff --git a/gcc/ada/a-ngcoar.adb b/gcc/ada/a-ngcoar.adb index ca0c58c..e9b2465 100644 --- a/gcc/ada/a-ngcoar.adb +++ b/gcc/ada/a-ngcoar.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2016, 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- -- @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ with System.Generic_Array_Operations; use System.Generic_Array_Operations; -with Ada.Numerics; use Ada.Numerics; package body Ada.Numerics.Generic_Complex_Arrays is @@ -694,11 +693,11 @@ package body Ada.Numerics.Generic_Complex_Arrays is -- Solve -- ----------- - function Solve is - new Matrix_Vector_Solution (Complex, Complex_Vector, Complex_Matrix); + function Solve is new Matrix_Vector_Solution + (Complex, (0.0, 0.0), Complex_Vector, Complex_Matrix); - function Solve is - new Matrix_Matrix_Solution (Complex, Complex_Matrix); + function Solve is new Matrix_Matrix_Solution + (Complex, (0.0, 0.0), Complex_Matrix); ----------------- -- Unit_Matrix -- diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index 68d5365..c3b954a 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2016, 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- -- @@ -337,10 +337,11 @@ package body Ada.Numerics.Generic_Real_Arrays is Result_Matrix => Real_Matrix, Operation => "abs"); - function Solve is - new Matrix_Vector_Solution (Real'Base, Real_Vector, Real_Matrix); + function Solve is new + Matrix_Vector_Solution (Real'Base, 0.0, Real_Vector, Real_Matrix); - function Solve is new Matrix_Matrix_Solution (Real'Base, Real_Matrix); + function Solve is new + Matrix_Matrix_Solution (Real'Base, 0.0, Real_Matrix); function Unit_Matrix is new Generic_Array_Operations.Unit_Matrix diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb index f84280e..b6d6f22 100644 --- a/gcc/ada/s-gearop.adb +++ b/gcc/ada/s-gearop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2016, 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- -- @@ -30,9 +30,7 @@ ------------------------------------------------------------------------------ with Ada.Numerics; use Ada.Numerics; - package body System.Generic_Array_Operations is - function Check_Unit_Last (Index : Integer; Order : Positive; @@ -696,6 +694,11 @@ package body System.Generic_Array_Operations is end loop; Forward_Eliminate (MA, MX, Det); + + if Det = Zero then + raise Constraint_Error with "matrix is singular"; + end if; + Back_Substitute (MA, MX); for J in 0 .. R'Length - 1 loop @@ -735,6 +738,11 @@ package body System.Generic_Array_Operations is end loop; Forward_Eliminate (MA, MB, Det); + + if Det = Zero then + raise Constraint_Error with "matrix is singular"; + end if; + Back_Substitute (MA, MB); return MB; diff --git a/gcc/ada/s-gearop.ads b/gcc/ada/s-gearop.ads index f401da2..7e252ee 100644 --- a/gcc/ada/s-gearop.ads +++ b/gcc/ada/s-gearop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2016, 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- -- @@ -396,6 +396,7 @@ pragma Pure (Generic_Array_Operations); generic type Scalar is private; + Zero : Scalar; type Vector is array (Integer range <>) of Scalar; type Matrix is array (Integer range <>, Integer range <>) of Scalar; with procedure Back_Substitute (M, N : in out Matrix) is <>; @@ -411,6 +412,7 @@ pragma Pure (Generic_Array_Operations); generic type Scalar is private; + Zero : Scalar; type Matrix is array (Integer range <>, Integer range <>) of Scalar; with procedure Back_Substitute (M, N : in out Matrix) is <>; with procedure Forward_Eliminate diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cde4d1a..c9aa9d6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3835,8 +3835,16 @@ package body Sem_Ch3 is Check_Expression_Against_Static_Predicate (E, T); end if; - Insert_After (N, - Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); + -- If the type is a null record and there is no explicit initial + -- expression, no predicate check applies. + + if No (E) and then Is_Null_Record_Type (T) then + null; + + else + Insert_After (N, + Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); + end if; end if; -- Case of unconstrained type @@ -13039,7 +13047,7 @@ package body Sem_Ch3 is procedure Fixup_Bad_Constraint; -- Called after finding a bad constraint, and after having posted an -- appropriate error message. The goal is to leave type Def_Id in as - -- reasonable state as possiblet. + -- reasonable state as possible. -------------------------- -- Fixup_Bad_Constraint -- @@ -13112,7 +13120,7 @@ package body Sem_Ch3 is and then Nkind (Parent (S)) = N_Subtype_Declaration and then not Is_Itype (Def_Id) then - -- A little sanity check, emit an error message if the type has + -- A little sanity check: emit an error message if the type has -- discriminants to begin with. Type T may be a regular incomplete -- type or imported via a limited with clause. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index dc742de..1a8786d 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -544,35 +544,6 @@ package body Sem_Ch7 is -- Start of processing for Analyze_Package_Body_Helper begin - -- A [generic] package body "freezes" the contract of the nearest - -- enclosing package body and all other contracts encountered in the - -- same declarative part up to and excluding the package body: - - -- package body Nearest_Enclosing_Package - -- with Refined_State => (State => Constit) - -- is - -- Constit : ...; - - -- package body Freezes_Enclosing_Package_Body - -- with Refined_State => (State_2 => Constit_2) - -- is - -- Constit_2 : ...; - - -- procedure Proc - -- with Refined_Depends => (Input => (Constit, Constit_2)) ... - - -- This ensures that any annotations referenced by the contract of a - -- [generic] subprogram body declared within the current package body - -- are available. This form of "freezing" is decoupled from the usual - -- Freeze_xxx mechanism because it must also work in the context of - -- generics where normal freezing is disabled. - - -- Only bodies coming from source should cause this type of "freezing" - - if Comes_From_Source (N) then - Analyze_Previous_Contracts (N); - end if; - -- Find corresponding package specification, and establish the current -- scope. The visible defining entity for the package is the defining -- occurrence in the spec. On exit from the package body, all body @@ -628,6 +599,42 @@ package body Sem_Ch7 is end if; end if; + -- A [generic] package body "freezes" the contract of the nearest + -- enclosing package body and all other contracts encountered in the + -- same declarative part up to and excluding the package body: + + -- package body Nearest_Enclosing_Package + -- with Refined_State => (State => Constit) + -- is + -- Constit : ...; + + -- package body Freezes_Enclosing_Package_Body + -- with Refined_State => (State_2 => Constit_2) + -- is + -- Constit_2 : ...; + + -- procedure Proc + -- with Refined_Depends => (Input => (Constit, Constit_2)) ... + + -- This ensures that any annotations referenced by the contract of a + -- [generic] subprogram body declared within the current package body + -- are available. This form of "freezing" is decoupled from the usual + -- Freeze_xxx mechanism because it must also work in the context of + -- generics where normal freezing is disabled. + + -- Only bodies coming from source should cause this type of "freezing". + -- Instantiated generic bodies are excluded because their processing is + -- performed in a separate compilation pass which lacks enough semantic + -- information with respect to contract analysis. It is safe to suppress + -- the "freezing" of contracts in this case because this action already + -- took place at the end of the enclosing declarative part. + + if Comes_From_Source (N) + and then not Is_Generic_Instance (Spec_Id) + then + Analyze_Previous_Contracts (N); + end if; + -- A package body is Ghost when the corresponding spec is Ghost. Set -- the mode now to ensure that any nodes generated during analysis and -- expansion are properly flagged as ignored Ghost. diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index c7282b1..cabb013 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1120,9 +1120,15 @@ package body Sem_Dim is procedure Analyze_Dimension (N : Node_Id) is begin -- Aspect is an Ada 2012 feature. Note that there is no need to check - -- dimensions for nodes that don't come from source. + -- dimensions for nodes that don't come from source, except for subtype + -- declarations where the dimensions are inherited from the base type. - if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then + if Ada_Version < Ada_2012 then + return; + + elsif not Comes_From_Source (N) + and then Nkind (N) /= N_Subtype_Declaration + then return; end if; @@ -2232,10 +2238,10 @@ package body Sem_Dim is if Exists (Dims_Of_Etyp) then - -- If subtype already has a dimension (from Aspect_Dimension), - -- it cannot inherit a dimension from its subtype. + -- If subtype already has a dimension (from Aspect_Dimension), it + -- cannot inherit different dimensions from its subtype. - if Exists (Dims_Of_Id) then + if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then Error_Msg_NE ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id); else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7f99291..e1b1b50 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13111,6 +13111,20 @@ package body Sem_Util is end Is_Nontrivial_Default_Init_Cond_Procedure; ------------------------- + -- Is_Null_Record_Type -- + ------------------------- + + function Is_Null_Record_Type (T : Entity_Id) return Boolean is + Decl : constant Node_Id := Parent (T); + begin + return Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then + (No (Component_List (Type_Definition (Decl))) + or else Null_Present (Component_List (Type_Definition (Decl)))); + end Is_Null_Record_Type; + + ------------------------- -- Is_Object_Reference -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0845bf7..fb049ef 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1481,6 +1481,10 @@ package Sem_Util is -- assertion expression of pragma Default_Initial_Condition and if it does, -- the encapsulated expression is nontrivial. + function Is_Null_Record_Type (T : Entity_Id) return Boolean; + -- Determine whether T is declared with a null record definition or a + -- null component list. + function Is_Object_Reference (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an object. Both -- variable and constant objects return True (compare Is_Variable). |