Skip various cmp-mem-const tests on lp64 hppa*-*-*
[official-gcc.git] / gcc / ada / sem_dim.adb
blob816870fc70a7bf3832ee2d7ea654d65bf694664f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ D I M --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2011-2023, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Einfo.Entities; use Einfo.Entities;
29 with Einfo.Utils; use Einfo.Utils;
30 with Errout; use Errout;
31 with Exp_Util; use Exp_Util;
32 with Lib; use Lib;
33 with Namet; use Namet;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
36 with Opt; use Opt;
37 with Rtsfind; use Rtsfind;
38 with Sem; use Sem;
39 with Sem_Aux; use Sem_Aux;
40 with Sem_Eval; use Sem_Eval;
41 with Sem_Res; use Sem_Res;
42 with Sem_Util; use Sem_Util;
43 with Sinfo; use Sinfo;
44 with Sinfo.Nodes; use Sinfo.Nodes;
45 with Sinfo.Utils; use Sinfo.Utils;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Table;
50 with Tbuild; use Tbuild;
51 with Uintp; use Uintp;
52 with Urealp; use Urealp;
54 with GNAT.HTable;
56 package body Sem_Dim is
58 -------------------------
59 -- Rational Arithmetic --
60 -------------------------
62 type Whole is new Int;
63 subtype Positive_Whole is Whole range 1 .. Whole'Last;
65 type Rational is record
66 Numerator : Whole;
67 Denominator : Positive_Whole;
68 end record;
70 Zero : constant Rational := Rational'(Numerator => 0,
71 Denominator => 1);
73 No_Rational : constant Rational := Rational'(Numerator => 0,
74 Denominator => 2);
75 -- Used to indicate an expression that cannot be interpreted as a rational
76 -- Returned value of the Create_Rational_From routine when parameter Expr
77 -- is not a static representation of a rational.
79 -- Rational constructors
81 function "+" (Right : Whole) return Rational;
82 function GCD (Left, Right : Whole) return Int;
83 function Reduce (X : Rational) return Rational;
85 -- Unary operator for Rational
87 function "-" (Right : Rational) return Rational;
88 function "abs" (Right : Rational) return Rational;
90 -- Rational operations for Rationals
92 function "+" (Left, Right : Rational) return Rational;
93 function "-" (Left, Right : Rational) return Rational;
94 function "*" (Left, Right : Rational) return Rational;
95 function "/" (Left, Right : Rational) return Rational;
97 ------------------
98 -- System Types --
99 ------------------
101 Max_Number_Of_Dimensions : constant := 7;
102 -- Maximum number of dimensions in a dimension system
104 High_Position_Bound : constant := Max_Number_Of_Dimensions;
105 Invalid_Position : constant := 0;
106 Low_Position_Bound : constant := 1;
108 subtype Dimension_Position is
109 Nat range Invalid_Position .. High_Position_Bound;
111 type Name_Array is
112 array (Dimension_Position range
113 Low_Position_Bound .. High_Position_Bound) of Name_Id;
114 -- Store the names of all units within a system
116 No_Names : constant Name_Array := (others => No_Name);
118 type Symbol_Array is
119 array (Dimension_Position range
120 Low_Position_Bound .. High_Position_Bound) of String_Id;
121 -- Store the symbols of all units within a system
123 No_Symbols : constant Symbol_Array := (others => No_String);
125 -- The following record should be documented field by field
127 type System_Type is record
128 Type_Decl : Node_Id;
129 Unit_Names : Name_Array;
130 Unit_Symbols : Symbol_Array;
131 Dim_Symbols : Symbol_Array;
132 Count : Dimension_Position;
133 end record;
135 Null_System : constant System_Type :=
136 (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
138 subtype System_Id is Nat;
140 -- The following table maps types to systems
142 package System_Table is new Table.Table (
143 Table_Component_Type => System_Type,
144 Table_Index_Type => System_Id,
145 Table_Low_Bound => 1,
146 Table_Initial => 5,
147 Table_Increment => 5,
148 Table_Name => "System_Table");
150 --------------------
151 -- Dimension Type --
152 --------------------
154 type Dimension_Type is
155 array (Dimension_Position range
156 Low_Position_Bound .. High_Position_Bound) of Rational;
158 Null_Dimension : constant Dimension_Type := (others => Zero);
160 type Dimension_Table_Range is range 0 .. 510;
161 function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
163 -- The following table associates nodes with dimensions
165 package Dimension_Table is new
166 GNAT.HTable.Simple_HTable
167 (Header_Num => Dimension_Table_Range,
168 Element => Dimension_Type,
169 No_Element => Null_Dimension,
170 Key => Node_Id,
171 Hash => Dimension_Table_Hash,
172 Equal => "=");
174 ------------------
175 -- Symbol Types --
176 ------------------
178 type Symbol_Table_Range is range 0 .. 510;
179 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
181 -- Each subtype with a dimension has a symbolic representation of the
182 -- related unit. This table establishes a relation between the subtype
183 -- and the symbol.
185 package Symbol_Table is new
186 GNAT.HTable.Simple_HTable
187 (Header_Num => Symbol_Table_Range,
188 Element => String_Id,
189 No_Element => No_String,
190 Key => Entity_Id,
191 Hash => Symbol_Table_Hash,
192 Equal => "=");
194 -- The following array enumerates all contexts which may contain or
195 -- produce a dimension.
197 OK_For_Dimension : constant array (Node_Kind) of Boolean :=
198 (N_Attribute_Reference => True,
199 N_Case_Expression => True,
200 N_Expanded_Name => True,
201 N_Explicit_Dereference => True,
202 N_Defining_Identifier => True,
203 N_Function_Call => True,
204 N_Identifier => True,
205 N_If_Expression => True,
206 N_Indexed_Component => True,
207 N_Integer_Literal => True,
208 N_Op_Abs => True,
209 N_Op_Add => True,
210 N_Op_Divide => True,
211 N_Op_Expon => True,
212 N_Op_Minus => True,
213 N_Op_Mod => True,
214 N_Op_Multiply => True,
215 N_Op_Plus => True,
216 N_Op_Rem => True,
217 N_Op_Subtract => True,
218 N_Qualified_Expression => True,
219 N_Real_Literal => True,
220 N_Selected_Component => True,
221 N_Slice => True,
222 N_Type_Conversion => True,
223 N_Unchecked_Type_Conversion => True,
225 others => False);
227 -----------------------
228 -- Local Subprograms --
229 -----------------------
231 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
232 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
233 -- dimensions of the left-hand side and the right-hand side of N match.
235 procedure Analyze_Dimension_Binary_Op (N : Node_Id);
236 -- Subroutine of Analyze_Dimension for binary operators. Check the
237 -- dimensions of the right and the left operand permit the operation.
238 -- Then, evaluate the resulting dimensions for each binary operator.
240 procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
241 -- Subroutine of Analyze_Dimension for component declaration. Check that
242 -- the dimensions of the type of N and of the expression match.
244 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
245 -- Subroutine of Analyze_Dimension for extended return statement. Check
246 -- that the dimensions of the returned type and of the returned object
247 -- match.
249 procedure Analyze_Dimension_Has_Etype (N : Node_Id);
250 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
251 -- the list below:
252 -- N_Attribute_Reference
253 -- N_Identifier
254 -- N_Indexed_Component
255 -- N_Qualified_Expression
256 -- N_Selected_Component
257 -- N_Slice
258 -- N_Type_Conversion
259 -- N_Unchecked_Type_Conversion
261 procedure Analyze_Dimension_Case_Expression (N : Node_Id);
262 -- Verify that all alternatives have the same dimension
264 procedure Analyze_Dimension_If_Expression (N : Node_Id);
265 -- Verify that all alternatives have the same dimension
267 procedure Analyze_Dimension_Number_Declaration (N : Node_Id);
268 -- Procedure to analyze dimension of expression in a number declaration.
269 -- This allows a named number to have nontrivial dimensions, while by
270 -- default a named number is dimensionless.
272 procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
273 -- Subroutine of Analyze_Dimension for object declaration. Check that
274 -- the dimensions of the object type and the dimensions of the expression
275 -- (if expression is present) match. Note that when the expression is
276 -- a literal, no error is returned. This special case allows object
277 -- declaration such as: m : constant Length := 1.0;
279 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
280 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
281 -- the dimensions of the type and of the renamed object name of N match.
283 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
284 -- Subroutine of Analyze_Dimension for simple return statement
285 -- Check that the dimensions of the returned type and of the returned
286 -- expression match.
288 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
289 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
290 -- dimensions from the parent type to the identifier of N. Note that if
291 -- both the identifier and the parent type of N are not dimensionless,
292 -- return an error.
294 procedure Analyze_Dimension_Type_Conversion (N : Node_Id);
295 -- Type conversions handle conversions between literals and dimensioned
296 -- types, from dimensioned types to their base type, and between different
297 -- dimensioned systems. Dimensions of the conversion are obtained either
298 -- from those of the expression, or from the target type, and dimensional
299 -- consistency must be checked when converting between values belonging
300 -- to different dimensioned systems.
302 procedure Analyze_Dimension_Unary_Op (N : Node_Id);
303 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
304 -- Abs operators, propagate the dimensions from the operand to N.
306 function Create_Rational_From
307 (Expr : Node_Id;
308 Complain : Boolean) return Rational;
309 -- Given an arbitrary expression Expr, return a valid rational if Expr can
310 -- be interpreted as a rational. Otherwise return No_Rational and also an
311 -- error message if Complain is set to True.
313 function Dimensions_Of (N : Node_Id) return Dimension_Type;
314 -- Return the dimension vector of node N
316 function Dimensions_Msg_Of
317 (N : Node_Id;
318 Description_Needed : Boolean := False) return String;
319 -- Given a node N, return the dimension symbols of N, preceded by "has
320 -- dimension" if Description_Needed. If N is dimensionless, return "'[']",
321 -- or "is dimensionless" if Description_Needed.
323 function Dimension_System_Root (T : Entity_Id) return Entity_Id;
324 -- Given a type that has dimension information, return the type that is the
325 -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
326 -- type, i.e. a standard numeric type, return Empty.
328 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
329 -- Issue a warning on the given numeric literal N to indicate that the
330 -- compiler made the assumption that the literal is not dimensionless
331 -- but has the dimension of Typ.
333 procedure Eval_Op_Expon_With_Rational_Exponent
334 (N : Node_Id;
335 Exponent_Value : Rational);
336 -- Evaluate the exponent it is a rational and the operand has a dimension
338 function Exists (Dim : Dimension_Type) return Boolean;
339 -- Returns True iff Dim does not denote the null dimension
341 function Exists (Str : String_Id) return Boolean;
342 -- Returns True iff Str does not denote No_String
344 function Exists (Sys : System_Type) return Boolean;
345 -- Returns True iff Sys does not denote the null system
347 function From_Dim_To_Str_Of_Dim_Symbols
348 (Dims : Dimension_Type;
349 System : System_Type;
350 In_Error_Msg : Boolean := False) return String_Id;
351 -- Given a dimension vector and a dimension system, return the proper
352 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
353 -- will be used to issue an error message) then this routine has a special
354 -- handling for the insertion characters * or [ which must be preceded by
355 -- a quote ' to be placed literally into the message.
357 function From_Dim_To_Str_Of_Unit_Symbols
358 (Dims : Dimension_Type;
359 System : System_Type) return String_Id;
360 -- Given a dimension vector and a dimension system, return the proper
361 -- string of unit symbols.
363 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
364 -- Return True if E is the package entity of System.Dim.Float_IO or
365 -- System.Dim.Integer_IO.
367 function Is_Invalid (Position : Dimension_Position) return Boolean;
368 -- Return True if Pos denotes the invalid position
370 procedure Move_Dimensions (From : Node_Id; To : Node_Id);
371 -- Copy dimension vector of From to To and delete dimension vector of From
373 procedure Remove_Dimensions (N : Node_Id);
374 -- Remove the dimension vector of node N
376 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
377 -- Associate a dimension vector with a node
379 procedure Set_Symbol (E : Entity_Id; Val : String_Id);
380 -- Associate a symbol representation of a dimension vector with a subtype
382 function Symbol_Of (E : Entity_Id) return String_Id;
383 -- E denotes a subtype with a dimension. Return the symbol representation
384 -- of the dimension vector.
386 function System_Of (E : Entity_Id) return System_Type;
387 -- E denotes a type, return associated system of the type if it has one
389 ---------
390 -- "+" --
391 ---------
393 function "+" (Right : Whole) return Rational is
394 begin
395 return Rational'(Numerator => Right, Denominator => 1);
396 end "+";
398 function "+" (Left, Right : Rational) return Rational is
399 R : constant Rational :=
400 Rational'(Numerator => Left.Numerator * Right.Denominator +
401 Left.Denominator * Right.Numerator,
402 Denominator => Left.Denominator * Right.Denominator);
403 begin
404 return Reduce (R);
405 end "+";
407 ---------
408 -- "-" --
409 ---------
411 function "-" (Right : Rational) return Rational is
412 begin
413 return Rational'(Numerator => -Right.Numerator,
414 Denominator => Right.Denominator);
415 end "-";
417 function "-" (Left, Right : Rational) return Rational is
418 R : constant Rational :=
419 Rational'(Numerator => Left.Numerator * Right.Denominator -
420 Left.Denominator * Right.Numerator,
421 Denominator => Left.Denominator * Right.Denominator);
423 begin
424 return Reduce (R);
425 end "-";
427 ---------
428 -- "*" --
429 ---------
431 function "*" (Left, Right : Rational) return Rational is
432 R : constant Rational :=
433 Rational'(Numerator => Left.Numerator * Right.Numerator,
434 Denominator => Left.Denominator * Right.Denominator);
435 begin
436 return Reduce (R);
437 end "*";
439 ---------
440 -- "/" --
441 ---------
443 function "/" (Left, Right : Rational) return Rational is
444 R : constant Rational := abs Right;
445 L : Rational := Left;
447 begin
448 if Right.Numerator < 0 then
449 L.Numerator := Whole (-Integer (L.Numerator));
450 end if;
452 return Reduce (Rational'(Numerator => L.Numerator * R.Denominator,
453 Denominator => L.Denominator * R.Numerator));
454 end "/";
456 -----------
457 -- "abs" --
458 -----------
460 function "abs" (Right : Rational) return Rational is
461 begin
462 return Rational'(Numerator => abs Right.Numerator,
463 Denominator => Right.Denominator);
464 end "abs";
466 ------------------------------
467 -- Analyze_Aspect_Dimension --
468 ------------------------------
470 -- with Dimension =>
471 -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
473 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
475 -- DIMENSION_VALUE ::=
476 -- RATIONAL
477 -- | others => RATIONAL
478 -- | DISCRETE_CHOICE_LIST => RATIONAL
480 -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
482 -- Note that when the dimensioned type is an integer type, then any
483 -- dimension value must be an integer literal.
485 procedure Analyze_Aspect_Dimension
486 (N : Node_Id;
487 Id : Entity_Id;
488 Aggr : Node_Id)
490 Def_Id : constant Entity_Id := Defining_Identifier (N);
492 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
493 -- This array is used when processing ranges or Others_Choice as part of
494 -- the dimension aggregate.
496 Dimensions : Dimension_Type := Null_Dimension;
498 procedure Extract_Power
499 (Expr : Node_Id;
500 Position : Dimension_Position);
501 -- Given an expression with denotes a rational number, read the number
502 -- and associate it with Position in Dimensions.
504 function Position_In_System
505 (Id : Node_Id;
506 System : System_Type) return Dimension_Position;
507 -- Given an identifier which denotes a dimension, return the position of
508 -- that dimension within System.
510 -------------------
511 -- Extract_Power --
512 -------------------
514 procedure Extract_Power
515 (Expr : Node_Id;
516 Position : Dimension_Position)
518 begin
519 Dimensions (Position) := Create_Rational_From (Expr, True);
520 Processed (Position) := True;
522 -- If the dimensioned root type is an integer type, it is not
523 -- particularly useful, and fractional dimensions do not make
524 -- much sense for such types, so previously we used to reject
525 -- dimensions of integer types that were not integer literals.
526 -- However, the manipulation of dimensions does not depend on
527 -- the kind of root type, so we can accept this usage for rare
528 -- cases where dimensions are specified for integer values.
530 end Extract_Power;
532 ------------------------
533 -- Position_In_System --
534 ------------------------
536 function Position_In_System
537 (Id : Node_Id;
538 System : System_Type) return Dimension_Position
540 Dimension_Name : constant Name_Id := Chars (Id);
542 begin
543 for Position in System.Unit_Names'Range loop
544 if Dimension_Name = System.Unit_Names (Position) then
545 return Position;
546 end if;
547 end loop;
549 return Invalid_Position;
550 end Position_In_System;
552 -- Local variables
554 Assoc : Node_Id;
555 Choice : Node_Id;
556 Expr : Node_Id;
557 Num_Choices : Nat := 0;
558 Num_Dimensions : Nat := 0;
559 Others_Seen : Boolean := False;
560 Position : Nat := 0;
561 Sub_Ind : Node_Id;
562 Symbol : String_Id := No_String;
563 Symbol_Expr : Node_Id;
564 System : System_Type;
565 Typ : Entity_Id;
567 Errors_Count : Nat;
568 -- Errors_Count is a count of errors detected by the compiler so far
569 -- just before the extraction of symbol, names and values in the
570 -- aggregate (Step 2).
572 -- At the end of the analysis, there is a check to verify that this
573 -- count equals to Serious_Errors_Detected i.e. no erros have been
574 -- encountered during the process. Otherwise the Dimension_Table is
575 -- not filled.
577 -- Start of processing for Analyze_Aspect_Dimension
579 begin
580 -- STEP 1: Legality of aspect
582 if Nkind (N) /= N_Subtype_Declaration then
583 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
584 return;
585 end if;
587 Sub_Ind := Subtype_Indication (N);
588 Typ := Etype (Sub_Ind);
589 System := System_Of (Typ);
591 if Nkind (Sub_Ind) = N_Subtype_Indication then
592 Error_Msg_NE
593 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
594 return;
595 end if;
597 -- The dimension declarations are useless if the parent type does not
598 -- declare a valid system.
600 if not Exists (System) then
601 Error_Msg_NE
602 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
603 return;
604 end if;
606 if Nkind (Aggr) /= N_Aggregate then
607 Error_Msg_N ("aggregate expected", Aggr);
608 return;
609 end if;
611 -- STEP 2: Symbol, Names and values extraction
613 -- Get the number of errors detected by the compiler so far
615 Errors_Count := Serious_Errors_Detected;
617 -- STEP 2a: Symbol extraction
619 -- The first entry in the aggregate may be the symbolic representation
620 -- of the quantity.
622 -- Positional symbol argument
624 Symbol_Expr := First (Expressions (Aggr));
626 -- Named symbol argument
628 if No (Symbol_Expr)
629 or else Nkind (Symbol_Expr) not in
630 N_Character_Literal | N_String_Literal
631 then
632 Symbol_Expr := Empty;
634 -- Component associations present
636 if Present (Component_Associations (Aggr)) then
637 Assoc := First (Component_Associations (Aggr));
638 Choice := First (Choices (Assoc));
640 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
642 -- Symbol component association is present
644 if Chars (Choice) = Name_Symbol then
645 Num_Choices := Num_Choices + 1;
646 Symbol_Expr := Expression (Assoc);
648 -- Verify symbol expression is a string or a character
650 if Nkind (Symbol_Expr) not in
651 N_Character_Literal | N_String_Literal
652 then
653 Symbol_Expr := Empty;
654 Error_Msg_N
655 ("symbol expression must be character or string",
656 Symbol_Expr);
657 end if;
659 -- Special error if no Symbol choice but expression is string
660 -- or character.
662 elsif Nkind (Expression (Assoc)) in
663 N_Character_Literal | N_String_Literal
664 then
665 Num_Choices := Num_Choices + 1;
666 Error_Msg_N
667 ("optional component Symbol expected, found&", Choice);
668 end if;
669 end if;
670 end if;
671 end if;
673 -- STEP 2b: Names and values extraction
675 -- Positional elements
677 Expr := First (Expressions (Aggr));
679 -- Skip the symbol expression when present
681 if Present (Symbol_Expr) and then Num_Choices = 0 then
682 Next (Expr);
683 end if;
685 Position := Low_Position_Bound;
686 while Present (Expr) loop
687 if Position > High_Position_Bound then
688 Error_Msg_N
689 ("type& has more dimensions than system allows", Def_Id);
690 exit;
691 end if;
693 Extract_Power (Expr, Position);
695 Position := Position + 1;
696 Num_Dimensions := Num_Dimensions + 1;
698 Next (Expr);
699 end loop;
701 -- Named elements
703 Assoc := First (Component_Associations (Aggr));
705 -- Skip the symbol association when present
707 if Num_Choices = 1 then
708 Next (Assoc);
709 end if;
711 while Present (Assoc) loop
712 Expr := Expression (Assoc);
714 Choice := First (Choices (Assoc));
715 while Present (Choice) loop
717 -- Identifier case: NAME => EXPRESSION
719 if Nkind (Choice) = N_Identifier then
720 Position := Position_In_System (Choice, System);
722 if Is_Invalid (Position) then
723 Error_Msg_N ("dimension name& not part of system", Choice);
724 else
725 Extract_Power (Expr, Position);
726 end if;
728 -- Range case: NAME .. NAME => EXPRESSION
730 elsif Nkind (Choice) = N_Range then
731 declare
732 Low : constant Node_Id := Low_Bound (Choice);
733 High : constant Node_Id := High_Bound (Choice);
734 Low_Pos : Dimension_Position;
735 High_Pos : Dimension_Position;
737 begin
738 if Nkind (Low) /= N_Identifier then
739 Error_Msg_N ("bound must denote a dimension name", Low);
741 elsif Nkind (High) /= N_Identifier then
742 Error_Msg_N ("bound must denote a dimension name", High);
744 else
745 Low_Pos := Position_In_System (Low, System);
746 High_Pos := Position_In_System (High, System);
748 if Is_Invalid (Low_Pos) then
749 Error_Msg_N ("dimension name& not part of system",
750 Low);
752 elsif Is_Invalid (High_Pos) then
753 Error_Msg_N ("dimension name& not part of system",
754 High);
756 elsif Low_Pos > High_Pos then
757 Error_Msg_N ("expected low to high range", Choice);
759 else
760 for Position in Low_Pos .. High_Pos loop
761 Extract_Power (Expr, Position);
762 end loop;
763 end if;
764 end if;
765 end;
767 -- Others case: OTHERS => EXPRESSION
769 elsif Nkind (Choice) = N_Others_Choice then
770 if Present (Next (Choice)) or else Present (Prev (Choice)) then
771 Error_Msg_N
772 ("OTHERS must appear alone in a choice list", Choice);
774 elsif Present (Next (Assoc)) then
775 Error_Msg_N
776 ("OTHERS must appear last in an aggregate", Choice);
778 elsif Others_Seen then
779 Error_Msg_N ("multiple OTHERS not allowed", Choice);
781 else
782 -- Fill the non-processed dimensions with the default value
783 -- supplied by others.
785 for Position in Processed'Range loop
786 if not Processed (Position) then
787 Extract_Power (Expr, Position);
788 end if;
789 end loop;
790 end if;
792 Others_Seen := True;
794 -- All other cases are illegal declarations of dimension names
796 else
797 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
798 end if;
800 Num_Choices := Num_Choices + 1;
801 Next (Choice);
802 end loop;
804 Num_Dimensions := Num_Dimensions + 1;
805 Next (Assoc);
806 end loop;
808 -- STEP 3: Consistency of system and dimensions
810 if Present (First (Expressions (Aggr)))
811 and then (First (Expressions (Aggr)) /= Symbol_Expr
812 or else Present (Next (Symbol_Expr)))
813 and then (Num_Choices > 1
814 or else (Num_Choices = 1 and then not Others_Seen))
815 then
816 Error_Msg_N
817 ("named associations cannot follow positional associations", Aggr);
818 end if;
820 if Num_Dimensions > System.Count then
821 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
823 elsif Num_Dimensions < System.Count and then not Others_Seen then
824 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
825 end if;
827 -- STEP 4: Dimension symbol extraction
829 if Present (Symbol_Expr) then
830 if Nkind (Symbol_Expr) = N_Character_Literal then
831 Start_String;
832 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
833 Symbol := End_String;
835 else
836 Symbol := Strval (Symbol_Expr);
837 end if;
839 if String_Length (Symbol) = 0 then
840 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
841 end if;
842 end if;
844 -- STEP 5: Storage of extracted values
846 -- Check that no errors have been detected during the analysis
848 if Errors_Count = Serious_Errors_Detected then
850 -- Check for useless declaration
852 if Symbol = No_String and then not Exists (Dimensions) then
853 Error_Msg_N ("useless dimension declaration", Aggr);
854 end if;
856 if Symbol /= No_String then
857 Set_Symbol (Def_Id, Symbol);
858 end if;
860 if Exists (Dimensions) then
861 Set_Dimensions (Def_Id, Dimensions);
862 end if;
863 end if;
864 end Analyze_Aspect_Dimension;
866 -------------------------------------
867 -- Analyze_Aspect_Dimension_System --
868 -------------------------------------
870 -- with Dimension_System => (DIMENSION {, DIMENSION});
872 -- DIMENSION ::= (
873 -- [Unit_Name =>] IDENTIFIER,
874 -- [Unit_Symbol =>] SYMBOL,
875 -- [Dim_Symbol =>] SYMBOL)
877 procedure Analyze_Aspect_Dimension_System
878 (N : Node_Id;
879 Id : Entity_Id;
880 Aggr : Node_Id)
882 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
883 -- Determine whether type declaration N denotes a numeric derived type
885 -------------------------------
886 -- Is_Derived_Numeric_Type --
887 -------------------------------
889 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
890 begin
891 return
892 Nkind (N) = N_Full_Type_Declaration
893 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
894 and then Is_Numeric_Type
895 (Entity (Subtype_Indication (Type_Definition (N))));
896 end Is_Derived_Numeric_Type;
898 -- Local variables
900 Assoc : Node_Id;
901 Choice : Node_Id;
902 Dim_Aggr : Node_Id;
903 Dim_Symbol : Node_Id;
904 Dim_Symbols : Symbol_Array := No_Symbols;
905 Dim_System : System_Type := Null_System;
906 Position : Dimension_Position := Invalid_Position;
907 Unit_Name : Node_Id;
908 Unit_Names : Name_Array := No_Names;
909 Unit_Symbol : Node_Id;
910 Unit_Symbols : Symbol_Array := No_Symbols;
912 Errors_Count : Nat;
913 -- Errors_Count is a count of errors detected by the compiler so far
914 -- just before the extraction of names and symbols in the aggregate
915 -- (Step 3).
917 -- At the end of the analysis, there is a check to verify that this
918 -- count equals Serious_Errors_Detected i.e. no errors have been
919 -- encountered during the process. Otherwise the System_Table is
920 -- not filled.
922 -- Start of processing for Analyze_Aspect_Dimension_System
924 begin
925 -- STEP 1: Legality of aspect
927 if not Is_Derived_Numeric_Type (N) then
928 Error_Msg_NE
929 ("aspect& must apply to numeric derived type declaration", N, Id);
930 return;
931 end if;
933 if Nkind (Aggr) /= N_Aggregate then
934 Error_Msg_N ("aggregate expected", Aggr);
935 return;
936 end if;
938 -- STEP 2: Structural verification of the dimension aggregate
940 if Present (Component_Associations (Aggr)) then
941 Error_Msg_N ("expected positional aggregate", Aggr);
942 return;
943 end if;
945 -- STEP 3: Name and Symbol extraction
947 Dim_Aggr := First (Expressions (Aggr));
948 Errors_Count := Serious_Errors_Detected;
949 while Present (Dim_Aggr) loop
950 if Position = High_Position_Bound then
951 Error_Msg_N ("too many dimensions in system", Aggr);
952 exit;
953 end if;
955 Position := Position + 1;
957 if Nkind (Dim_Aggr) /= N_Aggregate then
958 Error_Msg_N ("aggregate expected", Dim_Aggr);
960 else
961 if Present (Component_Associations (Dim_Aggr))
962 and then Present (Expressions (Dim_Aggr))
963 then
964 Error_Msg_N
965 ("mixed positional/named aggregate not allowed here",
966 Dim_Aggr);
968 -- Verify each dimension aggregate has three arguments
970 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
971 and then List_Length (Expressions (Dim_Aggr)) /= 3
972 then
973 Error_Msg_N
974 ("three components expected in aggregate", Dim_Aggr);
976 else
977 -- Named dimension aggregate
979 if Present (Component_Associations (Dim_Aggr)) then
981 -- Check first argument denotes the unit name
983 Assoc := First (Component_Associations (Dim_Aggr));
984 Choice := First (Choices (Assoc));
985 Unit_Name := Expression (Assoc);
987 if Present (Next (Choice))
988 or else Nkind (Choice) /= N_Identifier
989 then
990 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
992 elsif Chars (Choice) /= Name_Unit_Name then
993 Error_Msg_N ("expected Unit_Name, found&", Choice);
994 end if;
996 -- Check the second argument denotes the unit symbol
998 Next (Assoc);
999 Choice := First (Choices (Assoc));
1000 Unit_Symbol := Expression (Assoc);
1002 if Present (Next (Choice))
1003 or else Nkind (Choice) /= N_Identifier
1004 then
1005 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1007 elsif Chars (Choice) /= Name_Unit_Symbol then
1008 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1009 end if;
1011 -- Check the third argument denotes the dimension symbol
1013 Next (Assoc);
1014 Choice := First (Choices (Assoc));
1015 Dim_Symbol := Expression (Assoc);
1017 if Present (Next (Choice))
1018 or else Nkind (Choice) /= N_Identifier
1019 then
1020 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1021 elsif Chars (Choice) /= Name_Dim_Symbol then
1022 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1023 end if;
1025 -- Positional dimension aggregate
1027 else
1028 Unit_Name := First (Expressions (Dim_Aggr));
1029 Unit_Symbol := Next (Unit_Name);
1030 Dim_Symbol := Next (Unit_Symbol);
1031 end if;
1033 -- Check the first argument for each dimension aggregate is
1034 -- a name.
1036 if Nkind (Unit_Name) = N_Identifier then
1037 Unit_Names (Position) := Chars (Unit_Name);
1038 else
1039 Error_Msg_N ("expected unit name", Unit_Name);
1040 end if;
1042 -- Check the second argument for each dimension aggregate is
1043 -- a string or a character.
1045 if Nkind (Unit_Symbol) not in
1046 N_String_Literal | N_Character_Literal
1047 then
1048 Error_Msg_N
1049 ("expected unit symbol (string or character)",
1050 Unit_Symbol);
1052 else
1053 -- String case
1055 if Nkind (Unit_Symbol) = N_String_Literal then
1056 Unit_Symbols (Position) := Strval (Unit_Symbol);
1058 -- Character case
1060 else
1061 Start_String;
1062 Store_String_Char
1063 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1064 Unit_Symbols (Position) := End_String;
1065 end if;
1067 -- Verify that the string is not empty
1069 if String_Length (Unit_Symbols (Position)) = 0 then
1070 Error_Msg_N
1071 ("empty string not allowed here", Unit_Symbol);
1072 end if;
1073 end if;
1075 -- Check the third argument for each dimension aggregate is
1076 -- a string or a character.
1078 if Nkind (Dim_Symbol) not in
1079 N_String_Literal | N_Character_Literal
1080 then
1081 Error_Msg_N
1082 ("expected dimension symbol (string or character)",
1083 Dim_Symbol);
1085 else
1086 -- String case
1088 if Nkind (Dim_Symbol) = N_String_Literal then
1089 Dim_Symbols (Position) := Strval (Dim_Symbol);
1091 -- Character case
1093 else
1094 Start_String;
1095 Store_String_Char
1096 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1097 Dim_Symbols (Position) := End_String;
1098 end if;
1100 -- Verify that the string is not empty
1102 if String_Length (Dim_Symbols (Position)) = 0 then
1103 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1104 end if;
1105 end if;
1106 end if;
1107 end if;
1109 Next (Dim_Aggr);
1110 end loop;
1112 -- STEP 4: Storage of extracted values
1114 -- Check that no errors have been detected during the analysis
1116 if Errors_Count = Serious_Errors_Detected then
1117 Dim_System.Type_Decl := N;
1118 Dim_System.Unit_Names := Unit_Names;
1119 Dim_System.Unit_Symbols := Unit_Symbols;
1120 Dim_System.Dim_Symbols := Dim_Symbols;
1121 Dim_System.Count := Position;
1122 System_Table.Append (Dim_System);
1123 end if;
1124 end Analyze_Aspect_Dimension_System;
1126 -----------------------
1127 -- Analyze_Dimension --
1128 -----------------------
1130 -- This dispatch routine propagates dimensions for each node
1132 procedure Analyze_Dimension (N : Node_Id) is
1133 begin
1134 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1135 -- dimensions for nodes that don't come from source, except for subtype
1136 -- declarations where the dimensions are inherited from the base type,
1137 -- for explicit dereferences generated when expanding iterators, and
1138 -- for object declarations generated for inlining.
1140 if Ada_Version < Ada_2012 then
1141 return;
1143 -- Inlined bodies have already been checked for dimensionality
1145 elsif In_Inlined_Body then
1146 return;
1148 elsif not Comes_From_Source (N) then
1149 if Nkind (N) not in N_Explicit_Dereference
1150 | N_Identifier
1151 | N_Object_Declaration
1152 | N_Subtype_Declaration
1153 then
1154 return;
1155 end if;
1156 end if;
1158 case Nkind (N) is
1159 when N_Assignment_Statement =>
1160 Analyze_Dimension_Assignment_Statement (N);
1162 when N_Binary_Op =>
1163 Analyze_Dimension_Binary_Op (N);
1165 when N_Case_Expression =>
1166 Analyze_Dimension_Case_Expression (N);
1168 when N_Component_Declaration =>
1169 Analyze_Dimension_Component_Declaration (N);
1171 when N_Extended_Return_Statement =>
1172 Analyze_Dimension_Extended_Return_Statement (N);
1174 when N_Attribute_Reference
1175 | N_Expanded_Name
1176 | N_Explicit_Dereference
1177 | N_Function_Call
1178 | N_Indexed_Component
1179 | N_Qualified_Expression
1180 | N_Selected_Component
1181 | N_Slice
1182 | N_Unchecked_Type_Conversion
1184 Analyze_Dimension_Has_Etype (N);
1186 -- In the presence of a repaired syntax error, an identifier may be
1187 -- introduced without a usable type.
1189 when N_Identifier =>
1190 if Present (Etype (N)) then
1191 Analyze_Dimension_Has_Etype (N);
1192 end if;
1194 when N_If_Expression =>
1195 Analyze_Dimension_If_Expression (N);
1197 when N_Number_Declaration =>
1198 Analyze_Dimension_Number_Declaration (N);
1200 when N_Object_Declaration =>
1201 Analyze_Dimension_Object_Declaration (N);
1203 when N_Object_Renaming_Declaration =>
1204 Analyze_Dimension_Object_Renaming_Declaration (N);
1206 when N_Simple_Return_Statement =>
1207 if not Comes_From_Extended_Return_Statement (N) then
1208 Analyze_Dimension_Simple_Return_Statement (N);
1209 end if;
1211 when N_Subtype_Declaration =>
1212 Analyze_Dimension_Subtype_Declaration (N);
1214 when N_Type_Conversion =>
1215 Analyze_Dimension_Type_Conversion (N);
1217 when N_Unary_Op =>
1218 Analyze_Dimension_Unary_Op (N);
1220 when others =>
1221 null;
1222 end case;
1223 end Analyze_Dimension;
1225 ---------------------------------------
1226 -- Analyze_Dimension_Array_Aggregate --
1227 ---------------------------------------
1229 procedure Analyze_Dimension_Array_Aggregate
1230 (N : Node_Id;
1231 Comp_Typ : Entity_Id)
1233 Comp_Ass : constant List_Id := Component_Associations (N);
1234 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1235 Exps : constant List_Id := Expressions (N);
1237 Comp : Node_Id;
1238 Dims_Of_Expr : Dimension_Type;
1239 Expr : Node_Id;
1241 Error_Detected : Boolean := False;
1242 -- This flag is used in order to indicate if an error has been detected
1243 -- so far by the compiler in this routine.
1245 begin
1246 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1247 -- base type is not a dimensioned type.
1249 -- Inlined bodies have already been checked for dimensionality.
1251 -- Note that here the original node must come from source since the
1252 -- original array aggregate may not have been entirely decorated.
1254 if Ada_Version < Ada_2012
1255 or else In_Inlined_Body
1256 or else not Comes_From_Source (Original_Node (N))
1257 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1258 then
1259 return;
1260 end if;
1262 -- Check whether there is any positional component association
1264 if Is_Empty_List (Exps) then
1265 Comp := First (Comp_Ass);
1266 else
1267 Comp := First (Exps);
1268 end if;
1270 while Present (Comp) loop
1272 -- Get the expression from the component
1274 if Nkind (Comp) = N_Component_Association then
1275 Expr := Expression (Comp);
1276 else
1277 Expr := Comp;
1278 end if;
1280 -- Issue an error if the dimensions of the component type and the
1281 -- dimensions of the component mismatch.
1283 -- Note that we must ensure the expression has been fully analyzed
1284 -- since it may not be decorated at this point. We also don't want to
1285 -- issue the same error message multiple times on the same expression
1286 -- (may happen when an aggregate is converted into a positional
1287 -- aggregate). We also must verify that this is a scalar component,
1288 -- and not a subaggregate of a multidimensional aggregate.
1289 -- The expression may be an identifier that has been copied several
1290 -- times during expansion, its dimensions are those of its type.
1292 if Is_Entity_Name (Expr) then
1293 Dims_Of_Expr := Dimensions_Of (Etype (Expr));
1294 else
1295 Dims_Of_Expr := Dimensions_Of (Expr);
1296 end if;
1298 if Comes_From_Source (Original_Node (Expr))
1299 and then Present (Etype (Expr))
1300 and then Is_Numeric_Type (Etype (Expr))
1301 and then Dims_Of_Expr /= Dims_Of_Comp_Typ
1302 and then Sloc (Comp) /= Sloc (Prev (Comp))
1303 then
1304 -- Check if an error has already been encountered so far
1306 if not Error_Detected then
1307 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1308 Error_Detected := True;
1309 end if;
1311 Error_Msg_N
1312 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1313 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1314 end if;
1316 -- Look at the named components right after the positional components
1318 if No (Next (Comp))
1319 and then List_Containing (Comp) = Exps
1320 then
1321 Comp := First (Comp_Ass);
1322 else
1323 Next (Comp);
1324 end if;
1325 end loop;
1326 end Analyze_Dimension_Array_Aggregate;
1328 --------------------------------------------
1329 -- Analyze_Dimension_Assignment_Statement --
1330 --------------------------------------------
1332 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1333 Lhs : constant Node_Id := Name (N);
1334 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1335 Rhs : constant Node_Id := Expression (N);
1336 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1338 procedure Error_Dim_Msg_For_Assignment_Statement
1339 (N : Node_Id;
1340 Lhs : Node_Id;
1341 Rhs : Node_Id);
1342 -- Error using Error_Msg_N at node N. Output the dimensions of left
1343 -- and right hand sides.
1345 --------------------------------------------
1346 -- Error_Dim_Msg_For_Assignment_Statement --
1347 --------------------------------------------
1349 procedure Error_Dim_Msg_For_Assignment_Statement
1350 (N : Node_Id;
1351 Lhs : Node_Id;
1352 Rhs : Node_Id)
1354 begin
1355 Error_Msg_N ("dimensions mismatch in assignment", N);
1356 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1357 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1358 end Error_Dim_Msg_For_Assignment_Statement;
1360 -- Start of processing for Analyze_Dimension_Assignment
1362 begin
1363 if Dims_Of_Lhs /= Dims_Of_Rhs then
1364 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1365 end if;
1366 end Analyze_Dimension_Assignment_Statement;
1368 ---------------------------------
1369 -- Analyze_Dimension_Binary_Op --
1370 ---------------------------------
1372 -- Check and propagate the dimensions for binary operators
1373 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1375 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1376 N_Kind : constant Node_Kind := Nkind (N);
1378 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1379 -- If the operand is a numeric literal that comes from a declared
1380 -- constant, use the dimensions of the constant which were computed
1381 -- from the expression of the constant declaration. Otherwise the
1382 -- dimensions are those of the operand, or the type of the operand.
1383 -- This takes care of node rewritings from validity checks, where the
1384 -- dimensions of the operand itself may not be preserved, while the
1385 -- type comes from context and must have dimension information.
1387 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1388 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1389 -- dimensions of both operands.
1391 ---------------------------
1392 -- Dimensions_Of_Operand --
1393 ---------------------------
1395 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1396 Dims : constant Dimension_Type := Dimensions_Of (N);
1398 begin
1399 if Exists (Dims) then
1400 return Dims;
1402 elsif Is_Entity_Name (N) then
1403 return Dimensions_Of (Etype (Entity (N)));
1405 elsif Nkind (N) = N_Real_Literal then
1407 if Present (Original_Entity (N)) then
1408 return Dimensions_Of (Original_Entity (N));
1410 else
1411 return Dimensions_Of (Etype (N));
1412 end if;
1414 -- Otherwise return the default dimensions
1416 else
1417 return Dims;
1418 end if;
1419 end Dimensions_Of_Operand;
1421 ---------------------------------
1422 -- Error_Dim_Msg_For_Binary_Op --
1423 ---------------------------------
1425 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1426 begin
1427 Error_Msg_NE
1428 ("both operands for operation& must have same dimensions",
1429 N, Entity (N));
1430 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1431 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1432 end Error_Dim_Msg_For_Binary_Op;
1434 -- Start of processing for Analyze_Dimension_Binary_Op
1436 begin
1437 -- If the node is already analyzed, do not examine the operands. At the
1438 -- end of the analysis their dimensions have been removed, and the node
1439 -- itself may have been rewritten.
1441 if Analyzed (N) then
1442 return;
1443 end if;
1445 if N_Kind in N_Op_Add | N_Op_Expon | N_Op_Subtract
1446 | N_Multiplying_Operator | N_Op_Compare
1447 then
1448 declare
1449 L : constant Node_Id := Left_Opnd (N);
1450 Dims_Of_L : constant Dimension_Type :=
1451 Dimensions_Of_Operand (L);
1452 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1453 R : constant Node_Id := Right_Opnd (N);
1454 Dims_Of_R : constant Dimension_Type :=
1455 Dimensions_Of_Operand (R);
1456 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1457 Dims_Of_N : Dimension_Type := Null_Dimension;
1459 begin
1460 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1462 if N_Kind in N_Op_Add | N_Op_Mod | N_Op_Rem | N_Op_Subtract then
1464 -- Check both operands have same dimension
1466 if Dims_Of_L /= Dims_Of_R then
1467 Error_Dim_Msg_For_Binary_Op (N, L, R);
1468 else
1469 -- Check both operands are not dimensionless
1471 if Exists (Dims_Of_L) then
1472 Set_Dimensions (N, Dims_Of_L);
1473 end if;
1474 end if;
1476 -- N_Op_Multiply or N_Op_Divide case
1478 elsif N_Kind in N_Op_Multiply | N_Op_Divide then
1480 -- Check at least one operand is not dimensionless
1482 if L_Has_Dimensions or R_Has_Dimensions then
1484 -- Multiplication case
1486 -- Get both operands dimensions and add them
1488 if N_Kind = N_Op_Multiply then
1489 for Position in Dimension_Type'Range loop
1490 Dims_Of_N (Position) :=
1491 Dims_Of_L (Position) + Dims_Of_R (Position);
1492 end loop;
1494 -- Division case
1496 -- Get both operands dimensions and subtract them
1498 else
1499 for Position in Dimension_Type'Range loop
1500 Dims_Of_N (Position) :=
1501 Dims_Of_L (Position) - Dims_Of_R (Position);
1502 end loop;
1503 end if;
1505 if Exists (Dims_Of_N) then
1506 Set_Dimensions (N, Dims_Of_N);
1507 end if;
1508 end if;
1510 -- Exponentiation case
1512 -- Note: a rational exponent is allowed for dimensioned operand
1514 elsif N_Kind = N_Op_Expon then
1516 -- Check the left operand is not dimensionless. Note that the
1517 -- value of the exponent must be known compile time. Otherwise,
1518 -- the exponentiation evaluation will return an error message.
1520 if L_Has_Dimensions then
1521 if not Compile_Time_Known_Value (R) then
1522 Error_Msg_N
1523 ("exponent of dimensioned operand must be "
1524 & "known at compile time", N);
1525 end if;
1527 declare
1528 Exponent_Value : Rational := Zero;
1530 begin
1531 -- Real operand case
1533 if Is_Real_Type (Etype (L)) then
1535 -- Define the exponent as a Rational number
1537 Exponent_Value := Create_Rational_From (R, False);
1539 -- Verify that the exponent cannot be interpreted
1540 -- as a rational, otherwise interpret the exponent
1541 -- as an integer.
1543 if Exponent_Value = No_Rational then
1544 Exponent_Value :=
1545 +Whole (UI_To_Int (Expr_Value (R)));
1546 end if;
1548 -- Integer operand case.
1550 -- For integer operand, the exponent cannot be
1551 -- interpreted as a rational.
1553 else
1554 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1555 end if;
1557 for Position in Dimension_Type'Range loop
1558 Dims_Of_N (Position) :=
1559 Dims_Of_L (Position) * Exponent_Value;
1560 end loop;
1562 if Exists (Dims_Of_N) then
1563 Set_Dimensions (N, Dims_Of_N);
1564 end if;
1565 end;
1566 end if;
1568 -- Comparison cases
1570 -- For relational operations, only dimension checking is
1571 -- performed (no propagation). If one operand is the result
1572 -- of constant folding the dimensions may have been lost
1573 -- in a tree copy, so assume that preanalysis has verified
1574 -- that dimensions are correct.
1576 elsif N_Kind in N_Op_Compare then
1577 if (L_Has_Dimensions or R_Has_Dimensions)
1578 and then Dims_Of_L /= Dims_Of_R
1579 then
1580 if Nkind (L) = N_Real_Literal
1581 and then not (Comes_From_Source (L))
1582 and then Expander_Active
1583 then
1584 null;
1586 elsif Nkind (R) = N_Real_Literal
1587 and then not (Comes_From_Source (R))
1588 and then Expander_Active
1589 then
1590 null;
1592 -- Numeric literal case. Issue a warning to indicate the
1593 -- literal is treated as if its dimension matches the type
1594 -- dimension.
1596 elsif Nkind (Original_Node (L)) in
1597 N_Integer_Literal | N_Real_Literal
1598 then
1599 Dim_Warning_For_Numeric_Literal (L, Etype (R));
1601 elsif Nkind (Original_Node (R)) in
1602 N_Integer_Literal | N_Real_Literal
1603 then
1604 Dim_Warning_For_Numeric_Literal (R, Etype (L));
1606 else
1607 Error_Dim_Msg_For_Binary_Op (N, L, R);
1608 end if;
1609 end if;
1610 end if;
1612 -- If expander is active, remove dimension information from each
1613 -- operand, as only dimensions of result are relevant.
1615 if Expander_Active then
1616 Remove_Dimensions (L);
1617 Remove_Dimensions (R);
1618 end if;
1619 end;
1620 end if;
1621 end Analyze_Dimension_Binary_Op;
1623 ----------------------------
1624 -- Analyze_Dimension_Call --
1625 ----------------------------
1627 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1628 Actuals : constant List_Id := Parameter_Associations (N);
1629 Actual : Node_Id;
1630 Dims_Of_Formal : Dimension_Type;
1631 Formal : Node_Id;
1632 Formal_Typ : Entity_Id;
1634 Error_Detected : Boolean := False;
1635 -- This flag is used in order to indicate if an error has been detected
1636 -- so far by the compiler in this routine.
1638 begin
1639 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1640 -- dimensions for calls in inlined bodies, or calls that don't come
1641 -- from source, or those that may have semantic errors.
1643 if Ada_Version < Ada_2012
1644 or else In_Inlined_Body
1645 or else not Comes_From_Source (N)
1646 or else Error_Posted (N)
1647 then
1648 return;
1649 end if;
1651 -- Check the dimensions of the actuals, if any
1653 if not Is_Empty_List (Actuals) then
1655 -- Special processing for elementary functions
1657 -- For Sqrt call, the resulting dimensions equal to half the
1658 -- dimensions of the actual. For all other elementary calls, this
1659 -- routine check that every actual is dimensionless.
1661 if Nkind (N) = N_Function_Call then
1662 Elementary_Function_Calls : declare
1663 Dims_Of_Call : Dimension_Type;
1664 Ent : Entity_Id := Nam;
1666 function Is_Elementary_Function_Entity
1667 (Sub_Id : Entity_Id) return Boolean;
1668 -- Given Sub_Id, the original subprogram entity, return True
1669 -- if call is to an elementary function (see Ada.Numerics.
1670 -- Generic_Elementary_Functions).
1672 -----------------------------------
1673 -- Is_Elementary_Function_Entity --
1674 -----------------------------------
1676 function Is_Elementary_Function_Entity
1677 (Sub_Id : Entity_Id) return Boolean
1679 Loc : constant Source_Ptr := Sloc (Sub_Id);
1681 begin
1682 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1684 return
1685 Loc > No_Location
1686 and then
1687 Is_RTU
1688 (Cunit_Entity (Get_Source_Unit (Loc)),
1689 Ada_Numerics_Generic_Elementary_Functions);
1690 end Is_Elementary_Function_Entity;
1692 -- Start of processing for Elementary_Function_Calls
1694 begin
1695 -- Get original subprogram entity following the renaming chain
1697 if Present (Alias (Ent)) then
1698 Ent := Alias (Ent);
1699 end if;
1701 -- Check the call is an Elementary function call
1703 if Is_Elementary_Function_Entity (Ent) then
1705 -- Sqrt function call case
1707 if Chars (Ent) = Name_Sqrt then
1708 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1710 -- Evaluates the resulting dimensions (i.e. half the
1711 -- dimensions of the actual).
1713 if Exists (Dims_Of_Call) then
1714 for Position in Dims_Of_Call'Range loop
1715 Dims_Of_Call (Position) :=
1716 Dims_Of_Call (Position) *
1717 Rational'(Numerator => 1, Denominator => 2);
1718 end loop;
1720 Set_Dimensions (N, Dims_Of_Call);
1721 end if;
1723 -- All other elementary functions case. Note that every
1724 -- actual here should be dimensionless.
1726 else
1727 Actual := First_Actual (N);
1728 while Present (Actual) loop
1729 if Exists (Dimensions_Of (Actual)) then
1731 -- Check if error has already been encountered
1733 if not Error_Detected then
1734 Error_Msg_NE
1735 ("dimensions mismatch in call of&",
1736 N, Name (N));
1737 Error_Detected := True;
1738 end if;
1740 Error_Msg_N
1741 ("\expected dimension '['], found "
1742 & Dimensions_Msg_Of (Actual), Actual);
1743 end if;
1745 Next_Actual (Actual);
1746 end loop;
1747 end if;
1749 -- Nothing more to do for elementary functions
1751 return;
1752 end if;
1753 end Elementary_Function_Calls;
1754 end if;
1756 -- General case. Check, for each parameter, the dimensions of the
1757 -- actual and its corresponding formal match. Otherwise, complain.
1759 Actual := First_Actual (N);
1760 Formal := First_Formal (Nam);
1761 while Present (Formal) loop
1763 -- A missing corresponding actual indicates that the analysis of
1764 -- the call was aborted due to a previous error.
1766 if No (Actual) then
1767 Check_Error_Detected;
1768 return;
1769 end if;
1771 Formal_Typ := Etype (Formal);
1772 Dims_Of_Formal := Dimensions_Of (Formal_Typ);
1774 -- If the formal is not dimensionless, check dimensions of formal
1775 -- and actual match. Otherwise, complain.
1777 if Exists (Dims_Of_Formal)
1778 and then Dimensions_Of (Actual) /= Dims_Of_Formal
1779 then
1780 -- Check if an error has already been encountered so far
1782 if not Error_Detected then
1783 Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
1784 Error_Detected := True;
1785 end if;
1787 Error_Msg_N
1788 ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ)
1789 & ", found " & Dimensions_Msg_Of (Actual), Actual);
1790 end if;
1792 Next_Actual (Actual);
1793 Next_Formal (Formal);
1794 end loop;
1795 end if;
1797 -- For function calls, propagate the dimensions from the returned type
1799 if Nkind (N) = N_Function_Call then
1800 Analyze_Dimension_Has_Etype (N);
1801 end if;
1802 end Analyze_Dimension_Call;
1804 ---------------------------------------
1805 -- Analyze_Dimension_Case_Expression --
1806 ---------------------------------------
1808 procedure Analyze_Dimension_Case_Expression (N : Node_Id) is
1809 Frst : constant Node_Id := First (Alternatives (N));
1810 Frst_Expr : constant Node_Id := Expression (Frst);
1811 Dims : constant Dimension_Type := Dimensions_Of (Frst_Expr);
1813 Alt : Node_Id;
1815 begin
1816 Alt := Next (Frst);
1817 while Present (Alt) loop
1818 if Dimensions_Of (Expression (Alt)) /= Dims then
1819 Error_Msg_N ("dimension mismatch in case expression", Alt);
1820 exit;
1821 end if;
1823 Next (Alt);
1824 end loop;
1826 Copy_Dimensions (Frst_Expr, N);
1827 end Analyze_Dimension_Case_Expression;
1829 ---------------------------------------------
1830 -- Analyze_Dimension_Component_Declaration --
1831 ---------------------------------------------
1833 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1834 Expr : constant Node_Id := Expression (N);
1835 Id : constant Entity_Id := Defining_Identifier (N);
1836 Etyp : constant Entity_Id := Etype (Id);
1837 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1838 Dims_Of_Expr : Dimension_Type;
1840 procedure Error_Dim_Msg_For_Component_Declaration
1841 (N : Node_Id;
1842 Etyp : Entity_Id;
1843 Expr : Node_Id);
1844 -- Error using Error_Msg_N at node N. Output the dimensions of the
1845 -- type Etyp and the expression Expr of N.
1847 ---------------------------------------------
1848 -- Error_Dim_Msg_For_Component_Declaration --
1849 ---------------------------------------------
1851 procedure Error_Dim_Msg_For_Component_Declaration
1852 (N : Node_Id;
1853 Etyp : Entity_Id;
1854 Expr : Node_Id) is
1855 begin
1856 Error_Msg_N ("dimensions mismatch in component declaration", N);
1857 Error_Msg_N
1858 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
1859 & Dimensions_Msg_Of (Expr), Expr);
1860 end Error_Dim_Msg_For_Component_Declaration;
1862 -- Start of processing for Analyze_Dimension_Component_Declaration
1864 begin
1865 -- Expression is present
1867 if Present (Expr) then
1868 Dims_Of_Expr := Dimensions_Of (Expr);
1870 -- Check dimensions match
1872 if Dims_Of_Etyp /= Dims_Of_Expr then
1874 -- Numeric literal case. Issue a warning if the object type is not
1875 -- dimensionless to indicate the literal is treated as if its
1876 -- dimension matches the type dimension.
1878 if Nkind (Original_Node (Expr)) in
1879 N_Real_Literal | N_Integer_Literal
1880 then
1881 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
1883 -- Issue a dimension mismatch error for all other cases
1885 else
1886 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1887 end if;
1888 end if;
1889 end if;
1890 end Analyze_Dimension_Component_Declaration;
1892 -------------------------------------------------
1893 -- Analyze_Dimension_Extended_Return_Statement --
1894 -------------------------------------------------
1896 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1897 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
1898 Return_Etyp : constant Entity_Id :=
1899 Etype (Return_Applies_To (Return_Ent));
1900 Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
1901 Return_Obj_Decl : Node_Id;
1902 Return_Obj_Id : Entity_Id;
1903 Return_Obj_Typ : Entity_Id;
1905 procedure Error_Dim_Msg_For_Extended_Return_Statement
1906 (N : Node_Id;
1907 Return_Etyp : Entity_Id;
1908 Return_Obj_Typ : Entity_Id);
1909 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1910 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1912 -------------------------------------------------
1913 -- Error_Dim_Msg_For_Extended_Return_Statement --
1914 -------------------------------------------------
1916 procedure Error_Dim_Msg_For_Extended_Return_Statement
1917 (N : Node_Id;
1918 Return_Etyp : Entity_Id;
1919 Return_Obj_Typ : Entity_Id)
1921 begin
1922 Error_Msg_N ("dimensions mismatch in extended return statement", N);
1923 Error_Msg_N
1924 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
1925 & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N);
1926 end Error_Dim_Msg_For_Extended_Return_Statement;
1928 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1930 begin
1931 if Present (Return_Obj_Decls) then
1932 Return_Obj_Decl := First (Return_Obj_Decls);
1933 while Present (Return_Obj_Decl) loop
1934 if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1935 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1937 if Is_Return_Object (Return_Obj_Id) then
1938 Return_Obj_Typ := Etype (Return_Obj_Id);
1940 -- Issue an error message if dimensions mismatch
1942 if Dimensions_Of (Return_Etyp) /=
1943 Dimensions_Of (Return_Obj_Typ)
1944 then
1945 Error_Dim_Msg_For_Extended_Return_Statement
1946 (N, Return_Etyp, Return_Obj_Typ);
1947 return;
1948 end if;
1949 end if;
1950 end if;
1952 Next (Return_Obj_Decl);
1953 end loop;
1954 end if;
1955 end Analyze_Dimension_Extended_Return_Statement;
1957 -----------------------------------------------------
1958 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1959 -----------------------------------------------------
1961 procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
1962 Comp : Node_Id;
1963 Comp_Id : Entity_Id;
1964 Comp_Typ : Entity_Id;
1965 Expr : Node_Id;
1967 Error_Detected : Boolean := False;
1968 -- This flag is used in order to indicate if an error has been detected
1969 -- so far by the compiler in this routine.
1971 begin
1972 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1973 -- dimensions in inlined bodies, or for aggregates that don't come
1974 -- from source, or if we are within an initialization procedure, whose
1975 -- expressions have been checked at the point of record declaration.
1977 if Ada_Version < Ada_2012
1978 or else In_Inlined_Body
1979 or else not Comes_From_Source (N)
1980 or else Inside_Init_Proc
1981 then
1982 return;
1983 end if;
1985 Comp := First (Component_Associations (N));
1986 while Present (Comp) loop
1987 Comp_Id := Entity (First (Choices (Comp)));
1988 Comp_Typ := Etype (Comp_Id);
1990 -- Check the component type is either a dimensioned type or a
1991 -- dimensioned subtype.
1993 if Has_Dimension_System (Base_Type (Comp_Typ)) then
1994 Expr := Expression (Comp);
1996 -- A box-initialized component needs no checking.
1998 if No (Expr) and then Box_Present (Comp) then
1999 null;
2001 -- Issue an error if the dimensions of the component type and the
2002 -- dimensions of the component mismatch.
2004 elsif Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
2006 -- Check if an error has already been encountered so far
2008 if not Error_Detected then
2010 -- Extension aggregate case
2012 if Nkind (N) = N_Extension_Aggregate then
2013 Error_Msg_N
2014 ("dimensions mismatch in extension aggregate", N);
2016 -- Record aggregate case
2018 else
2019 Error_Msg_N
2020 ("dimensions mismatch in record aggregate", N);
2021 end if;
2023 Error_Detected := True;
2024 end if;
2026 Error_Msg_N
2027 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
2028 & ", found " & Dimensions_Msg_Of (Expr), Comp);
2029 end if;
2030 end if;
2032 Next (Comp);
2033 end loop;
2034 end Analyze_Dimension_Extension_Or_Record_Aggregate;
2036 -------------------------------
2037 -- Analyze_Dimension_Formals --
2038 -------------------------------
2040 procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
2041 Dims_Of_Typ : Dimension_Type;
2042 Formal : Node_Id;
2043 Typ : Entity_Id;
2045 begin
2046 -- Aspect is an Ada 2012 feature. Note that there is no need to check
2047 -- dimensions for sub specs that don't come from source.
2049 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
2050 return;
2051 end if;
2053 Formal := First (Formals);
2054 while Present (Formal) loop
2055 Typ := Parameter_Type (Formal);
2056 Dims_Of_Typ := Dimensions_Of (Typ);
2058 if Exists (Dims_Of_Typ) then
2059 declare
2060 Expr : constant Node_Id := Expression (Formal);
2062 begin
2063 -- Issue a warning if Expr is a numeric literal and if its
2064 -- dimensions differ with the dimensions of the formal type.
2066 if Present (Expr)
2067 and then Dims_Of_Typ /= Dimensions_Of (Expr)
2068 and then Nkind (Original_Node (Expr)) in
2069 N_Real_Literal | N_Integer_Literal
2070 then
2071 Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
2072 end if;
2073 end;
2074 end if;
2076 Next (Formal);
2077 end loop;
2078 end Analyze_Dimension_Formals;
2080 ---------------------------------
2081 -- Analyze_Dimension_Has_Etype --
2082 ---------------------------------
2084 procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
2085 Etyp : constant Entity_Id := Etype (N);
2086 Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp);
2088 begin
2089 -- General case. Propagation of the dimensions from the type
2091 if Exists (Dims_Of_Etyp) then
2092 Set_Dimensions (N, Dims_Of_Etyp);
2094 -- Identifier case. Propagate the dimensions from the entity for
2095 -- identifier whose entity is a non-dimensionless constant.
2097 elsif Nkind (N) = N_Identifier then
2098 Analyze_Dimension_Identifier : declare
2099 Id : constant Entity_Id := Entity (N);
2101 begin
2102 -- If Id is missing, abnormal tree, assume previous error
2104 if No (Id) then
2105 Check_Error_Detected;
2106 return;
2108 elsif Ekind (Id) in E_Constant | E_Named_Real
2109 and then Exists (Dimensions_Of (Id))
2110 then
2111 Set_Dimensions (N, Dimensions_Of (Id));
2112 end if;
2113 end Analyze_Dimension_Identifier;
2115 -- Attribute reference case. Propagate the dimensions from the prefix.
2117 elsif Nkind (N) = N_Attribute_Reference
2118 and then Has_Dimension_System (Base_Type (Etyp))
2119 then
2120 Dims_Of_Etyp := Dimensions_Of (Prefix (N));
2122 -- Check the prefix is not dimensionless
2124 if Exists (Dims_Of_Etyp) then
2125 Set_Dimensions (N, Dims_Of_Etyp);
2126 end if;
2127 end if;
2129 -- Remove dimensions from inner expressions, to prevent dimensions
2130 -- table from growing uselessly.
2132 case Nkind (N) is
2133 when N_Attribute_Reference
2134 | N_Indexed_Component
2136 declare
2137 Exprs : constant List_Id := Expressions (N);
2138 Expr : Node_Id;
2140 begin
2141 if Present (Exprs) then
2142 Expr := First (Exprs);
2143 while Present (Expr) loop
2144 Remove_Dimensions (Expr);
2145 Next (Expr);
2146 end loop;
2147 end if;
2148 end;
2150 when N_Qualified_Expression
2151 | N_Type_Conversion
2152 | N_Unchecked_Type_Conversion
2154 Remove_Dimensions (Expression (N));
2156 when N_Selected_Component =>
2157 Remove_Dimensions (Selector_Name (N));
2159 when others =>
2160 null;
2161 end case;
2162 end Analyze_Dimension_Has_Etype;
2164 -------------------------------------
2165 -- Analyze_Dimension_If_Expression --
2166 -------------------------------------
2168 procedure Analyze_Dimension_If_Expression (N : Node_Id) is
2169 Then_Expr : constant Node_Id := Next (First (Expressions (N)));
2170 Else_Expr : constant Node_Id := Next (Then_Expr);
2172 begin
2173 if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then
2174 Error_Msg_N ("dimensions mismatch in conditional expression", N);
2175 else
2176 Copy_Dimensions (Then_Expr, N);
2177 end if;
2178 end Analyze_Dimension_If_Expression;
2180 ------------------------------------------
2181 -- Analyze_Dimension_Number_Declaration --
2182 ------------------------------------------
2184 procedure Analyze_Dimension_Number_Declaration (N : Node_Id) is
2185 Expr : constant Node_Id := Expression (N);
2186 Id : constant Entity_Id := Defining_Identifier (N);
2187 Dim_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
2189 begin
2190 if Exists (Dim_Of_Expr) then
2191 Set_Dimensions (Id, Dim_Of_Expr);
2192 Set_Etype (Id, Etype (Expr));
2193 end if;
2194 end Analyze_Dimension_Number_Declaration;
2196 ------------------------------------------
2197 -- Analyze_Dimension_Object_Declaration --
2198 ------------------------------------------
2200 procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
2201 Expr : constant Node_Id := Expression (N);
2202 Id : constant Entity_Id := Defining_Identifier (N);
2203 Etyp : constant Entity_Id := Etype (Id);
2204 Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
2205 Dim_Of_Expr : Dimension_Type;
2207 procedure Error_Dim_Msg_For_Object_Declaration
2208 (N : Node_Id;
2209 Etyp : Entity_Id;
2210 Expr : Node_Id);
2211 -- Error using Error_Msg_N at node N. Output the dimensions of the
2212 -- type Etyp and of the expression Expr.
2214 ------------------------------------------
2215 -- Error_Dim_Msg_For_Object_Declaration --
2216 ------------------------------------------
2218 procedure Error_Dim_Msg_For_Object_Declaration
2219 (N : Node_Id;
2220 Etyp : Entity_Id;
2221 Expr : Node_Id) is
2222 begin
2223 Error_Msg_N ("dimensions mismatch in object declaration", N);
2224 Error_Msg_N
2225 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
2226 & Dimensions_Msg_Of (Expr), Expr);
2227 end Error_Dim_Msg_For_Object_Declaration;
2229 -- Start of processing for Analyze_Dimension_Object_Declaration
2231 begin
2232 -- Expression is present
2234 if Present (Expr) then
2235 Dim_Of_Expr := Dimensions_Of (Expr);
2237 -- Check dimensions match
2239 if Dim_Of_Expr /= Dim_Of_Etyp then
2241 -- Numeric literal case. Issue a warning if the object type is
2242 -- not dimensionless to indicate the literal is treated as if
2243 -- its dimension matches the type dimension.
2245 if Nkind (Original_Node (Expr)) in
2246 N_Real_Literal | N_Integer_Literal
2247 then
2248 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
2250 -- Case of object is a constant whose type is a dimensioned type
2252 elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
2254 -- Propagate dimension from expression to object entity
2256 Set_Dimensions (Id, Dim_Of_Expr);
2258 -- Expression may have been constant-folded. If nominal type has
2259 -- dimensions, verify that expression has same type.
2261 elsif Exists (Dim_Of_Etyp) and then Etype (Expr) = Etyp then
2262 null;
2264 -- For all other cases, issue an error message
2266 else
2267 Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
2268 end if;
2269 end if;
2271 -- Remove dimensions in expression after checking consistency with
2272 -- given type.
2274 Remove_Dimensions (Expr);
2275 end if;
2276 end Analyze_Dimension_Object_Declaration;
2278 ---------------------------------------------------
2279 -- Analyze_Dimension_Object_Renaming_Declaration --
2280 ---------------------------------------------------
2282 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
2283 Renamed_Name : constant Node_Id := Name (N);
2284 Sub_Mark : constant Node_Id := Subtype_Mark (N);
2286 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2287 (N : Node_Id;
2288 Sub_Mark : Node_Id;
2289 Renamed_Name : Node_Id);
2290 -- Error using Error_Msg_N at node N. Output the dimensions of
2291 -- Sub_Mark and of Renamed_Name.
2293 ---------------------------------------------------
2294 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2295 ---------------------------------------------------
2297 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2298 (N : Node_Id;
2299 Sub_Mark : Node_Id;
2300 Renamed_Name : Node_Id) is
2301 begin
2302 Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
2303 Error_Msg_N
2304 ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found "
2305 & Dimensions_Msg_Of (Renamed_Name), Renamed_Name);
2306 end Error_Dim_Msg_For_Object_Renaming_Declaration;
2308 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2310 begin
2311 if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
2312 Error_Dim_Msg_For_Object_Renaming_Declaration
2313 (N, Sub_Mark, Renamed_Name);
2314 end if;
2315 end Analyze_Dimension_Object_Renaming_Declaration;
2317 -----------------------------------------------
2318 -- Analyze_Dimension_Simple_Return_Statement --
2319 -----------------------------------------------
2321 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
2322 Expr : constant Node_Id := Expression (N);
2323 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
2324 Return_Etyp : constant Entity_Id :=
2325 Etype (Return_Applies_To (Return_Ent));
2326 Dims_Of_Return_Etyp : constant Dimension_Type :=
2327 Dimensions_Of (Return_Etyp);
2329 procedure Error_Dim_Msg_For_Simple_Return_Statement
2330 (N : Node_Id;
2331 Return_Etyp : Entity_Id;
2332 Expr : Node_Id);
2333 -- Error using Error_Msg_N at node N. Output the dimensions of the
2334 -- returned type Return_Etyp and the returned expression Expr of N.
2336 -----------------------------------------------
2337 -- Error_Dim_Msg_For_Simple_Return_Statement --
2338 -----------------------------------------------
2340 procedure Error_Dim_Msg_For_Simple_Return_Statement
2341 (N : Node_Id;
2342 Return_Etyp : Entity_Id;
2343 Expr : Node_Id)
2345 begin
2346 Error_Msg_N ("dimensions mismatch in return statement", N);
2347 Error_Msg_N
2348 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
2349 & ", found " & Dimensions_Msg_Of (Expr), Expr);
2350 end Error_Dim_Msg_For_Simple_Return_Statement;
2352 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2354 begin
2355 if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then
2356 Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
2357 Remove_Dimensions (Expr);
2358 end if;
2359 end Analyze_Dimension_Simple_Return_Statement;
2361 -------------------------------------------
2362 -- Analyze_Dimension_Subtype_Declaration --
2363 -------------------------------------------
2365 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
2366 Id : constant Entity_Id := Defining_Identifier (N);
2367 Dims_Of_Id : constant Dimension_Type := Dimensions_Of (Id);
2368 Dims_Of_Etyp : Dimension_Type;
2369 Etyp : Node_Id;
2371 begin
2372 -- No constraint case in subtype declaration
2374 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
2375 Etyp := Etype (Subtype_Indication (N));
2376 Dims_Of_Etyp := Dimensions_Of (Etyp);
2378 if Exists (Dims_Of_Etyp) then
2380 -- If subtype already has a dimension (from Aspect_Dimension), it
2381 -- cannot inherit different dimensions from its subtype.
2383 if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then
2384 Error_Msg_NE
2385 ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id);
2386 else
2387 Set_Dimensions (Id, Dims_Of_Etyp);
2388 Set_Symbol (Id, Symbol_Of (Etyp));
2389 end if;
2390 end if;
2392 -- Constraint present in subtype declaration
2394 else
2395 Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
2396 Dims_Of_Etyp := Dimensions_Of (Etyp);
2398 if Exists (Dims_Of_Etyp) then
2399 Set_Dimensions (Id, Dims_Of_Etyp);
2400 Set_Symbol (Id, Symbol_Of (Etyp));
2401 end if;
2402 end if;
2403 end Analyze_Dimension_Subtype_Declaration;
2405 ---------------------------------------
2406 -- Analyze_Dimension_Type_Conversion --
2407 ---------------------------------------
2409 procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is
2410 Expr_Root : constant Entity_Id :=
2411 Dimension_System_Root (Etype (Expression (N)));
2412 Target_Root : constant Entity_Id :=
2413 Dimension_System_Root (Etype (N));
2415 begin
2416 -- If the expression has dimensions and the target type has dimensions,
2417 -- the conversion has the dimensions of the expression. Consistency is
2418 -- checked below. Converting to a non-dimensioned type such as Float
2419 -- ignores the dimensions of the expression.
2421 if Exists (Dimensions_Of (Expression (N)))
2422 and then Present (Target_Root)
2423 then
2424 Set_Dimensions (N, Dimensions_Of (Expression (N)));
2426 -- Otherwise the dimensions are those of the target type.
2428 else
2429 Analyze_Dimension_Has_Etype (N);
2430 end if;
2432 -- A conversion between types in different dimension systems (e.g. MKS
2433 -- and British units) must respect the dimensions of expression and
2434 -- type, It is up to the user to provide proper conversion factors.
2436 -- Upward conversions to root type of a dimensioned system are legal,
2437 -- and correspond to "view conversions", i.e. preserve the dimensions
2438 -- of the expression; otherwise conversion must be between types with
2439 -- then same dimensions. Conversions to a non-dimensioned type such as
2440 -- Float lose the dimensions of the expression.
2442 if Present (Expr_Root)
2443 and then Present (Target_Root)
2444 and then Etype (N) /= Target_Root
2445 and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N))
2446 then
2447 Error_Msg_N ("dimensions mismatch in conversion", N);
2448 Error_Msg_N
2449 ("\expression " & Dimensions_Msg_Of (Expression (N), True), N);
2450 Error_Msg_N
2451 ("\target type " & Dimensions_Msg_Of (Etype (N), True), N);
2452 end if;
2453 end Analyze_Dimension_Type_Conversion;
2455 --------------------------------
2456 -- Analyze_Dimension_Unary_Op --
2457 --------------------------------
2459 procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
2460 begin
2461 case Nkind (N) is
2463 -- Propagate the dimension if the operand is not dimensionless
2465 when N_Op_Abs
2466 | N_Op_Minus
2467 | N_Op_Plus
2469 declare
2470 R : constant Node_Id := Right_Opnd (N);
2471 begin
2472 Move_Dimensions (R, N);
2473 end;
2475 when others =>
2476 null;
2477 end case;
2478 end Analyze_Dimension_Unary_Op;
2480 ---------------------------------
2481 -- Check_Expression_Dimensions --
2482 ---------------------------------
2484 procedure Check_Expression_Dimensions
2485 (Expr : Node_Id;
2486 Typ : Entity_Id)
2488 begin
2489 if Is_Floating_Point_Type (Etype (Expr)) then
2490 Analyze_Dimension (Expr);
2492 if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then
2493 Error_Msg_N ("dimensions mismatch in array aggregate", Expr);
2494 Error_Msg_N
2495 ("\expected dimension " & Dimensions_Msg_Of (Typ)
2496 & ", found " & Dimensions_Msg_Of (Expr), Expr);
2497 end if;
2498 end if;
2499 end Check_Expression_Dimensions;
2501 ---------------------
2502 -- Copy_Dimensions --
2503 ---------------------
2505 procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is
2506 Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
2508 begin
2509 -- Ignore if not Ada 2012 or beyond
2511 if Ada_Version < Ada_2012 then
2512 return;
2514 -- For Ada 2012, Copy the dimension of 'From to 'To'
2516 elsif Exists (Dims_Of_From) then
2517 Set_Dimensions (To, Dims_Of_From);
2518 end if;
2519 end Copy_Dimensions;
2521 -----------------------------------
2522 -- Copy_Dimensions_Of_Components --
2523 -----------------------------------
2525 procedure Copy_Dimensions_Of_Components (Rec : Entity_Id) is
2526 C : Entity_Id;
2528 begin
2529 C := First_Component (Rec);
2530 while Present (C) loop
2531 if Nkind (Parent (C)) = N_Component_Declaration then
2532 Copy_Dimensions
2533 (Expression (Parent (Corresponding_Record_Component (C))),
2534 Expression (Parent (C)));
2535 end if;
2536 Next_Component (C);
2537 end loop;
2538 end Copy_Dimensions_Of_Components;
2540 --------------------------
2541 -- Create_Rational_From --
2542 --------------------------
2544 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2546 -- A rational number is a number that can be expressed as the quotient or
2547 -- fraction a/b of two integers, where b is non-zero positive.
2549 function Create_Rational_From
2550 (Expr : Node_Id;
2551 Complain : Boolean) return Rational
2553 Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
2554 Result : Rational := No_Rational;
2556 function Process_Minus (N : Node_Id) return Rational;
2557 -- Create a rational from a N_Op_Minus node
2559 function Process_Divide (N : Node_Id) return Rational;
2560 -- Create a rational from a N_Op_Divide node
2562 function Process_Literal (N : Node_Id) return Rational;
2563 -- Create a rational from a N_Integer_Literal node
2565 -------------------
2566 -- Process_Minus --
2567 -------------------
2569 function Process_Minus (N : Node_Id) return Rational is
2570 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2571 Result : Rational;
2573 begin
2574 -- Operand is an integer literal
2576 if Nkind (Right) = N_Integer_Literal then
2577 Result := -Process_Literal (Right);
2579 -- Operand is a divide operator
2581 elsif Nkind (Right) = N_Op_Divide then
2582 Result := -Process_Divide (Right);
2584 else
2585 Result := No_Rational;
2586 end if;
2588 return Result;
2589 end Process_Minus;
2591 --------------------
2592 -- Process_Divide --
2593 --------------------
2595 function Process_Divide (N : Node_Id) return Rational is
2596 Left : constant Node_Id := Original_Node (Left_Opnd (N));
2597 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2598 Left_Rat : Rational;
2599 Result : Rational := No_Rational;
2600 Right_Rat : Rational;
2602 begin
2603 -- Both left and right operands are integer literals
2605 if Nkind (Left) = N_Integer_Literal
2606 and then
2607 Nkind (Right) = N_Integer_Literal
2608 then
2609 Left_Rat := Process_Literal (Left);
2610 Right_Rat := Process_Literal (Right);
2611 Result := Left_Rat / Right_Rat;
2612 end if;
2614 return Result;
2615 end Process_Divide;
2617 ---------------------
2618 -- Process_Literal --
2619 ---------------------
2621 function Process_Literal (N : Node_Id) return Rational is
2622 begin
2623 return +Whole (UI_To_Int (Intval (N)));
2624 end Process_Literal;
2626 -- Start of processing for Create_Rational_From
2628 begin
2629 -- Check the expression is either a division of two integers or an
2630 -- integer itself. Note that the check applies to the original node
2631 -- since the node could have already been rewritten.
2633 -- Integer literal case
2635 if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
2636 Result := Process_Literal (Or_Node_Of_Expr);
2638 -- Divide operator case
2640 elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
2641 Result := Process_Divide (Or_Node_Of_Expr);
2643 -- Minus operator case
2645 elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
2646 Result := Process_Minus (Or_Node_Of_Expr);
2647 end if;
2649 -- When Expr cannot be interpreted as a rational and Complain is true,
2650 -- generate an error message.
2652 if Complain and then Result = No_Rational then
2653 Error_Msg_N ("rational expected", Expr);
2654 end if;
2656 return Result;
2657 end Create_Rational_From;
2659 -------------------
2660 -- Dimensions_Of --
2661 -------------------
2663 function Dimensions_Of (N : Node_Id) return Dimension_Type is
2664 begin
2665 return Dimension_Table.Get (N);
2666 end Dimensions_Of;
2668 -----------------------
2669 -- Dimensions_Msg_Of --
2670 -----------------------
2672 function Dimensions_Msg_Of
2673 (N : Node_Id;
2674 Description_Needed : Boolean := False) return String
2676 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2677 Dimensions_Msg : Name_Id;
2678 System : System_Type;
2680 begin
2681 -- Initialization of Name_Buffer
2683 Name_Len := 0;
2685 -- N is not dimensionless
2687 if Exists (Dims_Of_N) then
2688 System := System_Of (Base_Type (Etype (N)));
2690 -- When Description_Needed, add to string "has dimension " before the
2691 -- actual dimension.
2693 if Description_Needed then
2694 Add_Str_To_Name_Buffer ("has dimension ");
2695 end if;
2697 Append
2698 (Global_Name_Buffer,
2699 From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
2701 -- N is dimensionless
2703 -- When Description_Needed, return "is dimensionless"
2705 elsif Description_Needed then
2706 Add_Str_To_Name_Buffer ("is dimensionless");
2708 -- Otherwise, return "'[']"
2710 else
2711 Add_Str_To_Name_Buffer ("'[']");
2712 end if;
2714 Dimensions_Msg := Name_Find;
2715 return Get_Name_String (Dimensions_Msg);
2716 end Dimensions_Msg_Of;
2718 --------------------------
2719 -- Dimension_Table_Hash --
2720 --------------------------
2722 function Dimension_Table_Hash
2723 (Key : Node_Id) return Dimension_Table_Range
2725 begin
2726 return Dimension_Table_Range (Key mod 511);
2727 end Dimension_Table_Hash;
2729 -------------------------------------
2730 -- Dim_Warning_For_Numeric_Literal --
2731 -------------------------------------
2733 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
2734 begin
2735 -- Consider the literal zero (integer 0 or real 0.0) to be of any
2736 -- dimension.
2738 case Nkind (Original_Node (N)) is
2739 when N_Real_Literal =>
2740 if Expr_Value_R (N) = Ureal_0 then
2741 return;
2742 end if;
2744 when N_Integer_Literal =>
2745 if Expr_Value (N) = Uint_0 then
2746 return;
2747 end if;
2749 when others =>
2750 null;
2751 end case;
2753 -- Initialize name buffer
2755 Name_Len := 0;
2757 Append (Global_Name_Buffer, String_From_Numeric_Literal (N));
2759 -- Insert a blank between the literal and the symbol
2761 Add_Char_To_Name_Buffer (' ');
2762 Append (Global_Name_Buffer, Symbol_Of (Typ));
2764 Error_Msg_Name_1 := Name_Find;
2765 Error_Msg_N ("assumed to be%%??", N);
2766 end Dim_Warning_For_Numeric_Literal;
2768 ----------------------
2769 -- Dimensions_Match --
2770 ----------------------
2772 function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2773 begin
2774 return
2775 not Has_Dimension_System (Base_Type (T1))
2776 or else Dimensions_Of (T1) = Dimensions_Of (T2);
2777 end Dimensions_Match;
2779 ---------------------------
2780 -- Dimension_System_Root --
2781 ---------------------------
2783 function Dimension_System_Root (T : Entity_Id) return Entity_Id is
2784 Root : Entity_Id;
2786 begin
2787 Root := Base_Type (T);
2789 if Has_Dimension_System (Root) then
2790 return First_Subtype (Root); -- for example Dim_Mks
2792 else
2793 return Empty;
2794 end if;
2795 end Dimension_System_Root;
2797 ----------------------------------------
2798 -- Eval_Op_Expon_For_Dimensioned_Type --
2799 ----------------------------------------
2801 -- Evaluate the expon operator for real dimensioned type.
2803 -- Note that if the exponent is an integer (denominator = 1) the node is
2804 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2806 procedure Eval_Op_Expon_For_Dimensioned_Type
2807 (N : Node_Id;
2808 Btyp : Entity_Id)
2810 R : constant Node_Id := Right_Opnd (N);
2811 R_Value : Rational := No_Rational;
2813 begin
2814 if Is_Real_Type (Btyp) then
2815 R_Value := Create_Rational_From (R, False);
2816 end if;
2818 -- Check that the exponent is not an integer
2820 if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
2821 Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
2822 else
2823 Eval_Op_Expon (N);
2824 end if;
2825 end Eval_Op_Expon_For_Dimensioned_Type;
2827 ------------------------------------------
2828 -- Eval_Op_Expon_With_Rational_Exponent --
2829 ------------------------------------------
2831 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2832 -- Rational and not only an Integer like for dimensionless operands. For
2833 -- that particular case, the left operand is rewritten as a function call
2834 -- using the function Expon_LLF from s-llflex.ads.
2836 procedure Eval_Op_Expon_With_Rational_Exponent
2837 (N : Node_Id;
2838 Exponent_Value : Rational)
2840 Loc : constant Source_Ptr := Sloc (N);
2841 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2842 L : constant Node_Id := Left_Opnd (N);
2843 Etyp_Of_L : constant Entity_Id := Etype (L);
2844 Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2845 Actual_1 : Node_Id;
2846 Actual_2 : Node_Id;
2847 Dim_Power : Rational;
2848 List_Of_Dims : List_Id;
2849 New_Aspect : Node_Id;
2850 New_Aspects : List_Id;
2851 New_Id : Entity_Id;
2852 New_N : Node_Id;
2853 New_Subtyp_Decl_For_L : Node_Id;
2854 System : System_Type;
2856 begin
2857 -- Case when the operand is not dimensionless
2859 if Exists (Dims_Of_N) then
2861 -- Get the corresponding System_Type to know the exact number of
2862 -- dimensions in the system.
2864 System := System_Of (Btyp_Of_L);
2866 -- Generation of a new subtype with the proper dimensions
2868 -- In order to rewrite the operator as a type conversion, a new
2869 -- dimensioned subtype with the resulting dimensions of the
2870 -- exponentiation must be created.
2872 -- Generate:
2874 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2875 -- System : constant System_Id :=
2876 -- Get_Dimension_System_Id (Btyp_Of_L);
2877 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2878 -- Dimension_Systems.Table (System).Dimension_Count;
2880 -- subtype T is Btyp_Of_L
2881 -- with
2882 -- Dimension => (
2883 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2884 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2885 -- ...
2886 -- Dims_Of_N (Num_Of_Dims).Numerator /
2887 -- Dims_Of_N (Num_Of_Dims).Denominator);
2889 -- Step 1: Generate the new aggregate for the aspect Dimension
2891 New_Aspects := Empty_List;
2893 List_Of_Dims := New_List;
2894 for Position in Dims_Of_N'First .. System.Count loop
2895 Dim_Power := Dims_Of_N (Position);
2896 Append_To (List_Of_Dims,
2897 Make_Op_Divide (Loc,
2898 Left_Opnd =>
2899 Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)),
2900 Right_Opnd =>
2901 Make_Integer_Literal (Loc, Int (Dim_Power.Denominator))));
2902 end loop;
2904 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2906 New_Aspect :=
2907 Make_Aspect_Specification (Loc,
2908 Identifier => Make_Identifier (Loc, Name_Dimension),
2909 Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2911 -- Step 3: Make a temporary identifier for the new subtype
2913 New_Id := Make_Temporary (Loc, 'T');
2914 Set_Is_Internal (New_Id);
2916 -- Step 4: Declaration of the new subtype
2918 New_Subtyp_Decl_For_L :=
2919 Make_Subtype_Declaration (Loc,
2920 Defining_Identifier => New_Id,
2921 Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc));
2923 Append (New_Aspect, New_Aspects);
2924 Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2926 Analyze (New_Subtyp_Decl_For_L);
2928 -- Case where the operand is dimensionless
2930 else
2931 New_Id := Btyp_Of_L;
2932 end if;
2934 -- Replacement of N by New_N
2936 -- Generate:
2938 -- Actual_1 := Long_Long_Float (L),
2940 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2941 -- Long_Long_Float (Exponent_Value.Denominator);
2943 -- (T (Expon_LLF (Actual_1, Actual_2)));
2945 -- where T is the subtype declared in step 1
2947 -- The node is rewritten as a type conversion
2949 -- Step 1: Creation of the two parameters of Expon_LLF function call
2951 Actual_1 :=
2952 Make_Type_Conversion (Loc,
2953 Subtype_Mark => New_Occurrence_Of (Standard_Long_Long_Float, Loc),
2954 Expression => Relocate_Node (L));
2956 Actual_2 :=
2957 Make_Op_Divide (Loc,
2958 Left_Opnd =>
2959 Make_Real_Literal (Loc,
2960 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2961 Right_Opnd =>
2962 Make_Real_Literal (Loc,
2963 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2965 -- Step 2: Creation of New_N
2967 New_N :=
2968 Make_Type_Conversion (Loc,
2969 Subtype_Mark => New_Occurrence_Of (New_Id, Loc),
2970 Expression =>
2971 Make_Function_Call (Loc,
2972 Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc),
2973 Parameter_Associations => New_List (
2974 Actual_1, Actual_2)));
2976 -- Step 3: Rewrite N with the result
2978 Rewrite (N, New_N);
2979 Set_Etype (N, New_Id);
2980 Analyze_And_Resolve (N, New_Id);
2981 end Eval_Op_Expon_With_Rational_Exponent;
2983 ------------
2984 -- Exists --
2985 ------------
2987 function Exists (Dim : Dimension_Type) return Boolean is
2988 begin
2989 return Dim /= Null_Dimension;
2990 end Exists;
2992 function Exists (Str : String_Id) return Boolean is
2993 begin
2994 return Str /= No_String;
2995 end Exists;
2997 function Exists (Sys : System_Type) return Boolean is
2998 begin
2999 return Sys /= Null_System;
3000 end Exists;
3002 ---------------------------------
3003 -- Expand_Put_Call_With_Symbol --
3004 ---------------------------------
3006 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in
3007 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string
3008 -- parameter is rewritten to include the unit symbol (or the dimension
3009 -- symbols if not a defined quantity) in the output of a dimensioned
3010 -- object. If a value is already supplied by the user for the parameter
3011 -- Symbol, it is used as is.
3013 -- Case 1. Item is dimensionless
3015 -- * Put : Item appears without a suffix
3017 -- * Put_Dim_Of : the output is []
3019 -- Obj : Mks_Type := 2.6;
3020 -- Put (Obj, 1, 1, 0);
3021 -- Put_Dim_Of (Obj);
3023 -- The corresponding outputs are:
3024 -- $2.6
3025 -- $[]
3027 -- Case 2. Item has a dimension
3029 -- * Put : If the type of Item is a dimensioned subtype whose
3030 -- symbol is not empty, then the symbol appears as a
3031 -- suffix. Otherwise, a new string is created and appears
3032 -- as a suffix of Item. This string results in the
3033 -- successive concatenations between each unit symbol
3034 -- raised by its corresponding dimension power from the
3035 -- dimensions of Item.
3037 -- * Put_Dim_Of : The output is a new string resulting in the successive
3038 -- concatenations between each dimension symbol raised by
3039 -- its corresponding dimension power from the dimensions of
3040 -- Item.
3042 -- subtype Random is Mks_Type
3043 -- with
3044 -- Dimension => (
3045 -- Meter => 3,
3046 -- Candela => -1,
3047 -- others => 0);
3049 -- Obj : Random := 5.0;
3050 -- Put (Obj);
3051 -- Put_Dim_Of (Obj);
3053 -- The corresponding outputs are:
3054 -- $5.0 m**3.cd**(-1)
3055 -- $[l**3.J**(-1)]
3057 -- The function Image returns the string identical to that produced by
3058 -- a call to Put whose first parameter is a string.
3060 procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
3061 Actuals : constant List_Id := Parameter_Associations (N);
3062 Loc : constant Source_Ptr := Sloc (N);
3063 Name_Call : constant Node_Id := Name (N);
3064 New_Actuals : constant List_Id := New_List;
3065 Actual : Node_Id;
3066 Dims_Of_Actual : Dimension_Type;
3067 Etyp : Entity_Id;
3068 New_Str_Lit : Node_Id := Empty;
3069 Symbols : String_Id;
3071 Is_Put_Dim_Of : Boolean := False;
3072 -- This flag is used in order to differentiate routines Put and
3073 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
3074 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
3076 function Has_Symbols return Boolean;
3077 -- Return True if the current Put call already has a parameter
3078 -- association for parameter "Symbols" with the correct string of
3079 -- symbols.
3081 function Is_Procedure_Put_Call return Boolean;
3082 -- Return True if the current call is a call of an instantiation of a
3083 -- procedure Put defined in the package System.Dim.Float_IO and
3084 -- System.Dim.Integer_IO.
3086 function Item_Actual return Node_Id;
3087 -- Return the item actual parameter node in the output call
3089 -----------------
3090 -- Has_Symbols --
3091 -----------------
3093 function Has_Symbols return Boolean is
3094 Actual : Node_Id;
3095 Actual_Str : Node_Id;
3097 begin
3098 -- Look for a symbols parameter association in the list of actuals
3100 Actual := First (Actuals);
3101 while Present (Actual) loop
3103 -- Positional parameter association case when the actual is a
3104 -- string literal.
3106 if Nkind (Actual) = N_String_Literal then
3107 Actual_Str := Actual;
3109 -- Named parameter association case when selector name is Symbol
3111 elsif Nkind (Actual) = N_Parameter_Association
3112 and then Chars (Selector_Name (Actual)) = Name_Symbol
3113 then
3114 Actual_Str := Explicit_Actual_Parameter (Actual);
3116 -- Ignore all other cases
3118 else
3119 Actual_Str := Empty;
3120 end if;
3122 if Present (Actual_Str) then
3124 -- Return True if the actual comes from source or if the string
3125 -- of symbols doesn't have the default value (i.e. it is ""),
3126 -- in which case it is used as suffix of the generated string.
3128 if Comes_From_Source (Actual)
3129 or else String_Length (Strval (Actual_Str)) /= 0
3130 then
3131 return True;
3133 else
3134 return False;
3135 end if;
3136 end if;
3138 Next (Actual);
3139 end loop;
3141 -- At this point, the call has no parameter association. Look to the
3142 -- last actual since the symbols parameter is the last one.
3144 return Nkind (Last (Actuals)) = N_String_Literal;
3145 end Has_Symbols;
3147 ---------------------------
3148 -- Is_Procedure_Put_Call --
3149 ---------------------------
3151 function Is_Procedure_Put_Call return Boolean is
3152 Ent : Entity_Id;
3153 Loc : Source_Ptr;
3155 begin
3156 -- There are three different Put (resp. Put_Dim_Of) routines in each
3157 -- generic dim IO package. Verify the current procedure call is one
3158 -- of them.
3160 if Is_Entity_Name (Name_Call) then
3161 Ent := Entity (Name_Call);
3163 -- Get the original subprogram entity following the renaming chain
3165 if Present (Alias (Ent)) then
3166 Ent := Alias (Ent);
3167 end if;
3169 Loc := Sloc (Ent);
3171 -- Check the name of the entity subprogram is Put (resp.
3172 -- Put_Dim_Of) and verify this entity is located in either
3173 -- System.Dim.Float_IO or System.Dim.Integer_IO.
3175 if Loc > No_Location
3176 and then Is_Dim_IO_Package_Entity
3177 (Cunit_Entity (Get_Source_Unit (Loc)))
3178 then
3179 if Chars (Ent) = Name_Put_Dim_Of then
3180 Is_Put_Dim_Of := True;
3181 return True;
3183 elsif Chars (Ent) = Name_Put
3184 or else Chars (Ent) = Name_Image
3185 then
3186 return True;
3187 end if;
3188 end if;
3189 end if;
3191 return False;
3192 end Is_Procedure_Put_Call;
3194 -----------------
3195 -- Item_Actual --
3196 -----------------
3198 function Item_Actual return Node_Id is
3199 Actual : Node_Id;
3201 begin
3202 -- Look for the item actual as a parameter association
3204 Actual := First (Actuals);
3205 while Present (Actual) loop
3206 if Nkind (Actual) = N_Parameter_Association
3207 and then Chars (Selector_Name (Actual)) = Name_Item
3208 then
3209 return Explicit_Actual_Parameter (Actual);
3210 end if;
3212 Next (Actual);
3213 end loop;
3215 -- Case where the item has been defined without an association
3217 Actual := First (Actuals);
3219 -- Depending on the procedure Put, Item actual could be first or
3220 -- second in the list of actuals.
3222 if Has_Dimension_System (Base_Type (Etype (Actual))) then
3223 return Actual;
3224 else
3225 return Next (Actual);
3226 end if;
3227 end Item_Actual;
3229 -- Start of processing for Expand_Put_Call_With_Symbol
3231 begin
3232 if Is_Procedure_Put_Call and then not Has_Symbols then
3233 Actual := Item_Actual;
3234 Dims_Of_Actual := Dimensions_Of (Actual);
3235 Etyp := Etype (Actual);
3237 -- Put_Dim_Of case
3239 if Is_Put_Dim_Of then
3241 -- Check that the item is not dimensionless
3243 -- Create the new String_Literal with the new String_Id generated
3244 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
3246 if Exists (Dims_Of_Actual) then
3247 New_Str_Lit :=
3248 Make_String_Literal (Loc,
3249 From_Dim_To_Str_Of_Dim_Symbols
3250 (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
3252 -- If dimensionless, the output is []
3254 else
3255 New_Str_Lit :=
3256 Make_String_Literal (Loc, "[]");
3257 end if;
3259 -- Put case
3261 else
3262 -- Add the symbol as a suffix of the value if the subtype has a
3263 -- unit symbol or if the parameter is not dimensionless.
3265 if Exists (Symbol_Of (Etyp)) then
3266 Symbols := Symbol_Of (Etyp);
3267 else
3268 Symbols := From_Dim_To_Str_Of_Unit_Symbols
3269 (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
3270 end if;
3272 -- Check Symbols exists
3274 if Exists (Symbols) then
3275 Start_String;
3277 -- Put a space between the value and the dimension
3279 Store_String_Char (' ');
3280 Store_String_Chars (Symbols);
3281 New_Str_Lit := Make_String_Literal (Loc, End_String);
3282 end if;
3283 end if;
3285 if Present (New_Str_Lit) then
3287 -- Insert all actuals in New_Actuals
3289 Actual := First (Actuals);
3290 while Present (Actual) loop
3292 -- Copy every actuals in New_Actuals except the Symbols
3293 -- parameter association.
3295 if Nkind (Actual) = N_Parameter_Association
3296 and then Chars (Selector_Name (Actual)) /= Name_Symbol
3297 then
3298 Append_To (New_Actuals,
3299 Make_Parameter_Association (Loc,
3300 Selector_Name => New_Copy (Selector_Name (Actual)),
3301 Explicit_Actual_Parameter =>
3302 New_Copy (Explicit_Actual_Parameter (Actual))));
3304 elsif Nkind (Actual) /= N_Parameter_Association then
3305 Append_To (New_Actuals, New_Copy (Actual));
3306 end if;
3308 Next (Actual);
3309 end loop;
3311 -- Create new Symbols param association and append to New_Actuals
3313 Append_To (New_Actuals,
3314 Make_Parameter_Association (Loc,
3315 Selector_Name => Make_Identifier (Loc, Name_Symbol),
3316 Explicit_Actual_Parameter => New_Str_Lit));
3318 -- Rewrite and analyze the procedure call
3320 if Chars (Name_Call) = Name_Image then
3321 Rewrite (N,
3322 Make_Function_Call (Loc,
3323 Name => New_Copy (Name_Call),
3324 Parameter_Associations => New_Actuals));
3325 Analyze_And_Resolve (N);
3326 else
3327 Rewrite (N,
3328 Make_Procedure_Call_Statement (Loc,
3329 Name => New_Copy (Name_Call),
3330 Parameter_Associations => New_Actuals));
3331 Analyze (N);
3332 end if;
3334 end if;
3335 end if;
3336 end Expand_Put_Call_With_Symbol;
3338 ------------------------------------
3339 -- From_Dim_To_Str_Of_Dim_Symbols --
3340 ------------------------------------
3342 -- Given a dimension vector and the corresponding dimension system, create
3343 -- a String_Id to output dimension symbols corresponding to the dimensions
3344 -- Dims. If In_Error_Msg is True, there is a special handling for character
3345 -- asterisk * which is an insertion character in error messages.
3347 function From_Dim_To_Str_Of_Dim_Symbols
3348 (Dims : Dimension_Type;
3349 System : System_Type;
3350 In_Error_Msg : Boolean := False) return String_Id
3352 Dim_Power : Rational;
3353 First_Dim : Boolean := True;
3355 procedure Store_String_Oexpon;
3356 -- Store the expon operator symbol "**" in the string. In error
3357 -- messages, asterisk * is a special character and must be quoted
3358 -- to be placed literally into the message.
3360 -------------------------
3361 -- Store_String_Oexpon --
3362 -------------------------
3364 procedure Store_String_Oexpon is
3365 begin
3366 if In_Error_Msg then
3367 Store_String_Chars ("'*'*");
3368 else
3369 Store_String_Chars ("**");
3370 end if;
3371 end Store_String_Oexpon;
3373 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3375 begin
3376 -- Initialization of the new String_Id
3378 Start_String;
3380 -- Store the dimension symbols inside boxes
3382 if In_Error_Msg then
3383 Store_String_Chars ("'[");
3384 else
3385 Store_String_Char ('[');
3386 end if;
3388 for Position in Dimension_Type'Range loop
3389 Dim_Power := Dims (Position);
3390 if Dim_Power /= Zero then
3392 if First_Dim then
3393 First_Dim := False;
3394 else
3395 Store_String_Char ('.');
3396 end if;
3398 Store_String_Chars (System.Dim_Symbols (Position));
3400 -- Positive dimension case
3402 if Dim_Power.Numerator > 0 then
3404 -- Integer case
3406 if Dim_Power.Denominator = 1 then
3407 if Dim_Power.Numerator /= 1 then
3408 Store_String_Oexpon;
3409 Store_String_Int (Int (Dim_Power.Numerator));
3410 end if;
3412 -- Rational case when denominator /= 1
3414 else
3415 Store_String_Oexpon;
3416 Store_String_Char ('(');
3417 Store_String_Int (Int (Dim_Power.Numerator));
3418 Store_String_Char ('/');
3419 Store_String_Int (Int (Dim_Power.Denominator));
3420 Store_String_Char (')');
3421 end if;
3423 -- Negative dimension case
3425 else
3426 Store_String_Oexpon;
3427 Store_String_Char ('(');
3428 Store_String_Char ('-');
3429 Store_String_Int (Int (-Dim_Power.Numerator));
3431 -- Integer case
3433 if Dim_Power.Denominator = 1 then
3434 Store_String_Char (')');
3436 -- Rational case when denominator /= 1
3438 else
3439 Store_String_Char ('/');
3440 Store_String_Int (Int (Dim_Power.Denominator));
3441 Store_String_Char (')');
3442 end if;
3443 end if;
3444 end if;
3445 end loop;
3447 if In_Error_Msg then
3448 Store_String_Chars ("']");
3449 else
3450 Store_String_Char (']');
3451 end if;
3453 return End_String;
3454 end From_Dim_To_Str_Of_Dim_Symbols;
3456 -------------------------------------
3457 -- From_Dim_To_Str_Of_Unit_Symbols --
3458 -------------------------------------
3460 -- Given a dimension vector and the corresponding dimension system,
3461 -- create a String_Id to output the unit symbols corresponding to the
3462 -- dimensions Dims.
3464 function From_Dim_To_Str_Of_Unit_Symbols
3465 (Dims : Dimension_Type;
3466 System : System_Type) return String_Id
3468 Dim_Power : Rational;
3469 First_Dim : Boolean := True;
3471 begin
3472 -- Return No_String if dimensionless
3474 if not Exists (Dims) then
3475 return No_String;
3476 end if;
3478 -- Initialization of the new String_Id
3480 Start_String;
3482 for Position in Dimension_Type'Range loop
3483 Dim_Power := Dims (Position);
3485 if Dim_Power /= Zero then
3486 if First_Dim then
3487 First_Dim := False;
3488 else
3489 Store_String_Char ('.');
3490 end if;
3492 Store_String_Chars (System.Unit_Symbols (Position));
3494 -- Positive dimension case
3496 if Dim_Power.Numerator > 0 then
3498 -- Integer case
3500 if Dim_Power.Denominator = 1 then
3501 if Dim_Power.Numerator /= 1 then
3502 Store_String_Chars ("**");
3503 Store_String_Int (Int (Dim_Power.Numerator));
3504 end if;
3506 -- Rational case when denominator /= 1
3508 else
3509 Store_String_Chars ("**");
3510 Store_String_Char ('(');
3511 Store_String_Int (Int (Dim_Power.Numerator));
3512 Store_String_Char ('/');
3513 Store_String_Int (Int (Dim_Power.Denominator));
3514 Store_String_Char (')');
3515 end if;
3517 -- Negative dimension case
3519 else
3520 Store_String_Chars ("**");
3521 Store_String_Char ('(');
3522 Store_String_Char ('-');
3523 Store_String_Int (Int (-Dim_Power.Numerator));
3525 -- Integer case
3527 if Dim_Power.Denominator = 1 then
3528 Store_String_Char (')');
3530 -- Rational case when denominator /= 1
3532 else
3533 Store_String_Char ('/');
3534 Store_String_Int (Int (Dim_Power.Denominator));
3535 Store_String_Char (')');
3536 end if;
3537 end if;
3538 end if;
3539 end loop;
3541 return End_String;
3542 end From_Dim_To_Str_Of_Unit_Symbols;
3544 ---------
3545 -- GCD --
3546 ---------
3548 function GCD (Left, Right : Whole) return Int is
3549 L : Whole;
3550 R : Whole;
3552 begin
3553 L := Left;
3554 R := Right;
3555 while R /= 0 loop
3556 L := L mod R;
3558 if L = 0 then
3559 return Int (R);
3560 end if;
3562 R := R mod L;
3563 end loop;
3565 return Int (L);
3566 end GCD;
3568 --------------------------
3569 -- Has_Dimension_System --
3570 --------------------------
3572 function Has_Dimension_System (Typ : Entity_Id) return Boolean is
3573 begin
3574 return Exists (System_Of (Typ));
3575 end Has_Dimension_System;
3577 ------------------------------
3578 -- Is_Dim_IO_Package_Entity --
3579 ------------------------------
3581 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
3582 begin
3583 -- Check the package entity corresponds to System.Dim.Float_IO or
3584 -- System.Dim.Integer_IO.
3586 return
3587 Is_RTU (E, System_Dim_Float_IO)
3588 or else
3589 Is_RTU (E, System_Dim_Integer_IO);
3590 end Is_Dim_IO_Package_Entity;
3592 -------------------------------------
3593 -- Is_Dim_IO_Package_Instantiation --
3594 -------------------------------------
3596 function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
3597 Gen_Id : constant Node_Id := Name (N);
3599 begin
3600 -- Check that the instantiated package is either System.Dim.Float_IO
3601 -- or System.Dim.Integer_IO.
3603 return
3604 Is_Entity_Name (Gen_Id)
3605 and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
3606 end Is_Dim_IO_Package_Instantiation;
3608 ----------------
3609 -- Is_Invalid --
3610 ----------------
3612 function Is_Invalid (Position : Dimension_Position) return Boolean is
3613 begin
3614 return Position = Invalid_Position;
3615 end Is_Invalid;
3617 ---------------------
3618 -- Move_Dimensions --
3619 ---------------------
3621 procedure Move_Dimensions (From, To : Node_Id) is
3622 begin
3623 if Ada_Version < Ada_2012 then
3624 return;
3625 end if;
3627 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3629 Copy_Dimensions (From, To);
3630 Remove_Dimensions (From);
3631 end Move_Dimensions;
3633 ---------------------------------------
3634 -- New_Copy_Tree_And_Copy_Dimensions --
3635 ---------------------------------------
3637 function New_Copy_Tree_And_Copy_Dimensions
3638 (Source : Node_Id;
3639 Map : Elist_Id := No_Elist;
3640 New_Sloc : Source_Ptr := No_Location;
3641 New_Scope : Entity_Id := Empty) return Node_Id
3643 New_Copy : constant Node_Id :=
3644 New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
3646 begin
3647 -- Move the dimensions of Source to New_Copy
3649 Copy_Dimensions (Source, New_Copy);
3650 return New_Copy;
3651 end New_Copy_Tree_And_Copy_Dimensions;
3653 ------------
3654 -- Reduce --
3655 ------------
3657 function Reduce (X : Rational) return Rational is
3658 begin
3659 if X.Numerator = 0 then
3660 return Zero;
3661 end if;
3663 declare
3664 G : constant Int := GCD (X.Numerator, X.Denominator);
3665 begin
3666 return Rational'(Numerator => Whole (Int (X.Numerator) / G),
3667 Denominator => Whole (Int (X.Denominator) / G));
3668 end;
3669 end Reduce;
3671 -----------------------
3672 -- Remove_Dimensions --
3673 -----------------------
3675 procedure Remove_Dimensions (N : Node_Id) is
3676 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3677 begin
3678 if Exists (Dims_Of_N) then
3679 Dimension_Table.Remove (N);
3680 end if;
3681 end Remove_Dimensions;
3683 -----------------------------------
3684 -- Remove_Dimension_In_Statement --
3685 -----------------------------------
3687 -- Removal of dimension in statement as part of the Analyze_Statements
3688 -- routine (see package Sem_Ch5).
3690 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3691 begin
3692 if Ada_Version < Ada_2012 then
3693 return;
3694 end if;
3696 -- Remove dimension in parameter specifications for accept statement
3698 if Nkind (Stmt) = N_Accept_Statement then
3699 declare
3700 Param : Node_Id := First (Parameter_Specifications (Stmt));
3701 begin
3702 while Present (Param) loop
3703 Remove_Dimensions (Param);
3704 Next (Param);
3705 end loop;
3706 end;
3708 -- Remove dimension of name and expression in assignments
3710 elsif Nkind (Stmt) = N_Assignment_Statement then
3711 Remove_Dimensions (Expression (Stmt));
3712 Remove_Dimensions (Name (Stmt));
3713 end if;
3714 end Remove_Dimension_In_Statement;
3716 --------------------
3717 -- Set_Dimensions --
3718 --------------------
3720 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3721 begin
3722 pragma Assert (OK_For_Dimension (Nkind (N)));
3723 pragma Assert (Exists (Val));
3725 Dimension_Table.Set (N, Val);
3726 end Set_Dimensions;
3728 ----------------
3729 -- Set_Symbol --
3730 ----------------
3732 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3733 begin
3734 Symbol_Table.Set (E, Val);
3735 end Set_Symbol;
3737 ---------------
3738 -- Symbol_Of --
3739 ---------------
3741 function Symbol_Of (E : Entity_Id) return String_Id is
3742 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3743 begin
3744 if Subtype_Symbol /= No_String then
3745 return Subtype_Symbol;
3746 else
3747 return From_Dim_To_Str_Of_Unit_Symbols
3748 (Dimensions_Of (E), System_Of (Base_Type (E)));
3749 end if;
3750 end Symbol_Of;
3752 -----------------------
3753 -- Symbol_Table_Hash --
3754 -----------------------
3756 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3757 begin
3758 return Symbol_Table_Range (Key mod 511);
3759 end Symbol_Table_Hash;
3761 ---------------
3762 -- System_Of --
3763 ---------------
3765 function System_Of (E : Entity_Id) return System_Type is
3766 begin
3767 if Present (E) then
3768 declare
3769 Type_Decl : constant Node_Id := Parent (E);
3770 begin
3771 -- Look for Type_Decl in System_Table
3773 for Dim_Sys in 1 .. System_Table.Last loop
3774 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3775 return System_Table.Table (Dim_Sys);
3776 end if;
3777 end loop;
3778 end;
3779 end if;
3781 return Null_System;
3782 end System_Of;
3784 end Sem_Dim;