Skip to content

R
riscv-gcc-1
Commit 680d5f61 by Arnaud Charlet
Options

[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
parent 14f3895c
Showing with 134 additions and 52 deletions
gcc/ada/ChangeLog
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.
......
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 --
......
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
......
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;
......
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
......
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.
......
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.
......
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
......
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 --
-------------------------
......
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).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment