Skip to content

R
riscv-gcc-1
Commit 88115c2a by Arnaud Charlet
Options

[multiple changes] 

2011-12-21  Robert Dewar  <dewar@adacore.com>

	* exp_ch5.adb, sem_dim.adb, sem_dim.ads, sem_ch12.adb, prj-conf.adb:
	Minor reformatting.

2011-12-21  Claire Dross  <dross@adacore.com>

	* a-cfdlli.ads (Constant_Indexing, Default_Iterator,
	Iterator_Element): Added to type List.               
	(Not_No_Element, List_Iterator_Interfaces, Iterate,
	Constant_Reference_Type, Constant_Reference): New.
	* a-cfdlli.adb (type Iterator, Finalize, First, Last, Next,
	Previous, Iterate, Not_No_Element, Constant_Reference): New.

From-SVN: r182576
parent 6c57023b
Showing with 412 additions and 183 deletions
gcc/ada/ChangeLog
2011-12-21 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb, sem_dim.adb, sem_dim.ads, sem_ch12.adb, prj-conf.adb:
Minor reformatting.
2011-12-21 Claire Dross <dross@adacore.com>
* a-cfdlli.ads (Constant_Indexing, Default_Iterator,
Iterator_Element): Added to type List.
(Not_No_Element, List_Iterator_Interfaces, Iterate,
Constant_Reference_Type, Constant_Reference): New.
* a-cfdlli.adb (type Iterator, Finalize, First, Last, Next,
Previous, Iterate, Not_No_Element, Constant_Reference): New.
2011-12-21 Gary Dismukes <dismukes@adacore.com> 2011-12-21 Gary Dismukes <dismukes@adacore.com>
* gnat_ugn.texi: Minor reformatting. * gnat_ugn.texi: Minor reformatting.
......
gcc/ada/a-cfdlli.adb
...@@ -26,9 +26,30 @@ ...@@ -26,9 +26,30 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with System; use type System.Address; with System; use type System.Address;
with Ada.Finalization;
package body Ada.Containers.Formal_Doubly_Linked_Lists is package body Ada.Containers.Formal_Doubly_Linked_Lists is
type Iterator is new Ada.Finalization.Limited_Controlled and
List_Iterator_Interfaces.Reversible_Iterator with
record
Container : List_Access;
Node : Count_Type;
end record;
overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
overriding function Previous
(Object : Iterator;
Position : Cursor) return Cursor;
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
...@@ -423,6 +444,21 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -423,6 +444,21 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return Container.Nodes (Position.Node).Element; return Container.Nodes (Position.Node).Element;
end Element; end Element;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
...@@ -474,6 +510,28 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -474,6 +510,28 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return (Node => Container.First); return (Node => Container.First);
end First; end First;
function First (Object : Iterator) return Cursor is
begin
-- The value of the iterator object's Node component influences the
-- behavior of the First (and Last) selector function.
-- When the Node component is null, this means the iterator object was
-- constructed without a start expression, in which case the (forward)
-- iteration starts from the (logical) beginning of the entire sequence
-- of items (corresponding to Container.First, for a forward iterator).
-- Otherwise, this is iteration over a partial sequence of items. When
-- the Node component is non-null, the iterator object was constructed
-- with a start expression, that specifies the position from which the
-- (forward) partial iteration begins.
if Object.Node = 0 then
return First (Object.Container.all);
else
return (Node => Object.Node);
end if;
end First;
------------------- -------------------
-- First_Element -- -- First_Element --
------------------- -------------------
...@@ -915,6 +973,71 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -915,6 +973,71 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
B := B - 1; B := B - 1;
end Iterate; end Iterate;
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- component is null (as is the case here), this means the iterator
-- object was constructed without a start expression. This is a
-- complete iterator, meaning that the iteration starts from the
-- (logical) beginning of the sequence of items.
-- Note: For a forward iterator, Container.First is the beginning, and
-- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator :=
Iterator'(Ada.Finalization.Limited_Controlled with
Container => Container'Unrestricted_Access,
Node => 0)
do
B := B + 1;
end return;
end Iterate;
function Iterate (Container : List; Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
-- and iterate over the entire sequence of items. However, those
-- semantics were unintuitive and arguably error-prone (it is too easy
-- to accidentally create an endless loop), and so they were changed,
-- per the ARG meeting in Denver on 2011/11. However, there was no
-- consensus about what positive meaning this corner case should have,
-- and so it was decided to simply raise an exception. This does imply,
-- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items.
if not Has_Element (Container, Start) then
raise Constraint_Error with
"Start position for iterator is not a valid cursor";
end if;
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- component is non-null (as is the case here), it means that this
-- is a partial iteration, over a subset of the complete sequence of
-- items. The iterator object was constructed with a start expression,
-- indicating the position from which the iteration begins. Note that
-- the start position has the same value irrespective of whether this
-- is a forward or reverse iteration.
return It : constant Iterator :=
Iterator'(Ada.Finalization.Limited_Controlled with
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
B := B + 1;
end return;
end Iterate;
---------- ----------
-- Last -- -- Last --
---------- ----------
...@@ -927,6 +1050,28 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -927,6 +1050,28 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return (Node => Container.Last); return (Node => Container.Last);
end Last; end Last;
function Last (Object : Iterator) return Cursor is
begin
-- The value of the iterator object's Node component influences the
-- behavior of the Last (and First) selector function.
-- When the Node component is null, this means the iterator object was
-- constructed without a start expression, in which case the (reverse)
-- iteration starts from the (logical) beginning of the entire sequence
-- (corresponding to Container.Last, for a reverse iterator).
-- Otherwise, this is iteration over a partial sequence of items. When
-- the Node component is non-null, the iterator object was constructed
-- with a start expression, that specifies the position from which the
-- (reverse) partial iteration begins.
if Object.Node = 0 then
return Last (Object.Container.all);
else
return (Node => Object.Node);
end if;
end Last;
------------------ ------------------
-- Last_Element -- -- Last_Element --
------------------ ------------------
...@@ -1085,6 +1230,24 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1085,6 +1230,24 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return (Node => Container.Nodes (Position.Node).Next); return (Node => Container.Nodes (Position.Node).Next);
end Next; end Next;
function Next
(Object : Iterator;
Position : Cursor) return Cursor
is
begin
return Next (Object.Container.all, Position);
end Next;
--------------------
-- Not_No_Element --
--------------------
function Not_No_Element (Position : Cursor) return Boolean is
begin
return Position /= No_Element;
end Not_No_Element;
------------- -------------
-- Prepend -- -- Prepend --
------------- -------------
...@@ -1120,6 +1283,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1120,6 +1283,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return (Node => Container.Nodes (Position.Node).Prev); return (Node => Container.Nodes (Position.Node).Prev);
end Previous; end Previous;
function Previous
(Object : Iterator;
Position : Cursor) return Cursor
is
begin
return Previous (Object.Container.all, Position);
end Previous;
------------------- -------------------
-- Query_Element -- -- Query_Element --
------------------- -------------------
...@@ -1196,6 +1368,21 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1196,6 +1368,21 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
raise Program_Error with "attempt to stream list cursor"; raise Program_Error with "attempt to stream list cursor";
end Read; end Read;
---------------
-- Reference --
---------------
function Constant_Reference (Container : List; Position : Cursor)
return Constant_Reference_Type is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
return (Element => Container.Nodes (Position.Node).Element'Access);
end Constant_Reference;
--------------------- ---------------------
-- Replace_Element -- -- Replace_Element --
--------------------- ---------------------
......
gcc/ada/a-cfdlli.ads
...@@ -53,6 +53,7 @@ ...@@ -53,6 +53,7 @@
private with Ada.Streams; private with Ada.Streams;
with Ada.Containers; with Ada.Containers;
with Ada.Iterator_Interfaces;
generic generic
type Element_Type is private; type Element_Type is private;
...@@ -63,7 +64,10 @@ generic ...@@ -63,7 +64,10 @@ generic
package Ada.Containers.Formal_Doubly_Linked_Lists is package Ada.Containers.Formal_Doubly_Linked_Lists is
pragma Pure; pragma Pure;
type List (Capacity : Count_Type) is tagged private; type List (Capacity : Count_Type) is tagged private with
Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
-- pragma Preelaborable_Initialization (List); -- pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
...@@ -73,6 +77,17 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -73,6 +77,17 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is
No_Element : constant Cursor; No_Element : constant Cursor;
function Not_No_Element (Position : Cursor) return Boolean;
package List_Iterator_Interfaces is new
Ada.Iterator_Interfaces (Cursor => Cursor, Has_Element => Not_No_Element);
function Iterate (Container : List; Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class;
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class;
function "=" (Left, Right : List) return Boolean; function "=" (Left, Right : List) return Boolean;
function Length (Container : List) return Count_Type; function Length (Container : List) return Count_Type;
...@@ -225,6 +240,15 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -225,6 +240,15 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is
end Generic_Sorting; end Generic_Sorting;
type Constant_Reference_Type
(Element : not null access constant Element_Type) is private
with
Implicit_Dereference => Element;
function Constant_Reference
(Container : List; Position : Cursor) -- SHOULD BE ALIASED
return Constant_Reference_Type;
function Strict_Equal (Left, Right : List) return Boolean; function Strict_Equal (Left, Right : List) return Boolean;
-- Strict_Equal returns True if the containers are physically equal, i.e. -- Strict_Equal returns True if the containers are physically equal, i.e.
-- they are structurally equal (function "=" returns True) and that they -- they are structurally equal (function "=" returns True) and that they
...@@ -244,8 +268,9 @@ private ...@@ -244,8 +268,9 @@ private
type Node_Type is record type Node_Type is record
Prev : Count_Type'Base := -1; Prev : Count_Type'Base := -1;
Next : Count_Type; Next : Count_Type;
Element : Element_Type; Element : aliased Element_Type;
end record; end record;
function "=" (L, R : Node_Type) return Boolean is abstract; function "=" (L, R : Node_Type) return Boolean is abstract;
type Node_Array is array (Count_Type range <>) of Node_Type; type Node_Array is array (Count_Type range <>) of Node_Type;
...@@ -275,6 +300,9 @@ private ...@@ -275,6 +300,9 @@ private
for List'Write use Write; for List'Write use Write;
type List_Access is access all List;
for List_Access'Storage_Size use 0;
type Cursor is record type Cursor is record
Node : Count_Type := 0; Node : Count_Type := 0;
end record; end record;
...@@ -295,4 +323,7 @@ private ...@@ -295,4 +323,7 @@ private
No_Element : constant Cursor := (Node => 0); No_Element : constant Cursor := (Node => 0);
type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record;
end Ada.Containers.Formal_Doubly_Linked_Lists; end Ada.Containers.Formal_Doubly_Linked_Lists;
gcc/ada/exp_ch5.adb
...@@ -3003,7 +3003,7 @@ package body Exp_Ch5 is ...@@ -3003,7 +3003,7 @@ package body Exp_Ch5 is
-- Cursor : Cursor_type := First (Iter); -- Cursor : Cursor_type := First (Iter);
-- while Has_Element (Iter) loop -- while Has_Element (Iter) loop
-- declare -- declare
-- -- the block is added when Element_Type is controlled -- -- The block is added when Element_Type is controlled
-- Obj : Pack.Element_Type := Element (Cursor); -- Obj : Pack.Element_Type := Element (Cursor);
-- -- for the "of" loop form -- -- for the "of" loop form
...@@ -3052,7 +3052,7 @@ package body Exp_Ch5 is ...@@ -3052,7 +3052,7 @@ package body Exp_Ch5 is
-- The "of" case uses an internally generated cursor whose type -- The "of" case uses an internally generated cursor whose type
-- is found in the container package. The domain of iteration -- is found in the container package. The domain of iteration
-- is expanded into a call to the default Iterator function, but -- is expanded into a call to the default Iterator function, but
-- this expansion does not take place in a quantifier expressions -- this expansion does not take place in quantified expressions
-- that are analyzed with expansion disabled, and in that case the -- that are analyzed with expansion disabled, and in that case the
-- type of the iterator must be obtained from the aspect. -- type of the iterator must be obtained from the aspect.
...@@ -3103,8 +3103,8 @@ package body Exp_Ch5 is ...@@ -3103,8 +3103,8 @@ package body Exp_Ch5 is
New_List (Container_Arg))); New_List (Container_Arg)));
Analyze_And_Resolve (Name (I_Spec)); Analyze_And_Resolve (Name (I_Spec));
-- Find cursor type in proper iterator package, which -- Find cursor type in proper iterator package, which is an
-- is an instantiation of Iterator_Interfaces. -- instantiation of Iterator_Interfaces.
Ent := First_Entity (Pack); Ent := First_Entity (Pack);
while Present (Ent) loop while Present (Ent) loop
...@@ -3218,7 +3218,7 @@ package body Exp_Ch5 is ...@@ -3218,7 +3218,7 @@ package body Exp_Ch5 is
-- while Iterator.Has_Element loop -- while Iterator.Has_Element loop
-- <Stats> -- <Stats>
-- end loop; -- end loop;
--
-- Has_Element is the second actual in the iterator package -- Has_Element is the second actual in the iterator package
New_Loop := New_Loop :=
...@@ -3236,12 +3236,8 @@ package body Exp_Ch5 is ...@@ -3236,12 +3236,8 @@ package body Exp_Ch5 is
Statements => Stats, Statements => Stats,
End_Label => Empty); End_Label => Empty);
-- Make_Selected_Component (Loc,
-- Prefix => New_Reference_To (Cursor, Loc),
-- Selector_Name =>
-- Make_Identifier (Loc, Name_Has_Element))),
-- Create the declarations for Iterator and cursor and insert then -- Create the declarations for Iterator and cursor and insert them
-- before the source loop. Given that the domain of iteration is -- before the source loop. Given that the domain of iteration is
-- already an entity, the iterator is just a renaming of that -- already an entity, the iterator is just a renaming of that
-- entity. Possible optimization ??? -- entity. Possible optimization ???
......
gcc/ada/prj-conf.adb
...@@ -1157,8 +1157,8 @@ package body Prj.Conf is ...@@ -1157,8 +1157,8 @@ package body Prj.Conf is
if Path_FD /= Invalid_FD then if Path_FD /= Invalid_FD then
declare declare
Temp_Dir : constant String := Temp_Dir : constant String :=
Containing_Directory Containing_Directory
(Get_Name_String (Path_Name)); (Get_Name_String (Path_Name));
begin begin
GNAT.OS_Lib.Close (Path_FD); GNAT.OS_Lib.Close (Path_FD);
Args (3) := Args (3) :=
......
gcc/ada/sem_ch12.adb
...@@ -3795,10 +3795,10 @@ package body Sem_Ch12 is ...@@ -3795,10 +3795,10 @@ package body Sem_Ch12 is
then then
declare declare
Assoc : constant Node_Id := First (Generic_Associations (N)); Assoc : constant Node_Id := First (Generic_Associations (N));
begin begin
if not Has_Dimension_System if not Has_Dimension_System
(Etype (Explicit_Generic_Actual_Parameter (Assoc))) then (Etype (Explicit_Generic_Actual_Parameter (Assoc)))
then
Error_Msg_N ("type with a dimension system expected", Assoc); Error_Msg_N ("type with a dimension system expected", Assoc);
end if; end if;
end; end;
......
gcc/ada/sem_dim.adb
...@@ -217,57 +217,53 @@ package body Sem_Dim is ...@@ -217,57 +217,53 @@ package body Sem_Dim is
----------------------- -----------------------
procedure Analyze_Dimension_Assignment_Statement (N : Node_Id); procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
-- Subroutine of Analyze_Dimension for assignment statement -- Subroutine of Analyze_Dimension for assignment statement. Check that the
-- Check that the dimensions of the left-hand side and the right-hand side -- dimensions of the left-hand side and the right-hand side of N match.
-- of N match.
procedure Analyze_Dimension_Binary_Op (N : Node_Id); procedure Analyze_Dimension_Binary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for binary operators -- Subroutine of Analyze_Dimension for binary operators. Check the
-- Check the dimensions of the right and the left operand permit the -- dimensions of the right and the left operand permit the operation.
-- operation. Then, evaluate the resulting dimensions for each binary -- Then, evaluate the resulting dimensions for each binary operator.
-- operator.
procedure Analyze_Dimension_Component_Declaration (N : Node_Id); procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
-- Subroutine of Analyze_Dimension for component declaration -- Subroutine of Analyze_Dimension for component declaration. Check that
-- Check that the dimensions of the type of N and of the expression match. -- the dimensions of the type of N and of the expression match.
procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id); procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
-- Subroutine of Analyze_Dimension for extended return statement -- Subroutine of Analyze_Dimension for extended return statement. Check
-- Check that the dimensions of the returned type and of the returned -- that the dimensions of the returned type and of the returned object
-- object match. -- match.
procedure Analyze_Dimension_Function_Call (N : Node_Id); procedure Analyze_Dimension_Function_Call (N : Node_Id);
-- Subroutine of Analyze_Dimension for function call -- Subroutine of Analyze_Dimension for function call. General case:
-- General case: propagate the dimensions from the returned type to N. -- propagate the dimensions from the returned type to N. Elementary
-- Elementary function case (Ada.Numerics.Generic_Elementary_Functions): -- function case (Ada.Numerics.Generic_Elementary_Functions): If N
-- If N is a Sqrt call, then evaluate the resulting dimensions as half the -- is a Sqrt call, then evaluate the resulting dimensions as half the
-- dimensions of the parameter. Otherwise, verify that each parameters are -- dimensions of the parameter. Otherwise, verify that each parameters
-- dimensionless. -- are dimensionless.
procedure Analyze_Dimension_Has_Etype (N : Node_Id); procedure Analyze_Dimension_Has_Etype (N : Node_Id);
-- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
-- the list below: -- the list below:
-- N_Attribute_Reference -- N_Attribute_Reference
-- N_Identifier -- N_Identifier
-- N_Indexed_Component -- N_Indexed_Component
-- N_Qualified_Expression -- N_Qualified_Expression
-- N_Selected_Component -- N_Selected_Component
-- N_Slice -- N_Slice
-- N_Type_Conversion -- N_Type_Conversion
-- N_Unchecked_Type_Conversion -- N_Unchecked_Type_Conversion
procedure Analyze_Dimension_Object_Declaration (N : Node_Id); procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
-- Subroutine of Analyze_Dimension for object declaration -- Subroutine of Analyze_Dimension for object declaration. Check that
-- Check that the dimensions of the object type and the dimensions of the -- the dimensions of the object type and the dimensions of the expression
-- expression (if expression is present) match. -- (if expression is present) match. Note that when the expression is
-- Note that when the expression is a literal, no warning is returned. -- a literal, no warning is returned. This special case allows object
-- This special case allows object declaration such as: -- declaration such as: m : constant Length := 1.0;
-- m : constant Length := 1.0;
procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
-- Subroutine of Analyze_Dimension for object renaming declaration -- Subroutine of Analyze_Dimension for object renaming declaration. Check
-- Check the dimensions of the type and of the renamed object name of N -- the dimensions of the type and of the renamed object name of N match.
-- match.
procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id); procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
-- Subroutine of Analyze_Dimension for simple return statement -- Subroutine of Analyze_Dimension for simple return statement
...@@ -275,18 +271,18 @@ package body Sem_Dim is ...@@ -275,18 +271,18 @@ package body Sem_Dim is
-- expression match. -- expression match.
procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id); procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
-- Subroutine of Analyze_Dimension for subtype declaration -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
-- Propagate the dimensions from the parent type to the identifier of N. -- dimensions from the parent type to the identifier of N. Note that if
-- Note that if both the identifier and the parent type of N are not -- both the identifier and the parent type of N are not dimensionless,
-- dimensionless, return an error message. -- return an error message.
procedure Analyze_Dimension_Unary_Op (N : Node_Id); procedure Analyze_Dimension_Unary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for unary operators -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
-- For Plus, Minus and Abs operators, propagate the dimensions from the -- Abs operators, propagate the dimensions from the operand to N.
-- operand to N.
function Create_Rational_From (Expr : Node_Id; function Create_Rational_From
Complain : Boolean) return Rational; (Expr : Node_Id;
Complain : Boolean) return Rational;
-- Given an arbitrary expression Expr, return a valid rational if Expr can -- Given an arbitrary expression Expr, return a valid rational if Expr can
-- be interpreted as a rational. Otherwise return No_Rational and also an -- be interpreted as a rational. Otherwise return No_Rational and also an
-- error message if Complain is set to True. -- error message if Complain is set to True.
...@@ -301,14 +297,13 @@ package body Sem_Dim is ...@@ -301,14 +297,13 @@ package body Sem_Dim is
procedure Eval_Op_Expon_With_Rational_Exponent procedure Eval_Op_Expon_With_Rational_Exponent
(N : Node_Id; (N : Node_Id;
Exponent_Value : Rational); Exponent_Value : Rational);
-- Evaluate the Expon if the exponent is a rational and the operand has a -- Evaluate the exponent it is a rational and the operand has a dimension
-- dimension.
function Exists (Dim : Dimension_Type) return Boolean; function Exists (Dim : Dimension_Type) return Boolean;
-- Determine whether Dim does not denote the null dimension -- Returns True iff Dim does not denote the null dimension
function Exists (Sys : System_Type) return Boolean; function Exists (Sys : System_Type) return Boolean;
-- Determine whether Sys does not denote the null system -- Returns True iff Sys does not denote the null system
function From_Dimension_To_String_Of_Symbols function From_Dimension_To_String_Of_Symbols
(Dims : Dimension_Type; (Dims : Dimension_Type;
...@@ -317,7 +312,7 @@ package body Sem_Dim is ...@@ -317,7 +312,7 @@ package body Sem_Dim is
-- string of symbols. -- string of symbols.
function Is_Invalid (Position : Dimension_Position) return Boolean; function Is_Invalid (Position : Dimension_Position) return Boolean;
-- Determine whether Pos denotes the invalid position -- Return True if Pos denotes the invalid position
procedure Move_Dimensions (From : Node_Id; To : Node_Id); procedure Move_Dimensions (From : Node_Id; To : Node_Id);
-- Copy dimension vector of From to To, delete dimension vector of From -- Copy dimension vector of From to To, delete dimension vector of From
...@@ -385,7 +380,6 @@ package body Sem_Dim is ...@@ -385,7 +380,6 @@ package body Sem_Dim is
R : constant Rational := R : constant Rational :=
Rational'(Numerator => Left.Numerator * Right.Numerator, Rational'(Numerator => Left.Numerator * Right.Numerator,
Denominator => Left.Denominator * Right.Denominator); Denominator => Left.Denominator * Right.Denominator);
begin begin
return Reduce (R); return Reduce (R);
end "*"; end "*";
...@@ -558,14 +552,15 @@ package body Sem_Dim is ...@@ -558,14 +552,15 @@ package body Sem_Dim is
System : System_Type; System : System_Type;
Typ : Entity_Id; Typ : Entity_Id;
Errors_Count : Nat; Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler so far -- Errors_Count is a count of errors detected by the compiler so far
-- just before the extraction of names and values in the aggregate -- just before the extraction of names and values in the aggregate
-- (Step 3). -- (Step 3).
-- At the end of the analysis, there is a check to verify that --
-- this count equals to Serious_Errors_Detected i.e. no erros have been -- At the end of the analysis, there is a check to verify that this
-- encountered during the process. Otherwise the Dimension_Table is not -- count equals to Serious_Errors_Detected i.e. no erros have been
-- filled. -- encountered during the process. Otherwise the Dimension_Table is
-- not filled.
-- Start of processing for Analyze_Aspect_Dimension -- Start of processing for Analyze_Aspect_Dimension
...@@ -582,9 +577,8 @@ package body Sem_Dim is ...@@ -582,9 +577,8 @@ package body Sem_Dim is
System := System_Of (Typ); System := System_Of (Typ);
if Nkind (Sub_Ind) = N_Subtype_Indication then if Nkind (Sub_Ind) = N_Subtype_Indication then
Error_Msg_NE ("constraint not allowed with aspect&", Error_Msg_NE
Constraint (Sub_Ind), ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
Id);
return; return;
end if; end if;
...@@ -604,9 +598,8 @@ package body Sem_Dim is ...@@ -604,9 +598,8 @@ package body Sem_Dim is
-- declare a valid system. -- declare a valid system.
if not Exists (System) then if not Exists (System) then
Error_Msg_NE ("parent type of& lacks dimension system", Error_Msg_NE
Sub_Ind, ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
Def_Id);
return; return;
end if; end if;
...@@ -656,7 +649,6 @@ package body Sem_Dim is ...@@ -656,7 +649,6 @@ package body Sem_Dim is
while Present (Assoc) loop while Present (Assoc) loop
Expr := Expression (Assoc); Expr := Expression (Assoc);
Choice := First (Choices (Assoc)); Choice := First (Choices (Assoc));
while Present (Choice) loop while Present (Choice) loop
-- Identifier case: NAME => EXPRESSION -- Identifier case: NAME => EXPRESSION
...@@ -682,8 +674,10 @@ package body Sem_Dim is ...@@ -682,8 +674,10 @@ package body Sem_Dim is
begin begin
if Nkind (Low) /= N_Identifier then if Nkind (Low) /= N_Identifier then
Error_Msg_N ("bound must denote a dimension name", Low); Error_Msg_N ("bound must denote a dimension name", Low);
elsif Nkind (High) /= N_Identifier then elsif Nkind (High) /= N_Identifier then
Error_Msg_N ("bound must denote a dimension name", High); Error_Msg_N ("bound must denote a dimension name", High);
else else
Low_Pos := Position_In_System (Low, System); Low_Pos := Position_In_System (Low, System);
High_Pos := Position_In_System (High, System); High_Pos := Position_In_System (High, System);
...@@ -743,12 +737,10 @@ package body Sem_Dim is ...@@ -743,12 +737,10 @@ package body Sem_Dim is
end if; end if;
Num_Choices := Num_Choices + 1; Num_Choices := Num_Choices + 1;
Next (Choice); Next (Choice);
end loop; end loop;
Num_Dimensions := Num_Dimensions + 1; Num_Dimensions := Num_Dimensions + 1;
Next (Assoc); Next (Assoc);
end loop; end loop;
...@@ -774,6 +766,7 @@ package body Sem_Dim is ...@@ -774,6 +766,7 @@ package body Sem_Dim is
Start_String; Start_String;
Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl))); Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl)));
Symbol := End_String; Symbol := End_String;
else else
Symbol := Strval (Symbol_Decl); Symbol := Strval (Symbol_Decl);
end if; end if;
...@@ -836,7 +829,7 @@ package body Sem_Dim is ...@@ -836,7 +829,7 @@ package body Sem_Dim is
(Entity (Subtype_Indication (Type_Definition (N)))); (Entity (Subtype_Indication (Type_Definition (N))));
end Is_Derived_Numeric_Type; end Is_Derived_Numeric_Type;
-- Local variables -- Local variables
Dim_Name : Node_Id; Dim_Name : Node_Id;
Dim_Pair : Node_Id; Dim_Pair : Node_Id;
...@@ -850,10 +843,11 @@ package body Sem_Dim is ...@@ -850,10 +843,11 @@ package body Sem_Dim is
-- Errors_Count is a count of errors detected by the compiler so far -- Errors_Count is a count of errors detected by the compiler so far
-- just before the extraction of names and symbols in the aggregate -- just before the extraction of names and symbols in the aggregate
-- (Step 3). -- (Step 3).
-- At the end of the analysis, there is a check to verify that --
-- this count equals to Serious_Errors_Detected i.e. no erros have been -- At the end of the analysis, there is a check to verify that this
-- encountered during the process. Otherwise the System_Table is not -- count equals Serious_Errors_Detected i.e. no errors have been
-- filled. -- encountered during the process. Otherwise the System_Table is
-- not filled.
-- Start of processing for Analyze_Aspect_Dimension_System -- Start of processing for Analyze_Aspect_Dimension_System
...@@ -882,7 +876,6 @@ package body Sem_Dim is ...@@ -882,7 +876,6 @@ package body Sem_Dim is
Dim_Pair := First (Expressions (Aggr)); Dim_Pair := First (Expressions (Aggr));
Errors_Count := Serious_Errors_Detected; Errors_Count := Serious_Errors_Detected;
while Present (Dim_Pair) loop while Present (Dim_Pair) loop
Position := Position + 1; Position := Position + 1;
...@@ -941,14 +934,14 @@ package body Sem_Dim is ...@@ -941,14 +934,14 @@ package body Sem_Dim is
-- Verify that the string is not empty -- Verify that the string is not empty
if String_Length (Symbols (Position)) = 0 then if String_Length (Symbols (Position)) = 0 then
Error_Msg_N ("empty string not allowed here", Error_Msg_N
Dim_Symbol); ("empty string not allowed here", Dim_Symbol);
end if; end if;
end if; end if;
else else
Error_Msg_N ("two expressions expected in aggregate", Error_Msg_N
Dim_Pair); ("two expressions expected in aggregate", Dim_Pair);
end if; end if;
end if; end if;
end if; end if;
...@@ -1043,9 +1036,8 @@ package body Sem_Dim is ...@@ -1043,9 +1036,8 @@ package body Sem_Dim is
Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id); procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id);
-- Error using Error_Msg_N at node N -- Error using Error_Msg_N at node N. Output in the error message the
-- Output in the error message the dimensions of left and right hand -- dimensions of left and right hand sides.
-- sides.
---------------------------------------- ----------------------------------------
-- Error_Dim_For_Assignment_Statement -- -- Error_Dim_For_Assignment_Statement --
...@@ -1102,24 +1094,26 @@ package body Sem_Dim is ...@@ -1102,24 +1094,26 @@ package body Sem_Dim is
or else N_Kind in N_Op_Compare or else N_Kind in N_Op_Compare
then then
declare declare
L : constant Node_Id := Left_Opnd (N); L : constant Node_Id := Left_Opnd (N);
Dims_Of_L : constant Dimension_Type := Dimensions_Of (L); Dims_Of_L : constant Dimension_Type := Dimensions_Of (L);
L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L); L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
R : constant Node_Id := Right_Opnd (N); R : constant Node_Id := Right_Opnd (N);
Dims_Of_R : constant Dimension_Type := Dimensions_Of (R); Dims_Of_R : constant Dimension_Type := Dimensions_Of (R);
R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R); R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
Dims_Of_N : Dimension_Type := Null_Dimension; Dims_Of_N : Dimension_Type := Null_Dimension;
begin begin
-- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
-- Check both operands have same dimension -- Check both operands have same dimension
if Dims_Of_L /= Dims_Of_R then if Dims_Of_L /= Dims_Of_R then
Error_Dim_For_Binary_Op (N, L, R); Error_Dim_For_Binary_Op (N, L, R);
else else
-- Check both operands are not dimensionless -- Check both operands are not dimensionless
if Exists (Dims_Of_L) then if Exists (Dims_Of_L) then
Set_Dimensions (N, Dims_Of_L); Set_Dimensions (N, Dims_Of_L);
end if; end if;
...@@ -1128,11 +1122,13 @@ package body Sem_Dim is ...@@ -1128,11 +1122,13 @@ package body Sem_Dim is
-- N_Op_Multiply or N_Op_Divide case -- N_Op_Multiply or N_Op_Divide case
elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
-- Check at least one operand is not dimensionless -- Check at least one operand is not dimensionless
if L_Has_Dimensions or R_Has_Dimensions then if L_Has_Dimensions or R_Has_Dimensions then
-- Multiplication case -- Multiplication case
-- Get both operands dimensions and add them -- Get both operands dimensions and add them
if N_Kind = N_Op_Multiply then if N_Kind = N_Op_Multiply then
...@@ -1142,6 +1138,7 @@ package body Sem_Dim is ...@@ -1142,6 +1138,7 @@ package body Sem_Dim is
end loop; end loop;
-- Division case -- Division case
-- Get both operands dimensions and subtract them -- Get both operands dimensions and subtract them
else else
...@@ -1156,14 +1153,15 @@ package body Sem_Dim is ...@@ -1156,14 +1153,15 @@ package body Sem_Dim is
end if; end if;
end if; end if;
-- N_Op_Expon case -- Exponentiation case
-- Note that rational exponent are allowed for dimensioned operand
-- Note: a rational exponent is allowed for dimensioned operand
elsif N_Kind = N_Op_Expon then elsif N_Kind = N_Op_Expon then
-- Check the left operand is not dimensionless
-- Note that the value of the exponent must be known compile -- Check the left operand is not dimensionless. Note that the
-- time. Otherwise, the exponentiation evaluation will return -- value of the exponent must be known compile time. Otherwise,
-- an error message. -- the exponentiation evaluation will return an error message.
if L_Has_Dimensions if L_Has_Dimensions
and then Compile_Time_Known_Value (R) and then Compile_Time_Known_Value (R)
...@@ -1189,7 +1187,8 @@ package body Sem_Dim is ...@@ -1189,7 +1187,8 @@ package body Sem_Dim is
+Whole (UI_To_Int (Expr_Value (R))); +Whole (UI_To_Int (Expr_Value (R)));
end if; end if;
-- Integer operand case -- Integer operand case.
-- For integer operand, the exponent cannot be -- For integer operand, the exponent cannot be
-- interpreted as a rational. -- interpreted as a rational.
...@@ -1208,13 +1207,14 @@ package body Sem_Dim is ...@@ -1208,13 +1207,14 @@ package body Sem_Dim is
end; end;
end if; end if;
-- N_Op_Compare case -- Comparison cases
-- For relational operations, only a dimension checking is
-- For relational operations, only dimension checking is
-- performed (no propagation). -- performed (no propagation).
elsif N_Kind in N_Op_Compare then elsif N_Kind in N_Op_Compare then
if (L_Has_Dimensions or R_Has_Dimensions) if (L_Has_Dimensions or R_Has_Dimensions)
and then Dims_Of_L /= Dims_Of_R and then Dims_Of_L /= Dims_Of_R
then then
Error_Dim_For_Binary_Op (N, L, R); Error_Dim_For_Binary_Op (N, L, R);
end if; end if;
...@@ -1233,9 +1233,9 @@ package body Sem_Dim is ...@@ -1233,9 +1233,9 @@ package body Sem_Dim is
--------------------------------------------- ---------------------------------------------
procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
Id : constant Entity_Id := Defining_Identifier (N); Id : constant Entity_Id := Defining_Identifier (N);
Etyp : constant Entity_Id := Etype (Id); Etyp : constant Entity_Id := Etype (Id);
Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
Dims_Of_Expr : Dimension_Type; Dims_Of_Expr : Dimension_Type;
...@@ -1243,9 +1243,8 @@ package body Sem_Dim is ...@@ -1243,9 +1243,8 @@ package body Sem_Dim is
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Error using Error_Msg_N at node N -- Error using Error_Msg_N at node N. Output in the error message the
-- Output in the error message the dimensions of the type Etyp and the -- dimensions of the type Etyp and the expression Expr of N.
-- expression Expr of N.
----------------------------------------- -----------------------------------------
-- Error_Dim_For_Component_Declaration -- -- Error_Dim_For_Component_Declaration --
...@@ -1257,8 +1256,8 @@ package body Sem_Dim is ...@@ -1257,8 +1256,8 @@ package body Sem_Dim is
Expr : Node_Id) is Expr : Node_Id) is
begin begin
Error_Msg_N ("?dimensions mismatch in component declaration", N); Error_Msg_N ("?dimensions mismatch in component declaration", N);
Error_Msg_N ("?component type " & Dimensions_Msg_Of (Etyp), N); Error_Msg_N ("\?component type " & Dimensions_Msg_Of (Etyp), N);
Error_Msg_N ("?component expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\?component expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Component_Declaration; end Error_Dim_For_Component_Declaration;
-- Start of processing for Analyze_Dimension_Component_Declaration -- Start of processing for Analyze_Dimension_Component_Declaration
...@@ -1301,9 +1300,9 @@ package body Sem_Dim is ...@@ -1301,9 +1300,9 @@ package body Sem_Dim is
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Return_Obj_Id : Entity_Id); Return_Obj_Id : Entity_Id);
-- Error using Error_Msg_N at node N -- Warning using Error_Msg_N at node N. Output in the error message the
-- Output in the error message the dimensions of the returned type -- dimensions of the returned type Return_Etyp and the returned object
-- Return_Etyp and the returned object Return_Obj_Id of N. -- Return_Obj_Id of N.
--------------------------------------------- ---------------------------------------------
-- Error_Dim_For_Extended_Return_Statement -- -- Error_Dim_For_Extended_Return_Statement --
...@@ -1325,7 +1324,6 @@ package body Sem_Dim is ...@@ -1325,7 +1324,6 @@ package body Sem_Dim is
begin begin
if Present (Return_Obj_Decls) then if Present (Return_Obj_Decls) then
Return_Obj_Decl := First (Return_Obj_Decls); Return_Obj_Decl := First (Return_Obj_Decls);
while Present (Return_Obj_Decl) loop while Present (Return_Obj_Decl) loop
if Nkind (Return_Obj_Decl) = N_Object_Declaration then if Nkind (Return_Obj_Decl) = N_Object_Declaration then
Return_Obj_Id := Defining_Identifier (Return_Obj_Decl); Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
...@@ -1369,7 +1367,7 @@ package body Sem_Dim is ...@@ -1369,7 +1367,7 @@ package body Sem_Dim is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
-- Note that the node must come from source -- Note that the node must come from source (why not???)
if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call); Ent := Entity (Name_Call);
...@@ -1415,8 +1413,7 @@ package body Sem_Dim is ...@@ -1415,8 +1413,7 @@ package body Sem_Dim is
end if; end if;
-- All other functions in Ada.Numerics.Generic_Elementary_Functions -- All other functions in Ada.Numerics.Generic_Elementary_Functions
-- case. -- case. Note that all parameters here should be dimensionless.
-- Note that all parameters here should be dimensionless
else else
Actual := First (Actuals); Actual := First (Actuals);
...@@ -1427,8 +1424,8 @@ package body Sem_Dim is ...@@ -1427,8 +1424,8 @@ package body Sem_Dim is
Error_Msg_NE Error_Msg_NE
("?parameter should be dimensionless for elementary " ("?parameter should be dimensionless for elementary "
& "function&", Actual, Name_Call); & "function&", Actual, Name_Call);
Error_Msg_N ("?parameter " & Dimensions_Msg_Of (Actual), Error_Msg_N
Actual); ("?parameter " & Dimensions_Msg_Of (Actual), Actual);
end if; end if;
Next (Actual); Next (Actual);
...@@ -1460,11 +1457,12 @@ package body Sem_Dim is ...@@ -1460,11 +1457,12 @@ package body Sem_Dim is
-- Removal of dimensions in expression -- Removal of dimensions in expression
-- Wouldn't a case statement be clearer here???
if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then
declare declare
Expr : Node_Id; Expr : Node_Id;
Exprs : constant List_Id := Expressions (N); Exprs : constant List_Id := Expressions (N);
begin begin
if Present (Exprs) then if Present (Exprs) then
Expr := First (Exprs); Expr := First (Exprs);
...@@ -1475,11 +1473,9 @@ package body Sem_Dim is ...@@ -1475,11 +1473,9 @@ package body Sem_Dim is
end if; end if;
end; end;
elsif Nkind_In elsif Nkind_In (N_Kind, N_Qualified_Expression,
(N_Kind, N_Type_Conversion,
N_Qualified_Expression, N_Unchecked_Type_Conversion)
N_Type_Conversion,
N_Unchecked_Type_Conversion)
then then
Remove_Dimensions (Expression (N)); Remove_Dimensions (Expression (N));
...@@ -1503,9 +1499,8 @@ package body Sem_Dim is ...@@ -1503,9 +1499,8 @@ package body Sem_Dim is
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Error using Error_Msg_N at node N -- Warnings using Error_Msg_N at node N. Output in the error message the
-- Output in the error message the dimensions of the type Etyp and the -- dimensions of the type Etyp and the ???
-- expression Expr of N.
-------------------------------------- --------------------------------------
-- Error_Dim_For_Object_Declaration -- -- Error_Dim_For_Object_Declaration --
...@@ -1517,8 +1512,8 @@ package body Sem_Dim is ...@@ -1517,8 +1512,8 @@ package body Sem_Dim is
Expr : Node_Id) is Expr : Node_Id) is
begin begin
Error_Msg_N ("?dimensions mismatch in object declaration", N); Error_Msg_N ("?dimensions mismatch in object declaration", N);
Error_Msg_N ("?object type " & Dimensions_Msg_Of (Etyp), N); Error_Msg_N ("\?object type " & Dimensions_Msg_Of (Etyp), N);
Error_Msg_N ("?object expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\?object expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Object_Declaration; end Error_Dim_For_Object_Declaration;
-- Start of processing for Analyze_Dimension_Object_Declaration -- Start of processing for Analyze_Dimension_Object_Declaration
...@@ -1558,9 +1553,8 @@ package body Sem_Dim is ...@@ -1558,9 +1553,8 @@ package body Sem_Dim is
(N : Node_Id; (N : Node_Id;
Sub_Mark : Node_Id; Sub_Mark : Node_Id;
Renamed_Name : Node_Id); Renamed_Name : Node_Id);
-- Error using Error_Msg_N at node N -- Error using Error_Msg_N at node N. Output in the error message the
-- Output in the error message the dimensions of Sub_Mark and of -- dimensions of Sub_Mark and of Renamed_Name.
-- Renamed_Name.
----------------------------------------------- -----------------------------------------------
-- Error_Dim_For_Object_Renaming_Declaration -- -- Error_Dim_For_Object_Renaming_Declaration --
...@@ -1604,9 +1598,9 @@ package body Sem_Dim is ...@@ -1604,9 +1598,9 @@ package body Sem_Dim is
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Error using Error_Msg_N at node N -- Error using Error_Msg_N at node N. Output in the error message
-- Output in the error message the dimensions of the returned type -- the dimensions of the returned type Return_Etyp and the returned
-- Return_Etyp and the returned expression Expr of N. -- expression Expr of N.
------------------------------------------- -------------------------------------------
-- Error_Dim_For_Simple_Return_Statement -- -- Error_Dim_For_Simple_Return_Statement --
...@@ -1619,8 +1613,8 @@ package body Sem_Dim is ...@@ -1619,8 +1613,8 @@ package body Sem_Dim is
is is
begin begin
Error_Msg_N ("?dimensions mismatch in return statement", N); Error_Msg_N ("?dimensions mismatch in return statement", N);
Error_Msg_N ("?returned type " & Dimensions_Msg_Of (Return_Etyp), N); Error_Msg_N ("\?returned type " & Dimensions_Msg_Of (Return_Etyp), N);
Error_Msg_N ("?returned expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\?returned expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Simple_Return_Statement; end Error_Dim_For_Simple_Return_Statement;
-- Start of processing for Analyze_Dimension_Simple_Return_Statement -- Start of processing for Analyze_Dimension_Simple_Return_Statement
...@@ -1650,6 +1644,7 @@ package body Sem_Dim is ...@@ -1650,6 +1644,7 @@ package body Sem_Dim is
Dims_Of_Etyp := Dimensions_Of (Etyp); Dims_Of_Etyp := Dimensions_Of (Etyp);
if Exists (Dims_Of_Etyp) then if Exists (Dims_Of_Etyp) then
-- If subtype already has a dimension (from Aspect_Dimension), -- If subtype already has a dimension (from Aspect_Dimension),
-- it cannot inherit a dimension from its subtype. -- it cannot inherit a dimension from its subtype.
...@@ -1705,19 +1700,21 @@ package body Sem_Dim is ...@@ -1705,19 +1700,21 @@ package body Sem_Dim is
-- A rational number is a number that can be expressed as the quotient or -- A rational number is a number that can be expressed as the quotient or
-- fraction a/b of two integers, where b is non-zero. -- fraction a/b of two integers, where b is non-zero.
function Create_Rational_From (Expr : Node_Id; function Create_Rational_From
Complain : Boolean) return Rational is (Expr : Node_Id;
Complain : Boolean) return Rational
is
Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr); Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
Result : Rational := No_Rational; Result : Rational := No_Rational;
function Process_Minus (N : Node_Id) return Rational; function Process_Minus (N : Node_Id) return Rational;
-- Create a rational from a N_Op_Minus -- Create a rational from a N_Op_Minus node
function Process_Divide (N : Node_Id) return Rational; function Process_Divide (N : Node_Id) return Rational;
-- Create a rational from a N_Op_Divide -- Create a rational from a N_Op_Divide node
function Process_Literal (N : Node_Id) return Rational; function Process_Literal (N : Node_Id) return Rational;
-- Create a rational from a N_Integer_Literal -- Create a rational from a N_Integer_Literal node
------------------- -------------------
-- Process_Minus -- -- Process_Minus --
...@@ -1725,7 +1722,7 @@ package body Sem_Dim is ...@@ -1725,7 +1722,7 @@ package body Sem_Dim is
function Process_Minus (N : Node_Id) return Rational is function Process_Minus (N : Node_Id) return Rational is
Right : constant Node_Id := Original_Node (Right_Opnd (N)); Right : constant Node_Id := Original_Node (Right_Opnd (N));
Result : Rational := No_Rational; Result : Rational;
begin begin
-- Operand is an integer literal -- Operand is an integer literal
...@@ -1737,6 +1734,9 @@ package body Sem_Dim is ...@@ -1737,6 +1734,9 @@ package body Sem_Dim is
elsif Nkind (Right) = N_Op_Divide then elsif Nkind (Right) = N_Op_Divide then
Result := -Process_Divide (Right); Result := -Process_Divide (Right);
else
Result := No_Rational;
end if; end if;
return Result; return Result;
...@@ -1780,9 +1780,8 @@ package body Sem_Dim is ...@@ -1780,9 +1780,8 @@ package body Sem_Dim is
begin begin
-- Check the expression is either a division of two integers or an -- Check the expression is either a division of two integers or an
-- integer itself. -- integer itself. Note that the check applies to the original node
-- Note that the check applies to the original node since the node could -- since the node could have already been rewritten.
-- have already been rewritten.
-- Integer literal case -- Integer literal case
...@@ -1801,7 +1800,7 @@ package body Sem_Dim is ...@@ -1801,7 +1800,7 @@ package body Sem_Dim is
end if; end if;
-- When Expr cannot be interpreted as a rational and Complain is true, -- When Expr cannot be interpreted as a rational and Complain is true,
-- return an error message. -- generate an error message.
if Complain and then Result = No_Rational then if Complain and then Result = No_Rational then
Error_Msg_N ("must be a rational", Expr); Error_Msg_N ("must be a rational", Expr);
...@@ -1915,8 +1914,8 @@ package body Sem_Dim is ...@@ -1915,8 +1914,8 @@ package body Sem_Dim is
-- Eval_Op_Expon_For_Dimensioned_Type -- -- Eval_Op_Expon_For_Dimensioned_Type --
---------------------------------------- ----------------------------------------
-- Evaluate the expon operator for real dimensioned type -- Evaluate the expon operator for real dimensioned type. Note that the
-- Note that the node must come from source -- node must come from source. Why???
-- Note that if the exponent is an integer (denominator = 1) the node is -- Note that if the exponent is an integer (denominator = 1) the node is
-- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval). -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
...@@ -1937,9 +1936,7 @@ package body Sem_Dim is ...@@ -1937,9 +1936,7 @@ package body Sem_Dim is
-- Check that the exponent is not an integer -- Check that the exponent is not an integer
if R_Value /= No_Rational if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
and then R_Value.Denominator /= 1
then
Eval_Op_Expon_With_Rational_Exponent (N, R_Value); Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
else else
Eval_Op_Expon (N); Eval_Op_Expon (N);
...@@ -2051,7 +2048,7 @@ package body Sem_Dim is ...@@ -2051,7 +2048,7 @@ package body Sem_Dim is
Analyze (New_Subtyp_Decl_For_L); Analyze (New_Subtyp_Decl_For_L);
-- Case where the operand is dimensionless -- Case where the operand is dimensionless
else else
New_Id := Btyp_Of_L; New_Id := Btyp_Of_L;
...@@ -2068,8 +2065,9 @@ package body Sem_Dim is ...@@ -2068,8 +2065,9 @@ package body Sem_Dim is
-- (T (Expon_LLF (Actual_1, Actual_2))); -- (T (Expon_LLF (Actual_1, Actual_2)));
-- -- where T is the subtype declared in step 1 -- where T is the subtype declared in step 1
-- -- The node is rewritten as a type conversion
-- The node is rewritten as a type conversion
-- Step 1: Creation of the two parameters of Expon_LLF function call -- Step 1: Creation of the two parameters of Expon_LLF function call
...@@ -2098,7 +2096,7 @@ package body Sem_Dim is ...@@ -2098,7 +2096,7 @@ package body Sem_Dim is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Actual_1, Actual_2))); Actual_1, Actual_2)));
-- Step 3: Rewitten of N -- Step 3: Rewrite N with the result
Rewrite (N, New_N); Rewrite (N, New_N);
Set_Etype (N, New_Id); Set_Etype (N, New_Id);
...@@ -2128,9 +2126,10 @@ package body Sem_Dim is ...@@ -2128,9 +2126,10 @@ package body Sem_Dim is
-- symbols in the output of a dimensioned object. -- symbols in the output of a dimensioned object.
-- Case 1: the parameter is a variable -- Case 1: the parameter is a variable
-- The default string parameter is replaced by the symbol defined in the -- The default string parameter is replaced by the symbol defined in the
-- aspect Dimension of the subtype. -- aspect Dimension of the subtype. For instance to output a speed:
-- For instance if the user wants to output a speed:
-- subtype Force is Mks_Type -- subtype Force is Mks_Type
-- with -- with
-- Dimension => ("N", -- Dimension => ("N",
...@@ -2143,11 +2142,12 @@ package body Sem_Dim is ...@@ -2143,11 +2142,12 @@ package body Sem_Dim is
-- > 2.1 N -- > 2.1 N
-- Case 2: the parameter is an expression -- Case 2: the parameter is an expression
-- then we call the procedure Expand_Put_Call_With_Dimension_Symbol that
-- creates the string of symbols (for instance "m.s**(-1)") and rewrites -- In this case we call the procedure Expand_Put_Call_With_Dimension_Symbol
-- the default string parameter of Put with the corresponding the -- that creates the string of symbols (for instance "m.s**(-1)") and
-- String_Id. -- rewrites the default string parameter of Put with the corresponding
-- For instance: -- the String_Id. For instance:
-- Put (2.1 * m * kg * s**(-2)); -- Put (2.1 * m * kg * s**(-2));
-- > 2.1 m.kg.s**(-2) -- > 2.1 m.kg.s**(-2)
...@@ -2170,6 +2170,10 @@ package body Sem_Dim is ...@@ -2170,6 +2170,10 @@ package body Sem_Dim is
-- procedure Put defined in the package System.Dim_Float_IO and -- procedure Put defined in the package System.Dim_Float_IO and
-- System.Dim_Integer_IO. -- System.Dim_Integer_IO.
---------------------------
-- Is_Procedure_Put_Call --
---------------------------
function Is_Procedure_Put_Call return Boolean is function Is_Procedure_Put_Call return Boolean is
Ent : Entity_Id; Ent : Entity_Id;
...@@ -2307,9 +2311,9 @@ package body Sem_Dim is ...@@ -2307,9 +2311,9 @@ package body Sem_Dim is
-- From_Dimension_To_String_Of_Symbols -- -- From_Dimension_To_String_Of_Symbols --
----------------------------------------- -----------------------------------------
-- Given a dimension vector and the corresponding dimension system, create -- Given a dimension vector and the corresponding dimension system,
-- a String_Id to output the dimension symbols corresponding to the -- create a String_Id to output the dimension symbols corresponding to
-- dimensions Dims. -- the dimensions Dims.
function From_Dimension_To_String_Of_Symbols function From_Dimension_To_String_Of_Symbols
(Dims : Dimension_Type; (Dims : Dimension_Type;
...@@ -2492,7 +2496,6 @@ package body Sem_Dim is ...@@ -2492,7 +2496,6 @@ package body Sem_Dim is
declare declare
G : constant Int := GCD (X.Numerator, X.Denominator); G : constant Int := GCD (X.Numerator, X.Denominator);
begin begin
return Rational'(Numerator => Whole (Int (X.Numerator) / G), return Rational'(Numerator => Whole (Int (X.Numerator) / G),
Denominator => Whole (Int (X.Denominator) / G)); Denominator => Whole (Int (X.Denominator) / G));
......
gcc/ada/sem_dim.ads
...@@ -98,10 +98,9 @@ package Sem_Dim is ...@@ -98,10 +98,9 @@ package Sem_Dim is
Id : Entity_Id; Id : Entity_Id;
Aggr : Node_Id); Aggr : Node_Id);
-- Analyze the contents of aspect Dimension. Associate the provided values -- Analyze the contents of aspect Dimension. Associate the provided values
-- and quantifiers with the related context N. -- and quantifiers with the related context N. Id is the corresponding
-- Id is the corresponding Aspect_Id (Aspect_Dimension) -- Aspect_Id (Aspect_Dimension) Aggr is the corresponding expression for
-- Aggr is the corresponding expression for the aspect Dimension declared -- the aspect Dimension declared by the declaration of N.
-- by the declaration of N.
procedure Analyze_Aspect_Dimension_System procedure Analyze_Aspect_Dimension_System
(N : Node_Id; (N : Node_Id;
...@@ -141,9 +140,8 @@ package Sem_Dim is ...@@ -141,9 +140,8 @@ package Sem_Dim is
Btyp : Entity_Id); Btyp : Entity_Id);
-- Evaluate the Expon operator for dimensioned type with rational exponent. -- Evaluate the Expon operator for dimensioned type with rational exponent.
-- Indeed the regular Eval_Op_Expon routine (see package Sem_Eval) is -- Indeed the regular Eval_Op_Expon routine (see package Sem_Eval) is
-- restricted to Integer exponent. -- restricted to Integer exponent. This routine deals only with rational
-- This routine deals only with rational exponent which is not an integer -- exponent which is not an integer if Btyp is a dimensioned type.
-- if Btyp is a dimensioned type.
procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id); procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id);
-- Determine whether N denotes a subprogram call to one of the routines -- Determine whether N denotes a subprogram call to one of the routines
......
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