1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2017, 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)
523 if Is_Integer_Type (Def_Id) then
525 -- Dimension value must be an integer literal
527 if Nkind (Expr) = N_Integer_Literal then
528 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
530 Error_Msg_N ("integer literal expected", Expr);
536 Dimensions (Position) := Create_Rational_From (Expr, True);
539 Processed (Position) := True;
542 ------------------------
543 -- Position_In_System --
544 ------------------------
546 function Position_In_System
548 System : System_Type) return Dimension_Position
550 Dimension_Name : constant Name_Id := Chars (Id);
553 for Position in System.Unit_Names'Range loop
554 if Dimension_Name = System.Unit_Names (Position) then
559 return Invalid_Position;
560 end Position_In_System;
567 Num_Choices : Nat := 0;
568 Num_Dimensions : Nat := 0;
569 Others_Seen : Boolean := False;
572 Symbol : String_Id := No_String;
573 Symbol_Expr : Node_Id;
574 System : System_Type;
578 -- Errors_Count is a count of errors detected by the compiler so far
579 -- just before the extraction of symbol, names and values in the
580 -- aggregate (Step 2).
582 -- At the end of the analysis, there is a check to verify that this
583 -- count equals to Serious_Errors_Detected i.e. no erros have been
584 -- encountered during the process. Otherwise the Dimension_Table is
587 -- Start of processing for Analyze_Aspect_Dimension
590 -- STEP 1: Legality of aspect
592 if Nkind (N) /= N_Subtype_Declaration then
593 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
597 Sub_Ind := Subtype_Indication (N);
598 Typ := Etype (Sub_Ind);
599 System := System_Of (Typ);
601 if Nkind (Sub_Ind) = N_Subtype_Indication then
603 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
607 -- The dimension declarations are useless if the parent type does not
608 -- declare a valid system.
610 if not Exists (System) then
612 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
616 if Nkind (Aggr) /= N_Aggregate then
617 Error_Msg_N ("aggregate expected", Aggr);
621 -- STEP 2: Symbol, Names and values extraction
623 -- Get the number of errors detected by the compiler so far
625 Errors_Count := Serious_Errors_Detected;
627 -- STEP 2a: Symbol extraction
629 -- The first entry in the aggregate may be the symbolic representation
632 -- Positional symbol argument
634 Symbol_Expr := First (Expressions (Aggr));
636 -- Named symbol argument
639 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
642 Symbol_Expr := Empty;
644 -- Component associations present
646 if Present (Component_Associations (Aggr)) then
647 Assoc := First (Component_Associations (Aggr));
648 Choice := First (Choices (Assoc));
650 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
652 -- Symbol component association is present
654 if Chars (Choice) = Name_Symbol then
655 Num_Choices := Num_Choices + 1;
656 Symbol_Expr := Expression (Assoc);
658 -- Verify symbol expression is a string or a character
660 if not Nkind_In (Symbol_Expr, N_Character_Literal,
663 Symbol_Expr := Empty;
665 ("symbol expression must be character or string",
669 -- Special error if no Symbol choice but expression is string
672 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
675 Num_Choices := Num_Choices + 1;
677 ("optional component Symbol expected, found&", Choice);
683 -- STEP 2b: Names and values extraction
685 -- Positional elements
687 Expr := First (Expressions (Aggr));
689 -- Skip the symbol expression when present
691 if Present (Symbol_Expr) and then Num_Choices = 0 then
695 Position := Low_Position_Bound;
696 while Present (Expr) loop
697 if Position > High_Position_Bound then
699 ("type& has more dimensions than system allows", Def_Id);
703 Extract_Power (Expr, Position);
705 Position := Position + 1;
706 Num_Dimensions := Num_Dimensions + 1;
713 Assoc := First (Component_Associations (Aggr));
715 -- Skip the symbol association when present
717 if Num_Choices = 1 then
721 while Present (Assoc) loop
722 Expr := Expression (Assoc);
724 Choice := First (Choices (Assoc));
725 while Present (Choice) loop
727 -- Identifier case: NAME => EXPRESSION
729 if Nkind (Choice) = N_Identifier then
730 Position := Position_In_System (Choice, System);
732 if Is_Invalid (Position) then
733 Error_Msg_N ("dimension name& not part of system", Choice);
735 Extract_Power (Expr, Position);
738 -- Range case: NAME .. NAME => EXPRESSION
740 elsif Nkind (Choice) = N_Range then
742 Low : constant Node_Id := Low_Bound (Choice);
743 High : constant Node_Id := High_Bound (Choice);
744 Low_Pos : Dimension_Position;
745 High_Pos : Dimension_Position;
748 if Nkind (Low) /= N_Identifier then
749 Error_Msg_N ("bound must denote a dimension name", Low);
751 elsif Nkind (High) /= N_Identifier then
752 Error_Msg_N ("bound must denote a dimension name", High);
755 Low_Pos := Position_In_System (Low, System);
756 High_Pos := Position_In_System (High, System);
758 if Is_Invalid (Low_Pos) then
759 Error_Msg_N ("dimension name& not part of system",
762 elsif Is_Invalid (High_Pos) then
763 Error_Msg_N ("dimension name& not part of system",
766 elsif Low_Pos > High_Pos then
767 Error_Msg_N ("expected low to high range", Choice);
770 for Position in Low_Pos .. High_Pos loop
771 Extract_Power (Expr, Position);
777 -- Others case: OTHERS => EXPRESSION
779 elsif Nkind (Choice) = N_Others_Choice then
780 if Present (Next (Choice)) or else Present (Prev (Choice)) then
782 ("OTHERS must appear alone in a choice list", Choice);
784 elsif Present (Next (Assoc)) then
786 ("OTHERS must appear last in an aggregate", Choice);
788 elsif Others_Seen then
789 Error_Msg_N ("multiple OTHERS not allowed", Choice);
792 -- Fill the non-processed dimensions with the default value
793 -- supplied by others.
795 for Position in Processed'Range loop
796 if not Processed (Position) then
797 Extract_Power (Expr, Position);
804 -- All other cases are illegal declarations of dimension names
807 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
810 Num_Choices := Num_Choices + 1;
814 Num_Dimensions := Num_Dimensions + 1;
818 -- STEP 3: Consistency of system and dimensions
820 if Present (First (Expressions (Aggr)))
821 and then (First (Expressions (Aggr)) /= Symbol_Expr
822 or else Present (Next (Symbol_Expr)))
823 and then (Num_Choices > 1
824 or else (Num_Choices = 1 and then not Others_Seen))
827 ("named associations cannot follow positional associations", Aggr);
830 if Num_Dimensions > System.Count then
831 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
833 elsif Num_Dimensions < System.Count and then not Others_Seen then
834 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
837 -- STEP 4: Dimension symbol extraction
839 if Present (Symbol_Expr) then
840 if Nkind (Symbol_Expr) = N_Character_Literal then
842 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
843 Symbol := End_String;
846 Symbol := Strval (Symbol_Expr);
849 if String_Length (Symbol) = 0 then
850 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
854 -- STEP 5: Storage of extracted values
856 -- Check that no errors have been detected during the analysis
858 if Errors_Count = Serious_Errors_Detected then
860 -- Check for useless declaration
862 if Symbol = No_String and then not Exists (Dimensions) then
863 Error_Msg_N ("useless dimension declaration", Aggr);
866 if Symbol /= No_String then
867 Set_Symbol (Def_Id, Symbol);
870 if Exists (Dimensions) then
871 Set_Dimensions (Def_Id, Dimensions);
874 end Analyze_Aspect_Dimension;
876 -------------------------------------
877 -- Analyze_Aspect_Dimension_System --
878 -------------------------------------
880 -- with Dimension_System => (DIMENSION {, DIMENSION});
883 -- [Unit_Name =>] IDENTIFIER,
884 -- [Unit_Symbol =>] SYMBOL,
885 -- [Dim_Symbol =>] SYMBOL)
887 procedure Analyze_Aspect_Dimension_System
892 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
893 -- Determine whether type declaration N denotes a numeric derived type
895 -------------------------------
896 -- Is_Derived_Numeric_Type --
897 -------------------------------
899 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
902 Nkind (N) = N_Full_Type_Declaration
903 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
904 and then Is_Numeric_Type
905 (Entity (Subtype_Indication (Type_Definition (N))));
906 end Is_Derived_Numeric_Type;
913 Dim_Symbol : Node_Id;
914 Dim_Symbols : Symbol_Array := No_Symbols;
915 Dim_System : System_Type := Null_System;
918 Unit_Names : Name_Array := No_Names;
919 Unit_Symbol : Node_Id;
920 Unit_Symbols : Symbol_Array := No_Symbols;
923 -- Errors_Count is a count of errors detected by the compiler so far
924 -- just before the extraction of names and symbols in the aggregate
927 -- At the end of the analysis, there is a check to verify that this
928 -- count equals Serious_Errors_Detected i.e. no errors have been
929 -- encountered during the process. Otherwise the System_Table is
932 -- Start of processing for Analyze_Aspect_Dimension_System
935 -- STEP 1: Legality of aspect
937 if not Is_Derived_Numeric_Type (N) then
939 ("aspect& must apply to numeric derived type declaration", N, Id);
943 if Nkind (Aggr) /= N_Aggregate then
944 Error_Msg_N ("aggregate expected", Aggr);
948 -- STEP 2: Structural verification of the dimension aggregate
950 if Present (Component_Associations (Aggr)) then
951 Error_Msg_N ("expected positional aggregate", Aggr);
955 -- STEP 3: Name and Symbol extraction
957 Dim_Aggr := First (Expressions (Aggr));
958 Errors_Count := Serious_Errors_Detected;
959 while Present (Dim_Aggr) loop
960 Position := Position + 1;
962 if Position > High_Position_Bound then
963 Error_Msg_N ("too many dimensions in system", Aggr);
967 if Nkind (Dim_Aggr) /= N_Aggregate then
968 Error_Msg_N ("aggregate expected", Dim_Aggr);
971 if Present (Component_Associations (Dim_Aggr))
972 and then Present (Expressions (Dim_Aggr))
975 ("mixed positional/named aggregate not allowed here",
978 -- Verify each dimension aggregate has three arguments
980 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
981 and then List_Length (Expressions (Dim_Aggr)) /= 3
984 ("three components expected in aggregate", Dim_Aggr);
987 -- Named dimension aggregate
989 if Present (Component_Associations (Dim_Aggr)) then
991 -- Check first argument denotes the unit name
993 Assoc := First (Component_Associations (Dim_Aggr));
994 Choice := First (Choices (Assoc));
995 Unit_Name := Expression (Assoc);
997 if Present (Next (Choice))
998 or else Nkind (Choice) /= N_Identifier
1000 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1002 elsif Chars (Choice) /= Name_Unit_Name then
1003 Error_Msg_N ("expected Unit_Name, found&", Choice);
1006 -- Check the second argument denotes the unit symbol
1009 Choice := First (Choices (Assoc));
1010 Unit_Symbol := Expression (Assoc);
1012 if Present (Next (Choice))
1013 or else Nkind (Choice) /= N_Identifier
1015 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1017 elsif Chars (Choice) /= Name_Unit_Symbol then
1018 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1021 -- Check the third argument denotes the dimension symbol
1024 Choice := First (Choices (Assoc));
1025 Dim_Symbol := Expression (Assoc);
1027 if Present (Next (Choice))
1028 or else Nkind (Choice) /= N_Identifier
1030 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1031 elsif Chars (Choice) /= Name_Dim_Symbol then
1032 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1035 -- Positional dimension aggregate
1038 Unit_Name := First (Expressions (Dim_Aggr));
1039 Unit_Symbol := Next (Unit_Name);
1040 Dim_Symbol := Next (Unit_Symbol);
1043 -- Check the first argument for each dimension aggregate is
1046 if Nkind (Unit_Name) = N_Identifier then
1047 Unit_Names (Position) := Chars (Unit_Name);
1049 Error_Msg_N ("expected unit name", Unit_Name);
1052 -- Check the second argument for each dimension aggregate is
1053 -- a string or a character.
1055 if not Nkind_In (Unit_Symbol, N_String_Literal,
1056 N_Character_Literal)
1059 ("expected unit symbol (string or character)",
1065 if Nkind (Unit_Symbol) = N_String_Literal then
1066 Unit_Symbols (Position) := Strval (Unit_Symbol);
1073 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1074 Unit_Symbols (Position) := End_String;
1077 -- Verify that the string is not empty
1079 if String_Length (Unit_Symbols (Position)) = 0 then
1081 ("empty string not allowed here", Unit_Symbol);
1085 -- Check the third argument for each dimension aggregate is
1086 -- a string or a character.
1088 if not Nkind_In (Dim_Symbol, N_String_Literal,
1089 N_Character_Literal)
1092 ("expected dimension symbol (string or character)",
1098 if Nkind (Dim_Symbol) = N_String_Literal then
1099 Dim_Symbols (Position) := Strval (Dim_Symbol);
1106 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1107 Dim_Symbols (Position) := End_String;
1110 -- Verify that the string is not empty
1112 if String_Length (Dim_Symbols (Position)) = 0 then
1113 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1122 -- STEP 4: Storage of extracted values
1124 -- Check that no errors have been detected during the analysis
1126 if Errors_Count = Serious_Errors_Detected then
1127 Dim_System.Type_Decl := N;
1128 Dim_System.Unit_Names := Unit_Names;
1129 Dim_System.Unit_Symbols := Unit_Symbols;
1130 Dim_System.Dim_Symbols := Dim_Symbols;
1131 Dim_System.Count := Position;
1132 System_Table.Append (Dim_System);
1134 end Analyze_Aspect_Dimension_System;
1136 -----------------------
1137 -- Analyze_Dimension --
1138 -----------------------
1140 -- This dispatch routine propagates dimensions for each node
1142 procedure Analyze_Dimension (N : Node_Id) is
1144 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1145 -- dimensions for nodes that don't come from source, except for subtype
1146 -- declarations where the dimensions are inherited from the base type,
1147 -- for explicit dereferences generated when expanding iterators, and
1148 -- for object declarations generated for inlining.
1150 if Ada_Version < Ada_2012 then
1153 elsif not Comes_From_Source (N) then
1154 if Nkind_In (N, N_Explicit_Dereference,
1156 N_Object_Declaration,
1157 N_Subtype_Declaration)
1166 when N_Assignment_Statement =>
1167 Analyze_Dimension_Assignment_Statement (N);
1170 Analyze_Dimension_Binary_Op (N);
1172 when N_Case_Expression =>
1173 Analyze_Dimension_Case_Expression (N);
1175 when N_Component_Declaration =>
1176 Analyze_Dimension_Component_Declaration (N);
1178 when N_Extended_Return_Statement =>
1179 Analyze_Dimension_Extended_Return_Statement (N);
1181 when N_Attribute_Reference
1183 | N_Explicit_Dereference
1185 | N_Indexed_Component
1186 | N_Qualified_Expression
1187 | N_Selected_Component
1189 | N_Unchecked_Type_Conversion
1191 Analyze_Dimension_Has_Etype (N);
1193 -- In the presence of a repaired syntax error, an identifier may be
1194 -- introduced without a usable type.
1196 when N_Identifier =>
1197 if Present (Etype (N)) then
1198 Analyze_Dimension_Has_Etype (N);
1201 when N_If_Expression =>
1202 Analyze_Dimension_If_Expression (N);
1204 when N_Number_Declaration =>
1205 Analyze_Dimension_Number_Declaration (N);
1207 when N_Object_Declaration =>
1208 Analyze_Dimension_Object_Declaration (N);
1210 when N_Object_Renaming_Declaration =>
1211 Analyze_Dimension_Object_Renaming_Declaration (N);
1213 when N_Simple_Return_Statement =>
1214 if not Comes_From_Extended_Return_Statement (N) then
1215 Analyze_Dimension_Simple_Return_Statement (N);
1218 when N_Subtype_Declaration =>
1219 Analyze_Dimension_Subtype_Declaration (N);
1221 when N_Type_Conversion =>
1222 Analyze_Dimension_Type_Conversion (N);
1225 Analyze_Dimension_Unary_Op (N);
1230 end Analyze_Dimension;
1232 ---------------------------------------
1233 -- Analyze_Dimension_Array_Aggregate --
1234 ---------------------------------------
1236 procedure Analyze_Dimension_Array_Aggregate
1238 Comp_Typ : Entity_Id)
1240 Comp_Ass : constant List_Id := Component_Associations (N);
1241 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1242 Exps : constant List_Id := Expressions (N);
1247 Error_Detected : Boolean := False;
1248 -- This flag is used in order to indicate if an error has been detected
1249 -- so far by the compiler in this routine.
1252 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1253 -- base type is not a dimensioned type.
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 not Comes_From_Source (Original_Node (N))
1260 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1265 -- Check whether there is any positional component association
1267 if Is_Empty_List (Exps) then
1268 Comp := First (Comp_Ass);
1270 Comp := First (Exps);
1273 while Present (Comp) loop
1275 -- Get the expression from the component
1277 if Nkind (Comp) = N_Component_Association then
1278 Expr := Expression (Comp);
1283 -- Issue an error if the dimensions of the component type and the
1284 -- dimensions of the component mismatch.
1286 -- Note that we must ensure the expression has been fully analyzed
1287 -- since it may not be decorated at this point. We also don't want to
1288 -- issue the same error message multiple times on the same expression
1289 -- (may happen when an aggregate is converted into a positional
1290 -- aggregate). We also must verify that this is a scalar component,
1291 -- and not a subaggregate of a multidimensional aggregate.
1293 if Comes_From_Source (Original_Node (Expr))
1294 and then Present (Etype (Expr))
1295 and then Is_Numeric_Type (Etype (Expr))
1296 and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1297 and then Sloc (Comp) /= Sloc (Prev (Comp))
1299 -- Check if an error has already been encountered so far
1301 if not Error_Detected then
1302 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1303 Error_Detected := True;
1307 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1308 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1311 -- Look at the named components right after the positional components
1313 if not Present (Next (Comp))
1314 and then List_Containing (Comp) = Exps
1316 Comp := First (Comp_Ass);
1321 end Analyze_Dimension_Array_Aggregate;
1323 --------------------------------------------
1324 -- Analyze_Dimension_Assignment_Statement --
1325 --------------------------------------------
1327 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1328 Lhs : constant Node_Id := Name (N);
1329 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1330 Rhs : constant Node_Id := Expression (N);
1331 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1333 procedure Error_Dim_Msg_For_Assignment_Statement
1337 -- Error using Error_Msg_N at node N. Output the dimensions of left
1338 -- and right hand sides.
1340 --------------------------------------------
1341 -- Error_Dim_Msg_For_Assignment_Statement --
1342 --------------------------------------------
1344 procedure Error_Dim_Msg_For_Assignment_Statement
1350 Error_Msg_N ("dimensions mismatch in assignment", N);
1351 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1352 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1353 end Error_Dim_Msg_For_Assignment_Statement;
1355 -- Start of processing for Analyze_Dimension_Assignment
1358 if Dims_Of_Lhs /= Dims_Of_Rhs then
1359 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1361 end Analyze_Dimension_Assignment_Statement;
1363 ---------------------------------
1364 -- Analyze_Dimension_Binary_Op --
1365 ---------------------------------
1367 -- Check and propagate the dimensions for binary operators
1368 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1370 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1371 N_Kind : constant Node_Kind := Nkind (N);
1373 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1374 -- If the operand is a numeric literal that comes from a declared
1375 -- constant, use the dimensions of the constant which were computed
1376 -- from the expression of the constant declaration. Otherwise the
1377 -- dimensions are those of the operand, or the type of the operand.
1378 -- This takes care of node rewritings from validity checks, where the
1379 -- dimensions of the operand itself may not be preserved, while the
1380 -- type comes from context and must have dimension information.
1382 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1383 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1384 -- dimensions of both operands.
1386 ---------------------------
1387 -- Dimensions_Of_Operand --
1388 ---------------------------
1390 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1391 Dims : constant Dimension_Type := Dimensions_Of (N);
1394 if Exists (Dims) then
1397 elsif Is_Entity_Name (N) then
1398 return Dimensions_Of (Etype (Entity (N)));
1400 elsif Nkind (N) = N_Real_Literal then
1402 if Present (Original_Entity (N)) then
1403 return Dimensions_Of (Original_Entity (N));
1406 return Dimensions_Of (Etype (N));
1409 -- Otherwise return the default dimensions
1414 end Dimensions_Of_Operand;
1416 ---------------------------------
1417 -- Error_Dim_Msg_For_Binary_Op --
1418 ---------------------------------
1420 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1423 ("both operands for operation& must have same dimensions",
1425 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1426 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1427 end Error_Dim_Msg_For_Binary_Op;
1429 -- Start of processing for Analyze_Dimension_Binary_Op
1432 -- If the node is already analyzed, do not examine the operands. At the
1433 -- end of the analysis their dimensions have been removed, and the node
1434 -- itself may have been rewritten.
1436 if Analyzed (N) then
1440 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1441 or else N_Kind in N_Multiplying_Operator
1442 or else N_Kind in N_Op_Compare
1445 L : constant Node_Id := Left_Opnd (N);
1446 Dims_Of_L : constant Dimension_Type :=
1447 Dimensions_Of_Operand (L);
1448 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1449 R : constant Node_Id := Right_Opnd (N);
1450 Dims_Of_R : constant Dimension_Type :=
1451 Dimensions_Of_Operand (R);
1452 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1453 Dims_Of_N : Dimension_Type := Null_Dimension;
1456 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1458 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1460 -- Check both operands have same dimension
1462 if Dims_Of_L /= Dims_Of_R then
1463 Error_Dim_Msg_For_Binary_Op (N, L, R);
1465 -- Check both operands are not dimensionless
1467 if Exists (Dims_Of_L) then
1468 Set_Dimensions (N, Dims_Of_L);
1472 -- N_Op_Multiply or N_Op_Divide case
1474 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1476 -- Check at least one operand is not dimensionless
1478 if L_Has_Dimensions or R_Has_Dimensions then
1480 -- Multiplication case
1482 -- Get both operands dimensions and add them
1484 if N_Kind = N_Op_Multiply then
1485 for Position in Dimension_Type'Range loop
1486 Dims_Of_N (Position) :=
1487 Dims_Of_L (Position) + Dims_Of_R (Position);
1492 -- Get both operands dimensions and subtract them
1495 for Position in Dimension_Type'Range loop
1496 Dims_Of_N (Position) :=
1497 Dims_Of_L (Position) - Dims_Of_R (Position);
1501 if Exists (Dims_Of_N) then
1502 Set_Dimensions (N, Dims_Of_N);
1506 -- Exponentiation case
1508 -- Note: a rational exponent is allowed for dimensioned operand
1510 elsif N_Kind = N_Op_Expon then
1512 -- Check the left operand is not dimensionless. Note that the
1513 -- value of the exponent must be known compile time. Otherwise,
1514 -- the exponentiation evaluation will return an error message.
1516 if L_Has_Dimensions then
1517 if not Compile_Time_Known_Value (R) then
1519 ("exponent of dimensioned operand must be "
1520 & "known at compile time", N);
1524 Exponent_Value : Rational := Zero;
1527 -- Real operand case
1529 if Is_Real_Type (Etype (L)) then
1531 -- Define the exponent as a Rational number
1533 Exponent_Value := Create_Rational_From (R, False);
1535 -- Verify that the exponent cannot be interpreted
1536 -- as a rational, otherwise interpret the exponent
1539 if Exponent_Value = No_Rational then
1541 +Whole (UI_To_Int (Expr_Value (R)));
1544 -- Integer operand case.
1546 -- For integer operand, the exponent cannot be
1547 -- interpreted as a rational.
1550 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1553 for Position in Dimension_Type'Range loop
1554 Dims_Of_N (Position) :=
1555 Dims_Of_L (Position) * Exponent_Value;
1558 if Exists (Dims_Of_N) then
1559 Set_Dimensions (N, Dims_Of_N);
1566 -- For relational operations, only dimension checking is
1567 -- performed (no propagation). If one operand is the result
1568 -- of constant folding the dimensions may have been lost
1569 -- in a tree copy, so assume that pre-analysis has verified
1570 -- that dimensions are correct.
1572 elsif N_Kind in N_Op_Compare then
1573 if (L_Has_Dimensions or R_Has_Dimensions)
1574 and then Dims_Of_L /= Dims_Of_R
1576 if Nkind (L) = N_Real_Literal
1577 and then not (Comes_From_Source (L))
1578 and then Expander_Active
1582 elsif Nkind (R) = N_Real_Literal
1583 and then not (Comes_From_Source (R))
1584 and then Expander_Active
1589 Error_Dim_Msg_For_Binary_Op (N, L, R);
1594 -- If expander is active, remove dimension information from each
1595 -- operand, as only dimensions of result are relevant.
1597 if Expander_Active then
1598 Remove_Dimensions (L);
1599 Remove_Dimensions (R);
1603 end Analyze_Dimension_Binary_Op;
1605 ----------------------------
1606 -- Analyze_Dimension_Call --
1607 ----------------------------
1609 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1610 Actuals : constant List_Id := Parameter_Associations (N);
1612 Dims_Of_Formal : Dimension_Type;
1614 Formal_Typ : Entity_Id;
1616 Error_Detected : Boolean := False;
1617 -- This flag is used in order to indicate if an error has been detected
1618 -- so far by the compiler in this routine.
1621 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1622 -- dimensions for calls that don't come from source, or those that may
1623 -- have semantic errors.
1625 if Ada_Version < Ada_2012
1626 or else not Comes_From_Source (N)
1627 or else Error_Posted (N)
1632 -- Check the dimensions of the actuals, if any
1634 if not Is_Empty_List (Actuals) then
1636 -- Special processing for elementary functions
1638 -- For Sqrt call, the resulting dimensions equal to half the
1639 -- dimensions of the actual. For all other elementary calls, this
1640 -- routine check that every actual is dimensionless.
1642 if Nkind (N) = N_Function_Call then
1643 Elementary_Function_Calls : declare
1644 Dims_Of_Call : Dimension_Type;
1645 Ent : Entity_Id := Nam;
1647 function Is_Elementary_Function_Entity
1648 (Sub_Id : Entity_Id) return Boolean;
1649 -- Given Sub_Id, the original subprogram entity, return True
1650 -- if call is to an elementary function (see Ada.Numerics.
1651 -- Generic_Elementary_Functions).
1653 -----------------------------------
1654 -- Is_Elementary_Function_Entity --
1655 -----------------------------------
1657 function Is_Elementary_Function_Entity
1658 (Sub_Id : Entity_Id) return Boolean
1660 Loc : constant Source_Ptr := Sloc (Sub_Id);
1663 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1669 (Cunit_Entity (Get_Source_Unit (Loc)),
1670 Ada_Numerics_Generic_Elementary_Functions);
1671 end Is_Elementary_Function_Entity;
1673 -- Start of processing for Elementary_Function_Calls
1676 -- Get original subprogram entity following the renaming chain
1678 if Present (Alias (Ent)) then
1682 -- Check the call is an Elementary function call
1684 if Is_Elementary_Function_Entity (Ent) then
1686 -- Sqrt function call case
1688 if Chars (Ent) = Name_Sqrt then
1689 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1691 -- Evaluates the resulting dimensions (i.e. half the
1692 -- dimensions of the actual).
1694 if Exists (Dims_Of_Call) then
1695 for Position in Dims_Of_Call'Range loop
1696 Dims_Of_Call (Position) :=
1697 Dims_Of_Call (Position) *
1698 Rational'(Numerator
=> 1, Denominator
=> 2);
1701 Set_Dimensions
(N
, Dims_Of_Call
);
1704 -- All other elementary functions case. Note that every
1705 -- actual here should be dimensionless.
1708 Actual
:= First_Actual
(N
);
1709 while Present
(Actual
) loop
1710 if Exists
(Dimensions_Of
(Actual
)) then
1712 -- Check if error has already been encountered
1714 if not Error_Detected
then
1716 ("dimensions mismatch in call of&",
1718 Error_Detected
:= True;
1722 ("\expected dimension '['], found "
1723 & Dimensions_Msg_Of
(Actual
), Actual
);
1726 Next_Actual
(Actual
);
1730 -- Nothing more to do for elementary functions
1734 end Elementary_Function_Calls
;
1737 -- General case. Check, for each parameter, the dimensions of the
1738 -- actual and its corresponding formal match. Otherwise, complain.
1740 Actual
:= First_Actual
(N
);
1741 Formal
:= First_Formal
(Nam
);
1742 while Present
(Formal
) loop
1744 -- A missing corresponding actual indicates that the analysis of
1745 -- the call was aborted due to a previous error.
1748 Check_Error_Detected
;
1752 Formal_Typ
:= Etype
(Formal
);
1753 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1755 -- If the formal is not dimensionless, check dimensions of formal
1756 -- and actual match. Otherwise, complain.
1758 if Exists
(Dims_Of_Formal
)
1759 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1761 -- Check if an error has already been encountered so far
1763 if not Error_Detected
then
1764 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1765 Error_Detected
:= True;
1769 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1770 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1773 Next_Actual
(Actual
);
1774 Next_Formal
(Formal
);
1778 -- For function calls, propagate the dimensions from the returned type
1780 if Nkind
(N
) = N_Function_Call
then
1781 Analyze_Dimension_Has_Etype
(N
);
1783 end Analyze_Dimension_Call
;
1785 ---------------------------------------
1786 -- Analyze_Dimension_Case_Expression --
1787 ---------------------------------------
1789 procedure Analyze_Dimension_Case_Expression
(N
: Node_Id
) is
1790 Frst
: constant Node_Id
:= First
(Alternatives
(N
));
1791 Frst_Expr
: constant Node_Id
:= Expression
(Frst
);
1792 Dims
: constant Dimension_Type
:= Dimensions_Of
(Frst_Expr
);
1798 while Present
(Alt
) loop
1799 if Dimensions_Of
(Expression
(Alt
)) /= Dims
then
1800 Error_Msg_N
("dimension mismatch in case expression", Alt
);
1807 Copy_Dimensions
(Frst_Expr
, N
);
1808 end Analyze_Dimension_Case_Expression
;
1810 ---------------------------------------------
1811 -- Analyze_Dimension_Component_Declaration --
1812 ---------------------------------------------
1814 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1815 Expr
: constant Node_Id
:= Expression
(N
);
1816 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1817 Etyp
: constant Entity_Id
:= Etype
(Id
);
1818 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1819 Dims_Of_Expr
: Dimension_Type
;
1821 procedure Error_Dim_Msg_For_Component_Declaration
1825 -- Error using Error_Msg_N at node N. Output the dimensions of the
1826 -- type Etyp and the expression Expr of N.
1828 ---------------------------------------------
1829 -- Error_Dim_Msg_For_Component_Declaration --
1830 ---------------------------------------------
1832 procedure Error_Dim_Msg_For_Component_Declaration
1837 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1839 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
1840 & Dimensions_Msg_Of
(Expr
), Expr
);
1841 end Error_Dim_Msg_For_Component_Declaration
;
1843 -- Start of processing for Analyze_Dimension_Component_Declaration
1846 -- Expression is present
1848 if Present
(Expr
) then
1849 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1851 -- Check dimensions match
1853 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1855 -- Numeric literal case. Issue a warning if the object type is not
1856 -- dimensionless to indicate the literal is treated as if its
1857 -- dimension matches the type dimension.
1859 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1862 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1864 -- Issue a dimension mismatch error for all other cases
1867 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1871 end Analyze_Dimension_Component_Declaration
;
1873 -------------------------------------------------
1874 -- Analyze_Dimension_Extended_Return_Statement --
1875 -------------------------------------------------
1877 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1878 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1879 Return_Etyp
: constant Entity_Id
:=
1880 Etype
(Return_Applies_To
(Return_Ent
));
1881 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1882 Return_Obj_Decl
: Node_Id
;
1883 Return_Obj_Id
: Entity_Id
;
1884 Return_Obj_Typ
: Entity_Id
;
1886 procedure Error_Dim_Msg_For_Extended_Return_Statement
1888 Return_Etyp
: Entity_Id
;
1889 Return_Obj_Typ
: Entity_Id
);
1890 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1891 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1893 -------------------------------------------------
1894 -- Error_Dim_Msg_For_Extended_Return_Statement --
1895 -------------------------------------------------
1897 procedure Error_Dim_Msg_For_Extended_Return_Statement
1899 Return_Etyp
: Entity_Id
;
1900 Return_Obj_Typ
: Entity_Id
)
1903 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1905 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
1906 & ", found " & Dimensions_Msg_Of
(Return_Obj_Typ
), N
);
1907 end Error_Dim_Msg_For_Extended_Return_Statement
;
1909 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1912 if Present
(Return_Obj_Decls
) then
1913 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1914 while Present
(Return_Obj_Decl
) loop
1915 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1916 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1918 if Is_Return_Object
(Return_Obj_Id
) then
1919 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1921 -- Issue an error message if dimensions mismatch
1923 if Dimensions_Of
(Return_Etyp
) /=
1924 Dimensions_Of
(Return_Obj_Typ
)
1926 Error_Dim_Msg_For_Extended_Return_Statement
1927 (N
, Return_Etyp
, Return_Obj_Typ
);
1933 Next
(Return_Obj_Decl
);
1936 end Analyze_Dimension_Extended_Return_Statement
;
1938 -----------------------------------------------------
1939 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1940 -----------------------------------------------------
1942 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1944 Comp_Id
: Entity_Id
;
1945 Comp_Typ
: Entity_Id
;
1948 Error_Detected
: Boolean := False;
1949 -- This flag is used in order to indicate if an error has been detected
1950 -- so far by the compiler in this routine.
1953 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1954 -- dimensions for aggregates that don't come from source, or if we are
1955 -- within an initialization procedure, whose expressions have been
1956 -- checked at the point of record declaration.
1958 if Ada_Version
< Ada_2012
1959 or else not Comes_From_Source
(N
)
1960 or else Inside_Init_Proc
1965 Comp
:= First
(Component_Associations
(N
));
1966 while Present
(Comp
) loop
1967 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1968 Comp_Typ
:= Etype
(Comp_Id
);
1970 -- Check the component type is either a dimensioned type or a
1971 -- dimensioned subtype.
1973 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1974 Expr
:= Expression
(Comp
);
1976 -- A box-initialized component needs no checking.
1978 if No
(Expr
) and then Box_Present
(Comp
) then
1981 -- Issue an error if the dimensions of the component type and the
1982 -- dimensions of the component mismatch.
1984 elsif Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
1986 -- Check if an error has already been encountered so far
1988 if not Error_Detected
then
1990 -- Extension aggregate case
1992 if Nkind
(N
) = N_Extension_Aggregate
then
1994 ("dimensions mismatch in extension aggregate", N
);
1996 -- Record aggregate case
2000 ("dimensions mismatch in record aggregate", N
);
2003 Error_Detected
:= True;
2007 ("\expected dimension " & Dimensions_Msg_Of
(Comp_Typ
)
2008 & ", found " & Dimensions_Msg_Of
(Expr
), Comp
);
2014 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
2016 -------------------------------
2017 -- Analyze_Dimension_Formals --
2018 -------------------------------
2020 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
2021 Dims_Of_Typ
: Dimension_Type
;
2026 -- Aspect is an Ada 2012 feature. Note that there is no need to check
2027 -- dimensions for sub specs that don't come from source.
2029 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
2033 Formal
:= First
(Formals
);
2034 while Present
(Formal
) loop
2035 Typ
:= Parameter_Type
(Formal
);
2036 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
2038 if Exists
(Dims_Of_Typ
) then
2040 Expr
: constant Node_Id
:= Expression
(Formal
);
2043 -- Issue a warning if Expr is a numeric literal and if its
2044 -- dimensions differ with the dimensions of the formal type.
2047 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
2048 and then Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2051 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
2058 end Analyze_Dimension_Formals
;
2060 ---------------------------------
2061 -- Analyze_Dimension_Has_Etype --
2062 ---------------------------------
2064 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
2065 Etyp
: constant Entity_Id
:= Etype
(N
);
2066 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
2069 -- General case. Propagation of the dimensions from the type
2071 if Exists
(Dims_Of_Etyp
) then
2072 Set_Dimensions
(N
, Dims_Of_Etyp
);
2074 -- Identifier case. Propagate the dimensions from the entity for
2075 -- identifier whose entity is a non-dimensionless constant.
2077 elsif Nkind
(N
) = N_Identifier
then
2078 Analyze_Dimension_Identifier
: declare
2079 Id
: constant Entity_Id
:= Entity
(N
);
2082 -- If Id is missing, abnormal tree, assume previous error
2085 Check_Error_Detected
;
2088 elsif Ekind_In
(Id
, E_Constant
, E_Named_Real
)
2089 and then Exists
(Dimensions_Of
(Id
))
2091 Set_Dimensions
(N
, Dimensions_Of
(Id
));
2093 end Analyze_Dimension_Identifier
;
2095 -- Attribute reference case. Propagate the dimensions from the prefix.
2097 elsif Nkind
(N
) = N_Attribute_Reference
2098 and then Has_Dimension_System
(Base_Type
(Etyp
))
2100 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
2102 -- Check the prefix is not dimensionless
2104 if Exists
(Dims_Of_Etyp
) then
2105 Set_Dimensions
(N
, Dims_Of_Etyp
);
2109 -- Remove dimensions from inner expressions, to prevent dimensions
2110 -- table from growing uselessly.
2113 when N_Attribute_Reference
2114 | N_Indexed_Component
2117 Exprs
: constant List_Id
:= Expressions
(N
);
2121 if Present
(Exprs
) then
2122 Expr
:= First
(Exprs
);
2123 while Present
(Expr
) loop
2124 Remove_Dimensions
(Expr
);
2130 when N_Qualified_Expression
2132 | N_Unchecked_Type_Conversion
2134 Remove_Dimensions
(Expression
(N
));
2136 when N_Selected_Component
=>
2137 Remove_Dimensions
(Selector_Name
(N
));
2142 end Analyze_Dimension_Has_Etype
;
2144 -------------------------------------
2145 -- Analyze_Dimension_If_Expression --
2146 -------------------------------------
2148 procedure Analyze_Dimension_If_Expression
(N
: Node_Id
) is
2149 Then_Expr
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
2150 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2153 if Dimensions_Of
(Then_Expr
) /= Dimensions_Of
(Else_Expr
) then
2154 Error_Msg_N
("dimensions mismatch in conditional expression", N
);
2156 Copy_Dimensions
(Then_Expr
, N
);
2158 end Analyze_Dimension_If_Expression
;
2160 ------------------------------------------
2161 -- Analyze_Dimension_Number_Declaration --
2162 ------------------------------------------
2164 procedure Analyze_Dimension_Number_Declaration
(N
: Node_Id
) is
2165 Expr
: constant Node_Id
:= Expression
(N
);
2166 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2167 Dim_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2170 if Exists
(Dim_Of_Expr
) then
2171 Set_Dimensions
(Id
, Dim_Of_Expr
);
2172 Set_Etype
(Id
, Etype
(Expr
));
2174 end Analyze_Dimension_Number_Declaration
;
2176 ------------------------------------------
2177 -- Analyze_Dimension_Object_Declaration --
2178 ------------------------------------------
2180 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
2181 Expr
: constant Node_Id
:= Expression
(N
);
2182 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2183 Etyp
: constant Entity_Id
:= Etype
(Id
);
2184 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
2185 Dim_Of_Expr
: Dimension_Type
;
2187 procedure Error_Dim_Msg_For_Object_Declaration
2191 -- Error using Error_Msg_N at node N. Output the dimensions of the
2192 -- type Etyp and of the expression Expr.
2194 ------------------------------------------
2195 -- Error_Dim_Msg_For_Object_Declaration --
2196 ------------------------------------------
2198 procedure Error_Dim_Msg_For_Object_Declaration
2203 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2205 ("\expected dimension " & Dimensions_Msg_Of
(Etyp
) & ", found "
2206 & Dimensions_Msg_Of
(Expr
), Expr
);
2207 end Error_Dim_Msg_For_Object_Declaration
;
2209 -- Start of processing for Analyze_Dimension_Object_Declaration
2212 -- Expression is present
2214 if Present
(Expr
) then
2215 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2217 -- Check dimensions match
2219 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2221 -- Numeric literal case. Issue a warning if the object type is
2222 -- not dimensionless to indicate the literal is treated as if
2223 -- its dimension matches the type dimension.
2225 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2228 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2230 -- Case of object is a constant whose type is a dimensioned type
2232 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2234 -- Propagate dimension from expression to object entity
2236 Set_Dimensions
(Id
, Dim_Of_Expr
);
2238 -- Expression may have been constant-folded. If nominal type has
2239 -- dimensions, verify that expression has same type.
2241 elsif Exists
(Dim_Of_Etyp
) and then Etype
(Expr
) = Etyp
then
2244 -- For all other cases, issue an error message
2247 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2251 -- Remove dimensions in expression after checking consistency with
2254 Remove_Dimensions
(Expr
);
2256 end Analyze_Dimension_Object_Declaration
;
2258 ---------------------------------------------------
2259 -- Analyze_Dimension_Object_Renaming_Declaration --
2260 ---------------------------------------------------
2262 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2263 Renamed_Name
: constant Node_Id
:= Name
(N
);
2264 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2266 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2269 Renamed_Name
: Node_Id
);
2270 -- Error using Error_Msg_N at node N. Output the dimensions of
2271 -- Sub_Mark and of Renamed_Name.
2273 ---------------------------------------------------
2274 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2275 ---------------------------------------------------
2277 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2280 Renamed_Name
: Node_Id
) is
2282 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2284 ("\expected dimension " & Dimensions_Msg_Of
(Sub_Mark
) & ", found "
2285 & Dimensions_Msg_Of
(Renamed_Name
), Renamed_Name
);
2286 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2288 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2291 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2292 Error_Dim_Msg_For_Object_Renaming_Declaration
2293 (N
, Sub_Mark
, Renamed_Name
);
2295 end Analyze_Dimension_Object_Renaming_Declaration
;
2297 -----------------------------------------------
2298 -- Analyze_Dimension_Simple_Return_Statement --
2299 -----------------------------------------------
2301 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2302 Expr
: constant Node_Id
:= Expression
(N
);
2303 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2304 Return_Etyp
: constant Entity_Id
:=
2305 Etype
(Return_Applies_To
(Return_Ent
));
2306 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2307 Dimensions_Of
(Return_Etyp
);
2309 procedure Error_Dim_Msg_For_Simple_Return_Statement
2311 Return_Etyp
: Entity_Id
;
2313 -- Error using Error_Msg_N at node N. Output the dimensions of the
2314 -- returned type Return_Etyp and the returned expression Expr of N.
2316 -----------------------------------------------
2317 -- Error_Dim_Msg_For_Simple_Return_Statement --
2318 -----------------------------------------------
2320 procedure Error_Dim_Msg_For_Simple_Return_Statement
2322 Return_Etyp
: Entity_Id
;
2326 Error_Msg_N
("dimensions mismatch in return statement", N
);
2328 ("\expected dimension " & Dimensions_Msg_Of
(Return_Etyp
)
2329 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2330 end Error_Dim_Msg_For_Simple_Return_Statement
;
2332 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2335 if Dims_Of_Return_Etyp
/= Dimensions_Of
(Expr
) then
2336 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2337 Remove_Dimensions
(Expr
);
2339 end Analyze_Dimension_Simple_Return_Statement
;
2341 -------------------------------------------
2342 -- Analyze_Dimension_Subtype_Declaration --
2343 -------------------------------------------
2345 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2346 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2347 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2348 Dims_Of_Etyp
: Dimension_Type
;
2352 -- No constraint case in subtype declaration
2354 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2355 Etyp
:= Etype
(Subtype_Indication
(N
));
2356 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2358 if Exists
(Dims_Of_Etyp
) then
2360 -- If subtype already has a dimension (from Aspect_Dimension), it
2361 -- cannot inherit different dimensions from its subtype.
2363 if Exists
(Dims_Of_Id
) and then Dims_Of_Etyp
/= Dims_Of_Id
then
2365 ("subtype& already " & Dimensions_Msg_Of
(Id
, True), N
, Id
);
2367 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2368 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2372 -- Constraint present in subtype declaration
2375 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2376 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2378 if Exists
(Dims_Of_Etyp
) then
2379 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2380 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2383 end Analyze_Dimension_Subtype_Declaration
;
2385 ---------------------------------------
2386 -- Analyze_Dimension_Type_Conversion --
2387 ---------------------------------------
2389 procedure Analyze_Dimension_Type_Conversion
(N
: Node_Id
) is
2390 Expr_Root
: constant Entity_Id
:=
2391 Dimension_System_Root
(Etype
(Expression
(N
)));
2392 Target_Root
: constant Entity_Id
:=
2393 Dimension_System_Root
(Etype
(N
));
2396 -- If the expression has dimensions and the target type has dimensions,
2397 -- the conversion has the dimensions of the expression. Consistency is
2398 -- checked below. Converting to a non-dimensioned type such as Float
2399 -- ignores the dimensions of the expression.
2401 if Exists
(Dimensions_Of
(Expression
(N
)))
2402 and then Present
(Target_Root
)
2404 Set_Dimensions
(N
, Dimensions_Of
(Expression
(N
)));
2406 -- Otherwise the dimensions are those of the target type.
2409 Analyze_Dimension_Has_Etype
(N
);
2412 -- A conversion between types in different dimension systems (e.g. MKS
2413 -- and British units) must respect the dimensions of expression and
2414 -- type, It is up to the user to provide proper conversion factors.
2416 -- Upward conversions to root type of a dimensioned system are legal,
2417 -- and correspond to "view conversions", i.e. preserve the dimensions
2418 -- of the expression; otherwise conversion must be between types with
2419 -- then same dimensions. Conversions to a non-dimensioned type such as
2420 -- Float lose the dimensions of the expression.
2422 if Present
(Expr_Root
)
2423 and then Present
(Target_Root
)
2424 and then Etype
(N
) /= Target_Root
2425 and then Dimensions_Of
(Expression
(N
)) /= Dimensions_Of
(Etype
(N
))
2427 Error_Msg_N
("dimensions mismatch in conversion", N
);
2429 ("\expression " & Dimensions_Msg_Of
(Expression
(N
), True), N
);
2431 ("\target type " & Dimensions_Msg_Of
(Etype
(N
), True), N
);
2433 end Analyze_Dimension_Type_Conversion
;
2435 --------------------------------
2436 -- Analyze_Dimension_Unary_Op --
2437 --------------------------------
2439 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2443 -- Propagate the dimension if the operand is not dimensionless
2450 R
: constant Node_Id
:= Right_Opnd
(N
);
2452 Move_Dimensions
(R
, N
);
2458 end Analyze_Dimension_Unary_Op
;
2460 ---------------------------------
2461 -- Check_Expression_Dimensions --
2462 ---------------------------------
2464 procedure Check_Expression_Dimensions
2469 if Is_Floating_Point_Type
(Etype
(Expr
)) then
2470 Analyze_Dimension
(Expr
);
2472 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Typ
) then
2473 Error_Msg_N
("dimensions mismatch in array aggregate", Expr
);
2475 ("\expected dimension " & Dimensions_Msg_Of
(Typ
)
2476 & ", found " & Dimensions_Msg_Of
(Expr
), Expr
);
2479 end Check_Expression_Dimensions
;
2481 ---------------------
2482 -- Copy_Dimensions --
2483 ---------------------
2485 procedure Copy_Dimensions
(From
: Node_Id
; To
: Node_Id
) is
2486 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2489 -- Ignore if not Ada 2012 or beyond
2491 if Ada_Version
< Ada_2012
then
2494 -- For Ada 2012, Copy the dimension of 'From to 'To'
2496 elsif Exists
(Dims_Of_From
) then
2497 Set_Dimensions
(To
, Dims_Of_From
);
2499 end Copy_Dimensions
;
2501 -----------------------------------
2502 -- Copy_Dimensions_Of_Components --
2503 -----------------------------------
2505 procedure Copy_Dimensions_Of_Components
(Rec
: Entity_Id
) is
2509 C
:= First_Component
(Rec
);
2510 while Present
(C
) loop
2511 if Nkind
(Parent
(C
)) = N_Component_Declaration
then
2513 (Expression
(Parent
(Corresponding_Record_Component
(C
))),
2514 Expression
(Parent
(C
)));
2518 end Copy_Dimensions_Of_Components
;
2520 --------------------------
2521 -- Create_Rational_From --
2522 --------------------------
2524 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2526 -- A rational number is a number that can be expressed as the quotient or
2527 -- fraction a/b of two integers, where b is non-zero positive.
2529 function Create_Rational_From
2531 Complain
: Boolean) return Rational
2533 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2534 Result
: Rational
:= No_Rational
;
2536 function Process_Minus
(N
: Node_Id
) return Rational
;
2537 -- Create a rational from a N_Op_Minus node
2539 function Process_Divide
(N
: Node_Id
) return Rational
;
2540 -- Create a rational from a N_Op_Divide node
2542 function Process_Literal
(N
: Node_Id
) return Rational
;
2543 -- Create a rational from a N_Integer_Literal node
2549 function Process_Minus
(N
: Node_Id
) return Rational
is
2550 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2554 -- Operand is an integer literal
2556 if Nkind
(Right
) = N_Integer_Literal
then
2557 Result
:= -Process_Literal
(Right
);
2559 -- Operand is a divide operator
2561 elsif Nkind
(Right
) = N_Op_Divide
then
2562 Result
:= -Process_Divide
(Right
);
2565 Result
:= No_Rational
;
2568 -- Provide minimal semantic information on dimension expressions,
2569 -- even though they have no run-time existence. This is for use by
2570 -- ASIS tools, in particular pretty-printing. If generating code
2571 -- standard operator resolution will take place.
2574 Set_Entity
(N
, Standard_Op_Minus
);
2575 Set_Etype
(N
, Standard_Integer
);
2581 --------------------
2582 -- Process_Divide --
2583 --------------------
2585 function Process_Divide
(N
: Node_Id
) return Rational
is
2586 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2587 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2588 Left_Rat
: Rational
;
2589 Result
: Rational
:= No_Rational
;
2590 Right_Rat
: Rational
;
2593 -- Both left and right operands are integer literals
2595 if Nkind
(Left
) = N_Integer_Literal
2597 Nkind
(Right
) = N_Integer_Literal
2599 Left_Rat
:= Process_Literal
(Left
);
2600 Right_Rat
:= Process_Literal
(Right
);
2601 Result
:= Left_Rat
/ Right_Rat
;
2604 -- Provide minimal semantic information on dimension expressions,
2605 -- even though they have no run-time existence. This is for use by
2606 -- ASIS tools, in particular pretty-printing. If generating code
2607 -- standard operator resolution will take place.
2610 Set_Entity
(N
, Standard_Op_Divide
);
2611 Set_Etype
(N
, Standard_Integer
);
2617 ---------------------
2618 -- Process_Literal --
2619 ---------------------
2621 function Process_Literal
(N
: Node_Id
) return Rational
is
2623 return +Whole
(UI_To_Int
(Intval
(N
)));
2624 end Process_Literal
;
2626 -- Start of processing for Create_Rational_From
2629 -- Check the expression is either a division of two integers or an
2630 -- integer itself. Note that the check applies to the original node
2631 -- since the node could have already been rewritten.
2633 -- Integer literal case
2635 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2636 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2638 -- Divide operator case
2640 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2641 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2643 -- Minus operator case
2645 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2646 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2649 -- When Expr cannot be interpreted as a rational and Complain is true,
2650 -- generate an error message.
2652 if Complain
and then Result
= No_Rational
then
2653 Error_Msg_N
("rational expected", Expr
);
2657 end Create_Rational_From
;
2663 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2665 return Dimension_Table
.Get
(N
);
2668 -----------------------
2669 -- Dimensions_Msg_Of --
2670 -----------------------
2672 function Dimensions_Msg_Of
2674 Description_Needed
: Boolean := False) return String
2676 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2677 Dimensions_Msg
: Name_Id
;
2678 System
: System_Type
;
2681 -- Initialization of Name_Buffer
2685 -- N is not dimensionless
2687 if Exists
(Dims_Of_N
) then
2688 System
:= System_Of
(Base_Type
(Etype
(N
)));
2690 -- When Description_Needed, add to string "has dimension " before the
2691 -- actual dimension.
2693 if Description_Needed
then
2694 Add_Str_To_Name_Buffer
("has dimension ");
2698 (Global_Name_Buffer
,
2699 From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2701 -- N is dimensionless
2703 -- When Description_Needed, return "is dimensionless"
2705 elsif Description_Needed
then
2706 Add_Str_To_Name_Buffer
("is dimensionless");
2708 -- Otherwise, return "'[']"
2711 Add_Str_To_Name_Buffer
("'[']");
2714 Dimensions_Msg
:= Name_Find
;
2715 return Get_Name_String
(Dimensions_Msg
);
2716 end Dimensions_Msg_Of
;
2718 --------------------------
2719 -- Dimension_Table_Hash --
2720 --------------------------
2722 function Dimension_Table_Hash
2723 (Key
: Node_Id
) return Dimension_Table_Range
2726 return Dimension_Table_Range
(Key
mod 511);
2727 end Dimension_Table_Hash
;
2729 -------------------------------------
2730 -- Dim_Warning_For_Numeric_Literal --
2731 -------------------------------------
2733 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2735 -- Initialize name buffer
2739 Append
(Global_Name_Buffer
, String_From_Numeric_Literal
(N
));
2741 -- Insert a blank between the literal and the symbol
2743 Add_Str_To_Name_Buffer
(" ");
2744 Append
(Global_Name_Buffer
, Symbol_Of
(Typ
));
2746 Error_Msg_Name_1
:= Name_Find
;
2747 Error_Msg_N
("assumed to be%%??", N
);
2748 end Dim_Warning_For_Numeric_Literal
;
2750 ----------------------
2751 -- Dimensions_Match --
2752 ----------------------
2754 function Dimensions_Match
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2757 not Has_Dimension_System
(Base_Type
(T1
))
2758 or else Dimensions_Of
(T1
) = Dimensions_Of
(T2
);
2759 end Dimensions_Match
;
2761 ---------------------------
2762 -- Dimension_System_Root --
2763 ---------------------------
2765 function Dimension_System_Root
(T
: Entity_Id
) return Entity_Id
is
2769 Root
:= Base_Type
(T
);
2771 if Has_Dimension_System
(Root
) then
2772 return First_Subtype
(Root
); -- for example Dim_Mks
2777 end Dimension_System_Root
;
2779 ----------------------------------------
2780 -- Eval_Op_Expon_For_Dimensioned_Type --
2781 ----------------------------------------
2783 -- Evaluate the expon operator for real dimensioned type.
2785 -- Note that if the exponent is an integer (denominator = 1) the node is
2786 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2788 procedure Eval_Op_Expon_For_Dimensioned_Type
2792 R
: constant Node_Id
:= Right_Opnd
(N
);
2793 R_Value
: Rational
:= No_Rational
;
2796 if Is_Real_Type
(Btyp
) then
2797 R_Value
:= Create_Rational_From
(R
, False);
2800 -- Check that the exponent is not an integer
2802 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2803 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2807 end Eval_Op_Expon_For_Dimensioned_Type
;
2809 ------------------------------------------
2810 -- Eval_Op_Expon_With_Rational_Exponent --
2811 ------------------------------------------
2813 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2814 -- Rational and not only an Integer like for dimensionless operands. For
2815 -- that particular case, the left operand is rewritten as a function call
2816 -- using the function Expon_LLF from s-llflex.ads.
2818 procedure Eval_Op_Expon_With_Rational_Exponent
2820 Exponent_Value
: Rational
)
2822 Loc
: constant Source_Ptr
:= Sloc
(N
);
2823 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2824 L
: constant Node_Id
:= Left_Opnd
(N
);
2825 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2826 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2829 Dim_Power
: Rational
;
2830 List_Of_Dims
: List_Id
;
2831 New_Aspect
: Node_Id
;
2832 New_Aspects
: List_Id
;
2835 New_Subtyp_Decl_For_L
: Node_Id
;
2836 System
: System_Type
;
2839 -- Case when the operand is not dimensionless
2841 if Exists
(Dims_Of_N
) then
2843 -- Get the corresponding System_Type to know the exact number of
2844 -- dimensions in the system.
2846 System
:= System_Of
(Btyp_Of_L
);
2848 -- Generation of a new subtype with the proper dimensions
2850 -- In order to rewrite the operator as a type conversion, a new
2851 -- dimensioned subtype with the resulting dimensions of the
2852 -- exponentiation must be created.
2856 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2857 -- System : constant System_Id :=
2858 -- Get_Dimension_System_Id (Btyp_Of_L);
2859 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2860 -- Dimension_Systems.Table (System).Dimension_Count;
2862 -- subtype T is Btyp_Of_L
2865 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2866 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2868 -- Dims_Of_N (Num_Of_Dims).Numerator /
2869 -- Dims_Of_N (Num_Of_Dims).Denominator);
2871 -- Step 1: Generate the new aggregate for the aspect Dimension
2873 New_Aspects
:= Empty_List
;
2875 List_Of_Dims
:= New_List
;
2876 for Position
in Dims_Of_N
'First .. System
.Count
loop
2877 Dim_Power
:= Dims_Of_N
(Position
);
2878 Append_To
(List_Of_Dims
,
2879 Make_Op_Divide
(Loc
,
2881 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Numerator
)),
2883 Make_Integer_Literal
(Loc
, Int
(Dim_Power
.Denominator
))));
2886 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2889 Make_Aspect_Specification
(Loc
,
2890 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2891 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2893 -- Step 3: Make a temporary identifier for the new subtype
2895 New_Id
:= Make_Temporary
(Loc
, 'T');
2896 Set_Is_Internal
(New_Id
);
2898 -- Step 4: Declaration of the new subtype
2900 New_Subtyp_Decl_For_L
:=
2901 Make_Subtype_Declaration
(Loc
,
2902 Defining_Identifier
=> New_Id
,
2903 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2905 Append
(New_Aspect
, New_Aspects
);
2906 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2907 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2909 Analyze
(New_Subtyp_Decl_For_L
);
2911 -- Case where the operand is dimensionless
2914 New_Id
:= Btyp_Of_L
;
2917 -- Replacement of N by New_N
2921 -- Actual_1 := Long_Long_Float (L),
2923 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2924 -- Long_Long_Float (Exponent_Value.Denominator);
2926 -- (T (Expon_LLF (Actual_1, Actual_2)));
2928 -- where T is the subtype declared in step 1
2930 -- The node is rewritten as a type conversion
2932 -- Step 1: Creation of the two parameters of Expon_LLF function call
2935 Make_Type_Conversion
(Loc
,
2936 Subtype_Mark
=> New_Occurrence_Of
(Standard_Long_Long_Float
, Loc
),
2937 Expression
=> Relocate_Node
(L
));
2940 Make_Op_Divide
(Loc
,
2942 Make_Real_Literal
(Loc
,
2943 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2945 Make_Real_Literal
(Loc
,
2946 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2948 -- Step 2: Creation of New_N
2951 Make_Type_Conversion
(Loc
,
2952 Subtype_Mark
=> New_Occurrence_Of
(New_Id
, Loc
),
2954 Make_Function_Call
(Loc
,
2955 Name
=> New_Occurrence_Of
(RTE
(RE_Expon_LLF
), Loc
),
2956 Parameter_Associations
=> New_List
(
2957 Actual_1
, Actual_2
)));
2959 -- Step 3: Rewrite N with the result
2962 Set_Etype
(N
, New_Id
);
2963 Analyze_And_Resolve
(N
, New_Id
);
2964 end Eval_Op_Expon_With_Rational_Exponent
;
2970 function Exists
(Dim
: Dimension_Type
) return Boolean is
2972 return Dim
/= Null_Dimension
;
2975 function Exists
(Str
: String_Id
) return Boolean is
2977 return Str
/= No_String
;
2980 function Exists
(Sys
: System_Type
) return Boolean is
2982 return Sys
/= Null_System
;
2985 ---------------------------------
2986 -- Expand_Put_Call_With_Symbol --
2987 ---------------------------------
2989 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in
2990 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string
2991 -- parameter is rewritten to include the unit symbol (or the dimension
2992 -- symbols if not a defined quantity) in the output of a dimensioned
2993 -- object. If a value is already supplied by the user for the parameter
2994 -- Symbol, it is used as is.
2996 -- Case 1. Item is dimensionless
2998 -- * Put : Item appears without a suffix
3000 -- * Put_Dim_Of : the output is []
3002 -- Obj : Mks_Type := 2.6;
3003 -- Put (Obj, 1, 1, 0);
3004 -- Put_Dim_Of (Obj);
3006 -- The corresponding outputs are:
3010 -- Case 2. Item has a dimension
3012 -- * Put : If the type of Item is a dimensioned subtype whose
3013 -- symbol is not empty, then the symbol appears as a
3014 -- suffix. Otherwise, a new string is created and appears
3015 -- as a suffix of Item. This string results in the
3016 -- successive concatanations between each unit symbol
3017 -- raised by its corresponding dimension power from the
3018 -- dimensions of Item.
3020 -- * Put_Dim_Of : The output is a new string resulting in the successive
3021 -- concatanations between each dimension symbol raised by
3022 -- its corresponding dimension power from the dimensions of
3025 -- subtype Random is Mks_Type
3032 -- Obj : Random := 5.0;
3034 -- Put_Dim_Of (Obj);
3036 -- The corresponding outputs are:
3037 -- $5.0 m**3.cd**(-1)
3040 -- The function Image returns the string identical to that produced by
3041 -- a call to Put whose first parameter is a string.
3043 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
3044 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
3045 Loc
: constant Source_Ptr
:= Sloc
(N
);
3046 Name_Call
: constant Node_Id
:= Name
(N
);
3047 New_Actuals
: constant List_Id
:= New_List
;
3049 Dims_Of_Actual
: Dimension_Type
;
3051 New_Str_Lit
: Node_Id
:= Empty
;
3052 Symbols
: String_Id
;
3054 Is_Put_Dim_Of
: Boolean := False;
3055 -- This flag is used in order to differentiate routines Put and
3056 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
3057 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
3059 function Has_Symbols
return Boolean;
3060 -- Return True if the current Put call already has a parameter
3061 -- association for parameter "Symbols" with the correct string of
3064 function Is_Procedure_Put_Call
return Boolean;
3065 -- Return True if the current call is a call of an instantiation of a
3066 -- procedure Put defined in the package System.Dim.Float_IO and
3067 -- System.Dim.Integer_IO.
3069 function Item_Actual
return Node_Id
;
3070 -- Return the item actual parameter node in the output call
3076 function Has_Symbols
return Boolean is
3078 Actual_Str
: Node_Id
;
3081 -- Look for a symbols parameter association in the list of actuals
3083 Actual
:= First
(Actuals
);
3084 while Present
(Actual
) loop
3086 -- Positional parameter association case when the actual is a
3089 if Nkind
(Actual
) = N_String_Literal
then
3090 Actual_Str
:= Actual
;
3092 -- Named parameter association case when selector name is Symbol
3094 elsif Nkind
(Actual
) = N_Parameter_Association
3095 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
3097 Actual_Str
:= Explicit_Actual_Parameter
(Actual
);
3099 -- Ignore all other cases
3102 Actual_Str
:= Empty
;
3105 if Present
(Actual_Str
) then
3107 -- Return True if the actual comes from source or if the string
3108 -- of symbols doesn't have the default value (i.e. it is ""),
3109 -- in which case it is used as suffix of the generated string.
3111 if Comes_From_Source
(Actual
)
3112 or else String_Length
(Strval
(Actual_Str
)) /= 0
3124 -- At this point, the call has no parameter association. Look to the
3125 -- last actual since the symbols parameter is the last one.
3127 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
3130 ---------------------------
3131 -- Is_Procedure_Put_Call --
3132 ---------------------------
3134 function Is_Procedure_Put_Call
return Boolean is
3139 -- There are three different Put (resp. Put_Dim_Of) routines in each
3140 -- generic dim IO package. Verify the current procedure call is one
3143 if Is_Entity_Name
(Name_Call
) then
3144 Ent
:= Entity
(Name_Call
);
3146 -- Get the original subprogram entity following the renaming chain
3148 if Present
(Alias
(Ent
)) then
3154 -- Check the name of the entity subprogram is Put (resp.
3155 -- Put_Dim_Of) and verify this entity is located in either
3156 -- System.Dim.Float_IO or System.Dim.Integer_IO.
3158 if Loc
> No_Location
3159 and then Is_Dim_IO_Package_Entity
3160 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
3162 if Chars
(Ent
) = Name_Put_Dim_Of
then
3163 Is_Put_Dim_Of
:= True;
3166 elsif Chars
(Ent
) = Name_Put
3167 or else Chars
(Ent
) = Name_Image
3175 end Is_Procedure_Put_Call
;
3181 function Item_Actual
return Node_Id
is
3185 -- Look for the item actual as a parameter association
3187 Actual
:= First
(Actuals
);
3188 while Present
(Actual
) loop
3189 if Nkind
(Actual
) = N_Parameter_Association
3190 and then Chars
(Selector_Name
(Actual
)) = Name_Item
3192 return Explicit_Actual_Parameter
(Actual
);
3198 -- Case where the item has been defined without an association
3200 Actual
:= First
(Actuals
);
3202 -- Depending on the procedure Put, Item actual could be first or
3203 -- second in the list of actuals.
3205 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
3208 return Next
(Actual
);
3212 -- Start of processing for Expand_Put_Call_With_Symbol
3215 if Is_Procedure_Put_Call
and then not Has_Symbols
then
3216 Actual
:= Item_Actual
;
3217 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
3218 Etyp
:= Etype
(Actual
);
3222 if Is_Put_Dim_Of
then
3224 -- Check that the item is not dimensionless
3226 -- Create the new String_Literal with the new String_Id generated
3227 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
3229 if Exists
(Dims_Of_Actual
) then
3231 Make_String_Literal
(Loc
,
3232 From_Dim_To_Str_Of_Dim_Symbols
3233 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
))));
3235 -- If dimensionless, the output is []
3239 Make_String_Literal
(Loc
, "[]");
3245 -- Add the symbol as a suffix of the value if the subtype has a
3246 -- unit symbol or if the parameter is not dimensionless.
3248 if Exists
(Symbol_Of
(Etyp
)) then
3249 Symbols
:= Symbol_Of
(Etyp
);
3251 Symbols
:= From_Dim_To_Str_Of_Unit_Symbols
3252 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
)));
3255 -- Check Symbols exists
3257 if Exists
(Symbols
) then
3260 -- Put a space between the value and the dimension
3262 Store_String_Char
(' ');
3263 Store_String_Chars
(Symbols
);
3264 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
3268 if Present
(New_Str_Lit
) then
3270 -- Insert all actuals in New_Actuals
3272 Actual
:= First
(Actuals
);
3273 while Present
(Actual
) loop
3275 -- Copy every actuals in New_Actuals except the Symbols
3276 -- parameter association.
3278 if Nkind
(Actual
) = N_Parameter_Association
3279 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
3281 Append_To
(New_Actuals
,
3282 Make_Parameter_Association
(Loc
,
3283 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
3284 Explicit_Actual_Parameter
=>
3285 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
3287 elsif Nkind
(Actual
) /= N_Parameter_Association
then
3288 Append_To
(New_Actuals
, New_Copy
(Actual
));
3294 -- Create new Symbols param association and append to New_Actuals
3296 Append_To
(New_Actuals
,
3297 Make_Parameter_Association
(Loc
,
3298 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
3299 Explicit_Actual_Parameter
=> New_Str_Lit
));
3301 -- Rewrite and analyze the procedure call
3303 if Chars
(Name_Call
) = Name_Image
then
3305 Make_Function_Call
(Loc
,
3306 Name
=> New_Copy
(Name_Call
),
3307 Parameter_Associations
=> New_Actuals
));
3308 Analyze_And_Resolve
(N
);
3311 Make_Procedure_Call_Statement
(Loc
,
3312 Name
=> New_Copy
(Name_Call
),
3313 Parameter_Associations
=> New_Actuals
));
3319 end Expand_Put_Call_With_Symbol
;
3321 ------------------------------------
3322 -- From_Dim_To_Str_Of_Dim_Symbols --
3323 ------------------------------------
3325 -- Given a dimension vector and the corresponding dimension system, create
3326 -- a String_Id to output dimension symbols corresponding to the dimensions
3327 -- Dims. If In_Error_Msg is True, there is a special handling for character
3328 -- asterisk * which is an insertion character in error messages.
3330 function From_Dim_To_Str_Of_Dim_Symbols
3331 (Dims
: Dimension_Type
;
3332 System
: System_Type
;
3333 In_Error_Msg
: Boolean := False) return String_Id
3335 Dim_Power
: Rational
;
3336 First_Dim
: Boolean := True;
3338 procedure Store_String_Oexpon
;
3339 -- Store the expon operator symbol "**" in the string. In error
3340 -- messages, asterisk * is a special character and must be quoted
3341 -- to be placed literally into the message.
3343 -------------------------
3344 -- Store_String_Oexpon --
3345 -------------------------
3347 procedure Store_String_Oexpon
is
3349 if In_Error_Msg
then
3350 Store_String_Chars
("'*'*");
3352 Store_String_Chars
("**");
3354 end Store_String_Oexpon
;
3356 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3359 -- Initialization of the new String_Id
3363 -- Store the dimension symbols inside boxes
3365 if In_Error_Msg
then
3366 Store_String_Chars
("'[");
3368 Store_String_Char
('[');
3371 for Position
in Dimension_Type
'Range loop
3372 Dim_Power
:= Dims
(Position
);
3373 if Dim_Power
/= Zero
then
3378 Store_String_Char
('.');
3381 Store_String_Chars
(System
.Dim_Symbols
(Position
));
3383 -- Positive dimension case
3385 if Dim_Power
.Numerator
> 0 then
3389 if Dim_Power
.Denominator
= 1 then
3390 if Dim_Power
.Numerator
/= 1 then
3391 Store_String_Oexpon
;
3392 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3395 -- Rational case when denominator /= 1
3398 Store_String_Oexpon
;
3399 Store_String_Char
('(');
3400 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3401 Store_String_Char
('/');
3402 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3403 Store_String_Char
(')');
3406 -- Negative dimension case
3409 Store_String_Oexpon
;
3410 Store_String_Char
('(');
3411 Store_String_Char
('-');
3412 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3416 if Dim_Power
.Denominator
= 1 then
3417 Store_String_Char
(')');
3419 -- Rational case when denominator /= 1
3422 Store_String_Char
('/');
3423 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3424 Store_String_Char
(')');
3430 if In_Error_Msg
then
3431 Store_String_Chars
("']");
3433 Store_String_Char
(']');
3437 end From_Dim_To_Str_Of_Dim_Symbols
;
3439 -------------------------------------
3440 -- From_Dim_To_Str_Of_Unit_Symbols --
3441 -------------------------------------
3443 -- Given a dimension vector and the corresponding dimension system,
3444 -- create a String_Id to output the unit symbols corresponding to the
3447 function From_Dim_To_Str_Of_Unit_Symbols
3448 (Dims
: Dimension_Type
;
3449 System
: System_Type
) return String_Id
3451 Dim_Power
: Rational
;
3452 First_Dim
: Boolean := True;
3455 -- Return No_String if dimensionless
3457 if not Exists
(Dims
) then
3461 -- Initialization of the new String_Id
3465 for Position
in Dimension_Type
'Range loop
3466 Dim_Power
:= Dims
(Position
);
3468 if Dim_Power
/= Zero
then
3472 Store_String_Char
('.');
3475 Store_String_Chars
(System
.Unit_Symbols
(Position
));
3477 -- Positive dimension case
3479 if Dim_Power
.Numerator
> 0 then
3483 if Dim_Power
.Denominator
= 1 then
3484 if Dim_Power
.Numerator
/= 1 then
3485 Store_String_Chars
("**");
3486 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3489 -- Rational case when denominator /= 1
3492 Store_String_Chars
("**");
3493 Store_String_Char
('(');
3494 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3495 Store_String_Char
('/');
3496 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3497 Store_String_Char
(')');
3500 -- Negative dimension case
3503 Store_String_Chars
("**");
3504 Store_String_Char
('(');
3505 Store_String_Char
('-');
3506 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3510 if Dim_Power
.Denominator
= 1 then
3511 Store_String_Char
(')');
3513 -- Rational case when denominator /= 1
3516 Store_String_Char
('/');
3517 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3518 Store_String_Char
(')');
3525 end From_Dim_To_Str_Of_Unit_Symbols
;
3531 function GCD
(Left
, Right
: Whole
) return Int
is
3551 --------------------------
3552 -- Has_Dimension_System --
3553 --------------------------
3555 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
3557 return Exists
(System_Of
(Typ
));
3558 end Has_Dimension_System
;
3560 ------------------------------
3561 -- Is_Dim_IO_Package_Entity --
3562 ------------------------------
3564 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
3566 -- Check the package entity corresponds to System.Dim.Float_IO or
3567 -- System.Dim.Integer_IO.
3570 Is_RTU
(E
, System_Dim_Float_IO
)
3572 Is_RTU
(E
, System_Dim_Integer_IO
);
3573 end Is_Dim_IO_Package_Entity
;
3575 -------------------------------------
3576 -- Is_Dim_IO_Package_Instantiation --
3577 -------------------------------------
3579 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
3580 Gen_Id
: constant Node_Id
:= Name
(N
);
3583 -- Check that the instantiated package is either System.Dim.Float_IO
3584 -- or System.Dim.Integer_IO.
3587 Is_Entity_Name
(Gen_Id
)
3588 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
3589 end Is_Dim_IO_Package_Instantiation
;
3595 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
3597 return Position
= Invalid_Position
;
3600 ---------------------
3601 -- Move_Dimensions --
3602 ---------------------
3604 procedure Move_Dimensions
(From
, To
: Node_Id
) is
3606 if Ada_Version
< Ada_2012
then
3610 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3612 Copy_Dimensions
(From
, To
);
3613 Remove_Dimensions
(From
);
3614 end Move_Dimensions
;
3616 ---------------------------------------
3617 -- New_Copy_Tree_And_Copy_Dimensions --
3618 ---------------------------------------
3620 function New_Copy_Tree_And_Copy_Dimensions
3622 Map
: Elist_Id
:= No_Elist
;
3623 New_Sloc
: Source_Ptr
:= No_Location
;
3624 New_Scope
: Entity_Id
:= Empty
) return Node_Id
3626 New_Copy
: constant Node_Id
:=
3627 New_Copy_Tree
(Source
, Map
, New_Sloc
, New_Scope
);
3630 -- Move the dimensions of Source to New_Copy
3632 Copy_Dimensions
(Source
, New_Copy
);
3634 end New_Copy_Tree_And_Copy_Dimensions
;
3640 function Reduce
(X
: Rational
) return Rational
is
3642 if X
.Numerator
= 0 then
3647 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
3649 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
3650 Denominator => Whole (Int (X.Denominator) / G));
3654 -----------------------
3655 -- Remove_Dimensions --
3656 -----------------------
3658 procedure Remove_Dimensions (N : Node_Id) is
3659 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3661 if Exists (Dims_Of_N) then
3662 Dimension_Table.Remove (N);
3664 end Remove_Dimensions;
3666 -----------------------------------
3667 -- Remove_Dimension_In_Statement --
3668 -----------------------------------
3670 -- Removal of dimension in statement as part of the Analyze_Statements
3671 -- routine (see package Sem_Ch5).
3673 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3675 if Ada_Version < Ada_2012 then
3679 -- Remove dimension in parameter specifications for accept statement
3681 if Nkind (Stmt) = N_Accept_Statement then
3683 Param : Node_Id := First (Parameter_Specifications (Stmt));
3685 while Present (Param) loop
3686 Remove_Dimensions (Param);
3691 -- Remove dimension of name and expression in assignments
3693 elsif Nkind (Stmt) = N_Assignment_Statement then
3694 Remove_Dimensions (Expression (Stmt));
3695 Remove_Dimensions (Name (Stmt));
3697 end Remove_Dimension_In_Statement;
3699 --------------------
3700 -- Set_Dimensions --
3701 --------------------
3703 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3705 pragma Assert (OK_For_Dimension (Nkind (N)));
3706 pragma Assert (Exists (Val));
3708 Dimension_Table.Set (N, Val);
3715 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3717 Symbol_Table.Set (E, Val);
3720 ---------------------------------
3721 -- String_From_Numeric_Literal --
3722 ---------------------------------
3724 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3725 Loc : constant Source_Ptr := Sloc (N);
3726 Sbuffer : constant Source_Buffer_Ptr :=
3727 Source_Text (Get_Source_File_Index (Loc));
3728 Src_Ptr : Source_Ptr := Loc;
3730 C : Character := Sbuffer (Src_Ptr);
3731 -- Current source program character
3733 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3734 -- Return True if C belongs to a numeric literal
3736 -------------------------------
3737 -- Belong_To_Numeric_Literal --
3738 -------------------------------
3740 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3744 | '_
' | '.' | 'e
' | '#
' | 'A
' | 'B
' | 'C
' | 'D
' | 'E
' | 'F
'
3748 -- Make sure '+' or '-' is part of an exponent.
3752 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3754 return Prev_C = 'e
' or else Prev_C = 'E
';
3757 -- All other character doesn't belong to a numeric literal
3762 end Belong_To_Numeric_Literal;
3764 -- Start of processing for String_From_Numeric_Literal
3768 while Belong_To_Numeric_Literal (C) loop
3769 Store_String_Char (C);
3770 Src_Ptr := Src_Ptr + 1;
3771 C := Sbuffer (Src_Ptr);
3775 end String_From_Numeric_Literal;
3781 function Symbol_Of (E : Entity_Id) return String_Id is
3782 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3784 if Subtype_Symbol /= No_String then
3785 return Subtype_Symbol;
3787 return From_Dim_To_Str_Of_Unit_Symbols
3788 (Dimensions_Of (E), System_Of (Base_Type (E)));
3792 -----------------------
3793 -- Symbol_Table_Hash --
3794 -----------------------
3796 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3798 return Symbol_Table_Range (Key mod 511);
3799 end Symbol_Table_Hash;
3805 function System_Of (E : Entity_Id) return System_Type is
3806 Type_Decl : constant Node_Id := Parent (E);
3809 -- Look for Type_Decl in System_Table
3811 for Dim_Sys in 1 .. System_Table.Last loop
3812 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3813 return System_Table.Table (Dim_Sys);