OSDN Git Service

f90fa0ad34103306081633b0ed3673c15ef60129
[pf3gnuchains/gcc-fork.git] / gcc / ada / 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, 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 Lib;      use Lib;
31 with Namet;    use Namet;
32 with Nlists;   use Nlists;
33 with Nmake;    use Nmake;
34 with Opt;      use Opt;
35 with Rtsfind;  use Rtsfind;
36 with Sem;      use Sem;
37 with Sem_Eval; use Sem_Eval;
38 with Sem_Res;  use Sem_Res;
39 with Sem_Util; use Sem_Util;
40 with Sinfo;    use Sinfo;
41 with Snames;   use Snames;
42 with Stand;    use Stand;
43 with Stringt;  use Stringt;
44 with Table;
45 with Tbuild;   use Tbuild;
46 with Uintp;    use Uintp;
47 with Urealp;   use Urealp;
48
49 with GNAT.HTable;
50
51 package body Sem_Dim is
52
53    -------------------------
54    -- Rational arithmetic --
55    -------------------------
56
57    type Whole is new Int;
58    subtype Positive_Whole is Whole range 1 .. Whole'Last;
59
60    type Rational is record
61       Numerator   : Whole;
62       Denominator : Positive_Whole;
63    end record;
64
65    Zero : constant Rational := Rational'(Numerator =>   0,
66                                          Denominator => 1);
67
68    No_Rational : constant Rational := Rational'(Numerator =>   0,
69                                                 Denominator => 2);
70    --  Used to indicate an expression that cannot be interpreted as a rational
71    --  Returned value of the Create_Rational_From routine when parameter Expr
72    --  is not a static representation of a rational.
73
74    --  Rational constructors
75
76    function "+" (Right : Whole) return Rational;
77    function GCD (Left, Right : Whole) return Int;
78    function Reduce (X : Rational) return Rational;
79
80    --  Unary operator for Rational
81
82    function "-" (Right : Rational) return Rational;
83    function "abs" (Right : Rational) return Rational;
84
85    --  Rational operations for Rationals
86
87    function "+" (Left, Right : Rational) return Rational;
88    function "-" (Left, Right : Rational) return Rational;
89    function "*" (Left, Right : Rational) return Rational;
90    function "/" (Left, Right : Rational) return Rational;
91
92    ------------------
93    -- System types --
94    ------------------
95
96    Max_Number_Of_Dimensions : constant := 7;
97    --  Maximum number of dimensions in a dimension system
98
99    High_Position_Bound : constant := Max_Number_Of_Dimensions;
100    Invalid_Position    : constant := 0;
101    Low_Position_Bound  : constant := 1;
102
103    subtype Dimension_Position is
104      Nat range Invalid_Position .. High_Position_Bound;
105
106    type Name_Array is
107      array (Dimension_Position range
108               Low_Position_Bound .. High_Position_Bound) of Name_Id;
109    --  A data structure used to store the names of all units within a system
110
111    No_Names : constant Name_Array := (others => No_Name);
112
113    type Symbol_Array is
114      array (Dimension_Position range
115               Low_Position_Bound ..  High_Position_Bound) of String_Id;
116    --  A data structure used to store the symbols of all units within a system
117
118    No_Symbols : constant Symbol_Array := (others => No_String);
119
120    type System_Type is record
121       Type_Decl : Node_Id;
122       Names     : Name_Array;
123       Symbols   : Symbol_Array;
124       Count     : Dimension_Position;
125    end record;
126
127    Null_System : constant System_Type :=
128                    (Empty, No_Names, No_Symbols, Invalid_Position);
129
130    subtype System_Id is Nat;
131
132    --  The following table maps types to systems
133
134    package System_Table is new Table.Table (
135      Table_Component_Type => System_Type,
136      Table_Index_Type     => System_Id,
137      Table_Low_Bound      => 1,
138      Table_Initial        => 5,
139      Table_Increment      => 5,
140      Table_Name           => "System_Table");
141
142    --------------------
143    -- Dimension type --
144    --------------------
145
146    type Dimension_Type is
147      array (Dimension_Position range
148               Low_Position_Bound ..  High_Position_Bound) of Rational;
149
150    Null_Dimension : constant Dimension_Type := (others => Zero);
151
152    type Dimension_Table_Range is range 0 .. 510;
153    function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
154
155    --  The following table associates nodes with dimensions
156
157    package Dimension_Table is new
158      GNAT.HTable.Simple_HTable
159        (Header_Num => Dimension_Table_Range,
160         Element    => Dimension_Type,
161         No_Element => Null_Dimension,
162         Key        => Node_Id,
163         Hash       => Dimension_Table_Hash,
164         Equal      => "=");
165
166    ------------------
167    -- Symbol types --
168    ------------------
169
170    type Symbol_Table_Range is range 0 .. 510;
171    function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
172
173    --  Each subtype with a dimension has a symbolic representation of the
174    --  related unit. This table establishes a relation between the subtype
175    --  and the symbol.
176
177    package Symbol_Table is new
178      GNAT.HTable.Simple_HTable
179        (Header_Num => Symbol_Table_Range,
180         Element    => String_Id,
181         No_Element => No_String,
182         Key        => Entity_Id,
183         Hash       => Symbol_Table_Hash,
184         Equal      => "=");
185
186    --  The following array enumerates all contexts which may contain or
187    --  produce a dimension.
188
189    OK_For_Dimension : constant array (Node_Kind) of Boolean :=
190      (N_Attribute_Reference       => True,
191       N_Defining_Identifier       => True,
192       N_Function_Call             => True,
193       N_Identifier                => True,
194       N_Indexed_Component         => True,
195       N_Integer_Literal           => True,
196       N_Op_Abs                    => True,
197       N_Op_Add                    => True,
198       N_Op_Divide                 => True,
199       N_Op_Expon                  => True,
200       N_Op_Minus                  => True,
201       N_Op_Mod                    => True,
202       N_Op_Multiply               => True,
203       N_Op_Plus                   => True,
204       N_Op_Rem                    => True,
205       N_Op_Subtract               => True,
206       N_Qualified_Expression      => True,
207       N_Real_Literal              => True,
208       N_Selected_Component        => True,
209       N_Slice                     => True,
210       N_Type_Conversion           => True,
211       N_Unchecked_Type_Conversion => True,
212
213       others                      => False);
214
215    -----------------------
216    -- Local Subprograms --
217    -----------------------
218
219    procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
220    --  Subroutine of Analyze_Dimension for assignment statement. Check that the
221    --  dimensions of the left-hand side and the right-hand side of N match.
222
223    procedure Analyze_Dimension_Binary_Op (N : Node_Id);
224    --  Subroutine of Analyze_Dimension for binary operators. Check the
225    --  dimensions of the right and the left operand permit the operation.
226    --  Then, evaluate the resulting dimensions for each binary operator.
227
228    procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
229    --  Subroutine of Analyze_Dimension for component declaration. Check that
230    --  the dimensions of the type of N and of the expression match.
231
232    procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
233    --  Subroutine of Analyze_Dimension for extended return statement. Check
234    --  that the dimensions of the returned type and of the returned object
235    --  match.
236
237    procedure Analyze_Dimension_Function_Call (N : Node_Id);
238    --  Subroutine of Analyze_Dimension for function call. General case:
239    --  propagate the dimensions from the returned type to N. Elementary
240    --  function case (Ada.Numerics.Generic_Elementary_Functions): If N
241    --  is a Sqrt call, then evaluate the resulting dimensions as half the
242    --  dimensions of the parameter. Otherwise, verify that each parameters
243    --  are dimensionless.
244
245    procedure Analyze_Dimension_Has_Etype (N : Node_Id);
246    --  Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
247    --  the list below:
248    --    N_Attribute_Reference
249    --    N_Identifier
250    --    N_Indexed_Component
251    --    N_Qualified_Expression
252    --    N_Selected_Component
253    --    N_Slice
254    --    N_Type_Conversion
255    --    N_Unchecked_Type_Conversion
256
257    procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
258    --  Subroutine of Analyze_Dimension for object declaration. Check that
259    --  the dimensions of the object type and the dimensions of the expression
260    --  (if expression is present) match. Note that when the expression is
261    --  a literal, no warning is returned. This special case allows object
262    --  declaration such as: m : constant Length := 1.0;
263
264    procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
265    --  Subroutine of Analyze_Dimension for object renaming declaration. Check
266    --  the dimensions of the type and of the renamed object name of N match.
267
268    procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
269    --  Subroutine of Analyze_Dimension for simple return statement
270    --  Check that the dimensions of the returned type and of the returned
271    --  expression match.
272
273    procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
274    --  Subroutine of Analyze_Dimension for subtype declaration. Propagate the
275    --  dimensions from the parent type to the identifier of N. Note that if
276    --  both the identifier and the parent type of N are not dimensionless,
277    --  return an error message.
278
279    procedure Analyze_Dimension_Unary_Op (N : Node_Id);
280    --  Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
281    --  Abs operators, propagate the dimensions from the operand to N.
282
283    function Create_Rational_From
284      (Expr     : Node_Id;
285       Complain : Boolean) return Rational;
286    --  Given an arbitrary expression Expr, return a valid rational if Expr can
287    --  be interpreted as a rational. Otherwise return No_Rational and also an
288    --  error message if Complain is set to True.
289
290    function Dimensions_Of (N : Node_Id) return Dimension_Type;
291    --  Return the dimension vector of node N
292
293    function Dimensions_Msg_Of (N : Node_Id) return String;
294    --  Given a node, return "has dimension" followed by the dimension vector of
295    --  N or "is dimensionless" if N is dimensionless.
296
297    procedure Eval_Op_Expon_With_Rational_Exponent
298      (N              : Node_Id;
299       Exponent_Value : Rational);
300    --  Evaluate the exponent it is a rational and the operand has a dimension
301
302    function Exists (Dim : Dimension_Type) return Boolean;
303    --  Returns True iff Dim does not denote the null dimension
304
305    function Exists (Sys : System_Type) return Boolean;
306    --  Returns True iff Sys does not denote the null system
307
308    function From_Dimension_To_String_Of_Symbols
309      (Dims   : Dimension_Type;
310       System : System_Type) return String_Id;
311    --  Given a dimension vector and a dimension system, return the proper
312    --  string of symbols.
313
314    function Is_Invalid (Position : Dimension_Position) return Boolean;
315    --  Return True if Pos denotes the invalid position
316
317    procedure Move_Dimensions (From : Node_Id; To : Node_Id);
318    --  Copy dimension vector of From to To, delete dimension vector of From
319
320    procedure Remove_Dimensions (N : Node_Id);
321    --  Remove the dimension vector of node N
322
323    procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
324    --  Associate a dimension vector with a node
325
326    procedure Set_Symbol (E : Entity_Id; Val : String_Id);
327    --  Associate a symbol representation of a dimension vector with a subtype
328
329    function Symbol_Of (E : Entity_Id) return String_Id;
330    --  E denotes a subtype with a dimension. Return the symbol representation
331    --  of the dimension vector.
332
333    function System_Of (E : Entity_Id) return System_Type;
334    --  E denotes a type, return associated system of the type if it has one
335
336    ---------
337    -- "+" --
338    ---------
339
340    function "+" (Right : Whole) return Rational is
341    begin
342       return Rational'(Numerator =>   Right,
343                        Denominator => 1);
344    end "+";
345
346    function "+" (Left, Right : Rational) return Rational is
347       R : constant Rational :=
348             Rational'(Numerator =>   Left.Numerator * Right.Denominator +
349                                        Left.Denominator * Right.Numerator,
350                       Denominator => Left.Denominator * Right.Denominator);
351    begin
352       return Reduce (R);
353    end "+";
354
355    ---------
356    -- "-" --
357    ---------
358
359    function "-" (Right : Rational) return Rational is
360    begin
361       return Rational'(Numerator =>   -Right.Numerator,
362                        Denominator => Right.Denominator);
363    end "-";
364
365    function "-" (Left, Right : Rational) return Rational is
366       R : constant Rational :=
367             Rational'(Numerator =>   Left.Numerator * Right.Denominator -
368                                        Left.Denominator * Right.Numerator,
369                       Denominator => Left.Denominator * Right.Denominator);
370
371    begin
372       return Reduce (R);
373    end "-";
374
375    ---------
376    -- "*" --
377    ---------
378
379    function "*" (Left, Right : Rational) return Rational is
380       R : constant Rational :=
381             Rational'(Numerator =>   Left.Numerator * Right.Numerator,
382                       Denominator => Left.Denominator * Right.Denominator);
383    begin
384       return Reduce (R);
385    end "*";
386
387    ---------
388    -- "/" --
389    ---------
390
391    function "/" (Left, Right : Rational) return Rational is
392       R : constant Rational := abs Right;
393       L : Rational := Left;
394
395    begin
396       if Right.Numerator < 0 then
397          L.Numerator := Whole (-Integer (L.Numerator));
398       end if;
399
400       return Reduce (Rational'(Numerator =>   L.Numerator * R.Denominator,
401                                Denominator => L.Denominator * R.Numerator));
402    end "/";
403    -----------
404    -- "abs" --
405    -----------
406
407    function "abs" (Right : Rational) return Rational is
408    begin
409       return Rational'(Numerator =>   abs Right.Numerator,
410                        Denominator => Right.Denominator);
411    end "abs";
412
413    ------------------------------
414    -- Analyze_Aspect_Dimension --
415    ------------------------------
416
417    --  with Dimension => DIMENSION_FOR_SUBTYPE
418    --  DIMENSION_FOR_SUBTYPE ::= (DIMENSION_STRING, DIMENSION_RATIONALS)
419    --  DIMENSION_RATIONALS ::=
420    --    RATIONAL,  {, RATIONAL}
421    --  | RATIONAL {, RATIONAL}, others => RATIONAL
422    --  | DISCRETE_CHOICE_LIST => RATIONAL
423    --  RATIONAL ::= [-] NUMERAL [/ NUMERAL]
424
425    --  (see Analyze_Aspect_Dimension_System for DIMENSION_STRING grammar)
426
427    procedure Analyze_Aspect_Dimension
428      (N    : Node_Id;
429       Id   : Entity_Id;
430       Aggr : Node_Id)
431    is
432       Def_Id    : constant Entity_Id := Defining_Identifier (N);
433
434       Processed : array (Dimension_Type'Range) of Boolean := (others => False);
435       --  This array is used when processing ranges or Others_Choice as part of
436       --  the dimension aggregate.
437
438       Dimensions : Dimension_Type := Null_Dimension;
439
440       procedure Extract_Power
441         (Expr     : Node_Id;
442          Position : Dimension_Position);
443       --  Given an expression with denotes a rational number, read the number
444       --  and associate it with Position in Dimensions.
445
446       function Has_Compile_Time_Known_Expressions
447         (Aggr : Node_Id) return Boolean;
448       --  Determine whether aggregate Aggr contains only expressions that are
449       --  known at compile time.
450
451       function Position_In_System
452         (Id     : Node_Id;
453          System : System_Type) return Dimension_Position;
454       --  Given an identifier which denotes a dimension, return the position of
455       --  that dimension within System.
456
457       -------------------
458       -- Extract_Power --
459       -------------------
460
461       procedure Extract_Power
462         (Expr     : Node_Id;
463          Position : Dimension_Position)
464       is
465       begin
466          if Is_Integer_Type (Def_Id) then
467             Dimensions (Position) := +Whole (UI_To_Int (Expr_Value (Expr)));
468          else
469             Dimensions (Position) := Create_Rational_From (Expr, True);
470          end if;
471
472          Processed (Position) := True;
473       end Extract_Power;
474
475       ----------------------------------------
476       -- Has_Compile_Time_Known_Expressions --
477       ----------------------------------------
478
479       function Has_Compile_Time_Known_Expressions
480         (Aggr : Node_Id) return Boolean
481       is
482          Comp : Node_Id;
483          Expr : Node_Id;
484
485       begin
486          Expr := First (Expressions (Aggr));
487          if Present (Expr) then
488
489             --  The first expression within the aggregate describes the
490             --  symbolic name of a dimension, skip it.
491
492             Next (Expr);
493             while Present (Expr) loop
494                Analyze_And_Resolve (Expr);
495
496                if not Compile_Time_Known_Value (Expr) then
497                   return False;
498                end if;
499
500                Next (Expr);
501             end loop;
502          end if;
503
504          Comp := First (Component_Associations (Aggr));
505          while Present (Comp) loop
506             Expr := Expression (Comp);
507
508             Analyze_And_Resolve (Expr);
509
510             if not Compile_Time_Known_Value (Expr) then
511                return False;
512             end if;
513
514             Next (Comp);
515          end loop;
516
517          return True;
518       end Has_Compile_Time_Known_Expressions;
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.Names'Range loop
532             if Dimension_Name = System.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;
551       Symbol_Decl    : 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 names and values in the aggregate
558       --  (Step 3).
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       if Nkind (Aggr) /= N_Aggregate then
586          Error_Msg_N ("aggregate expected", Aggr);
587          return;
588       end if;
589
590       --  Each expression in dimension aggregate must be known at compile time
591
592       if not Has_Compile_Time_Known_Expressions (Aggr) then
593          Error_Msg_N ("values of aggregate must be static", Aggr);
594          return;
595       end if;
596
597       --  The dimension declarations are useless if the parent type does not
598       --  declare a valid system.
599
600       if not Exists (System) then
601          Error_Msg_NE
602            ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
603          return;
604       end if;
605
606       --  STEP 2: Structural verification of the dimension aggregate
607
608       --  The first entry in the aggregate is the symbolic representation of
609       --  the dimension.
610
611       Symbol_Decl := First (Expressions (Aggr));
612
613       if No (Symbol_Decl)
614         or else not Nkind_In (Symbol_Decl, N_Character_Literal,
615                                            N_String_Literal)
616       then
617          Error_Msg_N ("first argument must be character or string", Aggr);
618          return;
619       end if;
620
621       --  STEP 3: Name and value extraction
622
623       --  Get the number of errors detected by the compiler so far
624
625       Errors_Count := Serious_Errors_Detected;
626
627       --  Positional elements
628
629       Expr := Next (Symbol_Decl);
630       Position := Low_Position_Bound;
631       while Present (Expr) loop
632          if Position > High_Position_Bound then
633             Error_Msg_N
634               ("type& has more dimensions than system allows", Def_Id);
635             exit;
636          end if;
637
638          Extract_Power (Expr, Position);
639
640          Position := Position + 1;
641          Num_Dimensions := Num_Dimensions + 1;
642
643          Next (Expr);
644       end loop;
645
646       --  Named elements
647
648       Assoc := First (Component_Associations (Aggr));
649       while Present (Assoc) loop
650          Expr   := Expression (Assoc);
651          Choice := First (Choices (Assoc));
652          while Present (Choice) loop
653
654             --  Identifier case: NAME => EXPRESSION
655
656             if Nkind (Choice) = N_Identifier then
657                Position := Position_In_System (Choice, System);
658
659                if Is_Invalid (Position) then
660                   Error_Msg_N ("dimension name& not part of system", Choice);
661                else
662                   Extract_Power (Expr, Position);
663                end if;
664
665             --  Range case: NAME .. NAME => EXPRESSION
666
667             elsif Nkind (Choice) = N_Range then
668                declare
669                   Low      : constant Node_Id := Low_Bound (Choice);
670                   High     : constant Node_Id := High_Bound (Choice);
671                   Low_Pos  : Dimension_Position;
672                   High_Pos : Dimension_Position;
673
674                begin
675                   if Nkind (Low) /= N_Identifier then
676                      Error_Msg_N ("bound must denote a dimension name", Low);
677
678                   elsif Nkind (High) /= N_Identifier then
679                      Error_Msg_N ("bound must denote a dimension name", High);
680
681                   else
682                      Low_Pos  := Position_In_System (Low, System);
683                      High_Pos := Position_In_System (High, System);
684
685                      if Is_Invalid (Low_Pos) then
686                         Error_Msg_N ("dimension name& not part of system",
687                                      Low);
688
689                      elsif Is_Invalid (High_Pos) then
690                         Error_Msg_N ("dimension name& not part of system",
691                                      High);
692
693                      elsif Low_Pos > High_Pos then
694                         Error_Msg_N ("expected low to high range", Choice);
695
696                      else
697                         for Position in Low_Pos .. High_Pos loop
698                            Extract_Power (Expr, Position);
699                         end loop;
700                      end if;
701                   end if;
702                end;
703
704             --  Others case: OTHERS => EXPRESSION
705
706             elsif Nkind (Choice) = N_Others_Choice then
707                if Present (Next (Choice))
708                  or else Present (Prev (Choice))
709                then
710                   Error_Msg_N
711                     ("OTHERS must appear alone in a choice list", Choice);
712
713                elsif Present (Next (Assoc)) then
714                   Error_Msg_N
715                     ("OTHERS must appear last in an aggregate", Choice);
716
717                elsif Others_Seen then
718                   Error_Msg_N ("multiple OTHERS not allowed", Choice);
719
720                else
721                   --  Fill the non-processed dimensions with the default value
722                   --  supplied by others.
723
724                   for Position in Processed'Range loop
725                      if not Processed (Position) then
726                         Extract_Power (Expr, Position);
727                      end if;
728                   end loop;
729                end if;
730
731                Others_Seen := True;
732
733             --  All other cases are erroneous declarations of dimension names
734
735             else
736                Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
737             end if;
738
739             Num_Choices := Num_Choices + 1;
740             Next (Choice);
741          end loop;
742
743          Num_Dimensions := Num_Dimensions + 1;
744          Next (Assoc);
745       end loop;
746
747       --  STEP 4: Consistency of system and dimensions
748
749       if Present (Next (Symbol_Decl))
750         and then (Num_Choices > 1
751                    or else (Num_Choices = 1 and then not Others_Seen))
752       then
753          Error_Msg_N
754            ("named associations cannot follow positional associations", Aggr);
755
756       elsif Num_Dimensions > System.Count then
757          Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
758
759       elsif Num_Dimensions < System.Count and then not Others_Seen then
760          Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
761       end if;
762
763       --  STEP 5: Dimension symbol extraction
764
765       if Nkind (Symbol_Decl) = N_Character_Literal then
766          Start_String;
767          Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Decl)));
768          Symbol := End_String;
769
770       else
771          Symbol := Strval (Symbol_Decl);
772       end if;
773
774       if String_Length (Symbol) = 0 and then not Exists (Dimensions) then
775          Error_Msg_N ("useless dimension declaration", Aggr);
776       end if;
777
778       --  STEP 6: Storage of extracted values
779
780       --  Check that no errors have been detected during the analysis
781
782       if Errors_Count = Serious_Errors_Detected then
783          if String_Length (Symbol) /= 0 then
784             Set_Symbol (Def_Id, Symbol);
785          end if;
786
787          if Exists (Dimensions) then
788             Set_Dimensions (Def_Id, Dimensions);
789          end if;
790       end if;
791    end Analyze_Aspect_Dimension;
792
793    -------------------------------------
794    -- Analyze_Aspect_Dimension_System --
795    -------------------------------------
796
797    --  with Dimension_System => DIMENSION_PAIRS
798
799    --  DIMENSION_PAIRS ::=
800    --    (DIMENSION_PAIR
801    --      [, DIMENSION_PAIR]
802    --      [, DIMENSION_PAIR]
803    --      [, DIMENSION_PAIR]
804    --      [, DIMENSION_PAIR]
805    --      [, DIMENSION_PAIR]
806    --      [, DIMENSION_PAIR])
807    --  DIMENSION_PAIR ::= (DIMENSION_IDENTIFIER, DIMENSION_STRING)
808    --  DIMENSION_IDENTIFIER ::= IDENTIFIER
809    --  DIMENSION_STRING ::= STRING_LITERAL | CHARACTER_LITERAL
810
811    procedure Analyze_Aspect_Dimension_System
812      (N    : Node_Id;
813       Id   : Entity_Id;
814       Aggr : Node_Id)
815    is
816       function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
817       --  Determine whether type declaration N denotes a numeric derived type
818
819       -------------------------------
820       -- Is_Derived_Numeric_Type --
821       -------------------------------
822
823       function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
824       begin
825          return
826            Nkind (N) = N_Full_Type_Declaration
827              and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
828              and then Is_Numeric_Type
829                         (Entity (Subtype_Indication (Type_Definition (N))));
830       end Is_Derived_Numeric_Type;
831
832       --  Local variables
833
834       Dim_Name     : Node_Id;
835       Dim_Pair     : Node_Id;
836       Dim_Symbol   : Node_Id;
837       Dim_System   : System_Type  := Null_System;
838       Names        : Name_Array   := No_Names;
839       Position     : Nat := 0;
840       Symbols      : Symbol_Array := No_Symbols;
841
842       Errors_Count : Nat;
843       --  Errors_Count is a count of errors detected by the compiler so far
844       --  just before the extraction of names and symbols in the aggregate
845       --  (Step 3).
846       --
847       --  At the end of the analysis, there is a check to verify that this
848       --  count equals Serious_Errors_Detected i.e. no errors have been
849       --  encountered during the process. Otherwise the System_Table is
850       --  not filled.
851
852    --  Start of processing for Analyze_Aspect_Dimension_System
853
854    begin
855       --  STEP 1: Legality of aspect
856
857       if not Is_Derived_Numeric_Type (N) then
858          Error_Msg_NE
859            ("aspect& must apply to numeric derived type declaration", N, Id);
860          return;
861       end if;
862
863       if Nkind (Aggr) /= N_Aggregate then
864          Error_Msg_N ("aggregate expected", Aggr);
865          return;
866       end if;
867
868       --  STEP 2: Structural verification of the dimension aggregate
869
870       if Present (Component_Associations (Aggr)) then
871          Error_Msg_N ("expected positional aggregate", Aggr);
872          return;
873       end if;
874
875       --  STEP 3: Name and Symbol extraction
876
877       Dim_Pair     := First (Expressions (Aggr));
878       Errors_Count := Serious_Errors_Detected;
879       while Present (Dim_Pair) loop
880          Position := Position + 1;
881
882          if Position > High_Position_Bound then
883             Error_Msg_N
884               ("too many dimensions in system", Aggr);
885             exit;
886          end if;
887
888          if Nkind (Dim_Pair) /= N_Aggregate then
889             Error_Msg_N ("aggregate expected", Dim_Pair);
890
891          else
892             if Present (Component_Associations (Dim_Pair)) then
893                Error_Msg_N ("expected positional aggregate", Dim_Pair);
894
895             else
896                if List_Length (Expressions (Dim_Pair)) = 2 then
897                   Dim_Name := First (Expressions (Dim_Pair));
898                   Dim_Symbol := Next (Dim_Name);
899
900                   --  Check the first argument for each pair is a name
901
902                   if Nkind (Dim_Name) = N_Identifier then
903                      Names (Position) := Chars (Dim_Name);
904                   else
905                      Error_Msg_N ("expected dimension name", Dim_Name);
906                   end if;
907
908                   --  Check the second argument for each pair is a string or a
909                   --  character.
910
911                   if not Nkind_In
912                            (Dim_Symbol,
913                               N_String_Literal,
914                               N_Character_Literal)
915                   then
916                      Error_Msg_N ("expected dimension string or character",
917                                   Dim_Symbol);
918
919                   else
920                      --  String case
921
922                      if Nkind (Dim_Symbol) = N_String_Literal then
923                         Symbols (Position) := Strval (Dim_Symbol);
924
925                      --  Character case
926
927                      else
928                         Start_String;
929                         Store_String_Char
930                           (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
931                         Symbols (Position) := End_String;
932                      end if;
933
934                      --  Verify that the string is not empty
935
936                      if String_Length (Symbols (Position)) = 0 then
937                         Error_Msg_N
938                           ("empty string not allowed here", Dim_Symbol);
939                      end if;
940                   end if;
941
942                else
943                   Error_Msg_N
944                     ("two expressions expected in aggregate", Dim_Pair);
945                end if;
946             end if;
947          end if;
948
949          Next (Dim_Pair);
950       end loop;
951
952       --  STEP 4: Storage of extracted values
953
954       --  Check that no errors have been detected during the analysis
955
956       if Errors_Count = Serious_Errors_Detected then
957          Dim_System.Type_Decl := N;
958          Dim_System.Names := Names;
959          Dim_System.Count := Position;
960          Dim_System.Symbols := Symbols;
961          System_Table.Append (Dim_System);
962       end if;
963    end Analyze_Aspect_Dimension_System;
964
965    -----------------------
966    -- Analyze_Dimension --
967    -----------------------
968
969    --  This dispatch routine propagates dimensions for each node
970
971    procedure Analyze_Dimension (N : Node_Id) is
972    begin
973       --  Aspect is an Ada 2012 feature
974
975       if Ada_Version < Ada_2012 then
976          return;
977       end if;
978
979       case Nkind (N) is
980
981          when N_Assignment_Statement =>
982             Analyze_Dimension_Assignment_Statement (N);
983
984          when N_Binary_Op =>
985             Analyze_Dimension_Binary_Op (N);
986
987          when N_Component_Declaration =>
988             Analyze_Dimension_Component_Declaration (N);
989
990          when N_Extended_Return_Statement =>
991             Analyze_Dimension_Extended_Return_Statement (N);
992
993          when N_Function_Call =>
994             Analyze_Dimension_Function_Call (N);
995
996          when N_Attribute_Reference       |
997               N_Identifier                |
998               N_Indexed_Component         |
999               N_Qualified_Expression      |
1000               N_Selected_Component        |
1001               N_Slice                     |
1002               N_Type_Conversion           |
1003               N_Unchecked_Type_Conversion =>
1004             Analyze_Dimension_Has_Etype (N);
1005
1006          when N_Object_Declaration =>
1007             Analyze_Dimension_Object_Declaration (N);
1008
1009          when N_Object_Renaming_Declaration =>
1010             Analyze_Dimension_Object_Renaming_Declaration (N);
1011
1012          when N_Simple_Return_Statement =>
1013             if not Comes_From_Extended_Return_Statement (N) then
1014                Analyze_Dimension_Simple_Return_Statement (N);
1015             end if;
1016
1017          when N_Subtype_Declaration =>
1018             Analyze_Dimension_Subtype_Declaration (N);
1019
1020          when N_Unary_Op =>
1021             Analyze_Dimension_Unary_Op (N);
1022
1023          when others => null;
1024
1025       end case;
1026    end Analyze_Dimension;
1027
1028    --------------------------------------------
1029    -- Analyze_Dimension_Assignment_Statement --
1030    --------------------------------------------
1031
1032    procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1033       Lhs         : constant Node_Id := Name (N);
1034       Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1035       Rhs         : constant Node_Id := Expression (N);
1036       Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1037
1038       procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id);
1039       --  Error using Error_Msg_N at node N. Output in the error message the
1040       --  dimensions of left and right hand sides.
1041
1042       ----------------------------------------
1043       -- Error_Dim_For_Assignment_Statement --
1044       ----------------------------------------
1045
1046       procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id) is
1047       begin
1048          Error_Msg_N ("?dimensions mismatch in assignment", N);
1049          Error_Msg_N ("?left-hand side " & Dimensions_Msg_Of (Lhs), N);
1050          Error_Msg_N ("?right-hand side " & Dimensions_Msg_Of (Rhs), N);
1051       end Error_Dim_For_Assignment_Statement;
1052
1053    --  Start of processing for Analyze_Dimension_Assignment
1054
1055    begin
1056       if Dims_Of_Lhs /= Dims_Of_Rhs then
1057          Error_Dim_For_Assignment_Statement (N, Lhs, Rhs);
1058       end if;
1059    end Analyze_Dimension_Assignment_Statement;
1060
1061    ---------------------------------
1062    -- Analyze_Dimension_Binary_Op --
1063    ---------------------------------
1064
1065    --  Check and propagate the dimensions for binary operators
1066    --  Note that when the dimensions mismatch, no dimension is propagated to N.
1067
1068    procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1069       N_Kind : constant Node_Kind := Nkind (N);
1070
1071       procedure Error_Dim_For_Binary_Op (N, L, R : Node_Id);
1072       --  Error using Error_Msg_N at node N
1073       --  Output in the error message the dimensions of both operands.
1074
1075       -----------------------------
1076       -- Error_Dim_For_Binary_Op --
1077       -----------------------------
1078
1079       procedure Error_Dim_For_Binary_Op (N, L, R : Node_Id) is
1080       begin
1081          Error_Msg_NE ("?both operands for operation& must have same " &
1082                        "dimensions",
1083                        N,
1084                        Entity (N));
1085          Error_Msg_N ("?left operand " & Dimensions_Msg_Of (L), N);
1086          Error_Msg_N ("?right operand " & Dimensions_Msg_Of (R), N);
1087       end Error_Dim_For_Binary_Op;
1088
1089    --  Start of processing for Analyze_Dimension_Binary_Op
1090
1091    begin
1092       if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1093         or else N_Kind in N_Multiplying_Operator
1094         or else N_Kind in N_Op_Compare
1095       then
1096          declare
1097             L                : constant Node_Id := Left_Opnd (N);
1098             Dims_Of_L        : constant Dimension_Type := Dimensions_Of (L);
1099             L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1100             R                : constant Node_Id := Right_Opnd (N);
1101             Dims_Of_R        : constant Dimension_Type := Dimensions_Of (R);
1102             R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1103             Dims_Of_N        : Dimension_Type := Null_Dimension;
1104
1105          begin
1106             --  N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1107
1108             if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1109
1110                --  Check both operands have same dimension
1111
1112                if Dims_Of_L /= Dims_Of_R then
1113                   Error_Dim_For_Binary_Op (N, L, R);
1114                else
1115                   --  Check both operands are not dimensionless
1116
1117                   if Exists (Dims_Of_L) then
1118                      Set_Dimensions (N, Dims_Of_L);
1119                   end if;
1120                end if;
1121
1122             --  N_Op_Multiply or N_Op_Divide case
1123
1124             elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1125
1126                --  Check at least one operand is not dimensionless
1127
1128                if L_Has_Dimensions or R_Has_Dimensions then
1129
1130                   --  Multiplication case
1131
1132                   --  Get both operands dimensions and add them
1133
1134                   if N_Kind = N_Op_Multiply then
1135                      for Position in Dimension_Type'Range loop
1136                         Dims_Of_N (Position) :=
1137                           Dims_Of_L (Position) + Dims_Of_R (Position);
1138                      end loop;
1139
1140                   --  Division case
1141
1142                   --  Get both operands dimensions and subtract them
1143
1144                   else
1145                      for Position in Dimension_Type'Range loop
1146                         Dims_Of_N (Position) :=
1147                           Dims_Of_L (Position) - Dims_Of_R (Position);
1148                      end loop;
1149                   end if;
1150
1151                   if Exists (Dims_Of_N) then
1152                      Set_Dimensions (N, Dims_Of_N);
1153                   end if;
1154                end if;
1155
1156             --  Exponentiation case
1157
1158             --  Note: a rational exponent is allowed for dimensioned operand
1159
1160             elsif N_Kind = N_Op_Expon then
1161
1162                --  Check the left operand is not dimensionless. Note that the
1163                --  value of the exponent must be known compile time. Otherwise,
1164                --  the exponentiation evaluation will return an error message.
1165
1166                if L_Has_Dimensions
1167                  and then Compile_Time_Known_Value (R)
1168                then
1169                   declare
1170                      Exponent_Value : Rational := Zero;
1171
1172                   begin
1173                      --  Real operand case
1174
1175                      if Is_Real_Type (Etype (L)) then
1176
1177                         --  Define the exponent as a Rational number
1178
1179                         Exponent_Value := Create_Rational_From (R, False);
1180
1181                         --  Verify that the exponent cannot be interpreted
1182                         --  as a rational, otherwise interpret the exponent
1183                         --  as an integer.
1184
1185                         if Exponent_Value = No_Rational then
1186                            Exponent_Value :=
1187                              +Whole (UI_To_Int (Expr_Value (R)));
1188                         end if;
1189
1190                      --  Integer operand case.
1191
1192                      --  For integer operand, the exponent cannot be
1193                      --  interpreted as a rational.
1194
1195                      else
1196                         Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1197                      end if;
1198
1199                      for Position in Dimension_Type'Range loop
1200                         Dims_Of_N (Position) :=
1201                           Dims_Of_L (Position) * Exponent_Value;
1202                      end loop;
1203
1204                      if Exists (Dims_Of_N) then
1205                         Set_Dimensions (N, Dims_Of_N);
1206                      end if;
1207                   end;
1208                end if;
1209
1210             --  Comparison cases
1211
1212             --  For relational operations, only dimension checking is
1213             --  performed (no propagation).
1214
1215             elsif N_Kind in N_Op_Compare then
1216                if (L_Has_Dimensions or R_Has_Dimensions)
1217                  and then Dims_Of_L /= Dims_Of_R
1218                then
1219                   Error_Dim_For_Binary_Op (N, L, R);
1220                end if;
1221             end if;
1222
1223             --  Removal of dimensions for each operands
1224
1225             Remove_Dimensions (L);
1226             Remove_Dimensions (R);
1227          end;
1228       end if;
1229    end Analyze_Dimension_Binary_Op;
1230
1231    ---------------------------------------------
1232    -- Analyze_Dimension_Component_Declaration --
1233    ---------------------------------------------
1234
1235    procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1236       Expr         : constant Node_Id        := Expression (N);
1237       Id           : constant Entity_Id      := Defining_Identifier (N);
1238       Etyp         : constant Entity_Id      := Etype (Id);
1239       Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1240       Dims_Of_Expr : Dimension_Type;
1241
1242       procedure Error_Dim_For_Component_Declaration
1243         (N    : Node_Id;
1244          Etyp : Entity_Id;
1245          Expr : Node_Id);
1246       --  Error using Error_Msg_N at node N. Output in the error message the
1247       --  dimensions of the type Etyp and the expression Expr of N.
1248
1249       -----------------------------------------
1250       -- Error_Dim_For_Component_Declaration --
1251       -----------------------------------------
1252
1253       procedure Error_Dim_For_Component_Declaration
1254         (N    : Node_Id;
1255          Etyp : Entity_Id;
1256          Expr : Node_Id) is
1257       begin
1258          Error_Msg_N ("?dimensions mismatch in component declaration", N);
1259          Error_Msg_N ("\?component type " & Dimensions_Msg_Of (Etyp), N);
1260          Error_Msg_N ("\?component expression " & Dimensions_Msg_Of (Expr), N);
1261       end Error_Dim_For_Component_Declaration;
1262
1263    --  Start of processing for Analyze_Dimension_Component_Declaration
1264
1265    begin
1266       if Present (Expr) then
1267          Dims_Of_Expr := Dimensions_Of (Expr);
1268
1269          --  Return an error if the dimension of the expression and the
1270          --  dimension of the type mismatch.
1271
1272          if Dims_Of_Etyp /= Dims_Of_Expr then
1273             Error_Dim_For_Component_Declaration (N, Etyp, Expr);
1274          end if;
1275
1276          --  Removal of dimensions in expression
1277
1278          Remove_Dimensions (Expr);
1279       end if;
1280    end Analyze_Dimension_Component_Declaration;
1281
1282    -------------------------------------------------
1283    -- Analyze_Dimension_Extended_Return_Statement --
1284    -------------------------------------------------
1285
1286    procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1287       Return_Ent            : constant Entity_Id :=
1288                                 Return_Statement_Entity (N);
1289       Return_Etyp           : constant Entity_Id :=
1290                                 Etype (Return_Applies_To (Return_Ent));
1291       Dims_Of_Return_Etyp   : constant Dimension_Type :=
1292                                 Dimensions_Of (Return_Etyp);
1293       Return_Obj_Decls      : constant List_Id :=
1294                                 Return_Object_Declarations (N);
1295       Dims_Of_Return_Obj_Id : Dimension_Type;
1296       Return_Obj_Decl       : Node_Id;
1297       Return_Obj_Id         : Entity_Id;
1298
1299       procedure Error_Dim_For_Extended_Return_Statement
1300         (N             : Node_Id;
1301          Return_Etyp   : Entity_Id;
1302          Return_Obj_Id : Entity_Id);
1303       --  Warning using Error_Msg_N at node N. Output in the error message the
1304       --  dimensions of the returned type Return_Etyp and the returned object
1305       --  Return_Obj_Id of N.
1306
1307       ---------------------------------------------
1308       -- Error_Dim_For_Extended_Return_Statement --
1309       ---------------------------------------------
1310
1311       procedure Error_Dim_For_Extended_Return_Statement
1312         (N             : Node_Id;
1313          Return_Etyp   : Entity_Id;
1314          Return_Obj_Id : Entity_Id)
1315       is
1316       begin
1317          Error_Msg_N ("?dimensions mismatch in extended return statement", N);
1318          Error_Msg_N ("?returned type " & Dimensions_Msg_Of (Return_Etyp), N);
1319          Error_Msg_N ("?returned object " & Dimensions_Msg_Of (Return_Obj_Id),
1320                       N);
1321       end Error_Dim_For_Extended_Return_Statement;
1322
1323    --  Start of processing for Analyze_Dimension_Extended_Return_Statement
1324    begin
1325       if Present (Return_Obj_Decls) then
1326          Return_Obj_Decl := First (Return_Obj_Decls);
1327          while Present (Return_Obj_Decl) loop
1328             if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1329                Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1330
1331                if Is_Return_Object (Return_Obj_Id) then
1332                   Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
1333
1334                   if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
1335                      Error_Dim_For_Extended_Return_Statement
1336                        (N, Return_Etyp, Return_Obj_Id);
1337                      return;
1338                   end if;
1339                end if;
1340             end if;
1341
1342             Next (Return_Obj_Decl);
1343          end loop;
1344       end if;
1345    end Analyze_Dimension_Extended_Return_Statement;
1346
1347    -------------------------------------
1348    -- Analyze_Dimension_Function_Call --
1349    -------------------------------------
1350
1351    procedure Analyze_Dimension_Function_Call (N : Node_Id) is
1352       Name_Call      : constant Node_Id := Name (N);
1353       Actuals        : constant List_Id := Parameter_Associations (N);
1354       Actual         : Node_Id;
1355       Dims_Of_Actual : Dimension_Type;
1356       Dims_Of_Call   : Dimension_Type;
1357
1358       function Is_Elementary_Function_Call (N : Node_Id) return Boolean;
1359       --  Return True if the call is a call of an elementary function (see
1360       --  Ada.Numerics.Generic_Elementary_Functions).
1361
1362       ---------------------------------
1363       -- Is_Elementary_Function_Call --
1364       ---------------------------------
1365
1366       function Is_Elementary_Function_Call (N : Node_Id) return Boolean is
1367          Ent : Entity_Id;
1368
1369       begin
1370          --  Note that the node must come from source (why not???)
1371
1372          if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then
1373             Ent := Entity (Name_Call);
1374
1375             --  Check the procedure is defined in an instantiation of a generic
1376             --  package.
1377
1378             if Is_Generic_Instance (Scope (Ent)) then
1379                Ent := Cunit_Entity (Get_Source_Unit (Ent));
1380
1381                --  Check the name of the generic package is
1382                --  Generic_Elementary_Functions
1383
1384                return
1385                  Is_Library_Level_Entity (Ent)
1386                    and then Chars (Ent) = Name_Generic_Elementary_Functions;
1387             end if;
1388          end if;
1389
1390          return False;
1391       end Is_Elementary_Function_Call;
1392
1393    --  Start of processing for Analyze_Dimension_Function_Call
1394
1395    begin
1396       --  Elementary function case
1397
1398       if Is_Elementary_Function_Call (N) then
1399
1400          --  Sqrt function call case
1401
1402          if Chars (Name_Call) = Name_Sqrt then
1403             Dims_Of_Call := Dimensions_Of (First (Actuals));
1404
1405             if Exists (Dims_Of_Call) then
1406                for Position in Dims_Of_Call'Range loop
1407                   Dims_Of_Call (Position) :=
1408                     Dims_Of_Call (Position) * Rational'(Numerator =>   1,
1409                                                         Denominator => 2);
1410                end loop;
1411
1412                Set_Dimensions (N, Dims_Of_Call);
1413             end if;
1414
1415          --  All other functions in Ada.Numerics.Generic_Elementary_Functions
1416          --  case. Note that all parameters here should be dimensionless.
1417
1418          else
1419             Actual := First (Actuals);
1420             while Present (Actual) loop
1421                Dims_Of_Actual := Dimensions_Of (Actual);
1422
1423                if Exists (Dims_Of_Actual) then
1424                   Error_Msg_NE
1425                     ("?parameter should be dimensionless for elementary "
1426                      & "function&", Actual, Name_Call);
1427                   Error_Msg_N
1428                     ("?parameter " & Dimensions_Msg_Of (Actual), Actual);
1429                end if;
1430
1431                Next (Actual);
1432             end loop;
1433          end if;
1434
1435       --  Other case
1436
1437       else
1438          Analyze_Dimension_Has_Etype (N);
1439       end if;
1440    end Analyze_Dimension_Function_Call;
1441
1442    ---------------------------------
1443    -- Analyze_Dimension_Has_Etype --
1444    ---------------------------------
1445
1446    procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
1447       Etyp         : constant Entity_Id := Etype (N);
1448       Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1449       N_Kind       : constant Node_Kind := Nkind (N);
1450
1451    begin
1452       --  Propagation of the dimensions from the type
1453
1454       if Exists (Dims_Of_Etyp) then
1455          Set_Dimensions (N, Dims_Of_Etyp);
1456       end if;
1457
1458       --  Removal of dimensions in expression
1459
1460       --  Wouldn't a case statement be clearer here???
1461
1462       if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then
1463          declare
1464             Expr  : Node_Id;
1465             Exprs : constant List_Id := Expressions (N);
1466          begin
1467             if Present (Exprs) then
1468                Expr := First (Exprs);
1469                while Present (Expr) loop
1470                   Remove_Dimensions (Expr);
1471                   Next (Expr);
1472                end loop;
1473             end if;
1474          end;
1475
1476       elsif Nkind_In (N_Kind, N_Qualified_Expression,
1477                               N_Type_Conversion,
1478                               N_Unchecked_Type_Conversion)
1479       then
1480          Remove_Dimensions (Expression (N));
1481
1482       elsif N_Kind = N_Selected_Component then
1483          Remove_Dimensions (Selector_Name (N));
1484       end if;
1485    end Analyze_Dimension_Has_Etype;
1486
1487    ------------------------------------------
1488    -- Analyze_Dimension_Object_Declaration --
1489    ------------------------------------------
1490
1491    procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
1492       Expr        : constant Node_Id   := Expression (N);
1493       Id          : constant Entity_Id := Defining_Identifier (N);
1494       Etyp        : constant Entity_Id := Etype (Id);
1495       Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1496       Dim_Of_Expr : Dimension_Type;
1497
1498       procedure Error_Dim_For_Object_Declaration
1499         (N    : Node_Id;
1500          Etyp : Entity_Id;
1501          Expr : Node_Id);
1502       --  Warnings using Error_Msg_N at node N. Output in the error message the
1503       --  dimensions of the type Etyp and the ???
1504
1505       --------------------------------------
1506       -- Error_Dim_For_Object_Declaration --
1507       --------------------------------------
1508
1509       procedure Error_Dim_For_Object_Declaration
1510         (N    : Node_Id;
1511          Etyp : Entity_Id;
1512          Expr : Node_Id) is
1513       begin
1514          Error_Msg_N ("?dimensions mismatch in object declaration", N);
1515          Error_Msg_N ("\?object type " & Dimensions_Msg_Of (Etyp), N);
1516          Error_Msg_N ("\?object expression " & Dimensions_Msg_Of (Expr), N);
1517       end Error_Dim_For_Object_Declaration;
1518
1519    --  Start of processing for Analyze_Dimension_Object_Declaration
1520
1521    begin
1522       --  Expression is present
1523
1524       if Present (Expr) then
1525          Dim_Of_Expr := Dimensions_Of (Expr);
1526
1527          --  case when expression is not a literal and when dimensions of the
1528          --  expression and of the type mismatch
1529
1530          if not Nkind_In (Original_Node (Expr),
1531                              N_Real_Literal,
1532                              N_Integer_Literal)
1533            and then Dim_Of_Expr /= Dim_Of_Etyp
1534          then
1535             Error_Dim_For_Object_Declaration (N, Etyp, Expr);
1536          end if;
1537
1538          --  Removal of dimensions in expression
1539
1540          Remove_Dimensions (Expr);
1541       end if;
1542    end Analyze_Dimension_Object_Declaration;
1543
1544    ---------------------------------------------------
1545    -- Analyze_Dimension_Object_Renaming_Declaration --
1546    ---------------------------------------------------
1547
1548    procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
1549       Renamed_Name : constant Node_Id := Name (N);
1550       Sub_Mark     : constant Node_Id := Subtype_Mark (N);
1551
1552       procedure Error_Dim_For_Object_Renaming_Declaration
1553         (N            : Node_Id;
1554          Sub_Mark     : Node_Id;
1555          Renamed_Name : Node_Id);
1556       --  Error using Error_Msg_N at node N. Output in the error message the
1557       --  dimensions of Sub_Mark and of Renamed_Name.
1558
1559       -----------------------------------------------
1560       -- Error_Dim_For_Object_Renaming_Declaration --
1561       -----------------------------------------------
1562
1563       procedure Error_Dim_For_Object_Renaming_Declaration
1564         (N            : Node_Id;
1565          Sub_Mark     : Node_Id;
1566          Renamed_Name : Node_Id) is
1567       begin
1568          Error_Msg_N ("?dimensions mismatch in object renaming declaration",
1569                       N);
1570          Error_Msg_N ("?type " & Dimensions_Msg_Of (Sub_Mark), N);
1571          Error_Msg_N ("?renamed object " & Dimensions_Msg_Of (Renamed_Name),
1572                       N);
1573       end Error_Dim_For_Object_Renaming_Declaration;
1574
1575    --  Start of processing for Analyze_Dimension_Object_Renaming_Declaration
1576
1577    begin
1578       if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
1579          Error_Dim_For_Object_Renaming_Declaration
1580            (N, Sub_Mark, Renamed_Name);
1581       end if;
1582    end Analyze_Dimension_Object_Renaming_Declaration;
1583
1584    -----------------------------------------------
1585    -- Analyze_Dimension_Simple_Return_Statement --
1586    -----------------------------------------------
1587
1588    procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
1589       Expr                : constant Node_Id := Expression (N);
1590       Dims_Of_Expr        : constant Dimension_Type := Dimensions_Of (Expr);
1591       Return_Ent          : constant Entity_Id := Return_Statement_Entity (N);
1592       Return_Etyp         : constant Entity_Id :=
1593                               Etype (Return_Applies_To (Return_Ent));
1594       Dims_Of_Return_Etyp : constant Dimension_Type :=
1595                               Dimensions_Of (Return_Etyp);
1596
1597       procedure Error_Dim_For_Simple_Return_Statement
1598         (N           : Node_Id;
1599          Return_Etyp : Entity_Id;
1600          Expr        : Node_Id);
1601       --  Error using Error_Msg_N at node N. Output in the error message
1602       --  the dimensions of the returned type Return_Etyp and the returned
1603       --  expression Expr of N.
1604
1605       -------------------------------------------
1606       -- Error_Dim_For_Simple_Return_Statement --
1607       -------------------------------------------
1608
1609       procedure Error_Dim_For_Simple_Return_Statement
1610         (N           : Node_Id;
1611          Return_Etyp : Entity_Id;
1612          Expr        : Node_Id)
1613       is
1614       begin
1615          Error_Msg_N ("?dimensions mismatch in return statement", N);
1616          Error_Msg_N ("\?returned type " & Dimensions_Msg_Of (Return_Etyp), N);
1617          Error_Msg_N ("\?returned expression " & Dimensions_Msg_Of (Expr), N);
1618       end Error_Dim_For_Simple_Return_Statement;
1619
1620    --  Start of processing for Analyze_Dimension_Simple_Return_Statement
1621
1622    begin
1623       if Dims_Of_Return_Etyp /= Dims_Of_Expr then
1624          Error_Dim_For_Simple_Return_Statement (N, Return_Etyp, Expr);
1625          Remove_Dimensions (Expr);
1626       end if;
1627    end Analyze_Dimension_Simple_Return_Statement;
1628
1629    -------------------------------------------
1630    -- Analyze_Dimension_Subtype_Declaration --
1631    -------------------------------------------
1632
1633    procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
1634       Id           : constant Entity_Id := Defining_Identifier (N);
1635       Dims_Of_Id   : constant Dimension_Type := Dimensions_Of (Id);
1636       Dims_Of_Etyp : Dimension_Type;
1637       Etyp         : Node_Id;
1638
1639    begin
1640       --  No constraint case in subtype declaration
1641
1642       if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
1643          Etyp := Etype (Subtype_Indication (N));
1644          Dims_Of_Etyp := Dimensions_Of (Etyp);
1645
1646          if Exists (Dims_Of_Etyp) then
1647
1648             --  If subtype already has a dimension (from Aspect_Dimension),
1649             --  it cannot inherit a dimension from its subtype.
1650
1651             if Exists (Dims_Of_Id) then
1652                Error_Msg_N ("?subtype& already" & Dimensions_Msg_Of (Id), N);
1653             else
1654                Set_Dimensions (Id, Dims_Of_Etyp);
1655                Set_Symbol (Id, Symbol_Of (Etyp));
1656             end if;
1657          end if;
1658
1659       --  Constraint present in subtype declaration
1660
1661       else
1662          Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
1663          Dims_Of_Etyp := Dimensions_Of (Etyp);
1664
1665          if Exists (Dims_Of_Etyp) then
1666             Set_Dimensions (Id, Dims_Of_Etyp);
1667             Set_Symbol (Id, Symbol_Of (Etyp));
1668          end if;
1669       end if;
1670    end Analyze_Dimension_Subtype_Declaration;
1671
1672    --------------------------------
1673    -- Analyze_Dimension_Unary_Op --
1674    --------------------------------
1675
1676    procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
1677    begin
1678       case Nkind (N) is
1679          when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
1680             declare
1681                R : constant Node_Id := Right_Opnd (N);
1682
1683             begin
1684                --  Propagate the dimension if the operand is not dimensionless
1685
1686                Move_Dimensions (R, N);
1687             end;
1688
1689          when others => null;
1690
1691       end case;
1692    end Analyze_Dimension_Unary_Op;
1693
1694    --------------------------
1695    -- Create_Rational_From --
1696    --------------------------
1697
1698    --  RATIONAL ::= [-] NUMERAL [/ NUMERAL]
1699
1700    --  A rational number is a number that can be expressed as the quotient or
1701    --  fraction a/b of two integers, where b is non-zero.
1702
1703    function Create_Rational_From
1704      (Expr     : Node_Id;
1705       Complain : Boolean) return Rational
1706    is
1707       Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
1708       Result          : Rational := No_Rational;
1709
1710       function Process_Minus (N : Node_Id) return Rational;
1711       --  Create a rational from a N_Op_Minus node
1712
1713       function Process_Divide (N : Node_Id) return Rational;
1714       --  Create a rational from a N_Op_Divide node
1715
1716       function Process_Literal (N : Node_Id) return Rational;
1717       --  Create a rational from a N_Integer_Literal node
1718
1719       -------------------
1720       -- Process_Minus --
1721       -------------------
1722
1723       function Process_Minus (N : Node_Id) return Rational is
1724          Right  : constant Node_Id := Original_Node (Right_Opnd (N));
1725          Result : Rational;
1726
1727       begin
1728          --  Operand is an integer literal
1729
1730          if Nkind (Right) = N_Integer_Literal then
1731             Result := -Process_Literal (Right);
1732
1733          --  Operand is a divide operator
1734
1735          elsif Nkind (Right) = N_Op_Divide then
1736             Result := -Process_Divide (Right);
1737
1738          else
1739             Result := No_Rational;
1740          end if;
1741
1742          return Result;
1743       end Process_Minus;
1744
1745       --------------------
1746       -- Process_Divide --
1747       --------------------
1748
1749       function Process_Divide (N : Node_Id) return Rational is
1750          Left      : constant Node_Id := Original_Node (Left_Opnd (N));
1751          Right     : constant Node_Id := Original_Node (Right_Opnd (N));
1752          Left_Rat  : Rational;
1753          Result    : Rational := No_Rational;
1754          Right_Rat : Rational;
1755
1756       begin
1757          --  Both left and right operands are an integer literal
1758
1759          if Nkind (Left) = N_Integer_Literal
1760            and then Nkind (Right) = N_Integer_Literal
1761          then
1762             Left_Rat := Process_Literal (Left);
1763             Right_Rat := Process_Literal (Right);
1764             Result := Left_Rat / Right_Rat;
1765          end if;
1766
1767          return Result;
1768       end Process_Divide;
1769
1770       ---------------------
1771       -- Process_Literal --
1772       ---------------------
1773
1774       function Process_Literal (N : Node_Id) return Rational is
1775       begin
1776          return +Whole (UI_To_Int (Intval (N)));
1777       end Process_Literal;
1778
1779    --  Start of processing for Create_Rational_From
1780
1781    begin
1782       --  Check the expression is either a division of two integers or an
1783       --  integer itself. Note that the check applies to the original node
1784       --  since the node could have already been rewritten.
1785
1786       --  Integer literal case
1787
1788       if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
1789          Result := Process_Literal (Or_Node_Of_Expr);
1790
1791       --  Divide operator case
1792
1793       elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
1794          Result := Process_Divide (Or_Node_Of_Expr);
1795
1796       --  Minus operator case
1797
1798       elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
1799          Result := Process_Minus (Or_Node_Of_Expr);
1800       end if;
1801
1802       --  When Expr cannot be interpreted as a rational and Complain is true,
1803       --  generate an error message.
1804
1805       if Complain and then Result = No_Rational then
1806          Error_Msg_N ("must be a rational", Expr);
1807       end if;
1808
1809       return Result;
1810    end Create_Rational_From;
1811
1812    -------------------
1813    -- Dimensions_Of --
1814    -------------------
1815
1816    function Dimensions_Of (N : Node_Id) return Dimension_Type is
1817    begin
1818       return Dimension_Table.Get (N);
1819    end Dimensions_Of;
1820
1821    -----------------------
1822    -- Dimensions_Msg_Of --
1823    -----------------------
1824
1825    function Dimensions_Msg_Of (N : Node_Id) return String is
1826       Dims_Of_N      : constant Dimension_Type := Dimensions_Of (N);
1827       Dimensions_Msg : Name_Id;
1828       System         : System_Type;
1829
1830       procedure Add_Dimension_Vector_To_Buffer
1831         (Dims   : Dimension_Type;
1832          System : System_Type);
1833       --  Given a Dims and System, add to Name_Buffer the string representation
1834       --  of a dimension vector.
1835
1836       procedure Add_Whole_To_Buffer (W : Whole);
1837       --  Add image of Whole to Name_Buffer
1838
1839       ------------------------------------
1840       -- Add_Dimension_Vector_To_Buffer --
1841       ------------------------------------
1842
1843       procedure Add_Dimension_Vector_To_Buffer
1844         (Dims   : Dimension_Type;
1845          System : System_Type)
1846       is
1847          Dim_Power : Rational;
1848          First_Dim : Boolean := True;
1849
1850       begin
1851          Add_Char_To_Name_Buffer ('(');
1852
1853          for Position in Dims_Of_N'First ..  System.Count loop
1854             Dim_Power := Dims (Position);
1855
1856             if First_Dim then
1857                First_Dim := False;
1858             else
1859                Add_Str_To_Name_Buffer (", ");
1860             end if;
1861
1862             Add_Whole_To_Buffer (Dim_Power.Numerator);
1863
1864             if Dim_Power.Denominator /= 1 then
1865                Add_Char_To_Name_Buffer ('/');
1866                Add_Whole_To_Buffer (Dim_Power.Denominator);
1867             end if;
1868          end loop;
1869
1870          Add_Char_To_Name_Buffer (')');
1871       end Add_Dimension_Vector_To_Buffer;
1872
1873       -------------------------
1874       -- Add_Whole_To_Buffer --
1875       -------------------------
1876
1877       procedure Add_Whole_To_Buffer (W : Whole) is
1878       begin
1879          UI_Image (UI_From_Int (Int (W)));
1880          Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1881       end Add_Whole_To_Buffer;
1882
1883    --  Start of processing for Dimensions_Msg_Of
1884
1885    begin
1886       --  Initialization of Name_Buffer
1887
1888       Name_Len := 0;
1889
1890       if Exists (Dims_Of_N) then
1891          System := System_Of (Base_Type (Etype (N)));
1892          Add_Str_To_Name_Buffer ("has dimensions: ");
1893          Add_Dimension_Vector_To_Buffer (Dims_Of_N, System);
1894       else
1895          Add_Str_To_Name_Buffer ("is dimensionless");
1896       end if;
1897
1898       Dimensions_Msg := Name_Find;
1899       return Get_Name_String (Dimensions_Msg);
1900    end Dimensions_Msg_Of;
1901
1902    --------------------------
1903    -- Dimension_Table_Hash --
1904    --------------------------
1905
1906    function Dimension_Table_Hash
1907      (Key : Node_Id) return Dimension_Table_Range
1908    is
1909    begin
1910       return Dimension_Table_Range (Key mod 511);
1911    end Dimension_Table_Hash;
1912
1913    ----------------------------------------
1914    -- Eval_Op_Expon_For_Dimensioned_Type --
1915    ----------------------------------------
1916
1917    --  Evaluate the expon operator for real dimensioned type. Note that the
1918    --  node must come from source. Why???
1919
1920    --  Note that if the exponent is an integer (denominator = 1) the node is
1921    --  evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
1922
1923    procedure Eval_Op_Expon_For_Dimensioned_Type
1924      (N    : Node_Id;
1925       Btyp : Entity_Id)
1926    is
1927       R       : constant Node_Id := Right_Opnd (N);
1928       R_Value : Rational := No_Rational;
1929
1930    begin
1931       if Comes_From_Source (N)
1932         and then Is_Real_Type (Btyp)
1933       then
1934          R_Value := Create_Rational_From (R, False);
1935       end if;
1936
1937       --  Check that the exponent is not an integer
1938
1939       if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
1940          Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
1941       else
1942          Eval_Op_Expon (N);
1943       end if;
1944    end Eval_Op_Expon_For_Dimensioned_Type;
1945
1946    ------------------------------------------
1947    -- Eval_Op_Expon_With_Rational_Exponent --
1948    ------------------------------------------
1949
1950    --  For dimensioned operand in exponentiation, exponent is allowed to be a
1951    --  Rational and not only an Integer like for dimensionless operands. For
1952    --  that particular case, the left operand is rewritten as a function call
1953    --  using the function Expon_LLF from s-llflex.ads.
1954
1955    procedure Eval_Op_Expon_With_Rational_Exponent
1956      (N              : Node_Id;
1957       Exponent_Value : Rational)
1958    is
1959       Dims_Of_N             : constant Dimension_Type := Dimensions_Of (N);
1960       L                     : constant Node_Id := Left_Opnd (N);
1961       Etyp_Of_L             : constant Entity_Id := Etype (L);
1962       Btyp_Of_L             : constant Entity_Id := Base_Type (Etyp_Of_L);
1963       Loc                   : constant Source_Ptr := Sloc (N);
1964       Actual_1              : Node_Id;
1965       Actual_2              : Node_Id;
1966       Dim_Power             : Rational;
1967       List_Of_Dims          : List_Id;
1968       New_Aspect            : Node_Id;
1969       New_Aspects           : List_Id;
1970       New_Id                : Entity_Id;
1971       New_N                 : Node_Id;
1972       New_Subtyp_Decl_For_L : Node_Id;
1973       System                : System_Type;
1974
1975    begin
1976       --  Case when the operand is not dimensionless
1977
1978       if Exists (Dims_Of_N) then
1979
1980          --  Get the corresponding System_Type to know the exact number of
1981          --  dimensions in the system.
1982
1983          System := System_Of (Btyp_Of_L);
1984
1985          --  Generation of a new subtype with the proper dimensions
1986
1987          --  In order to rewrite the operator as a type conversion, a new
1988          --  dimensioned subtype with the resulting dimensions of the
1989          --  exponentiation must be created.
1990
1991          --  Generate:
1992
1993          --  Btyp_Of_L   : constant Entity_Id := Base_Type (Etyp_Of_L);
1994          --  System      : constant System_Id :=
1995          --                  Get_Dimension_System_Id (Btyp_Of_L);
1996          --  Num_Of_Dims : constant Number_Of_Dimensions :=
1997          --                  Dimension_Systems.Table (System).Dimension_Count;
1998
1999          --  subtype T is Btyp_Of_L
2000          --    with
2001          --      Dimension => ("",
2002          --        Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2003          --        Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2004          --        ...
2005          --        Dims_Of_N (Num_Of_Dims).Numerator /
2006          --          Dims_Of_N (Num_Of_Dims).Denominator);
2007
2008          --  Step 1: Generate the new aggregate for the aspect Dimension
2009
2010          New_Aspects  := Empty_List;
2011          List_Of_Dims := New_List;
2012          Append (Make_String_Literal (Loc, ""), List_Of_Dims);
2013
2014          for Position in Dims_Of_N'First ..  System.Count loop
2015             Dim_Power := Dims_Of_N (Position);
2016             Append_To (List_Of_Dims,
2017                Make_Op_Divide (Loc,
2018                  Left_Opnd  =>
2019                    Make_Integer_Literal (Loc,
2020                      Int (Dim_Power.Numerator)),
2021                  Right_Opnd =>
2022                    Make_Integer_Literal (Loc,
2023                      Int (Dim_Power.Denominator))));
2024          end loop;
2025
2026          --  Step 2: Create the new Aspect Specification for Aspect Dimension
2027
2028          New_Aspect :=
2029            Make_Aspect_Specification (Loc,
2030              Identifier => Make_Identifier (Loc, Name_Dimension),
2031              Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2032
2033          --  Step 3: Make a temporary identifier for the new subtype
2034
2035          New_Id := Make_Temporary (Loc, 'T');
2036          Set_Is_Internal (New_Id);
2037
2038          --  Step 4: Declaration of the new subtype
2039
2040          New_Subtyp_Decl_For_L :=
2041             Make_Subtype_Declaration (Loc,
2042                Defining_Identifier => New_Id,
2043                Subtype_Indication  => New_Occurrence_Of (Btyp_Of_L, Loc));
2044
2045          Append (New_Aspect, New_Aspects);
2046          Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
2047          Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2048
2049          Analyze (New_Subtyp_Decl_For_L);
2050
2051       --  Case where the operand is dimensionless
2052
2053       else
2054          New_Id := Btyp_Of_L;
2055       end if;
2056
2057       --  Replacement of N by New_N
2058
2059       --  Generate:
2060
2061       --  Actual_1 := Long_Long_Float (L),
2062
2063       --  Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2064       --                Long_Long_Float (Exponent_Value.Denominator);
2065
2066       --  (T (Expon_LLF (Actual_1, Actual_2)));
2067
2068       --  where T is the subtype declared in step 1
2069
2070       --  The node is rewritten as a type conversion
2071
2072       --  Step 1: Creation of the two parameters of Expon_LLF function call
2073
2074       Actual_1 :=
2075         Make_Type_Conversion (Loc,
2076           Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc),
2077           Expression   => Relocate_Node (L));
2078
2079       Actual_2 :=
2080         Make_Op_Divide (Loc,
2081           Left_Opnd  =>
2082             Make_Real_Literal (Loc,
2083               UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2084           Right_Opnd =>
2085             Make_Real_Literal (Loc,
2086               UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2087
2088       --  Step 2: Creation of New_N
2089
2090       New_N :=
2091          Make_Type_Conversion (Loc,
2092            Subtype_Mark => New_Reference_To (New_Id, Loc),
2093            Expression =>
2094              Make_Function_Call (Loc,
2095                Name => New_Reference_To (RTE (RE_Expon_LLF), Loc),
2096                Parameter_Associations => New_List (
2097                  Actual_1, Actual_2)));
2098
2099       --  Step 3: Rewrite N with the result
2100
2101       Rewrite (N, New_N);
2102       Set_Etype (N, New_Id);
2103       Analyze_And_Resolve (N, New_Id);
2104    end Eval_Op_Expon_With_Rational_Exponent;
2105
2106    ------------
2107    -- Exists --
2108    ------------
2109
2110    function Exists (Dim : Dimension_Type) return Boolean is
2111    begin
2112       return Dim /= Null_Dimension;
2113    end Exists;
2114
2115    function Exists (Sys : System_Type) return Boolean is
2116    begin
2117       return Sys /= Null_System;
2118    end Exists;
2119
2120    -------------------------------------------
2121    -- Expand_Put_Call_With_Dimension_Symbol --
2122    -------------------------------------------
2123
2124    --  For procedure Put defined in System.Dim_Float_IO/System.Dim_Integer_IO,
2125    --  the default string parameter must be rewritten to include the dimension
2126    --  symbols in the output of a dimensioned object.
2127
2128    --  Case 1: the parameter is a variable
2129
2130    --  The default string parameter is replaced by the symbol defined in the
2131    --  aspect Dimension of the subtype. For instance to output a speed:
2132
2133    --  subtype Force is Mks_Type
2134    --    with
2135    --      Dimension => ("N",
2136    --        Meter =>    1,
2137    --        Kilogram => 1,
2138    --        Second =>   -2,
2139    --        others =>   0);
2140    --  F : Force := 2.1 * m * kg * s**(-2);
2141    --  Put (F);
2142    --  > 2.1 N
2143
2144    --  Case 2: the parameter is an expression
2145
2146    --  In this case we call the procedure Expand_Put_Call_With_Dimension_Symbol
2147    --  that creates the string of symbols (for instance "m.s**(-1)") and
2148    --  rewrites the default string parameter of Put with the corresponding
2149    --  the String_Id. For instance:
2150
2151    --  Put (2.1 * m * kg * s**(-2));
2152    --  > 2.1 m.kg.s**(-2)
2153
2154    procedure Expand_Put_Call_With_Dimension_Symbol (N : Node_Id) is
2155       Actuals        : constant List_Id := Parameter_Associations (N);
2156       Loc            : constant Source_Ptr := Sloc (N);
2157       Name_Call      : constant Node_Id := Name (N);
2158       Actual         : Node_Id;
2159       Base_Typ       : Node_Id;
2160       Dims_Of_Actual : Dimension_Type;
2161       Etyp           : Entity_Id;
2162       First_Actual   : Node_Id;
2163       New_Actuals    : List_Id;
2164       New_Str_Lit    : Node_Id;
2165       Package_Name   : Name_Id;
2166       System         : System_Type;
2167
2168       function Is_Procedure_Put_Call return Boolean;
2169       --  Return True if the current call is a call of an instantiation of a
2170       --  procedure Put defined in the package System.Dim_Float_IO and
2171       --  System.Dim_Integer_IO.
2172
2173       ---------------------------
2174       -- Is_Procedure_Put_Call --
2175       ---------------------------
2176
2177       function Is_Procedure_Put_Call return Boolean is
2178          Ent : Entity_Id;
2179
2180       begin
2181          --  There are three different Put routine in each generic package
2182          --  Check that the current procedure call is one of them
2183
2184          if Is_Entity_Name (Name_Call) then
2185             Ent := Entity (Name_Call);
2186
2187             --  Check that the name of the procedure is Put
2188             --  Check the procedure is defined in an instantiation of a
2189             --  generic package.
2190
2191             if Chars (Name_Call) = Name_Put
2192               and then Is_Generic_Instance (Scope (Ent))
2193             then
2194                Ent := Cunit_Entity (Get_Source_Unit (Ent));
2195
2196                --  Verify that the generic package is System.Dim_Float_IO or
2197                --  System.Dim_Integer_IO.
2198
2199                if Is_Library_Level_Entity (Ent) then
2200                   Package_Name := Chars (Ent);
2201
2202                   return
2203                     Package_Name = Name_Dim_Float_IO
2204                       or else Package_Name = Name_Dim_Integer_IO;
2205                end if;
2206             end if;
2207          end if;
2208
2209          return False;
2210       end Is_Procedure_Put_Call;
2211
2212    --  Start of processing for Expand_Put_Call_With_Dimension_Symbol
2213
2214    begin
2215       if Is_Procedure_Put_Call then
2216
2217          --  Get the first parameter
2218
2219          First_Actual := First (Actuals);
2220
2221          --  Case when the Put routine has four (System.Dim_Integer_IO) or five
2222          --  (System.Dim_Float_IO) parameters.
2223
2224          if List_Length (Actuals) = 5
2225            or else List_Length (Actuals) = 4
2226          then
2227             Actual := Next (First_Actual);
2228
2229             if Nkind (Actual) = N_Parameter_Association then
2230
2231                --  Get the dimensions and the corresponding dimension system
2232                --  from the first actual.
2233
2234                Actual := First_Actual;
2235             end if;
2236
2237          --  Case when the Put routine has six parameters
2238
2239          else
2240             Actual := Next (First_Actual);
2241          end if;
2242
2243          Base_Typ := Base_Type (Etype (Actual));
2244          System := System_Of (Base_Typ);
2245
2246          --  Check the base type of Actual is a dimensioned type
2247
2248          if Exists (System) then
2249             Dims_Of_Actual := Dimensions_Of (Actual);
2250             Etyp := Etype (Actual);
2251
2252             --  Add the symbol as a suffix of the value if the subtype has a
2253             --  dimension symbol or if the parameter is not dimensionless.
2254
2255             if Exists (Dims_Of_Actual)
2256               or else Symbol_Of (Etyp) /= No_String
2257             then
2258                New_Actuals := New_List;
2259
2260                --  Add to the list First_Actual and Actual if they differ
2261
2262                if Actual /= First_Actual then
2263                   Append (New_Copy (First_Actual), New_Actuals);
2264                end if;
2265
2266                Append (New_Copy (Actual), New_Actuals);
2267
2268                --  Look to the next parameter
2269
2270                Next (Actual);
2271
2272                --  Check if the type of N is a subtype that has a symbol of
2273                --  dimensions in Aspect_Dimension_String_Id_Hash_Table.
2274
2275                if Symbol_Of (Etyp) /= No_String then
2276                   Start_String;
2277
2278                   --  Put a space between the value and the dimension
2279
2280                   Store_String_Char (' ');
2281                   Store_String_Chars (Symbol_Of (Etyp));
2282                   New_Str_Lit := Make_String_Literal (Loc, End_String);
2283
2284                --  Rewrite the String_Literal of the second actual with the
2285                --  new String_Id created by the routine
2286                --  From_Dimension_To_String.
2287
2288                else
2289                   New_Str_Lit :=
2290                     Make_String_Literal (Loc,
2291                       From_Dimension_To_String_Of_Symbols (Dims_Of_Actual,
2292                         System));
2293                end if;
2294
2295                Append (New_Str_Lit, New_Actuals);
2296
2297                --  Rewrite the procedure call with the new list of parameters
2298
2299                Rewrite (N,
2300                  Make_Procedure_Call_Statement (Loc,
2301                    Name =>                   New_Copy (Name_Call),
2302                    Parameter_Associations => New_Actuals));
2303
2304                Analyze (N);
2305             end if;
2306          end if;
2307       end if;
2308    end Expand_Put_Call_With_Dimension_Symbol;
2309
2310    -----------------------------------------
2311    -- From_Dimension_To_String_Of_Symbols --
2312    -----------------------------------------
2313
2314    --  Given a dimension vector and the corresponding dimension system,
2315    --  create a String_Id to output the dimension symbols corresponding to
2316    --  the dimensions Dims.
2317
2318    function From_Dimension_To_String_Of_Symbols
2319      (Dims   : Dimension_Type;
2320       System : System_Type) return String_Id
2321    is
2322       Dimension_Power     : Rational;
2323       First_Symbol_In_Str : Boolean := True;
2324
2325    begin
2326       --  Initialization of the new String_Id
2327
2328       Start_String;
2329
2330       --  Put a space between the value and the symbols
2331
2332       Store_String_Char (' ');
2333
2334       for Position in Dimension_Type'Range loop
2335          Dimension_Power := Dims (Position);
2336          if Dimension_Power /= Zero then
2337
2338             if First_Symbol_In_Str then
2339                First_Symbol_In_Str := False;
2340             else
2341                Store_String_Char ('.');
2342             end if;
2343
2344             --  Positive dimension case
2345
2346             if Dimension_Power.Numerator > 0 then
2347                if System.Symbols (Position) = No_String then
2348                   Store_String_Chars
2349                     (Get_Name_String (System.Names (Position)));
2350                else
2351                   Store_String_Chars (System.Symbols (Position));
2352                end if;
2353
2354                --  Integer case
2355
2356                if Dimension_Power.Denominator = 1 then
2357                   if Dimension_Power.Numerator /= 1 then
2358                      Store_String_Chars ("**");
2359                      Store_String_Int (Int (Dimension_Power.Numerator));
2360                   end if;
2361
2362                --  Rational case when denominator /= 1
2363
2364                else
2365                   Store_String_Chars ("**");
2366                   Store_String_Char ('(');
2367                   Store_String_Int (Int (Dimension_Power.Numerator));
2368                   Store_String_Char ('/');
2369                   Store_String_Int (Int (Dimension_Power.Denominator));
2370                   Store_String_Char (')');
2371                end if;
2372
2373             --  Negative dimension case
2374
2375             else
2376                if System.Symbols (Position) = No_String then
2377                   Store_String_Chars
2378                     (Get_Name_String (System.Names (Position)));
2379                else
2380                   Store_String_Chars (System.Symbols (Position));
2381                end if;
2382
2383                Store_String_Chars ("**");
2384                Store_String_Char ('(');
2385                Store_String_Char ('-');
2386                Store_String_Int (Int (-Dimension_Power.Numerator));
2387
2388                --  Integer case
2389
2390                if Dimension_Power.Denominator = 1 then
2391                   Store_String_Char (')');
2392
2393                --  Rational case when denominator /= 1
2394
2395                else
2396                   Store_String_Char ('/');
2397                   Store_String_Int (Int (Dimension_Power.Denominator));
2398                   Store_String_Char (')');
2399                end if;
2400             end if;
2401          end if;
2402       end loop;
2403
2404       return End_String;
2405    end From_Dimension_To_String_Of_Symbols;
2406
2407    ---------
2408    -- GCD --
2409    ---------
2410
2411    function GCD (Left, Right : Whole) return Int is
2412       L : Whole;
2413       R : Whole;
2414
2415    begin
2416       L := Left;
2417       R := Right;
2418       while R /= 0 loop
2419          L := L mod R;
2420
2421          if L = 0 then
2422             return Int (R);
2423          end if;
2424
2425          R := R mod L;
2426       end loop;
2427
2428       return Int (L);
2429    end GCD;
2430
2431    --------------------------
2432    -- Has_Dimension_System --
2433    --------------------------
2434
2435    function Has_Dimension_System (Typ : Entity_Id) return Boolean is
2436    begin
2437       return Exists (System_Of (Typ));
2438    end Has_Dimension_System;
2439
2440    -------------------------------------
2441    -- Is_Dim_IO_Package_Instantiation --
2442    -------------------------------------
2443
2444    function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
2445       Gen_Id : constant Node_Id := Name (N);
2446       Ent    : Entity_Id;
2447
2448    begin
2449       if Is_Entity_Name (Gen_Id) then
2450          Ent := Entity (Gen_Id);
2451
2452          return
2453            Is_Library_Level_Entity (Ent)
2454              and then
2455                (Chars (Ent) = Name_Dim_Float_IO
2456                  or else Chars (Ent) = Name_Dim_Integer_IO);
2457       end if;
2458
2459       return False;
2460    end Is_Dim_IO_Package_Instantiation;
2461
2462    ----------------
2463    -- Is_Invalid --
2464    ----------------
2465
2466    function Is_Invalid (Position : Dimension_Position) return Boolean is
2467    begin
2468       return Position = Invalid_Position;
2469    end Is_Invalid;
2470
2471    ---------------------
2472    -- Move_Dimensions --
2473    ---------------------
2474
2475    procedure Move_Dimensions (From, To : Node_Id) is
2476       Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
2477
2478    begin
2479       --  Copy the dimension of 'From to 'To' and remove dimension of 'From'
2480
2481       if Exists (Dims_Of_From) then
2482          Set_Dimensions (To, Dims_Of_From);
2483          Remove_Dimensions (From);
2484       end if;
2485    end Move_Dimensions;
2486
2487    ------------
2488    -- Reduce --
2489    ------------
2490
2491    function Reduce (X : Rational) return Rational is
2492    begin
2493       if X.Numerator = 0 then
2494          return Zero;
2495       end if;
2496
2497       declare
2498          G : constant Int := GCD (X.Numerator, X.Denominator);
2499       begin
2500          return Rational'(Numerator =>   Whole (Int (X.Numerator) / G),
2501                           Denominator => Whole (Int (X.Denominator) / G));
2502       end;
2503    end Reduce;
2504
2505    -----------------------
2506    -- Remove_Dimensions --
2507    -----------------------
2508
2509    procedure Remove_Dimensions (N : Node_Id) is
2510       Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2511    begin
2512       if Exists (Dims_Of_N) then
2513          Dimension_Table.Remove (N);
2514       end if;
2515    end Remove_Dimensions;
2516
2517    ------------------------------
2518    -- Remove_Dimension_In_Call --
2519    ------------------------------
2520
2521    procedure Remove_Dimension_In_Call (Call : Node_Id) is
2522       Actual : Node_Id;
2523
2524    begin
2525       if Ada_Version < Ada_2012 then
2526          return;
2527       end if;
2528
2529       Actual := First (Parameter_Associations (Call));
2530
2531       while Present (Actual) loop
2532          Remove_Dimensions (Actual);
2533          Next (Actual);
2534       end loop;
2535    end Remove_Dimension_In_Call;
2536
2537    -----------------------------------
2538    -- Remove_Dimension_In_Statement --
2539    -----------------------------------
2540
2541    --  Removal of dimension in statement as part of the Analyze_Statements
2542    --  routine (see package Sem_Ch5).
2543
2544    procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
2545    begin
2546       if Ada_Version < Ada_2012 then
2547          return;
2548       end if;
2549
2550       --  Remove dimension in parameter specifications for accept statement
2551
2552       if Nkind (Stmt) = N_Accept_Statement then
2553          declare
2554             Param : Node_Id := First (Parameter_Specifications (Stmt));
2555          begin
2556             while Present (Param) loop
2557                Remove_Dimensions (Param);
2558                Next (Param);
2559             end loop;
2560          end;
2561
2562       --  Remove dimension of name and expression in assignments
2563
2564       elsif Nkind (Stmt) = N_Assignment_Statement then
2565          Remove_Dimensions (Expression (Stmt));
2566          Remove_Dimensions (Name (Stmt));
2567       end if;
2568    end Remove_Dimension_In_Statement;
2569
2570    --------------------
2571    -- Set_Dimensions --
2572    --------------------
2573
2574    procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
2575    begin
2576       pragma Assert (OK_For_Dimension (Nkind (N)));
2577       pragma Assert (Exists (Val));
2578
2579       Dimension_Table.Set (N, Val);
2580    end Set_Dimensions;
2581
2582    ----------------
2583    -- Set_Symbol --
2584    ----------------
2585
2586    procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
2587    begin
2588       Symbol_Table.Set (E, Val);
2589    end Set_Symbol;
2590
2591    ---------------
2592    -- Symbol_Of --
2593    ---------------
2594
2595    function Symbol_Of (E : Entity_Id) return String_Id is
2596    begin
2597       return Symbol_Table.Get (E);
2598    end Symbol_Of;
2599
2600    -----------------------
2601    -- Symbol_Table_Hash --
2602    -----------------------
2603
2604    function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
2605    begin
2606       return Symbol_Table_Range (Key mod 511);
2607    end Symbol_Table_Hash;
2608
2609    ---------------
2610    -- System_Of --
2611    ---------------
2612
2613    function System_Of (E : Entity_Id) return System_Type is
2614       Type_Decl : constant Node_Id := Parent (E);
2615
2616    begin
2617       --  Look for Type_Decl in System_Table
2618
2619       for Dim_Sys in 1 .. System_Table.Last loop
2620          if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
2621             return System_Table.Table (Dim_Sys);
2622          end if;
2623       end loop;
2624
2625       return Null_System;
2626    end System_Of;
2627
2628 end Sem_Dim;