+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.
-- --
-- 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- --
------------------------------------------------------------------------------
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-with Ada.Numerics; use Ada.Numerics;
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 --
-- --
-- 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- --
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
-- --
-- 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- --
------------------------------------------------------------------------------
with Ada.Numerics; use Ada.Numerics;
-
package body System.Generic_Array_Operations is
-
function Check_Unit_Last
(Index : Integer;
Order : Positive;
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
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;
-- --
-- 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- --
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 <>;
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
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
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 --
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.
-- 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
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.
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;
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
return False;
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 --
-------------------------
-- 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).
projects / thirdparty / gcc.git / commitdiff
