1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2012, 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
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Rtsfind
; use Rtsfind
;
37 with Sem_Eval
; use Sem_Eval
;
38 with Sem_Res
; use Sem_Res
;
39 with Sem_Util
; use Sem_Util
;
40 with Sinfo
; use Sinfo
;
41 with Sinput
; use Sinput
;
42 with Snames
; use Snames
;
43 with Stand
; use Stand
;
44 with Stringt
; use Stringt
;
46 with Tbuild
; use Tbuild
;
47 with Uintp
; use Uintp
;
48 with Urealp
; use Urealp
;
52 package body Sem_Dim
is
54 -------------------------
55 -- Rational arithmetic --
56 -------------------------
58 type Whole
is new Int
;
59 subtype Positive_Whole
is Whole
range 1 .. Whole
'Last;
61 type Rational
is record
63 Denominator
: Positive_Whole
;
66 Zero
: constant Rational
:= Rational
'(Numerator => 0,
69 No_Rational : constant Rational := Rational'(Numerator
=> 0,
71 -- Used to indicate an expression that cannot be interpreted as a rational
72 -- Returned value of the Create_Rational_From routine when parameter Expr
73 -- is not a static representation of a rational.
75 -- Rational constructors
77 function "+" (Right
: Whole
) return Rational
;
78 function GCD
(Left
, Right
: Whole
) return Int
;
79 function Reduce
(X
: Rational
) return Rational
;
81 -- Unary operator for Rational
83 function "-" (Right
: Rational
) return Rational
;
84 function "abs" (Right
: Rational
) return Rational
;
86 -- Rational operations for Rationals
88 function "+" (Left
, Right
: Rational
) return Rational
;
89 function "-" (Left
, Right
: Rational
) return Rational
;
90 function "*" (Left
, Right
: Rational
) return Rational
;
91 function "/" (Left
, Right
: Rational
) return Rational
;
97 Max_Number_Of_Dimensions
: constant := 7;
98 -- Maximum number of dimensions in a dimension system
100 High_Position_Bound
: constant := Max_Number_Of_Dimensions
;
101 Invalid_Position
: constant := 0;
102 Low_Position_Bound
: constant := 1;
104 subtype Dimension_Position
is
105 Nat
range Invalid_Position
.. High_Position_Bound
;
108 array (Dimension_Position
range
109 Low_Position_Bound
.. High_Position_Bound
) of Name_Id
;
110 -- A data structure used to store the names of all units within a system
112 No_Names
: constant Name_Array
:= (others => No_Name
);
115 array (Dimension_Position
range
116 Low_Position_Bound
.. High_Position_Bound
) of String_Id
;
117 -- A data structure used to store the symbols of all units within a system
119 No_Symbols
: constant Symbol_Array
:= (others => No_String
);
121 -- The following record should be documented field by field
123 type System_Type
is record
125 Unit_Names
: Name_Array
;
126 Unit_Symbols
: Symbol_Array
;
127 Dim_Symbols
: Symbol_Array
;
128 Count
: Dimension_Position
;
131 Null_System
: constant System_Type
:=
132 (Empty
, No_Names
, No_Symbols
, No_Symbols
, Invalid_Position
);
134 subtype System_Id
is Nat
;
136 -- The following table maps types to systems
138 package System_Table
is new Table
.Table
(
139 Table_Component_Type
=> System_Type
,
140 Table_Index_Type
=> System_Id
,
141 Table_Low_Bound
=> 1,
143 Table_Increment
=> 5,
144 Table_Name
=> "System_Table");
150 type Dimension_Type
is
151 array (Dimension_Position
range
152 Low_Position_Bound
.. High_Position_Bound
) of Rational
;
154 Null_Dimension
: constant Dimension_Type
:= (others => Zero
);
156 type Dimension_Table_Range
is range 0 .. 510;
157 function Dimension_Table_Hash
(Key
: Node_Id
) return Dimension_Table_Range
;
159 -- The following table associates nodes with dimensions
161 package Dimension_Table
is new
162 GNAT
.HTable
.Simple_HTable
163 (Header_Num
=> Dimension_Table_Range
,
164 Element
=> Dimension_Type
,
165 No_Element
=> Null_Dimension
,
167 Hash
=> Dimension_Table_Hash
,
174 type Symbol_Table_Range
is range 0 .. 510;
175 function Symbol_Table_Hash
(Key
: Entity_Id
) return Symbol_Table_Range
;
177 -- Each subtype with a dimension has a symbolic representation of the
178 -- related unit. This table establishes a relation between the subtype
181 package Symbol_Table
is new
182 GNAT
.HTable
.Simple_HTable
183 (Header_Num
=> Symbol_Table_Range
,
184 Element
=> String_Id
,
185 No_Element
=> No_String
,
187 Hash
=> Symbol_Table_Hash
,
190 -- The following array enumerates all contexts which may contain or
191 -- produce a dimension.
193 OK_For_Dimension
: constant array (Node_Kind
) of Boolean :=
194 (N_Attribute_Reference
=> True,
195 N_Expanded_Name
=> True,
196 N_Defining_Identifier
=> True,
197 N_Function_Call
=> True,
198 N_Identifier
=> True,
199 N_Indexed_Component
=> True,
200 N_Integer_Literal
=> True,
207 N_Op_Multiply
=> True,
210 N_Op_Subtract
=> True,
211 N_Qualified_Expression
=> True,
212 N_Real_Literal
=> True,
213 N_Selected_Component
=> True,
215 N_Type_Conversion
=> True,
216 N_Unchecked_Type_Conversion
=> True,
220 -----------------------
221 -- Local Subprograms --
222 -----------------------
224 procedure Analyze_Dimension_Assignment_Statement
(N
: Node_Id
);
225 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
226 -- dimensions of the left-hand side and the right-hand side of N match.
228 procedure Analyze_Dimension_Binary_Op
(N
: Node_Id
);
229 -- Subroutine of Analyze_Dimension for binary operators. Check the
230 -- dimensions of the right and the left operand permit the operation.
231 -- Then, evaluate the resulting dimensions for each binary operator.
233 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
);
234 -- Subroutine of Analyze_Dimension for component declaration. Check that
235 -- the dimensions of the type of N and of the expression match.
237 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
);
238 -- Subroutine of Analyze_Dimension for extended return statement. Check
239 -- that the dimensions of the returned type and of the returned object
242 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
);
243 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
245 -- N_Attribute_Reference
247 -- N_Indexed_Component
248 -- N_Qualified_Expression
249 -- N_Selected_Component
252 -- N_Unchecked_Type_Conversion
254 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
);
255 -- Subroutine of Analyze_Dimension for object declaration. Check that
256 -- the dimensions of the object type and the dimensions of the expression
257 -- (if expression is present) match. Note that when the expression is
258 -- a literal, no error is returned. This special case allows object
259 -- declaration such as: m : constant Length := 1.0;
261 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
);
262 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
263 -- the dimensions of the type and of the renamed object name of N match.
265 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
);
266 -- Subroutine of Analyze_Dimension for simple return statement
267 -- Check that the dimensions of the returned type and of the returned
270 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
);
271 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
272 -- dimensions from the parent type to the identifier of N. Note that if
273 -- both the identifier and the parent type of N are not dimensionless,
276 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
);
277 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
278 -- Abs operators, propagate the dimensions from the operand to N.
280 function Create_Rational_From
282 Complain
: Boolean) return Rational
;
283 -- Given an arbitrary expression Expr, return a valid rational if Expr can
284 -- be interpreted as a rational. Otherwise return No_Rational and also an
285 -- error message if Complain is set to True.
287 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
;
288 -- Return the dimension vector of node N
290 function Dimensions_Msg_Of
292 Description_Needed
: Boolean := False) return String;
293 -- Given a node N, return the dimension symbols of N, preceded by "has
294 -- dimension" if Description_Needed. if N is dimensionless, return "[]", or
295 -- "is dimensionless" if Description_Needed.
297 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
298 -- Issue a warning on the given numeric literal N to indicate the
299 -- compilateur made the assumption that the literal is not dimensionless
300 -- but has the dimension of Typ.
302 procedure Eval_Op_Expon_With_Rational_Exponent
304 Exponent_Value
: Rational
);
305 -- Evaluate the exponent it is a rational and the operand has a dimension
307 function Exists
(Dim
: Dimension_Type
) return Boolean;
308 -- Returns True iff Dim does not denote the null dimension
310 function Exists
(Str
: String_Id
) return Boolean;
311 -- Returns True iff Str does not denote No_String
313 function Exists
(Sys
: System_Type
) return Boolean;
314 -- Returns True iff Sys does not denote the null system
316 function From_Dim_To_Str_Of_Dim_Symbols
317 (Dims
: Dimension_Type
;
318 System
: System_Type
;
319 In_Error_Msg
: Boolean := False) return String_Id
;
320 -- Given a dimension vector and a dimension system, return the proper
321 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
322 -- will be used to issue an error message) then this routine has a special
323 -- handling for the insertion character asterisk * which must be precede by
324 -- a quote ' to to be placed literally into the message.
326 function From_Dim_To_Str_Of_Unit_Symbols
327 (Dims
: Dimension_Type
;
328 System
: System_Type
) return String_Id
;
329 -- Given a dimension vector and a dimension system, return the proper
330 -- string of unit symbols.
332 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean;
333 -- Return True if E is the package entity of System.Dim.Float_IO or
334 -- System.Dim.Integer_IO.
336 function Is_Invalid
(Position
: Dimension_Position
) return Boolean;
337 -- Return True if Pos denotes the invalid position
339 procedure Move_Dimensions
(From
: Node_Id
; To
: Node_Id
);
340 -- Copy dimension vector of From to To and delete dimension vector of From
342 procedure Remove_Dimensions
(N
: Node_Id
);
343 -- Remove the dimension vector of node N
345 procedure Set_Dimensions
(N
: Node_Id
; Val
: Dimension_Type
);
346 -- Associate a dimension vector with a node
348 procedure Set_Symbol
(E
: Entity_Id
; Val
: String_Id
);
349 -- Associate a symbol representation of a dimension vector with a subtype
351 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
;
352 -- Return the string that corresponds to the numeric litteral N as it
353 -- appears in the source.
355 function Symbol_Of
(E
: Entity_Id
) return String_Id
;
356 -- E denotes a subtype with a dimension. Return the symbol representation
357 -- of the dimension vector.
359 function System_Of
(E
: Entity_Id
) return System_Type
;
360 -- E denotes a type, return associated system of the type if it has one
366 function "+" (Right
: Whole
) return Rational
is
368 return Rational
'(Numerator => Right,
372 function "+" (Left, Right : Rational) return Rational is
373 R : constant Rational :=
374 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
+
375 Left
.Denominator
* Right
.Numerator
,
376 Denominator
=> Left
.Denominator
* Right
.Denominator
);
385 function "-" (Right
: Rational
) return Rational
is
387 return Rational
'(Numerator => -Right.Numerator,
388 Denominator => Right.Denominator);
391 function "-" (Left, Right : Rational) return Rational is
392 R : constant Rational :=
393 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
-
394 Left
.Denominator
* Right
.Numerator
,
395 Denominator
=> Left
.Denominator
* Right
.Denominator
);
405 function "*" (Left
, Right
: Rational
) return Rational
is
406 R
: constant Rational
:=
407 Rational
'(Numerator => Left.Numerator * Right.Numerator,
408 Denominator => Left.Denominator * Right.Denominator);
417 function "/" (Left, Right : Rational) return Rational is
418 R : constant Rational := abs Right;
419 L : Rational := Left;
422 if Right.Numerator < 0 then
423 L.Numerator := Whole (-Integer (L.Numerator));
426 return Reduce (Rational'(Numerator
=> L
.Numerator
* R
.Denominator
,
427 Denominator
=> L
.Denominator
* R
.Numerator
));
434 function "abs" (Right
: Rational
) return Rational
is
436 return Rational
'(Numerator => abs Right.Numerator,
437 Denominator => Right.Denominator);
440 ------------------------------
441 -- Analyze_Aspect_Dimension --
442 ------------------------------
444 -- with Dimension => (
445 -- [[Symbol =>] SYMBOL,]
447 -- [, DIMENSION_VALUE]
448 -- [, DIMENSION_VALUE]
449 -- [, DIMENSION_VALUE]
450 -- [, DIMENSION_VALUE]
451 -- [, DIMENSION_VALUE]
452 -- [, DIMENSION_VALUE]);
454 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
456 -- DIMENSION_VALUE ::=
458 -- | others => RATIONAL
459 -- | DISCRETE_CHOICE_LIST => RATIONAL
461 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
463 -- Note that when the dimensioned type is an integer type, then any
464 -- dimension value must be an integer literal.
466 procedure Analyze_Aspect_Dimension
471 Def_Id : constant Entity_Id := Defining_Identifier (N);
473 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
474 -- This array is used when processing ranges or Others_Choice as part of
475 -- the dimension aggregate.
477 Dimensions : Dimension_Type := Null_Dimension;
479 procedure Extract_Power
481 Position : Dimension_Position);
482 -- Given an expression with denotes a rational number, read the number
483 -- and associate it with Position in Dimensions.
485 function Position_In_System
487 System : System_Type) return Dimension_Position;
488 -- Given an identifier which denotes a dimension, return the position of
489 -- that dimension within System.
495 procedure Extract_Power
497 Position : Dimension_Position)
502 if Is_Integer_Type (Def_Id) then
503 -- Dimension value must be an integer literal
505 if Nkind (Expr) = N_Integer_Literal then
506 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
508 Error_Msg_N ("integer literal expected", Expr);
514 Dimensions (Position) := Create_Rational_From (Expr, True);
517 Processed (Position) := True;
520 ------------------------
521 -- Position_In_System --
522 ------------------------
524 function Position_In_System
526 System : System_Type) return Dimension_Position
528 Dimension_Name : constant Name_Id := Chars (Id);
531 for Position in System.Unit_Names'Range loop
532 if Dimension_Name = System.Unit_Names (Position) then
537 return Invalid_Position;
538 end Position_In_System;
545 Num_Choices : Nat := 0;
546 Num_Dimensions : Nat := 0;
547 Others_Seen : Boolean := False;
550 Symbol : String_Id := No_String;
551 Symbol_Expr : Node_Id;
552 System : System_Type;
556 -- Errors_Count is a count of errors detected by the compiler so far
557 -- just before the extraction of symbol, names and values in the
558 -- aggregate (Step 2).
560 -- At the end of the analysis, there is a check to verify that this
561 -- count equals to Serious_Errors_Detected i.e. no erros have been
562 -- encountered during the process. Otherwise the Dimension_Table is
565 -- Start of processing for Analyze_Aspect_Dimension
568 -- STEP 1: Legality of aspect
570 if Nkind (N) /= N_Subtype_Declaration then
571 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
575 Sub_Ind := Subtype_Indication (N);
576 Typ := Etype (Sub_Ind);
577 System := System_Of (Typ);
579 if Nkind (Sub_Ind) = N_Subtype_Indication then
581 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
585 -- The dimension declarations are useless if the parent type does not
586 -- declare a valid system.
588 if not Exists (System) then
590 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
594 if Nkind (Aggr) /= N_Aggregate then
595 Error_Msg_N ("aggregate expected", Aggr);
599 -- STEP 2: Symbol, Names and values extraction
601 -- Get the number of errors detected by the compiler so far
603 Errors_Count := Serious_Errors_Detected;
605 -- STEP 2a: Symbol extraction
607 -- The first entry in the aggregate may be the symbolic representation
610 -- Positional symbol argument
612 Symbol_Expr := First (Expressions (Aggr));
614 -- Named symbol argument
617 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
620 Symbol_Expr := Empty;
622 -- Component associations present
624 if Present (Component_Associations (Aggr)) then
625 Assoc := First (Component_Associations (Aggr));
626 Choice := First (Choices (Assoc));
628 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
630 -- Symbol component association is present
632 if Chars (Choice) = Name_Symbol then
633 Num_Choices := Num_Choices + 1;
634 Symbol_Expr := Expression (Assoc);
636 -- Verify symbol expression is a string or a character
638 if not Nkind_In (Symbol_Expr, N_Character_Literal,
641 Symbol_Expr := Empty;
643 ("symbol expression must be character or string",
647 -- Special error if no Symbol choice but expression is string
650 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
653 Num_Choices := Num_Choices + 1;
654 Error_Msg_N ("optional component Symbol expected, found&",
661 -- STEP 2b: Names and values extraction
663 -- Positional elements
665 Expr := First (Expressions (Aggr));
667 -- Skip the symbol expression when present
669 if Present (Symbol_Expr) and then Num_Choices = 0 then
673 Position := Low_Position_Bound;
674 while Present (Expr) loop
675 if Position > High_Position_Bound then
677 ("type& has more dimensions than system allows", Def_Id);
681 Extract_Power (Expr, Position);
683 Position := Position + 1;
684 Num_Dimensions := Num_Dimensions + 1;
691 Assoc := First (Component_Associations (Aggr));
693 -- Skip the symbol association when present
695 if Num_Choices = 1 then
699 while Present (Assoc) loop
700 Expr := Expression (Assoc);
702 Choice := First (Choices (Assoc));
703 while Present (Choice) loop
705 -- Identifier case: NAME => EXPRESSION
707 if Nkind (Choice) = N_Identifier then
708 Position := Position_In_System (Choice, System);
710 if Is_Invalid (Position) then
711 Error_Msg_N ("dimension name& not part of system", Choice);
713 Extract_Power (Expr, Position);
716 -- Range case: NAME .. NAME => EXPRESSION
718 elsif Nkind (Choice) = N_Range then
720 Low : constant Node_Id := Low_Bound (Choice);
721 High : constant Node_Id := High_Bound (Choice);
722 Low_Pos : Dimension_Position;
723 High_Pos : Dimension_Position;
726 if Nkind (Low) /= N_Identifier then
727 Error_Msg_N ("bound must denote a dimension name", Low);
729 elsif Nkind (High) /= N_Identifier then
730 Error_Msg_N ("bound must denote a dimension name", High);
733 Low_Pos := Position_In_System (Low, System);
734 High_Pos := Position_In_System (High, System);
736 if Is_Invalid (Low_Pos) then
737 Error_Msg_N ("dimension name& not part of system",
740 elsif Is_Invalid (High_Pos) then
741 Error_Msg_N ("dimension name& not part of system",
744 elsif Low_Pos > High_Pos then
745 Error_Msg_N ("expected low to high range", Choice);
748 for Position in Low_Pos .. High_Pos loop
749 Extract_Power (Expr, Position);
755 -- Others case: OTHERS => EXPRESSION
757 elsif Nkind (Choice) = N_Others_Choice then
758 if Present (Next (Choice)) or else Present (Prev (Choice)) then
760 ("OTHERS must appear alone in a choice list", Choice);
762 elsif Present (Next (Assoc)) then
764 ("OTHERS must appear last in an aggregate", Choice);
766 elsif Others_Seen then
767 Error_Msg_N ("multiple OTHERS not allowed", Choice);
770 -- Fill the non-processed dimensions with the default value
771 -- supplied by others.
773 for Position in Processed'Range loop
774 if not Processed (Position) then
775 Extract_Power (Expr, Position);
782 -- All other cases are erroneous declarations of dimension names
785 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
788 Num_Choices := Num_Choices + 1;
792 Num_Dimensions := Num_Dimensions + 1;
796 -- STEP 3: Consistency of system and dimensions
798 if Present (First (Expressions (Aggr)))
799 and then (First (Expressions (Aggr)) /= Symbol_Expr
800 or else Present (Next (Symbol_Expr)))
801 and then (Num_Choices > 1
802 or else (Num_Choices = 1 and then not Others_Seen))
805 ("named associations cannot follow positional associations", Aggr);
808 if Num_Dimensions > System.Count then
809 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
811 elsif Num_Dimensions < System.Count and then not Others_Seen then
812 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
815 -- STEP 4: Dimension symbol extraction
817 if Present (Symbol_Expr) then
818 if Nkind (Symbol_Expr) = N_Character_Literal then
820 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
821 Symbol := End_String;
824 Symbol := Strval (Symbol_Expr);
827 if String_Length (Symbol) = 0 then
828 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
832 -- STEP 5: Storage of extracted values
834 -- Check that no errors have been detected during the analysis
836 if Errors_Count = Serious_Errors_Detected then
838 -- Check for useless declaration
840 if Symbol = No_String and then not Exists (Dimensions) then
841 Error_Msg_N ("useless dimension declaration", Aggr);
844 if Symbol /= No_String then
845 Set_Symbol (Def_Id, Symbol);
848 if Exists (Dimensions) then
849 Set_Dimensions (Def_Id, Dimensions);
852 end Analyze_Aspect_Dimension;
854 -------------------------------------
855 -- Analyze_Aspect_Dimension_System --
856 -------------------------------------
858 -- with Dimension_System => (
868 -- [Unit_Name =>] IDENTIFIER,
869 -- [Unit_Symbol =>] SYMBOL,
870 -- [Dim_Symbol =>] SYMBOL)
872 procedure Analyze_Aspect_Dimension_System
877 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
878 -- Determine whether type declaration N denotes a numeric derived type
880 -------------------------------
881 -- Is_Derived_Numeric_Type --
882 -------------------------------
884 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
887 Nkind (N) = N_Full_Type_Declaration
888 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
889 and then Is_Numeric_Type
890 (Entity (Subtype_Indication (Type_Definition (N))));
891 end Is_Derived_Numeric_Type;
898 Dim_Symbol : Node_Id;
899 Dim_Symbols : Symbol_Array := No_Symbols;
900 Dim_System : System_Type := Null_System;
903 Unit_Names : Name_Array := No_Names;
904 Unit_Symbol : Node_Id;
905 Unit_Symbols : Symbol_Array := No_Symbols;
908 -- Errors_Count is a count of errors detected by the compiler so far
909 -- just before the extraction of names and symbols in the aggregate
912 -- At the end of the analysis, there is a check to verify that this
913 -- count equals Serious_Errors_Detected i.e. no errors have been
914 -- encountered during the process. Otherwise the System_Table is
917 -- Start of processing for Analyze_Aspect_Dimension_System
920 -- STEP 1: Legality of aspect
922 if not Is_Derived_Numeric_Type (N) then
924 ("aspect& must apply to numeric derived type declaration", N, Id);
928 if Nkind (Aggr) /= N_Aggregate then
929 Error_Msg_N ("aggregate expected", Aggr);
933 -- STEP 2: Structural verification of the dimension aggregate
935 if Present (Component_Associations (Aggr)) then
936 Error_Msg_N ("expected positional aggregate", Aggr);
940 -- STEP 3: Name and Symbol extraction
942 Dim_Aggr := First (Expressions (Aggr));
943 Errors_Count := Serious_Errors_Detected;
944 while Present (Dim_Aggr) loop
945 Position := Position + 1;
947 if Position > High_Position_Bound then
949 ("too many dimensions in system", Aggr);
953 if Nkind (Dim_Aggr) /= N_Aggregate then
954 Error_Msg_N ("aggregate expected", Dim_Aggr);
957 if Present (Component_Associations (Dim_Aggr))
958 and then Present (Expressions (Dim_Aggr))
960 Error_Msg_N ("mixed positional/named aggregate not allowed " &
964 -- Verify each dimension aggregate has three arguments
966 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
967 and then List_Length (Expressions (Dim_Aggr)) /= 3
970 ("three components expected in aggregate", Dim_Aggr);
973 -- Named dimension aggregate
975 if Present (Component_Associations (Dim_Aggr)) then
977 -- Check first argument denotes the unit name
979 Assoc := First (Component_Associations (Dim_Aggr));
980 Choice := First (Choices (Assoc));
981 Unit_Name := Expression (Assoc);
983 if Present (Next (Choice))
984 or else Nkind (Choice) /= N_Identifier
986 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
988 elsif Chars (Choice) /= Name_Unit_Name then
989 Error_Msg_N ("expected Unit_Name, found&", Choice);
992 -- Check the second argument denotes the unit symbol
995 Choice := First (Choices (Assoc));
996 Unit_Symbol := Expression (Assoc);
998 if Present (Next (Choice))
999 or else Nkind (Choice) /= N_Identifier
1001 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1003 elsif Chars (Choice) /= Name_Unit_Symbol then
1004 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1007 -- Check the third argument denotes the dimension symbol
1010 Choice := First (Choices (Assoc));
1011 Dim_Symbol := Expression (Assoc);
1013 if Present (Next (Choice))
1014 or else Nkind (Choice) /= N_Identifier
1016 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1018 elsif Chars (Choice) /= Name_Dim_Symbol then
1019 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1022 -- Positional dimension aggregate
1025 Unit_Name := First (Expressions (Dim_Aggr));
1026 Unit_Symbol := Next (Unit_Name);
1027 Dim_Symbol := Next (Unit_Symbol);
1030 -- Check the first argument for each dimension aggregate is
1033 if Nkind (Unit_Name) = N_Identifier then
1034 Unit_Names (Position) := Chars (Unit_Name);
1036 Error_Msg_N ("expected unit name", Unit_Name);
1039 -- Check the second argument for each dimension aggregate is
1040 -- a string or a character.
1045 N_Character_Literal)
1047 Error_Msg_N ("expected unit symbol (string or character)",
1053 if Nkind (Unit_Symbol) = N_String_Literal then
1054 Unit_Symbols (Position) := Strval (Unit_Symbol);
1061 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1062 Unit_Symbols (Position) := End_String;
1065 -- Verify that the string is not empty
1067 if String_Length (Unit_Symbols (Position)) = 0 then
1069 ("empty string not allowed here", Unit_Symbol);
1073 -- Check the third argument for each dimension aggregate is
1074 -- a string or a character.
1079 N_Character_Literal)
1081 Error_Msg_N ("expected dimension symbol (string or " &
1088 if Nkind (Dim_Symbol) = N_String_Literal then
1089 Dim_Symbols (Position) := Strval (Dim_Symbol);
1096 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1097 Dim_Symbols (Position) := End_String;
1100 -- Verify that the string is not empty
1102 if String_Length (Dim_Symbols (Position)) = 0 then
1104 ("empty string not allowed here", Dim_Symbol);
1113 -- STEP 4: Storage of extracted values
1115 -- Check that no errors have been detected during the analysis
1117 if Errors_Count = Serious_Errors_Detected then
1118 Dim_System.Type_Decl := N;
1119 Dim_System.Unit_Names := Unit_Names;
1120 Dim_System.Unit_Symbols := Unit_Symbols;
1121 Dim_System.Dim_Symbols := Dim_Symbols;
1122 Dim_System.Count := Position;
1123 System_Table.Append (Dim_System);
1125 end Analyze_Aspect_Dimension_System;
1127 -----------------------
1128 -- Analyze_Dimension --
1129 -----------------------
1131 -- This dispatch routine propagates dimensions for each node
1133 procedure Analyze_Dimension (N : Node_Id) is
1135 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1136 -- dimensions for nodes that don't come from source.
1138 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1143 when N_Assignment_Statement =>
1144 Analyze_Dimension_Assignment_Statement (N);
1147 Analyze_Dimension_Binary_Op (N);
1149 when N_Component_Declaration =>
1150 Analyze_Dimension_Component_Declaration (N);
1152 when N_Extended_Return_Statement =>
1153 Analyze_Dimension_Extended_Return_Statement (N);
1155 when N_Attribute_Reference |
1159 N_Indexed_Component |
1160 N_Qualified_Expression |
1161 N_Selected_Component |
1164 N_Unchecked_Type_Conversion =>
1165 Analyze_Dimension_Has_Etype (N);
1167 when N_Object_Declaration =>
1168 Analyze_Dimension_Object_Declaration (N);
1170 when N_Object_Renaming_Declaration =>
1171 Analyze_Dimension_Object_Renaming_Declaration (N);
1173 when N_Simple_Return_Statement =>
1174 if not Comes_From_Extended_Return_Statement (N) then
1175 Analyze_Dimension_Simple_Return_Statement (N);
1178 when N_Subtype_Declaration =>
1179 Analyze_Dimension_Subtype_Declaration (N);
1182 Analyze_Dimension_Unary_Op (N);
1184 when others => null;
1187 end Analyze_Dimension;
1189 ---------------------------------------
1190 -- Analyze_Dimension_Array_Aggregate --
1191 ---------------------------------------
1193 procedure Analyze_Dimension_Array_Aggregate
1195 Comp_Typ : Entity_Id)
1197 Comp_Ass : constant List_Id := Component_Associations (N);
1198 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1199 Exps : constant List_Id := Expressions (N);
1204 Error_Detected : Boolean := False;
1205 -- This flag is used in order to indicate if an error has been detected
1206 -- so far by the compiler in this routine.
1209 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1210 -- base type is not a dimensioned type.
1212 -- Note that here the original node must come from source since the
1213 -- original array aggregate may not have been entirely decorated.
1215 if Ada_Version < Ada_2012
1216 or else not Comes_From_Source (Original_Node (N))
1217 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1222 -- Check whether there is any positional component association
1224 if Is_Empty_List (Exps) then
1225 Comp := First (Comp_Ass);
1227 Comp := First (Exps);
1230 while Present (Comp) loop
1232 -- Get the expression from the component
1234 if Nkind (Comp) = N_Component_Association then
1235 Expr := Expression (Comp);
1240 -- Issue an error if the dimensions of the component type and the
1241 -- dimensions of the component mismatch.
1243 -- Note that we must ensure the expression has been fully analyzed
1244 -- since it may not be decorated at this point. We also don't want to
1245 -- issue the same error message multiple times on the same expression
1246 -- (may happen when an aggregate is converted into a positional
1249 if Comes_From_Source (Original_Node (Expr))
1250 and then Present (Etype (Expr))
1251 and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1252 and then Sloc (Comp) /= Sloc (Prev (Comp))
1254 -- Check if an error has already been encountered so far
1256 if not Error_Detected then
1257 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1258 Error_Detected := True;
1262 ("\expected dimension "
1263 & Dimensions_Msg_Of (Comp_Typ)
1265 & Dimensions_Msg_Of (Expr),
1269 -- Look at the named components right after the positional components
1271 if not Present (Next (Comp))
1272 and then List_Containing (Comp) = Exps
1274 Comp := First (Comp_Ass);
1279 end Analyze_Dimension_Array_Aggregate;
1281 --------------------------------------------
1282 -- Analyze_Dimension_Assignment_Statement --
1283 --------------------------------------------
1285 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1286 Lhs : constant Node_Id := Name (N);
1287 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1288 Rhs : constant Node_Id := Expression (N);
1289 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1291 procedure Error_Dim_Msg_For_Assignment_Statement
1295 -- Error using Error_Msg_N at node N. Output the dimensions of left
1296 -- and right hand sides.
1298 --------------------------------------------
1299 -- Error_Dim_Msg_For_Assignment_Statement --
1300 --------------------------------------------
1302 procedure Error_Dim_Msg_For_Assignment_Statement
1308 Error_Msg_N ("dimensions mismatch in assignment", N);
1309 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1310 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1311 end Error_Dim_Msg_For_Assignment_Statement;
1313 -- Start of processing for Analyze_Dimension_Assignment
1316 if Dims_Of_Lhs /= Dims_Of_Rhs then
1317 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1319 end Analyze_Dimension_Assignment_Statement;
1321 ---------------------------------
1322 -- Analyze_Dimension_Binary_Op --
1323 ---------------------------------
1325 -- Check and propagate the dimensions for binary operators
1326 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1328 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1329 N_Kind : constant Node_Kind := Nkind (N);
1331 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1332 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1333 -- dimensions of both operands.
1335 ---------------------------------
1336 -- Error_Dim_Msg_For_Binary_Op --
1337 ---------------------------------
1339 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1341 Error_Msg_NE ("both operands for operation& must have same " &
1345 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1346 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1347 end Error_Dim_Msg_For_Binary_Op;
1349 -- Start of processing for Analyze_Dimension_Binary_Op
1352 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1353 or else N_Kind in N_Multiplying_Operator
1354 or else N_Kind in N_Op_Compare
1357 L : constant Node_Id := Left_Opnd (N);
1358 Dims_Of_L : constant Dimension_Type := Dimensions_Of (L);
1359 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1360 R : constant Node_Id := Right_Opnd (N);
1361 Dims_Of_R : constant Dimension_Type := Dimensions_Of (R);
1362 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1363 Dims_Of_N : Dimension_Type := Null_Dimension;
1366 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1368 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1370 -- Check both operands have same dimension
1372 if Dims_Of_L /= Dims_Of_R then
1373 Error_Dim_Msg_For_Binary_Op (N, L, R);
1375 -- Check both operands are not dimensionless
1377 if Exists (Dims_Of_L) then
1378 Set_Dimensions (N, Dims_Of_L);
1382 -- N_Op_Multiply or N_Op_Divide case
1384 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1386 -- Check at least one operand is not dimensionless
1388 if L_Has_Dimensions or R_Has_Dimensions then
1390 -- Multiplication case
1392 -- Get both operands dimensions and add them
1394 if N_Kind = N_Op_Multiply then
1395 for Position in Dimension_Type'Range loop
1396 Dims_Of_N (Position) :=
1397 Dims_Of_L (Position) + Dims_Of_R (Position);
1402 -- Get both operands dimensions and subtract them
1405 for Position in Dimension_Type'Range loop
1406 Dims_Of_N (Position) :=
1407 Dims_Of_L (Position) - Dims_Of_R (Position);
1411 if Exists (Dims_Of_N) then
1412 Set_Dimensions (N, Dims_Of_N);
1416 -- Exponentiation case
1418 -- Note: a rational exponent is allowed for dimensioned operand
1420 elsif N_Kind = N_Op_Expon then
1422 -- Check the left operand is not dimensionless. Note that the
1423 -- value of the exponent must be known compile time. Otherwise,
1424 -- the exponentiation evaluation will return an error message.
1426 if L_Has_Dimensions then
1427 if not Compile_Time_Known_Value (R) then
1428 Error_Msg_N ("exponent of dimensioned operand must be " &
1429 "known at compile-time", N);
1433 Exponent_Value : Rational := Zero;
1436 -- Real operand case
1438 if Is_Real_Type (Etype (L)) then
1440 -- Define the exponent as a Rational number
1442 Exponent_Value := Create_Rational_From (R, False);
1444 -- Verify that the exponent cannot be interpreted
1445 -- as a rational, otherwise interpret the exponent
1448 if Exponent_Value = No_Rational then
1450 +Whole (UI_To_Int (Expr_Value (R)));
1453 -- Integer operand case.
1455 -- For integer operand, the exponent cannot be
1456 -- interpreted as a rational.
1459 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1462 for Position in Dimension_Type'Range loop
1463 Dims_Of_N (Position) :=
1464 Dims_Of_L (Position) * Exponent_Value;
1467 if Exists (Dims_Of_N) then
1468 Set_Dimensions (N, Dims_Of_N);
1475 -- For relational operations, only dimension checking is
1476 -- performed (no propagation).
1478 elsif N_Kind in N_Op_Compare then
1479 if (L_Has_Dimensions or R_Has_Dimensions)
1480 and then Dims_Of_L /= Dims_Of_R
1482 Error_Dim_Msg_For_Binary_Op (N, L, R);
1486 -- Removal of dimensions for each operands
1488 Remove_Dimensions (L);
1489 Remove_Dimensions (R);
1492 end Analyze_Dimension_Binary_Op;
1494 ----------------------------
1495 -- Analyze_Dimension_Call --
1496 ----------------------------
1498 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1499 Actuals : constant List_Id := Parameter_Associations (N);
1501 Dims_Of_Formal : Dimension_Type;
1503 Formal_Typ : Entity_Id;
1505 Error_Detected : Boolean := False;
1506 -- This flag is used in order to indicate if an error has been detected
1507 -- so far by the compiler in this routine.
1510 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1511 -- dimensions for calls that don't come from source.
1513 if Ada_Version < Ada_2012
1514 or else not Comes_From_Source (N)
1519 -- Check the dimensions of the actuals, if any
1521 if not Is_Empty_List (Actuals) then
1523 -- Special processing for elementary functions
1525 -- For Sqrt call, the resulting dimensions equal to half the
1526 -- dimensions of the actual. For all other elementary calls, this
1527 -- routine check that every actual is dimensionless.
1529 if Nkind (N) = N_Function_Call then
1530 Elementary_Function_Calls : declare
1531 Dims_Of_Call : Dimension_Type;
1532 Ent : Entity_Id := Nam;
1534 function Is_Elementary_Function_Entity
1535 (Sub_Id : Entity_Id) return Boolean;
1536 -- Given Sub_Id, the original subprogram entity, return True
1537 -- if call is to an elementary function (see Ada.Numerics.
1538 -- Generic_Elementary_Functions).
1540 -----------------------------------
1541 -- Is_Elementary_Function_Entity --
1542 -----------------------------------
1544 function Is_Elementary_Function_Entity
1545 (Sub_Id : Entity_Id) return Boolean
1547 Loc : constant Source_Ptr := Sloc (Sub_Id);
1550 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1556 (Cunit_Entity (Get_Source_Unit (Loc)),
1557 Ada_Numerics_Generic_Elementary_Functions);
1558 end Is_Elementary_Function_Entity;
1560 -- Start of processing for Elementary_Function_Calls
1563 -- Get original subprogram entity following the renaming chain
1565 if Present (Alias (Ent)) then
1569 -- Check the call is an Elementary function call
1571 if Is_Elementary_Function_Entity (Ent) then
1573 -- Sqrt function call case
1575 if Chars (Ent) = Name_Sqrt then
1576 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1578 -- Evaluates the resulting dimensions (i.e. half the
1579 -- dimensions of the actual).
1581 if Exists (Dims_Of_Call) then
1582 for Position in Dims_Of_Call'Range loop
1583 Dims_Of_Call (Position) :=
1584 Dims_Of_Call (Position) *
1585 Rational'(Numerator
=> 1, Denominator
=> 2);
1588 Set_Dimensions
(N
, Dims_Of_Call
);
1591 -- All other elementary functions case. Note that every
1592 -- actual here should be dimensionless.
1595 Actual
:= First_Actual
(N
);
1596 while Present
(Actual
) loop
1597 if Exists
(Dimensions_Of
(Actual
)) then
1599 -- Check if error has already been encountered
1601 if not Error_Detected
then
1602 Error_Msg_NE
("dimensions mismatch in call of&",
1604 Error_Detected
:= True;
1607 Error_Msg_N
("\expected dimension [], found " &
1608 Dimensions_Msg_Of
(Actual
),
1612 Next_Actual
(Actual
);
1616 -- Nothing more to do for elementary functions
1620 end Elementary_Function_Calls
;
1623 -- General case. Check, for each parameter, the dimensions of the
1624 -- actual and its corresponding formal match. Otherwise, complain.
1626 Actual
:= First_Actual
(N
);
1627 Formal
:= First_Formal
(Nam
);
1629 while Present
(Formal
) loop
1630 Formal_Typ
:= Etype
(Formal
);
1631 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1633 -- If the formal is not dimensionless, check dimensions of formal
1634 -- and actual match. Otherwise, complain.
1636 if Exists
(Dims_Of_Formal
)
1637 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1639 -- Check if an error has already been encountered so far
1641 if not Error_Detected
then
1642 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1643 Error_Detected
:= True;
1647 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1648 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1651 Next_Actual
(Actual
);
1652 Next_Formal
(Formal
);
1656 -- For function calls, propagate the dimensions from the returned type
1658 if Nkind
(N
) = N_Function_Call
then
1659 Analyze_Dimension_Has_Etype
(N
);
1661 end Analyze_Dimension_Call
;
1663 ---------------------------------------------
1664 -- Analyze_Dimension_Component_Declaration --
1665 ---------------------------------------------
1667 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1668 Expr
: constant Node_Id
:= Expression
(N
);
1669 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1670 Etyp
: constant Entity_Id
:= Etype
(Id
);
1671 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1672 Dims_Of_Expr
: Dimension_Type
;
1674 procedure Error_Dim_Msg_For_Component_Declaration
1678 -- Error using Error_Msg_N at node N. Output the dimensions of the
1679 -- type Etyp and the expression Expr of N.
1681 ---------------------------------------------
1682 -- Error_Dim_Msg_For_Component_Declaration --
1683 ---------------------------------------------
1685 procedure Error_Dim_Msg_For_Component_Declaration
1690 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1691 Error_Msg_N
("\expected dimension "
1692 & Dimensions_Msg_Of
(Etyp
)
1694 & Dimensions_Msg_Of
(Expr
),
1696 end Error_Dim_Msg_For_Component_Declaration
;
1698 -- Start of processing for Analyze_Dimension_Component_Declaration
1701 -- Expression is present
1703 if Present
(Expr
) then
1704 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1706 -- Check dimensions match
1708 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1709 -- Numeric literal case. Issue a warning if the object type is not
1710 -- dimensionless to indicate the literal is treated as if its
1711 -- dimension matches the type dimension.
1713 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1716 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1718 -- Issue a dimension mismatch error for all other cases
1721 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1725 end Analyze_Dimension_Component_Declaration
;
1727 -------------------------------------------------
1728 -- Analyze_Dimension_Extended_Return_Statement --
1729 -------------------------------------------------
1731 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1732 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1733 Return_Etyp
: constant Entity_Id
:=
1734 Etype
(Return_Applies_To
(Return_Ent
));
1735 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1736 Return_Obj_Decl
: Node_Id
;
1737 Return_Obj_Id
: Entity_Id
;
1738 Return_Obj_Typ
: Entity_Id
;
1740 procedure Error_Dim_Msg_For_Extended_Return_Statement
1742 Return_Etyp
: Entity_Id
;
1743 Return_Obj_Typ
: Entity_Id
);
1744 -- Error using Error_Msg_N at node N. Output the dimensions of the
1745 -- returned type Return_Etyp and the returned object type Return_Obj_Typ
1748 -------------------------------------------------
1749 -- Error_Dim_Msg_For_Extended_Return_Statement --
1750 -------------------------------------------------
1752 procedure Error_Dim_Msg_For_Extended_Return_Statement
1754 Return_Etyp
: Entity_Id
;
1755 Return_Obj_Typ
: Entity_Id
)
1758 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1759 Error_Msg_N
("\expected dimension "
1760 & Dimensions_Msg_Of
(Return_Etyp
)
1762 & Dimensions_Msg_Of
(Return_Obj_Typ
),
1764 end Error_Dim_Msg_For_Extended_Return_Statement
;
1766 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1769 if Present
(Return_Obj_Decls
) then
1770 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1771 while Present
(Return_Obj_Decl
) loop
1772 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1773 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1775 if Is_Return_Object
(Return_Obj_Id
) then
1776 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1778 -- Issue an error message if dimensions mismatch
1780 if Dimensions_Of
(Return_Etyp
) /=
1781 Dimensions_Of
(Return_Obj_Typ
)
1783 Error_Dim_Msg_For_Extended_Return_Statement
1784 (N
, Return_Etyp
, Return_Obj_Typ
);
1790 Next
(Return_Obj_Decl
);
1793 end Analyze_Dimension_Extended_Return_Statement
;
1795 -----------------------------------------------------
1796 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1797 -----------------------------------------------------
1799 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1801 Comp_Id
: Entity_Id
;
1802 Comp_Typ
: Entity_Id
;
1805 Error_Detected
: Boolean := False;
1806 -- This flag is used in order to indicate if an error has been detected
1807 -- so far by the compiler in this routine.
1810 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1811 -- dimensions for aggregates that don't come from source.
1813 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
1817 Comp
:= First
(Component_Associations
(N
));
1818 while Present
(Comp
) loop
1819 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1820 Comp_Typ
:= Etype
(Comp_Id
);
1822 -- Check the component type is either a dimensioned type or a
1823 -- dimensioned subtype.
1825 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1826 Expr
:= Expression
(Comp
);
1828 -- Issue an error if the dimensions of the component type and the
1829 -- dimensions of the component mismatch.
1831 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
1833 -- Check if an error has already been encountered so far
1835 if not Error_Detected
then
1837 -- Extension aggregate case
1839 if Nkind
(N
) = N_Extension_Aggregate
then
1841 ("dimensions mismatch in extension aggregate", N
);
1843 -- Record aggregate case
1847 ("dimensions mismatch in record aggregate", N
);
1850 Error_Detected
:= True;
1854 ("\expected dimension "
1855 & Dimensions_Msg_Of
(Comp_Typ
)
1857 & Dimensions_Msg_Of
(Expr
),
1864 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
1866 -------------------------------
1867 -- Analyze_Dimension_Formals --
1868 -------------------------------
1870 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
1871 Dims_Of_Typ
: Dimension_Type
;
1876 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1877 -- dimensions for sub specs that don't come from source.
1879 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
1883 Formal
:= First
(Formals
);
1884 while Present
(Formal
) loop
1885 Typ
:= Parameter_Type
(Formal
);
1886 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
1888 if Exists
(Dims_Of_Typ
) then
1890 Expr
: constant Node_Id
:= Expression
(Formal
);
1893 -- Issue a warning if Expr is a numeric literal and if its
1894 -- dimensions differ with the dimensions of the formal type.
1897 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
1898 and then Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1901 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
1908 end Analyze_Dimension_Formals
;
1910 ---------------------------------
1911 -- Analyze_Dimension_Has_Etype --
1912 ---------------------------------
1914 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
1915 Etyp
: constant Entity_Id
:= Etype
(N
);
1916 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
1919 -- General case. Propagation of the dimensions from the type
1921 if Exists
(Dims_Of_Etyp
) then
1922 Set_Dimensions
(N
, Dims_Of_Etyp
);
1924 -- Identifier case. Propagate the dimensions from the entity for
1925 -- identifier whose entity is a non-dimensionless constant.
1927 elsif Nkind
(N
) = N_Identifier
then
1928 Analyze_Dimension_Identifier
: declare
1929 Id
: constant Entity_Id
:= Entity
(N
);
1931 if Ekind
(Id
) = E_Constant
1932 and then Exists
(Dimensions_Of
(Id
))
1934 Set_Dimensions
(N
, Dimensions_Of
(Id
));
1936 end Analyze_Dimension_Identifier
;
1938 -- Attribute reference case. Propagate the dimensions from the prefix.
1940 elsif Nkind
(N
) = N_Attribute_Reference
1941 and then Has_Dimension_System
(Base_Type
(Etyp
))
1943 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
1945 -- Check the prefix is not dimensionless
1947 if Exists
(Dims_Of_Etyp
) then
1948 Set_Dimensions
(N
, Dims_Of_Etyp
);
1952 -- Removal of dimensions in expression
1955 when N_Attribute_Reference |
1956 N_Indexed_Component
=>
1959 Exprs
: constant List_Id
:= Expressions
(N
);
1962 if Present
(Exprs
) then
1963 Expr
:= First
(Exprs
);
1964 while Present
(Expr
) loop
1965 Remove_Dimensions
(Expr
);
1971 when N_Qualified_Expression |
1973 N_Unchecked_Type_Conversion
=>
1974 Remove_Dimensions
(Expression
(N
));
1976 when N_Selected_Component
=>
1977 Remove_Dimensions
(Selector_Name
(N
));
1979 when others => null;
1981 end Analyze_Dimension_Has_Etype
;
1983 ------------------------------------------
1984 -- Analyze_Dimension_Object_Declaration --
1985 ------------------------------------------
1987 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
1988 Expr
: constant Node_Id
:= Expression
(N
);
1989 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1990 Etyp
: constant Entity_Id
:= Etype
(Id
);
1991 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1992 Dim_Of_Expr
: Dimension_Type
;
1994 procedure Error_Dim_Msg_For_Object_Declaration
1998 -- Error using Error_Msg_N at node N. Output the dimensions of the
1999 -- type Etyp and of the expression Expr.
2001 ------------------------------------------
2002 -- Error_Dim_Msg_For_Object_Declaration --
2003 ------------------------------------------
2005 procedure Error_Dim_Msg_For_Object_Declaration
2010 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2012 ("\expected dimension "
2013 & Dimensions_Msg_Of
(Etyp
)
2015 & Dimensions_Msg_Of
(Expr
),
2017 end Error_Dim_Msg_For_Object_Declaration
;
2019 -- Start of processing for Analyze_Dimension_Object_Declaration
2022 -- Expression is present
2024 if Present
(Expr
) then
2025 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2027 -- Check dimensions match
2029 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2031 -- Numeric literal case. Issue a warning if the object type is not
2032 -- dimensionless to indicate the literal is treated as if its
2033 -- dimension matches the type dimension.
2035 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2038 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2040 -- Case of object is a constant whose type is a dimensioned type
2042 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2044 -- Propagate dimension from expression to object entity
2046 Set_Dimensions
(Id
, Dim_Of_Expr
);
2048 -- For all other cases, issue an error message
2051 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2055 -- Removal of dimensions in expression
2057 Remove_Dimensions
(Expr
);
2059 end Analyze_Dimension_Object_Declaration
;
2061 ---------------------------------------------------
2062 -- Analyze_Dimension_Object_Renaming_Declaration --
2063 ---------------------------------------------------
2065 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2066 Renamed_Name
: constant Node_Id
:= Name
(N
);
2067 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2069 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2072 Renamed_Name
: Node_Id
);
2073 -- Error using Error_Msg_N at node N. Output the dimensions of
2074 -- Sub_Mark and of Renamed_Name.
2076 ---------------------------------------------------
2077 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2078 ---------------------------------------------------
2080 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2083 Renamed_Name
: Node_Id
) is
2085 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2087 ("\expected dimension "
2088 & Dimensions_Msg_Of
(Sub_Mark
)
2090 & Dimensions_Msg_Of
(Renamed_Name
),
2092 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2094 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2097 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2098 Error_Dim_Msg_For_Object_Renaming_Declaration
2099 (N
, Sub_Mark
, Renamed_Name
);
2101 end Analyze_Dimension_Object_Renaming_Declaration
;
2103 -----------------------------------------------
2104 -- Analyze_Dimension_Simple_Return_Statement --
2105 -----------------------------------------------
2107 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2108 Expr
: constant Node_Id
:= Expression
(N
);
2109 Dims_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2110 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2111 Return_Etyp
: constant Entity_Id
:=
2112 Etype
(Return_Applies_To
(Return_Ent
));
2113 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2114 Dimensions_Of
(Return_Etyp
);
2116 procedure Error_Dim_Msg_For_Simple_Return_Statement
2118 Return_Etyp
: Entity_Id
;
2120 -- Error using Error_Msg_N at node N. Output the dimensions of the
2121 -- returned type Return_Etyp and the returned expression Expr of N.
2123 -----------------------------------------------
2124 -- Error_Dim_Msg_For_Simple_Return_Statement --
2125 -----------------------------------------------
2127 procedure Error_Dim_Msg_For_Simple_Return_Statement
2129 Return_Etyp
: Entity_Id
;
2133 Error_Msg_N
("dimensions mismatch in return statement", N
);
2135 ("\expected dimension "
2136 & Dimensions_Msg_Of
(Return_Etyp
)
2138 & Dimensions_Msg_Of
(Expr
),
2140 end Error_Dim_Msg_For_Simple_Return_Statement
;
2142 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2145 if Dims_Of_Return_Etyp
/= Dims_Of_Expr
then
2146 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2147 Remove_Dimensions
(Expr
);
2149 end Analyze_Dimension_Simple_Return_Statement
;
2151 -------------------------------------------
2152 -- Analyze_Dimension_Subtype_Declaration --
2153 -------------------------------------------
2155 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2156 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2157 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2158 Dims_Of_Etyp
: Dimension_Type
;
2162 -- No constraint case in subtype declaration
2164 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2165 Etyp
:= Etype
(Subtype_Indication
(N
));
2166 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2168 if Exists
(Dims_Of_Etyp
) then
2170 -- If subtype already has a dimension (from Aspect_Dimension),
2171 -- it cannot inherit a dimension from its subtype.
2173 if Exists
(Dims_Of_Id
) then
2175 ("subtype& already" & Dimensions_Msg_Of
(Id
, True), N
);
2178 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2179 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2183 -- Constraint present in subtype declaration
2186 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2187 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2189 if Exists
(Dims_Of_Etyp
) then
2190 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2191 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2194 end Analyze_Dimension_Subtype_Declaration
;
2196 --------------------------------
2197 -- Analyze_Dimension_Unary_Op --
2198 --------------------------------
2200 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2203 when N_Op_Plus | N_Op_Minus | N_Op_Abs
=>
2205 R
: constant Node_Id
:= Right_Opnd
(N
);
2208 -- Propagate the dimension if the operand is not dimensionless
2210 Move_Dimensions
(R
, N
);
2213 when others => null;
2216 end Analyze_Dimension_Unary_Op
;
2218 ---------------------
2219 -- Copy_Dimensions --
2220 ---------------------
2222 procedure Copy_Dimensions
(From
, To
: Node_Id
) is
2223 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2226 -- Ignore if not Ada 2012 or beyond
2228 if Ada_Version
< Ada_2012
then
2231 -- For Ada 2012, Copy the dimension of 'From to 'To'
2233 elsif Exists
(Dims_Of_From
) then
2234 Set_Dimensions
(To
, Dims_Of_From
);
2236 end Copy_Dimensions
;
2238 --------------------------
2239 -- Create_Rational_From --
2240 --------------------------
2242 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2244 -- A rational number is a number that can be expressed as the quotient or
2245 -- fraction a/b of two integers, where b is non-zero positive.
2247 function Create_Rational_From
2249 Complain
: Boolean) return Rational
2251 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2252 Result
: Rational
:= No_Rational
;
2254 function Process_Minus
(N
: Node_Id
) return Rational
;
2255 -- Create a rational from a N_Op_Minus node
2257 function Process_Divide
(N
: Node_Id
) return Rational
;
2258 -- Create a rational from a N_Op_Divide node
2260 function Process_Literal
(N
: Node_Id
) return Rational
;
2261 -- Create a rational from a N_Integer_Literal node
2267 function Process_Minus
(N
: Node_Id
) return Rational
is
2268 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2272 -- Operand is an integer literal
2274 if Nkind
(Right
) = N_Integer_Literal
then
2275 Result
:= -Process_Literal
(Right
);
2277 -- Operand is a divide operator
2279 elsif Nkind
(Right
) = N_Op_Divide
then
2280 Result
:= -Process_Divide
(Right
);
2283 Result
:= No_Rational
;
2289 --------------------
2290 -- Process_Divide --
2291 --------------------
2293 function Process_Divide
(N
: Node_Id
) return Rational
is
2294 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2295 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2296 Left_Rat
: Rational
;
2297 Result
: Rational
:= No_Rational
;
2298 Right_Rat
: Rational
;
2301 -- Both left and right operands are an integer literal
2303 if Nkind
(Left
) = N_Integer_Literal
2304 and then Nkind
(Right
) = N_Integer_Literal
2306 Left_Rat
:= Process_Literal
(Left
);
2307 Right_Rat
:= Process_Literal
(Right
);
2308 Result
:= Left_Rat
/ Right_Rat
;
2314 ---------------------
2315 -- Process_Literal --
2316 ---------------------
2318 function Process_Literal
(N
: Node_Id
) return Rational
is
2320 return +Whole
(UI_To_Int
(Intval
(N
)));
2321 end Process_Literal
;
2323 -- Start of processing for Create_Rational_From
2326 -- Check the expression is either a division of two integers or an
2327 -- integer itself. Note that the check applies to the original node
2328 -- since the node could have already been rewritten.
2330 -- Integer literal case
2332 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2333 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2335 -- Divide operator case
2337 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2338 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2340 -- Minus operator case
2342 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2343 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2346 -- When Expr cannot be interpreted as a rational and Complain is true,
2347 -- generate an error message.
2349 if Complain
and then Result
= No_Rational
then
2350 Error_Msg_N
("rational expected", Expr
);
2354 end Create_Rational_From
;
2360 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2362 return Dimension_Table
.Get
(N
);
2365 -----------------------
2366 -- Dimensions_Msg_Of --
2367 -----------------------
2369 function Dimensions_Msg_Of
2371 Description_Needed
: Boolean := False) return String
2373 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2374 Dimensions_Msg
: Name_Id
;
2375 System
: System_Type
;
2378 -- Initialization of Name_Buffer
2382 -- N is not dimensionless
2384 if Exists
(Dims_Of_N
) then
2385 System
:= System_Of
(Base_Type
(Etype
(N
)));
2387 -- When Description_Needed, add to string "has dimension " before the
2388 -- actual dimension.
2390 if Description_Needed
then
2391 Add_Str_To_Name_Buffer
("has dimension ");
2394 Add_String_To_Name_Buffer
2395 (From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2397 -- N is dimensionless
2399 -- When Description_Needed, return "is dimensionless"
2401 elsif Description_Needed
then
2402 Add_Str_To_Name_Buffer
("is dimensionless");
2404 -- Otherwise, return "[]"
2407 Add_Str_To_Name_Buffer
("[]");
2410 Dimensions_Msg
:= Name_Find
;
2411 return Get_Name_String
(Dimensions_Msg
);
2412 end Dimensions_Msg_Of
;
2414 --------------------------
2415 -- Dimension_Table_Hash --
2416 --------------------------
2418 function Dimension_Table_Hash
2419 (Key
: Node_Id
) return Dimension_Table_Range
2422 return Dimension_Table_Range
(Key
mod 511);
2423 end Dimension_Table_Hash
;
2425 -------------------------------------
2426 -- Dim_Warning_For_Numeric_Literal --
2427 -------------------------------------
2429 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2431 -- Initialize name buffer
2435 Add_String_To_Name_Buffer
(String_From_Numeric_Literal
(N
));
2437 -- Insert a blank between the literal and the symbol
2438 Add_Str_To_Name_Buffer
(" ");
2440 Add_String_To_Name_Buffer
(Symbol_Of
(Typ
));
2442 Error_Msg_Name_1
:= Name_Find
;
2443 Error_Msg_N
("?assumed to be%%", N
);
2444 end Dim_Warning_For_Numeric_Literal
;
2446 ----------------------------------------
2447 -- Eval_Op_Expon_For_Dimensioned_Type --
2448 ----------------------------------------
2450 -- Evaluate the expon operator for real dimensioned type.
2452 -- Note that if the exponent is an integer (denominator = 1) the node is
2453 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2455 procedure Eval_Op_Expon_For_Dimensioned_Type
2459 R
: constant Node_Id
:= Right_Opnd
(N
);
2460 R_Value
: Rational
:= No_Rational
;
2463 if Is_Real_Type
(Btyp
) then
2464 R_Value
:= Create_Rational_From
(R
, False);
2467 -- Check that the exponent is not an integer
2469 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2470 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2474 end Eval_Op_Expon_For_Dimensioned_Type
;
2476 ------------------------------------------
2477 -- Eval_Op_Expon_With_Rational_Exponent --
2478 ------------------------------------------
2480 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2481 -- Rational and not only an Integer like for dimensionless operands. For
2482 -- that particular case, the left operand is rewritten as a function call
2483 -- using the function Expon_LLF from s-llflex.ads.
2485 procedure Eval_Op_Expon_With_Rational_Exponent
2487 Exponent_Value
: Rational
)
2489 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2490 L
: constant Node_Id
:= Left_Opnd
(N
);
2491 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2492 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2493 Loc
: constant Source_Ptr
:= Sloc
(N
);
2496 Dim_Power
: Rational
;
2497 List_Of_Dims
: List_Id
;
2498 New_Aspect
: Node_Id
;
2499 New_Aspects
: List_Id
;
2502 New_Subtyp_Decl_For_L
: Node_Id
;
2503 System
: System_Type
;
2506 -- Case when the operand is not dimensionless
2508 if Exists
(Dims_Of_N
) then
2510 -- Get the corresponding System_Type to know the exact number of
2511 -- dimensions in the system.
2513 System
:= System_Of
(Btyp_Of_L
);
2515 -- Generation of a new subtype with the proper dimensions
2517 -- In order to rewrite the operator as a type conversion, a new
2518 -- dimensioned subtype with the resulting dimensions of the
2519 -- exponentiation must be created.
2523 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2524 -- System : constant System_Id :=
2525 -- Get_Dimension_System_Id (Btyp_Of_L);
2526 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2527 -- Dimension_Systems.Table (System).Dimension_Count;
2529 -- subtype T is Btyp_Of_L
2532 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2533 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2535 -- Dims_Of_N (Num_Of_Dims).Numerator /
2536 -- Dims_Of_N (Num_Of_Dims).Denominator);
2538 -- Step 1: Generate the new aggregate for the aspect Dimension
2540 New_Aspects
:= Empty_List
;
2541 List_Of_Dims
:= New_List
;
2543 for Position
in Dims_Of_N
'First .. System
.Count
loop
2544 Dim_Power
:= Dims_Of_N
(Position
);
2545 Append_To
(List_Of_Dims
,
2546 Make_Op_Divide
(Loc
,
2548 Make_Integer_Literal
(Loc
,
2549 Int
(Dim_Power
.Numerator
)),
2551 Make_Integer_Literal
(Loc
,
2552 Int
(Dim_Power
.Denominator
))));
2555 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2558 Make_Aspect_Specification
(Loc
,
2559 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2560 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2562 -- Step 3: Make a temporary identifier for the new subtype
2564 New_Id
:= Make_Temporary
(Loc
, 'T');
2565 Set_Is_Internal
(New_Id
);
2567 -- Step 4: Declaration of the new subtype
2569 New_Subtyp_Decl_For_L
:=
2570 Make_Subtype_Declaration
(Loc
,
2571 Defining_Identifier
=> New_Id
,
2572 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2574 Append
(New_Aspect
, New_Aspects
);
2575 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2576 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2578 Analyze
(New_Subtyp_Decl_For_L
);
2580 -- Case where the operand is dimensionless
2583 New_Id
:= Btyp_Of_L
;
2586 -- Replacement of N by New_N
2590 -- Actual_1 := Long_Long_Float (L),
2592 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2593 -- Long_Long_Float (Exponent_Value.Denominator);
2595 -- (T (Expon_LLF (Actual_1, Actual_2)));
2597 -- where T is the subtype declared in step 1
2599 -- The node is rewritten as a type conversion
2601 -- Step 1: Creation of the two parameters of Expon_LLF function call
2604 Make_Type_Conversion
(Loc
,
2605 Subtype_Mark
=> New_Reference_To
(Standard_Long_Long_Float
, Loc
),
2606 Expression
=> Relocate_Node
(L
));
2609 Make_Op_Divide
(Loc
,
2611 Make_Real_Literal
(Loc
,
2612 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2614 Make_Real_Literal
(Loc
,
2615 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2617 -- Step 2: Creation of New_N
2620 Make_Type_Conversion
(Loc
,
2621 Subtype_Mark
=> New_Reference_To
(New_Id
, Loc
),
2623 Make_Function_Call
(Loc
,
2624 Name
=> New_Reference_To
(RTE
(RE_Expon_LLF
), Loc
),
2625 Parameter_Associations
=> New_List
(
2626 Actual_1
, Actual_2
)));
2628 -- Step 3: Rewrite N with the result
2631 Set_Etype
(N
, New_Id
);
2632 Analyze_And_Resolve
(N
, New_Id
);
2633 end Eval_Op_Expon_With_Rational_Exponent
;
2639 function Exists
(Dim
: Dimension_Type
) return Boolean is
2641 return Dim
/= Null_Dimension
;
2644 function Exists
(Str
: String_Id
) return Boolean is
2646 return Str
/= No_String
;
2649 function Exists
(Sys
: System_Type
) return Boolean is
2651 return Sys
/= Null_System
;
2654 ---------------------------------
2655 -- Expand_Put_Call_With_Symbol --
2656 ---------------------------------
2658 -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2659 -- (System.Dim.Integer_IO), the default string parameter must be rewritten
2660 -- to include the unit symbols (resp. dimension symbols) in the output
2661 -- of a dimensioned object. Note that if a value is already supplied for
2662 -- parameter Symbol, this routine doesn't do anything.
2664 -- Case 1. Item is dimensionless
2666 -- * Put : Item appears without a suffix
2668 -- * Put_Dim_Of : the output is []
2670 -- Obj : Mks_Type := 2.6;
2671 -- Put (Obj, 1, 1, 0);
2672 -- Put_Dim_Of (Obj);
2674 -- The corresponding outputs are:
2678 -- Case 2. Item has a dimension
2680 -- * Put : If the type of Item is a dimensioned subtype whose
2681 -- symbol is not empty, then the symbol appears as a
2682 -- suffix. Otherwise, a new string is created and appears
2683 -- as a suffix of Item. This string results in the
2684 -- successive concatanations between each unit symbol
2685 -- raised by its corresponding dimension power from the
2686 -- dimensions of Item.
2688 -- * Put_Dim_Of : The output is a new string resulting in the successive
2689 -- concatanations between each dimension symbol raised by
2690 -- its corresponding dimension power from the dimensions of
2693 -- subtype Random is Mks_Type
2700 -- Obj : Random := 5.0;
2702 -- Put_Dim_Of (Obj);
2704 -- The corresponding outputs are:
2705 -- $5.0 m**3.cd**(-1)
2708 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
2709 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2710 Loc
: constant Source_Ptr
:= Sloc
(N
);
2711 Name_Call
: constant Node_Id
:= Name
(N
);
2712 New_Actuals
: constant List_Id
:= New_List
;
2714 Dims_Of_Actual
: Dimension_Type
;
2716 New_Str_Lit
: Node_Id
:= Empty
;
2717 Symbols
: String_Id
;
2719 Is_Put_Dim_Of
: Boolean := False;
2720 -- This flag is used in order to differentiate routines Put and
2721 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2722 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2724 function Has_Symbols
return Boolean;
2725 -- Return True if the current Put call already has a parameter
2726 -- association for parameter "Symbols" with the correct string of
2729 function Is_Procedure_Put_Call
return Boolean;
2730 -- Return True if the current call is a call of an instantiation of a
2731 -- procedure Put defined in the package System.Dim.Float_IO and
2732 -- System.Dim.Integer_IO.
2734 function Item_Actual
return Node_Id
;
2735 -- Return the item actual parameter node in the output call
2741 function Has_Symbols
return Boolean is
2743 Actual_Str
: Node_Id
;
2746 Actual
:= First
(Actuals
);
2748 -- Look for a symbols parameter association in the list of actuals
2750 while Present
(Actual
) loop
2752 -- Positional parameter association case when the actual is a
2755 if Nkind
(Actual
) = N_String_Literal
then
2756 Actual_Str
:= Actual
;
2758 -- Named parameter association case when selector name is Symbol
2760 elsif Nkind
(Actual
) = N_Parameter_Association
2761 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
2763 Actual_Str
:= Explicit_Actual_Parameter
(Actual
);
2765 -- Ignore all other cases
2768 Actual_Str
:= Empty
;
2771 if Present
(Actual_Str
) then
2773 -- Return True if the actual comes from source or if the string
2774 -- of symbols doesn't have the default value (i.e. it is "").
2776 if Comes_From_Source
(Actual
)
2777 or else String_Length
(Strval
(Actual_Str
)) /= 0
2779 -- Complain only if the actual comes from source or if it
2780 -- hasn't been fully analyzed yet.
2782 if Comes_From_Source
(Actual
)
2783 or else not Analyzed
(Actual
)
2785 Error_Msg_N
("Symbol parameter should not be provided",
2787 Error_Msg_N
("\reserved for compiler use only", Actual
);
2800 -- At this point, the call has no parameter association. Look to the
2801 -- last actual since the symbols parameter is the last one.
2803 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
2806 ---------------------------
2807 -- Is_Procedure_Put_Call --
2808 ---------------------------
2810 function Is_Procedure_Put_Call
return Boolean is
2815 -- There are three different Put (resp. Put_Dim_Of) routines in each
2816 -- generic dim IO package. Verify the current procedure call is one
2819 if Is_Entity_Name
(Name_Call
) then
2820 Ent
:= Entity
(Name_Call
);
2822 -- Get the original subprogram entity following the renaming chain
2824 if Present
(Alias
(Ent
)) then
2830 -- Check the name of the entity subprogram is Put (resp.
2831 -- Put_Dim_Of) and verify this entity is located in either
2832 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2834 if Loc
> No_Location
2835 and then Is_Dim_IO_Package_Entity
2836 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
2838 if Chars
(Ent
) = Name_Put_Dim_Of
then
2839 Is_Put_Dim_Of
:= True;
2842 elsif Chars
(Ent
) = Name_Put
then
2849 end Is_Procedure_Put_Call
;
2855 function Item_Actual
return Node_Id
is
2859 -- Look for the item actual as a parameter association
2861 Actual
:= First
(Actuals
);
2862 while Present
(Actual
) loop
2863 if Nkind
(Actual
) = N_Parameter_Association
2864 and then Chars
(Selector_Name
(Actual
)) = Name_Item
2866 return Explicit_Actual_Parameter
(Actual
);
2872 -- Case where the item has been defined without an association
2874 Actual
:= First
(Actuals
);
2876 -- Depending on the procedure Put, Item actual could be first or
2877 -- second in the list of actuals.
2879 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
2882 return Next
(Actual
);
2886 -- Start of processing for Expand_Put_Call_With_Symbol
2889 if Is_Procedure_Put_Call
and then not Has_Symbols
then
2890 Actual
:= Item_Actual
;
2891 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
2892 Etyp
:= Etype
(Actual
);
2896 if Is_Put_Dim_Of
then
2898 -- Check that the item is not dimensionless
2900 -- Create the new String_Literal with the new String_Id generated
2901 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
2903 if Exists
(Dims_Of_Actual
) then
2905 Make_String_Literal
(Loc
,
2906 From_Dim_To_Str_Of_Dim_Symbols
2907 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
))));
2909 -- If dimensionless, the output is []
2913 Make_String_Literal
(Loc
, "[]");
2919 -- Add the symbol as a suffix of the value if the subtype has a
2920 -- unit symbol or if the parameter is not dimensionless.
2922 if Exists
(Symbol_Of
(Etyp
)) then
2923 Symbols
:= Symbol_Of
(Etyp
);
2925 Symbols
:= From_Dim_To_Str_Of_Unit_Symbols
2926 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
)));
2929 -- Check Symbols exists
2931 if Exists
(Symbols
) then
2934 -- Put a space between the value and the dimension
2936 Store_String_Char
(' ');
2937 Store_String_Chars
(Symbols
);
2938 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
2942 if Present
(New_Str_Lit
) then
2944 -- Insert all actuals in New_Actuals
2946 Actual
:= First
(Actuals
);
2947 while Present
(Actual
) loop
2949 -- Copy every actuals in New_Actuals except the Symbols
2950 -- parameter association.
2952 if Nkind
(Actual
) = N_Parameter_Association
2953 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
2955 Append_To
(New_Actuals
,
2956 Make_Parameter_Association
(Loc
,
2957 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
2958 Explicit_Actual_Parameter
=>
2959 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
2961 elsif Nkind
(Actual
) /= N_Parameter_Association
then
2962 Append_To
(New_Actuals
, New_Copy
(Actual
));
2968 -- Create new Symbols param association and append to New_Actuals
2970 Append_To
(New_Actuals
,
2971 Make_Parameter_Association
(Loc
,
2972 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
2973 Explicit_Actual_Parameter
=> New_Str_Lit
));
2975 -- Rewrite and analyze the procedure call
2978 Make_Procedure_Call_Statement
(Loc
,
2979 Name
=> New_Copy
(Name_Call
),
2980 Parameter_Associations
=> New_Actuals
));
2985 end Expand_Put_Call_With_Symbol
;
2987 ------------------------------------
2988 -- From_Dim_To_Str_Of_Dim_Symbols --
2989 ------------------------------------
2991 -- Given a dimension vector and the corresponding dimension system, create
2992 -- a String_Id to output dimension symbols corresponding to the dimensions
2993 -- Dims. If In_Error_Msg is True, there is a special handling for character
2994 -- asterisk * which is an insertion character in error messages.
2996 function From_Dim_To_Str_Of_Dim_Symbols
2997 (Dims
: Dimension_Type
;
2998 System
: System_Type
;
2999 In_Error_Msg
: Boolean := False) return String_Id
3001 Dim_Power
: Rational
;
3002 First_Dim
: Boolean := True;
3004 procedure Store_String_Oexpon
;
3005 -- Store the expon operator symbol "**" in the string. In error
3006 -- messages, asterisk * is a special character and must be quoted
3007 -- to be placed literally into the message.
3009 -------------------------
3010 -- Store_String_Oexpon --
3011 -------------------------
3013 procedure Store_String_Oexpon
is
3015 if In_Error_Msg
then
3016 Store_String_Chars
("'*'*");
3018 Store_String_Chars
("**");
3020 end Store_String_Oexpon
;
3022 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3025 -- Initialization of the new String_Id
3029 -- Store the dimension symbols inside boxes
3031 Store_String_Char
('[');
3033 for Position
in Dimension_Type
'Range loop
3034 Dim_Power
:= Dims
(Position
);
3035 if Dim_Power
/= Zero
then
3040 Store_String_Char
('.');
3043 Store_String_Chars
(System
.Dim_Symbols
(Position
));
3045 -- Positive dimension case
3047 if Dim_Power
.Numerator
> 0 then
3050 if Dim_Power
.Denominator
= 1 then
3051 if Dim_Power
.Numerator
/= 1 then
3052 Store_String_Oexpon
;
3053 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3056 -- Rational case when denominator /= 1
3059 Store_String_Oexpon
;
3060 Store_String_Char
('(');
3061 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3062 Store_String_Char
('/');
3063 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3064 Store_String_Char
(')');
3067 -- Negative dimension case
3070 Store_String_Oexpon
;
3071 Store_String_Char
('(');
3072 Store_String_Char
('-');
3073 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3077 if Dim_Power
.Denominator
= 1 then
3078 Store_String_Char
(')');
3080 -- Rational case when denominator /= 1
3083 Store_String_Char
('/');
3084 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3085 Store_String_Char
(')');
3091 Store_String_Char
(']');
3093 end From_Dim_To_Str_Of_Dim_Symbols
;
3095 -------------------------------------
3096 -- From_Dim_To_Str_Of_Unit_Symbols --
3097 -------------------------------------
3099 -- Given a dimension vector and the corresponding dimension system,
3100 -- create a String_Id to output the unit symbols corresponding to the
3103 function From_Dim_To_Str_Of_Unit_Symbols
3104 (Dims
: Dimension_Type
;
3105 System
: System_Type
) return String_Id
3107 Dim_Power
: Rational
;
3108 First_Dim
: Boolean := True;
3111 -- Return No_String if dimensionless
3113 if not Exists
(Dims
) then
3117 -- Initialization of the new String_Id
3121 for Position
in Dimension_Type
'Range loop
3122 Dim_Power
:= Dims
(Position
);
3124 if Dim_Power
/= Zero
then
3129 Store_String_Char
('.');
3132 Store_String_Chars
(System
.Unit_Symbols
(Position
));
3134 -- Positive dimension case
3136 if Dim_Power
.Numerator
> 0 then
3140 if Dim_Power
.Denominator
= 1 then
3141 if Dim_Power
.Numerator
/= 1 then
3142 Store_String_Chars
("**");
3143 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3146 -- Rational case when denominator /= 1
3149 Store_String_Chars
("**");
3150 Store_String_Char
('(');
3151 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3152 Store_String_Char
('/');
3153 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3154 Store_String_Char
(')');
3157 -- Negative dimension case
3160 Store_String_Chars
("**");
3161 Store_String_Char
('(');
3162 Store_String_Char
('-');
3163 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3167 if Dim_Power
.Denominator
= 1 then
3168 Store_String_Char
(')');
3170 -- Rational case when denominator /= 1
3173 Store_String_Char
('/');
3174 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3175 Store_String_Char
(')');
3182 end From_Dim_To_Str_Of_Unit_Symbols
;
3188 function GCD
(Left
, Right
: Whole
) return Int
is
3208 --------------------------
3209 -- Has_Dimension_System --
3210 --------------------------
3212 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
3214 return Exists
(System_Of
(Typ
));
3215 end Has_Dimension_System
;
3217 ------------------------------
3218 -- Is_Dim_IO_Package_Entity --
3219 ------------------------------
3221 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
3223 -- Check the package entity corresponds to System.Dim.Float_IO or
3224 -- System.Dim.Integer_IO.
3227 Is_RTU
(E
, System_Dim_Float_IO
)
3229 Is_RTU
(E
, System_Dim_Integer_IO
);
3230 end Is_Dim_IO_Package_Entity
;
3232 -------------------------------------
3233 -- Is_Dim_IO_Package_Instantiation --
3234 -------------------------------------
3236 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
3237 Gen_Id
: constant Node_Id
:= Name
(N
);
3240 -- Check that the instantiated package is either System.Dim.Float_IO
3241 -- or System.Dim.Integer_IO.
3244 Is_Entity_Name
(Gen_Id
)
3245 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
3246 end Is_Dim_IO_Package_Instantiation
;
3252 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
3254 return Position
= Invalid_Position
;
3257 ---------------------
3258 -- Move_Dimensions --
3259 ---------------------
3261 procedure Move_Dimensions
(From
, To
: Node_Id
) is
3263 if Ada_Version
< Ada_2012
then
3267 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3269 Copy_Dimensions
(From
, To
);
3270 Remove_Dimensions
(From
);
3271 end Move_Dimensions
;
3277 function Reduce
(X
: Rational
) return Rational
is
3279 if X
.Numerator
= 0 then
3284 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
3286 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
3287 Denominator => Whole (Int (X.Denominator) / G));
3291 -----------------------
3292 -- Remove_Dimensions --
3293 -----------------------
3295 procedure Remove_Dimensions (N : Node_Id) is
3296 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3298 if Exists (Dims_Of_N) then
3299 Dimension_Table.Remove (N);
3301 end Remove_Dimensions;
3303 -----------------------------------
3304 -- Remove_Dimension_In_Statement --
3305 -----------------------------------
3307 -- Removal of dimension in statement as part of the Analyze_Statements
3308 -- routine (see package Sem_Ch5).
3310 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3312 if Ada_Version < Ada_2012 then
3316 -- Remove dimension in parameter specifications for accept statement
3318 if Nkind (Stmt) = N_Accept_Statement then
3320 Param : Node_Id := First (Parameter_Specifications (Stmt));
3322 while Present (Param) loop
3323 Remove_Dimensions (Param);
3328 -- Remove dimension of name and expression in assignments
3330 elsif Nkind (Stmt) = N_Assignment_Statement then
3331 Remove_Dimensions (Expression (Stmt));
3332 Remove_Dimensions (Name (Stmt));
3334 end Remove_Dimension_In_Statement;
3336 --------------------
3337 -- Set_Dimensions --
3338 --------------------
3340 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3342 pragma Assert (OK_For_Dimension (Nkind (N)));
3343 pragma Assert (Exists (Val));
3345 Dimension_Table.Set (N, Val);
3352 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3354 Symbol_Table.Set (E, Val);
3357 ---------------------------------
3358 -- String_From_Numeric_Literal --
3359 ---------------------------------
3361 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3362 Loc : constant Source_Ptr := Sloc (N);
3363 Sbuffer : constant Source_Buffer_Ptr :=
3364 Source_Text (Get_Source_File_Index (Loc));
3365 Src_Ptr : Source_Ptr := Loc;
3366 C : Character := Sbuffer (Src_Ptr);
3367 -- Current source program character
3369 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3370 -- Return True if C belongs to a numeric literal
3372 -------------------------------
3373 -- Belong_To_Numeric_Literal --
3374 -------------------------------
3376 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3392 -- Make sure '+' or '-' is part of an exponent.
3396 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3398 return Prev_C = 'e
' or else Prev_C = 'E
';
3401 -- All other character doesn't belong to a numeric literal
3406 end Belong_To_Numeric_Literal;
3408 -- Start of processing for String_From_Numeric_Literal
3412 while Belong_To_Numeric_Literal (C) loop
3413 Store_String_Char (C);
3414 Src_Ptr := Src_Ptr + 1;
3415 C := Sbuffer (Src_Ptr);
3419 end String_From_Numeric_Literal;
3425 function Symbol_Of (E : Entity_Id) return String_Id is
3426 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3428 if Subtype_Symbol /= No_String then
3429 return Subtype_Symbol;
3431 return From_Dim_To_Str_Of_Unit_Symbols
3432 (Dimensions_Of (E), System_Of (Base_Type (E)));
3436 -----------------------
3437 -- Symbol_Table_Hash --
3438 -----------------------
3440 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3442 return Symbol_Table_Range (Key mod 511);
3443 end Symbol_Table_Hash;
3449 function System_Of (E : Entity_Id) return System_Type is
3450 Type_Decl : constant Node_Id := Parent (E);
3453 -- Look for Type_Decl in System_Table
3455 for Dim_Sys in 1 .. System_Table.Last loop
3456 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3457 return System_Table.Table (Dim_Sys);