1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2024, 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 Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Einfo
.Entities
; use Einfo
.Entities
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Errout
; use Errout
;
31 with Exp_Util
; use Exp_Util
;
33 with Namet
; use Namet
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
37 with Rtsfind
; use Rtsfind
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Eval
; use Sem_Eval
;
41 with Sem_Res
; use Sem_Res
;
42 with Sem_Util
; use Sem_Util
;
43 with Sinfo
; use Sinfo
;
44 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
45 with Sinfo
.Utils
; use Sinfo
.Utils
;
46 with Snames
; use Snames
;
47 with Stand
; use Stand
;
48 with Stringt
; use Stringt
;
50 with Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
52 with Urealp
; use Urealp
;
56 package body Sem_Dim
is
58 -------------------------
59 -- Rational Arithmetic --
60 -------------------------
62 type Whole
is new Int
;
63 subtype Positive_Whole
is Whole
range 1 .. Whole
'Last;
65 type Rational
is record
67 Denominator
: Positive_Whole
;
70 Zero
: constant Rational
:= Rational
'(Numerator => 0,
73 No_Rational : constant Rational := Rational'(Numerator
=> 0,
75 -- Used to indicate an expression that cannot be interpreted as a rational
76 -- Returned value of the Create_Rational_From routine when parameter Expr
77 -- is not a static representation of a rational.
79 -- Rational constructors
81 function "+" (Right
: Whole
) return Rational
;
82 function GCD
(Left
, Right
: Whole
) return Int
;
83 function Reduce
(X
: Rational
) return Rational
;
85 -- Unary operator for Rational
87 function "-" (Right
: Rational
) return Rational
;
88 function "abs" (Right
: Rational
) return Rational
;
90 -- Rational operations for Rationals
92 function "+" (Left
, Right
: Rational
) return Rational
;
93 function "-" (Left
, Right
: Rational
) return Rational
;
94 function "*" (Left
, Right
: Rational
) return Rational
;
95 function "/" (Left
, Right
: Rational
) return Rational
;
101 Max_Number_Of_Dimensions
: constant := 7;
102 -- Maximum number of dimensions in a dimension system
104 High_Position_Bound
: constant := Max_Number_Of_Dimensions
;
105 Invalid_Position
: constant := 0;
106 Low_Position_Bound
: constant := 1;
108 subtype Dimension_Position
is
109 Nat
range Invalid_Position
.. High_Position_Bound
;
112 array (Dimension_Position
range
113 Low_Position_Bound
.. High_Position_Bound
) of Name_Id
;
114 -- Store the names of all units within a system
116 No_Names
: constant Name_Array
:= (others => No_Name
);
119 array (Dimension_Position
range
120 Low_Position_Bound
.. High_Position_Bound
) of String_Id
;
121 -- Store the symbols of all units within a system
123 No_Symbols
: constant Symbol_Array
:= (others => No_String
);
125 -- The following record should be documented field by field
127 type System_Type
is record
129 Unit_Names
: Name_Array
;
130 Unit_Symbols
: Symbol_Array
;
131 Dim_Symbols
: Symbol_Array
;
132 Count
: Dimension_Position
;
135 Null_System
: constant System_Type
:=
136 (Empty
, No_Names
, No_Symbols
, No_Symbols
, Invalid_Position
);
138 subtype System_Id
is Nat
;
140 -- The following table maps types to systems
142 package System_Table
is new Table
.Table
(
143 Table_Component_Type
=> System_Type
,
144 Table_Index_Type
=> System_Id
,
145 Table_Low_Bound
=> 1,
147 Table_Increment
=> 5,
148 Table_Name
=> "System_Table");
154 type Dimension_Type
is
155 array (Dimension_Position
range
156 Low_Position_Bound
.. High_Position_Bound
) of Rational
;
158 Null_Dimension
: constant Dimension_Type
:= (others => Zero
);
160 type Dimension_Table_Range
is range 0 .. 510;
161 function Dimension_Table_Hash
(Key
: Node_Id
) return Dimension_Table_Range
;
163 -- The following table associates nodes with dimensions
165 package Dimension_Table
is new
166 GNAT
.HTable
.Simple_HTable
167 (Header_Num
=> Dimension_Table_Range
,
168 Element
=> Dimension_Type
,
169 No_Element
=> Null_Dimension
,
171 Hash
=> Dimension_Table_Hash
,
178 type Symbol_Table_Range
is range 0 .. 510;
179 function Symbol_Table_Hash
(Key
: Entity_Id
) return Symbol_Table_Range
;
181 -- Each subtype with a dimension has a symbolic representation of the
182 -- related unit. This table establishes a relation between the subtype
185 package Symbol_Table
is new
186 GNAT
.HTable
.Simple_HTable
187 (Header_Num
=> Symbol_Table_Range
,
188 Element
=> String_Id
,
189 No_Element
=> No_String
,
191 Hash
=> Symbol_Table_Hash
,
194 -- The following array enumerates all contexts which may contain or
195 -- produce a dimension.
197 OK_For_Dimension
: constant array (Node_Kind
) of Boolean :=
198 (N_Attribute_Reference
=> True,
199 N_Case_Expression
=> True,
200 N_Expanded_Name
=> True,
201 N_Explicit_Dereference
=> True,
202 N_Defining_Identifier
=> True,
203 N_Function_Call
=> True,
204 N_Identifier
=> True,
205 N_If_Expression
=> True,
206 N_Indexed_Component
=> True,
207 N_Integer_Literal
=> True,
214 N_Op_Multiply
=> True,
217 N_Op_Subtract
=> True,
218 N_Qualified_Expression
=> True,
219 N_Real_Literal
=> True,
220 N_Selected_Component
=> True,
222 N_Target_Name
=> 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
1184 | N_Unchecked_Type_Conversion
1186 Analyze_Dimension_Has_Etype (N);
1188 -- In the presence of a repaired syntax error, an identifier may be
1189 -- introduced without a usable type.
1191 when N_Identifier =>
1192 if Present (Etype (N)) then
1193 Analyze_Dimension_Has_Etype (N);
1196 when N_If_Expression =>
1197 Analyze_Dimension_If_Expression (N);
1199 when N_Number_Declaration =>
1200 Analyze_Dimension_Number_Declaration (N);
1202 when N_Object_Declaration =>
1203 Analyze_Dimension_Object_Declaration (N);
1205 when N_Object_Renaming_Declaration =>
1206 Analyze_Dimension_Object_Renaming_Declaration (N);
1208 when N_Simple_Return_Statement =>
1209 if not Comes_From_Extended_Return_Statement (N) then
1210 Analyze_Dimension_Simple_Return_Statement (N);
1213 when N_Subtype_Declaration =>
1214 Analyze_Dimension_Subtype_Declaration (N);
1216 when N_Type_Conversion =>
1217 Analyze_Dimension_Type_Conversion (N);
1220 Analyze_Dimension_Unary_Op (N);
1225 end Analyze_Dimension;
1227 ---------------------------------------
1228 -- Analyze_Dimension_Array_Aggregate --
1229 ---------------------------------------
1231 procedure Analyze_Dimension_Array_Aggregate
1233 Comp_Typ : Entity_Id)
1235 Comp_Ass : constant List_Id := Component_Associations (N);
1236 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1237 Exps : constant List_Id := Expressions (N);
1240 Dims_Of_Expr : Dimension_Type;
1243 Error_Detected : Boolean := False;
1244 -- This flag is used in order to indicate if an error has been detected
1245 -- so far by the compiler in this routine.
1248 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1249 -- base type is not a dimensioned type.
1251 -- Inlined bodies have already been checked for dimensionality.
1253 -- Note that here the original node must come from source since the
1254 -- original array aggregate may not have been entirely decorated.
1256 if Ada_Version < Ada_2012
1257 or else In_Inlined_Body
1258 or else not Comes_From_Source (Original_Node (N))
1259 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1264 -- Check whether there is any positional component association
1266 if Is_Empty_List (Exps) then
1267 Comp := First (Comp_Ass);
1269 Comp := First (Exps);
1272 while Present (Comp) loop
1274 -- Get the expression from the component
1276 if Nkind (Comp) = N_Component_Association then
1277 Expr := Expression (Comp);
1282 -- Issue an error if the dimensions of the component type and the
1283 -- dimensions of the component mismatch.
1285 -- Note that we must ensure the expression has been fully analyzed
1286 -- since it may not be decorated at this point. We also don't want to
1287 -- issue the same error message multiple times on the same expression
1288 -- (may happen when an aggregate is converted into a positional
1289 -- aggregate). We also must verify that this is a scalar component,
1290 -- and not a subaggregate of a multidimensional aggregate.
1291 -- The expression may be an identifier that has been copied several
1292 -- times during expansion, its dimensions are those of its type.
1294 if Is_Entity_Name (Expr) then
1295 Dims_Of_Expr := Dimensions_Of (Etype (Expr));
1297 Dims_Of_Expr := Dimensions_Of (Expr);
1300 if Comes_From_Source (Original_Node (Expr))
1301 and then Present (Etype (Expr))
1302 and then Is_Numeric_Type (Etype (Expr))
1303 and then Dims_Of_Expr /= Dims_Of_Comp_Typ
1304 and then Sloc (Comp) /= Sloc (Prev (Comp))
1306 -- Check if an error has already been encountered so far
1308 if not Error_Detected then
1309 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1310 Error_Detected := True;
1314 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1315 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1318 -- Look at the named components right after the positional components
1321 and then List_Containing (Comp) = Exps
1323 Comp := First (Comp_Ass);
1328 end Analyze_Dimension_Array_Aggregate;
1330 --------------------------------------------
1331 -- Analyze_Dimension_Assignment_Statement --
1332 --------------------------------------------
1334 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1335 Lhs : constant Node_Id := Name (N);
1336 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1337 Rhs : constant Node_Id := Expression (N);
1338 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1340 procedure Error_Dim_Msg_For_Assignment_Statement
1344 -- Error using Error_Msg_N at node N. Output the dimensions of left
1345 -- and right hand sides.
1347 --------------------------------------------
1348 -- Error_Dim_Msg_For_Assignment_Statement --
1349 --------------------------------------------
1351 procedure Error_Dim_Msg_For_Assignment_Statement
1357 Error_Msg_N ("dimensions mismatch in assignment", N);
1358 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1359 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1360 end Error_Dim_Msg_For_Assignment_Statement;
1362 -- Start of processing for Analyze_Dimension_Assignment
1365 if Dims_Of_Lhs /= Dims_Of_Rhs then
1366 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1368 end Analyze_Dimension_Assignment_Statement;
1370 ---------------------------------
1371 -- Analyze_Dimension_Binary_Op --
1372 ---------------------------------
1374 -- Check and propagate the dimensions for binary operators
1375 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1377 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1378 N_Kind : constant Node_Kind := Nkind (N);
1380 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1381 -- If the operand is a numeric literal that comes from a declared
1382 -- constant, use the dimensions of the constant which were computed
1383 -- from the expression of the constant declaration. Otherwise the
1384 -- dimensions are those of the operand, or the type of the operand.
1385 -- This takes care of node rewritings from validity checks, where the
1386 -- dimensions of the operand itself may not be preserved, while the
1387 -- type comes from context and must have dimension information.
1389 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1390 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1391 -- dimensions of both operands.
1393 ---------------------------
1394 -- Dimensions_Of_Operand --
1395 ---------------------------
1397 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1398 Dims : constant Dimension_Type := Dimensions_Of (N);
1401 if Exists (Dims) then
1404 elsif Is_Entity_Name (N) then
1405 return Dimensions_Of (Etype (Entity (N)));
1407 elsif Nkind (N) = N_Real_Literal then
1409 if Present (Original_Entity (N)) then
1410 return Dimensions_Of (Original_Entity (N));
1413 return Dimensions_Of (Etype (N));
1416 -- Otherwise return the default dimensions
1421 end Dimensions_Of_Operand;
1423 ---------------------------------
1424 -- Error_Dim_Msg_For_Binary_Op --
1425 ---------------------------------
1427 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1430 ("both operands for operation& must have same dimensions",
1432 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1433 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1434 end Error_Dim_Msg_For_Binary_Op;
1436 -- Start of processing for Analyze_Dimension_Binary_Op
1439 -- If the node is already analyzed, do not examine the operands. At the
1440 -- end of the analysis their dimensions have been removed, and the node
1441 -- itself may have been rewritten.
1443 if Analyzed (N) then
1447 if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract
1448 | N_Multiplying_Operator | N_Op_Compare
1451 L : constant Node_Id := Left_Opnd (N);
1452 Dims_Of_L : constant Dimension_Type :=
1453 Dimensions_Of_Operand (L);
1454 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1455 R : constant Node_Id := Right_Opnd (N);
1456 Dims_Of_R : constant Dimension_Type :=
1457 Dimensions_Of_Operand (R);
1458 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1459 Dims_Of_N : Dimension_Type := Null_Dimension;
1462 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1464 if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then
1466 -- Check both operands have same dimension
1468 if Dims_Of_L /= Dims_Of_R then
1469 Error_Dim_Msg_For_Binary_Op (N, L, R);
1471 -- Check both operands are not dimensionless
1473 if Exists (Dims_Of_L) then
1474 Set_Dimensions (N, Dims_Of_L);
1478 -- N_Op_Multiply or N_Op_Divide case
1480 elsif N_Kind in N_Op_Multiply | N_Op_Divide then
1482 -- Check at least one operand is not dimensionless
1484 if L_Has_Dimensions or R_Has_Dimensions then
1486 -- Multiplication case
1488 -- Get both operands dimensions and add them
1490 if N_Kind = N_Op_Multiply then
1491 for Position in Dimension_Type'Range loop
1492 Dims_Of_N (Position) :=
1493 Dims_Of_L (Position) + Dims_Of_R (Position);
1498 -- Get both operands dimensions and subtract them
1501 for Position in Dimension_Type'Range loop
1502 Dims_Of_N (Position) :=
1503 Dims_Of_L (Position) - Dims_Of_R (Position);
1507 if Exists (Dims_Of_N) then
1508 Set_Dimensions (N, Dims_Of_N);
1512 -- Exponentiation case
1514 -- Note: a rational exponent is allowed for dimensioned operand
1516 elsif N_Kind = N_Op_Expon then
1518 -- Check the left operand is not dimensionless. Note that the
1519 -- value of the exponent must be known compile time. Otherwise,
1520 -- the exponentiation evaluation will return an error message.
1522 if L_Has_Dimensions then
1523 if not Compile_Time_Known_Value (R) then
1525 ("exponent of dimensioned operand must be "
1526 & "known at compile time", N);
1530 Exponent_Value : Rational := Zero;
1533 -- Real operand case
1535 if Is_Real_Type (Etype (L)) then
1537 -- Define the exponent as a Rational number
1539 Exponent_Value := Create_Rational_From (R, False);
1541 -- Verify that the exponent cannot be interpreted
1542 -- as a rational, otherwise interpret the exponent
1545 if Exponent_Value = No_Rational then
1547 +Whole (UI_To_Int (Expr_Value (R)));
1550 -- Integer operand case.
1552 -- For integer operand, the exponent cannot be
1553 -- interpreted as a rational.
1556 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1559 for Position in Dimension_Type'Range loop
1560 Dims_Of_N (Position) :=
1561 Dims_Of_L (Position) * Exponent_Value;
1564 if Exists (Dims_Of_N) then
1565 Set_Dimensions (N, Dims_Of_N);
1572 -- For relational operations, only dimension checking is
1573 -- performed (no propagation). If one operand is the result
1574 -- of constant folding the dimensions may have been lost
1575 -- in a tree copy, so assume that preanalysis has verified
1576 -- that dimensions are correct.
1578 elsif N_Kind in N_Op_Compare then
1579 if (L_Has_Dimensions or R_Has_Dimensions)
1580 and then Dims_Of_L /= Dims_Of_R
1582 if Nkind (L) = N_Real_Literal
1583 and then not (Comes_From_Source (L))
1584 and then Expander_Active
1588 elsif Nkind (R) = N_Real_Literal
1589 and then not (Comes_From_Source (R))
1590 and then Expander_Active
1594 -- Numeric literal case. Issue a warning to indicate the
1595 -- literal is treated as if its dimension matches the type
1598 elsif Nkind (Original_Node (L)) in
1599 N_Integer_Literal | N_Real_Literal
1601 Dim_Warning_For_Numeric_Literal (L, Etype (R));
1603 elsif Nkind (Original_Node (R)) in
1604 N_Integer_Literal | N_Real_Literal
1606 Dim_Warning_For_Numeric_Literal (R, Etype (L));
1609 Error_Dim_Msg_For_Binary_Op (N, L, R);
1614 -- If expander is active, remove dimension information from each
1615 -- operand, as only dimensions of result are relevant.
1617 if Expander_Active then
1618 Remove_Dimensions (L);
1619 Remove_Dimensions (R);
1623 end Analyze_Dimension_Binary_Op;
1625 ----------------------------
1626 -- Analyze_Dimension_Call --
1627 ----------------------------
1629 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1630 Actuals : constant List_Id := Parameter_Associations (N);
1632 Dims_Of_Formal : Dimension_Type;
1634 Formal_Typ : Entity_Id;
1636 Error_Detected : Boolean := False;
1637 -- This flag is used in order to indicate if an error has been detected
1638 -- so far by the compiler in this routine.
1641 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1642 -- dimensions for calls in inlined bodies, or calls that don't come
1643 -- from source, or those that may have semantic errors.
1645 if Ada_Version < Ada_2012
1646 or else In_Inlined_Body
1647 or else not Comes_From_Source (N)
1648 or else Error_Posted (N)
1653 -- Check the dimensions of the actuals, if any
1655 if not Is_Empty_List (Actuals) then
1657 -- Special processing for elementary functions
1659 -- For Sqrt call, the resulting dimensions equal to half the
1660 -- dimensions of the actual. For all other elementary calls, this
1661 -- routine check that every actual is dimensionless.
1663 if Nkind (N) = N_Function_Call then
1664 Elementary_Function_Calls : declare
1665 Dims_Of_Call : Dimension_Type;
1666 Ent : Entity_Id := Nam;
1668 function Is_Elementary_Function_Entity
1669 (Sub_Id : Entity_Id) return Boolean;
1670 -- Given Sub_Id, the original subprogram entity, return True
1671 -- if call is to an elementary function (see Ada.Numerics.
1672 -- Generic_Elementary_Functions).
1674 -----------------------------------
1675 -- Is_Elementary_Function_Entity --
1676 -----------------------------------
1678 function Is_Elementary_Function_Entity
1679 (Sub_Id : Entity_Id) return Boolean
1681 Loc : constant Source_Ptr := Sloc (Sub_Id);
1684 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1690 (Cunit_Entity (Get_Source_Unit (Loc)),
1691 Ada_Numerics_Generic_Elementary_Functions);
1692 end Is_Elementary_Function_Entity;
1694 -- Start of processing for Elementary_Function_Calls
1697 -- Get original subprogram entity following the renaming chain
1699 if Present (Alias (Ent)) then
1703 -- Check the call is an Elementary function call
1705 if Is_Elementary_Function_Entity (Ent) then
1707 -- Sqrt function call case
1709 if Chars (Ent) = Name_Sqrt then
1710 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1712 -- Evaluates the resulting dimensions (i.e. half the
1713 -- dimensions of the actual).
1715 if Exists (Dims_Of_Call) then
1716 for Position in Dims_Of_Call'Range loop
1717 Dims_Of_Call (Position) :=
1718 Dims_Of_Call (Position) *
1719 Rational'(Numerator
=> 1, Denominator
=> 2);
1722 Set_Dimensions
(N
, Dims_Of_Call
);
1725 -- All other elementary functions case. Note that every
1726 -- actual here should be dimensionless.
1729 Actual
:= First_Actual
(N
);
1730 while Present
(Actual
) loop
1731 if Exists
(Dimensions_Of
(Actual
)) then
1733 -- Check if error has already been encountered
1735 if not Error_Detected
then
1737 ("dimensions mismatch in call of&",
1739 Error_Detected
:= True;
1743 ("\expected dimension '['], found "
1744 & Dimensions_Msg_Of
(Actual
), Actual
);
1747 Next_Actual
(Actual
);
1751 -- Nothing more to do for elementary functions
1755 end Elementary_Function_Calls
;
1758 -- General case. Check, for each parameter, the dimensions of the
1759 -- actual and its corresponding formal match. Otherwise, complain.
1761 Actual
:= First_Actual
(N
);
1762 Formal
:= First_Formal
(Nam
);
1763 while Present
(Formal
) loop
1765 -- A missing corresponding actual indicates that the analysis of
1766 -- the call was aborted due to a previous error.
1769 Check_Error_Detected
;
1773 Formal_Typ
:= Etype
(Formal
);
1774 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1776 -- If the formal is not dimensionless, check dimensions of formal
1777 -- and actual match. Otherwise, complain.
1779 if Exists
(Dims_Of_Formal
)
1780 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1782 -- Check if an error has already been encountered so far
1784 if not Error_Detected
then
1785 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1786 Error_Detected
:= True;
1790 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1791 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1794 Next_Actual
(Actual
);
1795 Next_Formal
(Formal
);
1799 -- For function calls, propagate the dimensions from the returned type
1801 if Nkind
(N
) = N_Function_Call
then
1802 Analyze_Dimension_Has_Etype
(N
);
1804 end Analyze_Dimension_Call
;
1806 ---------------------------------------
1807 -- Analyze_Dimension_Case_Expression --
1808 ---------------------------------------
1810 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
) is
1811 Frst
: constant Node_Id
:= First
(Alternatives
(N
));
1812 Frst_Expr
: constant Node_Id
:= Expression
(Frst
);
1813 Dims
: constant Dimension_Type
:= Dimensions_Of
(Frst_Expr
);
1819 while Present
(Alt
) loop
1820 if Dimensions_Of
(Expression
(Alt
)) /= Dims
then
1821 Error_Msg_N
("dimension mismatch in case expression", Alt
);
1828 Copy_Dimensions
(Frst_Expr
, N
);
1829 end Analyze_Dimension_Case_Expression
;
1831 ---------------------------------------------
1832 -- Analyze_Dimension_Component_Declaration --
1833 ---------------------------------------------
1835 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1836 Expr
: constant Node_Id
:= Expression
(N
);
1837 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1838 Etyp
: constant Entity_Id
:= Etype
(Id
);
1839 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1840 Dims_Of_Expr
: Dimension_Type
;
1842 procedure Error_Dim_Msg_For_Component_Declaration
1846 -- Error using Error_Msg_N at node N. Output the dimensions of the
1847 -- type Etyp and the expression Expr of N.
1849 ---------------------------------------------
1850 -- Error_Dim_Msg_For_Component_Declaration --
1851 ---------------------------------------------
1853 procedure Error_Dim_Msg_For_Component_Declaration
1858 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1860 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
1861 & Dimensions_Msg_Of
(Expr
), Expr
);
1862 end Error_Dim_Msg_For_Component_Declaration
;
1864 -- Start of processing for Analyze_Dimension_Component_Declaration
1867 -- Expression is present
1869 if Present
(Expr
) then
1870 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1872 -- Check dimensions match
1874 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1876 -- Numeric literal case. Issue a warning if the object type is not
1877 -- dimensionless to indicate the literal is treated as if its
1878 -- dimension matches the type dimension.
1880 if Nkind
(Original_Node
(Expr
)) in
1881 N_Real_Literal | N_Integer_Literal
1883 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1885 -- Issue a dimension mismatch error for all other cases
1888 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1892 end Analyze_Dimension_Component_Declaration
;
1894 -------------------------------------------------
1895 -- Analyze_Dimension_Extended_Return_Statement --
1896 -------------------------------------------------
1898 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1899 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1900 Return_Etyp
: constant Entity_Id
:=
1901 Etype
(Return_Applies_To
(Return_Ent
));
1902 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1903 Return_Obj_Decl
: Node_Id
;
1904 Return_Obj_Id
: Entity_Id
;
1905 Return_Obj_Typ
: Entity_Id
;
1907 procedure Error_Dim_Msg_For_Extended_Return_Statement
1909 Return_Etyp
: Entity_Id
;
1910 Return_Obj_Typ
: Entity_Id
);
1911 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1912 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1914 -------------------------------------------------
1915 -- Error_Dim_Msg_For_Extended_Return_Statement --
1916 -------------------------------------------------
1918 procedure Error_Dim_Msg_For_Extended_Return_Statement
1920 Return_Etyp
: Entity_Id
;
1921 Return_Obj_Typ
: Entity_Id
)
1924 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1926 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
1927 & ", found " & Dimensions_Msg_Of
(Return_Obj_Typ
), N
);
1928 end Error_Dim_Msg_For_Extended_Return_Statement
;
1930 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1933 if Present
(Return_Obj_Decls
) then
1934 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1935 while Present
(Return_Obj_Decl
) loop
1936 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1937 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1939 if Is_Return_Object
(Return_Obj_Id
) then
1940 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1942 -- Issue an error message if dimensions mismatch
1944 if Dimensions_Of
(Return_Etyp
) /=
1945 Dimensions_Of
(Return_Obj_Typ
)
1947 Error_Dim_Msg_For_Extended_Return_Statement
1948 (N
, Return_Etyp
, Return_Obj_Typ
);
1954 Next
(Return_Obj_Decl
);
1957 end Analyze_Dimension_Extended_Return_Statement
;
1959 -----------------------------------------------------
1960 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1961 -----------------------------------------------------
1963 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1965 Comp_Id
: Entity_Id
;
1966 Comp_Typ
: Entity_Id
;
1969 Error_Detected
: Boolean := False;
1970 -- This flag is used in order to indicate if an error has been detected
1971 -- so far by the compiler in this routine.
1974 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1975 -- dimensions in inlined bodies, or for aggregates that don't come
1976 -- from source, or if we are within an initialization procedure, whose
1977 -- expressions have been checked at the point of record declaration.
1979 if Ada_Version
< Ada_2012
1980 or else In_Inlined_Body
1981 or else not Comes_From_Source
(N
)
1982 or else Inside_Init_Proc
1987 Comp
:= First
(Component_Associations
(N
));
1988 while Present
(Comp
) loop
1989 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1990 Comp_Typ
:= Etype
(Comp_Id
);
1992 -- Check the component type is either a dimensioned type or a
1993 -- dimensioned subtype.
1995 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1996 Expr
:= Expression
(Comp
);
1998 -- A box-initialized component needs no checking.
2000 if No
(Expr
) and then Box_Present
(Comp
) then
2003 -- Issue an error if the dimensions of the component type and the
2004 -- dimensions of the component mismatch.
2006 elsif Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
2008 -- Check if an error has already been encountered so far
2010 if not Error_Detected
then
2012 -- Extension aggregate case
2014 if Nkind
(N
) = N_Extension_Aggregate
then
2016 ("dimensions mismatch in extension aggregate", N
);
2018 -- Record aggregate case
2022 ("dimensions mismatch in record aggregate", N
);
2025 Error_Detected
:= True;
2029 ("\expected dimension " & Dimensions_Msg_Of
(Comp_Typ
)
2030 & ", found " & Dimensions_Msg_Of
(Expr
), Comp
);
2036 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
2038 -------------------------------
2039 -- Analyze_Dimension_Formals --
2040 -------------------------------
2042 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
2043 Dims_Of_Typ
: Dimension_Type
;
2048 -- Aspect is an Ada 2012 feature. Note that there is no need to check
2049 -- dimensions for sub specs that don't come from source.
2051 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
2055 Formal
:= First
(Formals
);
2056 while Present
(Formal
) loop
2057 Typ
:= Parameter_Type
(Formal
);
2058 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
2060 if Exists
(Dims_Of_Typ
) then
2062 Expr
: constant Node_Id
:= Expression
(Formal
);
2065 -- Issue a warning if Expr is a numeric literal and if its
2066 -- dimensions differ with the dimensions of the formal type.
2069 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
2070 and then Nkind
(Original_Node
(Expr
)) in
2071 N_Real_Literal | N_Integer_Literal
2073 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
2080 end Analyze_Dimension_Formals
;
2082 ---------------------------------
2083 -- Analyze_Dimension_Has_Etype --
2084 ---------------------------------
2086 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
2087 Etyp
: constant Entity_Id
:= Etype
(N
);
2088 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
2091 -- General case. Propagation of the dimensions from the type
2093 if Exists
(Dims_Of_Etyp
) then
2094 Set_Dimensions
(N
, Dims_Of_Etyp
);
2096 -- Identifier case. Propagate the dimensions from the entity for
2097 -- identifier whose entity is a non-dimensionless constant.
2099 elsif Nkind
(N
) = N_Identifier
then
2100 Analyze_Dimension_Identifier
: declare
2101 Id
: constant Entity_Id
:= Entity
(N
);
2104 -- If Id is missing, abnormal tree, assume previous error
2107 Check_Error_Detected
;
2110 elsif Ekind
(Id
) in E_Constant | E_Named_Real
2111 and then Exists
(Dimensions_Of
(Id
))
2113 Set_Dimensions
(N
, Dimensions_Of
(Id
));
2115 end Analyze_Dimension_Identifier
;
2117 -- Attribute reference case. Propagate the dimensions from the prefix.
2119 elsif Nkind
(N
) = N_Attribute_Reference
2120 and then Has_Dimension_System
(Base_Type
(Etyp
))
2122 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
2124 -- Check the prefix is not dimensionless
2126 if Exists
(Dims_Of_Etyp
) then
2127 Set_Dimensions
(N
, Dims_Of_Etyp
);
2131 -- Remove dimensions from inner expressions, to prevent dimensions
2132 -- table from growing uselessly.
2135 when N_Attribute_Reference
2136 | N_Indexed_Component
2139 Exprs
: constant List_Id
:= Expressions
(N
);
2143 if Present
(Exprs
) then
2144 Expr
:= First
(Exprs
);
2145 while Present
(Expr
) loop
2146 Remove_Dimensions
(Expr
);
2152 when N_Qualified_Expression
2154 | N_Unchecked_Type_Conversion
2156 Remove_Dimensions
(Expression
(N
));
2158 when N_Selected_Component
=>
2159 Remove_Dimensions
(Selector_Name
(N
));
2164 end Analyze_Dimension_Has_Etype
;
2166 -------------------------------------
2167 -- Analyze_Dimension_If_Expression --
2168 -------------------------------------
2170 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
) is
2171 Then_Expr
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
2172 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2175 if Dimensions_Of
(Then_Expr
) /= Dimensions_Of
(Else_Expr
) then
2176 Error_Msg_N
("dimensions mismatch in conditional expression", N
);
2178 Copy_Dimensions
(Then_Expr
, N
);
2180 end Analyze_Dimension_If_Expression
;
2182 ------------------------------------------
2183 -- Analyze_Dimension_Number_Declaration --
2184 ------------------------------------------
2186 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
) is
2187 Expr
: constant Node_Id
:= Expression
(N
);
2188 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2189 Dim_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2192 if Exists
(Dim_Of_Expr
) then
2193 Set_Dimensions
(Id
, Dim_Of_Expr
);
2194 Set_Etype
(Id
, Etype
(Expr
));
2196 end Analyze_Dimension_Number_Declaration
;
2198 ------------------------------------------
2199 -- Analyze_Dimension_Object_Declaration --
2200 ------------------------------------------
2202 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
2203 Expr
: constant Node_Id
:= Expression
(N
);
2204 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2205 Etyp
: constant Entity_Id
:= Etype
(Id
);
2206 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
2207 Dim_Of_Expr
: Dimension_Type
;
2209 procedure Error_Dim_Msg_For_Object_Declaration
2213 -- Error using Error_Msg_N at node N. Output the dimensions of the
2214 -- type Etyp and of the expression Expr.
2216 ------------------------------------------
2217 -- Error_Dim_Msg_For_Object_Declaration --
2218 ------------------------------------------
2220 procedure Error_Dim_Msg_For_Object_Declaration
2225 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2227 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
2228 & Dimensions_Msg_Of
(Expr
), Expr
);
2229 end Error_Dim_Msg_For_Object_Declaration
;
2231 -- Start of processing for Analyze_Dimension_Object_Declaration
2234 -- Expression is present
2236 if Present
(Expr
) then
2237 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2239 -- Check dimensions match
2241 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2243 -- Numeric literal case. Issue a warning if the object type is
2244 -- not dimensionless to indicate the literal is treated as if
2245 -- its dimension matches the type dimension.
2247 if Nkind
(Original_Node
(Expr
)) in
2248 N_Real_Literal | N_Integer_Literal
2250 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2252 -- Case of object is a constant whose type is a dimensioned type
2254 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2256 -- Propagate dimension from expression to object entity
2258 Set_Dimensions
(Id
, Dim_Of_Expr
);
2260 -- Expression may have been constant-folded. If nominal type has
2261 -- dimensions, verify that expression has same type.
2263 elsif Exists
(Dim_Of_Etyp
) and then Etype
(Expr
) = Etyp
then
2266 -- For all other cases, issue an error message
2269 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2273 -- Remove dimensions in expression after checking consistency with
2276 Remove_Dimensions
(Expr
);
2278 end Analyze_Dimension_Object_Declaration
;
2280 ---------------------------------------------------
2281 -- Analyze_Dimension_Object_Renaming_Declaration --
2282 ---------------------------------------------------
2284 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2285 Renamed_Name
: constant Node_Id
:= Name
(N
);
2286 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2288 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2291 Renamed_Name
: Node_Id
);
2292 -- Error using Error_Msg_N at node N. Output the dimensions of
2293 -- Sub_Mark and of Renamed_Name.
2295 ---------------------------------------------------
2296 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2297 ---------------------------------------------------
2299 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2302 Renamed_Name
: Node_Id
) is
2304 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2306 ("\expected dimension " & Dimensions_Msg_Of
(Sub_Mark
) & ", found "
2307 & Dimensions_Msg_Of
(Renamed_Name
), Renamed_Name
);
2308 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2310 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2313 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2314 Error_Dim_Msg_For_Object_Renaming_Declaration
2315 (N
, Sub_Mark
, Renamed_Name
);
2317 end Analyze_Dimension_Object_Renaming_Declaration
;
2319 -----------------------------------------------
2320 -- Analyze_Dimension_Simple_Return_Statement --
2321 -----------------------------------------------
2323 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2324 Expr
: constant Node_Id
:= Expression
(N
);
2325 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2326 Return_Etyp
: constant Entity_Id
:=
2327 Etype
(Return_Applies_To
(Return_Ent
));
2328 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2329 Dimensions_Of
(Return_Etyp
);
2331 procedure Error_Dim_Msg_For_Simple_Return_Statement
2333 Return_Etyp
: Entity_Id
;
2335 -- Error using Error_Msg_N at node N. Output the dimensions of the
2336 -- returned type Return_Etyp and the returned expression Expr of N.
2338 -----------------------------------------------
2339 -- Error_Dim_Msg_For_Simple_Return_Statement --
2340 -----------------------------------------------
2342 procedure Error_Dim_Msg_For_Simple_Return_Statement
2344 Return_Etyp
: Entity_Id
;
2348 Error_Msg_N
("dimensions mismatch in return statement", N
);
2350 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
2351 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2352 end Error_Dim_Msg_For_Simple_Return_Statement
;
2354 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2357 if Dims_Of_Return_Etyp
/= Dimensions_Of
(Expr
) then
2358 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2359 Remove_Dimensions
(Expr
);
2361 end Analyze_Dimension_Simple_Return_Statement
;
2363 -------------------------------------------
2364 -- Analyze_Dimension_Subtype_Declaration --
2365 -------------------------------------------
2367 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2368 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2369 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2370 Dims_Of_Etyp
: Dimension_Type
;
2374 -- No constraint case in subtype declaration
2376 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2377 Etyp
:= Etype
(Subtype_Indication
(N
));
2378 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2380 if Exists
(Dims_Of_Etyp
) then
2382 -- If subtype already has a dimension (from Aspect_Dimension), it
2383 -- cannot inherit different dimensions from its subtype.
2385 if Exists
(Dims_Of_Id
) and then Dims_Of_Etyp
/= Dims_Of_Id
then
2387 ("subtype& already " & Dimensions_Msg_Of
(Id
, True), N
, Id
);
2389 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2390 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2394 -- Constraint present in subtype declaration
2397 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2398 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2400 if Exists
(Dims_Of_Etyp
) then
2401 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2402 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2405 end Analyze_Dimension_Subtype_Declaration
;
2407 ---------------------------------------
2408 -- Analyze_Dimension_Type_Conversion --
2409 ---------------------------------------
2411 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
) is
2412 Expr_Root
: constant Entity_Id
:=
2413 Dimension_System_Root
(Etype
(Expression
(N
)));
2414 Target_Root
: constant Entity_Id
:=
2415 Dimension_System_Root
(Etype
(N
));
2418 -- If the expression has dimensions and the target type has dimensions,
2419 -- the conversion has the dimensions of the expression. Consistency is
2420 -- checked below. Converting to a non-dimensioned type such as Float
2421 -- ignores the dimensions of the expression.
2423 if Exists
(Dimensions_Of
(Expression
(N
)))
2424 and then Present
(Target_Root
)
2426 Set_Dimensions
(N
, Dimensions_Of
(Expression
(N
)));
2428 -- Otherwise the dimensions are those of the target type.
2431 Analyze_Dimension_Has_Etype
(N
);
2434 -- A conversion between types in different dimension systems (e.g. MKS
2435 -- and British units) must respect the dimensions of expression and
2436 -- type, It is up to the user to provide proper conversion factors.
2438 -- Upward conversions to root type of a dimensioned system are legal,
2439 -- and correspond to "view conversions", i.e. preserve the dimensions
2440 -- of the expression; otherwise conversion must be between types with
2441 -- then same dimensions. Conversions to a non-dimensioned type such as
2442 -- Float lose the dimensions of the expression.
2444 if Present
(Expr_Root
)
2445 and then Present
(Target_Root
)
2446 and then Etype
(N
) /= Target_Root
2447 and then Dimensions_Of
(Expression
(N
)) /= Dimensions_Of
(Etype
(N
))
2449 Error_Msg_N
("dimensions mismatch in conversion", N
);
2451 ("\expression " & Dimensions_Msg_Of
(Expression
(N
), True), N
);
2453 ("\target type " & Dimensions_Msg_Of
(Etype
(N
), True), N
);
2455 end Analyze_Dimension_Type_Conversion
;
2457 --------------------------------
2458 -- Analyze_Dimension_Unary_Op --
2459 --------------------------------
2461 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2465 -- Propagate the dimension if the operand is not dimensionless
2472 R
: constant Node_Id
:= Right_Opnd
(N
);
2474 Move_Dimensions
(R
, N
);
2480 end Analyze_Dimension_Unary_Op
;
2482 ---------------------------------
2483 -- Check_Expression_Dimensions --
2484 ---------------------------------
2486 procedure Check_Expression_Dimensions
2491 if Is_Floating_Point_Type
(Etype
(Expr
)) then
2492 Analyze_Dimension
(Expr
);
2494 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Typ
) then
2495 Error_Msg_N
("dimensions mismatch in array aggregate", Expr
);
2497 ("\expected dimension " & Dimensions_Msg_Of
(Typ
)
2498 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2501 end Check_Expression_Dimensions
;
2503 ---------------------
2504 -- Copy_Dimensions --
2505 ---------------------
2507 procedure Copy_Dimensions
(From
: Node_Id
; To
: Node_Id
) is
2508 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2511 -- Ignore if not Ada 2012 or beyond
2513 if Ada_Version
< Ada_2012
then
2516 -- For Ada 2012, Copy the dimension of 'From to 'To'
2518 elsif Exists
(Dims_Of_From
) then
2519 Set_Dimensions
(To
, Dims_Of_From
);
2521 end Copy_Dimensions
;
2523 -----------------------------------
2524 -- Copy_Dimensions_Of_Components --
2525 -----------------------------------
2527 procedure Copy_Dimensions_Of_Components
(Rec
: Entity_Id
) is
2531 C
:= First_Component
(Rec
);
2532 while Present
(C
) loop
2533 if Nkind
(Parent
(C
)) = N_Component_Declaration
then
2535 (Expression
(Parent
(Corresponding_Record_Component
(C
))),
2536 Expression
(Parent
(C
)));
2540 end Copy_Dimensions_Of_Components
;
2542 --------------------------
2543 -- Create_Rational_From --
2544 --------------------------
2546 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2548 -- A rational number is a number that can be expressed as the quotient or
2549 -- fraction a/b of two integers, where b is non-zero positive.
2551 function Create_Rational_From
2553 Complain
: Boolean) return Rational
2555 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2556 Result
: Rational
:= No_Rational
;
2558 function Process_Minus
(N
: Node_Id
) return Rational
;
2559 -- Create a rational from a N_Op_Minus node
2561 function Process_Divide
(N
: Node_Id
) return Rational
;
2562 -- Create a rational from a N_Op_Divide node
2564 function Process_Literal
(N
: Node_Id
) return Rational
;
2565 -- Create a rational from a N_Integer_Literal node
2571 function Process_Minus
(N
: Node_Id
) return Rational
is
2572 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2576 -- Operand is an integer literal
2578 if Nkind
(Right
) = N_Integer_Literal
then
2579 Result
:= -Process_Literal
(Right
);
2581 -- Operand is a divide operator
2583 elsif Nkind
(Right
) = N_Op_Divide
then
2584 Result
:= -Process_Divide
(Right
);
2587 Result
:= No_Rational
;
2593 --------------------
2594 -- Process_Divide --
2595 --------------------
2597 function Process_Divide
(N
: Node_Id
) return Rational
is
2598 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2599 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2600 Left_Rat
: Rational
;
2601 Result
: Rational
:= No_Rational
;
2602 Right_Rat
: Rational
;
2605 -- Both left and right operands are integer literals
2607 if Nkind
(Left
) = N_Integer_Literal
2609 Nkind
(Right
) = N_Integer_Literal
2611 Left_Rat
:= Process_Literal
(Left
);
2612 Right_Rat
:= Process_Literal
(Right
);
2613 Result
:= Left_Rat
/ Right_Rat
;
2619 ---------------------
2620 -- Process_Literal --
2621 ---------------------
2623 function Process_Literal
(N
: Node_Id
) return Rational
is
2625 return +Whole
(UI_To_Int
(Intval
(N
)));
2626 end Process_Literal
;
2628 -- Start of processing for Create_Rational_From
2631 -- Check the expression is either a division of two integers or an
2632 -- integer itself. Note that the check applies to the original node
2633 -- since the node could have already been rewritten.
2635 -- Integer literal case
2637 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2638 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2640 -- Divide operator case
2642 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2643 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2645 -- Minus operator case
2647 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2648 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2651 -- When Expr cannot be interpreted as a rational and Complain is true,
2652 -- generate an error message.
2654 if Complain
and then Result
= No_Rational
then
2655 Error_Msg_N
("rational expected", Expr
);
2659 end Create_Rational_From
;
2665 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2667 return Dimension_Table
.Get
(N
);
2670 -----------------------
2671 -- Dimensions_Msg_Of --
2672 -----------------------
2674 function Dimensions_Msg_Of
2676 Description_Needed
: Boolean := False) return String
2678 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2679 Dimensions_Msg
: Name_Id
;
2680 System
: System_Type
;
2683 -- Initialization of Name_Buffer
2687 -- N is not dimensionless
2689 if Exists
(Dims_Of_N
) then
2690 System
:= System_Of
(Base_Type
(Etype
(N
)));
2692 -- When Description_Needed, add to string "has dimension " before the
2693 -- actual dimension.
2695 if Description_Needed
then
2696 Add_Str_To_Name_Buffer
("has dimension ");
2700 (Global_Name_Buffer
,
2701 From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2703 -- N is dimensionless
2705 -- When Description_Needed, return "is dimensionless"
2707 elsif Description_Needed
then
2708 Add_Str_To_Name_Buffer
("is dimensionless");
2710 -- Otherwise, return "'[']"
2713 Add_Str_To_Name_Buffer
("'[']");
2716 Dimensions_Msg
:= Name_Find
;
2717 return Get_Name_String
(Dimensions_Msg
);
2718 end Dimensions_Msg_Of
;
2720 --------------------------
2721 -- Dimension_Table_Hash --
2722 --------------------------
2724 function Dimension_Table_Hash
2725 (Key
: Node_Id
) return Dimension_Table_Range
2728 return Dimension_Table_Range
(Key
mod 511);
2729 end Dimension_Table_Hash
;
2731 -------------------------------------
2732 -- Dim_Warning_For_Numeric_Literal --
2733 -------------------------------------
2735 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2737 -- Consider the literal zero (integer 0 or real 0.0) to be of any
2740 case Nkind
(Original_Node
(N
)) is
2741 when N_Real_Literal
=>
2742 if Expr_Value_R
(N
) = Ureal_0
then
2746 when N_Integer_Literal
=>
2747 if Expr_Value
(N
) = Uint_0
then
2755 -- Initialize name buffer
2759 Append
(Global_Name_Buffer
, String_From_Numeric_Literal
(N
));
2761 -- Insert a blank between the literal and the symbol
2763 Add_Char_To_Name_Buffer
(' ');
2764 Append
(Global_Name_Buffer
, Symbol_Of
(Typ
));
2766 Error_Msg_Name_1
:= Name_Find
;
2767 Error_Msg_N
("assumed to be%%??", N
);
2768 end Dim_Warning_For_Numeric_Literal
;
2770 ----------------------
2771 -- Dimensions_Match --
2772 ----------------------
2774 function Dimensions_Match
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2777 not Has_Dimension_System
(Base_Type
(T1
))
2778 or else Dimensions_Of
(T1
) = Dimensions_Of
(T2
);
2779 end Dimensions_Match
;
2781 ---------------------------
2782 -- Dimension_System_Root --
2783 ---------------------------
2785 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
is
2789 Root
:= Base_Type
(T
);
2791 if Has_Dimension_System
(Root
) then
2792 return First_Subtype
(Root
); -- for example Dim_Mks
2797 end Dimension_System_Root
;
2799 ----------------------------------------
2800 -- Eval_Op_Expon_For_Dimensioned_Type --
2801 ----------------------------------------
2803 -- Evaluate the expon operator for real dimensioned type.
2805 -- Note that if the exponent is an integer (denominator = 1) the node is
2806 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2808 procedure Eval_Op_Expon_For_Dimensioned_Type
2812 R
: constant Node_Id
:= Right_Opnd
(N
);
2813 R_Value
: Rational
:= No_Rational
;
2816 if Is_Real_Type
(Btyp
) then
2817 R_Value
:= Create_Rational_From
(R
, False);
2820 -- Check that the exponent is not an integer
2822 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2823 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2827 end Eval_Op_Expon_For_Dimensioned_Type
;
2829 ------------------------------------------
2830 -- Eval_Op_Expon_With_Rational_Exponent --
2831 ------------------------------------------
2833 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2834 -- Rational and not only an Integer like for dimensionless operands. For
2835 -- that particular case, the left operand is rewritten as a function call
2836 -- using the function Expon_LLF from s-llflex.ads.
2838 procedure Eval_Op_Expon_With_Rational_Exponent
2840 Exponent_Value
: Rational
)
2842 Loc
: constant Source_Ptr
:= Sloc
(N
);
2843 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2844 L
: constant Node_Id
:= Left_Opnd
(N
);
2845 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2846 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2849 Dim_Power
: Rational
;
2850 List_Of_Dims
: List_Id
;
2851 New_Aspect
: Node_Id
;
2852 New_Aspects
: List_Id
;
2855 New_Subtyp_Decl_For_L
: Node_Id
;
2856 System
: System_Type
;
2859 -- Case when the operand is not dimensionless
2861 if Exists
(Dims_Of_N
) then
2863 -- Get the corresponding System_Type to know the exact number of
2864 -- dimensions in the system.
2866 System
:= System_Of
(Btyp_Of_L
);
2868 -- Generation of a new subtype with the proper dimensions
2870 -- In order to rewrite the operator as a type conversion, a new
2871 -- dimensioned subtype with the resulting dimensions of the
2872 -- exponentiation must be created.
2876 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2877 -- System : constant System_Id :=
2878 -- Get_Dimension_System_Id (Btyp_Of_L);
2879 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2880 -- Dimension_Systems.Table (System).Dimension_Count;
2882 -- subtype T is Btyp_Of_L
2885 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2886 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2888 -- Dims_Of_N (Num_Of_Dims).Numerator /
2889 -- Dims_Of_N (Num_Of_Dims).Denominator);
2891 -- Step 1: Generate the new aggregate for the aspect Dimension
2893 New_Aspects
:= Empty_List
;
2895 List_Of_Dims
:= New_List
;
2896 for Position
in Dims_Of_N
'First .. System
.Count
loop
2897 Dim_Power
:= Dims_Of_N
(Position
);
2898 Append_To
(List_Of_Dims
,
2899 Make_Op_Divide
(Loc
,
2901 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Numerator
)),
2903 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Denominator
))));
2906 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2909 Make_Aspect_Specification
(Loc
,
2910 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2911 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2913 -- Step 3: Make a temporary identifier for the new subtype
2915 New_Id
:= Make_Temporary
(Loc
, 'T');
2916 Set_Is_Internal
(New_Id
);
2918 -- Step 4: Declaration of the new subtype
2920 New_Subtyp_Decl_For_L
:=
2921 Make_Subtype_Declaration
(Loc
,
2922 Defining_Identifier
=> New_Id
,
2923 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2925 Append
(New_Aspect
, New_Aspects
);
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);