1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Errout
; use Errout
;
32 with Exp_Util
; use Exp_Util
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Rtsfind
; use Rtsfind
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Eval
; use Sem_Eval
;
42 with Sem_Res
; use Sem_Res
;
43 with Sem_Util
; use Sem_Util
;
44 with Sinfo
; use Sinfo
;
45 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
46 with Sinfo
.Utils
; use Sinfo
.Utils
;
47 with Snames
; use Snames
;
48 with Stand
; use Stand
;
49 with Stringt
; use Stringt
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
53 with Urealp
; use Urealp
;
57 package body Sem_Dim
is
59 -------------------------
60 -- Rational Arithmetic --
61 -------------------------
63 type Whole
is new Int
;
64 subtype Positive_Whole
is Whole
range 1 .. Whole
'Last;
66 type Rational
is record
68 Denominator
: Positive_Whole
;
71 Zero
: constant Rational
:= Rational
'(Numerator => 0,
74 No_Rational : constant Rational := Rational'(Numerator
=> 0,
76 -- Used to indicate an expression that cannot be interpreted as a rational
77 -- Returned value of the Create_Rational_From routine when parameter Expr
78 -- is not a static representation of a rational.
80 -- Rational constructors
82 function "+" (Right
: Whole
) return Rational
;
83 function GCD
(Left
, Right
: Whole
) return Int
;
84 function Reduce
(X
: Rational
) return Rational
;
86 -- Unary operator for Rational
88 function "-" (Right
: Rational
) return Rational
;
89 function "abs" (Right
: Rational
) return Rational
;
91 -- Rational operations for Rationals
93 function "+" (Left
, Right
: Rational
) return Rational
;
94 function "-" (Left
, Right
: Rational
) return Rational
;
95 function "*" (Left
, Right
: Rational
) return Rational
;
96 function "/" (Left
, Right
: Rational
) return Rational
;
102 Max_Number_Of_Dimensions
: constant := 7;
103 -- Maximum number of dimensions in a dimension system
105 High_Position_Bound
: constant := Max_Number_Of_Dimensions
;
106 Invalid_Position
: constant := 0;
107 Low_Position_Bound
: constant := 1;
109 subtype Dimension_Position
is
110 Nat
range Invalid_Position
.. High_Position_Bound
;
113 array (Dimension_Position
range
114 Low_Position_Bound
.. High_Position_Bound
) of Name_Id
;
115 -- Store the names of all units within a system
117 No_Names
: constant Name_Array
:= (others => No_Name
);
120 array (Dimension_Position
range
121 Low_Position_Bound
.. High_Position_Bound
) of String_Id
;
122 -- Store the symbols of all units within a system
124 No_Symbols
: constant Symbol_Array
:= (others => No_String
);
126 -- The following record should be documented field by field
128 type System_Type
is record
130 Unit_Names
: Name_Array
;
131 Unit_Symbols
: Symbol_Array
;
132 Dim_Symbols
: Symbol_Array
;
133 Count
: Dimension_Position
;
136 Null_System
: constant System_Type
:=
137 (Empty
, No_Names
, No_Symbols
, No_Symbols
, Invalid_Position
);
139 subtype System_Id
is Nat
;
141 -- The following table maps types to systems
143 package System_Table
is new Table
.Table
(
144 Table_Component_Type
=> System_Type
,
145 Table_Index_Type
=> System_Id
,
146 Table_Low_Bound
=> 1,
148 Table_Increment
=> 5,
149 Table_Name
=> "System_Table");
155 type Dimension_Type
is
156 array (Dimension_Position
range
157 Low_Position_Bound
.. High_Position_Bound
) of Rational
;
159 Null_Dimension
: constant Dimension_Type
:= (others => Zero
);
161 type Dimension_Table_Range
is range 0 .. 510;
162 function Dimension_Table_Hash
(Key
: Node_Id
) return Dimension_Table_Range
;
164 -- The following table associates nodes with dimensions
166 package Dimension_Table
is new
167 GNAT
.HTable
.Simple_HTable
168 (Header_Num
=> Dimension_Table_Range
,
169 Element
=> Dimension_Type
,
170 No_Element
=> Null_Dimension
,
172 Hash
=> Dimension_Table_Hash
,
179 type Symbol_Table_Range
is range 0 .. 510;
180 function Symbol_Table_Hash
(Key
: Entity_Id
) return Symbol_Table_Range
;
182 -- Each subtype with a dimension has a symbolic representation of the
183 -- related unit. This table establishes a relation between the subtype
186 package Symbol_Table
is new
187 GNAT
.HTable
.Simple_HTable
188 (Header_Num
=> Symbol_Table_Range
,
189 Element
=> String_Id
,
190 No_Element
=> No_String
,
192 Hash
=> Symbol_Table_Hash
,
195 -- The following array enumerates all contexts which may contain or
196 -- produce a dimension.
198 OK_For_Dimension
: constant array (Node_Kind
) of Boolean :=
199 (N_Attribute_Reference
=> True,
200 N_Case_Expression
=> True,
201 N_Expanded_Name
=> True,
202 N_Explicit_Dereference
=> True,
203 N_Defining_Identifier
=> True,
204 N_Function_Call
=> True,
205 N_Identifier
=> True,
206 N_If_Expression
=> True,
207 N_Indexed_Component
=> True,
208 N_Integer_Literal
=> True,
215 N_Op_Multiply
=> True,
218 N_Op_Subtract
=> True,
219 N_Qualified_Expression
=> True,
220 N_Real_Literal
=> True,
221 N_Selected_Component
=> True,
223 N_Type_Conversion
=> True,
224 N_Unchecked_Type_Conversion
=> True,
228 -----------------------
229 -- Local Subprograms --
230 -----------------------
232 procedure Analyze_Dimension_Assignment_Statement
(N
: Node_Id
);
233 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
234 -- dimensions of the left-hand side and the right-hand side of N match.
236 procedure Analyze_Dimension_Binary_Op
(N
: Node_Id
);
237 -- Subroutine of Analyze_Dimension for binary operators. Check the
238 -- dimensions of the right and the left operand permit the operation.
239 -- Then, evaluate the resulting dimensions for each binary operator.
241 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
);
242 -- Subroutine of Analyze_Dimension for component declaration. Check that
243 -- the dimensions of the type of N and of the expression match.
245 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
);
246 -- Subroutine of Analyze_Dimension for extended return statement. Check
247 -- that the dimensions of the returned type and of the returned object
250 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
);
251 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
253 -- N_Attribute_Reference
255 -- N_Indexed_Component
256 -- N_Qualified_Expression
257 -- N_Selected_Component
260 -- N_Unchecked_Type_Conversion
262 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
);
263 -- Verify that all alternatives have the same dimension
265 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
);
266 -- Verify that all alternatives have the same dimension
268 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
);
269 -- Procedure to analyze dimension of expression in a number declaration.
270 -- This allows a named number to have nontrivial dimensions, while by
271 -- default a named number is dimensionless.
273 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
);
274 -- Subroutine of Analyze_Dimension for object declaration. Check that
275 -- the dimensions of the object type and the dimensions of the expression
276 -- (if expression is present) match. Note that when the expression is
277 -- a literal, no error is returned. This special case allows object
278 -- declaration such as: m : constant Length := 1.0;
280 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
);
281 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
282 -- the dimensions of the type and of the renamed object name of N match.
284 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
);
285 -- Subroutine of Analyze_Dimension for simple return statement
286 -- Check that the dimensions of the returned type and of the returned
289 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
);
290 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
291 -- dimensions from the parent type to the identifier of N. Note that if
292 -- both the identifier and the parent type of N are not dimensionless,
295 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
);
296 -- Type conversions handle conversions between literals and dimensioned
297 -- types, from dimensioned types to their base type, and between different
298 -- dimensioned systems. Dimensions of the conversion are obtained either
299 -- from those of the expression, or from the target type, and dimensional
300 -- consistency must be checked when converting between values belonging
301 -- to different dimensioned systems.
303 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
);
304 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
305 -- Abs operators, propagate the dimensions from the operand to N.
307 function Create_Rational_From
309 Complain
: Boolean) return Rational
;
310 -- Given an arbitrary expression Expr, return a valid rational if Expr can
311 -- be interpreted as a rational. Otherwise return No_Rational and also an
312 -- error message if Complain is set to True.
314 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
;
315 -- Return the dimension vector of node N
317 function Dimensions_Msg_Of
319 Description_Needed
: Boolean := False) return String;
320 -- Given a node N, return the dimension symbols of N, preceded by "has
321 -- dimension" if Description_Needed. If N is dimensionless, return "'[']",
322 -- or "is dimensionless" if Description_Needed.
324 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
;
325 -- Given a type that has dimension information, return the type that is the
326 -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
327 -- type, i.e. a standard numeric type, return Empty.
329 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
330 -- Issue a warning on the given numeric literal N to indicate that the
331 -- compiler made the assumption that the literal is not dimensionless
332 -- but has the dimension of Typ.
334 procedure Eval_Op_Expon_With_Rational_Exponent
336 Exponent_Value
: Rational
);
337 -- Evaluate the exponent it is a rational and the operand has a dimension
339 function Exists
(Dim
: Dimension_Type
) return Boolean;
340 -- Returns True iff Dim does not denote the null dimension
342 function Exists
(Str
: String_Id
) return Boolean;
343 -- Returns True iff Str does not denote No_String
345 function Exists
(Sys
: System_Type
) return Boolean;
346 -- Returns True iff Sys does not denote the null system
348 function From_Dim_To_Str_Of_Dim_Symbols
349 (Dims
: Dimension_Type
;
350 System
: System_Type
;
351 In_Error_Msg
: Boolean := False) return String_Id
;
352 -- Given a dimension vector and a dimension system, return the proper
353 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
354 -- will be used to issue an error message) then this routine has a special
355 -- handling for the insertion characters * or [ which must be preceded by
356 -- a quote ' to be placed literally into the message.
358 function From_Dim_To_Str_Of_Unit_Symbols
359 (Dims
: Dimension_Type
;
360 System
: System_Type
) return String_Id
;
361 -- Given a dimension vector and a dimension system, return the proper
362 -- string of unit symbols.
364 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean;
365 -- Return True if E is the package entity of System.Dim.Float_IO or
366 -- System.Dim.Integer_IO.
368 function Is_Invalid
(Position
: Dimension_Position
) return Boolean;
369 -- Return True if Pos denotes the invalid position
371 procedure Move_Dimensions
(From
: Node_Id
; To
: Node_Id
);
372 -- Copy dimension vector of From to To and delete dimension vector of From
374 procedure Remove_Dimensions
(N
: Node_Id
);
375 -- Remove the dimension vector of node N
377 procedure Set_Dimensions
(N
: Node_Id
; Val
: Dimension_Type
);
378 -- Associate a dimension vector with a node
380 procedure Set_Symbol
(E
: Entity_Id
; Val
: String_Id
);
381 -- Associate a symbol representation of a dimension vector with a subtype
383 function Symbol_Of
(E
: Entity_Id
) return String_Id
;
384 -- E denotes a subtype with a dimension. Return the symbol representation
385 -- of the dimension vector.
387 function System_Of
(E
: Entity_Id
) return System_Type
;
388 -- E denotes a type, return associated system of the type if it has one
394 function "+" (Right
: Whole
) return Rational
is
396 return Rational
'(Numerator => Right, Denominator => 1);
399 function "+" (Left, Right : Rational) return Rational is
400 R : constant Rational :=
401 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
+
402 Left
.Denominator
* Right
.Numerator
,
403 Denominator
=> Left
.Denominator
* Right
.Denominator
);
412 function "-" (Right
: Rational
) return Rational
is
414 return Rational
'(Numerator => -Right.Numerator,
415 Denominator => Right.Denominator);
418 function "-" (Left, Right : Rational) return Rational is
419 R : constant Rational :=
420 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
-
421 Left
.Denominator
* Right
.Numerator
,
422 Denominator
=> Left
.Denominator
* Right
.Denominator
);
432 function "*" (Left
, Right
: Rational
) return Rational
is
433 R
: constant Rational
:=
434 Rational
'(Numerator => Left.Numerator * Right.Numerator,
435 Denominator => Left.Denominator * Right.Denominator);
444 function "/" (Left, Right : Rational) return Rational is
445 R : constant Rational := abs Right;
446 L : Rational := Left;
449 if Right.Numerator < 0 then
450 L.Numerator := Whole (-Integer (L.Numerator));
453 return Reduce (Rational'(Numerator
=> L
.Numerator
* R
.Denominator
,
454 Denominator
=> L
.Denominator
* R
.Numerator
));
461 function "abs" (Right
: Rational
) return Rational
is
463 return Rational
'(Numerator => abs Right.Numerator,
464 Denominator => Right.Denominator);
467 ------------------------------
468 -- Analyze_Aspect_Dimension --
469 ------------------------------
472 -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
474 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
476 -- DIMENSION_VALUE ::=
478 -- | others => RATIONAL
479 -- | DISCRETE_CHOICE_LIST => RATIONAL
481 -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
483 -- Note that when the dimensioned type is an integer type, then any
484 -- dimension value must be an integer literal.
486 procedure Analyze_Aspect_Dimension
491 Def_Id : constant Entity_Id := Defining_Identifier (N);
493 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
494 -- This array is used when processing ranges or Others_Choice as part of
495 -- the dimension aggregate.
497 Dimensions : Dimension_Type := Null_Dimension;
499 procedure Extract_Power
501 Position : Dimension_Position);
502 -- Given an expression with denotes a rational number, read the number
503 -- and associate it with Position in Dimensions.
505 function Position_In_System
507 System : System_Type) return Dimension_Position;
508 -- Given an identifier which denotes a dimension, return the position of
509 -- that dimension within System.
515 procedure Extract_Power
517 Position : Dimension_Position)
520 Dimensions (Position) := Create_Rational_From (Expr, True);
521 Processed (Position) := True;
523 -- If the dimensioned root type is an integer type, it is not
524 -- particularly useful, and fractional dimensions do not make
525 -- much sense for such types, so previously we used to reject
526 -- dimensions of integer types that were not integer literals.
527 -- However, the manipulation of dimensions does not depend on
528 -- the kind of root type, so we can accept this usage for rare
529 -- cases where dimensions are specified for integer values.
533 ------------------------
534 -- Position_In_System --
535 ------------------------
537 function Position_In_System
539 System : System_Type) return Dimension_Position
541 Dimension_Name : constant Name_Id := Chars (Id);
544 for Position in System.Unit_Names'Range loop
545 if Dimension_Name = System.Unit_Names (Position) then
550 return Invalid_Position;
551 end Position_In_System;
558 Num_Choices : Nat := 0;
559 Num_Dimensions : Nat := 0;
560 Others_Seen : Boolean := False;
563 Symbol : String_Id := No_String;
564 Symbol_Expr : Node_Id;
565 System : System_Type;
569 -- Errors_Count is a count of errors detected by the compiler so far
570 -- just before the extraction of symbol, names and values in the
571 -- aggregate (Step 2).
573 -- At the end of the analysis, there is a check to verify that this
574 -- count equals to Serious_Errors_Detected i.e. no erros have been
575 -- encountered during the process. Otherwise the Dimension_Table is
578 -- Start of processing for Analyze_Aspect_Dimension
581 -- STEP 1: Legality of aspect
583 if Nkind (N) /= N_Subtype_Declaration then
584 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
588 Sub_Ind := Subtype_Indication (N);
589 Typ := Etype (Sub_Ind);
590 System := System_Of (Typ);
592 if Nkind (Sub_Ind) = N_Subtype_Indication then
594 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
598 -- The dimension declarations are useless if the parent type does not
599 -- declare a valid system.
601 if not Exists (System) then
603 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
607 if Nkind (Aggr) /= N_Aggregate then
608 Error_Msg_N ("aggregate expected", Aggr);
612 -- STEP 2: Symbol, Names and values extraction
614 -- Get the number of errors detected by the compiler so far
616 Errors_Count := Serious_Errors_Detected;
618 -- STEP 2a: Symbol extraction
620 -- The first entry in the aggregate may be the symbolic representation
623 -- Positional symbol argument
625 Symbol_Expr := First (Expressions (Aggr));
627 -- Named symbol argument
630 or else Nkind (Symbol_Expr) not in
631 N_Character_Literal | N_String_Literal
633 Symbol_Expr := Empty;
635 -- Component associations present
637 if Present (Component_Associations (Aggr)) then
638 Assoc := First (Component_Associations (Aggr));
639 Choice := First (Choices (Assoc));
641 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
643 -- Symbol component association is present
645 if Chars (Choice) = Name_Symbol then
646 Num_Choices := Num_Choices + 1;
647 Symbol_Expr := Expression (Assoc);
649 -- Verify symbol expression is a string or a character
651 if Nkind (Symbol_Expr) not in
652 N_Character_Literal | N_String_Literal
654 Symbol_Expr := Empty;
656 ("symbol expression must be character or string",
660 -- Special error if no Symbol choice but expression is string
663 elsif Nkind (Expression (Assoc)) in
664 N_Character_Literal | N_String_Literal
666 Num_Choices := Num_Choices + 1;
668 ("optional component Symbol expected, found&", Choice);
674 -- STEP 2b: Names and values extraction
676 -- Positional elements
678 Expr := First (Expressions (Aggr));
680 -- Skip the symbol expression when present
682 if Present (Symbol_Expr) and then Num_Choices = 0 then
686 Position := Low_Position_Bound;
687 while Present (Expr) loop
688 if Position > High_Position_Bound then
690 ("type& has more dimensions than system allows", Def_Id);
694 Extract_Power (Expr, Position);
696 Position := Position + 1;
697 Num_Dimensions := Num_Dimensions + 1;
704 Assoc := First (Component_Associations (Aggr));
706 -- Skip the symbol association when present
708 if Num_Choices = 1 then
712 while Present (Assoc) loop
713 Expr := Expression (Assoc);
715 Choice := First (Choices (Assoc));
716 while Present (Choice) loop
718 -- Identifier case: NAME => EXPRESSION
720 if Nkind (Choice) = N_Identifier then
721 Position := Position_In_System (Choice, System);
723 if Is_Invalid (Position) then
724 Error_Msg_N ("dimension name& not part of system", Choice);
726 Extract_Power (Expr, Position);
729 -- Range case: NAME .. NAME => EXPRESSION
731 elsif Nkind (Choice) = N_Range then
733 Low : constant Node_Id := Low_Bound (Choice);
734 High : constant Node_Id := High_Bound (Choice);
735 Low_Pos : Dimension_Position;
736 High_Pos : Dimension_Position;
739 if Nkind (Low) /= N_Identifier then
740 Error_Msg_N ("bound must denote a dimension name", Low);
742 elsif Nkind (High) /= N_Identifier then
743 Error_Msg_N ("bound must denote a dimension name", High);
746 Low_Pos := Position_In_System (Low, System);
747 High_Pos := Position_In_System (High, System);
749 if Is_Invalid (Low_Pos) then
750 Error_Msg_N ("dimension name& not part of system",
753 elsif Is_Invalid (High_Pos) then
754 Error_Msg_N ("dimension name& not part of system",
757 elsif Low_Pos > High_Pos then
758 Error_Msg_N ("expected low to high range", Choice);
761 for Position in Low_Pos .. High_Pos loop
762 Extract_Power (Expr, Position);
768 -- Others case: OTHERS => EXPRESSION
770 elsif Nkind (Choice) = N_Others_Choice then
771 if Present (Next (Choice)) or else Present (Prev (Choice)) then
773 ("OTHERS must appear alone in a choice list", Choice);
775 elsif Present (Next (Assoc)) then
777 ("OTHERS must appear last in an aggregate", Choice);
779 elsif Others_Seen then
780 Error_Msg_N ("multiple OTHERS not allowed", Choice);
783 -- Fill the non-processed dimensions with the default value
784 -- supplied by others.
786 for Position in Processed'Range loop
787 if not Processed (Position) then
788 Extract_Power (Expr, Position);
795 -- All other cases are illegal declarations of dimension names
798 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
801 Num_Choices := Num_Choices + 1;
805 Num_Dimensions := Num_Dimensions + 1;
809 -- STEP 3: Consistency of system and dimensions
811 if Present (First (Expressions (Aggr)))
812 and then (First (Expressions (Aggr)) /= Symbol_Expr
813 or else Present (Next (Symbol_Expr)))
814 and then (Num_Choices > 1
815 or else (Num_Choices = 1 and then not Others_Seen))
818 ("named associations cannot follow positional associations", Aggr);
821 if Num_Dimensions > System.Count then
822 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
824 elsif Num_Dimensions < System.Count and then not Others_Seen then
825 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
828 -- STEP 4: Dimension symbol extraction
830 if Present (Symbol_Expr) then
831 if Nkind (Symbol_Expr) = N_Character_Literal then
833 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
834 Symbol := End_String;
837 Symbol := Strval (Symbol_Expr);
840 if String_Length (Symbol) = 0 then
841 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
845 -- STEP 5: Storage of extracted values
847 -- Check that no errors have been detected during the analysis
849 if Errors_Count = Serious_Errors_Detected then
851 -- Check for useless declaration
853 if Symbol = No_String and then not Exists (Dimensions) then
854 Error_Msg_N ("useless dimension declaration", Aggr);
857 if Symbol /= No_String then
858 Set_Symbol (Def_Id, Symbol);
861 if Exists (Dimensions) then
862 Set_Dimensions (Def_Id, Dimensions);
865 end Analyze_Aspect_Dimension;
867 -------------------------------------
868 -- Analyze_Aspect_Dimension_System --
869 -------------------------------------
871 -- with Dimension_System => (DIMENSION {, DIMENSION});
874 -- [Unit_Name =>] IDENTIFIER,
875 -- [Unit_Symbol =>] SYMBOL,
876 -- [Dim_Symbol =>] SYMBOL)
878 procedure Analyze_Aspect_Dimension_System
883 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
884 -- Determine whether type declaration N denotes a numeric derived type
886 -------------------------------
887 -- Is_Derived_Numeric_Type --
888 -------------------------------
890 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
893 Nkind (N) = N_Full_Type_Declaration
894 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
895 and then Is_Numeric_Type
896 (Entity (Subtype_Indication (Type_Definition (N))));
897 end Is_Derived_Numeric_Type;
904 Dim_Symbol : Node_Id;
905 Dim_Symbols : Symbol_Array := No_Symbols;
906 Dim_System : System_Type := Null_System;
907 Position : Dimension_Position := Invalid_Position;
909 Unit_Names : Name_Array := No_Names;
910 Unit_Symbol : Node_Id;
911 Unit_Symbols : Symbol_Array := No_Symbols;
914 -- Errors_Count is a count of errors detected by the compiler so far
915 -- just before the extraction of names and symbols in the aggregate
918 -- At the end of the analysis, there is a check to verify that this
919 -- count equals Serious_Errors_Detected i.e. no errors have been
920 -- encountered during the process. Otherwise the System_Table is
923 -- Start of processing for Analyze_Aspect_Dimension_System
926 -- STEP 1: Legality of aspect
928 if not Is_Derived_Numeric_Type (N) then
930 ("aspect& must apply to numeric derived type declaration", N, Id);
934 if Nkind (Aggr) /= N_Aggregate then
935 Error_Msg_N ("aggregate expected", Aggr);
939 -- STEP 2: Structural verification of the dimension aggregate
941 if Present (Component_Associations (Aggr)) then
942 Error_Msg_N ("expected positional aggregate", Aggr);
946 -- STEP 3: Name and Symbol extraction
948 Dim_Aggr := First (Expressions (Aggr));
949 Errors_Count := Serious_Errors_Detected;
950 while Present (Dim_Aggr) loop
951 if Position = High_Position_Bound then
952 Error_Msg_N ("too many dimensions in system", Aggr);
956 Position := Position + 1;
958 if Nkind (Dim_Aggr) /= N_Aggregate then
959 Error_Msg_N ("aggregate expected", Dim_Aggr);
962 if Present (Component_Associations (Dim_Aggr))
963 and then Present (Expressions (Dim_Aggr))
966 ("mixed positional/named aggregate not allowed here",
969 -- Verify each dimension aggregate has three arguments
971 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
972 and then List_Length (Expressions (Dim_Aggr)) /= 3
975 ("three components expected in aggregate", Dim_Aggr);
978 -- Named dimension aggregate
980 if Present (Component_Associations (Dim_Aggr)) then
982 -- Check first argument denotes the unit name
984 Assoc := First (Component_Associations (Dim_Aggr));
985 Choice := First (Choices (Assoc));
986 Unit_Name := Expression (Assoc);
988 if Present (Next (Choice))
989 or else Nkind (Choice) /= N_Identifier
991 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
993 elsif Chars (Choice) /= Name_Unit_Name then
994 Error_Msg_N ("expected Unit_Name, found&", Choice);
997 -- Check the second argument denotes the unit symbol
1000 Choice := First (Choices (Assoc));
1001 Unit_Symbol := Expression (Assoc);
1003 if Present (Next (Choice))
1004 or else Nkind (Choice) /= N_Identifier
1006 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1008 elsif Chars (Choice) /= Name_Unit_Symbol then
1009 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1012 -- Check the third argument denotes the dimension symbol
1015 Choice := First (Choices (Assoc));
1016 Dim_Symbol := Expression (Assoc);
1018 if Present (Next (Choice))
1019 or else Nkind (Choice) /= N_Identifier
1021 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1022 elsif Chars (Choice) /= Name_Dim_Symbol then
1023 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1026 -- Positional dimension aggregate
1029 Unit_Name := First (Expressions (Dim_Aggr));
1030 Unit_Symbol := Next (Unit_Name);
1031 Dim_Symbol := Next (Unit_Symbol);
1034 -- Check the first argument for each dimension aggregate is
1037 if Nkind (Unit_Name) = N_Identifier then
1038 Unit_Names (Position) := Chars (Unit_Name);
1040 Error_Msg_N ("expected unit name", Unit_Name);
1043 -- Check the second argument for each dimension aggregate is
1044 -- a string or a character.
1046 if Nkind (Unit_Symbol) not in
1047 N_String_Literal | N_Character_Literal
1050 ("expected unit symbol (string or character)",
1056 if Nkind (Unit_Symbol) = N_String_Literal then
1057 Unit_Symbols (Position) := Strval (Unit_Symbol);
1064 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1065 Unit_Symbols (Position) := End_String;
1068 -- Verify that the string is not empty
1070 if String_Length (Unit_Symbols (Position)) = 0 then
1072 ("empty string not allowed here", Unit_Symbol);
1076 -- Check the third argument for each dimension aggregate is
1077 -- a string or a character.
1079 if Nkind (Dim_Symbol) not in
1080 N_String_Literal | N_Character_Literal
1083 ("expected dimension symbol (string or character)",
1089 if Nkind (Dim_Symbol) = N_String_Literal then
1090 Dim_Symbols (Position) := Strval (Dim_Symbol);
1097 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1098 Dim_Symbols (Position) := End_String;
1101 -- Verify that the string is not empty
1103 if String_Length (Dim_Symbols (Position)) = 0 then
1104 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1113 -- STEP 4: Storage of extracted values
1115 -- Check that no errors have been detected during the analysis
1117 if Errors_Count = Serious_Errors_Detected then
1118 Dim_System.Type_Decl := N;
1119 Dim_System.Unit_Names := Unit_Names;
1120 Dim_System.Unit_Symbols := Unit_Symbols;
1121 Dim_System.Dim_Symbols := Dim_Symbols;
1122 Dim_System.Count := Position;
1123 System_Table.Append (Dim_System);
1125 end Analyze_Aspect_Dimension_System;
1127 -----------------------
1128 -- Analyze_Dimension --
1129 -----------------------
1131 -- This dispatch routine propagates dimensions for each node
1133 procedure Analyze_Dimension (N : Node_Id) is
1135 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1136 -- dimensions for nodes that don't come from source, except for subtype
1137 -- declarations where the dimensions are inherited from the base type,
1138 -- for explicit dereferences generated when expanding iterators, and
1139 -- for object declarations generated for inlining.
1141 if Ada_Version < Ada_2012 then
1144 -- Inlined bodies have already been checked for dimensionality
1146 elsif In_Inlined_Body then
1149 elsif not Comes_From_Source (N) then
1150 if Nkind (N) not in N_Explicit_Dereference
1152 | N_Object_Declaration
1153 | N_Subtype_Declaration
1160 when N_Assignment_Statement =>
1161 Analyze_Dimension_Assignment_Statement (N);
1164 Analyze_Dimension_Binary_Op (N);
1166 when N_Case_Expression =>
1167 Analyze_Dimension_Case_Expression (N);
1169 when N_Component_Declaration =>
1170 Analyze_Dimension_Component_Declaration (N);
1172 when N_Extended_Return_Statement =>
1173 Analyze_Dimension_Extended_Return_Statement (N);
1175 when N_Attribute_Reference
1177 | N_Explicit_Dereference
1179 | N_Indexed_Component
1180 | N_Qualified_Expression
1181 | N_Selected_Component
1183 | N_Unchecked_Type_Conversion
1185 Analyze_Dimension_Has_Etype (N);
1187 -- In the presence of a repaired syntax error, an identifier may be
1188 -- introduced without a usable type.
1190 when N_Identifier =>
1191 if Present (Etype (N)) then
1192 Analyze_Dimension_Has_Etype (N);
1195 when N_If_Expression =>
1196 Analyze_Dimension_If_Expression (N);
1198 when N_Number_Declaration =>
1199 Analyze_Dimension_Number_Declaration (N);
1201 when N_Object_Declaration =>
1202 Analyze_Dimension_Object_Declaration (N);
1204 when N_Object_Renaming_Declaration =>
1205 Analyze_Dimension_Object_Renaming_Declaration (N);
1207 when N_Simple_Return_Statement =>
1208 if not Comes_From_Extended_Return_Statement (N) then
1209 Analyze_Dimension_Simple_Return_Statement (N);
1212 when N_Subtype_Declaration =>
1213 Analyze_Dimension_Subtype_Declaration (N);
1215 when N_Type_Conversion =>
1216 Analyze_Dimension_Type_Conversion (N);
1219 Analyze_Dimension_Unary_Op (N);
1224 end Analyze_Dimension;
1226 ---------------------------------------
1227 -- Analyze_Dimension_Array_Aggregate --
1228 ---------------------------------------
1230 procedure Analyze_Dimension_Array_Aggregate
1232 Comp_Typ : Entity_Id)
1234 Comp_Ass : constant List_Id := Component_Associations (N);
1235 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1236 Exps : constant List_Id := Expressions (N);
1239 Dims_Of_Expr : Dimension_Type;
1242 Error_Detected : Boolean := False;
1243 -- This flag is used in order to indicate if an error has been detected
1244 -- so far by the compiler in this routine.
1247 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1248 -- base type is not a dimensioned type.
1250 -- Inlined bodies have already been checked for dimensionality.
1252 -- Note that here the original node must come from source since the
1253 -- original array aggregate may not have been entirely decorated.
1255 if Ada_Version < Ada_2012
1256 or else In_Inlined_Body
1257 or else not Comes_From_Source (Original_Node (N))
1258 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1263 -- Check whether there is any positional component association
1265 if Is_Empty_List (Exps) then
1266 Comp := First (Comp_Ass);
1268 Comp := First (Exps);
1271 while Present (Comp) loop
1273 -- Get the expression from the component
1275 if Nkind (Comp) = N_Component_Association then
1276 Expr := Expression (Comp);
1281 -- Issue an error if the dimensions of the component type and the
1282 -- dimensions of the component mismatch.
1284 -- Note that we must ensure the expression has been fully analyzed
1285 -- since it may not be decorated at this point. We also don't want to
1286 -- issue the same error message multiple times on the same expression
1287 -- (may happen when an aggregate is converted into a positional
1288 -- aggregate). We also must verify that this is a scalar component,
1289 -- and not a subaggregate of a multidimensional aggregate.
1290 -- The expression may be an identifier that has been copied several
1291 -- times during expansion, its dimensions are those of its type.
1293 if Is_Entity_Name (Expr) then
1294 Dims_Of_Expr := Dimensions_Of (Etype (Expr));
1296 Dims_Of_Expr := Dimensions_Of (Expr);
1299 if Comes_From_Source (Original_Node (Expr))
1300 and then Present (Etype (Expr))
1301 and then Is_Numeric_Type (Etype (Expr))
1302 and then Dims_Of_Expr /= Dims_Of_Comp_Typ
1303 and then Sloc (Comp) /= Sloc (Prev (Comp))
1305 -- Check if an error has already been encountered so far
1307 if not Error_Detected then
1308 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1309 Error_Detected := True;
1313 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1314 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1317 -- Look at the named components right after the positional components
1320 and then List_Containing (Comp) = Exps
1322 Comp := First (Comp_Ass);
1327 end Analyze_Dimension_Array_Aggregate;
1329 --------------------------------------------
1330 -- Analyze_Dimension_Assignment_Statement --
1331 --------------------------------------------
1333 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1334 Lhs : constant Node_Id := Name (N);
1335 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1336 Rhs : constant Node_Id := Expression (N);
1337 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1339 procedure Error_Dim_Msg_For_Assignment_Statement
1343 -- Error using Error_Msg_N at node N. Output the dimensions of left
1344 -- and right hand sides.
1346 --------------------------------------------
1347 -- Error_Dim_Msg_For_Assignment_Statement --
1348 --------------------------------------------
1350 procedure Error_Dim_Msg_For_Assignment_Statement
1356 Error_Msg_N ("dimensions mismatch in assignment", N);
1357 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1358 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1359 end Error_Dim_Msg_For_Assignment_Statement;
1361 -- Start of processing for Analyze_Dimension_Assignment
1364 if Dims_Of_Lhs /= Dims_Of_Rhs then
1365 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1367 end Analyze_Dimension_Assignment_Statement;
1369 ---------------------------------
1370 -- Analyze_Dimension_Binary_Op --
1371 ---------------------------------
1373 -- Check and propagate the dimensions for binary operators
1374 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1376 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1377 N_Kind : constant Node_Kind := Nkind (N);
1379 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1380 -- If the operand is a numeric literal that comes from a declared
1381 -- constant, use the dimensions of the constant which were computed
1382 -- from the expression of the constant declaration. Otherwise the
1383 -- dimensions are those of the operand, or the type of the operand.
1384 -- This takes care of node rewritings from validity checks, where the
1385 -- dimensions of the operand itself may not be preserved, while the
1386 -- type comes from context and must have dimension information.
1388 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1389 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1390 -- dimensions of both operands.
1392 ---------------------------
1393 -- Dimensions_Of_Operand --
1394 ---------------------------
1396 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1397 Dims : constant Dimension_Type := Dimensions_Of (N);
1400 if Exists (Dims) then
1403 elsif Is_Entity_Name (N) then
1404 return Dimensions_Of (Etype (Entity (N)));
1406 elsif Nkind (N) = N_Real_Literal then
1408 if Present (Original_Entity (N)) then
1409 return Dimensions_Of (Original_Entity (N));
1412 return Dimensions_Of (Etype (N));
1415 -- Otherwise return the default dimensions
1420 end Dimensions_Of_Operand;
1422 ---------------------------------
1423 -- Error_Dim_Msg_For_Binary_Op --
1424 ---------------------------------
1426 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1429 ("both operands for operation& must have same dimensions",
1431 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1432 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1433 end Error_Dim_Msg_For_Binary_Op;
1435 -- Start of processing for Analyze_Dimension_Binary_Op
1438 -- If the node is already analyzed, do not examine the operands. At the
1439 -- end of the analysis their dimensions have been removed, and the node
1440 -- itself may have been rewritten.
1442 if Analyzed (N) then
1446 if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract
1447 | N_Multiplying_Operator | N_Op_Compare
1450 L : constant Node_Id := Left_Opnd (N);
1451 Dims_Of_L : constant Dimension_Type :=
1452 Dimensions_Of_Operand (L);
1453 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1454 R : constant Node_Id := Right_Opnd (N);
1455 Dims_Of_R : constant Dimension_Type :=
1456 Dimensions_Of_Operand (R);
1457 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1458 Dims_Of_N : Dimension_Type := Null_Dimension;
1461 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1463 if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then
1465 -- Check both operands have same dimension
1467 if Dims_Of_L /= Dims_Of_R then
1468 Error_Dim_Msg_For_Binary_Op (N, L, R);
1470 -- Check both operands are not dimensionless
1472 if Exists (Dims_Of_L) then
1473 Set_Dimensions (N, Dims_Of_L);
1477 -- N_Op_Multiply or N_Op_Divide case
1479 elsif N_Kind in N_Op_Multiply | N_Op_Divide then
1481 -- Check at least one operand is not dimensionless
1483 if L_Has_Dimensions or R_Has_Dimensions then
1485 -- Multiplication case
1487 -- Get both operands dimensions and add them
1489 if N_Kind = N_Op_Multiply then
1490 for Position in Dimension_Type'Range loop
1491 Dims_Of_N (Position) :=
1492 Dims_Of_L (Position) + Dims_Of_R (Position);
1497 -- Get both operands dimensions and subtract them
1500 for Position in Dimension_Type'Range loop
1501 Dims_Of_N (Position) :=
1502 Dims_Of_L (Position) - Dims_Of_R (Position);
1506 if Exists (Dims_Of_N) then
1507 Set_Dimensions (N, Dims_Of_N);
1511 -- Exponentiation case
1513 -- Note: a rational exponent is allowed for dimensioned operand
1515 elsif N_Kind = N_Op_Expon then
1517 -- Check the left operand is not dimensionless. Note that the
1518 -- value of the exponent must be known compile time. Otherwise,
1519 -- the exponentiation evaluation will return an error message.
1521 if L_Has_Dimensions then
1522 if not Compile_Time_Known_Value (R) then
1524 ("exponent of dimensioned operand must be "
1525 & "known at compile time", N);
1529 Exponent_Value : Rational := Zero;
1532 -- Real operand case
1534 if Is_Real_Type (Etype (L)) then
1536 -- Define the exponent as a Rational number
1538 Exponent_Value := Create_Rational_From (R, False);
1540 -- Verify that the exponent cannot be interpreted
1541 -- as a rational, otherwise interpret the exponent
1544 if Exponent_Value = No_Rational then
1546 +Whole (UI_To_Int (Expr_Value (R)));
1549 -- Integer operand case.
1551 -- For integer operand, the exponent cannot be
1552 -- interpreted as a rational.
1555 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1558 for Position in Dimension_Type'Range loop
1559 Dims_Of_N (Position) :=
1560 Dims_Of_L (Position) * Exponent_Value;
1563 if Exists (Dims_Of_N) then
1564 Set_Dimensions (N, Dims_Of_N);
1571 -- For relational operations, only dimension checking is
1572 -- performed (no propagation). If one operand is the result
1573 -- of constant folding the dimensions may have been lost
1574 -- in a tree copy, so assume that preanalysis has verified
1575 -- that dimensions are correct.
1577 elsif N_Kind in N_Op_Compare then
1578 if (L_Has_Dimensions or R_Has_Dimensions)
1579 and then Dims_Of_L /= Dims_Of_R
1581 if Nkind (L) = N_Real_Literal
1582 and then not (Comes_From_Source (L))
1583 and then Expander_Active
1587 elsif Nkind (R) = N_Real_Literal
1588 and then not (Comes_From_Source (R))
1589 and then Expander_Active
1593 -- Numeric literal case. Issue a warning to indicate the
1594 -- literal is treated as if its dimension matches the type
1597 elsif Nkind (Original_Node (L)) in
1598 N_Integer_Literal | N_Real_Literal
1600 Dim_Warning_For_Numeric_Literal (L, Etype (R));
1602 elsif Nkind (Original_Node (R)) in
1603 N_Integer_Literal | N_Real_Literal
1605 Dim_Warning_For_Numeric_Literal (R, Etype (L));
1608 Error_Dim_Msg_For_Binary_Op (N, L, R);
1613 -- If expander is active, remove dimension information from each
1614 -- operand, as only dimensions of result are relevant.
1616 if Expander_Active then
1617 Remove_Dimensions (L);
1618 Remove_Dimensions (R);
1622 end Analyze_Dimension_Binary_Op;
1624 ----------------------------
1625 -- Analyze_Dimension_Call --
1626 ----------------------------
1628 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1629 Actuals : constant List_Id := Parameter_Associations (N);
1631 Dims_Of_Formal : Dimension_Type;
1633 Formal_Typ : Entity_Id;
1635 Error_Detected : Boolean := False;
1636 -- This flag is used in order to indicate if an error has been detected
1637 -- so far by the compiler in this routine.
1640 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1641 -- dimensions for calls in inlined bodies, or calls that don't come
1642 -- from source, or those that may have semantic errors.
1644 if Ada_Version < Ada_2012
1645 or else In_Inlined_Body
1646 or else not Comes_From_Source (N)
1647 or else Error_Posted (N)
1652 -- Check the dimensions of the actuals, if any
1654 if not Is_Empty_List (Actuals) then
1656 -- Special processing for elementary functions
1658 -- For Sqrt call, the resulting dimensions equal to half the
1659 -- dimensions of the actual. For all other elementary calls, this
1660 -- routine check that every actual is dimensionless.
1662 if Nkind (N) = N_Function_Call then
1663 Elementary_Function_Calls : declare
1664 Dims_Of_Call : Dimension_Type;
1665 Ent : Entity_Id := Nam;
1667 function Is_Elementary_Function_Entity
1668 (Sub_Id : Entity_Id) return Boolean;
1669 -- Given Sub_Id, the original subprogram entity, return True
1670 -- if call is to an elementary function (see Ada.Numerics.
1671 -- Generic_Elementary_Functions).
1673 -----------------------------------
1674 -- Is_Elementary_Function_Entity --
1675 -----------------------------------
1677 function Is_Elementary_Function_Entity
1678 (Sub_Id : Entity_Id) return Boolean
1680 Loc : constant Source_Ptr := Sloc (Sub_Id);
1683 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1689 (Cunit_Entity (Get_Source_Unit (Loc)),
1690 Ada_Numerics_Generic_Elementary_Functions);
1691 end Is_Elementary_Function_Entity;
1693 -- Start of processing for Elementary_Function_Calls
1696 -- Get original subprogram entity following the renaming chain
1698 if Present (Alias (Ent)) then
1702 -- Check the call is an Elementary function call
1704 if Is_Elementary_Function_Entity (Ent) then
1706 -- Sqrt function call case
1708 if Chars (Ent) = Name_Sqrt then
1709 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1711 -- Evaluates the resulting dimensions (i.e. half the
1712 -- dimensions of the actual).
1714 if Exists (Dims_Of_Call) then
1715 for Position in Dims_Of_Call'Range loop
1716 Dims_Of_Call (Position) :=
1717 Dims_Of_Call (Position) *
1718 Rational'(Numerator
=> 1, Denominator
=> 2);
1721 Set_Dimensions
(N
, Dims_Of_Call
);
1724 -- All other elementary functions case. Note that every
1725 -- actual here should be dimensionless.
1728 Actual
:= First_Actual
(N
);
1729 while Present
(Actual
) loop
1730 if Exists
(Dimensions_Of
(Actual
)) then
1732 -- Check if error has already been encountered
1734 if not Error_Detected
then
1736 ("dimensions mismatch in call of&",
1738 Error_Detected
:= True;
1742 ("\expected dimension '['], found "
1743 & Dimensions_Msg_Of
(Actual
), Actual
);
1746 Next_Actual
(Actual
);
1750 -- Nothing more to do for elementary functions
1754 end Elementary_Function_Calls
;
1757 -- General case. Check, for each parameter, the dimensions of the
1758 -- actual and its corresponding formal match. Otherwise, complain.
1760 Actual
:= First_Actual
(N
);
1761 Formal
:= First_Formal
(Nam
);
1762 while Present
(Formal
) loop
1764 -- A missing corresponding actual indicates that the analysis of
1765 -- the call was aborted due to a previous error.
1768 Check_Error_Detected
;
1772 Formal_Typ
:= Etype
(Formal
);
1773 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1775 -- If the formal is not dimensionless, check dimensions of formal
1776 -- and actual match. Otherwise, complain.
1778 if Exists
(Dims_Of_Formal
)
1779 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1781 -- Check if an error has already been encountered so far
1783 if not Error_Detected
then
1784 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1785 Error_Detected
:= True;
1789 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1790 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1793 Next_Actual
(Actual
);
1794 Next_Formal
(Formal
);
1798 -- For function calls, propagate the dimensions from the returned type
1800 if Nkind
(N
) = N_Function_Call
then
1801 Analyze_Dimension_Has_Etype
(N
);
1803 end Analyze_Dimension_Call
;
1805 ---------------------------------------
1806 -- Analyze_Dimension_Case_Expression --
1807 ---------------------------------------
1809 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
) is
1810 Frst
: constant Node_Id
:= First
(Alternatives
(N
));
1811 Frst_Expr
: constant Node_Id
:= Expression
(Frst
);
1812 Dims
: constant Dimension_Type
:= Dimensions_Of
(Frst_Expr
);
1818 while Present
(Alt
) loop
1819 if Dimensions_Of
(Expression
(Alt
)) /= Dims
then
1820 Error_Msg_N
("dimension mismatch in case expression", Alt
);
1827 Copy_Dimensions
(Frst_Expr
, N
);
1828 end Analyze_Dimension_Case_Expression
;
1830 ---------------------------------------------
1831 -- Analyze_Dimension_Component_Declaration --
1832 ---------------------------------------------
1834 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1835 Expr
: constant Node_Id
:= Expression
(N
);
1836 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1837 Etyp
: constant Entity_Id
:= Etype
(Id
);
1838 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1839 Dims_Of_Expr
: Dimension_Type
;
1841 procedure Error_Dim_Msg_For_Component_Declaration
1845 -- Error using Error_Msg_N at node N. Output the dimensions of the
1846 -- type Etyp and the expression Expr of N.
1848 ---------------------------------------------
1849 -- Error_Dim_Msg_For_Component_Declaration --
1850 ---------------------------------------------
1852 procedure Error_Dim_Msg_For_Component_Declaration
1857 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1859 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
1860 & Dimensions_Msg_Of
(Expr
), Expr
);
1861 end Error_Dim_Msg_For_Component_Declaration
;
1863 -- Start of processing for Analyze_Dimension_Component_Declaration
1866 -- Expression is present
1868 if Present
(Expr
) then
1869 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1871 -- Check dimensions match
1873 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1875 -- Numeric literal case. Issue a warning if the object type is not
1876 -- dimensionless to indicate the literal is treated as if its
1877 -- dimension matches the type dimension.
1879 if Nkind
(Original_Node
(Expr
)) in
1880 N_Real_Literal | N_Integer_Literal
1882 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1884 -- Issue a dimension mismatch error for all other cases
1887 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1891 end Analyze_Dimension_Component_Declaration
;
1893 -------------------------------------------------
1894 -- Analyze_Dimension_Extended_Return_Statement --
1895 -------------------------------------------------
1897 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1898 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1899 Return_Etyp
: constant Entity_Id
:=
1900 Etype
(Return_Applies_To
(Return_Ent
));
1901 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1902 Return_Obj_Decl
: Node_Id
;
1903 Return_Obj_Id
: Entity_Id
;
1904 Return_Obj_Typ
: Entity_Id
;
1906 procedure Error_Dim_Msg_For_Extended_Return_Statement
1908 Return_Etyp
: Entity_Id
;
1909 Return_Obj_Typ
: Entity_Id
);
1910 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1911 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1913 -------------------------------------------------
1914 -- Error_Dim_Msg_For_Extended_Return_Statement --
1915 -------------------------------------------------
1917 procedure Error_Dim_Msg_For_Extended_Return_Statement
1919 Return_Etyp
: Entity_Id
;
1920 Return_Obj_Typ
: Entity_Id
)
1923 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1925 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
1926 & ", found " & Dimensions_Msg_Of
(Return_Obj_Typ
), N
);
1927 end Error_Dim_Msg_For_Extended_Return_Statement
;
1929 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1932 if Present
(Return_Obj_Decls
) then
1933 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1934 while Present
(Return_Obj_Decl
) loop
1935 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1936 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1938 if Is_Return_Object
(Return_Obj_Id
) then
1939 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1941 -- Issue an error message if dimensions mismatch
1943 if Dimensions_Of
(Return_Etyp
) /=
1944 Dimensions_Of
(Return_Obj_Typ
)
1946 Error_Dim_Msg_For_Extended_Return_Statement
1947 (N
, Return_Etyp
, Return_Obj_Typ
);
1953 Next
(Return_Obj_Decl
);
1956 end Analyze_Dimension_Extended_Return_Statement
;
1958 -----------------------------------------------------
1959 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1960 -----------------------------------------------------
1962 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1964 Comp_Id
: Entity_Id
;
1965 Comp_Typ
: Entity_Id
;
1968 Error_Detected
: Boolean := False;
1969 -- This flag is used in order to indicate if an error has been detected
1970 -- so far by the compiler in this routine.
1973 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1974 -- dimensions in inlined bodies, or for aggregates that don't come
1975 -- from source, or if we are within an initialization procedure, whose
1976 -- expressions have been checked at the point of record declaration.
1978 if Ada_Version
< Ada_2012
1979 or else In_Inlined_Body
1980 or else not Comes_From_Source
(N
)
1981 or else Inside_Init_Proc
1986 Comp
:= First
(Component_Associations
(N
));
1987 while Present
(Comp
) loop
1988 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1989 Comp_Typ
:= Etype
(Comp_Id
);
1991 -- Check the component type is either a dimensioned type or a
1992 -- dimensioned subtype.
1994 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1995 Expr
:= Expression
(Comp
);
1997 -- A box-initialized component needs no checking.
1999 if No
(Expr
) and then Box_Present
(Comp
) then
2002 -- Issue an error if the dimensions of the component type and the
2003 -- dimensions of the component mismatch.
2005 elsif Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
2007 -- Check if an error has already been encountered so far
2009 if not Error_Detected
then
2011 -- Extension aggregate case
2013 if Nkind
(N
) = N_Extension_Aggregate
then
2015 ("dimensions mismatch in extension aggregate", N
);
2017 -- Record aggregate case
2021 ("dimensions mismatch in record aggregate", N
);
2024 Error_Detected
:= True;
2028 ("\expected dimension " & Dimensions_Msg_Of
(Comp_Typ
)
2029 & ", found " & Dimensions_Msg_Of
(Expr
), Comp
);
2035 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
2037 -------------------------------
2038 -- Analyze_Dimension_Formals --
2039 -------------------------------
2041 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
2042 Dims_Of_Typ
: Dimension_Type
;
2047 -- Aspect is an Ada 2012 feature. Note that there is no need to check
2048 -- dimensions for sub specs that don't come from source.
2050 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
2054 Formal
:= First
(Formals
);
2055 while Present
(Formal
) loop
2056 Typ
:= Parameter_Type
(Formal
);
2057 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
2059 if Exists
(Dims_Of_Typ
) then
2061 Expr
: constant Node_Id
:= Expression
(Formal
);
2064 -- Issue a warning if Expr is a numeric literal and if its
2065 -- dimensions differ with the dimensions of the formal type.
2068 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
2069 and then Nkind
(Original_Node
(Expr
)) in
2070 N_Real_Literal | N_Integer_Literal
2072 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
2079 end Analyze_Dimension_Formals
;
2081 ---------------------------------
2082 -- Analyze_Dimension_Has_Etype --
2083 ---------------------------------
2085 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
2086 Etyp
: constant Entity_Id
:= Etype
(N
);
2087 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
2090 -- General case. Propagation of the dimensions from the type
2092 if Exists
(Dims_Of_Etyp
) then
2093 Set_Dimensions
(N
, Dims_Of_Etyp
);
2095 -- Identifier case. Propagate the dimensions from the entity for
2096 -- identifier whose entity is a non-dimensionless constant.
2098 elsif Nkind
(N
) = N_Identifier
then
2099 Analyze_Dimension_Identifier
: declare
2100 Id
: constant Entity_Id
:= Entity
(N
);
2103 -- If Id is missing, abnormal tree, assume previous error
2106 Check_Error_Detected
;
2109 elsif Ekind
(Id
) in E_Constant | E_Named_Real
2110 and then Exists
(Dimensions_Of
(Id
))
2112 Set_Dimensions
(N
, Dimensions_Of
(Id
));
2114 end Analyze_Dimension_Identifier
;
2116 -- Attribute reference case. Propagate the dimensions from the prefix.
2118 elsif Nkind
(N
) = N_Attribute_Reference
2119 and then Has_Dimension_System
(Base_Type
(Etyp
))
2121 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
2123 -- Check the prefix is not dimensionless
2125 if Exists
(Dims_Of_Etyp
) then
2126 Set_Dimensions
(N
, Dims_Of_Etyp
);
2130 -- Remove dimensions from inner expressions, to prevent dimensions
2131 -- table from growing uselessly.
2134 when N_Attribute_Reference
2135 | N_Indexed_Component
2138 Exprs
: constant List_Id
:= Expressions
(N
);
2142 if Present
(Exprs
) then
2143 Expr
:= First
(Exprs
);
2144 while Present
(Expr
) loop
2145 Remove_Dimensions
(Expr
);
2151 when N_Qualified_Expression
2153 | N_Unchecked_Type_Conversion
2155 Remove_Dimensions
(Expression
(N
));
2157 when N_Selected_Component
=>
2158 Remove_Dimensions
(Selector_Name
(N
));
2163 end Analyze_Dimension_Has_Etype
;
2165 -------------------------------------
2166 -- Analyze_Dimension_If_Expression --
2167 -------------------------------------
2169 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
) is
2170 Then_Expr
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
2171 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2174 if Dimensions_Of
(Then_Expr
) /= Dimensions_Of
(Else_Expr
) then
2175 Error_Msg_N
("dimensions mismatch in conditional expression", N
);
2177 Copy_Dimensions
(Then_Expr
, N
);
2179 end Analyze_Dimension_If_Expression
;
2181 ------------------------------------------
2182 -- Analyze_Dimension_Number_Declaration --
2183 ------------------------------------------
2185 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
) is
2186 Expr
: constant Node_Id
:= Expression
(N
);
2187 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2188 Dim_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2191 if Exists
(Dim_Of_Expr
) then
2192 Set_Dimensions
(Id
, Dim_Of_Expr
);
2193 Set_Etype
(Id
, Etype
(Expr
));
2195 end Analyze_Dimension_Number_Declaration
;
2197 ------------------------------------------
2198 -- Analyze_Dimension_Object_Declaration --
2199 ------------------------------------------
2201 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
2202 Expr
: constant Node_Id
:= Expression
(N
);
2203 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2204 Etyp
: constant Entity_Id
:= Etype
(Id
);
2205 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
2206 Dim_Of_Expr
: Dimension_Type
;
2208 procedure Error_Dim_Msg_For_Object_Declaration
2212 -- Error using Error_Msg_N at node N. Output the dimensions of the
2213 -- type Etyp and of the expression Expr.
2215 ------------------------------------------
2216 -- Error_Dim_Msg_For_Object_Declaration --
2217 ------------------------------------------
2219 procedure Error_Dim_Msg_For_Object_Declaration
2224 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2226 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
2227 & Dimensions_Msg_Of
(Expr
), Expr
);
2228 end Error_Dim_Msg_For_Object_Declaration
;
2230 -- Start of processing for Analyze_Dimension_Object_Declaration
2233 -- Expression is present
2235 if Present
(Expr
) then
2236 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2238 -- Check dimensions match
2240 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2242 -- Numeric literal case. Issue a warning if the object type is
2243 -- not dimensionless to indicate the literal is treated as if
2244 -- its dimension matches the type dimension.
2246 if Nkind
(Original_Node
(Expr
)) in
2247 N_Real_Literal | N_Integer_Literal
2249 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2251 -- Case of object is a constant whose type is a dimensioned type
2253 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2255 -- Propagate dimension from expression to object entity
2257 Set_Dimensions
(Id
, Dim_Of_Expr
);
2259 -- Expression may have been constant-folded. If nominal type has
2260 -- dimensions, verify that expression has same type.
2262 elsif Exists
(Dim_Of_Etyp
) and then Etype
(Expr
) = Etyp
then
2265 -- For all other cases, issue an error message
2268 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2272 -- Remove dimensions in expression after checking consistency with
2275 Remove_Dimensions
(Expr
);
2277 end Analyze_Dimension_Object_Declaration
;
2279 ---------------------------------------------------
2280 -- Analyze_Dimension_Object_Renaming_Declaration --
2281 ---------------------------------------------------
2283 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2284 Renamed_Name
: constant Node_Id
:= Name
(N
);
2285 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2287 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2290 Renamed_Name
: Node_Id
);
2291 -- Error using Error_Msg_N at node N. Output the dimensions of
2292 -- Sub_Mark and of Renamed_Name.
2294 ---------------------------------------------------
2295 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2296 ---------------------------------------------------
2298 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2301 Renamed_Name
: Node_Id
) is
2303 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2305 ("\expected dimension " & Dimensions_Msg_Of
(Sub_Mark
) & ", found "
2306 & Dimensions_Msg_Of
(Renamed_Name
), Renamed_Name
);
2307 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2309 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2312 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2313 Error_Dim_Msg_For_Object_Renaming_Declaration
2314 (N
, Sub_Mark
, Renamed_Name
);
2316 end Analyze_Dimension_Object_Renaming_Declaration
;
2318 -----------------------------------------------
2319 -- Analyze_Dimension_Simple_Return_Statement --
2320 -----------------------------------------------
2322 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2323 Expr
: constant Node_Id
:= Expression
(N
);
2324 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2325 Return_Etyp
: constant Entity_Id
:=
2326 Etype
(Return_Applies_To
(Return_Ent
));
2327 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2328 Dimensions_Of
(Return_Etyp
);
2330 procedure Error_Dim_Msg_For_Simple_Return_Statement
2332 Return_Etyp
: Entity_Id
;
2334 -- Error using Error_Msg_N at node N. Output the dimensions of the
2335 -- returned type Return_Etyp and the returned expression Expr of N.
2337 -----------------------------------------------
2338 -- Error_Dim_Msg_For_Simple_Return_Statement --
2339 -----------------------------------------------
2341 procedure Error_Dim_Msg_For_Simple_Return_Statement
2343 Return_Etyp
: Entity_Id
;
2347 Error_Msg_N
("dimensions mismatch in return statement", N
);
2349 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
2350 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2351 end Error_Dim_Msg_For_Simple_Return_Statement
;
2353 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2356 if Dims_Of_Return_Etyp
/= Dimensions_Of
(Expr
) then
2357 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2358 Remove_Dimensions
(Expr
);
2360 end Analyze_Dimension_Simple_Return_Statement
;
2362 -------------------------------------------
2363 -- Analyze_Dimension_Subtype_Declaration --
2364 -------------------------------------------
2366 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2367 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2368 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2369 Dims_Of_Etyp
: Dimension_Type
;
2373 -- No constraint case in subtype declaration
2375 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2376 Etyp
:= Etype
(Subtype_Indication
(N
));
2377 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2379 if Exists
(Dims_Of_Etyp
) then
2381 -- If subtype already has a dimension (from Aspect_Dimension), it
2382 -- cannot inherit different dimensions from its subtype.
2384 if Exists
(Dims_Of_Id
) and then Dims_Of_Etyp
/= Dims_Of_Id
then
2386 ("subtype& already " & Dimensions_Msg_Of
(Id
, True), N
, Id
);
2388 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2389 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2393 -- Constraint present in subtype declaration
2396 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2397 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2399 if Exists
(Dims_Of_Etyp
) then
2400 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2401 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2404 end Analyze_Dimension_Subtype_Declaration
;
2406 ---------------------------------------
2407 -- Analyze_Dimension_Type_Conversion --
2408 ---------------------------------------
2410 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
) is
2411 Expr_Root
: constant Entity_Id
:=
2412 Dimension_System_Root
(Etype
(Expression
(N
)));
2413 Target_Root
: constant Entity_Id
:=
2414 Dimension_System_Root
(Etype
(N
));
2417 -- If the expression has dimensions and the target type has dimensions,
2418 -- the conversion has the dimensions of the expression. Consistency is
2419 -- checked below. Converting to a non-dimensioned type such as Float
2420 -- ignores the dimensions of the expression.
2422 if Exists
(Dimensions_Of
(Expression
(N
)))
2423 and then Present
(Target_Root
)
2425 Set_Dimensions
(N
, Dimensions_Of
(Expression
(N
)));
2427 -- Otherwise the dimensions are those of the target type.
2430 Analyze_Dimension_Has_Etype
(N
);
2433 -- A conversion between types in different dimension systems (e.g. MKS
2434 -- and British units) must respect the dimensions of expression and
2435 -- type, It is up to the user to provide proper conversion factors.
2437 -- Upward conversions to root type of a dimensioned system are legal,
2438 -- and correspond to "view conversions", i.e. preserve the dimensions
2439 -- of the expression; otherwise conversion must be between types with
2440 -- then same dimensions. Conversions to a non-dimensioned type such as
2441 -- Float lose the dimensions of the expression.
2443 if Present
(Expr_Root
)
2444 and then Present
(Target_Root
)
2445 and then Etype
(N
) /= Target_Root
2446 and then Dimensions_Of
(Expression
(N
)) /= Dimensions_Of
(Etype
(N
))
2448 Error_Msg_N
("dimensions mismatch in conversion", N
);
2450 ("\expression " & Dimensions_Msg_Of
(Expression
(N
), True), N
);
2452 ("\target type " & Dimensions_Msg_Of
(Etype
(N
), True), N
);
2454 end Analyze_Dimension_Type_Conversion
;
2456 --------------------------------
2457 -- Analyze_Dimension_Unary_Op --
2458 --------------------------------
2460 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2464 -- Propagate the dimension if the operand is not dimensionless
2471 R
: constant Node_Id
:= Right_Opnd
(N
);
2473 Move_Dimensions
(R
, N
);
2479 end Analyze_Dimension_Unary_Op
;
2481 ---------------------------------
2482 -- Check_Expression_Dimensions --
2483 ---------------------------------
2485 procedure Check_Expression_Dimensions
2490 if Is_Floating_Point_Type
(Etype
(Expr
)) then
2491 Analyze_Dimension
(Expr
);
2493 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Typ
) then
2494 Error_Msg_N
("dimensions mismatch in array aggregate", Expr
);
2496 ("\expected dimension " & Dimensions_Msg_Of
(Typ
)
2497 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2500 end Check_Expression_Dimensions
;
2502 ---------------------
2503 -- Copy_Dimensions --
2504 ---------------------
2506 procedure Copy_Dimensions
(From
: Node_Id
; To
: Node_Id
) is
2507 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2510 -- Ignore if not Ada 2012 or beyond
2512 if Ada_Version
< Ada_2012
then
2515 -- For Ada 2012, Copy the dimension of 'From to 'To'
2517 elsif Exists
(Dims_Of_From
) then
2518 Set_Dimensions
(To
, Dims_Of_From
);
2520 end Copy_Dimensions
;
2522 -----------------------------------
2523 -- Copy_Dimensions_Of_Components --
2524 -----------------------------------
2526 procedure Copy_Dimensions_Of_Components
(Rec
: Entity_Id
) is
2530 C
:= First_Component
(Rec
);
2531 while Present
(C
) loop
2532 if Nkind
(Parent
(C
)) = N_Component_Declaration
then
2534 (Expression
(Parent
(Corresponding_Record_Component
(C
))),
2535 Expression
(Parent
(C
)));
2539 end Copy_Dimensions_Of_Components
;
2541 --------------------------
2542 -- Create_Rational_From --
2543 --------------------------
2545 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2547 -- A rational number is a number that can be expressed as the quotient or
2548 -- fraction a/b of two integers, where b is non-zero positive.
2550 function Create_Rational_From
2552 Complain
: Boolean) return Rational
2554 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2555 Result
: Rational
:= No_Rational
;
2557 function Process_Minus
(N
: Node_Id
) return Rational
;
2558 -- Create a rational from a N_Op_Minus node
2560 function Process_Divide
(N
: Node_Id
) return Rational
;
2561 -- Create a rational from a N_Op_Divide node
2563 function Process_Literal
(N
: Node_Id
) return Rational
;
2564 -- Create a rational from a N_Integer_Literal node
2570 function Process_Minus
(N
: Node_Id
) return Rational
is
2571 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2575 -- Operand is an integer literal
2577 if Nkind
(Right
) = N_Integer_Literal
then
2578 Result
:= -Process_Literal
(Right
);
2580 -- Operand is a divide operator
2582 elsif Nkind
(Right
) = N_Op_Divide
then
2583 Result
:= -Process_Divide
(Right
);
2586 Result
:= No_Rational
;
2592 --------------------
2593 -- Process_Divide --
2594 --------------------
2596 function Process_Divide
(N
: Node_Id
) return Rational
is
2597 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2598 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2599 Left_Rat
: Rational
;
2600 Result
: Rational
:= No_Rational
;
2601 Right_Rat
: Rational
;
2604 -- Both left and right operands are integer literals
2606 if Nkind
(Left
) = N_Integer_Literal
2608 Nkind
(Right
) = N_Integer_Literal
2610 Left_Rat
:= Process_Literal
(Left
);
2611 Right_Rat
:= Process_Literal
(Right
);
2612 Result
:= Left_Rat
/ Right_Rat
;
2618 ---------------------
2619 -- Process_Literal --
2620 ---------------------
2622 function Process_Literal
(N
: Node_Id
) return Rational
is
2624 return +Whole
(UI_To_Int
(Intval
(N
)));
2625 end Process_Literal
;
2627 -- Start of processing for Create_Rational_From
2630 -- Check the expression is either a division of two integers or an
2631 -- integer itself. Note that the check applies to the original node
2632 -- since the node could have already been rewritten.
2634 -- Integer literal case
2636 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2637 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2639 -- Divide operator case
2641 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2642 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2644 -- Minus operator case
2646 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2647 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2650 -- When Expr cannot be interpreted as a rational and Complain is true,
2651 -- generate an error message.
2653 if Complain
and then Result
= No_Rational
then
2654 Error_Msg_N
("rational expected", Expr
);
2658 end Create_Rational_From
;
2664 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2666 return Dimension_Table
.Get
(N
);
2669 -----------------------
2670 -- Dimensions_Msg_Of --
2671 -----------------------
2673 function Dimensions_Msg_Of
2675 Description_Needed
: Boolean := False) return String
2677 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2678 Dimensions_Msg
: Name_Id
;
2679 System
: System_Type
;
2682 -- Initialization of Name_Buffer
2686 -- N is not dimensionless
2688 if Exists
(Dims_Of_N
) then
2689 System
:= System_Of
(Base_Type
(Etype
(N
)));
2691 -- When Description_Needed, add to string "has dimension " before the
2692 -- actual dimension.
2694 if Description_Needed
then
2695 Add_Str_To_Name_Buffer
("has dimension ");
2699 (Global_Name_Buffer
,
2700 From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2702 -- N is dimensionless
2704 -- When Description_Needed, return "is dimensionless"
2706 elsif Description_Needed
then
2707 Add_Str_To_Name_Buffer
("is dimensionless");
2709 -- Otherwise, return "'[']"
2712 Add_Str_To_Name_Buffer
("'[']");
2715 Dimensions_Msg
:= Name_Find
;
2716 return Get_Name_String
(Dimensions_Msg
);
2717 end Dimensions_Msg_Of
;
2719 --------------------------
2720 -- Dimension_Table_Hash --
2721 --------------------------
2723 function Dimension_Table_Hash
2724 (Key
: Node_Id
) return Dimension_Table_Range
2727 return Dimension_Table_Range
(Key
mod 511);
2728 end Dimension_Table_Hash
;
2730 -------------------------------------
2731 -- Dim_Warning_For_Numeric_Literal --
2732 -------------------------------------
2734 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2736 -- Consider the literal zero (integer 0 or real 0.0) to be of any
2739 case Nkind
(Original_Node
(N
)) is
2740 when N_Real_Literal
=>
2741 if Expr_Value_R
(N
) = Ureal_0
then
2745 when N_Integer_Literal
=>
2746 if Expr_Value
(N
) = Uint_0
then
2754 -- Initialize name buffer
2758 Append
(Global_Name_Buffer
, String_From_Numeric_Literal
(N
));
2760 -- Insert a blank between the literal and the symbol
2762 Add_Char_To_Name_Buffer
(' ');
2763 Append
(Global_Name_Buffer
, Symbol_Of
(Typ
));
2765 Error_Msg_Name_1
:= Name_Find
;
2766 Error_Msg_N
("assumed to be%%??", N
);
2767 end Dim_Warning_For_Numeric_Literal
;
2769 ----------------------
2770 -- Dimensions_Match --
2771 ----------------------
2773 function Dimensions_Match
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2776 not Has_Dimension_System
(Base_Type
(T1
))
2777 or else Dimensions_Of
(T1
) = Dimensions_Of
(T2
);
2778 end Dimensions_Match
;
2780 ---------------------------
2781 -- Dimension_System_Root --
2782 ---------------------------
2784 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
is
2788 Root
:= Base_Type
(T
);
2790 if Has_Dimension_System
(Root
) then
2791 return First_Subtype
(Root
); -- for example Dim_Mks
2796 end Dimension_System_Root
;
2798 ----------------------------------------
2799 -- Eval_Op_Expon_For_Dimensioned_Type --
2800 ----------------------------------------
2802 -- Evaluate the expon operator for real dimensioned type.
2804 -- Note that if the exponent is an integer (denominator = 1) the node is
2805 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2807 procedure Eval_Op_Expon_For_Dimensioned_Type
2811 R
: constant Node_Id
:= Right_Opnd
(N
);
2812 R_Value
: Rational
:= No_Rational
;
2815 if Is_Real_Type
(Btyp
) then
2816 R_Value
:= Create_Rational_From
(R
, False);
2819 -- Check that the exponent is not an integer
2821 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2822 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2826 end Eval_Op_Expon_For_Dimensioned_Type
;
2828 ------------------------------------------
2829 -- Eval_Op_Expon_With_Rational_Exponent --
2830 ------------------------------------------
2832 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2833 -- Rational and not only an Integer like for dimensionless operands. For
2834 -- that particular case, the left operand is rewritten as a function call
2835 -- using the function Expon_LLF from s-llflex.ads.
2837 procedure Eval_Op_Expon_With_Rational_Exponent
2839 Exponent_Value
: Rational
)
2841 Loc
: constant Source_Ptr
:= Sloc
(N
);
2842 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2843 L
: constant Node_Id
:= Left_Opnd
(N
);
2844 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2845 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2848 Dim_Power
: Rational
;
2849 List_Of_Dims
: List_Id
;
2850 New_Aspect
: Node_Id
;
2851 New_Aspects
: List_Id
;
2854 New_Subtyp_Decl_For_L
: Node_Id
;
2855 System
: System_Type
;
2858 -- Case when the operand is not dimensionless
2860 if Exists
(Dims_Of_N
) then
2862 -- Get the corresponding System_Type to know the exact number of
2863 -- dimensions in the system.
2865 System
:= System_Of
(Btyp_Of_L
);
2867 -- Generation of a new subtype with the proper dimensions
2869 -- In order to rewrite the operator as a type conversion, a new
2870 -- dimensioned subtype with the resulting dimensions of the
2871 -- exponentiation must be created.
2875 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2876 -- System : constant System_Id :=
2877 -- Get_Dimension_System_Id (Btyp_Of_L);
2878 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2879 -- Dimension_Systems.Table (System).Dimension_Count;
2881 -- subtype T is Btyp_Of_L
2884 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2885 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2887 -- Dims_Of_N (Num_Of_Dims).Numerator /
2888 -- Dims_Of_N (Num_Of_Dims).Denominator);
2890 -- Step 1: Generate the new aggregate for the aspect Dimension
2892 New_Aspects
:= Empty_List
;
2894 List_Of_Dims
:= New_List
;
2895 for Position
in Dims_Of_N
'First .. System
.Count
loop
2896 Dim_Power
:= Dims_Of_N
(Position
);
2897 Append_To
(List_Of_Dims
,
2898 Make_Op_Divide
(Loc
,
2900 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Numerator
)),
2902 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Denominator
))));
2905 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2908 Make_Aspect_Specification
(Loc
,
2909 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2910 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2912 -- Step 3: Make a temporary identifier for the new subtype
2914 New_Id
:= Make_Temporary
(Loc
, 'T');
2915 Set_Is_Internal
(New_Id
);
2917 -- Step 4: Declaration of the new subtype
2919 New_Subtyp_Decl_For_L
:=
2920 Make_Subtype_Declaration
(Loc
,
2921 Defining_Identifier
=> New_Id
,
2922 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2924 Append
(New_Aspect
, New_Aspects
);
2925 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2926 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2928 Analyze
(New_Subtyp_Decl_For_L
);
2930 -- Case where the operand is dimensionless
2933 New_Id
:= Btyp_Of_L
;
2936 -- Replacement of N by New_N
2940 -- Actual_1 := Long_Long_Float (L),
2942 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2943 -- Long_Long_Float (Exponent_Value.Denominator);
2945 -- (T (Expon_LLF (Actual_1, Actual_2)));
2947 -- where T is the subtype declared in step 1
2949 -- The node is rewritten as a type conversion
2951 -- Step 1: Creation of the two parameters of Expon_LLF function call
2954 Make_Type_Conversion
(Loc
,
2955 Subtype_Mark
=> New_Occurrence_Of
(Standard_Long_Long_Float
, Loc
),
2956 Expression
=> Relocate_Node
(L
));
2959 Make_Op_Divide
(Loc
,
2961 Make_Real_Literal
(Loc
,
2962 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2964 Make_Real_Literal
(Loc
,
2965 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2967 -- Step 2: Creation of New_N
2970 Make_Type_Conversion
(Loc
,
2971 Subtype_Mark
=> New_Occurrence_Of
(New_Id
, Loc
),
2973 Make_Function_Call
(Loc
,
2974 Name
=> New_Occurrence_Of
(RTE
(RE_Expon_LLF
), Loc
),
2975 Parameter_Associations
=> New_List
(
2976 Actual_1
, Actual_2
)));
2978 -- Step 3: Rewrite N with the result
2981 Set_Etype
(N
, New_Id
);
2982 Analyze_And_Resolve
(N
, New_Id
);
2983 end Eval_Op_Expon_With_Rational_Exponent
;
2989 function Exists
(Dim
: Dimension_Type
) return Boolean is
2991 return Dim
/= Null_Dimension
;
2994 function Exists
(Str
: String_Id
) return Boolean is
2996 return Str
/= No_String
;
2999 function Exists
(Sys
: System_Type
) return Boolean is
3001 return Sys
/= Null_System
;
3004 ---------------------------------
3005 -- Expand_Put_Call_With_Symbol --
3006 ---------------------------------
3008 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in
3009 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string
3010 -- parameter is rewritten to include the unit symbol (or the dimension
3011 -- symbols if not a defined quantity) in the output of a dimensioned
3012 -- object. If a value is already supplied by the user for the parameter
3013 -- Symbol, it is used as is.
3015 -- Case 1. Item is dimensionless
3017 -- * Put : Item appears without a suffix
3019 -- * Put_Dim_Of : the output is []
3021 -- Obj : Mks_Type := 2.6;
3022 -- Put (Obj, 1, 1, 0);
3023 -- Put_Dim_Of (Obj);
3025 -- The corresponding outputs are:
3029 -- Case 2. Item has a dimension
3031 -- * Put : If the type of Item is a dimensioned subtype whose
3032 -- symbol is not empty, then the symbol appears as a
3033 -- suffix. Otherwise, a new string is created and appears
3034 -- as a suffix of Item. This string results in the
3035 -- successive concatenations between each unit symbol
3036 -- raised by its corresponding dimension power from the
3037 -- dimensions of Item.
3039 -- * Put_Dim_Of : The output is a new string resulting in the successive
3040 -- concatenations between each dimension symbol raised by
3041 -- its corresponding dimension power from the dimensions of
3044 -- subtype Random is Mks_Type
3051 -- Obj : Random := 5.0;
3053 -- Put_Dim_Of (Obj);
3055 -- The corresponding outputs are:
3056 -- $5.0 m**3.cd**(-1)
3059 -- The function Image returns the string identical to that produced by
3060 -- a call to Put whose first parameter is a string.
3062 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
3063 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
3064 Loc
: constant Source_Ptr
:= Sloc
(N
);
3065 Name_Call
: constant Node_Id
:= Name
(N
);
3066 New_Actuals
: constant List_Id
:= New_List
;
3068 Dims_Of_Actual
: Dimension_Type
;
3070 New_Str_Lit
: Node_Id
:= Empty
;
3071 Symbols
: String_Id
;
3073 Is_Put_Dim_Of
: Boolean := False;
3074 -- This flag is used in order to differentiate routines Put and
3075 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
3076 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
3078 function Has_Symbols
return Boolean;
3079 -- Return True if the current Put call already has a parameter
3080 -- association for parameter "Symbols" with the correct string of
3083 function Is_Procedure_Put_Call
return Boolean;
3084 -- Return True if the current call is a call of an instantiation of a
3085 -- procedure Put defined in the package System.Dim.Float_IO and
3086 -- System.Dim.Integer_IO.
3088 function Item_Actual
return Node_Id
;
3089 -- Return the item actual parameter node in the output call
3095 function Has_Symbols
return Boolean is
3097 Actual_Str
: Node_Id
;
3100 -- Look for a symbols parameter association in the list of actuals
3102 Actual
:= First
(Actuals
);
3103 while Present
(Actual
) loop
3105 -- Positional parameter association case when the actual is a
3108 if Nkind
(Actual
) = N_String_Literal
then
3109 Actual_Str
:= Actual
;
3111 -- Named parameter association case when selector name is Symbol
3113 elsif Nkind
(Actual
) = N_Parameter_Association
3114 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
3116 Actual_Str
:= Explicit_Actual_Parameter
(Actual
);
3118 -- Ignore all other cases
3121 Actual_Str
:= Empty
;
3124 if Present
(Actual_Str
) then
3126 -- Return True if the actual comes from source or if the string
3127 -- of symbols doesn't have the default value (i.e. it is ""),
3128 -- in which case it is used as suffix of the generated string.
3130 if Comes_From_Source
(Actual
)
3131 or else String_Length
(Strval
(Actual_Str
)) /= 0
3143 -- At this point, the call has no parameter association. Look to the
3144 -- last actual since the symbols parameter is the last one.
3146 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
3149 ---------------------------
3150 -- Is_Procedure_Put_Call --
3151 ---------------------------
3153 function Is_Procedure_Put_Call
return Boolean is
3158 -- There are three different Put (resp. Put_Dim_Of) routines in each
3159 -- generic dim IO package. Verify the current procedure call is one
3162 if Is_Entity_Name
(Name_Call
) then
3163 Ent
:= Entity
(Name_Call
);
3165 -- Get the original subprogram entity following the renaming chain
3167 if Present
(Alias
(Ent
)) then
3173 -- Check the name of the entity subprogram is Put (resp.
3174 -- Put_Dim_Of) and verify this entity is located in either
3175 -- System.Dim.Float_IO or System.Dim.Integer_IO.
3177 if Loc
> No_Location
3178 and then Is_Dim_IO_Package_Entity
3179 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
3181 if Chars
(Ent
) = Name_Put_Dim_Of
then
3182 Is_Put_Dim_Of
:= True;
3185 elsif Chars
(Ent
) = Name_Put
3186 or else Chars
(Ent
) = Name_Image
3194 end Is_Procedure_Put_Call
;
3200 function Item_Actual
return Node_Id
is
3204 -- Look for the item actual as a parameter association
3206 Actual
:= First
(Actuals
);
3207 while Present
(Actual
) loop
3208 if Nkind
(Actual
) = N_Parameter_Association
3209 and then Chars
(Selector_Name
(Actual
)) = Name_Item
3211 return Explicit_Actual_Parameter
(Actual
);
3217 -- Case where the item has been defined without an association
3219 Actual
:= First
(Actuals
);
3221 -- Depending on the procedure Put, Item actual could be first or
3222 -- second in the list of actuals.
3224 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
3227 return Next
(Actual
);
3231 -- Start of processing for Expand_Put_Call_With_Symbol
3234 if Is_Procedure_Put_Call
and then not Has_Symbols
then
3235 Actual
:= Item_Actual
;
3236 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
3237 Etyp
:= Etype
(Actual
);
3241 if Is_Put_Dim_Of
then
3243 -- Check that the item is not dimensionless
3245 -- Create the new String_Literal with the new String_Id generated
3246 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
3248 if Exists
(Dims_Of_Actual
) then
3250 Make_String_Literal
(Loc
,
3251 From_Dim_To_Str_Of_Dim_Symbols
3252 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
))));
3254 -- If dimensionless, the output is []
3258 Make_String_Literal
(Loc
, "[]");
3264 -- Add the symbol as a suffix of the value if the subtype has a
3265 -- unit symbol or if the parameter is not dimensionless.
3267 if Exists
(Symbol_Of
(Etyp
)) then
3268 Symbols
:= Symbol_Of
(Etyp
);
3270 Symbols
:= From_Dim_To_Str_Of_Unit_Symbols
3271 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
)));
3274 -- Check Symbols exists
3276 if Exists
(Symbols
) then
3279 -- Put a space between the value and the dimension
3281 Store_String_Char
(' ');
3282 Store_String_Chars
(Symbols
);
3283 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
3287 if Present
(New_Str_Lit
) then
3289 -- Insert all actuals in New_Actuals
3291 Actual
:= First
(Actuals
);
3292 while Present
(Actual
) loop
3294 -- Copy every actuals in New_Actuals except the Symbols
3295 -- parameter association.
3297 if Nkind
(Actual
) = N_Parameter_Association
3298 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
3300 Append_To
(New_Actuals
,
3301 Make_Parameter_Association
(Loc
,
3302 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
3303 Explicit_Actual_Parameter
=>
3304 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
3306 elsif Nkind
(Actual
) /= N_Parameter_Association
then
3307 Append_To
(New_Actuals
, New_Copy
(Actual
));
3313 -- Create new Symbols param association and append to New_Actuals
3315 Append_To
(New_Actuals
,
3316 Make_Parameter_Association
(Loc
,
3317 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
3318 Explicit_Actual_Parameter
=> New_Str_Lit
));
3320 -- Rewrite and analyze the procedure call
3322 if Chars
(Name_Call
) = Name_Image
then
3324 Make_Function_Call
(Loc
,
3325 Name
=> New_Copy
(Name_Call
),
3326 Parameter_Associations
=> New_Actuals
));
3327 Analyze_And_Resolve
(N
);
3330 Make_Procedure_Call_Statement
(Loc
,
3331 Name
=> New_Copy
(Name_Call
),
3332 Parameter_Associations
=> New_Actuals
));
3338 end Expand_Put_Call_With_Symbol
;
3340 ------------------------------------
3341 -- From_Dim_To_Str_Of_Dim_Symbols --
3342 ------------------------------------
3344 -- Given a dimension vector and the corresponding dimension system, create
3345 -- a String_Id to output dimension symbols corresponding to the dimensions
3346 -- Dims. If In_Error_Msg is True, there is a special handling for character
3347 -- asterisk * which is an insertion character in error messages.
3349 function From_Dim_To_Str_Of_Dim_Symbols
3350 (Dims
: Dimension_Type
;
3351 System
: System_Type
;
3352 In_Error_Msg
: Boolean := False) return String_Id
3354 Dim_Power
: Rational
;
3355 First_Dim
: Boolean := True;
3357 procedure Store_String_Oexpon
;
3358 -- Store the expon operator symbol "**" in the string. In error
3359 -- messages, asterisk * is a special character and must be quoted
3360 -- to be placed literally into the message.
3362 -------------------------
3363 -- Store_String_Oexpon --
3364 -------------------------
3366 procedure Store_String_Oexpon
is
3368 if In_Error_Msg
then
3369 Store_String_Chars
("'*'*");
3371 Store_String_Chars
("**");
3373 end Store_String_Oexpon
;
3375 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3378 -- Initialization of the new String_Id
3382 -- Store the dimension symbols inside boxes
3384 if In_Error_Msg
then
3385 Store_String_Chars
("'[");
3387 Store_String_Char
('[');
3390 for Position
in Dimension_Type
'Range loop
3391 Dim_Power
:= Dims
(Position
);
3392 if Dim_Power
/= Zero
then
3397 Store_String_Char
('.');
3400 Store_String_Chars
(System
.Dim_Symbols
(Position
));
3402 -- Positive dimension case
3404 if Dim_Power
.Numerator
> 0 then
3408 if Dim_Power
.Denominator
= 1 then
3409 if Dim_Power
.Numerator
/= 1 then
3410 Store_String_Oexpon
;
3411 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3414 -- Rational case when denominator /= 1
3417 Store_String_Oexpon
;
3418 Store_String_Char
('(');
3419 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3420 Store_String_Char
('/');
3421 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3422 Store_String_Char
(')');
3425 -- Negative dimension case
3428 Store_String_Oexpon
;
3429 Store_String_Char
('(');
3430 Store_String_Char
('-');
3431 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3435 if Dim_Power
.Denominator
= 1 then
3436 Store_String_Char
(')');
3438 -- Rational case when denominator /= 1
3441 Store_String_Char
('/');
3442 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3443 Store_String_Char
(')');
3449 if In_Error_Msg
then
3450 Store_String_Chars
("']");
3452 Store_String_Char
(']');
3456 end From_Dim_To_Str_Of_Dim_Symbols
;
3458 -------------------------------------
3459 -- From_Dim_To_Str_Of_Unit_Symbols --
3460 -------------------------------------
3462 -- Given a dimension vector and the corresponding dimension system,
3463 -- create a String_Id to output the unit symbols corresponding to the
3466 function From_Dim_To_Str_Of_Unit_Symbols
3467 (Dims
: Dimension_Type
;
3468 System
: System_Type
) return String_Id
3470 Dim_Power
: Rational
;
3471 First_Dim
: Boolean := True;
3474 -- Return No_String if dimensionless
3476 if not Exists
(Dims
) then
3480 -- Initialization of the new String_Id
3484 for Position
in Dimension_Type
'Range loop
3485 Dim_Power
:= Dims
(Position
);
3487 if Dim_Power
/= Zero
then
3491 Store_String_Char
('.');
3494 Store_String_Chars
(System
.Unit_Symbols
(Position
));
3496 -- Positive dimension case
3498 if Dim_Power
.Numerator
> 0 then
3502 if Dim_Power
.Denominator
= 1 then
3503 if Dim_Power
.Numerator
/= 1 then
3504 Store_String_Chars
("**");
3505 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3508 -- Rational case when denominator /= 1
3511 Store_String_Chars
("**");
3512 Store_String_Char
('(');
3513 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3514 Store_String_Char
('/');
3515 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3516 Store_String_Char
(')');
3519 -- Negative dimension case
3522 Store_String_Chars
("**");
3523 Store_String_Char
('(');
3524 Store_String_Char
('-');
3525 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3529 if Dim_Power
.Denominator
= 1 then
3530 Store_String_Char
(')');
3532 -- Rational case when denominator /= 1
3535 Store_String_Char
('/');
3536 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3537 Store_String_Char
(')');
3544 end From_Dim_To_Str_Of_Unit_Symbols
;
3550 function GCD
(Left
, Right
: Whole
) return Int
is
3570 --------------------------
3571 -- Has_Dimension_System --
3572 --------------------------
3574 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
3576 return Exists
(System_Of
(Typ
));
3577 end Has_Dimension_System
;
3579 ------------------------------
3580 -- Is_Dim_IO_Package_Entity --
3581 ------------------------------
3583 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
3585 -- Check the package entity corresponds to System.Dim.Float_IO or
3586 -- System.Dim.Integer_IO.
3589 Is_RTU
(E
, System_Dim_Float_IO
)
3591 Is_RTU
(E
, System_Dim_Integer_IO
);
3592 end Is_Dim_IO_Package_Entity
;
3594 -------------------------------------
3595 -- Is_Dim_IO_Package_Instantiation --
3596 -------------------------------------
3598 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
3599 Gen_Id
: constant Node_Id
:= Name
(N
);
3602 -- Check that the instantiated package is either System.Dim.Float_IO
3603 -- or System.Dim.Integer_IO.
3606 Is_Entity_Name
(Gen_Id
)
3607 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
3608 end Is_Dim_IO_Package_Instantiation
;
3614 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
3616 return Position
= Invalid_Position
;
3619 ---------------------
3620 -- Move_Dimensions --
3621 ---------------------
3623 procedure Move_Dimensions
(From
, To
: Node_Id
) is
3625 if Ada_Version
< Ada_2012
then
3629 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3631 Copy_Dimensions
(From
, To
);
3632 Remove_Dimensions
(From
);
3633 end Move_Dimensions
;
3635 ---------------------------------------
3636 -- New_Copy_Tree_And_Copy_Dimensions --
3637 ---------------------------------------
3639 function New_Copy_Tree_And_Copy_Dimensions
3641 Map
: Elist_Id
:= No_Elist
;
3642 New_Sloc
: Source_Ptr
:= No_Location
;
3643 New_Scope
: Entity_Id
:= Empty
) return Node_Id
3645 New_Copy
: constant Node_Id
:=
3646 New_Copy_Tree
(Source
, Map
, New_Sloc
, New_Scope
);
3649 -- Move the dimensions of Source to New_Copy
3651 Copy_Dimensions
(Source
, New_Copy
);
3653 end New_Copy_Tree_And_Copy_Dimensions
;
3659 function Reduce
(X
: Rational
) return Rational
is
3661 if X
.Numerator
= 0 then
3666 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
3668 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
3669 Denominator => Whole (Int (X.Denominator) / G));
3673 -----------------------
3674 -- Remove_Dimensions --
3675 -----------------------
3677 procedure Remove_Dimensions (N : Node_Id) is
3678 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3680 if Exists (Dims_Of_N) then
3681 Dimension_Table.Remove (N);
3683 end Remove_Dimensions;
3685 -----------------------------------
3686 -- Remove_Dimension_In_Statement --
3687 -----------------------------------
3689 -- Removal of dimension in statement as part of the Analyze_Statements
3690 -- routine (see package Sem_Ch5).
3692 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3694 if Ada_Version < Ada_2012 then
3698 -- Remove dimension in parameter specifications for accept statement
3700 if Nkind (Stmt) = N_Accept_Statement then
3702 Param : Node_Id := First (Parameter_Specifications (Stmt));
3704 while Present (Param) loop
3705 Remove_Dimensions (Param);
3710 -- Remove dimension of name and expression in assignments
3712 elsif Nkind (Stmt) = N_Assignment_Statement then
3713 Remove_Dimensions (Expression (Stmt));
3714 Remove_Dimensions (Name (Stmt));
3716 end Remove_Dimension_In_Statement;
3718 --------------------
3719 -- Set_Dimensions --
3720 --------------------
3722 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3724 pragma Assert (OK_For_Dimension (Nkind (N)));
3725 pragma Assert (Exists (Val));
3727 Dimension_Table.Set (N, Val);
3734 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3736 Symbol_Table.Set (E, Val);
3743 function Symbol_Of (E : Entity_Id) return String_Id is
3744 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3746 if Subtype_Symbol /= No_String then
3747 return Subtype_Symbol;
3749 return From_Dim_To_Str_Of_Unit_Symbols
3750 (Dimensions_Of (E), System_Of (Base_Type (E)));
3754 -----------------------
3755 -- Symbol_Table_Hash --
3756 -----------------------
3758 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3760 return Symbol_Table_Range (Key mod 511);
3761 end Symbol_Table_Hash;
3767 function System_Of (E : Entity_Id) return System_Type is
3771 Type_Decl : constant Node_Id := Parent (E);
3773 -- Look for Type_Decl in System_Table
3775 for Dim_Sys in 1 .. System_Table.Last loop
3776 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3777 return System_Table.Table (Dim_Sys);