1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Util
; use Exp_Util
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
34 with Nmake
; use Nmake
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Eval
; use Sem_Eval
;
40 with Sem_Res
; use Sem_Res
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Sinput
; use Sinput
;
44 with Snames
; use Snames
;
45 with Stand
; use Stand
;
46 with Stringt
; use Stringt
;
48 with Tbuild
; use Tbuild
;
49 with Uintp
; use Uintp
;
50 with Urealp
; use Urealp
;
54 package body Sem_Dim
is
56 -------------------------
57 -- Rational Arithmetic --
58 -------------------------
60 type Whole
is new Int
;
61 subtype Positive_Whole
is Whole
range 1 .. Whole
'Last;
63 type Rational
is record
65 Denominator
: Positive_Whole
;
68 Zero
: constant Rational
:= Rational
'(Numerator => 0,
71 No_Rational : constant Rational := Rational'(Numerator
=> 0,
73 -- Used to indicate an expression that cannot be interpreted as a rational
74 -- Returned value of the Create_Rational_From routine when parameter Expr
75 -- is not a static representation of a rational.
77 -- Rational constructors
79 function "+" (Right
: Whole
) return Rational
;
80 function GCD
(Left
, Right
: Whole
) return Int
;
81 function Reduce
(X
: Rational
) return Rational
;
83 -- Unary operator for Rational
85 function "-" (Right
: Rational
) return Rational
;
86 function "abs" (Right
: Rational
) return Rational
;
88 -- Rational operations for Rationals
90 function "+" (Left
, Right
: Rational
) return Rational
;
91 function "-" (Left
, Right
: Rational
) return Rational
;
92 function "*" (Left
, Right
: Rational
) return Rational
;
93 function "/" (Left
, Right
: Rational
) return Rational
;
99 Max_Number_Of_Dimensions
: constant := 7;
100 -- Maximum number of dimensions in a dimension system
102 High_Position_Bound
: constant := Max_Number_Of_Dimensions
;
103 Invalid_Position
: constant := 0;
104 Low_Position_Bound
: constant := 1;
106 subtype Dimension_Position
is
107 Nat
range Invalid_Position
.. High_Position_Bound
;
110 array (Dimension_Position
range
111 Low_Position_Bound
.. High_Position_Bound
) of Name_Id
;
112 -- Store the names of all units within a system
114 No_Names
: constant Name_Array
:= (others => No_Name
);
117 array (Dimension_Position
range
118 Low_Position_Bound
.. High_Position_Bound
) of String_Id
;
119 -- Store the symbols of all units within a system
121 No_Symbols
: constant Symbol_Array
:= (others => No_String
);
123 -- The following record should be documented field by field
125 type System_Type
is record
127 Unit_Names
: Name_Array
;
128 Unit_Symbols
: Symbol_Array
;
129 Dim_Symbols
: Symbol_Array
;
130 Count
: Dimension_Position
;
133 Null_System
: constant System_Type
:=
134 (Empty
, No_Names
, No_Symbols
, No_Symbols
, Invalid_Position
);
136 subtype System_Id
is Nat
;
138 -- The following table maps types to systems
140 package System_Table
is new Table
.Table
(
141 Table_Component_Type
=> System_Type
,
142 Table_Index_Type
=> System_Id
,
143 Table_Low_Bound
=> 1,
145 Table_Increment
=> 5,
146 Table_Name
=> "System_Table");
152 type Dimension_Type
is
153 array (Dimension_Position
range
154 Low_Position_Bound
.. High_Position_Bound
) of Rational
;
156 Null_Dimension
: constant Dimension_Type
:= (others => Zero
);
158 type Dimension_Table_Range
is range 0 .. 510;
159 function Dimension_Table_Hash
(Key
: Node_Id
) return Dimension_Table_Range
;
161 -- The following table associates nodes with dimensions
163 package Dimension_Table
is new
164 GNAT
.HTable
.Simple_HTable
165 (Header_Num
=> Dimension_Table_Range
,
166 Element
=> Dimension_Type
,
167 No_Element
=> Null_Dimension
,
169 Hash
=> Dimension_Table_Hash
,
176 type Symbol_Table_Range
is range 0 .. 510;
177 function Symbol_Table_Hash
(Key
: Entity_Id
) return Symbol_Table_Range
;
179 -- Each subtype with a dimension has a symbolic representation of the
180 -- related unit. This table establishes a relation between the subtype
183 package Symbol_Table
is new
184 GNAT
.HTable
.Simple_HTable
185 (Header_Num
=> Symbol_Table_Range
,
186 Element
=> String_Id
,
187 No_Element
=> No_String
,
189 Hash
=> Symbol_Table_Hash
,
192 -- The following array enumerates all contexts which may contain or
193 -- produce a dimension.
195 OK_For_Dimension
: constant array (Node_Kind
) of Boolean :=
196 (N_Attribute_Reference
=> True,
197 N_Case_Expression
=> True,
198 N_Expanded_Name
=> True,
199 N_Explicit_Dereference
=> True,
200 N_Defining_Identifier
=> True,
201 N_Function_Call
=> True,
202 N_Identifier
=> True,
203 N_If_Expression
=> True,
204 N_Indexed_Component
=> True,
205 N_Integer_Literal
=> True,
212 N_Op_Multiply
=> True,
215 N_Op_Subtract
=> True,
216 N_Qualified_Expression
=> True,
217 N_Real_Literal
=> True,
218 N_Selected_Component
=> True,
220 N_Type_Conversion
=> True,
221 N_Unchecked_Type_Conversion
=> True,
225 -----------------------
226 -- Local Subprograms --
227 -----------------------
229 procedure Analyze_Dimension_Assignment_Statement
(N
: Node_Id
);
230 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
231 -- dimensions of the left-hand side and the right-hand side of N match.
233 procedure Analyze_Dimension_Binary_Op
(N
: Node_Id
);
234 -- Subroutine of Analyze_Dimension for binary operators. Check the
235 -- dimensions of the right and the left operand permit the operation.
236 -- Then, evaluate the resulting dimensions for each binary operator.
238 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
);
239 -- Subroutine of Analyze_Dimension for component declaration. Check that
240 -- the dimensions of the type of N and of the expression match.
242 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
);
243 -- Subroutine of Analyze_Dimension for extended return statement. Check
244 -- that the dimensions of the returned type and of the returned object
247 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
);
248 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
250 -- N_Attribute_Reference
252 -- N_Indexed_Component
253 -- N_Qualified_Expression
254 -- N_Selected_Component
257 -- N_Unchecked_Type_Conversion
259 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
);
260 -- Verify that all alternatives have the same dimension
262 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
);
263 -- Verify that all alternatives have the same dimension
265 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
);
266 -- Procedure to analyze dimension of expression in a number declaration.
267 -- This allows a named number to have nontrivial dimensions, while by
268 -- default a named number is dimensionless.
270 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
);
271 -- Subroutine of Analyze_Dimension for object declaration. Check that
272 -- the dimensions of the object type and the dimensions of the expression
273 -- (if expression is present) match. Note that when the expression is
274 -- a literal, no error is returned. This special case allows object
275 -- declaration such as: m : constant Length := 1.0;
277 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
);
278 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
279 -- the dimensions of the type and of the renamed object name of N match.
281 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
);
282 -- Subroutine of Analyze_Dimension for simple return statement
283 -- Check that the dimensions of the returned type and of the returned
286 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
);
287 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
288 -- dimensions from the parent type to the identifier of N. Note that if
289 -- both the identifier and the parent type of N are not dimensionless,
292 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
);
293 -- Type conversions handle conversions between literals and dimensioned
294 -- types, from dimensioned types to their base type, and between different
295 -- dimensioned systems. Dimensions of the conversion are obtained either
296 -- from those of the expression, or from the target type, and dimensional
297 -- consistency must be checked when converting between values belonging
298 -- to different dimensioned systems.
300 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
);
301 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
302 -- Abs operators, propagate the dimensions from the operand to N.
304 function Create_Rational_From
306 Complain
: Boolean) return Rational
;
307 -- Given an arbitrary expression Expr, return a valid rational if Expr can
308 -- be interpreted as a rational. Otherwise return No_Rational and also an
309 -- error message if Complain is set to True.
311 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
;
312 -- Return the dimension vector of node N
314 function Dimensions_Msg_Of
316 Description_Needed
: Boolean := False) return String;
317 -- Given a node N, return the dimension symbols of N, preceded by "has
318 -- dimension" if Description_Needed. if N is dimensionless, return "'[']",
319 -- or "is dimensionless" if Description_Needed.
321 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
;
322 -- Given a type that has dimension information, return the type that is the
323 -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
324 -- type, i.e. a standard numeric type, return Empty.
326 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
327 -- Issue a warning on the given numeric literal N to indicate that the
328 -- compiler made the assumption that the literal is not dimensionless
329 -- but has the dimension of Typ.
331 procedure Eval_Op_Expon_With_Rational_Exponent
333 Exponent_Value
: Rational
);
334 -- Evaluate the exponent it is a rational and the operand has a dimension
336 function Exists
(Dim
: Dimension_Type
) return Boolean;
337 -- Returns True iff Dim does not denote the null dimension
339 function Exists
(Str
: String_Id
) return Boolean;
340 -- Returns True iff Str does not denote No_String
342 function Exists
(Sys
: System_Type
) return Boolean;
343 -- Returns True iff Sys does not denote the null system
345 function From_Dim_To_Str_Of_Dim_Symbols
346 (Dims
: Dimension_Type
;
347 System
: System_Type
;
348 In_Error_Msg
: Boolean := False) return String_Id
;
349 -- Given a dimension vector and a dimension system, return the proper
350 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
351 -- will be used to issue an error message) then this routine has a special
352 -- handling for the insertion characters * or [ which must be preceded by
353 -- a quote ' to be placed literally into the message.
355 function From_Dim_To_Str_Of_Unit_Symbols
356 (Dims
: Dimension_Type
;
357 System
: System_Type
) return String_Id
;
358 -- Given a dimension vector and a dimension system, return the proper
359 -- string of unit symbols.
361 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean;
362 -- Return True if E is the package entity of System.Dim.Float_IO or
363 -- System.Dim.Integer_IO.
365 function Is_Invalid
(Position
: Dimension_Position
) return Boolean;
366 -- Return True if Pos denotes the invalid position
368 procedure Move_Dimensions
(From
: Node_Id
; To
: Node_Id
);
369 -- Copy dimension vector of From to To and delete dimension vector of From
371 procedure Remove_Dimensions
(N
: Node_Id
);
372 -- Remove the dimension vector of node N
374 procedure Set_Dimensions
(N
: Node_Id
; Val
: Dimension_Type
);
375 -- Associate a dimension vector with a node
377 procedure Set_Symbol
(E
: Entity_Id
; Val
: String_Id
);
378 -- Associate a symbol representation of a dimension vector with a subtype
380 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
;
381 -- Return the string that corresponds to the numeric litteral N as it
382 -- appears in the source.
384 function Symbol_Of
(E
: Entity_Id
) return String_Id
;
385 -- E denotes a subtype with a dimension. Return the symbol representation
386 -- of the dimension vector.
388 function System_Of
(E
: Entity_Id
) return System_Type
;
389 -- E denotes a type, return associated system of the type if it has one
395 function "+" (Right
: Whole
) return Rational
is
397 return Rational
'(Numerator => Right, Denominator => 1);
400 function "+" (Left, Right : Rational) return Rational is
401 R : constant Rational :=
402 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
+
403 Left
.Denominator
* Right
.Numerator
,
404 Denominator
=> Left
.Denominator
* Right
.Denominator
);
413 function "-" (Right
: Rational
) return Rational
is
415 return Rational
'(Numerator => -Right.Numerator,
416 Denominator => Right.Denominator);
419 function "-" (Left, Right : Rational) return Rational is
420 R : constant Rational :=
421 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
-
422 Left
.Denominator
* Right
.Numerator
,
423 Denominator
=> Left
.Denominator
* Right
.Denominator
);
433 function "*" (Left
, Right
: Rational
) return Rational
is
434 R
: constant Rational
:=
435 Rational
'(Numerator => Left.Numerator * Right.Numerator,
436 Denominator => Left.Denominator * Right.Denominator);
445 function "/" (Left, Right : Rational) return Rational is
446 R : constant Rational := abs Right;
447 L : Rational := Left;
450 if Right.Numerator < 0 then
451 L.Numerator := Whole (-Integer (L.Numerator));
454 return Reduce (Rational'(Numerator
=> L
.Numerator
* R
.Denominator
,
455 Denominator
=> L
.Denominator
* R
.Numerator
));
462 function "abs" (Right
: Rational
) return Rational
is
464 return Rational
'(Numerator => abs Right.Numerator,
465 Denominator => Right.Denominator);
468 ------------------------------
469 -- Analyze_Aspect_Dimension --
470 ------------------------------
473 -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
475 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
477 -- DIMENSION_VALUE ::=
479 -- | others => RATIONAL
480 -- | DISCRETE_CHOICE_LIST => RATIONAL
482 -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
484 -- Note that when the dimensioned type is an integer type, then any
485 -- dimension value must be an integer literal.
487 procedure Analyze_Aspect_Dimension
492 Def_Id : constant Entity_Id := Defining_Identifier (N);
494 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
495 -- This array is used when processing ranges or Others_Choice as part of
496 -- the dimension aggregate.
498 Dimensions : Dimension_Type := Null_Dimension;
500 procedure Extract_Power
502 Position : Dimension_Position);
503 -- Given an expression with denotes a rational number, read the number
504 -- and associate it with Position in Dimensions.
506 function Position_In_System
508 System : System_Type) return Dimension_Position;
509 -- Given an identifier which denotes a dimension, return the position of
510 -- that dimension within System.
516 procedure Extract_Power
518 Position : Dimension_Position)
521 Dimensions (Position) := Create_Rational_From (Expr, True);
522 Processed (Position) := True;
524 -- If the dimensioned root type is an integer type, it is not
525 -- particularly useful, and fractional dimensions do not make
526 -- much sense for such types, so previously we used to reject
527 -- dimensions of integer types that were not integer literals.
528 -- However, the manipulation of dimensions does not depend on
529 -- the kind of root type, so we can accept this usage for rare
530 -- cases where dimensions are specified for integer values.
534 ------------------------
535 -- Position_In_System --
536 ------------------------
538 function Position_In_System
540 System : System_Type) return Dimension_Position
542 Dimension_Name : constant Name_Id := Chars (Id);
545 for Position in System.Unit_Names'Range loop
546 if Dimension_Name = System.Unit_Names (Position) then
551 return Invalid_Position;
552 end Position_In_System;
559 Num_Choices : Nat := 0;
560 Num_Dimensions : Nat := 0;
561 Others_Seen : Boolean := False;
564 Symbol : String_Id := No_String;
565 Symbol_Expr : Node_Id;
566 System : System_Type;
570 -- Errors_Count is a count of errors detected by the compiler so far
571 -- just before the extraction of symbol, names and values in the
572 -- aggregate (Step 2).
574 -- At the end of the analysis, there is a check to verify that this
575 -- count equals to Serious_Errors_Detected i.e. no erros have been
576 -- encountered during the process. Otherwise the Dimension_Table is
579 -- Start of processing for Analyze_Aspect_Dimension
582 -- STEP 1: Legality of aspect
584 if Nkind (N) /= N_Subtype_Declaration then
585 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
589 Sub_Ind := Subtype_Indication (N);
590 Typ := Etype (Sub_Ind);
591 System := System_Of (Typ);
593 if Nkind (Sub_Ind) = N_Subtype_Indication then
595 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
599 -- The dimension declarations are useless if the parent type does not
600 -- declare a valid system.
602 if not Exists (System) then
604 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
608 if Nkind (Aggr) /= N_Aggregate then
609 Error_Msg_N ("aggregate expected", Aggr);
613 -- STEP 2: Symbol, Names and values extraction
615 -- Get the number of errors detected by the compiler so far
617 Errors_Count := Serious_Errors_Detected;
619 -- STEP 2a: Symbol extraction
621 -- The first entry in the aggregate may be the symbolic representation
624 -- Positional symbol argument
626 Symbol_Expr := First (Expressions (Aggr));
628 -- Named symbol argument
631 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
634 Symbol_Expr := Empty;
636 -- Component associations present
638 if Present (Component_Associations (Aggr)) then
639 Assoc := First (Component_Associations (Aggr));
640 Choice := First (Choices (Assoc));
642 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
644 -- Symbol component association is present
646 if Chars (Choice) = Name_Symbol then
647 Num_Choices := Num_Choices + 1;
648 Symbol_Expr := Expression (Assoc);
650 -- Verify symbol expression is a string or a character
652 if not Nkind_In (Symbol_Expr, N_Character_Literal,
655 Symbol_Expr := Empty;
657 ("symbol expression must be character or string",
661 -- Special error if no Symbol choice but expression is string
664 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
667 Num_Choices := Num_Choices + 1;
669 ("optional component Symbol expected, found&", Choice);
675 -- STEP 2b: Names and values extraction
677 -- Positional elements
679 Expr := First (Expressions (Aggr));
681 -- Skip the symbol expression when present
683 if Present (Symbol_Expr) and then Num_Choices = 0 then
687 Position := Low_Position_Bound;
688 while Present (Expr) loop
689 if Position > High_Position_Bound then
691 ("type& has more dimensions than system allows", Def_Id);
695 Extract_Power (Expr, Position);
697 Position := Position + 1;
698 Num_Dimensions := Num_Dimensions + 1;
705 Assoc := First (Component_Associations (Aggr));
707 -- Skip the symbol association when present
709 if Num_Choices = 1 then
713 while Present (Assoc) loop
714 Expr := Expression (Assoc);
716 Choice := First (Choices (Assoc));
717 while Present (Choice) loop
719 -- Identifier case: NAME => EXPRESSION
721 if Nkind (Choice) = N_Identifier then
722 Position := Position_In_System (Choice, System);
724 if Is_Invalid (Position) then
725 Error_Msg_N ("dimension name& not part of system", Choice);
727 Extract_Power (Expr, Position);
730 -- Range case: NAME .. NAME => EXPRESSION
732 elsif Nkind (Choice) = N_Range then
734 Low : constant Node_Id := Low_Bound (Choice);
735 High : constant Node_Id := High_Bound (Choice);
736 Low_Pos : Dimension_Position;
737 High_Pos : Dimension_Position;
740 if Nkind (Low) /= N_Identifier then
741 Error_Msg_N ("bound must denote a dimension name", Low);
743 elsif Nkind (High) /= N_Identifier then
744 Error_Msg_N ("bound must denote a dimension name", High);
747 Low_Pos := Position_In_System (Low, System);
748 High_Pos := Position_In_System (High, System);
750 if Is_Invalid (Low_Pos) then
751 Error_Msg_N ("dimension name& not part of system",
754 elsif Is_Invalid (High_Pos) then
755 Error_Msg_N ("dimension name& not part of system",
758 elsif Low_Pos > High_Pos then
759 Error_Msg_N ("expected low to high range", Choice);
762 for Position in Low_Pos .. High_Pos loop
763 Extract_Power (Expr, Position);
769 -- Others case: OTHERS => EXPRESSION
771 elsif Nkind (Choice) = N_Others_Choice then
772 if Present (Next (Choice)) or else Present (Prev (Choice)) then
774 ("OTHERS must appear alone in a choice list", Choice);
776 elsif Present (Next (Assoc)) then
778 ("OTHERS must appear last in an aggregate", Choice);
780 elsif Others_Seen then
781 Error_Msg_N ("multiple OTHERS not allowed", Choice);
784 -- Fill the non-processed dimensions with the default value
785 -- supplied by others.
787 for Position in Processed'Range loop
788 if not Processed (Position) then
789 Extract_Power (Expr, Position);
796 -- All other cases are illegal declarations of dimension names
799 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
802 Num_Choices := Num_Choices + 1;
806 Num_Dimensions := Num_Dimensions + 1;
810 -- STEP 3: Consistency of system and dimensions
812 if Present (First (Expressions (Aggr)))
813 and then (First (Expressions (Aggr)) /= Symbol_Expr
814 or else Present (Next (Symbol_Expr)))
815 and then (Num_Choices > 1
816 or else (Num_Choices = 1 and then not Others_Seen))
819 ("named associations cannot follow positional associations", Aggr);
822 if Num_Dimensions > System.Count then
823 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
825 elsif Num_Dimensions < System.Count and then not Others_Seen then
826 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
829 -- STEP 4: Dimension symbol extraction
831 if Present (Symbol_Expr) then
832 if Nkind (Symbol_Expr) = N_Character_Literal then
834 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
835 Symbol := End_String;
838 Symbol := Strval (Symbol_Expr);
841 if String_Length (Symbol) = 0 then
842 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
846 -- STEP 5: Storage of extracted values
848 -- Check that no errors have been detected during the analysis
850 if Errors_Count = Serious_Errors_Detected then
852 -- Check for useless declaration
854 if Symbol = No_String and then not Exists (Dimensions) then
855 Error_Msg_N ("useless dimension declaration", Aggr);
858 if Symbol /= No_String then
859 Set_Symbol (Def_Id, Symbol);
862 if Exists (Dimensions) then
863 Set_Dimensions (Def_Id, Dimensions);
866 end Analyze_Aspect_Dimension;
868 -------------------------------------
869 -- Analyze_Aspect_Dimension_System --
870 -------------------------------------
872 -- with Dimension_System => (DIMENSION {, DIMENSION});
875 -- [Unit_Name =>] IDENTIFIER,
876 -- [Unit_Symbol =>] SYMBOL,
877 -- [Dim_Symbol =>] SYMBOL)
879 procedure Analyze_Aspect_Dimension_System
884 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
885 -- Determine whether type declaration N denotes a numeric derived type
887 -------------------------------
888 -- Is_Derived_Numeric_Type --
889 -------------------------------
891 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
894 Nkind (N) = N_Full_Type_Declaration
895 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
896 and then Is_Numeric_Type
897 (Entity (Subtype_Indication (Type_Definition (N))));
898 end Is_Derived_Numeric_Type;
905 Dim_Symbol : Node_Id;
906 Dim_Symbols : Symbol_Array := No_Symbols;
907 Dim_System : System_Type := Null_System;
908 Position : Dimension_Position := Invalid_Position;
910 Unit_Names : Name_Array := No_Names;
911 Unit_Symbol : Node_Id;
912 Unit_Symbols : Symbol_Array := No_Symbols;
915 -- Errors_Count is a count of errors detected by the compiler so far
916 -- just before the extraction of names and symbols in the aggregate
919 -- At the end of the analysis, there is a check to verify that this
920 -- count equals Serious_Errors_Detected i.e. no errors have been
921 -- encountered during the process. Otherwise the System_Table is
924 -- Start of processing for Analyze_Aspect_Dimension_System
927 -- STEP 1: Legality of aspect
929 if not Is_Derived_Numeric_Type (N) then
931 ("aspect& must apply to numeric derived type declaration", N, Id);
935 if Nkind (Aggr) /= N_Aggregate then
936 Error_Msg_N ("aggregate expected", Aggr);
940 -- STEP 2: Structural verification of the dimension aggregate
942 if Present (Component_Associations (Aggr)) then
943 Error_Msg_N ("expected positional aggregate", Aggr);
947 -- STEP 3: Name and Symbol extraction
949 Dim_Aggr := First (Expressions (Aggr));
950 Errors_Count := Serious_Errors_Detected;
951 while Present (Dim_Aggr) loop
952 if Position = High_Position_Bound then
953 Error_Msg_N ("too many dimensions in system", Aggr);
957 Position := Position + 1;
959 if Nkind (Dim_Aggr) /= N_Aggregate then
960 Error_Msg_N ("aggregate expected", Dim_Aggr);
963 if Present (Component_Associations (Dim_Aggr))
964 and then Present (Expressions (Dim_Aggr))
967 ("mixed positional/named aggregate not allowed here",
970 -- Verify each dimension aggregate has three arguments
972 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
973 and then List_Length (Expressions (Dim_Aggr)) /= 3
976 ("three components expected in aggregate", Dim_Aggr);
979 -- Named dimension aggregate
981 if Present (Component_Associations (Dim_Aggr)) then
983 -- Check first argument denotes the unit name
985 Assoc := First (Component_Associations (Dim_Aggr));
986 Choice := First (Choices (Assoc));
987 Unit_Name := Expression (Assoc);
989 if Present (Next (Choice))
990 or else Nkind (Choice) /= N_Identifier
992 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
994 elsif Chars (Choice) /= Name_Unit_Name then
995 Error_Msg_N ("expected Unit_Name, found&", Choice);
998 -- Check the second argument denotes the unit symbol
1001 Choice := First (Choices (Assoc));
1002 Unit_Symbol := Expression (Assoc);
1004 if Present (Next (Choice))
1005 or else Nkind (Choice) /= N_Identifier
1007 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1009 elsif Chars (Choice) /= Name_Unit_Symbol then
1010 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1013 -- Check the third argument denotes the dimension symbol
1016 Choice := First (Choices (Assoc));
1017 Dim_Symbol := Expression (Assoc);
1019 if Present (Next (Choice))
1020 or else Nkind (Choice) /= N_Identifier
1022 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1023 elsif Chars (Choice) /= Name_Dim_Symbol then
1024 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1027 -- Positional dimension aggregate
1030 Unit_Name := First (Expressions (Dim_Aggr));
1031 Unit_Symbol := Next (Unit_Name);
1032 Dim_Symbol := Next (Unit_Symbol);
1035 -- Check the first argument for each dimension aggregate is
1038 if Nkind (Unit_Name) = N_Identifier then
1039 Unit_Names (Position) := Chars (Unit_Name);
1041 Error_Msg_N ("expected unit name", Unit_Name);
1044 -- Check the second argument for each dimension aggregate is
1045 -- a string or a character.
1047 if not Nkind_In (Unit_Symbol, N_String_Literal,
1048 N_Character_Literal)
1051 ("expected unit symbol (string or character)",
1057 if Nkind (Unit_Symbol) = N_String_Literal then
1058 Unit_Symbols (Position) := Strval (Unit_Symbol);
1065 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1066 Unit_Symbols (Position) := End_String;
1069 -- Verify that the string is not empty
1071 if String_Length (Unit_Symbols (Position)) = 0 then
1073 ("empty string not allowed here", Unit_Symbol);
1077 -- Check the third argument for each dimension aggregate is
1078 -- a string or a character.
1080 if not Nkind_In (Dim_Symbol, N_String_Literal,
1081 N_Character_Literal)
1084 ("expected dimension symbol (string or character)",
1090 if Nkind (Dim_Symbol) = N_String_Literal then
1091 Dim_Symbols (Position) := Strval (Dim_Symbol);
1098 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1099 Dim_Symbols (Position) := End_String;
1102 -- Verify that the string is not empty
1104 if String_Length (Dim_Symbols (Position)) = 0 then
1105 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1114 -- STEP 4: Storage of extracted values
1116 -- Check that no errors have been detected during the analysis
1118 if Errors_Count = Serious_Errors_Detected then
1119 Dim_System.Type_Decl := N;
1120 Dim_System.Unit_Names := Unit_Names;
1121 Dim_System.Unit_Symbols := Unit_Symbols;
1122 Dim_System.Dim_Symbols := Dim_Symbols;
1123 Dim_System.Count := Position;
1124 System_Table.Append (Dim_System);
1126 end Analyze_Aspect_Dimension_System;
1128 -----------------------
1129 -- Analyze_Dimension --
1130 -----------------------
1132 -- This dispatch routine propagates dimensions for each node
1134 procedure Analyze_Dimension (N : Node_Id) is
1136 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1137 -- dimensions for nodes that don't come from source, except for subtype
1138 -- declarations where the dimensions are inherited from the base type,
1139 -- for explicit dereferences generated when expanding iterators, and
1140 -- for object declarations generated for inlining.
1142 if Ada_Version < Ada_2012 then
1145 -- Inlined bodies have already been checked for dimensionality
1147 elsif In_Inlined_Body then
1150 elsif not Comes_From_Source (N) then
1151 if Nkind_In (N, N_Explicit_Dereference,
1153 N_Object_Declaration,
1154 N_Subtype_Declaration)
1163 when N_Assignment_Statement =>
1164 Analyze_Dimension_Assignment_Statement (N);
1167 Analyze_Dimension_Binary_Op (N);
1169 when N_Case_Expression =>
1170 Analyze_Dimension_Case_Expression (N);
1172 when N_Component_Declaration =>
1173 Analyze_Dimension_Component_Declaration (N);
1175 when N_Extended_Return_Statement =>
1176 Analyze_Dimension_Extended_Return_Statement (N);
1178 when N_Attribute_Reference
1180 | N_Explicit_Dereference
1182 | N_Indexed_Component
1183 | N_Qualified_Expression
1184 | N_Selected_Component
1186 | N_Unchecked_Type_Conversion
1188 Analyze_Dimension_Has_Etype (N);
1190 -- In the presence of a repaired syntax error, an identifier may be
1191 -- introduced without a usable type.
1193 when N_Identifier =>
1194 if Present (Etype (N)) then
1195 Analyze_Dimension_Has_Etype (N);
1198 when N_If_Expression =>
1199 Analyze_Dimension_If_Expression (N);
1201 when N_Number_Declaration =>
1202 Analyze_Dimension_Number_Declaration (N);
1204 when N_Object_Declaration =>
1205 Analyze_Dimension_Object_Declaration (N);
1207 when N_Object_Renaming_Declaration =>
1208 Analyze_Dimension_Object_Renaming_Declaration (N);
1210 when N_Simple_Return_Statement =>
1211 if not Comes_From_Extended_Return_Statement (N) then
1212 Analyze_Dimension_Simple_Return_Statement (N);
1215 when N_Subtype_Declaration =>
1216 Analyze_Dimension_Subtype_Declaration (N);
1218 when N_Type_Conversion =>
1219 Analyze_Dimension_Type_Conversion (N);
1222 Analyze_Dimension_Unary_Op (N);
1227 end Analyze_Dimension;
1229 ---------------------------------------
1230 -- Analyze_Dimension_Array_Aggregate --
1231 ---------------------------------------
1233 procedure Analyze_Dimension_Array_Aggregate
1235 Comp_Typ : Entity_Id)
1237 Comp_Ass : constant List_Id := Component_Associations (N);
1238 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1239 Exps : constant List_Id := Expressions (N);
1242 Dims_Of_Expr : Dimension_Type;
1245 Error_Detected : Boolean := False;
1246 -- This flag is used in order to indicate if an error has been detected
1247 -- so far by the compiler in this routine.
1250 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1251 -- base type is not a dimensioned type.
1253 -- Inlined bodies have already been checked for dimensionality.
1255 -- Note that here the original node must come from source since the
1256 -- original array aggregate may not have been entirely decorated.
1258 if Ada_Version < Ada_2012
1259 or else In_Inlined_Body
1260 or else not Comes_From_Source (Original_Node (N))
1261 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1266 -- Check whether there is any positional component association
1268 if Is_Empty_List (Exps) then
1269 Comp := First (Comp_Ass);
1271 Comp := First (Exps);
1274 while Present (Comp) loop
1276 -- Get the expression from the component
1278 if Nkind (Comp) = N_Component_Association then
1279 Expr := Expression (Comp);
1284 -- Issue an error if the dimensions of the component type and the
1285 -- dimensions of the component mismatch.
1287 -- Note that we must ensure the expression has been fully analyzed
1288 -- since it may not be decorated at this point. We also don't want to
1289 -- issue the same error message multiple times on the same expression
1290 -- (may happen when an aggregate is converted into a positional
1291 -- aggregate). We also must verify that this is a scalar component,
1292 -- and not a subaggregate of a multidimensional aggregate.
1293 -- The expression may be an identifier that has been copied several
1294 -- times during expansion, its dimensions are those of its type.
1296 if Is_Entity_Name (Expr) then
1297 Dims_Of_Expr := Dimensions_Of (Etype (Expr));
1299 Dims_Of_Expr := Dimensions_Of (Expr);
1302 if Comes_From_Source (Original_Node (Expr))
1303 and then Present (Etype (Expr))
1304 and then Is_Numeric_Type (Etype (Expr))
1305 and then Dims_Of_Expr /= Dims_Of_Comp_Typ
1306 and then Sloc (Comp) /= Sloc (Prev (Comp))
1308 -- Check if an error has already been encountered so far
1310 if not Error_Detected then
1311 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1312 Error_Detected := True;
1316 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1317 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1320 -- Look at the named components right after the positional components
1322 if not Present (Next (Comp))
1323 and then List_Containing (Comp) = Exps
1325 Comp := First (Comp_Ass);
1330 end Analyze_Dimension_Array_Aggregate;
1332 --------------------------------------------
1333 -- Analyze_Dimension_Assignment_Statement --
1334 --------------------------------------------
1336 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1337 Lhs : constant Node_Id := Name (N);
1338 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1339 Rhs : constant Node_Id := Expression (N);
1340 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1342 procedure Error_Dim_Msg_For_Assignment_Statement
1346 -- Error using Error_Msg_N at node N. Output the dimensions of left
1347 -- and right hand sides.
1349 --------------------------------------------
1350 -- Error_Dim_Msg_For_Assignment_Statement --
1351 --------------------------------------------
1353 procedure Error_Dim_Msg_For_Assignment_Statement
1359 Error_Msg_N ("dimensions mismatch in assignment", N);
1360 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1361 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1362 end Error_Dim_Msg_For_Assignment_Statement;
1364 -- Start of processing for Analyze_Dimension_Assignment
1367 if Dims_Of_Lhs /= Dims_Of_Rhs then
1368 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1370 end Analyze_Dimension_Assignment_Statement;
1372 ---------------------------------
1373 -- Analyze_Dimension_Binary_Op --
1374 ---------------------------------
1376 -- Check and propagate the dimensions for binary operators
1377 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1379 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1380 N_Kind : constant Node_Kind := Nkind (N);
1382 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1383 -- If the operand is a numeric literal that comes from a declared
1384 -- constant, use the dimensions of the constant which were computed
1385 -- from the expression of the constant declaration. Otherwise the
1386 -- dimensions are those of the operand, or the type of the operand.
1387 -- This takes care of node rewritings from validity checks, where the
1388 -- dimensions of the operand itself may not be preserved, while the
1389 -- type comes from context and must have dimension information.
1391 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1392 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1393 -- dimensions of both operands.
1395 ---------------------------
1396 -- Dimensions_Of_Operand --
1397 ---------------------------
1399 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1400 Dims : constant Dimension_Type := Dimensions_Of (N);
1403 if Exists (Dims) then
1406 elsif Is_Entity_Name (N) then
1407 return Dimensions_Of (Etype (Entity (N)));
1409 elsif Nkind (N) = N_Real_Literal then
1411 if Present (Original_Entity (N)) then
1412 return Dimensions_Of (Original_Entity (N));
1415 return Dimensions_Of (Etype (N));
1418 -- Otherwise return the default dimensions
1423 end Dimensions_Of_Operand;
1425 ---------------------------------
1426 -- Error_Dim_Msg_For_Binary_Op --
1427 ---------------------------------
1429 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1432 ("both operands for operation& must have same dimensions",
1434 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1435 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1436 end Error_Dim_Msg_For_Binary_Op;
1438 -- Start of processing for Analyze_Dimension_Binary_Op
1441 -- If the node is already analyzed, do not examine the operands. At the
1442 -- end of the analysis their dimensions have been removed, and the node
1443 -- itself may have been rewritten.
1445 if Analyzed (N) then
1449 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1450 or else N_Kind in N_Multiplying_Operator
1451 or else N_Kind in N_Op_Compare
1454 L : constant Node_Id := Left_Opnd (N);
1455 Dims_Of_L : constant Dimension_Type :=
1456 Dimensions_Of_Operand (L);
1457 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1458 R : constant Node_Id := Right_Opnd (N);
1459 Dims_Of_R : constant Dimension_Type :=
1460 Dimensions_Of_Operand (R);
1461 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1462 Dims_Of_N : Dimension_Type := Null_Dimension;
1465 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1467 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1469 -- Check both operands have same dimension
1471 if Dims_Of_L /= Dims_Of_R then
1472 Error_Dim_Msg_For_Binary_Op (N, L, R);
1474 -- Check both operands are not dimensionless
1476 if Exists (Dims_Of_L) then
1477 Set_Dimensions (N, Dims_Of_L);
1481 -- N_Op_Multiply or N_Op_Divide case
1483 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1485 -- Check at least one operand is not dimensionless
1487 if L_Has_Dimensions or R_Has_Dimensions then
1489 -- Multiplication case
1491 -- Get both operands dimensions and add them
1493 if N_Kind = N_Op_Multiply then
1494 for Position in Dimension_Type'Range loop
1495 Dims_Of_N (Position) :=
1496 Dims_Of_L (Position) + Dims_Of_R (Position);
1501 -- Get both operands dimensions and subtract them
1504 for Position in Dimension_Type'Range loop
1505 Dims_Of_N (Position) :=
1506 Dims_Of_L (Position) - Dims_Of_R (Position);
1510 if Exists (Dims_Of_N) then
1511 Set_Dimensions (N, Dims_Of_N);
1515 -- Exponentiation case
1517 -- Note: a rational exponent is allowed for dimensioned operand
1519 elsif N_Kind = N_Op_Expon then
1521 -- Check the left operand is not dimensionless. Note that the
1522 -- value of the exponent must be known compile time. Otherwise,
1523 -- the exponentiation evaluation will return an error message.
1525 if L_Has_Dimensions then
1526 if not Compile_Time_Known_Value (R) then
1528 ("exponent of dimensioned operand must be "
1529 & "known at compile time", N);
1533 Exponent_Value : Rational := Zero;
1536 -- Real operand case
1538 if Is_Real_Type (Etype (L)) then
1540 -- Define the exponent as a Rational number
1542 Exponent_Value := Create_Rational_From (R, False);
1544 -- Verify that the exponent cannot be interpreted
1545 -- as a rational, otherwise interpret the exponent
1548 if Exponent_Value = No_Rational then
1550 +Whole (UI_To_Int (Expr_Value (R)));
1553 -- Integer operand case.
1555 -- For integer operand, the exponent cannot be
1556 -- interpreted as a rational.
1559 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1562 for Position in Dimension_Type'Range loop
1563 Dims_Of_N (Position) :=
1564 Dims_Of_L (Position) * Exponent_Value;
1567 if Exists (Dims_Of_N) then
1568 Set_Dimensions (N, Dims_Of_N);
1575 -- For relational operations, only dimension checking is
1576 -- performed (no propagation). If one operand is the result
1577 -- of constant folding the dimensions may have been lost
1578 -- in a tree copy, so assume that preanalysis has verified
1579 -- that dimensions are correct.
1581 elsif N_Kind in N_Op_Compare then
1582 if (L_Has_Dimensions or R_Has_Dimensions)
1583 and then Dims_Of_L /= Dims_Of_R
1585 if Nkind (L) = N_Real_Literal
1586 and then not (Comes_From_Source (L))
1587 and then Expander_Active
1591 elsif Nkind (R) = N_Real_Literal
1592 and then not (Comes_From_Source (R))
1593 and then Expander_Active
1597 -- Numeric literal case. Issue a warning to indicate the
1598 -- literal is treated as if its dimension matches the type
1601 elsif Nkind_In (Original_Node (L), N_Integer_Literal,
1604 Dim_Warning_For_Numeric_Literal (L, Etype (R));
1606 elsif Nkind_In (Original_Node (R), N_Integer_Literal,
1609 Dim_Warning_For_Numeric_Literal (R, Etype (L));
1612 Error_Dim_Msg_For_Binary_Op (N, L, R);
1617 -- If expander is active, remove dimension information from each
1618 -- operand, as only dimensions of result are relevant.
1620 if Expander_Active then
1621 Remove_Dimensions (L);
1622 Remove_Dimensions (R);
1626 end Analyze_Dimension_Binary_Op;
1628 ----------------------------
1629 -- Analyze_Dimension_Call --
1630 ----------------------------
1632 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1633 Actuals : constant List_Id := Parameter_Associations (N);
1635 Dims_Of_Formal : Dimension_Type;
1637 Formal_Typ : Entity_Id;
1639 Error_Detected : Boolean := False;
1640 -- This flag is used in order to indicate if an error has been detected
1641 -- so far by the compiler in this routine.
1644 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1645 -- dimensions for calls in inlined bodies, or calls that don't come
1646 -- from source, or those that may have semantic errors.
1648 if Ada_Version < Ada_2012
1649 or else In_Inlined_Body
1650 or else not Comes_From_Source (N)
1651 or else Error_Posted (N)
1656 -- Check the dimensions of the actuals, if any
1658 if not Is_Empty_List (Actuals) then
1660 -- Special processing for elementary functions
1662 -- For Sqrt call, the resulting dimensions equal to half the
1663 -- dimensions of the actual. For all other elementary calls, this
1664 -- routine check that every actual is dimensionless.
1666 if Nkind (N) = N_Function_Call then
1667 Elementary_Function_Calls : declare
1668 Dims_Of_Call : Dimension_Type;
1669 Ent : Entity_Id := Nam;
1671 function Is_Elementary_Function_Entity
1672 (Sub_Id : Entity_Id) return Boolean;
1673 -- Given Sub_Id, the original subprogram entity, return True
1674 -- if call is to an elementary function (see Ada.Numerics.
1675 -- Generic_Elementary_Functions).
1677 -----------------------------------
1678 -- Is_Elementary_Function_Entity --
1679 -----------------------------------
1681 function Is_Elementary_Function_Entity
1682 (Sub_Id : Entity_Id) return Boolean
1684 Loc : constant Source_Ptr := Sloc (Sub_Id);
1687 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1693 (Cunit_Entity (Get_Source_Unit (Loc)),
1694 Ada_Numerics_Generic_Elementary_Functions);
1695 end Is_Elementary_Function_Entity;
1697 -- Start of processing for Elementary_Function_Calls
1700 -- Get original subprogram entity following the renaming chain
1702 if Present (Alias (Ent)) then
1706 -- Check the call is an Elementary function call
1708 if Is_Elementary_Function_Entity (Ent) then
1710 -- Sqrt function call case
1712 if Chars (Ent) = Name_Sqrt then
1713 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1715 -- Evaluates the resulting dimensions (i.e. half the
1716 -- dimensions of the actual).
1718 if Exists (Dims_Of_Call) then
1719 for Position in Dims_Of_Call'Range loop
1720 Dims_Of_Call (Position) :=
1721 Dims_Of_Call (Position) *
1722 Rational'(Numerator
=> 1, Denominator
=> 2);
1725 Set_Dimensions
(N
, Dims_Of_Call
);
1728 -- All other elementary functions case. Note that every
1729 -- actual here should be dimensionless.
1732 Actual
:= First_Actual
(N
);
1733 while Present
(Actual
) loop
1734 if Exists
(Dimensions_Of
(Actual
)) then
1736 -- Check if error has already been encountered
1738 if not Error_Detected
then
1740 ("dimensions mismatch in call of&",
1742 Error_Detected
:= True;
1746 ("\expected dimension '['], found "
1747 & Dimensions_Msg_Of
(Actual
), Actual
);
1750 Next_Actual
(Actual
);
1754 -- Nothing more to do for elementary functions
1758 end Elementary_Function_Calls
;
1761 -- General case. Check, for each parameter, the dimensions of the
1762 -- actual and its corresponding formal match. Otherwise, complain.
1764 Actual
:= First_Actual
(N
);
1765 Formal
:= First_Formal
(Nam
);
1766 while Present
(Formal
) loop
1768 -- A missing corresponding actual indicates that the analysis of
1769 -- the call was aborted due to a previous error.
1772 Check_Error_Detected
;
1776 Formal_Typ
:= Etype
(Formal
);
1777 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1779 -- If the formal is not dimensionless, check dimensions of formal
1780 -- and actual match. Otherwise, complain.
1782 if Exists
(Dims_Of_Formal
)
1783 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1785 -- Check if an error has already been encountered so far
1787 if not Error_Detected
then
1788 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1789 Error_Detected
:= True;
1793 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1794 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1797 Next_Actual
(Actual
);
1798 Next_Formal
(Formal
);
1802 -- For function calls, propagate the dimensions from the returned type
1804 if Nkind
(N
) = N_Function_Call
then
1805 Analyze_Dimension_Has_Etype
(N
);
1807 end Analyze_Dimension_Call
;
1809 ---------------------------------------
1810 -- Analyze_Dimension_Case_Expression --
1811 ---------------------------------------
1813 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
) is
1814 Frst
: constant Node_Id
:= First
(Alternatives
(N
));
1815 Frst_Expr
: constant Node_Id
:= Expression
(Frst
);
1816 Dims
: constant Dimension_Type
:= Dimensions_Of
(Frst_Expr
);
1822 while Present
(Alt
) loop
1823 if Dimensions_Of
(Expression
(Alt
)) /= Dims
then
1824 Error_Msg_N
("dimension mismatch in case expression", Alt
);
1831 Copy_Dimensions
(Frst_Expr
, N
);
1832 end Analyze_Dimension_Case_Expression
;
1834 ---------------------------------------------
1835 -- Analyze_Dimension_Component_Declaration --
1836 ---------------------------------------------
1838 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1839 Expr
: constant Node_Id
:= Expression
(N
);
1840 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1841 Etyp
: constant Entity_Id
:= Etype
(Id
);
1842 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1843 Dims_Of_Expr
: Dimension_Type
;
1845 procedure Error_Dim_Msg_For_Component_Declaration
1849 -- Error using Error_Msg_N at node N. Output the dimensions of the
1850 -- type Etyp and the expression Expr of N.
1852 ---------------------------------------------
1853 -- Error_Dim_Msg_For_Component_Declaration --
1854 ---------------------------------------------
1856 procedure Error_Dim_Msg_For_Component_Declaration
1861 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1863 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
1864 & Dimensions_Msg_Of
(Expr
), Expr
);
1865 end Error_Dim_Msg_For_Component_Declaration
;
1867 -- Start of processing for Analyze_Dimension_Component_Declaration
1870 -- Expression is present
1872 if Present
(Expr
) then
1873 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1875 -- Check dimensions match
1877 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1879 -- Numeric literal case. Issue a warning if the object type is not
1880 -- dimensionless to indicate the literal is treated as if its
1881 -- dimension matches the type dimension.
1883 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1886 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1888 -- Issue a dimension mismatch error for all other cases
1891 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1895 end Analyze_Dimension_Component_Declaration
;
1897 -------------------------------------------------
1898 -- Analyze_Dimension_Extended_Return_Statement --
1899 -------------------------------------------------
1901 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1902 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1903 Return_Etyp
: constant Entity_Id
:=
1904 Etype
(Return_Applies_To
(Return_Ent
));
1905 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1906 Return_Obj_Decl
: Node_Id
;
1907 Return_Obj_Id
: Entity_Id
;
1908 Return_Obj_Typ
: Entity_Id
;
1910 procedure Error_Dim_Msg_For_Extended_Return_Statement
1912 Return_Etyp
: Entity_Id
;
1913 Return_Obj_Typ
: Entity_Id
);
1914 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1915 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1917 -------------------------------------------------
1918 -- Error_Dim_Msg_For_Extended_Return_Statement --
1919 -------------------------------------------------
1921 procedure Error_Dim_Msg_For_Extended_Return_Statement
1923 Return_Etyp
: Entity_Id
;
1924 Return_Obj_Typ
: Entity_Id
)
1927 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1929 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
1930 & ", found " & Dimensions_Msg_Of
(Return_Obj_Typ
), N
);
1931 end Error_Dim_Msg_For_Extended_Return_Statement
;
1933 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1936 if Present
(Return_Obj_Decls
) then
1937 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1938 while Present
(Return_Obj_Decl
) loop
1939 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1940 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1942 if Is_Return_Object
(Return_Obj_Id
) then
1943 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1945 -- Issue an error message if dimensions mismatch
1947 if Dimensions_Of
(Return_Etyp
) /=
1948 Dimensions_Of
(Return_Obj_Typ
)
1950 Error_Dim_Msg_For_Extended_Return_Statement
1951 (N
, Return_Etyp
, Return_Obj_Typ
);
1957 Next
(Return_Obj_Decl
);
1960 end Analyze_Dimension_Extended_Return_Statement
;
1962 -----------------------------------------------------
1963 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1964 -----------------------------------------------------
1966 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1968 Comp_Id
: Entity_Id
;
1969 Comp_Typ
: Entity_Id
;
1972 Error_Detected
: Boolean := False;
1973 -- This flag is used in order to indicate if an error has been detected
1974 -- so far by the compiler in this routine.
1977 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1978 -- dimensions in inlined bodies, or for aggregates that don't come
1979 -- from source, or if we are within an initialization procedure, whose
1980 -- expressions have been checked at the point of record declaration.
1982 if Ada_Version
< Ada_2012
1983 or else In_Inlined_Body
1984 or else not Comes_From_Source
(N
)
1985 or else Inside_Init_Proc
1990 Comp
:= First
(Component_Associations
(N
));
1991 while Present
(Comp
) loop
1992 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1993 Comp_Typ
:= Etype
(Comp_Id
);
1995 -- Check the component type is either a dimensioned type or a
1996 -- dimensioned subtype.
1998 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1999 Expr
:= Expression
(Comp
);
2001 -- A box-initialized component needs no checking.
2003 if No
(Expr
) and then Box_Present
(Comp
) then
2006 -- Issue an error if the dimensions of the component type and the
2007 -- dimensions of the component mismatch.
2009 elsif Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
2011 -- Check if an error has already been encountered so far
2013 if not Error_Detected
then
2015 -- Extension aggregate case
2017 if Nkind
(N
) = N_Extension_Aggregate
then
2019 ("dimensions mismatch in extension aggregate", N
);
2021 -- Record aggregate case
2025 ("dimensions mismatch in record aggregate", N
);
2028 Error_Detected
:= True;
2032 ("\expected dimension " & Dimensions_Msg_Of
(Comp_Typ
)
2033 & ", found " & Dimensions_Msg_Of
(Expr
), Comp
);
2039 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
2041 -------------------------------
2042 -- Analyze_Dimension_Formals --
2043 -------------------------------
2045 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
2046 Dims_Of_Typ
: Dimension_Type
;
2051 -- Aspect is an Ada 2012 feature. Note that there is no need to check
2052 -- dimensions for sub specs that don't come from source.
2054 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
2058 Formal
:= First
(Formals
);
2059 while Present
(Formal
) loop
2060 Typ
:= Parameter_Type
(Formal
);
2061 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
2063 if Exists
(Dims_Of_Typ
) then
2065 Expr
: constant Node_Id
:= Expression
(Formal
);
2068 -- Issue a warning if Expr is a numeric literal and if its
2069 -- dimensions differ with the dimensions of the formal type.
2072 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
2073 and then Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2076 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
2083 end Analyze_Dimension_Formals
;
2085 ---------------------------------
2086 -- Analyze_Dimension_Has_Etype --
2087 ---------------------------------
2089 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
2090 Etyp
: constant Entity_Id
:= Etype
(N
);
2091 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
2094 -- General case. Propagation of the dimensions from the type
2096 if Exists
(Dims_Of_Etyp
) then
2097 Set_Dimensions
(N
, Dims_Of_Etyp
);
2099 -- Identifier case. Propagate the dimensions from the entity for
2100 -- identifier whose entity is a non-dimensionless constant.
2102 elsif Nkind
(N
) = N_Identifier
then
2103 Analyze_Dimension_Identifier
: declare
2104 Id
: constant Entity_Id
:= Entity
(N
);
2107 -- If Id is missing, abnormal tree, assume previous error
2110 Check_Error_Detected
;
2113 elsif Ekind_In
(Id
, E_Constant
, E_Named_Real
)
2114 and then Exists
(Dimensions_Of
(Id
))
2116 Set_Dimensions
(N
, Dimensions_Of
(Id
));
2118 end Analyze_Dimension_Identifier
;
2120 -- Attribute reference case. Propagate the dimensions from the prefix.
2122 elsif Nkind
(N
) = N_Attribute_Reference
2123 and then Has_Dimension_System
(Base_Type
(Etyp
))
2125 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
2127 -- Check the prefix is not dimensionless
2129 if Exists
(Dims_Of_Etyp
) then
2130 Set_Dimensions
(N
, Dims_Of_Etyp
);
2134 -- Remove dimensions from inner expressions, to prevent dimensions
2135 -- table from growing uselessly.
2138 when N_Attribute_Reference
2139 | N_Indexed_Component
2142 Exprs
: constant List_Id
:= Expressions
(N
);
2146 if Present
(Exprs
) then
2147 Expr
:= First
(Exprs
);
2148 while Present
(Expr
) loop
2149 Remove_Dimensions
(Expr
);
2155 when N_Qualified_Expression
2157 | N_Unchecked_Type_Conversion
2159 Remove_Dimensions
(Expression
(N
));
2161 when N_Selected_Component
=>
2162 Remove_Dimensions
(Selector_Name
(N
));
2167 end Analyze_Dimension_Has_Etype
;
2169 -------------------------------------
2170 -- Analyze_Dimension_If_Expression --
2171 -------------------------------------
2173 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
) is
2174 Then_Expr
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
2175 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2178 if Dimensions_Of
(Then_Expr
) /= Dimensions_Of
(Else_Expr
) then
2179 Error_Msg_N
("dimensions mismatch in conditional expression", N
);
2181 Copy_Dimensions
(Then_Expr
, N
);
2183 end Analyze_Dimension_If_Expression
;
2185 ------------------------------------------
2186 -- Analyze_Dimension_Number_Declaration --
2187 ------------------------------------------
2189 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
) is
2190 Expr
: constant Node_Id
:= Expression
(N
);
2191 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2192 Dim_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2195 if Exists
(Dim_Of_Expr
) then
2196 Set_Dimensions
(Id
, Dim_Of_Expr
);
2197 Set_Etype
(Id
, Etype
(Expr
));
2199 end Analyze_Dimension_Number_Declaration
;
2201 ------------------------------------------
2202 -- Analyze_Dimension_Object_Declaration --
2203 ------------------------------------------
2205 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
2206 Expr
: constant Node_Id
:= Expression
(N
);
2207 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2208 Etyp
: constant Entity_Id
:= Etype
(Id
);
2209 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
2210 Dim_Of_Expr
: Dimension_Type
;
2212 procedure Error_Dim_Msg_For_Object_Declaration
2216 -- Error using Error_Msg_N at node N. Output the dimensions of the
2217 -- type Etyp and of the expression Expr.
2219 ------------------------------------------
2220 -- Error_Dim_Msg_For_Object_Declaration --
2221 ------------------------------------------
2223 procedure Error_Dim_Msg_For_Object_Declaration
2228 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2230 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
2231 & Dimensions_Msg_Of
(Expr
), Expr
);
2232 end Error_Dim_Msg_For_Object_Declaration
;
2234 -- Start of processing for Analyze_Dimension_Object_Declaration
2237 -- Expression is present
2239 if Present
(Expr
) then
2240 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2242 -- Check dimensions match
2244 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2246 -- Numeric literal case. Issue a warning if the object type is
2247 -- not dimensionless to indicate the literal is treated as if
2248 -- its dimension matches the type dimension.
2250 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2253 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2255 -- Case of object is a constant whose type is a dimensioned type
2257 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2259 -- Propagate dimension from expression to object entity
2261 Set_Dimensions
(Id
, Dim_Of_Expr
);
2263 -- Expression may have been constant-folded. If nominal type has
2264 -- dimensions, verify that expression has same type.
2266 elsif Exists
(Dim_Of_Etyp
) and then Etype
(Expr
) = Etyp
then
2269 -- For all other cases, issue an error message
2272 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2276 -- Remove dimensions in expression after checking consistency with
2279 Remove_Dimensions
(Expr
);
2281 end Analyze_Dimension_Object_Declaration
;
2283 ---------------------------------------------------
2284 -- Analyze_Dimension_Object_Renaming_Declaration --
2285 ---------------------------------------------------
2287 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2288 Renamed_Name
: constant Node_Id
:= Name
(N
);
2289 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2291 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2294 Renamed_Name
: Node_Id
);
2295 -- Error using Error_Msg_N at node N. Output the dimensions of
2296 -- Sub_Mark and of Renamed_Name.
2298 ---------------------------------------------------
2299 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2300 ---------------------------------------------------
2302 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2305 Renamed_Name
: Node_Id
) is
2307 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2309 ("\expected dimension " & Dimensions_Msg_Of
(Sub_Mark
) & ", found "
2310 & Dimensions_Msg_Of
(Renamed_Name
), Renamed_Name
);
2311 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2313 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2316 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2317 Error_Dim_Msg_For_Object_Renaming_Declaration
2318 (N
, Sub_Mark
, Renamed_Name
);
2320 end Analyze_Dimension_Object_Renaming_Declaration
;
2322 -----------------------------------------------
2323 -- Analyze_Dimension_Simple_Return_Statement --
2324 -----------------------------------------------
2326 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2327 Expr
: constant Node_Id
:= Expression
(N
);
2328 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2329 Return_Etyp
: constant Entity_Id
:=
2330 Etype
(Return_Applies_To
(Return_Ent
));
2331 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2332 Dimensions_Of
(Return_Etyp
);
2334 procedure Error_Dim_Msg_For_Simple_Return_Statement
2336 Return_Etyp
: Entity_Id
;
2338 -- Error using Error_Msg_N at node N. Output the dimensions of the
2339 -- returned type Return_Etyp and the returned expression Expr of N.
2341 -----------------------------------------------
2342 -- Error_Dim_Msg_For_Simple_Return_Statement --
2343 -----------------------------------------------
2345 procedure Error_Dim_Msg_For_Simple_Return_Statement
2347 Return_Etyp
: Entity_Id
;
2351 Error_Msg_N
("dimensions mismatch in return statement", N
);
2353 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
2354 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2355 end Error_Dim_Msg_For_Simple_Return_Statement
;
2357 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2360 if Dims_Of_Return_Etyp
/= Dimensions_Of
(Expr
) then
2361 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2362 Remove_Dimensions
(Expr
);
2364 end Analyze_Dimension_Simple_Return_Statement
;
2366 -------------------------------------------
2367 -- Analyze_Dimension_Subtype_Declaration --
2368 -------------------------------------------
2370 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2371 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2372 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2373 Dims_Of_Etyp
: Dimension_Type
;
2377 -- No constraint case in subtype declaration
2379 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2380 Etyp
:= Etype
(Subtype_Indication
(N
));
2381 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2383 if Exists
(Dims_Of_Etyp
) then
2385 -- If subtype already has a dimension (from Aspect_Dimension), it
2386 -- cannot inherit different dimensions from its subtype.
2388 if Exists
(Dims_Of_Id
) and then Dims_Of_Etyp
/= Dims_Of_Id
then
2390 ("subtype& already " & Dimensions_Msg_Of
(Id
, True), N
, Id
);
2392 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2393 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2397 -- Constraint present in subtype declaration
2400 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2401 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2403 if Exists
(Dims_Of_Etyp
) then
2404 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2405 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2408 end Analyze_Dimension_Subtype_Declaration
;
2410 ---------------------------------------
2411 -- Analyze_Dimension_Type_Conversion --
2412 ---------------------------------------
2414 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
) is
2415 Expr_Root
: constant Entity_Id
:=
2416 Dimension_System_Root
(Etype
(Expression
(N
)));
2417 Target_Root
: constant Entity_Id
:=
2418 Dimension_System_Root
(Etype
(N
));
2421 -- If the expression has dimensions and the target type has dimensions,
2422 -- the conversion has the dimensions of the expression. Consistency is
2423 -- checked below. Converting to a non-dimensioned type such as Float
2424 -- ignores the dimensions of the expression.
2426 if Exists
(Dimensions_Of
(Expression
(N
)))
2427 and then Present
(Target_Root
)
2429 Set_Dimensions
(N
, Dimensions_Of
(Expression
(N
)));
2431 -- Otherwise the dimensions are those of the target type.
2434 Analyze_Dimension_Has_Etype
(N
);
2437 -- A conversion between types in different dimension systems (e.g. MKS
2438 -- and British units) must respect the dimensions of expression and
2439 -- type, It is up to the user to provide proper conversion factors.
2441 -- Upward conversions to root type of a dimensioned system are legal,
2442 -- and correspond to "view conversions", i.e. preserve the dimensions
2443 -- of the expression; otherwise conversion must be between types with
2444 -- then same dimensions. Conversions to a non-dimensioned type such as
2445 -- Float lose the dimensions of the expression.
2447 if Present
(Expr_Root
)
2448 and then Present
(Target_Root
)
2449 and then Etype
(N
) /= Target_Root
2450 and then Dimensions_Of
(Expression
(N
)) /= Dimensions_Of
(Etype
(N
))
2452 Error_Msg_N
("dimensions mismatch in conversion", N
);
2454 ("\expression " & Dimensions_Msg_Of
(Expression
(N
), True), N
);
2456 ("\target type " & Dimensions_Msg_Of
(Etype
(N
), True), N
);
2458 end Analyze_Dimension_Type_Conversion
;
2460 --------------------------------
2461 -- Analyze_Dimension_Unary_Op --
2462 --------------------------------
2464 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2468 -- Propagate the dimension if the operand is not dimensionless
2475 R
: constant Node_Id
:= Right_Opnd
(N
);
2477 Move_Dimensions
(R
, N
);
2483 end Analyze_Dimension_Unary_Op
;
2485 ---------------------------------
2486 -- Check_Expression_Dimensions --
2487 ---------------------------------
2489 procedure Check_Expression_Dimensions
2494 if Is_Floating_Point_Type
(Etype
(Expr
)) then
2495 Analyze_Dimension
(Expr
);
2497 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Typ
) then
2498 Error_Msg_N
("dimensions mismatch in array aggregate", Expr
);
2500 ("\expected dimension " & Dimensions_Msg_Of
(Typ
)
2501 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2504 end Check_Expression_Dimensions
;
2506 ---------------------
2507 -- Copy_Dimensions --
2508 ---------------------
2510 procedure Copy_Dimensions
(From
: Node_Id
; To
: Node_Id
) is
2511 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2514 -- Ignore if not Ada 2012 or beyond
2516 if Ada_Version
< Ada_2012
then
2519 -- For Ada 2012, Copy the dimension of 'From to 'To'
2521 elsif Exists
(Dims_Of_From
) then
2522 Set_Dimensions
(To
, Dims_Of_From
);
2524 end Copy_Dimensions
;
2526 -----------------------------------
2527 -- Copy_Dimensions_Of_Components --
2528 -----------------------------------
2530 procedure Copy_Dimensions_Of_Components
(Rec
: Entity_Id
) is
2534 C
:= First_Component
(Rec
);
2535 while Present
(C
) loop
2536 if Nkind
(Parent
(C
)) = N_Component_Declaration
then
2538 (Expression
(Parent
(Corresponding_Record_Component
(C
))),
2539 Expression
(Parent
(C
)));
2543 end Copy_Dimensions_Of_Components
;
2545 --------------------------
2546 -- Create_Rational_From --
2547 --------------------------
2549 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2551 -- A rational number is a number that can be expressed as the quotient or
2552 -- fraction a/b of two integers, where b is non-zero positive.
2554 function Create_Rational_From
2556 Complain
: Boolean) return Rational
2558 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2559 Result
: Rational
:= No_Rational
;
2561 function Process_Minus
(N
: Node_Id
) return Rational
;
2562 -- Create a rational from a N_Op_Minus node
2564 function Process_Divide
(N
: Node_Id
) return Rational
;
2565 -- Create a rational from a N_Op_Divide node
2567 function Process_Literal
(N
: Node_Id
) return Rational
;
2568 -- Create a rational from a N_Integer_Literal node
2574 function Process_Minus
(N
: Node_Id
) return Rational
is
2575 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2579 -- Operand is an integer literal
2581 if Nkind
(Right
) = N_Integer_Literal
then
2582 Result
:= -Process_Literal
(Right
);
2584 -- Operand is a divide operator
2586 elsif Nkind
(Right
) = N_Op_Divide
then
2587 Result
:= -Process_Divide
(Right
);
2590 Result
:= No_Rational
;
2593 -- Provide minimal semantic information on dimension expressions,
2594 -- even though they have no run-time existence. This is for use by
2595 -- ASIS tools, in particular pretty-printing. If generating code
2596 -- standard operator resolution will take place.
2599 Set_Entity
(N
, Standard_Op_Minus
);
2600 Set_Etype
(N
, Standard_Integer
);
2606 --------------------
2607 -- Process_Divide --
2608 --------------------
2610 function Process_Divide
(N
: Node_Id
) return Rational
is
2611 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2612 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2613 Left_Rat
: Rational
;
2614 Result
: Rational
:= No_Rational
;
2615 Right_Rat
: Rational
;
2618 -- Both left and right operands are integer literals
2620 if Nkind
(Left
) = N_Integer_Literal
2622 Nkind
(Right
) = N_Integer_Literal
2624 Left_Rat
:= Process_Literal
(Left
);
2625 Right_Rat
:= Process_Literal
(Right
);
2626 Result
:= Left_Rat
/ Right_Rat
;
2629 -- Provide minimal semantic information on dimension expressions,
2630 -- even though they have no run-time existence. This is for use by
2631 -- ASIS tools, in particular pretty-printing. If generating code
2632 -- standard operator resolution will take place.
2635 Set_Entity
(N
, Standard_Op_Divide
);
2636 Set_Etype
(N
, Standard_Integer
);
2642 ---------------------
2643 -- Process_Literal --
2644 ---------------------
2646 function Process_Literal
(N
: Node_Id
) return Rational
is
2648 return +Whole
(UI_To_Int
(Intval
(N
)));
2649 end Process_Literal
;
2651 -- Start of processing for Create_Rational_From
2654 -- Check the expression is either a division of two integers or an
2655 -- integer itself. Note that the check applies to the original node
2656 -- since the node could have already been rewritten.
2658 -- Integer literal case
2660 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2661 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2663 -- Divide operator case
2665 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2666 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2668 -- Minus operator case
2670 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2671 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2674 -- When Expr cannot be interpreted as a rational and Complain is true,
2675 -- generate an error message.
2677 if Complain
and then Result
= No_Rational
then
2678 Error_Msg_N
("rational expected", Expr
);
2682 end Create_Rational_From
;
2688 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2690 return Dimension_Table
.Get
(N
);
2693 -----------------------
2694 -- Dimensions_Msg_Of --
2695 -----------------------
2697 function Dimensions_Msg_Of
2699 Description_Needed
: Boolean := False) return String
2701 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2702 Dimensions_Msg
: Name_Id
;
2703 System
: System_Type
;
2706 -- Initialization of Name_Buffer
2710 -- N is not dimensionless
2712 if Exists
(Dims_Of_N
) then
2713 System
:= System_Of
(Base_Type
(Etype
(N
)));
2715 -- When Description_Needed, add to string "has dimension " before the
2716 -- actual dimension.
2718 if Description_Needed
then
2719 Add_Str_To_Name_Buffer
("has dimension ");
2723 (Global_Name_Buffer
,
2724 From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2726 -- N is dimensionless
2728 -- When Description_Needed, return "is dimensionless"
2730 elsif Description_Needed
then
2731 Add_Str_To_Name_Buffer
("is dimensionless");
2733 -- Otherwise, return "'[']"
2736 Add_Str_To_Name_Buffer
("'[']");
2739 Dimensions_Msg
:= Name_Find
;
2740 return Get_Name_String
(Dimensions_Msg
);
2741 end Dimensions_Msg_Of
;
2743 --------------------------
2744 -- Dimension_Table_Hash --
2745 --------------------------
2747 function Dimension_Table_Hash
2748 (Key
: Node_Id
) return Dimension_Table_Range
2751 return Dimension_Table_Range
(Key
mod 511);
2752 end Dimension_Table_Hash
;
2754 -------------------------------------
2755 -- Dim_Warning_For_Numeric_Literal --
2756 -------------------------------------
2758 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2760 -- Consider the literal zero (integer 0 or real 0.0) to be of any
2763 case Nkind
(Original_Node
(N
)) is
2764 when N_Real_Literal
=>
2765 if Expr_Value_R
(N
) = Ureal_0
then
2769 when N_Integer_Literal
=>
2770 if Expr_Value
(N
) = Uint_0
then
2778 -- Initialize name buffer
2782 Append
(Global_Name_Buffer
, String_From_Numeric_Literal
(N
));
2784 -- Insert a blank between the literal and the symbol
2786 Add_Str_To_Name_Buffer
(" ");
2787 Append
(Global_Name_Buffer
, Symbol_Of
(Typ
));
2789 Error_Msg_Name_1
:= Name_Find
;
2790 Error_Msg_N
("assumed to be%%??", N
);
2791 end Dim_Warning_For_Numeric_Literal
;
2793 ----------------------
2794 -- Dimensions_Match --
2795 ----------------------
2797 function Dimensions_Match
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2800 not Has_Dimension_System
(Base_Type
(T1
))
2801 or else Dimensions_Of
(T1
) = Dimensions_Of
(T2
);
2802 end Dimensions_Match
;
2804 ---------------------------
2805 -- Dimension_System_Root --
2806 ---------------------------
2808 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
is
2812 Root
:= Base_Type
(T
);
2814 if Has_Dimension_System
(Root
) then
2815 return First_Subtype
(Root
); -- for example Dim_Mks
2820 end Dimension_System_Root
;
2822 ----------------------------------------
2823 -- Eval_Op_Expon_For_Dimensioned_Type --
2824 ----------------------------------------
2826 -- Evaluate the expon operator for real dimensioned type.
2828 -- Note that if the exponent is an integer (denominator = 1) the node is
2829 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2831 procedure Eval_Op_Expon_For_Dimensioned_Type
2835 R
: constant Node_Id
:= Right_Opnd
(N
);
2836 R_Value
: Rational
:= No_Rational
;
2839 if Is_Real_Type
(Btyp
) then
2840 R_Value
:= Create_Rational_From
(R
, False);
2843 -- Check that the exponent is not an integer
2845 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2846 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2850 end Eval_Op_Expon_For_Dimensioned_Type
;
2852 ------------------------------------------
2853 -- Eval_Op_Expon_With_Rational_Exponent --
2854 ------------------------------------------
2856 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2857 -- Rational and not only an Integer like for dimensionless operands. For
2858 -- that particular case, the left operand is rewritten as a function call
2859 -- using the function Expon_LLF from s-llflex.ads.
2861 procedure Eval_Op_Expon_With_Rational_Exponent
2863 Exponent_Value
: Rational
)
2865 Loc
: constant Source_Ptr
:= Sloc
(N
);
2866 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2867 L
: constant Node_Id
:= Left_Opnd
(N
);
2868 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2869 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2872 Dim_Power
: Rational
;
2873 List_Of_Dims
: List_Id
;
2874 New_Aspect
: Node_Id
;
2875 New_Aspects
: List_Id
;
2878 New_Subtyp_Decl_For_L
: Node_Id
;
2879 System
: System_Type
;
2882 -- Case when the operand is not dimensionless
2884 if Exists
(Dims_Of_N
) then
2886 -- Get the corresponding System_Type to know the exact number of
2887 -- dimensions in the system.
2889 System
:= System_Of
(Btyp_Of_L
);
2891 -- Generation of a new subtype with the proper dimensions
2893 -- In order to rewrite the operator as a type conversion, a new
2894 -- dimensioned subtype with the resulting dimensions of the
2895 -- exponentiation must be created.
2899 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2900 -- System : constant System_Id :=
2901 -- Get_Dimension_System_Id (Btyp_Of_L);
2902 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2903 -- Dimension_Systems.Table (System).Dimension_Count;
2905 -- subtype T is Btyp_Of_L
2908 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2909 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2911 -- Dims_Of_N (Num_Of_Dims).Numerator /
2912 -- Dims_Of_N (Num_Of_Dims).Denominator);
2914 -- Step 1: Generate the new aggregate for the aspect Dimension
2916 New_Aspects
:= Empty_List
;
2918 List_Of_Dims
:= New_List
;
2919 for Position
in Dims_Of_N
'First .. System
.Count
loop
2920 Dim_Power
:= Dims_Of_N
(Position
);
2921 Append_To
(List_Of_Dims
,
2922 Make_Op_Divide
(Loc
,
2924 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Numerator
)),
2926 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Denominator
))));
2929 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2932 Make_Aspect_Specification
(Loc
,
2933 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2934 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2936 -- Step 3: Make a temporary identifier for the new subtype
2938 New_Id
:= Make_Temporary
(Loc
, 'T');
2939 Set_Is_Internal
(New_Id
);
2941 -- Step 4: Declaration of the new subtype
2943 New_Subtyp_Decl_For_L
:=
2944 Make_Subtype_Declaration
(Loc
,
2945 Defining_Identifier
=> New_Id
,
2946 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2948 Append
(New_Aspect
, New_Aspects
);
2949 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2950 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2952 Analyze
(New_Subtyp_Decl_For_L
);
2954 -- Case where the operand is dimensionless
2957 New_Id
:= Btyp_Of_L
;
2960 -- Replacement of N by New_N
2964 -- Actual_1 := Long_Long_Float (L),
2966 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2967 -- Long_Long_Float (Exponent_Value.Denominator);
2969 -- (T (Expon_LLF (Actual_1, Actual_2)));
2971 -- where T is the subtype declared in step 1
2973 -- The node is rewritten as a type conversion
2975 -- Step 1: Creation of the two parameters of Expon_LLF function call
2978 Make_Type_Conversion
(Loc
,
2979 Subtype_Mark
=> New_Occurrence_Of
(Standard_Long_Long_Float
, Loc
),
2980 Expression
=> Relocate_Node
(L
));
2983 Make_Op_Divide
(Loc
,
2985 Make_Real_Literal
(Loc
,
2986 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2988 Make_Real_Literal
(Loc
,
2989 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2991 -- Step 2: Creation of New_N
2994 Make_Type_Conversion
(Loc
,
2995 Subtype_Mark
=> New_Occurrence_Of
(New_Id
, Loc
),
2997 Make_Function_Call
(Loc
,
2998 Name
=> New_Occurrence_Of
(RTE
(RE_Expon_LLF
), Loc
),
2999 Parameter_Associations
=> New_List
(
3000 Actual_1
, Actual_2
)));
3002 -- Step 3: Rewrite N with the result
3005 Set_Etype
(N
, New_Id
);
3006 Analyze_And_Resolve
(N
, New_Id
);
3007 end Eval_Op_Expon_With_Rational_Exponent
;
3013 function Exists
(Dim
: Dimension_Type
) return Boolean is
3015 return Dim
/= Null_Dimension
;
3018 function Exists
(Str
: String_Id
) return Boolean is
3020 return Str
/= No_String
;
3023 function Exists
(Sys
: System_Type
) return Boolean is
3025 return Sys
/= Null_System
;
3028 ---------------------------------
3029 -- Expand_Put_Call_With_Symbol --
3030 ---------------------------------
3032 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in
3033 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string
3034 -- parameter is rewritten to include the unit symbol (or the dimension
3035 -- symbols if not a defined quantity) in the output of a dimensioned
3036 -- object. If a value is already supplied by the user for the parameter
3037 -- Symbol, it is used as is.
3039 -- Case 1. Item is dimensionless
3041 -- * Put : Item appears without a suffix
3043 -- * Put_Dim_Of : the output is []
3045 -- Obj : Mks_Type := 2.6;
3046 -- Put (Obj, 1, 1, 0);
3047 -- Put_Dim_Of (Obj);
3049 -- The corresponding outputs are:
3053 -- Case 2. Item has a dimension
3055 -- * Put : If the type of Item is a dimensioned subtype whose
3056 -- symbol is not empty, then the symbol appears as a
3057 -- suffix. Otherwise, a new string is created and appears
3058 -- as a suffix of Item. This string results in the
3059 -- successive concatanations between each unit symbol
3060 -- raised by its corresponding dimension power from the
3061 -- dimensions of Item.
3063 -- * Put_Dim_Of : The output is a new string resulting in the successive
3064 -- concatanations between each dimension symbol raised by
3065 -- its corresponding dimension power from the dimensions of
3068 -- subtype Random is Mks_Type
3075 -- Obj : Random := 5.0;
3077 -- Put_Dim_Of (Obj);
3079 -- The corresponding outputs are:
3080 -- $5.0 m**3.cd**(-1)
3083 -- The function Image returns the string identical to that produced by
3084 -- a call to Put whose first parameter is a string.
3086 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
3087 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
3088 Loc
: constant Source_Ptr
:= Sloc
(N
);
3089 Name_Call
: constant Node_Id
:= Name
(N
);
3090 New_Actuals
: constant List_Id
:= New_List
;
3092 Dims_Of_Actual
: Dimension_Type
;
3094 New_Str_Lit
: Node_Id
:= Empty
;
3095 Symbols
: String_Id
;
3097 Is_Put_Dim_Of
: Boolean := False;
3098 -- This flag is used in order to differentiate routines Put and
3099 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
3100 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
3102 function Has_Symbols
return Boolean;
3103 -- Return True if the current Put call already has a parameter
3104 -- association for parameter "Symbols" with the correct string of
3107 function Is_Procedure_Put_Call
return Boolean;
3108 -- Return True if the current call is a call of an instantiation of a
3109 -- procedure Put defined in the package System.Dim.Float_IO and
3110 -- System.Dim.Integer_IO.
3112 function Item_Actual
return Node_Id
;
3113 -- Return the item actual parameter node in the output call
3119 function Has_Symbols
return Boolean is
3121 Actual_Str
: Node_Id
;
3124 -- Look for a symbols parameter association in the list of actuals
3126 Actual
:= First
(Actuals
);
3127 while Present
(Actual
) loop
3129 -- Positional parameter association case when the actual is a
3132 if Nkind
(Actual
) = N_String_Literal
then
3133 Actual_Str
:= Actual
;
3135 -- Named parameter association case when selector name is Symbol
3137 elsif Nkind
(Actual
) = N_Parameter_Association
3138 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
3140 Actual_Str
:= Explicit_Actual_Parameter
(Actual
);
3142 -- Ignore all other cases
3145 Actual_Str
:= Empty
;
3148 if Present
(Actual_Str
) then
3150 -- Return True if the actual comes from source or if the string
3151 -- of symbols doesn't have the default value (i.e. it is ""),
3152 -- in which case it is used as suffix of the generated string.
3154 if Comes_From_Source
(Actual
)
3155 or else String_Length
(Strval
(Actual_Str
)) /= 0
3167 -- At this point, the call has no parameter association. Look to the
3168 -- last actual since the symbols parameter is the last one.
3170 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
3173 ---------------------------
3174 -- Is_Procedure_Put_Call --
3175 ---------------------------
3177 function Is_Procedure_Put_Call
return Boolean is
3182 -- There are three different Put (resp. Put_Dim_Of) routines in each
3183 -- generic dim IO package. Verify the current procedure call is one
3186 if Is_Entity_Name
(Name_Call
) then
3187 Ent
:= Entity
(Name_Call
);
3189 -- Get the original subprogram entity following the renaming chain
3191 if Present
(Alias
(Ent
)) then
3197 -- Check the name of the entity subprogram is Put (resp.
3198 -- Put_Dim_Of) and verify this entity is located in either
3199 -- System.Dim.Float_IO or System.Dim.Integer_IO.
3201 if Loc
> No_Location
3202 and then Is_Dim_IO_Package_Entity
3203 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
3205 if Chars
(Ent
) = Name_Put_Dim_Of
then
3206 Is_Put_Dim_Of
:= True;
3209 elsif Chars
(Ent
) = Name_Put
3210 or else Chars
(Ent
) = Name_Image
3218 end Is_Procedure_Put_Call
;
3224 function Item_Actual
return Node_Id
is
3228 -- Look for the item actual as a parameter association
3230 Actual
:= First
(Actuals
);
3231 while Present
(Actual
) loop
3232 if Nkind
(Actual
) = N_Parameter_Association
3233 and then Chars
(Selector_Name
(Actual
)) = Name_Item
3235 return Explicit_Actual_Parameter
(Actual
);
3241 -- Case where the item has been defined without an association
3243 Actual
:= First
(Actuals
);
3245 -- Depending on the procedure Put, Item actual could be first or
3246 -- second in the list of actuals.
3248 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
3251 return Next
(Actual
);
3255 -- Start of processing for Expand_Put_Call_With_Symbol
3258 if Is_Procedure_Put_Call
and then not Has_Symbols
then
3259 Actual
:= Item_Actual
;
3260 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
3261 Etyp
:= Etype
(Actual
);
3265 if Is_Put_Dim_Of
then
3267 -- Check that the item is not dimensionless
3269 -- Create the new String_Literal with the new String_Id generated
3270 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
3272 if Exists
(Dims_Of_Actual
) then
3274 Make_String_Literal
(Loc
,
3275 From_Dim_To_Str_Of_Dim_Symbols
3276 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
))));
3278 -- If dimensionless, the output is []
3282 Make_String_Literal
(Loc
, "[]");
3288 -- Add the symbol as a suffix of the value if the subtype has a
3289 -- unit symbol or if the parameter is not dimensionless.
3291 if Exists
(Symbol_Of
(Etyp
)) then
3292 Symbols
:= Symbol_Of
(Etyp
);
3294 Symbols
:= From_Dim_To_Str_Of_Unit_Symbols
3295 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
)));
3298 -- Check Symbols exists
3300 if Exists
(Symbols
) then
3303 -- Put a space between the value and the dimension
3305 Store_String_Char
(' ');
3306 Store_String_Chars
(Symbols
);
3307 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
3311 if Present
(New_Str_Lit
) then
3313 -- Insert all actuals in New_Actuals
3315 Actual
:= First
(Actuals
);
3316 while Present
(Actual
) loop
3318 -- Copy every actuals in New_Actuals except the Symbols
3319 -- parameter association.
3321 if Nkind
(Actual
) = N_Parameter_Association
3322 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
3324 Append_To
(New_Actuals
,
3325 Make_Parameter_Association
(Loc
,
3326 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
3327 Explicit_Actual_Parameter
=>
3328 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
3330 elsif Nkind
(Actual
) /= N_Parameter_Association
then
3331 Append_To
(New_Actuals
, New_Copy
(Actual
));
3337 -- Create new Symbols param association and append to New_Actuals
3339 Append_To
(New_Actuals
,
3340 Make_Parameter_Association
(Loc
,
3341 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
3342 Explicit_Actual_Parameter
=> New_Str_Lit
));
3344 -- Rewrite and analyze the procedure call
3346 if Chars
(Name_Call
) = Name_Image
then
3348 Make_Function_Call
(Loc
,
3349 Name
=> New_Copy
(Name_Call
),
3350 Parameter_Associations
=> New_Actuals
));
3351 Analyze_And_Resolve
(N
);
3354 Make_Procedure_Call_Statement
(Loc
,
3355 Name
=> New_Copy
(Name_Call
),
3356 Parameter_Associations
=> New_Actuals
));
3362 end Expand_Put_Call_With_Symbol
;
3364 ------------------------------------
3365 -- From_Dim_To_Str_Of_Dim_Symbols --
3366 ------------------------------------
3368 -- Given a dimension vector and the corresponding dimension system, create
3369 -- a String_Id to output dimension symbols corresponding to the dimensions
3370 -- Dims. If In_Error_Msg is True, there is a special handling for character
3371 -- asterisk * which is an insertion character in error messages.
3373 function From_Dim_To_Str_Of_Dim_Symbols
3374 (Dims
: Dimension_Type
;
3375 System
: System_Type
;
3376 In_Error_Msg
: Boolean := False) return String_Id
3378 Dim_Power
: Rational
;
3379 First_Dim
: Boolean := True;
3381 procedure Store_String_Oexpon
;
3382 -- Store the expon operator symbol "**" in the string. In error
3383 -- messages, asterisk * is a special character and must be quoted
3384 -- to be placed literally into the message.
3386 -------------------------
3387 -- Store_String_Oexpon --
3388 -------------------------
3390 procedure Store_String_Oexpon
is
3392 if In_Error_Msg
then
3393 Store_String_Chars
("'*'*");
3395 Store_String_Chars
("**");
3397 end Store_String_Oexpon
;
3399 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3402 -- Initialization of the new String_Id
3406 -- Store the dimension symbols inside boxes
3408 if In_Error_Msg
then
3409 Store_String_Chars
("'[");
3411 Store_String_Char
('[');
3414 for Position
in Dimension_Type
'Range loop
3415 Dim_Power
:= Dims
(Position
);
3416 if Dim_Power
/= Zero
then
3421 Store_String_Char
('.');
3424 Store_String_Chars
(System
.Dim_Symbols
(Position
));
3426 -- Positive dimension case
3428 if Dim_Power
.Numerator
> 0 then
3432 if Dim_Power
.Denominator
= 1 then
3433 if Dim_Power
.Numerator
/= 1 then
3434 Store_String_Oexpon
;
3435 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3438 -- Rational case when denominator /= 1
3441 Store_String_Oexpon
;
3442 Store_String_Char
('(');
3443 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3444 Store_String_Char
('/');
3445 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3446 Store_String_Char
(')');
3449 -- Negative dimension case
3452 Store_String_Oexpon
;
3453 Store_String_Char
('(');
3454 Store_String_Char
('-');
3455 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3459 if Dim_Power
.Denominator
= 1 then
3460 Store_String_Char
(')');
3462 -- Rational case when denominator /= 1
3465 Store_String_Char
('/');
3466 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3467 Store_String_Char
(')');
3473 if In_Error_Msg
then
3474 Store_String_Chars
("']");
3476 Store_String_Char
(']');
3480 end From_Dim_To_Str_Of_Dim_Symbols
;
3482 -------------------------------------
3483 -- From_Dim_To_Str_Of_Unit_Symbols --
3484 -------------------------------------
3486 -- Given a dimension vector and the corresponding dimension system,
3487 -- create a String_Id to output the unit symbols corresponding to the
3490 function From_Dim_To_Str_Of_Unit_Symbols
3491 (Dims
: Dimension_Type
;
3492 System
: System_Type
) return String_Id
3494 Dim_Power
: Rational
;
3495 First_Dim
: Boolean := True;
3498 -- Return No_String if dimensionless
3500 if not Exists
(Dims
) then
3504 -- Initialization of the new String_Id
3508 for Position
in Dimension_Type
'Range loop
3509 Dim_Power
:= Dims
(Position
);
3511 if Dim_Power
/= Zero
then
3515 Store_String_Char
('.');
3518 Store_String_Chars
(System
.Unit_Symbols
(Position
));
3520 -- Positive dimension case
3522 if Dim_Power
.Numerator
> 0 then
3526 if Dim_Power
.Denominator
= 1 then
3527 if Dim_Power
.Numerator
/= 1 then
3528 Store_String_Chars
("**");
3529 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3532 -- Rational case when denominator /= 1
3535 Store_String_Chars
("**");
3536 Store_String_Char
('(');
3537 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3538 Store_String_Char
('/');
3539 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3540 Store_String_Char
(')');
3543 -- Negative dimension case
3546 Store_String_Chars
("**");
3547 Store_String_Char
('(');
3548 Store_String_Char
('-');
3549 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3553 if Dim_Power
.Denominator
= 1 then
3554 Store_String_Char
(')');
3556 -- Rational case when denominator /= 1
3559 Store_String_Char
('/');
3560 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3561 Store_String_Char
(')');
3568 end From_Dim_To_Str_Of_Unit_Symbols
;
3574 function GCD
(Left
, Right
: Whole
) return Int
is
3594 --------------------------
3595 -- Has_Dimension_System --
3596 --------------------------
3598 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
3600 return Exists
(System_Of
(Typ
));
3601 end Has_Dimension_System
;
3603 ------------------------------
3604 -- Is_Dim_IO_Package_Entity --
3605 ------------------------------
3607 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
3609 -- Check the package entity corresponds to System.Dim.Float_IO or
3610 -- System.Dim.Integer_IO.
3613 Is_RTU
(E
, System_Dim_Float_IO
)
3615 Is_RTU
(E
, System_Dim_Integer_IO
);
3616 end Is_Dim_IO_Package_Entity
;
3618 -------------------------------------
3619 -- Is_Dim_IO_Package_Instantiation --
3620 -------------------------------------
3622 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
3623 Gen_Id
: constant Node_Id
:= Name
(N
);
3626 -- Check that the instantiated package is either System.Dim.Float_IO
3627 -- or System.Dim.Integer_IO.
3630 Is_Entity_Name
(Gen_Id
)
3631 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
3632 end Is_Dim_IO_Package_Instantiation
;
3638 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
3640 return Position
= Invalid_Position
;
3643 ---------------------
3644 -- Move_Dimensions --
3645 ---------------------
3647 procedure Move_Dimensions
(From
, To
: Node_Id
) is
3649 if Ada_Version
< Ada_2012
then
3653 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3655 Copy_Dimensions
(From
, To
);
3656 Remove_Dimensions
(From
);
3657 end Move_Dimensions
;
3659 ---------------------------------------
3660 -- New_Copy_Tree_And_Copy_Dimensions --
3661 ---------------------------------------
3663 function New_Copy_Tree_And_Copy_Dimensions
3665 Map
: Elist_Id
:= No_Elist
;
3666 New_Sloc
: Source_Ptr
:= No_Location
;
3667 New_Scope
: Entity_Id
:= Empty
) return Node_Id
3669 New_Copy
: constant Node_Id
:=
3670 New_Copy_Tree
(Source
, Map
, New_Sloc
, New_Scope
);
3673 -- Move the dimensions of Source to New_Copy
3675 Copy_Dimensions
(Source
, New_Copy
);
3677 end New_Copy_Tree_And_Copy_Dimensions
;
3683 function Reduce
(X
: Rational
) return Rational
is
3685 if X
.Numerator
= 0 then
3690 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
3692 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
3693 Denominator => Whole (Int (X.Denominator) / G));
3697 -----------------------
3698 -- Remove_Dimensions --
3699 -----------------------
3701 procedure Remove_Dimensions (N : Node_Id) is
3702 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3704 if Exists (Dims_Of_N) then
3705 Dimension_Table.Remove (N);
3707 end Remove_Dimensions;
3709 -----------------------------------
3710 -- Remove_Dimension_In_Statement --
3711 -----------------------------------
3713 -- Removal of dimension in statement as part of the Analyze_Statements
3714 -- routine (see package Sem_Ch5).
3716 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3718 if Ada_Version < Ada_2012 then
3722 -- Remove dimension in parameter specifications for accept statement
3724 if Nkind (Stmt) = N_Accept_Statement then
3726 Param : Node_Id := First (Parameter_Specifications (Stmt));
3728 while Present (Param) loop
3729 Remove_Dimensions (Param);
3734 -- Remove dimension of name and expression in assignments
3736 elsif Nkind (Stmt) = N_Assignment_Statement then
3737 Remove_Dimensions (Expression (Stmt));
3738 Remove_Dimensions (Name (Stmt));
3740 end Remove_Dimension_In_Statement;
3742 --------------------
3743 -- Set_Dimensions --
3744 --------------------
3746 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3748 pragma Assert (OK_For_Dimension (Nkind (N)));
3749 pragma Assert (Exists (Val));
3751 Dimension_Table.Set (N, Val);
3758 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3760 Symbol_Table.Set (E, Val);
3763 ---------------------------------
3764 -- String_From_Numeric_Literal --
3765 ---------------------------------
3767 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3768 Loc : constant Source_Ptr := Sloc (N);
3769 Sbuffer : constant Source_Buffer_Ptr :=
3770 Source_Text (Get_Source_File_Index (Loc));
3771 Src_Ptr : Source_Ptr := Loc;
3773 C : Character := Sbuffer (Src_Ptr);
3774 -- Current source program character
3776 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3777 -- Return True if C belongs to a numeric literal
3779 -------------------------------
3780 -- Belong_To_Numeric_Literal --
3781 -------------------------------
3783 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3787 | '_
' | '.' | 'e
' | '#
' | 'A
' | 'B
' | 'C
' | 'D
' | 'E
' | 'F
'
3791 -- Make sure '+' or '-' is part of an exponent.
3795 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3797 return Prev_C = 'e
' or else Prev_C = 'E
';
3800 -- All other character doesn't belong to a numeric literal
3805 end Belong_To_Numeric_Literal;
3807 -- Start of processing for String_From_Numeric_Literal
3811 while Belong_To_Numeric_Literal (C) loop
3812 Store_String_Char (C);
3813 Src_Ptr := Src_Ptr + 1;
3814 C := Sbuffer (Src_Ptr);
3818 end String_From_Numeric_Literal;
3824 function Symbol_Of (E : Entity_Id) return String_Id is
3825 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3827 if Subtype_Symbol /= No_String then
3828 return Subtype_Symbol;
3830 return From_Dim_To_Str_Of_Unit_Symbols
3831 (Dimensions_Of (E), System_Of (Base_Type (E)));
3835 -----------------------
3836 -- Symbol_Table_Hash --
3837 -----------------------
3839 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3841 return Symbol_Table_Range (Key mod 511);
3842 end Symbol_Table_Hash;
3848 function System_Of (E : Entity_Id) return System_Type is
3849 Type_Decl : constant Node_Id := Parent (E);
3852 -- Look for Type_Decl in System_Table
3854 for Dim_Sys in 1 .. System_Table.Last loop
3855 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3856 return System_Table.Table (Dim_Sys);