This patch implements the proper handling of dimension information on type
conversions. Given a conversion T (Expr), where the expression has type TE,
the following cases arise:
a) If TE has dimension information, the dimensions of the conversion are those
of TE.
b) If TE has no dimension information, dimensions of conversion are those of T.
c) If T and TE belong to different dimension systems, they must have identical
dimensions, unless T is the root type of its system, in which case dimensions
are those of TE, and the conversion can be seen as a "view conversion" that
preserves the dimensions of its argument.
d) If T is a non-dimensioned type, such a Standard.Float, the conversion has no
dimension information.
The following must compile quietly:
gcc -c main.adb
gcc -c -gnatd.F main.adb
---
with Units; use Units;
procedure main with SPARK_Mode is
subtype Servo_Angle_Type is
Units.Angle_Type range -40.0 * Degree .. 40.0 * Degree;
function Sat_Servo_Angle is new Saturated_Cast (Servo_Angle_Type);
begin
null;
end main;
---
with Ada.Numerics;
package units with SPARK_Mode is
type Unit_Type is new Float with
Dimension_System =>
((Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'),
(Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'),
(Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'),
(Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'),
(Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"),
(Unit_Name => Radian, Unit_Symbol => "Rad", Dim_Symbol => "A")),
Default_Value => 0.0; -- required for matrices
subtype Angle_Type is Unit_Type with
Dimension => (Symbol => "Rad", Radian => 1, others => 0);
Degree : constant Angle_Type := Angle_Type (2.0 * Ada.Numerics.Pi / 360.0);
generic
type T is digits <>;
function Saturated_Cast (val : Float) return T with Inline;
-- convert a float into a more specific float type, and trim
-- to the value range
end units;
---
package body units with SPARK_Mode is
function Saturated_Cast (val : Float) return T is
ret : T;
begin
if val >= Float (T'Last) then
ret := T'Last;
elsif val <= Float (T'First) then
ret := T'First;
else
ret := T (val);
end if;
return ret;
end Saturated_Cast;
end units;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-07 Ed Schonberg <schonb...@adacore.com>
* sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
to handle properly various cases of type conversions where the
target type and/or the expression carry dimension information.
(Dimension_System_Root); If a subtype carries dimension
information, obtain the source parent type that carries the
Dimension aspect.
Index: sem_dim.adb
===================================================================
--- sem_dim.adb (revision 251836)
+++ sem_dim.adb (working copy)
@@ -35,6 +35,7 @@
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@@ -280,6 +281,14 @@
-- both the identifier and the parent type of N are not dimensionless,
-- return an error.
+ procedure Analyze_Dimension_Type_Conversion (N : Node_Id);
+ -- Type conversions handle conversions between literals and dimensioned
+ -- types, from dimensioned types to their base type, and between different
+ -- dimensioned systems. Dimensions of the conversion are obtained either
+ -- from those of the expression, or from the target type, and dimensional
+ -- consistency must be checked when converting between values belonging
+ -- to different dimensioned systems.
+
procedure Analyze_Dimension_Unary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
-- Abs operators, propagate the dimensions from the operand to N.
@@ -301,6 +310,11 @@
-- dimension" if Description_Needed. if N is dimensionless, return "'[']",
-- or "is dimensionless" if Description_Needed.
+ function Dimension_System_Root (T : Entity_Id) return Entity_Id;
+ -- Given a type that has dimension information, return the type that is the
+ -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
+ -- type, i.e. a standard numeric type, return Empty.
+
procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
-- Issue a warning on the given numeric literal N to indicate that the
-- compiler made the assumption that the literal is not dimensionless
@@ -1191,13 +1205,7 @@
Analyze_Dimension_Subtype_Declaration (N);
when N_Type_Conversion =>
- if In_Instance
- and then Exists (Dimensions_Of (Expression (N)))
- then
- Set_Dimensions (N, Dimensions_Of (Expression (N)));
- else
- Analyze_Dimension_Has_Etype (N);
- end if;
+ Analyze_Dimension_Type_Conversion (N);
when N_Unary_Op =>
Analyze_Dimension_Unary_Op (N);
@@ -1384,26 +1392,6 @@
return Dimensions_Of (Etype (N));
end if;
- -- A type conversion may have been inserted to rewrite other
- -- expressions, e.g. function returns. Dimensions are those of
- -- the target type, unless this is a conversion in an instance,
- -- in which case the proper dimensions are those of the operand,
-
- elsif Nkind (N) = N_Type_Conversion then
- if In_Instance
- and then Is_Generic_Actual_Type (Etype (Expression (N)))
- then
- return Dimensions_Of (Etype (Expression (N)));
-
- elsif In_Instance
- and then Exists (Dimensions_Of (Expression (N)))
- then
- return Dimensions_Of (Expression (N));
-
- else
- return Dimensions_Of (Etype (N));
- end if;
-
-- Otherwise return the default dimensions
else
@@ -2339,6 +2327,56 @@
end if;
end Analyze_Dimension_Subtype_Declaration;
+ ---------------------------------------
+ -- Analyze_Dimension_Type_Conversion --
+ ---------------------------------------
+
+ procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is
+ Expr_Root : constant Entity_Id :=
+ Dimension_System_Root (Etype (Expression (N)));
+ Target_Root : constant Entity_Id :=
+ Dimension_System_Root (Etype (N));
+
+ begin
+ -- If the expression has dimensions and the target type has dimensions,
+ -- the conversion has the dimensions of the expression. Consistency is
+ -- checked below. Converting to a non-dimensioned type such as Float
+ -- ignores the dimensions of the expression.
+
+ if Exists (Dimensions_Of (Expression (N)))
+ and then Present (Target_Root)
+ then
+ Set_Dimensions (N, Dimensions_Of (Expression (N)));
+
+ -- Otherwise the dimensions are those of the target type.
+
+ else
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+
+ -- A conversion between types in different dimension systems (e.g. MKS
+ -- and British units) must respect the dimensions of expression and
+ -- type, It is up to the user to provide proper conversion factors.
+
+ -- Upward conversions to root type of a dimensioned system are legal,
+ -- and correspond to "view conversions", i.e. preserve the dimensions
+ -- of the expression; otherwise conversion must be between types with
+ -- then same dimensions. Conversions to a non-dimensioned type such as
+ -- Float lose the dimensions of the expression.
+
+ if Present (Expr_Root)
+ and then Present (Target_Root)
+ and then Etype (N) /= Target_Root
+ and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N))
+ then
+ Error_Msg_N ("dimensions mismatch in conversion", N);
+ Error_Msg_N
+ ("\expression " & Dimensions_Msg_Of (Expression (N), True), N);
+ Error_Msg_N
+ ("\target type " & Dimensions_Msg_Of (Etype (N), True), N);
+ end if;
+ end Analyze_Dimension_Type_Conversion;
+
--------------------------------
-- Analyze_Dimension_Unary_Op --
--------------------------------
@@ -2665,6 +2703,24 @@
or else Dimensions_Of (T1) = Dimensions_Of (T2);
end Dimensions_Match;
+ ---------------------------
+ -- Dimension_System_Root --
+ ---------------------------
+
+ function Dimension_System_Root (T : Entity_Id) return Entity_Id is
+ Root : Entity_Id;
+
+ begin
+ Root := Base_Type (T);
+
+ if Has_Dimension_System (Root) then
+ return First_Subtype (Root); -- for example Dim_Mks
+
+ else
+ return Empty;
+ end if;
+ end Dimension_System_Root;
+
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------
