File : sem_dim.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Exp_Util; use Exp_Util;
31 with Lib; use Lib;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
34 with Nmake; use Nmake;
35 with Opt; use Opt;
36 with Rtsfind; use Rtsfind;
37 with Sem; use Sem;
38 with Sem_Eval; use Sem_Eval;
39 with Sem_Res; use Sem_Res;
40 with Sem_Util; use Sem_Util;
41 with Sinfo; use Sinfo;
42 with Sinput; use Sinput;
43 with Snames; use Snames;
44 with Stand; use Stand;
45 with Stringt; use Stringt;
46 with Table;
47 with Tbuild; use Tbuild;
48 with Uintp; use Uintp;
49 with Urealp; use Urealp;
50
51 with GNAT.HTable;
52
53 package body Sem_Dim is
54
55 -------------------------
56 -- Rational Arithmetic --
57 -------------------------
58
59 type Whole is new Int;
60 subtype Positive_Whole is Whole range 1 .. Whole'Last;
61
62 type Rational is record
63 Numerator : Whole;
64 Denominator : Positive_Whole;
65 end record;
66
67 Zero : constant Rational := Rational'(Numerator => 0,
68 Denominator => 1);
69
70 No_Rational : constant Rational := Rational'(Numerator => 0,
71 Denominator => 2);
72 -- Used to indicate an expression that cannot be interpreted as a rational
73 -- Returned value of the Create_Rational_From routine when parameter Expr
74 -- is not a static representation of a rational.
75
76 -- Rational constructors
77
78 function "+" (Right : Whole) return Rational;
79 function GCD (Left, Right : Whole) return Int;
80 function Reduce (X : Rational) return Rational;
81
82 -- Unary operator for Rational
83
84 function "-" (Right : Rational) return Rational;
85 function "abs" (Right : Rational) return Rational;
86
87 -- Rational operations for Rationals
88
89 function "+" (Left, Right : Rational) return Rational;
90 function "-" (Left, Right : Rational) return Rational;
91 function "*" (Left, Right : Rational) return Rational;
92 function "/" (Left, Right : Rational) return Rational;
93
94 ------------------
95 -- System Types --
96 ------------------
97
98 Max_Number_Of_Dimensions : constant := 7;
99 -- Maximum number of dimensions in a dimension system
100
101 High_Position_Bound : constant := Max_Number_Of_Dimensions;
102 Invalid_Position : constant := 0;
103 Low_Position_Bound : constant := 1;
104
105 subtype Dimension_Position is
106 Nat range Invalid_Position .. High_Position_Bound;
107
108 type Name_Array is
109 array (Dimension_Position range
110 Low_Position_Bound .. High_Position_Bound) of Name_Id;
111 -- Store the names of all units within a system
112
113 No_Names : constant Name_Array := (others => No_Name);
114
115 type Symbol_Array is
116 array (Dimension_Position range
117 Low_Position_Bound .. High_Position_Bound) of String_Id;
118 -- Store the symbols of all units within a system
119
120 No_Symbols : constant Symbol_Array := (others => No_String);
121
122 -- The following record should be documented field by field
123
124 type System_Type is record
125 Type_Decl : Node_Id;
126 Unit_Names : Name_Array;
127 Unit_Symbols : Symbol_Array;
128 Dim_Symbols : Symbol_Array;
129 Count : Dimension_Position;
130 end record;
131
132 Null_System : constant System_Type :=
133 (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
134
135 subtype System_Id is Nat;
136
137 -- The following table maps types to systems
138
139 package System_Table is new Table.Table (
140 Table_Component_Type => System_Type,
141 Table_Index_Type => System_Id,
142 Table_Low_Bound => 1,
143 Table_Initial => 5,
144 Table_Increment => 5,
145 Table_Name => "System_Table");
146
147 --------------------
148 -- Dimension Type --
149 --------------------
150
151 type Dimension_Type is
152 array (Dimension_Position range
153 Low_Position_Bound .. High_Position_Bound) of Rational;
154
155 Null_Dimension : constant Dimension_Type := (others => Zero);
156
157 type Dimension_Table_Range is range 0 .. 510;
158 function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
159
160 -- The following table associates nodes with dimensions
161
162 package Dimension_Table is new
163 GNAT.HTable.Simple_HTable
164 (Header_Num => Dimension_Table_Range,
165 Element => Dimension_Type,
166 No_Element => Null_Dimension,
167 Key => Node_Id,
168 Hash => Dimension_Table_Hash,
169 Equal => "=");
170
171 ------------------
172 -- Symbol Types --
173 ------------------
174
175 type Symbol_Table_Range is range 0 .. 510;
176 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
177
178 -- Each subtype with a dimension has a symbolic representation of the
179 -- related unit. This table establishes a relation between the subtype
180 -- and the symbol.
181
182 package Symbol_Table is new
183 GNAT.HTable.Simple_HTable
184 (Header_Num => Symbol_Table_Range,
185 Element => String_Id,
186 No_Element => No_String,
187 Key => Entity_Id,
188 Hash => Symbol_Table_Hash,
189 Equal => "=");
190
191 -- The following array enumerates all contexts which may contain or
192 -- produce a dimension.
193
194 OK_For_Dimension : constant array (Node_Kind) of Boolean :=
195 (N_Attribute_Reference => True,
196 N_Expanded_Name => True,
197 N_Explicit_Dereference => True,
198 N_Defining_Identifier => True,
199 N_Function_Call => True,
200 N_Identifier => True,
201 N_Indexed_Component => True,
202 N_Integer_Literal => True,
203 N_Op_Abs => True,
204 N_Op_Add => True,
205 N_Op_Divide => True,
206 N_Op_Expon => True,
207 N_Op_Minus => True,
208 N_Op_Mod => True,
209 N_Op_Multiply => True,
210 N_Op_Plus => True,
211 N_Op_Rem => True,
212 N_Op_Subtract => True,
213 N_Qualified_Expression => True,
214 N_Real_Literal => True,
215 N_Selected_Component => True,
216 N_Slice => True,
217 N_Type_Conversion => True,
218 N_Unchecked_Type_Conversion => True,
219
220 others => False);
221
222 -----------------------
223 -- Local Subprograms --
224 -----------------------
225
226 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
227 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
228 -- dimensions of the left-hand side and the right-hand side of N match.
229
230 procedure Analyze_Dimension_Binary_Op (N : Node_Id);
231 -- Subroutine of Analyze_Dimension for binary operators. Check the
232 -- dimensions of the right and the left operand permit the operation.
233 -- Then, evaluate the resulting dimensions for each binary operator.
234
235 procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
236 -- Subroutine of Analyze_Dimension for component declaration. Check that
237 -- the dimensions of the type of N and of the expression match.
238
239 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
240 -- Subroutine of Analyze_Dimension for extended return statement. Check
241 -- that the dimensions of the returned type and of the returned object
242 -- match.
243
244 procedure Analyze_Dimension_Has_Etype (N : Node_Id);
245 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
246 -- the list below:
247 -- N_Attribute_Reference
248 -- N_Identifier
249 -- N_Indexed_Component
250 -- N_Qualified_Expression
251 -- N_Selected_Component
252 -- N_Slice
253 -- N_Type_Conversion
254 -- N_Unchecked_Type_Conversion
255
256 procedure Analyze_Dimension_Number_Declaration (N : Node_Id);
257 -- Procedure to analyze dimension of expression in a number declaration.
258 -- This allows a named number to have nontrivial dimensions, while by
259 -- default a named number is dimensionless.
260
261 procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
262 -- Subroutine of Analyze_Dimension for object declaration. Check that
263 -- the dimensions of the object type and the dimensions of the expression
264 -- (if expression is present) match. Note that when the expression is
265 -- a literal, no error is returned. This special case allows object
266 -- declaration such as: m : constant Length := 1.0;
267
268 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
269 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
270 -- the dimensions of the type and of the renamed object name of N match.
271
272 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
273 -- Subroutine of Analyze_Dimension for simple return statement
274 -- Check that the dimensions of the returned type and of the returned
275 -- expression match.
276
277 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
278 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
279 -- dimensions from the parent type to the identifier of N. Note that if
280 -- both the identifier and the parent type of N are not dimensionless,
281 -- return an error.
282
283 procedure Analyze_Dimension_Unary_Op (N : Node_Id);
284 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
285 -- Abs operators, propagate the dimensions from the operand to N.
286
287 function Create_Rational_From
288 (Expr : Node_Id;
289 Complain : Boolean) return Rational;
290 -- Given an arbitrary expression Expr, return a valid rational if Expr can
291 -- be interpreted as a rational. Otherwise return No_Rational and also an
292 -- error message if Complain is set to True.
293
294 function Dimensions_Of (N : Node_Id) return Dimension_Type;
295 -- Return the dimension vector of node N
296
297 function Dimensions_Msg_Of
298 (N : Node_Id;
299 Description_Needed : Boolean := False) return String;
300 -- Given a node N, return the dimension symbols of N, preceded by "has
301 -- dimension" if Description_Needed. if N is dimensionless, return "'[']",
302 -- or "is dimensionless" if Description_Needed.
303
304 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
305 -- Issue a warning on the given numeric literal N to indicate that the
306 -- compiler made the assumption that the literal is not dimensionless
307 -- but has the dimension of Typ.
308
309 procedure Eval_Op_Expon_With_Rational_Exponent
310 (N : Node_Id;
311 Exponent_Value : Rational);
312 -- Evaluate the exponent it is a rational and the operand has a dimension
313
314 function Exists (Dim : Dimension_Type) return Boolean;
315 -- Returns True iff Dim does not denote the null dimension
316
317 function Exists (Str : String_Id) return Boolean;
318 -- Returns True iff Str does not denote No_String
319
320 function Exists (Sys : System_Type) return Boolean;
321 -- Returns True iff Sys does not denote the null system
322
323 function From_Dim_To_Str_Of_Dim_Symbols
324 (Dims : Dimension_Type;
325 System : System_Type;
326 In_Error_Msg : Boolean := False) return String_Id;
327 -- Given a dimension vector and a dimension system, return the proper
328 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
329 -- will be used to issue an error message) then this routine has a special
330 -- handling for the insertion characters * or [ which must be preceded by
331 -- a quote ' to to be placed literally into the message.
332
333 function From_Dim_To_Str_Of_Unit_Symbols
334 (Dims : Dimension_Type;
335 System : System_Type) return String_Id;
336 -- Given a dimension vector and a dimension system, return the proper
337 -- string of unit symbols.
338
339 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
340 -- Return True if E is the package entity of System.Dim.Float_IO or
341 -- System.Dim.Integer_IO.
342
343 function Is_Invalid (Position : Dimension_Position) return Boolean;
344 -- Return True if Pos denotes the invalid position
345
346 procedure Move_Dimensions (From : Node_Id; To : Node_Id);
347 -- Copy dimension vector of From to To and delete dimension vector of From
348
349 procedure Remove_Dimensions (N : Node_Id);
350 -- Remove the dimension vector of node N
351
352 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
353 -- Associate a dimension vector with a node
354
355 procedure Set_Symbol (E : Entity_Id; Val : String_Id);
356 -- Associate a symbol representation of a dimension vector with a subtype
357
358 function String_From_Numeric_Literal (N : Node_Id) return String_Id;
359 -- Return the string that corresponds to the numeric litteral N as it
360 -- appears in the source.
361
362 function Symbol_Of (E : Entity_Id) return String_Id;
363 -- E denotes a subtype with a dimension. Return the symbol representation
364 -- of the dimension vector.
365
366 function System_Of (E : Entity_Id) return System_Type;
367 -- E denotes a type, return associated system of the type if it has one
368
369 ---------
370 -- "+" --
371 ---------
372
373 function "+" (Right : Whole) return Rational is
374 begin
375 return Rational'(Numerator => Right, Denominator => 1);
376 end "+";
377
378 function "+" (Left, Right : Rational) return Rational is
379 R : constant Rational :=
380 Rational'(Numerator => Left.Numerator * Right.Denominator +
381 Left.Denominator * Right.Numerator,
382 Denominator => Left.Denominator * Right.Denominator);
383 begin
384 return Reduce (R);
385 end "+";
386
387 ---------
388 -- "-" --
389 ---------
390
391 function "-" (Right : Rational) return Rational is
392 begin
393 return Rational'(Numerator => -Right.Numerator,
394 Denominator => Right.Denominator);
395 end "-";
396
397 function "-" (Left, Right : Rational) return Rational is
398 R : constant Rational :=
399 Rational'(Numerator => Left.Numerator * Right.Denominator -
400 Left.Denominator * Right.Numerator,
401 Denominator => Left.Denominator * Right.Denominator);
402
403 begin
404 return Reduce (R);
405 end "-";
406
407 ---------
408 -- "*" --
409 ---------
410
411 function "*" (Left, Right : Rational) return Rational is
412 R : constant Rational :=
413 Rational'(Numerator => Left.Numerator * Right.Numerator,
414 Denominator => Left.Denominator * Right.Denominator);
415 begin
416 return Reduce (R);
417 end "*";
418
419 ---------
420 -- "/" --
421 ---------
422
423 function "/" (Left, Right : Rational) return Rational is
424 R : constant Rational := abs Right;
425 L : Rational := Left;
426
427 begin
428 if Right.Numerator < 0 then
429 L.Numerator := Whole (-Integer (L.Numerator));
430 end if;
431
432 return Reduce (Rational'(Numerator => L.Numerator * R.Denominator,
433 Denominator => L.Denominator * R.Numerator));
434 end "/";
435
436 -----------
437 -- "abs" --
438 -----------
439
440 function "abs" (Right : Rational) return Rational is
441 begin
442 return Rational'(Numerator => abs Right.Numerator,
443 Denominator => Right.Denominator);
444 end "abs";
445
446 ------------------------------
447 -- Analyze_Aspect_Dimension --
448 ------------------------------
449
450 -- with Dimension =>
451 -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
452 --
453 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
454
455 -- DIMENSION_VALUE ::=
456 -- RATIONAL
457 -- | others => RATIONAL
458 -- | DISCRETE_CHOICE_LIST => RATIONAL
459
460 -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
461
462 -- Note that when the dimensioned type is an integer type, then any
463 -- dimension value must be an integer literal.
464
465 procedure Analyze_Aspect_Dimension
466 (N : Node_Id;
467 Id : Entity_Id;
468 Aggr : Node_Id)
469 is
470 Def_Id : constant Entity_Id := Defining_Identifier (N);
471
472 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
473 -- This array is used when processing ranges or Others_Choice as part of
474 -- the dimension aggregate.
475
476 Dimensions : Dimension_Type := Null_Dimension;
477
478 procedure Extract_Power
479 (Expr : Node_Id;
480 Position : Dimension_Position);
481 -- Given an expression with denotes a rational number, read the number
482 -- and associate it with Position in Dimensions.
483
484 function Position_In_System
485 (Id : Node_Id;
486 System : System_Type) return Dimension_Position;
487 -- Given an identifier which denotes a dimension, return the position of
488 -- that dimension within System.
489
490 -------------------
491 -- Extract_Power --
492 -------------------
493
494 procedure Extract_Power
495 (Expr : Node_Id;
496 Position : Dimension_Position)
497 is
498 begin
499 -- Integer case
500
501 if Is_Integer_Type (Def_Id) then
502
503 -- Dimension value must be an integer literal
504
505 if Nkind (Expr) = N_Integer_Literal then
506 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
507 else
508 Error_Msg_N ("integer literal expected", Expr);
509 end if;
510
511 -- Float case
512
513 else
514 Dimensions (Position) := Create_Rational_From (Expr, True);
515 end if;
516
517 Processed (Position) := True;
518 end Extract_Power;
519
520 ------------------------
521 -- Position_In_System --
522 ------------------------
523
524 function Position_In_System
525 (Id : Node_Id;
526 System : System_Type) return Dimension_Position
527 is
528 Dimension_Name : constant Name_Id := Chars (Id);
529
530 begin
531 for Position in System.Unit_Names'Range loop
532 if Dimension_Name = System.Unit_Names (Position) then
533 return Position;
534 end if;
535 end loop;
536
537 return Invalid_Position;
538 end Position_In_System;
539
540 -- Local variables
541
542 Assoc : Node_Id;
543 Choice : Node_Id;
544 Expr : Node_Id;
545 Num_Choices : Nat := 0;
546 Num_Dimensions : Nat := 0;
547 Others_Seen : Boolean := False;
548 Position : Nat := 0;
549 Sub_Ind : Node_Id;
550 Symbol : String_Id := No_String;
551 Symbol_Expr : Node_Id;
552 System : System_Type;
553 Typ : Entity_Id;
554
555 Errors_Count : Nat;
556 -- Errors_Count is a count of errors detected by the compiler so far
557 -- just before the extraction of symbol, names and values in the
558 -- aggregate (Step 2).
559 --
560 -- At the end of the analysis, there is a check to verify that this
561 -- count equals to Serious_Errors_Detected i.e. no erros have been
562 -- encountered during the process. Otherwise the Dimension_Table is
563 -- not filled.
564
565 -- Start of processing for Analyze_Aspect_Dimension
566
567 begin
568 -- STEP 1: Legality of aspect
569
570 if Nkind (N) /= N_Subtype_Declaration then
571 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
572 return;
573 end if;
574
575 Sub_Ind := Subtype_Indication (N);
576 Typ := Etype (Sub_Ind);
577 System := System_Of (Typ);
578
579 if Nkind (Sub_Ind) = N_Subtype_Indication then
580 Error_Msg_NE
581 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
582 return;
583 end if;
584
585 -- The dimension declarations are useless if the parent type does not
586 -- declare a valid system.
587
588 if not Exists (System) then
589 Error_Msg_NE
590 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
591 return;
592 end if;
593
594 if Nkind (Aggr) /= N_Aggregate then
595 Error_Msg_N ("aggregate expected", Aggr);
596 return;
597 end if;
598
599 -- STEP 2: Symbol, Names and values extraction
600
601 -- Get the number of errors detected by the compiler so far
602
603 Errors_Count := Serious_Errors_Detected;
604
605 -- STEP 2a: Symbol extraction
606
607 -- The first entry in the aggregate may be the symbolic representation
608 -- of the quantity.
609
610 -- Positional symbol argument
611
612 Symbol_Expr := First (Expressions (Aggr));
613
614 -- Named symbol argument
615
616 if No (Symbol_Expr)
617 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
618 N_String_Literal)
619 then
620 Symbol_Expr := Empty;
621
622 -- Component associations present
623
624 if Present (Component_Associations (Aggr)) then
625 Assoc := First (Component_Associations (Aggr));
626 Choice := First (Choices (Assoc));
627
628 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
629
630 -- Symbol component association is present
631
632 if Chars (Choice) = Name_Symbol then
633 Num_Choices := Num_Choices + 1;
634 Symbol_Expr := Expression (Assoc);
635
636 -- Verify symbol expression is a string or a character
637
638 if not Nkind_In (Symbol_Expr, N_Character_Literal,
639 N_String_Literal)
640 then
641 Symbol_Expr := Empty;
642 Error_Msg_N
643 ("symbol expression must be character or string",
644 Symbol_Expr);
645 end if;
646
647 -- Special error if no Symbol choice but expression is string
648 -- or character.
649
650 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
651 N_String_Literal)
652 then
653 Num_Choices := Num_Choices + 1;
654 Error_Msg_N
655 ("optional component Symbol expected, found&", Choice);
656 end if;
657 end if;
658 end if;
659 end if;
660
661 -- STEP 2b: Names and values extraction
662
663 -- Positional elements
664
665 Expr := First (Expressions (Aggr));
666
667 -- Skip the symbol expression when present
668
669 if Present (Symbol_Expr) and then Num_Choices = 0 then
670 Expr := Next (Expr);
671 end if;
672
673 Position := Low_Position_Bound;
674 while Present (Expr) loop
675 if Position > High_Position_Bound then
676 Error_Msg_N
677 ("type& has more dimensions than system allows", Def_Id);
678 exit;
679 end if;
680
681 Extract_Power (Expr, Position);
682
683 Position := Position + 1;
684 Num_Dimensions := Num_Dimensions + 1;
685
686 Next (Expr);
687 end loop;
688
689 -- Named elements
690
691 Assoc := First (Component_Associations (Aggr));
692
693 -- Skip the symbol association when present
694
695 if Num_Choices = 1 then
696 Next (Assoc);
697 end if;
698
699 while Present (Assoc) loop
700 Expr := Expression (Assoc);
701
702 Choice := First (Choices (Assoc));
703 while Present (Choice) loop
704
705 -- Identifier case: NAME => EXPRESSION
706
707 if Nkind (Choice) = N_Identifier then
708 Position := Position_In_System (Choice, System);
709
710 if Is_Invalid (Position) then
711 Error_Msg_N ("dimension name& not part of system", Choice);
712 else
713 Extract_Power (Expr, Position);
714 end if;
715
716 -- Range case: NAME .. NAME => EXPRESSION
717
718 elsif Nkind (Choice) = N_Range then
719 declare
720 Low : constant Node_Id := Low_Bound (Choice);
721 High : constant Node_Id := High_Bound (Choice);
722 Low_Pos : Dimension_Position;
723 High_Pos : Dimension_Position;
724
725 begin
726 if Nkind (Low) /= N_Identifier then
727 Error_Msg_N ("bound must denote a dimension name", Low);
728
729 elsif Nkind (High) /= N_Identifier then
730 Error_Msg_N ("bound must denote a dimension name", High);
731
732 else
733 Low_Pos := Position_In_System (Low, System);
734 High_Pos := Position_In_System (High, System);
735
736 if Is_Invalid (Low_Pos) then
737 Error_Msg_N ("dimension name& not part of system",
738 Low);
739
740 elsif Is_Invalid (High_Pos) then
741 Error_Msg_N ("dimension name& not part of system",
742 High);
743
744 elsif Low_Pos > High_Pos then
745 Error_Msg_N ("expected low to high range", Choice);
746
747 else
748 for Position in Low_Pos .. High_Pos loop
749 Extract_Power (Expr, Position);
750 end loop;
751 end if;
752 end if;
753 end;
754
755 -- Others case: OTHERS => EXPRESSION
756
757 elsif Nkind (Choice) = N_Others_Choice then
758 if Present (Next (Choice)) or else Present (Prev (Choice)) then
759 Error_Msg_N
760 ("OTHERS must appear alone in a choice list", Choice);
761
762 elsif Present (Next (Assoc)) then
763 Error_Msg_N
764 ("OTHERS must appear last in an aggregate", Choice);
765
766 elsif Others_Seen then
767 Error_Msg_N ("multiple OTHERS not allowed", Choice);
768
769 else
770 -- Fill the non-processed dimensions with the default value
771 -- supplied by others.
772
773 for Position in Processed'Range loop
774 if not Processed (Position) then
775 Extract_Power (Expr, Position);
776 end if;
777 end loop;
778 end if;
779
780 Others_Seen := True;
781
782 -- All other cases are illegal declarations of dimension names
783
784 else
785 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
786 end if;
787
788 Num_Choices := Num_Choices + 1;
789 Next (Choice);
790 end loop;
791
792 Num_Dimensions := Num_Dimensions + 1;
793 Next (Assoc);
794 end loop;
795
796 -- STEP 3: Consistency of system and dimensions
797
798 if Present (First (Expressions (Aggr)))
799 and then (First (Expressions (Aggr)) /= Symbol_Expr
800 or else Present (Next (Symbol_Expr)))
801 and then (Num_Choices > 1
802 or else (Num_Choices = 1 and then not Others_Seen))
803 then
804 Error_Msg_N
805 ("named associations cannot follow positional associations", Aggr);
806 end if;
807
808 if Num_Dimensions > System.Count then
809 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
810
811 elsif Num_Dimensions < System.Count and then not Others_Seen then
812 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
813 end if;
814
815 -- STEP 4: Dimension symbol extraction
816
817 if Present (Symbol_Expr) then
818 if Nkind (Symbol_Expr) = N_Character_Literal then
819 Start_String;
820 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
821 Symbol := End_String;
822
823 else
824 Symbol := Strval (Symbol_Expr);
825 end if;
826
827 if String_Length (Symbol) = 0 then
828 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
829 end if;
830 end if;
831
832 -- STEP 5: Storage of extracted values
833
834 -- Check that no errors have been detected during the analysis
835
836 if Errors_Count = Serious_Errors_Detected then
837
838 -- Check for useless declaration
839
840 if Symbol = No_String and then not Exists (Dimensions) then
841 Error_Msg_N ("useless dimension declaration", Aggr);
842 end if;
843
844 if Symbol /= No_String then
845 Set_Symbol (Def_Id, Symbol);
846 end if;
847
848 if Exists (Dimensions) then
849 Set_Dimensions (Def_Id, Dimensions);
850 end if;
851 end if;
852 end Analyze_Aspect_Dimension;
853
854 -------------------------------------
855 -- Analyze_Aspect_Dimension_System --
856 -------------------------------------
857
858 -- with Dimension_System => (DIMENSION {, DIMENSION});
859
860 -- DIMENSION ::= (
861 -- [Unit_Name =>] IDENTIFIER,
862 -- [Unit_Symbol =>] SYMBOL,
863 -- [Dim_Symbol =>] SYMBOL)
864
865 procedure Analyze_Aspect_Dimension_System
866 (N : Node_Id;
867 Id : Entity_Id;
868 Aggr : Node_Id)
869 is
870 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
871 -- Determine whether type declaration N denotes a numeric derived type
872
873 -------------------------------
874 -- Is_Derived_Numeric_Type --
875 -------------------------------
876
877 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
878 begin
879 return
880 Nkind (N) = N_Full_Type_Declaration
881 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
882 and then Is_Numeric_Type
883 (Entity (Subtype_Indication (Type_Definition (N))));
884 end Is_Derived_Numeric_Type;
885
886 -- Local variables
887
888 Assoc : Node_Id;
889 Choice : Node_Id;
890 Dim_Aggr : Node_Id;
891 Dim_Symbol : Node_Id;
892 Dim_Symbols : Symbol_Array := No_Symbols;
893 Dim_System : System_Type := Null_System;
894 Position : Nat := 0;
895 Unit_Name : Node_Id;
896 Unit_Names : Name_Array := No_Names;
897 Unit_Symbol : Node_Id;
898 Unit_Symbols : Symbol_Array := No_Symbols;
899
900 Errors_Count : Nat;
901 -- Errors_Count is a count of errors detected by the compiler so far
902 -- just before the extraction of names and symbols in the aggregate
903 -- (Step 3).
904 --
905 -- At the end of the analysis, there is a check to verify that this
906 -- count equals Serious_Errors_Detected i.e. no errors have been
907 -- encountered during the process. Otherwise the System_Table is
908 -- not filled.
909
910 -- Start of processing for Analyze_Aspect_Dimension_System
911
912 begin
913 -- STEP 1: Legality of aspect
914
915 if not Is_Derived_Numeric_Type (N) then
916 Error_Msg_NE
917 ("aspect& must apply to numeric derived type declaration", N, Id);
918 return;
919 end if;
920
921 if Nkind (Aggr) /= N_Aggregate then
922 Error_Msg_N ("aggregate expected", Aggr);
923 return;
924 end if;
925
926 -- STEP 2: Structural verification of the dimension aggregate
927
928 if Present (Component_Associations (Aggr)) then
929 Error_Msg_N ("expected positional aggregate", Aggr);
930 return;
931 end if;
932
933 -- STEP 3: Name and Symbol extraction
934
935 Dim_Aggr := First (Expressions (Aggr));
936 Errors_Count := Serious_Errors_Detected;
937 while Present (Dim_Aggr) loop
938 Position := Position + 1;
939
940 if Position > High_Position_Bound then
941 Error_Msg_N ("too many dimensions in system", Aggr);
942 exit;
943 end if;
944
945 if Nkind (Dim_Aggr) /= N_Aggregate then
946 Error_Msg_N ("aggregate expected", Dim_Aggr);
947
948 else
949 if Present (Component_Associations (Dim_Aggr))
950 and then Present (Expressions (Dim_Aggr))
951 then
952 Error_Msg_N
953 ("mixed positional/named aggregate not allowed here",
954 Dim_Aggr);
955
956 -- Verify each dimension aggregate has three arguments
957
958 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
959 and then List_Length (Expressions (Dim_Aggr)) /= 3
960 then
961 Error_Msg_N
962 ("three components expected in aggregate", Dim_Aggr);
963
964 else
965 -- Named dimension aggregate
966
967 if Present (Component_Associations (Dim_Aggr)) then
968
969 -- Check first argument denotes the unit name
970
971 Assoc := First (Component_Associations (Dim_Aggr));
972 Choice := First (Choices (Assoc));
973 Unit_Name := Expression (Assoc);
974
975 if Present (Next (Choice))
976 or else Nkind (Choice) /= N_Identifier
977 then
978 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
979
980 elsif Chars (Choice) /= Name_Unit_Name then
981 Error_Msg_N ("expected Unit_Name, found&", Choice);
982 end if;
983
984 -- Check the second argument denotes the unit symbol
985
986 Next (Assoc);
987 Choice := First (Choices (Assoc));
988 Unit_Symbol := Expression (Assoc);
989
990 if Present (Next (Choice))
991 or else Nkind (Choice) /= N_Identifier
992 then
993 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
994
995 elsif Chars (Choice) /= Name_Unit_Symbol then
996 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
997 end if;
998
999 -- Check the third argument denotes the dimension symbol
1000
1001 Next (Assoc);
1002 Choice := First (Choices (Assoc));
1003 Dim_Symbol := Expression (Assoc);
1004
1005 if Present (Next (Choice))
1006 or else Nkind (Choice) /= N_Identifier
1007 then
1008 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1009 elsif Chars (Choice) /= Name_Dim_Symbol then
1010 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1011 end if;
1012
1013 -- Positional dimension aggregate
1014
1015 else
1016 Unit_Name := First (Expressions (Dim_Aggr));
1017 Unit_Symbol := Next (Unit_Name);
1018 Dim_Symbol := Next (Unit_Symbol);
1019 end if;
1020
1021 -- Check the first argument for each dimension aggregate is
1022 -- a name.
1023
1024 if Nkind (Unit_Name) = N_Identifier then
1025 Unit_Names (Position) := Chars (Unit_Name);
1026 else
1027 Error_Msg_N ("expected unit name", Unit_Name);
1028 end if;
1029
1030 -- Check the second argument for each dimension aggregate is
1031 -- a string or a character.
1032
1033 if not Nkind_In (Unit_Symbol, N_String_Literal,
1034 N_Character_Literal)
1035 then
1036 Error_Msg_N
1037 ("expected unit symbol (string or character)",
1038 Unit_Symbol);
1039
1040 else
1041 -- String case
1042
1043 if Nkind (Unit_Symbol) = N_String_Literal then
1044 Unit_Symbols (Position) := Strval (Unit_Symbol);
1045
1046 -- Character case
1047
1048 else
1049 Start_String;
1050 Store_String_Char
1051 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1052 Unit_Symbols (Position) := End_String;
1053 end if;
1054
1055 -- Verify that the string is not empty
1056
1057 if String_Length (Unit_Symbols (Position)) = 0 then
1058 Error_Msg_N
1059 ("empty string not allowed here", Unit_Symbol);
1060 end if;
1061 end if;
1062
1063 -- Check the third argument for each dimension aggregate is
1064 -- a string or a character.
1065
1066 if not Nkind_In (Dim_Symbol, N_String_Literal,
1067 N_Character_Literal)
1068 then
1069 Error_Msg_N
1070 ("expected dimension symbol (string or character)",
1071 Dim_Symbol);
1072
1073 else
1074 -- String case
1075
1076 if Nkind (Dim_Symbol) = N_String_Literal then
1077 Dim_Symbols (Position) := Strval (Dim_Symbol);
1078
1079 -- Character case
1080
1081 else
1082 Start_String;
1083 Store_String_Char
1084 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1085 Dim_Symbols (Position) := End_String;
1086 end if;
1087
1088 -- Verify that the string is not empty
1089
1090 if String_Length (Dim_Symbols (Position)) = 0 then
1091 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1092 end if;
1093 end if;
1094 end if;
1095 end if;
1096
1097 Next (Dim_Aggr);
1098 end loop;
1099
1100 -- STEP 4: Storage of extracted values
1101
1102 -- Check that no errors have been detected during the analysis
1103
1104 if Errors_Count = Serious_Errors_Detected then
1105 Dim_System.Type_Decl := N;
1106 Dim_System.Unit_Names := Unit_Names;
1107 Dim_System.Unit_Symbols := Unit_Symbols;
1108 Dim_System.Dim_Symbols := Dim_Symbols;
1109 Dim_System.Count := Position;
1110 System_Table.Append (Dim_System);
1111 end if;
1112 end Analyze_Aspect_Dimension_System;
1113
1114 -----------------------
1115 -- Analyze_Dimension --
1116 -----------------------
1117
1118 -- This dispatch routine propagates dimensions for each node
1119
1120 procedure Analyze_Dimension (N : Node_Id) is
1121 begin
1122 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1123 -- dimensions for nodes that don't come from source, except for subtype
1124 -- declarations where the dimensions are inherited from the base type,
1125 -- and for explicit dereferences generated when expanding iterators.
1126
1127 if Ada_Version < Ada_2012 then
1128 return;
1129
1130 elsif not Comes_From_Source (N)
1131 and then Nkind (N) /= N_Subtype_Declaration
1132 and then Nkind (N) /= N_Explicit_Dereference
1133 then
1134 return;
1135 end if;
1136
1137 case Nkind (N) is
1138 when N_Assignment_Statement =>
1139 Analyze_Dimension_Assignment_Statement (N);
1140
1141 when N_Binary_Op =>
1142 Analyze_Dimension_Binary_Op (N);
1143
1144 when N_Component_Declaration =>
1145 Analyze_Dimension_Component_Declaration (N);
1146
1147 when N_Extended_Return_Statement =>
1148 Analyze_Dimension_Extended_Return_Statement (N);
1149
1150 when N_Attribute_Reference |
1151 N_Expanded_Name |
1152 N_Explicit_Dereference |
1153 N_Function_Call |
1154 N_Indexed_Component |
1155 N_Qualified_Expression |
1156 N_Selected_Component |
1157 N_Slice |
1158 N_Type_Conversion |
1159 N_Unchecked_Type_Conversion =>
1160 Analyze_Dimension_Has_Etype (N);
1161
1162 -- In the presence of a repaired syntax error, an identifier
1163 -- may be introduced without a usable type.
1164
1165 when N_Identifier =>
1166 if Present (Etype (N)) then
1167 Analyze_Dimension_Has_Etype (N);
1168 end if;
1169
1170 when N_Number_Declaration =>
1171 Analyze_Dimension_Number_Declaration (N);
1172
1173 when N_Object_Declaration =>
1174 Analyze_Dimension_Object_Declaration (N);
1175
1176 when N_Object_Renaming_Declaration =>
1177 Analyze_Dimension_Object_Renaming_Declaration (N);
1178
1179 when N_Simple_Return_Statement =>
1180 if not Comes_From_Extended_Return_Statement (N) then
1181 Analyze_Dimension_Simple_Return_Statement (N);
1182 end if;
1183
1184 when N_Subtype_Declaration =>
1185 Analyze_Dimension_Subtype_Declaration (N);
1186
1187 when N_Unary_Op =>
1188 Analyze_Dimension_Unary_Op (N);
1189
1190 when others => null;
1191
1192 end case;
1193 end Analyze_Dimension;
1194
1195 ---------------------------------------
1196 -- Analyze_Dimension_Array_Aggregate --
1197 ---------------------------------------
1198
1199 procedure Analyze_Dimension_Array_Aggregate
1200 (N : Node_Id;
1201 Comp_Typ : Entity_Id)
1202 is
1203 Comp_Ass : constant List_Id := Component_Associations (N);
1204 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1205 Exps : constant List_Id := Expressions (N);
1206
1207 Comp : Node_Id;
1208 Expr : Node_Id;
1209
1210 Error_Detected : Boolean := False;
1211 -- This flag is used in order to indicate if an error has been detected
1212 -- so far by the compiler in this routine.
1213
1214 begin
1215 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1216 -- base type is not a dimensioned type.
1217
1218 -- Note that here the original node must come from source since the
1219 -- original array aggregate may not have been entirely decorated.
1220
1221 if Ada_Version < Ada_2012
1222 or else not Comes_From_Source (Original_Node (N))
1223 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1224 then
1225 return;
1226 end if;
1227
1228 -- Check whether there is any positional component association
1229
1230 if Is_Empty_List (Exps) then
1231 Comp := First (Comp_Ass);
1232 else
1233 Comp := First (Exps);
1234 end if;
1235
1236 while Present (Comp) loop
1237
1238 -- Get the expression from the component
1239
1240 if Nkind (Comp) = N_Component_Association then
1241 Expr := Expression (Comp);
1242 else
1243 Expr := Comp;
1244 end if;
1245
1246 -- Issue an error if the dimensions of the component type and the
1247 -- dimensions of the component mismatch.
1248
1249 -- Note that we must ensure the expression has been fully analyzed
1250 -- since it may not be decorated at this point. We also don't want to
1251 -- issue the same error message multiple times on the same expression
1252 -- (may happen when an aggregate is converted into a positional
1253 -- aggregate). We also must verify that this is a scalar component,
1254 -- and not a subaggregate of a multidimensional aggregate.
1255
1256 if Comes_From_Source (Original_Node (Expr))
1257 and then Present (Etype (Expr))
1258 and then Is_Numeric_Type (Etype (Expr))
1259 and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1260 and then Sloc (Comp) /= Sloc (Prev (Comp))
1261 then
1262 -- Check if an error has already been encountered so far
1263
1264 if not Error_Detected then
1265 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1266 Error_Detected := True;
1267 end if;
1268
1269 Error_Msg_N
1270 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1271 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1272 end if;
1273
1274 -- Look at the named components right after the positional components
1275
1276 if not Present (Next (Comp))
1277 and then List_Containing (Comp) = Exps
1278 then
1279 Comp := First (Comp_Ass);
1280 else
1281 Next (Comp);
1282 end if;
1283 end loop;
1284 end Analyze_Dimension_Array_Aggregate;
1285
1286 --------------------------------------------
1287 -- Analyze_Dimension_Assignment_Statement --
1288 --------------------------------------------
1289
1290 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1291 Lhs : constant Node_Id := Name (N);
1292 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1293 Rhs : constant Node_Id := Expression (N);
1294 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1295
1296 procedure Error_Dim_Msg_For_Assignment_Statement
1297 (N : Node_Id;
1298 Lhs : Node_Id;
1299 Rhs : Node_Id);
1300 -- Error using Error_Msg_N at node N. Output the dimensions of left
1301 -- and right hand sides.
1302
1303 --------------------------------------------
1304 -- Error_Dim_Msg_For_Assignment_Statement --
1305 --------------------------------------------
1306
1307 procedure Error_Dim_Msg_For_Assignment_Statement
1308 (N : Node_Id;
1309 Lhs : Node_Id;
1310 Rhs : Node_Id)
1311 is
1312 begin
1313 Error_Msg_N ("dimensions mismatch in assignment", N);
1314 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1315 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1316 end Error_Dim_Msg_For_Assignment_Statement;
1317
1318 -- Start of processing for Analyze_Dimension_Assignment
1319
1320 begin
1321 if Dims_Of_Lhs /= Dims_Of_Rhs then
1322 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1323 end if;
1324 end Analyze_Dimension_Assignment_Statement;
1325
1326 ---------------------------------
1327 -- Analyze_Dimension_Binary_Op --
1328 ---------------------------------
1329
1330 -- Check and propagate the dimensions for binary operators
1331 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1332
1333 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1334 N_Kind : constant Node_Kind := Nkind (N);
1335
1336 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
1337 -- If the operand is a numeric literal that comes from a declared
1338 -- constant, use the dimensions of the constant which were computed
1339 -- from the expression of the constant declaration.
1340
1341 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1342 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1343 -- dimensions of both operands.
1344
1345 ---------------------------
1346 -- Dimensions_Of_Operand --
1347 ---------------------------
1348
1349 function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
1350 begin
1351 if Nkind (N) = N_Real_Literal
1352 and then Present (Original_Entity (N))
1353 then
1354 return Dimensions_Of (Original_Entity (N));
1355 else
1356 return Dimensions_Of (N);
1357 end if;
1358 end Dimensions_Of_Operand;
1359
1360 ---------------------------------
1361 -- Error_Dim_Msg_For_Binary_Op --
1362 ---------------------------------
1363
1364 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1365 begin
1366 Error_Msg_NE
1367 ("both operands for operation& must have same dimensions",
1368 N, Entity (N));
1369 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1370 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1371 end Error_Dim_Msg_For_Binary_Op;
1372
1373 -- Start of processing for Analyze_Dimension_Binary_Op
1374
1375 begin
1376 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1377 or else N_Kind in N_Multiplying_Operator
1378 or else N_Kind in N_Op_Compare
1379 then
1380 declare
1381 L : constant Node_Id := Left_Opnd (N);
1382 Dims_Of_L : constant Dimension_Type :=
1383 Dimensions_Of_Operand (L);
1384 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1385 R : constant Node_Id := Right_Opnd (N);
1386 Dims_Of_R : constant Dimension_Type :=
1387 Dimensions_Of_Operand (R);
1388 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1389 Dims_Of_N : Dimension_Type := Null_Dimension;
1390
1391 begin
1392 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1393
1394 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1395
1396 -- Check both operands have same dimension
1397
1398 if Dims_Of_L /= Dims_Of_R then
1399 Error_Dim_Msg_For_Binary_Op (N, L, R);
1400 else
1401 -- Check both operands are not dimensionless
1402
1403 if Exists (Dims_Of_L) then
1404 Set_Dimensions (N, Dims_Of_L);
1405 end if;
1406 end if;
1407
1408 -- N_Op_Multiply or N_Op_Divide case
1409
1410 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1411
1412 -- Check at least one operand is not dimensionless
1413
1414 if L_Has_Dimensions or R_Has_Dimensions then
1415
1416 -- Multiplication case
1417
1418 -- Get both operands dimensions and add them
1419
1420 if N_Kind = N_Op_Multiply then
1421 for Position in Dimension_Type'Range loop
1422 Dims_Of_N (Position) :=
1423 Dims_Of_L (Position) + Dims_Of_R (Position);
1424 end loop;
1425
1426 -- Division case
1427
1428 -- Get both operands dimensions and subtract them
1429
1430 else
1431 for Position in Dimension_Type'Range loop
1432 Dims_Of_N (Position) :=
1433 Dims_Of_L (Position) - Dims_Of_R (Position);
1434 end loop;
1435 end if;
1436
1437 if Exists (Dims_Of_N) then
1438 Set_Dimensions (N, Dims_Of_N);
1439 end if;
1440 end if;
1441
1442 -- Exponentiation case
1443
1444 -- Note: a rational exponent is allowed for dimensioned operand
1445
1446 elsif N_Kind = N_Op_Expon then
1447
1448 -- Check the left operand is not dimensionless. Note that the
1449 -- value of the exponent must be known compile time. Otherwise,
1450 -- the exponentiation evaluation will return an error message.
1451
1452 if L_Has_Dimensions then
1453 if not Compile_Time_Known_Value (R) then
1454 Error_Msg_N
1455 ("exponent of dimensioned operand must be "
1456 & "known at compile time", N);
1457 end if;
1458
1459 declare
1460 Exponent_Value : Rational := Zero;
1461
1462 begin
1463 -- Real operand case
1464
1465 if Is_Real_Type (Etype (L)) then
1466
1467 -- Define the exponent as a Rational number
1468
1469 Exponent_Value := Create_Rational_From (R, False);
1470
1471 -- Verify that the exponent cannot be interpreted
1472 -- as a rational, otherwise interpret the exponent
1473 -- as an integer.
1474
1475 if Exponent_Value = No_Rational then
1476 Exponent_Value :=
1477 +Whole (UI_To_Int (Expr_Value (R)));
1478 end if;
1479
1480 -- Integer operand case.
1481
1482 -- For integer operand, the exponent cannot be
1483 -- interpreted as a rational.
1484
1485 else
1486 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1487 end if;
1488
1489 for Position in Dimension_Type'Range loop
1490 Dims_Of_N (Position) :=
1491 Dims_Of_L (Position) * Exponent_Value;
1492 end loop;
1493
1494 if Exists (Dims_Of_N) then
1495 Set_Dimensions (N, Dims_Of_N);
1496 end if;
1497 end;
1498 end if;
1499
1500 -- Comparison cases
1501
1502 -- For relational operations, only dimension checking is
1503 -- performed (no propagation). If one operand is the result
1504 -- of constant folding the dimensions may have been lost
1505 -- in a tree copy, so assume that pre-analysis has verified
1506 -- that dimensions are correct.
1507
1508 elsif N_Kind in N_Op_Compare then
1509 if (L_Has_Dimensions or R_Has_Dimensions)
1510 and then Dims_Of_L /= Dims_Of_R
1511 then
1512 if Nkind (L) = N_Real_Literal
1513 and then not (Comes_From_Source (L))
1514 and then Expander_Active
1515 then
1516 null;
1517
1518 elsif Nkind (R) = N_Real_Literal
1519 and then not (Comes_From_Source (R))
1520 and then Expander_Active
1521 then
1522 null;
1523
1524 else
1525 Error_Dim_Msg_For_Binary_Op (N, L, R);
1526 end if;
1527 end if;
1528 end if;
1529
1530 -- If expander is active, remove dimension information from each
1531 -- operand, as only dimensions of result are relevant.
1532
1533 if Expander_Active then
1534 Remove_Dimensions (L);
1535 Remove_Dimensions (R);
1536 end if;
1537 end;
1538 end if;
1539 end Analyze_Dimension_Binary_Op;
1540
1541 ----------------------------
1542 -- Analyze_Dimension_Call --
1543 ----------------------------
1544
1545 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1546 Actuals : constant List_Id := Parameter_Associations (N);
1547 Actual : Node_Id;
1548 Dims_Of_Formal : Dimension_Type;
1549 Formal : Node_Id;
1550 Formal_Typ : Entity_Id;
1551
1552 Error_Detected : Boolean := False;
1553 -- This flag is used in order to indicate if an error has been detected
1554 -- so far by the compiler in this routine.
1555
1556 begin
1557 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1558 -- dimensions for calls that don't come from source, or those that may
1559 -- have semantic errors.
1560
1561 if Ada_Version < Ada_2012
1562 or else not Comes_From_Source (N)
1563 or else Error_Posted (N)
1564 then
1565 return;
1566 end if;
1567
1568 -- Check the dimensions of the actuals, if any
1569
1570 if not Is_Empty_List (Actuals) then
1571
1572 -- Special processing for elementary functions
1573
1574 -- For Sqrt call, the resulting dimensions equal to half the
1575 -- dimensions of the actual. For all other elementary calls, this
1576 -- routine check that every actual is dimensionless.
1577
1578 if Nkind (N) = N_Function_Call then
1579 Elementary_Function_Calls : declare
1580 Dims_Of_Call : Dimension_Type;
1581 Ent : Entity_Id := Nam;
1582
1583 function Is_Elementary_Function_Entity
1584 (Sub_Id : Entity_Id) return Boolean;
1585 -- Given Sub_Id, the original subprogram entity, return True
1586 -- if call is to an elementary function (see Ada.Numerics.
1587 -- Generic_Elementary_Functions).
1588
1589 -----------------------------------
1590 -- Is_Elementary_Function_Entity --
1591 -----------------------------------
1592
1593 function Is_Elementary_Function_Entity
1594 (Sub_Id : Entity_Id) return Boolean
1595 is
1596 Loc : constant Source_Ptr := Sloc (Sub_Id);
1597
1598 begin
1599 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1600
1601 return
1602 Loc > No_Location
1603 and then
1604 Is_RTU
1605 (Cunit_Entity (Get_Source_Unit (Loc)),
1606 Ada_Numerics_Generic_Elementary_Functions);
1607 end Is_Elementary_Function_Entity;
1608
1609 -- Start of processing for Elementary_Function_Calls
1610
1611 begin
1612 -- Get original subprogram entity following the renaming chain
1613
1614 if Present (Alias (Ent)) then
1615 Ent := Alias (Ent);
1616 end if;
1617
1618 -- Check the call is an Elementary function call
1619
1620 if Is_Elementary_Function_Entity (Ent) then
1621
1622 -- Sqrt function call case
1623
1624 if Chars (Ent) = Name_Sqrt then
1625 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1626
1627 -- Evaluates the resulting dimensions (i.e. half the
1628 -- dimensions of the actual).
1629
1630 if Exists (Dims_Of_Call) then
1631 for Position in Dims_Of_Call'Range loop
1632 Dims_Of_Call (Position) :=
1633 Dims_Of_Call (Position) *
1634 Rational'(Numerator => 1, Denominator => 2);
1635 end loop;
1636
1637 Set_Dimensions (N, Dims_Of_Call);
1638 end if;
1639
1640 -- All other elementary functions case. Note that every
1641 -- actual here should be dimensionless.
1642
1643 else
1644 Actual := First_Actual (N);
1645 while Present (Actual) loop
1646 if Exists (Dimensions_Of (Actual)) then
1647
1648 -- Check if error has already been encountered
1649
1650 if not Error_Detected then
1651 Error_Msg_NE
1652 ("dimensions mismatch in call of&",
1653 N, Name (N));
1654 Error_Detected := True;
1655 end if;
1656
1657 Error_Msg_N
1658 ("\expected dimension '['], found "
1659 & Dimensions_Msg_Of (Actual), Actual);
1660 end if;
1661
1662 Next_Actual (Actual);
1663 end loop;
1664 end if;
1665
1666 -- Nothing more to do for elementary functions
1667
1668 return;
1669 end if;
1670 end Elementary_Function_Calls;
1671 end if;
1672
1673 -- General case. Check, for each parameter, the dimensions of the
1674 -- actual and its corresponding formal match. Otherwise, complain.
1675
1676 Actual := First_Actual (N);
1677 Formal := First_Formal (Nam);
1678 while Present (Formal) loop
1679
1680 -- A missing corresponding actual indicates that the analysis of
1681 -- the call was aborted due to a previous error.
1682
1683 if No (Actual) then
1684 Check_Error_Detected;
1685 return;
1686 end if;
1687
1688 Formal_Typ := Etype (Formal);
1689 Dims_Of_Formal := Dimensions_Of (Formal_Typ);
1690
1691 -- If the formal is not dimensionless, check dimensions of formal
1692 -- and actual match. Otherwise, complain.
1693
1694 if Exists (Dims_Of_Formal)
1695 and then Dimensions_Of (Actual) /= Dims_Of_Formal
1696 then
1697 -- Check if an error has already been encountered so far
1698
1699 if not Error_Detected then
1700 Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
1701 Error_Detected := True;
1702 end if;
1703
1704 Error_Msg_N
1705 ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ)
1706 & ", found " & Dimensions_Msg_Of (Actual), Actual);
1707 end if;
1708
1709 Next_Actual (Actual);
1710 Next_Formal (Formal);
1711 end loop;
1712 end if;
1713
1714 -- For function calls, propagate the dimensions from the returned type
1715
1716 if Nkind (N) = N_Function_Call then
1717 Analyze_Dimension_Has_Etype (N);
1718 end if;
1719 end Analyze_Dimension_Call;
1720
1721 ---------------------------------------------
1722 -- Analyze_Dimension_Component_Declaration --
1723 ---------------------------------------------
1724
1725 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1726 Expr : constant Node_Id := Expression (N);
1727 Id : constant Entity_Id := Defining_Identifier (N);
1728 Etyp : constant Entity_Id := Etype (Id);
1729 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1730 Dims_Of_Expr : Dimension_Type;
1731
1732 procedure Error_Dim_Msg_For_Component_Declaration
1733 (N : Node_Id;
1734 Etyp : Entity_Id;
1735 Expr : Node_Id);
1736 -- Error using Error_Msg_N at node N. Output the dimensions of the
1737 -- type Etyp and the expression Expr of N.
1738
1739 ---------------------------------------------
1740 -- Error_Dim_Msg_For_Component_Declaration --
1741 ---------------------------------------------
1742
1743 procedure Error_Dim_Msg_For_Component_Declaration
1744 (N : Node_Id;
1745 Etyp : Entity_Id;
1746 Expr : Node_Id) is
1747 begin
1748 Error_Msg_N ("dimensions mismatch in component declaration", N);
1749 Error_Msg_N
1750 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
1751 & Dimensions_Msg_Of (Expr), Expr);
1752 end Error_Dim_Msg_For_Component_Declaration;
1753
1754 -- Start of processing for Analyze_Dimension_Component_Declaration
1755
1756 begin
1757 -- Expression is present
1758
1759 if Present (Expr) then
1760 Dims_Of_Expr := Dimensions_Of (Expr);
1761
1762 -- Check dimensions match
1763
1764 if Dims_Of_Etyp /= Dims_Of_Expr then
1765
1766 -- Numeric literal case. Issue a warning if the object type is not
1767 -- dimensionless to indicate the literal is treated as if its
1768 -- dimension matches the type dimension.
1769
1770 if Nkind_In (Original_Node (Expr), N_Real_Literal,
1771 N_Integer_Literal)
1772 then
1773 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
1774
1775 -- Issue a dimension mismatch error for all other cases
1776
1777 else
1778 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1779 end if;
1780 end if;
1781 end if;
1782 end Analyze_Dimension_Component_Declaration;
1783
1784 -------------------------------------------------
1785 -- Analyze_Dimension_Extended_Return_Statement --
1786 -------------------------------------------------
1787
1788 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1789 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
1790 Return_Etyp : constant Entity_Id :=
1791 Etype (Return_Applies_To (Return_Ent));
1792 Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
1793 Return_Obj_Decl : Node_Id;
1794 Return_Obj_Id : Entity_Id;
1795 Return_Obj_Typ : Entity_Id;
1796
1797 procedure Error_Dim_Msg_For_Extended_Return_Statement
1798 (N : Node_Id;
1799 Return_Etyp : Entity_Id;
1800 Return_Obj_Typ : Entity_Id);
1801 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1802 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1803
1804 -------------------------------------------------
1805 -- Error_Dim_Msg_For_Extended_Return_Statement --
1806 -------------------------------------------------
1807
1808 procedure Error_Dim_Msg_For_Extended_Return_Statement
1809 (N : Node_Id;
1810 Return_Etyp : Entity_Id;
1811 Return_Obj_Typ : Entity_Id)
1812 is
1813 begin
1814 Error_Msg_N ("dimensions mismatch in extended return statement", N);
1815 Error_Msg_N
1816 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
1817 & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N);
1818 end Error_Dim_Msg_For_Extended_Return_Statement;
1819
1820 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1821
1822 begin
1823 if Present (Return_Obj_Decls) then
1824 Return_Obj_Decl := First (Return_Obj_Decls);
1825 while Present (Return_Obj_Decl) loop
1826 if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1827 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1828
1829 if Is_Return_Object (Return_Obj_Id) then
1830 Return_Obj_Typ := Etype (Return_Obj_Id);
1831
1832 -- Issue an error message if dimensions mismatch
1833
1834 if Dimensions_Of (Return_Etyp) /=
1835 Dimensions_Of (Return_Obj_Typ)
1836 then
1837 Error_Dim_Msg_For_Extended_Return_Statement
1838 (N, Return_Etyp, Return_Obj_Typ);
1839 return;
1840 end if;
1841 end if;
1842 end if;
1843
1844 Next (Return_Obj_Decl);
1845 end loop;
1846 end if;
1847 end Analyze_Dimension_Extended_Return_Statement;
1848
1849 -----------------------------------------------------
1850 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1851 -----------------------------------------------------
1852
1853 procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
1854 Comp : Node_Id;
1855 Comp_Id : Entity_Id;
1856 Comp_Typ : Entity_Id;
1857 Expr : Node_Id;
1858
1859 Error_Detected : Boolean := False;
1860 -- This flag is used in order to indicate if an error has been detected
1861 -- so far by the compiler in this routine.
1862
1863 begin
1864 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1865 -- dimensions for aggregates that don't come from source, or if we are
1866 -- within an initialization procedure, whose expressions have been
1867 -- checked at the point of record declaration.
1868
1869 if Ada_Version < Ada_2012
1870 or else not Comes_From_Source (N)
1871 or else Inside_Init_Proc
1872 then
1873 return;
1874 end if;
1875
1876 Comp := First (Component_Associations (N));
1877 while Present (Comp) loop
1878 Comp_Id := Entity (First (Choices (Comp)));
1879 Comp_Typ := Etype (Comp_Id);
1880
1881 -- Check the component type is either a dimensioned type or a
1882 -- dimensioned subtype.
1883
1884 if Has_Dimension_System (Base_Type (Comp_Typ)) then
1885 Expr := Expression (Comp);
1886
1887 -- A box-initialized component needs no checking.
1888
1889 if No (Expr) and then Box_Present (Comp) then
1890 null;
1891
1892 -- Issue an error if the dimensions of the component type and the
1893 -- dimensions of the component mismatch.
1894
1895 elsif Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
1896
1897 -- Check if an error has already been encountered so far
1898
1899 if not Error_Detected then
1900
1901 -- Extension aggregate case
1902
1903 if Nkind (N) = N_Extension_Aggregate then
1904 Error_Msg_N
1905 ("dimensions mismatch in extension aggregate", N);
1906
1907 -- Record aggregate case
1908
1909 else
1910 Error_Msg_N
1911 ("dimensions mismatch in record aggregate", N);
1912 end if;
1913
1914 Error_Detected := True;
1915 end if;
1916
1917 Error_Msg_N
1918 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1919 & ", found " & Dimensions_Msg_Of (Expr), Comp);
1920 end if;
1921 end if;
1922
1923 Next (Comp);
1924 end loop;
1925 end Analyze_Dimension_Extension_Or_Record_Aggregate;
1926
1927 -------------------------------
1928 -- Analyze_Dimension_Formals --
1929 -------------------------------
1930
1931 procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
1932 Dims_Of_Typ : Dimension_Type;
1933 Formal : Node_Id;
1934 Typ : Entity_Id;
1935
1936 begin
1937 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1938 -- dimensions for sub specs that don't come from source.
1939
1940 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1941 return;
1942 end if;
1943
1944 Formal := First (Formals);
1945 while Present (Formal) loop
1946 Typ := Parameter_Type (Formal);
1947 Dims_Of_Typ := Dimensions_Of (Typ);
1948
1949 if Exists (Dims_Of_Typ) then
1950 declare
1951 Expr : constant Node_Id := Expression (Formal);
1952
1953 begin
1954 -- Issue a warning if Expr is a numeric literal and if its
1955 -- dimensions differ with the dimensions of the formal type.
1956
1957 if Present (Expr)
1958 and then Dims_Of_Typ /= Dimensions_Of (Expr)
1959 and then Nkind_In (Original_Node (Expr), N_Real_Literal,
1960 N_Integer_Literal)
1961 then
1962 Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
1963 end if;
1964 end;
1965 end if;
1966
1967 Next (Formal);
1968 end loop;
1969 end Analyze_Dimension_Formals;
1970
1971 ---------------------------------
1972 -- Analyze_Dimension_Has_Etype --
1973 ---------------------------------
1974
1975 procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
1976 Etyp : constant Entity_Id := Etype (N);
1977 Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp);
1978
1979 begin
1980 -- General case. Propagation of the dimensions from the type
1981
1982 if Exists (Dims_Of_Etyp) then
1983 Set_Dimensions (N, Dims_Of_Etyp);
1984
1985 -- Identifier case. Propagate the dimensions from the entity for
1986 -- identifier whose entity is a non-dimensionless constant.
1987
1988 elsif Nkind (N) = N_Identifier then
1989 Analyze_Dimension_Identifier : declare
1990 Id : constant Entity_Id := Entity (N);
1991
1992 begin
1993 -- If Id is missing, abnormal tree, assume previous error
1994
1995 if No (Id) then
1996 Check_Error_Detected;
1997 return;
1998
1999 elsif Ekind_In (Id, E_Constant, E_Named_Real)
2000 and then Exists (Dimensions_Of (Id))
2001 then
2002 Set_Dimensions (N, Dimensions_Of (Id));
2003 end if;
2004 end Analyze_Dimension_Identifier;
2005
2006 -- Attribute reference case. Propagate the dimensions from the prefix.
2007
2008 elsif Nkind (N) = N_Attribute_Reference
2009 and then Has_Dimension_System (Base_Type (Etyp))
2010 then
2011 Dims_Of_Etyp := Dimensions_Of (Prefix (N));
2012
2013 -- Check the prefix is not dimensionless
2014
2015 if Exists (Dims_Of_Etyp) then
2016 Set_Dimensions (N, Dims_Of_Etyp);
2017 end if;
2018 end if;
2019
2020 -- Remove dimensions from inner expressions, to prevent dimensions
2021 -- table from growing uselessly.
2022
2023 case Nkind (N) is
2024 when N_Attribute_Reference |
2025 N_Indexed_Component =>
2026 declare
2027 Expr : Node_Id;
2028 Exprs : constant List_Id := Expressions (N);
2029 begin
2030 if Present (Exprs) then
2031 Expr := First (Exprs);
2032 while Present (Expr) loop
2033 Remove_Dimensions (Expr);
2034 Next (Expr);
2035 end loop;
2036 end if;
2037 end;
2038
2039 when N_Qualified_Expression |
2040 N_Type_Conversion |
2041 N_Unchecked_Type_Conversion =>
2042 Remove_Dimensions (Expression (N));
2043
2044 when N_Selected_Component =>
2045 Remove_Dimensions (Selector_Name (N));
2046
2047 when others => null;
2048 end case;
2049 end Analyze_Dimension_Has_Etype;
2050
2051 ------------------------------------------
2052 -- Analyze_Dimension_Number_Declaration --
2053 ------------------------------------------
2054
2055 procedure Analyze_Dimension_Number_Declaration (N : Node_Id) is
2056 Expr : constant Node_Id := Expression (N);
2057 Id : constant Entity_Id := Defining_Identifier (N);
2058 Dim_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
2059
2060 begin
2061 if Exists (Dim_Of_Expr) then
2062 Set_Dimensions (Id, Dim_Of_Expr);
2063 Set_Etype (Id, Etype (Expr));
2064 end if;
2065 end Analyze_Dimension_Number_Declaration;
2066
2067 ------------------------------------------
2068 -- Analyze_Dimension_Object_Declaration --
2069 ------------------------------------------
2070
2071 procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
2072 Expr : constant Node_Id := Expression (N);
2073 Id : constant Entity_Id := Defining_Identifier (N);
2074 Etyp : constant Entity_Id := Etype (Id);
2075 Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
2076 Dim_Of_Expr : Dimension_Type;
2077
2078 procedure Error_Dim_Msg_For_Object_Declaration
2079 (N : Node_Id;
2080 Etyp : Entity_Id;
2081 Expr : Node_Id);
2082 -- Error using Error_Msg_N at node N. Output the dimensions of the
2083 -- type Etyp and of the expression Expr.
2084
2085 ------------------------------------------
2086 -- Error_Dim_Msg_For_Object_Declaration --
2087 ------------------------------------------
2088
2089 procedure Error_Dim_Msg_For_Object_Declaration
2090 (N : Node_Id;
2091 Etyp : Entity_Id;
2092 Expr : Node_Id) is
2093 begin
2094 Error_Msg_N ("dimensions mismatch in object declaration", N);
2095 Error_Msg_N
2096 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
2097 & Dimensions_Msg_Of (Expr), Expr);
2098 end Error_Dim_Msg_For_Object_Declaration;
2099
2100 -- Start of processing for Analyze_Dimension_Object_Declaration
2101
2102 begin
2103 -- Expression is present
2104
2105 if Present (Expr) then
2106 Dim_Of_Expr := Dimensions_Of (Expr);
2107
2108 -- Check dimensions match
2109
2110 if Dim_Of_Expr /= Dim_Of_Etyp then
2111
2112 -- Numeric literal case. Issue a warning if the object type is not
2113 -- dimensionless to indicate the literal is treated as if its
2114 -- dimension matches the type dimension.
2115
2116 if Nkind_In (Original_Node (Expr), N_Real_Literal,
2117 N_Integer_Literal)
2118 then
2119 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
2120
2121 -- Case of object is a constant whose type is a dimensioned type
2122
2123 elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
2124
2125 -- Propagate dimension from expression to object entity
2126
2127 Set_Dimensions (Id, Dim_Of_Expr);
2128
2129 -- For all other cases, issue an error message
2130
2131 else
2132 Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
2133 end if;
2134 end if;
2135
2136 -- Removal of dimensions in expression
2137
2138 Remove_Dimensions (Expr);
2139 end if;
2140 end Analyze_Dimension_Object_Declaration;
2141
2142 ---------------------------------------------------
2143 -- Analyze_Dimension_Object_Renaming_Declaration --
2144 ---------------------------------------------------
2145
2146 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
2147 Renamed_Name : constant Node_Id := Name (N);
2148 Sub_Mark : constant Node_Id := Subtype_Mark (N);
2149
2150 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2151 (N : Node_Id;
2152 Sub_Mark : Node_Id;
2153 Renamed_Name : Node_Id);
2154 -- Error using Error_Msg_N at node N. Output the dimensions of
2155 -- Sub_Mark and of Renamed_Name.
2156
2157 ---------------------------------------------------
2158 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2159 ---------------------------------------------------
2160
2161 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2162 (N : Node_Id;
2163 Sub_Mark : Node_Id;
2164 Renamed_Name : Node_Id) is
2165 begin
2166 Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
2167 Error_Msg_N
2168 ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found "
2169 & Dimensions_Msg_Of (Renamed_Name), Renamed_Name);
2170 end Error_Dim_Msg_For_Object_Renaming_Declaration;
2171
2172 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2173
2174 begin
2175 if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
2176 Error_Dim_Msg_For_Object_Renaming_Declaration
2177 (N, Sub_Mark, Renamed_Name);
2178 end if;
2179 end Analyze_Dimension_Object_Renaming_Declaration;
2180
2181 -----------------------------------------------
2182 -- Analyze_Dimension_Simple_Return_Statement --
2183 -----------------------------------------------
2184
2185 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
2186 Expr : constant Node_Id := Expression (N);
2187 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
2188 Return_Etyp : constant Entity_Id :=
2189 Etype (Return_Applies_To (Return_Ent));
2190 Dims_Of_Return_Etyp : constant Dimension_Type :=
2191 Dimensions_Of (Return_Etyp);
2192
2193 procedure Error_Dim_Msg_For_Simple_Return_Statement
2194 (N : Node_Id;
2195 Return_Etyp : Entity_Id;
2196 Expr : Node_Id);
2197 -- Error using Error_Msg_N at node N. Output the dimensions of the
2198 -- returned type Return_Etyp and the returned expression Expr of N.
2199
2200 -----------------------------------------------
2201 -- Error_Dim_Msg_For_Simple_Return_Statement --
2202 -----------------------------------------------
2203
2204 procedure Error_Dim_Msg_For_Simple_Return_Statement
2205 (N : Node_Id;
2206 Return_Etyp : Entity_Id;
2207 Expr : Node_Id)
2208 is
2209 begin
2210 Error_Msg_N ("dimensions mismatch in return statement", N);
2211 Error_Msg_N
2212 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
2213 & ", found " & Dimensions_Msg_Of (Expr), Expr);
2214 end Error_Dim_Msg_For_Simple_Return_Statement;
2215
2216 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2217
2218 begin
2219 if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then
2220 Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
2221 Remove_Dimensions (Expr);
2222 end if;
2223 end Analyze_Dimension_Simple_Return_Statement;
2224
2225 -------------------------------------------
2226 -- Analyze_Dimension_Subtype_Declaration --
2227 -------------------------------------------
2228
2229 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
2230 Id : constant Entity_Id := Defining_Identifier (N);
2231 Dims_Of_Id : constant Dimension_Type := Dimensions_Of (Id);
2232 Dims_Of_Etyp : Dimension_Type;
2233 Etyp : Node_Id;
2234
2235 begin
2236 -- No constraint case in subtype declaration
2237
2238 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
2239 Etyp := Etype (Subtype_Indication (N));
2240 Dims_Of_Etyp := Dimensions_Of (Etyp);
2241
2242 if Exists (Dims_Of_Etyp) then
2243
2244 -- If subtype already has a dimension (from Aspect_Dimension), it
2245 -- cannot inherit different dimensions from its subtype.
2246
2247 if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then
2248 Error_Msg_NE
2249 ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id);
2250 else
2251 Set_Dimensions (Id, Dims_Of_Etyp);
2252 Set_Symbol (Id, Symbol_Of (Etyp));
2253 end if;
2254 end if;
2255
2256 -- Constraint present in subtype declaration
2257
2258 else
2259 Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
2260 Dims_Of_Etyp := Dimensions_Of (Etyp);
2261
2262 if Exists (Dims_Of_Etyp) then
2263 Set_Dimensions (Id, Dims_Of_Etyp);
2264 Set_Symbol (Id, Symbol_Of (Etyp));
2265 end if;
2266 end if;
2267 end Analyze_Dimension_Subtype_Declaration;
2268
2269 --------------------------------
2270 -- Analyze_Dimension_Unary_Op --
2271 --------------------------------
2272
2273 procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
2274 begin
2275 case Nkind (N) is
2276 when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
2277
2278 -- Propagate the dimension if the operand is not dimensionless
2279
2280 declare
2281 R : constant Node_Id := Right_Opnd (N);
2282 begin
2283 Move_Dimensions (R, N);
2284 end;
2285
2286 when others => null;
2287
2288 end case;
2289 end Analyze_Dimension_Unary_Op;
2290
2291 ---------------------------------
2292 -- Check_Expression_Dimensions --
2293 ---------------------------------
2294
2295 procedure Check_Expression_Dimensions
2296 (Expr : Node_Id;
2297 Typ : Entity_Id)
2298 is
2299 begin
2300 if Is_Floating_Point_Type (Etype (Expr)) then
2301 Analyze_Dimension (Expr);
2302
2303 if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then
2304 Error_Msg_N ("dimensions mismatch in array aggregate", Expr);
2305 Error_Msg_N
2306 ("\expected dimension " & Dimensions_Msg_Of (Typ)
2307 & ", found " & Dimensions_Msg_Of (Expr), Expr);
2308 end if;
2309 end if;
2310 end Check_Expression_Dimensions;
2311
2312 ---------------------
2313 -- Copy_Dimensions --
2314 ---------------------
2315
2316 procedure Copy_Dimensions (From, To : Node_Id) is
2317 Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
2318
2319 begin
2320 -- Ignore if not Ada 2012 or beyond
2321
2322 if Ada_Version < Ada_2012 then
2323 return;
2324
2325 -- For Ada 2012, Copy the dimension of 'From to 'To'
2326
2327 elsif Exists (Dims_Of_From) then
2328 Set_Dimensions (To, Dims_Of_From);
2329 end if;
2330 end Copy_Dimensions;
2331
2332 --------------------------
2333 -- Create_Rational_From --
2334 --------------------------
2335
2336 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2337
2338 -- A rational number is a number that can be expressed as the quotient or
2339 -- fraction a/b of two integers, where b is non-zero positive.
2340
2341 function Create_Rational_From
2342 (Expr : Node_Id;
2343 Complain : Boolean) return Rational
2344 is
2345 Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
2346 Result : Rational := No_Rational;
2347
2348 function Process_Minus (N : Node_Id) return Rational;
2349 -- Create a rational from a N_Op_Minus node
2350
2351 function Process_Divide (N : Node_Id) return Rational;
2352 -- Create a rational from a N_Op_Divide node
2353
2354 function Process_Literal (N : Node_Id) return Rational;
2355 -- Create a rational from a N_Integer_Literal node
2356
2357 -------------------
2358 -- Process_Minus --
2359 -------------------
2360
2361 function Process_Minus (N : Node_Id) return Rational is
2362 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2363 Result : Rational;
2364
2365 begin
2366 -- Operand is an integer literal
2367
2368 if Nkind (Right) = N_Integer_Literal then
2369 Result := -Process_Literal (Right);
2370
2371 -- Operand is a divide operator
2372
2373 elsif Nkind (Right) = N_Op_Divide then
2374 Result := -Process_Divide (Right);
2375
2376 else
2377 Result := No_Rational;
2378 end if;
2379
2380 -- Provide minimal semantic information on dimension expressions,
2381 -- even though they have no run-time existence. This is for use by
2382 -- ASIS tools, in particular pretty-printing. If generating code
2383 -- standard operator resolution will take place.
2384
2385 if ASIS_Mode then
2386 Set_Entity (N, Standard_Op_Minus);
2387 Set_Etype (N, Standard_Integer);
2388 end if;
2389
2390 return Result;
2391 end Process_Minus;
2392
2393 --------------------
2394 -- Process_Divide --
2395 --------------------
2396
2397 function Process_Divide (N : Node_Id) return Rational is
2398 Left : constant Node_Id := Original_Node (Left_Opnd (N));
2399 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2400 Left_Rat : Rational;
2401 Result : Rational := No_Rational;
2402 Right_Rat : Rational;
2403
2404 begin
2405 -- Both left and right operands are integer literals
2406
2407 if Nkind (Left) = N_Integer_Literal
2408 and then
2409 Nkind (Right) = N_Integer_Literal
2410 then
2411 Left_Rat := Process_Literal (Left);
2412 Right_Rat := Process_Literal (Right);
2413 Result := Left_Rat / Right_Rat;
2414 end if;
2415
2416 -- Provide minimal semantic information on dimension expressions,
2417 -- even though they have no run-time existence. This is for use by
2418 -- ASIS tools, in particular pretty-printing. If generating code
2419 -- standard operator resolution will take place.
2420
2421 if ASIS_Mode then
2422 Set_Entity (N, Standard_Op_Divide);
2423 Set_Etype (N, Standard_Integer);
2424 end if;
2425
2426 return Result;
2427 end Process_Divide;
2428
2429 ---------------------
2430 -- Process_Literal --
2431 ---------------------
2432
2433 function Process_Literal (N : Node_Id) return Rational is
2434 begin
2435 return +Whole (UI_To_Int (Intval (N)));
2436 end Process_Literal;
2437
2438 -- Start of processing for Create_Rational_From
2439
2440 begin
2441 -- Check the expression is either a division of two integers or an
2442 -- integer itself. Note that the check applies to the original node
2443 -- since the node could have already been rewritten.
2444
2445 -- Integer literal case
2446
2447 if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
2448 Result := Process_Literal (Or_Node_Of_Expr);
2449
2450 -- Divide operator case
2451
2452 elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
2453 Result := Process_Divide (Or_Node_Of_Expr);
2454
2455 -- Minus operator case
2456
2457 elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
2458 Result := Process_Minus (Or_Node_Of_Expr);
2459 end if;
2460
2461 -- When Expr cannot be interpreted as a rational and Complain is true,
2462 -- generate an error message.
2463
2464 if Complain and then Result = No_Rational then
2465 Error_Msg_N ("rational expected", Expr);
2466 end if;
2467
2468 return Result;
2469 end Create_Rational_From;
2470
2471 -------------------
2472 -- Dimensions_Of --
2473 -------------------
2474
2475 function Dimensions_Of (N : Node_Id) return Dimension_Type is
2476 begin
2477 return Dimension_Table.Get (N);
2478 end Dimensions_Of;
2479
2480 -----------------------
2481 -- Dimensions_Msg_Of --
2482 -----------------------
2483
2484 function Dimensions_Msg_Of
2485 (N : Node_Id;
2486 Description_Needed : Boolean := False) return String
2487 is
2488 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2489 Dimensions_Msg : Name_Id;
2490 System : System_Type;
2491
2492 begin
2493 -- Initialization of Name_Buffer
2494
2495 Name_Len := 0;
2496
2497 -- N is not dimensionless
2498
2499 if Exists (Dims_Of_N) then
2500 System := System_Of (Base_Type (Etype (N)));
2501
2502 -- When Description_Needed, add to string "has dimension " before the
2503 -- actual dimension.
2504
2505 if Description_Needed then
2506 Add_Str_To_Name_Buffer ("has dimension ");
2507 end if;
2508
2509 Add_String_To_Name_Buffer
2510 (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
2511
2512 -- N is dimensionless
2513
2514 -- When Description_Needed, return "is dimensionless"
2515
2516 elsif Description_Needed then
2517 Add_Str_To_Name_Buffer ("is dimensionless");
2518
2519 -- Otherwise, return "'[']"
2520
2521 else
2522 Add_Str_To_Name_Buffer ("'[']");
2523 end if;
2524
2525 Dimensions_Msg := Name_Find;
2526 return Get_Name_String (Dimensions_Msg);
2527 end Dimensions_Msg_Of;
2528
2529 --------------------------
2530 -- Dimension_Table_Hash --
2531 --------------------------
2532
2533 function Dimension_Table_Hash
2534 (Key : Node_Id) return Dimension_Table_Range
2535 is
2536 begin
2537 return Dimension_Table_Range (Key mod 511);
2538 end Dimension_Table_Hash;
2539
2540 -------------------------------------
2541 -- Dim_Warning_For_Numeric_Literal --
2542 -------------------------------------
2543
2544 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
2545 begin
2546 -- Initialize name buffer
2547
2548 Name_Len := 0;
2549
2550 Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
2551
2552 -- Insert a blank between the literal and the symbol
2553
2554 Add_Str_To_Name_Buffer (" ");
2555 Add_String_To_Name_Buffer (Symbol_Of (Typ));
2556
2557 Error_Msg_Name_1 := Name_Find;
2558 Error_Msg_N ("assumed to be%%??", N);
2559 end Dim_Warning_For_Numeric_Literal;
2560
2561 ----------------------------------------
2562 -- Eval_Op_Expon_For_Dimensioned_Type --
2563 ----------------------------------------
2564
2565 -- Evaluate the expon operator for real dimensioned type.
2566
2567 -- Note that if the exponent is an integer (denominator = 1) the node is
2568 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2569
2570 procedure Eval_Op_Expon_For_Dimensioned_Type
2571 (N : Node_Id;
2572 Btyp : Entity_Id)
2573 is
2574 R : constant Node_Id := Right_Opnd (N);
2575 R_Value : Rational := No_Rational;
2576
2577 begin
2578 if Is_Real_Type (Btyp) then
2579 R_Value := Create_Rational_From (R, False);
2580 end if;
2581
2582 -- Check that the exponent is not an integer
2583
2584 if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
2585 Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
2586 else
2587 Eval_Op_Expon (N);
2588 end if;
2589 end Eval_Op_Expon_For_Dimensioned_Type;
2590
2591 ------------------------------------------
2592 -- Eval_Op_Expon_With_Rational_Exponent --
2593 ------------------------------------------
2594
2595 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2596 -- Rational and not only an Integer like for dimensionless operands. For
2597 -- that particular case, the left operand is rewritten as a function call
2598 -- using the function Expon_LLF from s-llflex.ads.
2599
2600 procedure Eval_Op_Expon_With_Rational_Exponent
2601 (N : Node_Id;
2602 Exponent_Value : Rational)
2603 is
2604 Loc : constant Source_Ptr := Sloc (N);
2605 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2606 L : constant Node_Id := Left_Opnd (N);
2607 Etyp_Of_L : constant Entity_Id := Etype (L);
2608 Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2609 Actual_1 : Node_Id;
2610 Actual_2 : Node_Id;
2611 Dim_Power : Rational;
2612 List_Of_Dims : List_Id;
2613 New_Aspect : Node_Id;
2614 New_Aspects : List_Id;
2615 New_Id : Entity_Id;
2616 New_N : Node_Id;
2617 New_Subtyp_Decl_For_L : Node_Id;
2618 System : System_Type;
2619
2620 begin
2621 -- Case when the operand is not dimensionless
2622
2623 if Exists (Dims_Of_N) then
2624
2625 -- Get the corresponding System_Type to know the exact number of
2626 -- dimensions in the system.
2627
2628 System := System_Of (Btyp_Of_L);
2629
2630 -- Generation of a new subtype with the proper dimensions
2631
2632 -- In order to rewrite the operator as a type conversion, a new
2633 -- dimensioned subtype with the resulting dimensions of the
2634 -- exponentiation must be created.
2635
2636 -- Generate:
2637
2638 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2639 -- System : constant System_Id :=
2640 -- Get_Dimension_System_Id (Btyp_Of_L);
2641 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2642 -- Dimension_Systems.Table (System).Dimension_Count;
2643
2644 -- subtype T is Btyp_Of_L
2645 -- with
2646 -- Dimension => (
2647 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2648 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2649 -- ...
2650 -- Dims_Of_N (Num_Of_Dims).Numerator /
2651 -- Dims_Of_N (Num_Of_Dims).Denominator);
2652
2653 -- Step 1: Generate the new aggregate for the aspect Dimension
2654
2655 New_Aspects := Empty_List;
2656
2657 List_Of_Dims := New_List;
2658 for Position in Dims_Of_N'First .. System.Count loop
2659 Dim_Power := Dims_Of_N (Position);
2660 Append_To (List_Of_Dims,
2661 Make_Op_Divide (Loc,
2662 Left_Opnd =>
2663 Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)),
2664 Right_Opnd =>
2665 Make_Integer_Literal (Loc, Int (Dim_Power.Denominator))));
2666 end loop;
2667
2668 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2669
2670 New_Aspect :=
2671 Make_Aspect_Specification (Loc,
2672 Identifier => Make_Identifier (Loc, Name_Dimension),
2673 Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2674
2675 -- Step 3: Make a temporary identifier for the new subtype
2676
2677 New_Id := Make_Temporary (Loc, 'T');
2678 Set_Is_Internal (New_Id);
2679
2680 -- Step 4: Declaration of the new subtype
2681
2682 New_Subtyp_Decl_For_L :=
2683 Make_Subtype_Declaration (Loc,
2684 Defining_Identifier => New_Id,
2685 Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc));
2686
2687 Append (New_Aspect, New_Aspects);
2688 Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
2689 Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2690
2691 Analyze (New_Subtyp_Decl_For_L);
2692
2693 -- Case where the operand is dimensionless
2694
2695 else
2696 New_Id := Btyp_Of_L;
2697 end if;
2698
2699 -- Replacement of N by New_N
2700
2701 -- Generate:
2702
2703 -- Actual_1 := Long_Long_Float (L),
2704
2705 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2706 -- Long_Long_Float (Exponent_Value.Denominator);
2707
2708 -- (T (Expon_LLF (Actual_1, Actual_2)));
2709
2710 -- where T is the subtype declared in step 1
2711
2712 -- The node is rewritten as a type conversion
2713
2714 -- Step 1: Creation of the two parameters of Expon_LLF function call
2715
2716 Actual_1 :=
2717 Make_Type_Conversion (Loc,
2718 Subtype_Mark => New_Occurrence_Of (Standard_Long_Long_Float, Loc),
2719 Expression => Relocate_Node (L));
2720
2721 Actual_2 :=
2722 Make_Op_Divide (Loc,
2723 Left_Opnd =>
2724 Make_Real_Literal (Loc,
2725 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2726 Right_Opnd =>
2727 Make_Real_Literal (Loc,
2728 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2729
2730 -- Step 2: Creation of New_N
2731
2732 New_N :=
2733 Make_Type_Conversion (Loc,
2734 Subtype_Mark => New_Occurrence_Of (New_Id, Loc),
2735 Expression =>
2736 Make_Function_Call (Loc,
2737 Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc),
2738 Parameter_Associations => New_List (
2739 Actual_1, Actual_2)));
2740
2741 -- Step 3: Rewrite N with the result
2742
2743 Rewrite (N, New_N);
2744 Set_Etype (N, New_Id);
2745 Analyze_And_Resolve (N, New_Id);
2746 end Eval_Op_Expon_With_Rational_Exponent;
2747
2748 ------------
2749 -- Exists --
2750 ------------
2751
2752 function Exists (Dim : Dimension_Type) return Boolean is
2753 begin
2754 return Dim /= Null_Dimension;
2755 end Exists;
2756
2757 function Exists (Str : String_Id) return Boolean is
2758 begin
2759 return Str /= No_String;
2760 end Exists;
2761
2762 function Exists (Sys : System_Type) return Boolean is
2763 begin
2764 return Sys /= Null_System;
2765 end Exists;
2766
2767 ---------------------------------
2768 -- Expand_Put_Call_With_Symbol --
2769 ---------------------------------
2770
2771 -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in
2772 -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string
2773 -- parameter is rewritten to include the unit symbol (or the dimension
2774 -- symbols if not a defined quantity) in the output of a dimensioned
2775 -- object. If a value is already supplied by the user for the parameter
2776 -- Symbol, it is used as is.
2777
2778 -- Case 1. Item is dimensionless
2779
2780 -- * Put : Item appears without a suffix
2781
2782 -- * Put_Dim_Of : the output is []
2783
2784 -- Obj : Mks_Type := 2.6;
2785 -- Put (Obj, 1, 1, 0);
2786 -- Put_Dim_Of (Obj);
2787
2788 -- The corresponding outputs are:
2789 -- $2.6
2790 -- $[]
2791
2792 -- Case 2. Item has a dimension
2793
2794 -- * Put : If the type of Item is a dimensioned subtype whose
2795 -- symbol is not empty, then the symbol appears as a
2796 -- suffix. Otherwise, a new string is created and appears
2797 -- as a suffix of Item. This string results in the
2798 -- successive concatanations between each unit symbol
2799 -- raised by its corresponding dimension power from the
2800 -- dimensions of Item.
2801
2802 -- * Put_Dim_Of : The output is a new string resulting in the successive
2803 -- concatanations between each dimension symbol raised by
2804 -- its corresponding dimension power from the dimensions of
2805 -- Item.
2806
2807 -- subtype Random is Mks_Type
2808 -- with
2809 -- Dimension => (
2810 -- Meter => 3,
2811 -- Candela => -1,
2812 -- others => 0);
2813
2814 -- Obj : Random := 5.0;
2815 -- Put (Obj);
2816 -- Put_Dim_Of (Obj);
2817
2818 -- The corresponding outputs are:
2819 -- $5.0 m**3.cd**(-1)
2820 -- $[l**3.J**(-1)]
2821
2822 -- The function Image returns the string identical to that produced by
2823 -- a call to Put whose first parameter is a string.
2824
2825 procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
2826 Actuals : constant List_Id := Parameter_Associations (N);
2827 Loc : constant Source_Ptr := Sloc (N);
2828 Name_Call : constant Node_Id := Name (N);
2829 New_Actuals : constant List_Id := New_List;
2830 Actual : Node_Id;
2831 Dims_Of_Actual : Dimension_Type;
2832 Etyp : Entity_Id;
2833 New_Str_Lit : Node_Id := Empty;
2834 Symbols : String_Id;
2835
2836 Is_Put_Dim_Of : Boolean := False;
2837 -- This flag is used in order to differentiate routines Put and
2838 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2839 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2840
2841 function Has_Symbols return Boolean;
2842 -- Return True if the current Put call already has a parameter
2843 -- association for parameter "Symbols" with the correct string of
2844 -- symbols.
2845
2846 function Is_Procedure_Put_Call return Boolean;
2847 -- Return True if the current call is a call of an instantiation of a
2848 -- procedure Put defined in the package System.Dim.Float_IO and
2849 -- System.Dim.Integer_IO.
2850
2851 function Item_Actual return Node_Id;
2852 -- Return the item actual parameter node in the output call
2853
2854 -----------------
2855 -- Has_Symbols --
2856 -----------------
2857
2858 function Has_Symbols return Boolean is
2859 Actual : Node_Id;
2860 Actual_Str : Node_Id;
2861
2862 begin
2863 -- Look for a symbols parameter association in the list of actuals
2864
2865 Actual := First (Actuals);
2866 while Present (Actual) loop
2867
2868 -- Positional parameter association case when the actual is a
2869 -- string literal.
2870
2871 if Nkind (Actual) = N_String_Literal then
2872 Actual_Str := Actual;
2873
2874 -- Named parameter association case when selector name is Symbol
2875
2876 elsif Nkind (Actual) = N_Parameter_Association
2877 and then Chars (Selector_Name (Actual)) = Name_Symbol
2878 then
2879 Actual_Str := Explicit_Actual_Parameter (Actual);
2880
2881 -- Ignore all other cases
2882
2883 else
2884 Actual_Str := Empty;
2885 end if;
2886
2887 if Present (Actual_Str) then
2888
2889 -- Return True if the actual comes from source or if the string
2890 -- of symbols doesn't have the default value (i.e. it is ""),
2891 -- in which case it is used as suffix of the generated string.
2892
2893 if Comes_From_Source (Actual)
2894 or else String_Length (Strval (Actual_Str)) /= 0
2895 then
2896 return True;
2897
2898 else
2899 return False;
2900 end if;
2901 end if;
2902
2903 Next (Actual);
2904 end loop;
2905
2906 -- At this point, the call has no parameter association. Look to the
2907 -- last actual since the symbols parameter is the last one.
2908
2909 return Nkind (Last (Actuals)) = N_String_Literal;
2910 end Has_Symbols;
2911
2912 ---------------------------
2913 -- Is_Procedure_Put_Call --
2914 ---------------------------
2915
2916 function Is_Procedure_Put_Call return Boolean is
2917 Ent : Entity_Id;
2918 Loc : Source_Ptr;
2919
2920 begin
2921 -- There are three different Put (resp. Put_Dim_Of) routines in each
2922 -- generic dim IO package. Verify the current procedure call is one
2923 -- of them.
2924
2925 if Is_Entity_Name (Name_Call) then
2926 Ent := Entity (Name_Call);
2927
2928 -- Get the original subprogram entity following the renaming chain
2929
2930 if Present (Alias (Ent)) then
2931 Ent := Alias (Ent);
2932 end if;
2933
2934 Loc := Sloc (Ent);
2935
2936 -- Check the name of the entity subprogram is Put (resp.
2937 -- Put_Dim_Of) and verify this entity is located in either
2938 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2939
2940 if Loc > No_Location
2941 and then Is_Dim_IO_Package_Entity
2942 (Cunit_Entity (Get_Source_Unit (Loc)))
2943 then
2944 if Chars (Ent) = Name_Put_Dim_Of then
2945 Is_Put_Dim_Of := True;
2946 return True;
2947
2948 elsif Chars (Ent) = Name_Put
2949 or else Chars (Ent) = Name_Image
2950 then
2951 return True;
2952 end if;
2953 end if;
2954 end if;
2955
2956 return False;
2957 end Is_Procedure_Put_Call;
2958
2959 -----------------
2960 -- Item_Actual --
2961 -----------------
2962
2963 function Item_Actual return Node_Id is
2964 Actual : Node_Id;
2965
2966 begin
2967 -- Look for the item actual as a parameter association
2968
2969 Actual := First (Actuals);
2970 while Present (Actual) loop
2971 if Nkind (Actual) = N_Parameter_Association
2972 and then Chars (Selector_Name (Actual)) = Name_Item
2973 then
2974 return Explicit_Actual_Parameter (Actual);
2975 end if;
2976
2977 Next (Actual);
2978 end loop;
2979
2980 -- Case where the item has been defined without an association
2981
2982 Actual := First (Actuals);
2983
2984 -- Depending on the procedure Put, Item actual could be first or
2985 -- second in the list of actuals.
2986
2987 if Has_Dimension_System (Base_Type (Etype (Actual))) then
2988 return Actual;
2989 else
2990 return Next (Actual);
2991 end if;
2992 end Item_Actual;
2993
2994 -- Start of processing for Expand_Put_Call_With_Symbol
2995
2996 begin
2997 if Is_Procedure_Put_Call and then not Has_Symbols then
2998 Actual := Item_Actual;
2999 Dims_Of_Actual := Dimensions_Of (Actual);
3000 Etyp := Etype (Actual);
3001
3002 -- Put_Dim_Of case
3003
3004 if Is_Put_Dim_Of then
3005
3006 -- Check that the item is not dimensionless
3007
3008 -- Create the new String_Literal with the new String_Id generated
3009 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
3010
3011 if Exists (Dims_Of_Actual) then
3012 New_Str_Lit :=
3013 Make_String_Literal (Loc,
3014 From_Dim_To_Str_Of_Dim_Symbols
3015 (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
3016
3017 -- If dimensionless, the output is []
3018
3019 else
3020 New_Str_Lit :=
3021 Make_String_Literal (Loc, "[]");
3022 end if;
3023
3024 -- Put case
3025
3026 else
3027 -- Add the symbol as a suffix of the value if the subtype has a
3028 -- unit symbol or if the parameter is not dimensionless.
3029
3030 if Exists (Symbol_Of (Etyp)) then
3031 Symbols := Symbol_Of (Etyp);
3032 else
3033 Symbols := From_Dim_To_Str_Of_Unit_Symbols
3034 (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
3035 end if;
3036
3037 -- Check Symbols exists
3038
3039 if Exists (Symbols) then
3040 Start_String;
3041
3042 -- Put a space between the value and the dimension
3043
3044 Store_String_Char (' ');
3045 Store_String_Chars (Symbols);
3046 New_Str_Lit := Make_String_Literal (Loc, End_String);
3047 end if;
3048 end if;
3049
3050 if Present (New_Str_Lit) then
3051
3052 -- Insert all actuals in New_Actuals
3053
3054 Actual := First (Actuals);
3055 while Present (Actual) loop
3056
3057 -- Copy every actuals in New_Actuals except the Symbols
3058 -- parameter association.
3059
3060 if Nkind (Actual) = N_Parameter_Association
3061 and then Chars (Selector_Name (Actual)) /= Name_Symbol
3062 then
3063 Append_To (New_Actuals,
3064 Make_Parameter_Association (Loc,
3065 Selector_Name => New_Copy (Selector_Name (Actual)),
3066 Explicit_Actual_Parameter =>
3067 New_Copy (Explicit_Actual_Parameter (Actual))));
3068
3069 elsif Nkind (Actual) /= N_Parameter_Association then
3070 Append_To (New_Actuals, New_Copy (Actual));
3071 end if;
3072
3073 Next (Actual);
3074 end loop;
3075
3076 -- Create new Symbols param association and append to New_Actuals
3077
3078 Append_To (New_Actuals,
3079 Make_Parameter_Association (Loc,
3080 Selector_Name => Make_Identifier (Loc, Name_Symbol),
3081 Explicit_Actual_Parameter => New_Str_Lit));
3082
3083 -- Rewrite and analyze the procedure call
3084
3085 if Chars (Name_Call) = Name_Image then
3086 Rewrite (N,
3087 Make_Function_Call (Loc,
3088 Name => New_Copy (Name_Call),
3089 Parameter_Associations => New_Actuals));
3090 Analyze_And_Resolve (N);
3091 else
3092 Rewrite (N,
3093 Make_Procedure_Call_Statement (Loc,
3094 Name => New_Copy (Name_Call),
3095 Parameter_Associations => New_Actuals));
3096 Analyze (N);
3097 end if;
3098
3099 end if;
3100 end if;
3101 end Expand_Put_Call_With_Symbol;
3102
3103 ------------------------------------
3104 -- From_Dim_To_Str_Of_Dim_Symbols --
3105 ------------------------------------
3106
3107 -- Given a dimension vector and the corresponding dimension system, create
3108 -- a String_Id to output dimension symbols corresponding to the dimensions
3109 -- Dims. If In_Error_Msg is True, there is a special handling for character
3110 -- asterisk * which is an insertion character in error messages.
3111
3112 function From_Dim_To_Str_Of_Dim_Symbols
3113 (Dims : Dimension_Type;
3114 System : System_Type;
3115 In_Error_Msg : Boolean := False) return String_Id
3116 is
3117 Dim_Power : Rational;
3118 First_Dim : Boolean := True;
3119
3120 procedure Store_String_Oexpon;
3121 -- Store the expon operator symbol "**" in the string. In error
3122 -- messages, asterisk * is a special character and must be quoted
3123 -- to be placed literally into the message.
3124
3125 -------------------------
3126 -- Store_String_Oexpon --
3127 -------------------------
3128
3129 procedure Store_String_Oexpon is
3130 begin
3131 if In_Error_Msg then
3132 Store_String_Chars ("'*'*");
3133 else
3134 Store_String_Chars ("**");
3135 end if;
3136 end Store_String_Oexpon;
3137
3138 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3139
3140 begin
3141 -- Initialization of the new String_Id
3142
3143 Start_String;
3144
3145 -- Store the dimension symbols inside boxes
3146
3147 if In_Error_Msg then
3148 Store_String_Chars ("'[");
3149 else
3150 Store_String_Char ('[');
3151 end if;
3152
3153 for Position in Dimension_Type'Range loop
3154 Dim_Power := Dims (Position);
3155 if Dim_Power /= Zero then
3156
3157 if First_Dim then
3158 First_Dim := False;
3159 else
3160 Store_String_Char ('.');
3161 end if;
3162
3163 Store_String_Chars (System.Dim_Symbols (Position));
3164
3165 -- Positive dimension case
3166
3167 if Dim_Power.Numerator > 0 then
3168
3169 -- Integer case
3170
3171 if Dim_Power.Denominator = 1 then
3172 if Dim_Power.Numerator /= 1 then
3173 Store_String_Oexpon;
3174 Store_String_Int (Int (Dim_Power.Numerator));
3175 end if;
3176
3177 -- Rational case when denominator /= 1
3178
3179 else
3180 Store_String_Oexpon;
3181 Store_String_Char ('(');
3182 Store_String_Int (Int (Dim_Power.Numerator));
3183 Store_String_Char ('/');
3184 Store_String_Int (Int (Dim_Power.Denominator));
3185 Store_String_Char (')');
3186 end if;
3187
3188 -- Negative dimension case
3189
3190 else
3191 Store_String_Oexpon;
3192 Store_String_Char ('(');
3193 Store_String_Char ('-');
3194 Store_String_Int (Int (-Dim_Power.Numerator));
3195
3196 -- Integer case
3197
3198 if Dim_Power.Denominator = 1 then
3199 Store_String_Char (')');
3200
3201 -- Rational case when denominator /= 1
3202
3203 else
3204 Store_String_Char ('/');
3205 Store_String_Int (Int (Dim_Power.Denominator));
3206 Store_String_Char (')');
3207 end if;
3208 end if;
3209 end if;
3210 end loop;
3211
3212 if In_Error_Msg then
3213 Store_String_Chars ("']");
3214 else
3215 Store_String_Char (']');
3216 end if;
3217
3218 return End_String;
3219 end From_Dim_To_Str_Of_Dim_Symbols;
3220
3221 -------------------------------------
3222 -- From_Dim_To_Str_Of_Unit_Symbols --
3223 -------------------------------------
3224
3225 -- Given a dimension vector and the corresponding dimension system,
3226 -- create a String_Id to output the unit symbols corresponding to the
3227 -- dimensions Dims.
3228
3229 function From_Dim_To_Str_Of_Unit_Symbols
3230 (Dims : Dimension_Type;
3231 System : System_Type) return String_Id
3232 is
3233 Dim_Power : Rational;
3234 First_Dim : Boolean := True;
3235
3236 begin
3237 -- Return No_String if dimensionless
3238
3239 if not Exists (Dims) then
3240 return No_String;
3241 end if;
3242
3243 -- Initialization of the new String_Id
3244
3245 Start_String;
3246
3247 for Position in Dimension_Type'Range loop
3248 Dim_Power := Dims (Position);
3249
3250 if Dim_Power /= Zero then
3251 if First_Dim then
3252 First_Dim := False;
3253 else
3254 Store_String_Char ('.');
3255 end if;
3256
3257 Store_String_Chars (System.Unit_Symbols (Position));
3258
3259 -- Positive dimension case
3260
3261 if Dim_Power.Numerator > 0 then
3262
3263 -- Integer case
3264
3265 if Dim_Power.Denominator = 1 then
3266 if Dim_Power.Numerator /= 1 then
3267 Store_String_Chars ("**");
3268 Store_String_Int (Int (Dim_Power.Numerator));
3269 end if;
3270
3271 -- Rational case when denominator /= 1
3272
3273 else
3274 Store_String_Chars ("**");
3275 Store_String_Char ('(');
3276 Store_String_Int (Int (Dim_Power.Numerator));
3277 Store_String_Char ('/');
3278 Store_String_Int (Int (Dim_Power.Denominator));
3279 Store_String_Char (')');
3280 end if;
3281
3282 -- Negative dimension case
3283
3284 else
3285 Store_String_Chars ("**");
3286 Store_String_Char ('(');
3287 Store_String_Char ('-');
3288 Store_String_Int (Int (-Dim_Power.Numerator));
3289
3290 -- Integer case
3291
3292 if Dim_Power.Denominator = 1 then
3293 Store_String_Char (')');
3294
3295 -- Rational case when denominator /= 1
3296
3297 else
3298 Store_String_Char ('/');
3299 Store_String_Int (Int (Dim_Power.Denominator));
3300 Store_String_Char (')');
3301 end if;
3302 end if;
3303 end if;
3304 end loop;
3305
3306 return End_String;
3307 end From_Dim_To_Str_Of_Unit_Symbols;
3308
3309 ---------
3310 -- GCD --
3311 ---------
3312
3313 function GCD (Left, Right : Whole) return Int is
3314 L : Whole;
3315 R : Whole;
3316
3317 begin
3318 L := Left;
3319 R := Right;
3320 while R /= 0 loop
3321 L := L mod R;
3322
3323 if L = 0 then
3324 return Int (R);
3325 end if;
3326
3327 R := R mod L;
3328 end loop;
3329
3330 return Int (L);
3331 end GCD;
3332
3333 --------------------------
3334 -- Has_Dimension_System --
3335 --------------------------
3336
3337 function Has_Dimension_System (Typ : Entity_Id) return Boolean is
3338 begin
3339 return Exists (System_Of (Typ));
3340 end Has_Dimension_System;
3341
3342 ------------------------------
3343 -- Is_Dim_IO_Package_Entity --
3344 ------------------------------
3345
3346 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
3347 begin
3348 -- Check the package entity corresponds to System.Dim.Float_IO or
3349 -- System.Dim.Integer_IO.
3350
3351 return
3352 Is_RTU (E, System_Dim_Float_IO)
3353 or else
3354 Is_RTU (E, System_Dim_Integer_IO);
3355 end Is_Dim_IO_Package_Entity;
3356
3357 -------------------------------------
3358 -- Is_Dim_IO_Package_Instantiation --
3359 -------------------------------------
3360
3361 function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
3362 Gen_Id : constant Node_Id := Name (N);
3363
3364 begin
3365 -- Check that the instantiated package is either System.Dim.Float_IO
3366 -- or System.Dim.Integer_IO.
3367
3368 return
3369 Is_Entity_Name (Gen_Id)
3370 and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
3371 end Is_Dim_IO_Package_Instantiation;
3372
3373 ----------------
3374 -- Is_Invalid --
3375 ----------------
3376
3377 function Is_Invalid (Position : Dimension_Position) return Boolean is
3378 begin
3379 return Position = Invalid_Position;
3380 end Is_Invalid;
3381
3382 ---------------------
3383 -- Move_Dimensions --
3384 ---------------------
3385
3386 procedure Move_Dimensions (From, To : Node_Id) is
3387 begin
3388 if Ada_Version < Ada_2012 then
3389 return;
3390 end if;
3391
3392 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3393
3394 Copy_Dimensions (From, To);
3395 Remove_Dimensions (From);
3396 end Move_Dimensions;
3397
3398 ------------
3399 -- Reduce --
3400 ------------
3401
3402 function Reduce (X : Rational) return Rational is
3403 begin
3404 if X.Numerator = 0 then
3405 return Zero;
3406 end if;
3407
3408 declare
3409 G : constant Int := GCD (X.Numerator, X.Denominator);
3410 begin
3411 return Rational'(Numerator => Whole (Int (X.Numerator) / G),
3412 Denominator => Whole (Int (X.Denominator) / G));
3413 end;
3414 end Reduce;
3415
3416 -----------------------
3417 -- Remove_Dimensions --
3418 -----------------------
3419
3420 procedure Remove_Dimensions (N : Node_Id) is
3421 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3422 begin
3423 if Exists (Dims_Of_N) then
3424 Dimension_Table.Remove (N);
3425 end if;
3426 end Remove_Dimensions;
3427
3428 -----------------------------------
3429 -- Remove_Dimension_In_Statement --
3430 -----------------------------------
3431
3432 -- Removal of dimension in statement as part of the Analyze_Statements
3433 -- routine (see package Sem_Ch5).
3434
3435 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3436 begin
3437 if Ada_Version < Ada_2012 then
3438 return;
3439 end if;
3440
3441 -- Remove dimension in parameter specifications for accept statement
3442
3443 if Nkind (Stmt) = N_Accept_Statement then
3444 declare
3445 Param : Node_Id := First (Parameter_Specifications (Stmt));
3446 begin
3447 while Present (Param) loop
3448 Remove_Dimensions (Param);
3449 Next (Param);
3450 end loop;
3451 end;
3452
3453 -- Remove dimension of name and expression in assignments
3454
3455 elsif Nkind (Stmt) = N_Assignment_Statement then
3456 Remove_Dimensions (Expression (Stmt));
3457 Remove_Dimensions (Name (Stmt));
3458 end if;
3459 end Remove_Dimension_In_Statement;
3460
3461 --------------------
3462 -- Set_Dimensions --
3463 --------------------
3464
3465 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3466 begin
3467 pragma Assert (OK_For_Dimension (Nkind (N)));
3468 pragma Assert (Exists (Val));
3469
3470 Dimension_Table.Set (N, Val);
3471 end Set_Dimensions;
3472
3473 ----------------
3474 -- Set_Symbol --
3475 ----------------
3476
3477 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3478 begin
3479 Symbol_Table.Set (E, Val);
3480 end Set_Symbol;
3481
3482 ---------------------------------
3483 -- String_From_Numeric_Literal --
3484 ---------------------------------
3485
3486 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3487 Loc : constant Source_Ptr := Sloc (N);
3488 Sbuffer : constant Source_Buffer_Ptr :=
3489 Source_Text (Get_Source_File_Index (Loc));
3490 Src_Ptr : Source_Ptr := Loc;
3491
3492 C : Character := Sbuffer (Src_Ptr);
3493 -- Current source program character
3494
3495 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3496 -- Return True if C belongs to a numeric literal
3497
3498 -------------------------------
3499 -- Belong_To_Numeric_Literal --
3500 -------------------------------
3501
3502 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3503 begin
3504 case C is
3505 when '0' .. '9' |
3506 '_' |
3507 '.' |
3508 'e' |
3509 '#' |
3510 'A' |
3511 'B' |
3512 'C' |
3513 'D' |
3514 'E' |
3515 'F' =>
3516 return True;
3517
3518 -- Make sure '+' or '-' is part of an exponent.
3519
3520 when '+' | '-' =>
3521 declare
3522 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3523 begin
3524 return Prev_C = 'e' or else Prev_C = 'E';
3525 end;
3526
3527 -- All other character doesn't belong to a numeric literal
3528
3529 when others =>
3530 return False;
3531 end case;
3532 end Belong_To_Numeric_Literal;
3533
3534 -- Start of processing for String_From_Numeric_Literal
3535
3536 begin
3537 Start_String;
3538 while Belong_To_Numeric_Literal (C) loop
3539 Store_String_Char (C);
3540 Src_Ptr := Src_Ptr + 1;
3541 C := Sbuffer (Src_Ptr);
3542 end loop;
3543
3544 return End_String;
3545 end String_From_Numeric_Literal;
3546
3547 ---------------
3548 -- Symbol_Of --
3549 ---------------
3550
3551 function Symbol_Of (E : Entity_Id) return String_Id is
3552 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3553 begin
3554 if Subtype_Symbol /= No_String then
3555 return Subtype_Symbol;
3556 else
3557 return From_Dim_To_Str_Of_Unit_Symbols
3558 (Dimensions_Of (E), System_Of (Base_Type (E)));
3559 end if;
3560 end Symbol_Of;
3561
3562 -----------------------
3563 -- Symbol_Table_Hash --
3564 -----------------------
3565
3566 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3567 begin
3568 return Symbol_Table_Range (Key mod 511);
3569 end Symbol_Table_Hash;
3570
3571 ---------------
3572 -- System_Of --
3573 ---------------
3574
3575 function System_Of (E : Entity_Id) return System_Type is
3576 Type_Decl : constant Node_Id := Parent (E);
3577
3578 begin
3579 -- Look for Type_Decl in System_Table
3580
3581 for Dim_Sys in 1 .. System_Table.Last loop
3582 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3583 return System_Table.Table (Dim_Sys);
3584 end if;
3585 end loop;
3586
3587 return Null_System;
3588 end System_Of;
3589
3590 end Sem_Dim;