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, or those that may
1512 -- have semantic errors.
1514 if Ada_Version < Ada_2012
1515 or else not Comes_From_Source (N)
1516 or else Error_Posted (N)
1521 -- Check the dimensions of the actuals, if any
1523 if not Is_Empty_List (Actuals) then
1525 -- Special processing for elementary functions
1527 -- For Sqrt call, the resulting dimensions equal to half the
1528 -- dimensions of the actual. For all other elementary calls, this
1529 -- routine check that every actual is dimensionless.
1531 if Nkind (N) = N_Function_Call then
1532 Elementary_Function_Calls : declare
1533 Dims_Of_Call : Dimension_Type;
1534 Ent : Entity_Id := Nam;
1536 function Is_Elementary_Function_Entity
1537 (Sub_Id : Entity_Id) return Boolean;
1538 -- Given Sub_Id, the original subprogram entity, return True
1539 -- if call is to an elementary function (see Ada.Numerics.
1540 -- Generic_Elementary_Functions).
1542 -----------------------------------
1543 -- Is_Elementary_Function_Entity --
1544 -----------------------------------
1546 function Is_Elementary_Function_Entity
1547 (Sub_Id : Entity_Id) return Boolean
1549 Loc : constant Source_Ptr := Sloc (Sub_Id);
1552 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1558 (Cunit_Entity (Get_Source_Unit (Loc)),
1559 Ada_Numerics_Generic_Elementary_Functions);
1560 end Is_Elementary_Function_Entity;
1562 -- Start of processing for Elementary_Function_Calls
1565 -- Get original subprogram entity following the renaming chain
1567 if Present (Alias (Ent)) then
1571 -- Check the call is an Elementary function call
1573 if Is_Elementary_Function_Entity (Ent) then
1575 -- Sqrt function call case
1577 if Chars (Ent) = Name_Sqrt then
1578 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1580 -- Evaluates the resulting dimensions (i.e. half the
1581 -- dimensions of the actual).
1583 if Exists (Dims_Of_Call) then
1584 for Position in Dims_Of_Call'Range loop
1585 Dims_Of_Call (Position) :=
1586 Dims_Of_Call (Position) *
1587 Rational'(Numerator
=> 1, Denominator
=> 2);
1590 Set_Dimensions
(N
, Dims_Of_Call
);
1593 -- All other elementary functions case. Note that every
1594 -- actual here should be dimensionless.
1597 Actual
:= First_Actual
(N
);
1598 while Present
(Actual
) loop
1599 if Exists
(Dimensions_Of
(Actual
)) then
1601 -- Check if error has already been encountered
1603 if not Error_Detected
then
1604 Error_Msg_NE
("dimensions mismatch in call of&",
1606 Error_Detected
:= True;
1609 Error_Msg_N
("\expected dimension [], found " &
1610 Dimensions_Msg_Of
(Actual
),
1614 Next_Actual
(Actual
);
1618 -- Nothing more to do for elementary functions
1622 end Elementary_Function_Calls
;
1625 -- General case. Check, for each parameter, the dimensions of the
1626 -- actual and its corresponding formal match. Otherwise, complain.
1628 Actual
:= First_Actual
(N
);
1629 Formal
:= First_Formal
(Nam
);
1631 while Present
(Formal
) loop
1633 -- A missing corresponding actual indicates that the analysis of
1634 -- the call was aborted due to a previous error.
1641 Formal_Typ
:= Etype
(Formal
);
1642 Dims_Of_Formal
:= Dimensions_Of
(Formal_Typ
);
1644 -- If the formal is not dimensionless, check dimensions of formal
1645 -- and actual match. Otherwise, complain.
1647 if Exists
(Dims_Of_Formal
)
1648 and then Dimensions_Of
(Actual
) /= Dims_Of_Formal
1650 -- Check if an error has already been encountered so far
1652 if not Error_Detected
then
1653 Error_Msg_NE
("dimensions mismatch in& call", N
, Name
(N
));
1654 Error_Detected
:= True;
1658 ("\expected dimension " & Dimensions_Msg_Of
(Formal_Typ
)
1659 & ", found " & Dimensions_Msg_Of
(Actual
), Actual
);
1662 Next_Actual
(Actual
);
1663 Next_Formal
(Formal
);
1667 -- For function calls, propagate the dimensions from the returned type
1669 if Nkind
(N
) = N_Function_Call
then
1670 Analyze_Dimension_Has_Etype
(N
);
1672 end Analyze_Dimension_Call
;
1674 ---------------------------------------------
1675 -- Analyze_Dimension_Component_Declaration --
1676 ---------------------------------------------
1678 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
) is
1679 Expr
: constant Node_Id
:= Expression
(N
);
1680 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1681 Etyp
: constant Entity_Id
:= Etype
(Id
);
1682 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1683 Dims_Of_Expr
: Dimension_Type
;
1685 procedure Error_Dim_Msg_For_Component_Declaration
1689 -- Error using Error_Msg_N at node N. Output the dimensions of the
1690 -- type Etyp and the expression Expr of N.
1692 ---------------------------------------------
1693 -- Error_Dim_Msg_For_Component_Declaration --
1694 ---------------------------------------------
1696 procedure Error_Dim_Msg_For_Component_Declaration
1701 Error_Msg_N
("dimensions mismatch in component declaration", N
);
1702 Error_Msg_N
("\expected dimension "
1703 & Dimensions_Msg_Of
(Etyp
)
1705 & Dimensions_Msg_Of
(Expr
),
1707 end Error_Dim_Msg_For_Component_Declaration
;
1709 -- Start of processing for Analyze_Dimension_Component_Declaration
1712 -- Expression is present
1714 if Present
(Expr
) then
1715 Dims_Of_Expr
:= Dimensions_Of
(Expr
);
1717 -- Check dimensions match
1719 if Dims_Of_Etyp
/= Dims_Of_Expr
then
1720 -- Numeric literal case. Issue a warning if the object type is not
1721 -- dimensionless to indicate the literal is treated as if its
1722 -- dimension matches the type dimension.
1724 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1727 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
1729 -- Issue a dimension mismatch error for all other cases
1732 Error_Dim_Msg_For_Component_Declaration
(N
, Etyp
, Expr
);
1736 end Analyze_Dimension_Component_Declaration
;
1738 -------------------------------------------------
1739 -- Analyze_Dimension_Extended_Return_Statement --
1740 -------------------------------------------------
1742 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
) is
1743 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1744 Return_Etyp
: constant Entity_Id
:=
1745 Etype
(Return_Applies_To
(Return_Ent
));
1746 Return_Obj_Decls
: constant List_Id
:= Return_Object_Declarations
(N
);
1747 Return_Obj_Decl
: Node_Id
;
1748 Return_Obj_Id
: Entity_Id
;
1749 Return_Obj_Typ
: Entity_Id
;
1751 procedure Error_Dim_Msg_For_Extended_Return_Statement
1753 Return_Etyp
: Entity_Id
;
1754 Return_Obj_Typ
: Entity_Id
);
1755 -- Error using Error_Msg_N at node N. Output the dimensions of the
1756 -- returned type Return_Etyp and the returned object type Return_Obj_Typ
1759 -------------------------------------------------
1760 -- Error_Dim_Msg_For_Extended_Return_Statement --
1761 -------------------------------------------------
1763 procedure Error_Dim_Msg_For_Extended_Return_Statement
1765 Return_Etyp
: Entity_Id
;
1766 Return_Obj_Typ
: Entity_Id
)
1769 Error_Msg_N
("dimensions mismatch in extended return statement", N
);
1770 Error_Msg_N
("\expected dimension "
1771 & Dimensions_Msg_Of
(Return_Etyp
)
1773 & Dimensions_Msg_Of
(Return_Obj_Typ
),
1775 end Error_Dim_Msg_For_Extended_Return_Statement
;
1777 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1780 if Present
(Return_Obj_Decls
) then
1781 Return_Obj_Decl
:= First
(Return_Obj_Decls
);
1782 while Present
(Return_Obj_Decl
) loop
1783 if Nkind
(Return_Obj_Decl
) = N_Object_Declaration
then
1784 Return_Obj_Id
:= Defining_Identifier
(Return_Obj_Decl
);
1786 if Is_Return_Object
(Return_Obj_Id
) then
1787 Return_Obj_Typ
:= Etype
(Return_Obj_Id
);
1789 -- Issue an error message if dimensions mismatch
1791 if Dimensions_Of
(Return_Etyp
) /=
1792 Dimensions_Of
(Return_Obj_Typ
)
1794 Error_Dim_Msg_For_Extended_Return_Statement
1795 (N
, Return_Etyp
, Return_Obj_Typ
);
1801 Next
(Return_Obj_Decl
);
1804 end Analyze_Dimension_Extended_Return_Statement
;
1806 -----------------------------------------------------
1807 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1808 -----------------------------------------------------
1810 procedure Analyze_Dimension_Extension_Or_Record_Aggregate
(N
: Node_Id
) is
1812 Comp_Id
: Entity_Id
;
1813 Comp_Typ
: Entity_Id
;
1816 Error_Detected
: Boolean := False;
1817 -- This flag is used in order to indicate if an error has been detected
1818 -- so far by the compiler in this routine.
1821 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1822 -- dimensions for aggregates that don't come from source.
1824 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
1828 Comp
:= First
(Component_Associations
(N
));
1829 while Present
(Comp
) loop
1830 Comp_Id
:= Entity
(First
(Choices
(Comp
)));
1831 Comp_Typ
:= Etype
(Comp_Id
);
1833 -- Check the component type is either a dimensioned type or a
1834 -- dimensioned subtype.
1836 if Has_Dimension_System
(Base_Type
(Comp_Typ
)) then
1837 Expr
:= Expression
(Comp
);
1839 -- Issue an error if the dimensions of the component type and the
1840 -- dimensions of the component mismatch.
1842 if Dimensions_Of
(Expr
) /= Dimensions_Of
(Comp_Typ
) then
1844 -- Check if an error has already been encountered so far
1846 if not Error_Detected
then
1848 -- Extension aggregate case
1850 if Nkind
(N
) = N_Extension_Aggregate
then
1852 ("dimensions mismatch in extension aggregate", N
);
1854 -- Record aggregate case
1858 ("dimensions mismatch in record aggregate", N
);
1861 Error_Detected
:= True;
1865 ("\expected dimension "
1866 & Dimensions_Msg_Of
(Comp_Typ
)
1868 & Dimensions_Msg_Of
(Expr
),
1875 end Analyze_Dimension_Extension_Or_Record_Aggregate
;
1877 -------------------------------
1878 -- Analyze_Dimension_Formals --
1879 -------------------------------
1881 procedure Analyze_Dimension_Formals
(N
: Node_Id
; Formals
: List_Id
) is
1882 Dims_Of_Typ
: Dimension_Type
;
1887 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1888 -- dimensions for sub specs that don't come from source.
1890 if Ada_Version
< Ada_2012
or else not Comes_From_Source
(N
) then
1894 Formal
:= First
(Formals
);
1895 while Present
(Formal
) loop
1896 Typ
:= Parameter_Type
(Formal
);
1897 Dims_Of_Typ
:= Dimensions_Of
(Typ
);
1899 if Exists
(Dims_Of_Typ
) then
1901 Expr
: constant Node_Id
:= Expression
(Formal
);
1904 -- Issue a warning if Expr is a numeric literal and if its
1905 -- dimensions differ with the dimensions of the formal type.
1908 and then Dims_Of_Typ
/= Dimensions_Of
(Expr
)
1909 and then Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
1912 Dim_Warning_For_Numeric_Literal
(Expr
, Etype
(Typ
));
1919 end Analyze_Dimension_Formals
;
1921 ---------------------------------
1922 -- Analyze_Dimension_Has_Etype --
1923 ---------------------------------
1925 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
1926 Etyp
: constant Entity_Id
:= Etype
(N
);
1927 Dims_Of_Etyp
: Dimension_Type
:= Dimensions_Of
(Etyp
);
1930 -- General case. Propagation of the dimensions from the type
1932 if Exists
(Dims_Of_Etyp
) then
1933 Set_Dimensions
(N
, Dims_Of_Etyp
);
1935 -- Identifier case. Propagate the dimensions from the entity for
1936 -- identifier whose entity is a non-dimensionless constant.
1938 elsif Nkind
(N
) = N_Identifier
then
1939 Analyze_Dimension_Identifier
: declare
1940 Id
: constant Entity_Id
:= Entity
(N
);
1942 if Ekind
(Id
) = E_Constant
1943 and then Exists
(Dimensions_Of
(Id
))
1945 Set_Dimensions
(N
, Dimensions_Of
(Id
));
1947 end Analyze_Dimension_Identifier
;
1949 -- Attribute reference case. Propagate the dimensions from the prefix.
1951 elsif Nkind
(N
) = N_Attribute_Reference
1952 and then Has_Dimension_System
(Base_Type
(Etyp
))
1954 Dims_Of_Etyp
:= Dimensions_Of
(Prefix
(N
));
1956 -- Check the prefix is not dimensionless
1958 if Exists
(Dims_Of_Etyp
) then
1959 Set_Dimensions
(N
, Dims_Of_Etyp
);
1963 -- Removal of dimensions in expression
1966 when N_Attribute_Reference |
1967 N_Indexed_Component
=>
1970 Exprs
: constant List_Id
:= Expressions
(N
);
1973 if Present
(Exprs
) then
1974 Expr
:= First
(Exprs
);
1975 while Present
(Expr
) loop
1976 Remove_Dimensions
(Expr
);
1982 when N_Qualified_Expression |
1984 N_Unchecked_Type_Conversion
=>
1985 Remove_Dimensions
(Expression
(N
));
1987 when N_Selected_Component
=>
1988 Remove_Dimensions
(Selector_Name
(N
));
1990 when others => null;
1992 end Analyze_Dimension_Has_Etype
;
1994 ------------------------------------------
1995 -- Analyze_Dimension_Object_Declaration --
1996 ------------------------------------------
1998 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
1999 Expr
: constant Node_Id
:= Expression
(N
);
2000 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2001 Etyp
: constant Entity_Id
:= Etype
(Id
);
2002 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
2003 Dim_Of_Expr
: Dimension_Type
;
2005 procedure Error_Dim_Msg_For_Object_Declaration
2009 -- Error using Error_Msg_N at node N. Output the dimensions of the
2010 -- type Etyp and of the expression Expr.
2012 ------------------------------------------
2013 -- Error_Dim_Msg_For_Object_Declaration --
2014 ------------------------------------------
2016 procedure Error_Dim_Msg_For_Object_Declaration
2021 Error_Msg_N
("dimensions mismatch in object declaration", N
);
2023 ("\expected dimension "
2024 & Dimensions_Msg_Of
(Etyp
)
2026 & Dimensions_Msg_Of
(Expr
),
2028 end Error_Dim_Msg_For_Object_Declaration
;
2030 -- Start of processing for Analyze_Dimension_Object_Declaration
2033 -- Expression is present
2035 if Present
(Expr
) then
2036 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
2038 -- Check dimensions match
2040 if Dim_Of_Expr
/= Dim_Of_Etyp
then
2042 -- Numeric literal case. Issue a warning if the object type is not
2043 -- dimensionless to indicate the literal is treated as if its
2044 -- dimension matches the type dimension.
2046 if Nkind_In
(Original_Node
(Expr
), N_Real_Literal
,
2049 Dim_Warning_For_Numeric_Literal
(Expr
, Etyp
);
2051 -- Case of object is a constant whose type is a dimensioned type
2053 elsif Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
2055 -- Propagate dimension from expression to object entity
2057 Set_Dimensions
(Id
, Dim_Of_Expr
);
2059 -- For all other cases, issue an error message
2062 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
2066 -- Removal of dimensions in expression
2068 Remove_Dimensions
(Expr
);
2070 end Analyze_Dimension_Object_Declaration
;
2072 ---------------------------------------------------
2073 -- Analyze_Dimension_Object_Renaming_Declaration --
2074 ---------------------------------------------------
2076 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
2077 Renamed_Name
: constant Node_Id
:= Name
(N
);
2078 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
2080 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2083 Renamed_Name
: Node_Id
);
2084 -- Error using Error_Msg_N at node N. Output the dimensions of
2085 -- Sub_Mark and of Renamed_Name.
2087 ---------------------------------------------------
2088 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2089 ---------------------------------------------------
2091 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2094 Renamed_Name
: Node_Id
) is
2096 Error_Msg_N
("dimensions mismatch in object renaming declaration", N
);
2098 ("\expected dimension "
2099 & Dimensions_Msg_Of
(Sub_Mark
)
2101 & Dimensions_Msg_Of
(Renamed_Name
),
2103 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
2105 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2108 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
2109 Error_Dim_Msg_For_Object_Renaming_Declaration
2110 (N
, Sub_Mark
, Renamed_Name
);
2112 end Analyze_Dimension_Object_Renaming_Declaration
;
2114 -----------------------------------------------
2115 -- Analyze_Dimension_Simple_Return_Statement --
2116 -----------------------------------------------
2118 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
2119 Expr
: constant Node_Id
:= Expression
(N
);
2120 Dims_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
2121 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
2122 Return_Etyp
: constant Entity_Id
:=
2123 Etype
(Return_Applies_To
(Return_Ent
));
2124 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
2125 Dimensions_Of
(Return_Etyp
);
2127 procedure Error_Dim_Msg_For_Simple_Return_Statement
2129 Return_Etyp
: Entity_Id
;
2131 -- Error using Error_Msg_N at node N. Output the dimensions of the
2132 -- returned type Return_Etyp and the returned expression Expr of N.
2134 -----------------------------------------------
2135 -- Error_Dim_Msg_For_Simple_Return_Statement --
2136 -----------------------------------------------
2138 procedure Error_Dim_Msg_For_Simple_Return_Statement
2140 Return_Etyp
: Entity_Id
;
2144 Error_Msg_N
("dimensions mismatch in return statement", N
);
2146 ("\expected dimension "
2147 & Dimensions_Msg_Of
(Return_Etyp
)
2149 & Dimensions_Msg_Of
(Expr
),
2151 end Error_Dim_Msg_For_Simple_Return_Statement
;
2153 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2156 if Dims_Of_Return_Etyp
/= Dims_Of_Expr
then
2157 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
2158 Remove_Dimensions
(Expr
);
2160 end Analyze_Dimension_Simple_Return_Statement
;
2162 -------------------------------------------
2163 -- Analyze_Dimension_Subtype_Declaration --
2164 -------------------------------------------
2166 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
2167 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2168 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
2169 Dims_Of_Etyp
: Dimension_Type
;
2173 -- No constraint case in subtype declaration
2175 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2176 Etyp
:= Etype
(Subtype_Indication
(N
));
2177 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2179 if Exists
(Dims_Of_Etyp
) then
2181 -- If subtype already has a dimension (from Aspect_Dimension),
2182 -- it cannot inherit a dimension from its subtype.
2184 if Exists
(Dims_Of_Id
) then
2186 ("subtype& already" & Dimensions_Msg_Of
(Id
, True), N
);
2189 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2190 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2194 -- Constraint present in subtype declaration
2197 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
2198 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
2200 if Exists
(Dims_Of_Etyp
) then
2201 Set_Dimensions
(Id
, Dims_Of_Etyp
);
2202 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
2205 end Analyze_Dimension_Subtype_Declaration
;
2207 --------------------------------
2208 -- Analyze_Dimension_Unary_Op --
2209 --------------------------------
2211 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
2214 when N_Op_Plus | N_Op_Minus | N_Op_Abs
=>
2216 R
: constant Node_Id
:= Right_Opnd
(N
);
2219 -- Propagate the dimension if the operand is not dimensionless
2221 Move_Dimensions
(R
, N
);
2224 when others => null;
2227 end Analyze_Dimension_Unary_Op
;
2229 ---------------------
2230 -- Copy_Dimensions --
2231 ---------------------
2233 procedure Copy_Dimensions
(From
, To
: Node_Id
) is
2234 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2237 -- Ignore if not Ada 2012 or beyond
2239 if Ada_Version
< Ada_2012
then
2242 -- For Ada 2012, Copy the dimension of 'From to 'To'
2244 elsif Exists
(Dims_Of_From
) then
2245 Set_Dimensions
(To
, Dims_Of_From
);
2247 end Copy_Dimensions
;
2249 --------------------------
2250 -- Create_Rational_From --
2251 --------------------------
2253 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2255 -- A rational number is a number that can be expressed as the quotient or
2256 -- fraction a/b of two integers, where b is non-zero positive.
2258 function Create_Rational_From
2260 Complain
: Boolean) return Rational
2262 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
2263 Result
: Rational
:= No_Rational
;
2265 function Process_Minus
(N
: Node_Id
) return Rational
;
2266 -- Create a rational from a N_Op_Minus node
2268 function Process_Divide
(N
: Node_Id
) return Rational
;
2269 -- Create a rational from a N_Op_Divide node
2271 function Process_Literal
(N
: Node_Id
) return Rational
;
2272 -- Create a rational from a N_Integer_Literal node
2278 function Process_Minus
(N
: Node_Id
) return Rational
is
2279 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2283 -- Operand is an integer literal
2285 if Nkind
(Right
) = N_Integer_Literal
then
2286 Result
:= -Process_Literal
(Right
);
2288 -- Operand is a divide operator
2290 elsif Nkind
(Right
) = N_Op_Divide
then
2291 Result
:= -Process_Divide
(Right
);
2294 Result
:= No_Rational
;
2300 --------------------
2301 -- Process_Divide --
2302 --------------------
2304 function Process_Divide
(N
: Node_Id
) return Rational
is
2305 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
2306 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
2307 Left_Rat
: Rational
;
2308 Result
: Rational
:= No_Rational
;
2309 Right_Rat
: Rational
;
2312 -- Both left and right operands are an integer literal
2314 if Nkind
(Left
) = N_Integer_Literal
2315 and then Nkind
(Right
) = N_Integer_Literal
2317 Left_Rat
:= Process_Literal
(Left
);
2318 Right_Rat
:= Process_Literal
(Right
);
2319 Result
:= Left_Rat
/ Right_Rat
;
2325 ---------------------
2326 -- Process_Literal --
2327 ---------------------
2329 function Process_Literal
(N
: Node_Id
) return Rational
is
2331 return +Whole
(UI_To_Int
(Intval
(N
)));
2332 end Process_Literal
;
2334 -- Start of processing for Create_Rational_From
2337 -- Check the expression is either a division of two integers or an
2338 -- integer itself. Note that the check applies to the original node
2339 -- since the node could have already been rewritten.
2341 -- Integer literal case
2343 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
2344 Result
:= Process_Literal
(Or_Node_Of_Expr
);
2346 -- Divide operator case
2348 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
2349 Result
:= Process_Divide
(Or_Node_Of_Expr
);
2351 -- Minus operator case
2353 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
2354 Result
:= Process_Minus
(Or_Node_Of_Expr
);
2357 -- When Expr cannot be interpreted as a rational and Complain is true,
2358 -- generate an error message.
2360 if Complain
and then Result
= No_Rational
then
2361 Error_Msg_N
("rational expected", Expr
);
2365 end Create_Rational_From
;
2371 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2373 return Dimension_Table
.Get
(N
);
2376 -----------------------
2377 -- Dimensions_Msg_Of --
2378 -----------------------
2380 function Dimensions_Msg_Of
2382 Description_Needed
: Boolean := False) return String
2384 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2385 Dimensions_Msg
: Name_Id
;
2386 System
: System_Type
;
2389 -- Initialization of Name_Buffer
2393 -- N is not dimensionless
2395 if Exists
(Dims_Of_N
) then
2396 System
:= System_Of
(Base_Type
(Etype
(N
)));
2398 -- When Description_Needed, add to string "has dimension " before the
2399 -- actual dimension.
2401 if Description_Needed
then
2402 Add_Str_To_Name_Buffer
("has dimension ");
2405 Add_String_To_Name_Buffer
2406 (From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2408 -- N is dimensionless
2410 -- When Description_Needed, return "is dimensionless"
2412 elsif Description_Needed
then
2413 Add_Str_To_Name_Buffer
("is dimensionless");
2415 -- Otherwise, return "[]"
2418 Add_Str_To_Name_Buffer
("[]");
2421 Dimensions_Msg
:= Name_Find
;
2422 return Get_Name_String
(Dimensions_Msg
);
2423 end Dimensions_Msg_Of
;
2425 --------------------------
2426 -- Dimension_Table_Hash --
2427 --------------------------
2429 function Dimension_Table_Hash
2430 (Key
: Node_Id
) return Dimension_Table_Range
2433 return Dimension_Table_Range
(Key
mod 511);
2434 end Dimension_Table_Hash
;
2436 -------------------------------------
2437 -- Dim_Warning_For_Numeric_Literal --
2438 -------------------------------------
2440 procedure Dim_Warning_For_Numeric_Literal
(N
: Node_Id
; Typ
: Entity_Id
) is
2442 -- Initialize name buffer
2446 Add_String_To_Name_Buffer
(String_From_Numeric_Literal
(N
));
2448 -- Insert a blank between the literal and the symbol
2449 Add_Str_To_Name_Buffer
(" ");
2451 Add_String_To_Name_Buffer
(Symbol_Of
(Typ
));
2453 Error_Msg_Name_1
:= Name_Find
;
2454 Error_Msg_N
("?assumed to be%%", N
);
2455 end Dim_Warning_For_Numeric_Literal
;
2457 ----------------------------------------
2458 -- Eval_Op_Expon_For_Dimensioned_Type --
2459 ----------------------------------------
2461 -- Evaluate the expon operator for real dimensioned type.
2463 -- Note that if the exponent is an integer (denominator = 1) the node is
2464 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2466 procedure Eval_Op_Expon_For_Dimensioned_Type
2470 R
: constant Node_Id
:= Right_Opnd
(N
);
2471 R_Value
: Rational
:= No_Rational
;
2474 if Is_Real_Type
(Btyp
) then
2475 R_Value
:= Create_Rational_From
(R
, False);
2478 -- Check that the exponent is not an integer
2480 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2481 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2485 end Eval_Op_Expon_For_Dimensioned_Type
;
2487 ------------------------------------------
2488 -- Eval_Op_Expon_With_Rational_Exponent --
2489 ------------------------------------------
2491 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2492 -- Rational and not only an Integer like for dimensionless operands. For
2493 -- that particular case, the left operand is rewritten as a function call
2494 -- using the function Expon_LLF from s-llflex.ads.
2496 procedure Eval_Op_Expon_With_Rational_Exponent
2498 Exponent_Value
: Rational
)
2500 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2501 L
: constant Node_Id
:= Left_Opnd
(N
);
2502 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2503 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2504 Loc
: constant Source_Ptr
:= Sloc
(N
);
2507 Dim_Power
: Rational
;
2508 List_Of_Dims
: List_Id
;
2509 New_Aspect
: Node_Id
;
2510 New_Aspects
: List_Id
;
2513 New_Subtyp_Decl_For_L
: Node_Id
;
2514 System
: System_Type
;
2517 -- Case when the operand is not dimensionless
2519 if Exists
(Dims_Of_N
) then
2521 -- Get the corresponding System_Type to know the exact number of
2522 -- dimensions in the system.
2524 System
:= System_Of
(Btyp_Of_L
);
2526 -- Generation of a new subtype with the proper dimensions
2528 -- In order to rewrite the operator as a type conversion, a new
2529 -- dimensioned subtype with the resulting dimensions of the
2530 -- exponentiation must be created.
2534 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2535 -- System : constant System_Id :=
2536 -- Get_Dimension_System_Id (Btyp_Of_L);
2537 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2538 -- Dimension_Systems.Table (System).Dimension_Count;
2540 -- subtype T is Btyp_Of_L
2543 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2544 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2546 -- Dims_Of_N (Num_Of_Dims).Numerator /
2547 -- Dims_Of_N (Num_Of_Dims).Denominator);
2549 -- Step 1: Generate the new aggregate for the aspect Dimension
2551 New_Aspects
:= Empty_List
;
2552 List_Of_Dims
:= New_List
;
2554 for Position
in Dims_Of_N
'First .. System
.Count
loop
2555 Dim_Power
:= Dims_Of_N
(Position
);
2556 Append_To
(List_Of_Dims
,
2557 Make_Op_Divide
(Loc
,
2559 Make_Integer_Literal
(Loc
,
2560 Int
(Dim_Power
.Numerator
)),
2562 Make_Integer_Literal
(Loc
,
2563 Int
(Dim_Power
.Denominator
))));
2566 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2569 Make_Aspect_Specification
(Loc
,
2570 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2571 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2573 -- Step 3: Make a temporary identifier for the new subtype
2575 New_Id
:= Make_Temporary
(Loc
, 'T');
2576 Set_Is_Internal
(New_Id
);
2578 -- Step 4: Declaration of the new subtype
2580 New_Subtyp_Decl_For_L
:=
2581 Make_Subtype_Declaration
(Loc
,
2582 Defining_Identifier
=> New_Id
,
2583 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2585 Append
(New_Aspect
, New_Aspects
);
2586 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2587 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2589 Analyze
(New_Subtyp_Decl_For_L
);
2591 -- Case where the operand is dimensionless
2594 New_Id
:= Btyp_Of_L
;
2597 -- Replacement of N by New_N
2601 -- Actual_1 := Long_Long_Float (L),
2603 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2604 -- Long_Long_Float (Exponent_Value.Denominator);
2606 -- (T (Expon_LLF (Actual_1, Actual_2)));
2608 -- where T is the subtype declared in step 1
2610 -- The node is rewritten as a type conversion
2612 -- Step 1: Creation of the two parameters of Expon_LLF function call
2615 Make_Type_Conversion
(Loc
,
2616 Subtype_Mark
=> New_Reference_To
(Standard_Long_Long_Float
, Loc
),
2617 Expression
=> Relocate_Node
(L
));
2620 Make_Op_Divide
(Loc
,
2622 Make_Real_Literal
(Loc
,
2623 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2625 Make_Real_Literal
(Loc
,
2626 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2628 -- Step 2: Creation of New_N
2631 Make_Type_Conversion
(Loc
,
2632 Subtype_Mark
=> New_Reference_To
(New_Id
, Loc
),
2634 Make_Function_Call
(Loc
,
2635 Name
=> New_Reference_To
(RTE
(RE_Expon_LLF
), Loc
),
2636 Parameter_Associations
=> New_List
(
2637 Actual_1
, Actual_2
)));
2639 -- Step 3: Rewrite N with the result
2642 Set_Etype
(N
, New_Id
);
2643 Analyze_And_Resolve
(N
, New_Id
);
2644 end Eval_Op_Expon_With_Rational_Exponent
;
2650 function Exists
(Dim
: Dimension_Type
) return Boolean is
2652 return Dim
/= Null_Dimension
;
2655 function Exists
(Str
: String_Id
) return Boolean is
2657 return Str
/= No_String
;
2660 function Exists
(Sys
: System_Type
) return Boolean is
2662 return Sys
/= Null_System
;
2665 ---------------------------------
2666 -- Expand_Put_Call_With_Symbol --
2667 ---------------------------------
2669 -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2670 -- (System.Dim.Integer_IO), the default string parameter must be rewritten
2671 -- to include the unit symbols (resp. dimension symbols) in the output
2672 -- of a dimensioned object. Note that if a value is already supplied for
2673 -- parameter Symbol, this routine doesn't do anything.
2675 -- Case 1. Item is dimensionless
2677 -- * Put : Item appears without a suffix
2679 -- * Put_Dim_Of : the output is []
2681 -- Obj : Mks_Type := 2.6;
2682 -- Put (Obj, 1, 1, 0);
2683 -- Put_Dim_Of (Obj);
2685 -- The corresponding outputs are:
2689 -- Case 2. Item has a dimension
2691 -- * Put : If the type of Item is a dimensioned subtype whose
2692 -- symbol is not empty, then the symbol appears as a
2693 -- suffix. Otherwise, a new string is created and appears
2694 -- as a suffix of Item. This string results in the
2695 -- successive concatanations between each unit symbol
2696 -- raised by its corresponding dimension power from the
2697 -- dimensions of Item.
2699 -- * Put_Dim_Of : The output is a new string resulting in the successive
2700 -- concatanations between each dimension symbol raised by
2701 -- its corresponding dimension power from the dimensions of
2704 -- subtype Random is Mks_Type
2711 -- Obj : Random := 5.0;
2713 -- Put_Dim_Of (Obj);
2715 -- The corresponding outputs are:
2716 -- $5.0 m**3.cd**(-1)
2719 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
2720 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2721 Loc
: constant Source_Ptr
:= Sloc
(N
);
2722 Name_Call
: constant Node_Id
:= Name
(N
);
2723 New_Actuals
: constant List_Id
:= New_List
;
2725 Dims_Of_Actual
: Dimension_Type
;
2727 New_Str_Lit
: Node_Id
:= Empty
;
2728 Symbols
: String_Id
;
2730 Is_Put_Dim_Of
: Boolean := False;
2731 -- This flag is used in order to differentiate routines Put and
2732 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2733 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2735 function Has_Symbols
return Boolean;
2736 -- Return True if the current Put call already has a parameter
2737 -- association for parameter "Symbols" with the correct string of
2740 function Is_Procedure_Put_Call
return Boolean;
2741 -- Return True if the current call is a call of an instantiation of a
2742 -- procedure Put defined in the package System.Dim.Float_IO and
2743 -- System.Dim.Integer_IO.
2745 function Item_Actual
return Node_Id
;
2746 -- Return the item actual parameter node in the output call
2752 function Has_Symbols
return Boolean is
2754 Actual_Str
: Node_Id
;
2757 Actual
:= First
(Actuals
);
2759 -- Look for a symbols parameter association in the list of actuals
2761 while Present
(Actual
) loop
2763 -- Positional parameter association case when the actual is a
2766 if Nkind
(Actual
) = N_String_Literal
then
2767 Actual_Str
:= Actual
;
2769 -- Named parameter association case when selector name is Symbol
2771 elsif Nkind
(Actual
) = N_Parameter_Association
2772 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
2774 Actual_Str
:= Explicit_Actual_Parameter
(Actual
);
2776 -- Ignore all other cases
2779 Actual_Str
:= Empty
;
2782 if Present
(Actual_Str
) then
2784 -- Return True if the actual comes from source or if the string
2785 -- of symbols doesn't have the default value (i.e. it is "").
2787 if Comes_From_Source
(Actual
)
2788 or else String_Length
(Strval
(Actual_Str
)) /= 0
2790 -- Complain only if the actual comes from source or if it
2791 -- hasn't been fully analyzed yet.
2793 if Comes_From_Source
(Actual
)
2794 or else not Analyzed
(Actual
)
2796 Error_Msg_N
("Symbol parameter should not be provided",
2798 Error_Msg_N
("\reserved for compiler use only", Actual
);
2811 -- At this point, the call has no parameter association. Look to the
2812 -- last actual since the symbols parameter is the last one.
2814 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
2817 ---------------------------
2818 -- Is_Procedure_Put_Call --
2819 ---------------------------
2821 function Is_Procedure_Put_Call
return Boolean is
2826 -- There are three different Put (resp. Put_Dim_Of) routines in each
2827 -- generic dim IO package. Verify the current procedure call is one
2830 if Is_Entity_Name
(Name_Call
) then
2831 Ent
:= Entity
(Name_Call
);
2833 -- Get the original subprogram entity following the renaming chain
2835 if Present
(Alias
(Ent
)) then
2841 -- Check the name of the entity subprogram is Put (resp.
2842 -- Put_Dim_Of) and verify this entity is located in either
2843 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2845 if Loc
> No_Location
2846 and then Is_Dim_IO_Package_Entity
2847 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
2849 if Chars
(Ent
) = Name_Put_Dim_Of
then
2850 Is_Put_Dim_Of
:= True;
2853 elsif Chars
(Ent
) = Name_Put
then
2860 end Is_Procedure_Put_Call
;
2866 function Item_Actual
return Node_Id
is
2870 -- Look for the item actual as a parameter association
2872 Actual
:= First
(Actuals
);
2873 while Present
(Actual
) loop
2874 if Nkind
(Actual
) = N_Parameter_Association
2875 and then Chars
(Selector_Name
(Actual
)) = Name_Item
2877 return Explicit_Actual_Parameter
(Actual
);
2883 -- Case where the item has been defined without an association
2885 Actual
:= First
(Actuals
);
2887 -- Depending on the procedure Put, Item actual could be first or
2888 -- second in the list of actuals.
2890 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
2893 return Next
(Actual
);
2897 -- Start of processing for Expand_Put_Call_With_Symbol
2900 if Is_Procedure_Put_Call
and then not Has_Symbols
then
2901 Actual
:= Item_Actual
;
2902 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
2903 Etyp
:= Etype
(Actual
);
2907 if Is_Put_Dim_Of
then
2909 -- Check that the item is not dimensionless
2911 -- Create the new String_Literal with the new String_Id generated
2912 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
2914 if Exists
(Dims_Of_Actual
) then
2916 Make_String_Literal
(Loc
,
2917 From_Dim_To_Str_Of_Dim_Symbols
2918 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
))));
2920 -- If dimensionless, the output is []
2924 Make_String_Literal
(Loc
, "[]");
2930 -- Add the symbol as a suffix of the value if the subtype has a
2931 -- unit symbol or if the parameter is not dimensionless.
2933 if Exists
(Symbol_Of
(Etyp
)) then
2934 Symbols
:= Symbol_Of
(Etyp
);
2936 Symbols
:= From_Dim_To_Str_Of_Unit_Symbols
2937 (Dims_Of_Actual
, System_Of
(Base_Type
(Etyp
)));
2940 -- Check Symbols exists
2942 if Exists
(Symbols
) then
2945 -- Put a space between the value and the dimension
2947 Store_String_Char
(' ');
2948 Store_String_Chars
(Symbols
);
2949 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
2953 if Present
(New_Str_Lit
) then
2955 -- Insert all actuals in New_Actuals
2957 Actual
:= First
(Actuals
);
2958 while Present
(Actual
) loop
2960 -- Copy every actuals in New_Actuals except the Symbols
2961 -- parameter association.
2963 if Nkind
(Actual
) = N_Parameter_Association
2964 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
2966 Append_To
(New_Actuals
,
2967 Make_Parameter_Association
(Loc
,
2968 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
2969 Explicit_Actual_Parameter
=>
2970 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
2972 elsif Nkind
(Actual
) /= N_Parameter_Association
then
2973 Append_To
(New_Actuals
, New_Copy
(Actual
));
2979 -- Create new Symbols param association and append to New_Actuals
2981 Append_To
(New_Actuals
,
2982 Make_Parameter_Association
(Loc
,
2983 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
2984 Explicit_Actual_Parameter
=> New_Str_Lit
));
2986 -- Rewrite and analyze the procedure call
2989 Make_Procedure_Call_Statement
(Loc
,
2990 Name
=> New_Copy
(Name_Call
),
2991 Parameter_Associations
=> New_Actuals
));
2996 end Expand_Put_Call_With_Symbol
;
2998 ------------------------------------
2999 -- From_Dim_To_Str_Of_Dim_Symbols --
3000 ------------------------------------
3002 -- Given a dimension vector and the corresponding dimension system, create
3003 -- a String_Id to output dimension symbols corresponding to the dimensions
3004 -- Dims. If In_Error_Msg is True, there is a special handling for character
3005 -- asterisk * which is an insertion character in error messages.
3007 function From_Dim_To_Str_Of_Dim_Symbols
3008 (Dims
: Dimension_Type
;
3009 System
: System_Type
;
3010 In_Error_Msg
: Boolean := False) return String_Id
3012 Dim_Power
: Rational
;
3013 First_Dim
: Boolean := True;
3015 procedure Store_String_Oexpon
;
3016 -- Store the expon operator symbol "**" in the string. In error
3017 -- messages, asterisk * is a special character and must be quoted
3018 -- to be placed literally into the message.
3020 -------------------------
3021 -- Store_String_Oexpon --
3022 -------------------------
3024 procedure Store_String_Oexpon
is
3026 if In_Error_Msg
then
3027 Store_String_Chars
("'*'*");
3029 Store_String_Chars
("**");
3031 end Store_String_Oexpon
;
3033 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3036 -- Initialization of the new String_Id
3040 -- Store the dimension symbols inside boxes
3042 Store_String_Char
('[');
3044 for Position
in Dimension_Type
'Range loop
3045 Dim_Power
:= Dims
(Position
);
3046 if Dim_Power
/= Zero
then
3051 Store_String_Char
('.');
3054 Store_String_Chars
(System
.Dim_Symbols
(Position
));
3056 -- Positive dimension case
3058 if Dim_Power
.Numerator
> 0 then
3061 if Dim_Power
.Denominator
= 1 then
3062 if Dim_Power
.Numerator
/= 1 then
3063 Store_String_Oexpon
;
3064 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3067 -- Rational case when denominator /= 1
3070 Store_String_Oexpon
;
3071 Store_String_Char
('(');
3072 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3073 Store_String_Char
('/');
3074 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3075 Store_String_Char
(')');
3078 -- Negative dimension case
3081 Store_String_Oexpon
;
3082 Store_String_Char
('(');
3083 Store_String_Char
('-');
3084 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3088 if Dim_Power
.Denominator
= 1 then
3089 Store_String_Char
(')');
3091 -- Rational case when denominator /= 1
3094 Store_String_Char
('/');
3095 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3096 Store_String_Char
(')');
3102 Store_String_Char
(']');
3104 end From_Dim_To_Str_Of_Dim_Symbols
;
3106 -------------------------------------
3107 -- From_Dim_To_Str_Of_Unit_Symbols --
3108 -------------------------------------
3110 -- Given a dimension vector and the corresponding dimension system,
3111 -- create a String_Id to output the unit symbols corresponding to the
3114 function From_Dim_To_Str_Of_Unit_Symbols
3115 (Dims
: Dimension_Type
;
3116 System
: System_Type
) return String_Id
3118 Dim_Power
: Rational
;
3119 First_Dim
: Boolean := True;
3122 -- Return No_String if dimensionless
3124 if not Exists
(Dims
) then
3128 -- Initialization of the new String_Id
3132 for Position
in Dimension_Type
'Range loop
3133 Dim_Power
:= Dims
(Position
);
3135 if Dim_Power
/= Zero
then
3140 Store_String_Char
('.');
3143 Store_String_Chars
(System
.Unit_Symbols
(Position
));
3145 -- Positive dimension case
3147 if Dim_Power
.Numerator
> 0 then
3151 if Dim_Power
.Denominator
= 1 then
3152 if Dim_Power
.Numerator
/= 1 then
3153 Store_String_Chars
("**");
3154 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3157 -- Rational case when denominator /= 1
3160 Store_String_Chars
("**");
3161 Store_String_Char
('(');
3162 Store_String_Int
(Int
(Dim_Power
.Numerator
));
3163 Store_String_Char
('/');
3164 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3165 Store_String_Char
(')');
3168 -- Negative dimension case
3171 Store_String_Chars
("**");
3172 Store_String_Char
('(');
3173 Store_String_Char
('-');
3174 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
3178 if Dim_Power
.Denominator
= 1 then
3179 Store_String_Char
(')');
3181 -- Rational case when denominator /= 1
3184 Store_String_Char
('/');
3185 Store_String_Int
(Int
(Dim_Power
.Denominator
));
3186 Store_String_Char
(')');
3193 end From_Dim_To_Str_Of_Unit_Symbols
;
3199 function GCD
(Left
, Right
: Whole
) return Int
is
3219 --------------------------
3220 -- Has_Dimension_System --
3221 --------------------------
3223 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
3225 return Exists
(System_Of
(Typ
));
3226 end Has_Dimension_System
;
3228 ------------------------------
3229 -- Is_Dim_IO_Package_Entity --
3230 ------------------------------
3232 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
3234 -- Check the package entity corresponds to System.Dim.Float_IO or
3235 -- System.Dim.Integer_IO.
3238 Is_RTU
(E
, System_Dim_Float_IO
)
3240 Is_RTU
(E
, System_Dim_Integer_IO
);
3241 end Is_Dim_IO_Package_Entity
;
3243 -------------------------------------
3244 -- Is_Dim_IO_Package_Instantiation --
3245 -------------------------------------
3247 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
3248 Gen_Id
: constant Node_Id
:= Name
(N
);
3251 -- Check that the instantiated package is either System.Dim.Float_IO
3252 -- or System.Dim.Integer_IO.
3255 Is_Entity_Name
(Gen_Id
)
3256 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
3257 end Is_Dim_IO_Package_Instantiation
;
3263 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
3265 return Position
= Invalid_Position
;
3268 ---------------------
3269 -- Move_Dimensions --
3270 ---------------------
3272 procedure Move_Dimensions
(From
, To
: Node_Id
) is
3274 if Ada_Version
< Ada_2012
then
3278 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3280 Copy_Dimensions
(From
, To
);
3281 Remove_Dimensions
(From
);
3282 end Move_Dimensions
;
3288 function Reduce
(X
: Rational
) return Rational
is
3290 if X
.Numerator
= 0 then
3295 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
3297 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
3298 Denominator => Whole (Int (X.Denominator) / G));
3302 -----------------------
3303 -- Remove_Dimensions --
3304 -----------------------
3306 procedure Remove_Dimensions (N : Node_Id) is
3307 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3309 if Exists (Dims_Of_N) then
3310 Dimension_Table.Remove (N);
3312 end Remove_Dimensions;
3314 -----------------------------------
3315 -- Remove_Dimension_In_Statement --
3316 -----------------------------------
3318 -- Removal of dimension in statement as part of the Analyze_Statements
3319 -- routine (see package Sem_Ch5).
3321 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3323 if Ada_Version < Ada_2012 then
3327 -- Remove dimension in parameter specifications for accept statement
3329 if Nkind (Stmt) = N_Accept_Statement then
3331 Param : Node_Id := First (Parameter_Specifications (Stmt));
3333 while Present (Param) loop
3334 Remove_Dimensions (Param);
3339 -- Remove dimension of name and expression in assignments
3341 elsif Nkind (Stmt) = N_Assignment_Statement then
3342 Remove_Dimensions (Expression (Stmt));
3343 Remove_Dimensions (Name (Stmt));
3345 end Remove_Dimension_In_Statement;
3347 --------------------
3348 -- Set_Dimensions --
3349 --------------------
3351 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3353 pragma Assert (OK_For_Dimension (Nkind (N)));
3354 pragma Assert (Exists (Val));
3356 Dimension_Table.Set (N, Val);
3363 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3365 Symbol_Table.Set (E, Val);
3368 ---------------------------------
3369 -- String_From_Numeric_Literal --
3370 ---------------------------------
3372 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3373 Loc : constant Source_Ptr := Sloc (N);
3374 Sbuffer : constant Source_Buffer_Ptr :=
3375 Source_Text (Get_Source_File_Index (Loc));
3376 Src_Ptr : Source_Ptr := Loc;
3377 C : Character := Sbuffer (Src_Ptr);
3378 -- Current source program character
3380 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3381 -- Return True if C belongs to a numeric literal
3383 -------------------------------
3384 -- Belong_To_Numeric_Literal --
3385 -------------------------------
3387 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3403 -- Make sure '+' or '-' is part of an exponent.
3407 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3409 return Prev_C = 'e
' or else Prev_C = 'E
';
3412 -- All other character doesn't belong to a numeric literal
3417 end Belong_To_Numeric_Literal;
3419 -- Start of processing for String_From_Numeric_Literal
3423 while Belong_To_Numeric_Literal (C) loop
3424 Store_String_Char (C);
3425 Src_Ptr := Src_Ptr + 1;
3426 C := Sbuffer (Src_Ptr);
3430 end String_From_Numeric_Literal;
3436 function Symbol_Of (E : Entity_Id) return String_Id is
3437 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3439 if Subtype_Symbol /= No_String then
3440 return Subtype_Symbol;
3442 return From_Dim_To_Str_Of_Unit_Symbols
3443 (Dimensions_Of (E), System_Of (Base_Type (E)));
3447 -----------------------
3448 -- Symbol_Table_Hash --
3449 -----------------------
3451 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3453 return Symbol_Table_Range (Key mod 511);
3454 end Symbol_Table_Hash;
3460 function System_Of (E : Entity_Id) return System_Type is
3461 Type_Decl : constant Node_Id := Parent (E);
3464 -- Look for Type_Decl in System_Table
3466 for Dim_Sys in 1 .. System_Table.Last loop
3467 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3468 return System_Table.Table (Dim_Sys);