1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
35 with Rtsfind; use Rtsfind;
37 with Sem_Eval; use Sem_Eval;
38 with Sem_Res; use Sem_Res;
39 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo;
41 with Sinput; use Sinput;
42 with Snames; use Snames;
43 with Stand; use Stand;
44 with Stringt; use Stringt;
46 with Tbuild; use Tbuild;
47 with Uintp; use Uintp;
48 with Urealp; use Urealp;
52 package body Sem_Dim is
54 -------------------------
55 -- Rational arithmetic --
56 -------------------------
58 type Whole is new Int;
59 subtype Positive_Whole is Whole range 1 .. Whole'Last;
61 type Rational is record
63 Denominator : Positive_Whole;
66 Zero : constant Rational := Rational'(Numerator => 0,
69 No_Rational : constant Rational := Rational'(Numerator => 0,
71 -- Used to indicate an expression that cannot be interpreted as a rational
72 -- Returned value of the Create_Rational_From routine when parameter Expr
73 -- is not a static representation of a rational.
75 -- Rational constructors
77 function "+" (Right : Whole) return Rational;
78 function GCD (Left, Right : Whole) return Int;
79 function Reduce (X : Rational) return Rational;
81 -- Unary operator for Rational
83 function "-" (Right : Rational) return Rational;
84 function "abs" (Right : Rational) return Rational;
86 -- Rational operations for Rationals
88 function "+" (Left, Right : Rational) return Rational;
89 function "-" (Left, Right : Rational) return Rational;
90 function "*" (Left, Right : Rational) return Rational;
91 function "/" (Left, Right : Rational) return Rational;
97 Max_Number_Of_Dimensions : constant := 7;
98 -- Maximum number of dimensions in a dimension system
100 High_Position_Bound : constant := Max_Number_Of_Dimensions;
101 Invalid_Position : constant := 0;
102 Low_Position_Bound : constant := 1;
104 subtype Dimension_Position is
105 Nat range Invalid_Position .. High_Position_Bound;
108 array (Dimension_Position range
109 Low_Position_Bound .. High_Position_Bound) of Name_Id;
110 -- A data structure used to store the names of all units within a system
112 No_Names : constant Name_Array := (others => No_Name);
115 array (Dimension_Position range
116 Low_Position_Bound .. High_Position_Bound) of String_Id;
117 -- A data structure used to store the symbols of all units within a system
119 No_Symbols : constant Symbol_Array := (others => No_String);
121 -- The following record should be documented field by field
123 type System_Type is record
125 Unit_Names : Name_Array;
126 Unit_Symbols : Symbol_Array;
127 Dim_Symbols : Symbol_Array;
128 Count : Dimension_Position;
131 Null_System : constant System_Type :=
132 (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
134 subtype System_Id is Nat;
136 -- The following table maps types to systems
138 package System_Table is new Table.Table (
139 Table_Component_Type => System_Type,
140 Table_Index_Type => System_Id,
141 Table_Low_Bound => 1,
143 Table_Increment => 5,
144 Table_Name => "System_Table");
150 type Dimension_Type is
151 array (Dimension_Position range
152 Low_Position_Bound .. High_Position_Bound) of Rational;
154 Null_Dimension : constant Dimension_Type := (others => Zero);
156 type Dimension_Table_Range is range 0 .. 510;
157 function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
159 -- The following table associates nodes with dimensions
161 package Dimension_Table is new
162 GNAT.HTable.Simple_HTable
163 (Header_Num => Dimension_Table_Range,
164 Element => Dimension_Type,
165 No_Element => Null_Dimension,
167 Hash => Dimension_Table_Hash,
174 type Symbol_Table_Range is range 0 .. 510;
175 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
177 -- Each subtype with a dimension has a symbolic representation of the
178 -- related unit. This table establishes a relation between the subtype
181 package Symbol_Table is new
182 GNAT.HTable.Simple_HTable
183 (Header_Num => Symbol_Table_Range,
184 Element => String_Id,
185 No_Element => No_String,
187 Hash => Symbol_Table_Hash,
190 -- The following array enumerates all contexts which may contain or
191 -- produce a dimension.
193 OK_For_Dimension : constant array (Node_Kind) of Boolean :=
194 (N_Attribute_Reference => True,
195 N_Expanded_Name => True,
196 N_Defining_Identifier => True,
197 N_Function_Call => True,
198 N_Identifier => True,
199 N_Indexed_Component => True,
200 N_Integer_Literal => True,
207 N_Op_Multiply => True,
210 N_Op_Subtract => True,
211 N_Qualified_Expression => True,
212 N_Real_Literal => True,
213 N_Selected_Component => True,
215 N_Type_Conversion => True,
216 N_Unchecked_Type_Conversion => True,
220 -----------------------
221 -- Local Subprograms --
222 -----------------------
224 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
225 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
226 -- dimensions of the left-hand side and the right-hand side of N match.
228 procedure Analyze_Dimension_Binary_Op (N : Node_Id);
229 -- Subroutine of Analyze_Dimension for binary operators. Check the
230 -- dimensions of the right and the left operand permit the operation.
231 -- Then, evaluate the resulting dimensions for each binary operator.
233 procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
234 -- Subroutine of Analyze_Dimension for component declaration. Check that
235 -- the dimensions of the type of N and of the expression match.
237 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
238 -- Subroutine of Analyze_Dimension for extended return statement. Check
239 -- that the dimensions of the returned type and of the returned object
242 procedure Analyze_Dimension_Has_Etype (N : Node_Id);
243 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
245 -- N_Attribute_Reference
247 -- N_Indexed_Component
248 -- N_Qualified_Expression
249 -- N_Selected_Component
252 -- N_Unchecked_Type_Conversion
254 procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
255 -- Subroutine of Analyze_Dimension for object declaration. Check that
256 -- the dimensions of the object type and the dimensions of the expression
257 -- (if expression is present) match. Note that when the expression is
258 -- a literal, no error is returned. This special case allows object
259 -- declaration such as: m : constant Length := 1.0;
261 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
262 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
263 -- the dimensions of the type and of the renamed object name of N match.
265 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
266 -- Subroutine of Analyze_Dimension for simple return statement
267 -- Check that the dimensions of the returned type and of the returned
270 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
271 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
272 -- dimensions from the parent type to the identifier of N. Note that if
273 -- both the identifier and the parent type of N are not dimensionless,
276 procedure Analyze_Dimension_Unary_Op (N : Node_Id);
277 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
278 -- Abs operators, propagate the dimensions from the operand to N.
280 function Create_Rational_From
282 Complain : Boolean) return Rational;
283 -- Given an arbitrary expression Expr, return a valid rational if Expr can
284 -- be interpreted as a rational. Otherwise return No_Rational and also an
285 -- error message if Complain is set to True.
287 function Dimensions_Of (N : Node_Id) return Dimension_Type;
288 -- Return the dimension vector of node N
290 function Dimensions_Msg_Of
292 Description_Needed : Boolean := False) return String;
293 -- Given a node N, return the dimension symbols of N, preceded by "has
294 -- dimension" if Description_Needed. if N is dimensionless, return "[]", or
295 -- "is dimensionless" if Description_Needed.
297 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
298 -- Issue a warning on the given numeric literal N to indicate the
299 -- compilateur made the assumption that the literal is not dimensionless
300 -- but has the dimension of Typ.
302 procedure Eval_Op_Expon_With_Rational_Exponent
304 Exponent_Value : Rational);
305 -- Evaluate the exponent it is a rational and the operand has a dimension
307 function Exists (Dim : Dimension_Type) return Boolean;
308 -- Returns True iff Dim does not denote the null dimension
310 function Exists (Str : String_Id) return Boolean;
311 -- Returns True iff Str does not denote No_String
313 function Exists (Sys : System_Type) return Boolean;
314 -- Returns True iff Sys does not denote the null system
316 function From_Dim_To_Str_Of_Dim_Symbols
317 (Dims : Dimension_Type;
318 System : System_Type;
319 In_Error_Msg : Boolean := False) return String_Id;
320 -- Given a dimension vector and a dimension system, return the proper
321 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
322 -- will be used to issue an error message) then this routine has a special
323 -- handling for the insertion character asterisk * which must be precede by
324 -- a quote ' to to be placed literally into the message.
326 function From_Dim_To_Str_Of_Unit_Symbols
327 (Dims : Dimension_Type;
328 System : System_Type) return String_Id;
329 -- Given a dimension vector and a dimension system, return the proper
330 -- string of unit symbols.
332 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
333 -- Return True if E is the package entity of System.Dim.Float_IO or
334 -- System.Dim.Integer_IO.
336 function Is_Invalid (Position : Dimension_Position) return Boolean;
337 -- Return True if Pos denotes the invalid position
339 procedure Remove_Dimensions (N : Node_Id);
340 -- Remove the dimension vector of node N
342 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
343 -- Associate a dimension vector with a node
345 procedure Set_Symbol (E : Entity_Id; Val : String_Id);
346 -- Associate a symbol representation of a dimension vector with a subtype
348 function String_From_Numeric_Literal (N : Node_Id) return String_Id;
349 -- Return the string that corresponds to the numeric litteral N as it
350 -- appears in the source.
352 function Symbol_Of (E : Entity_Id) return String_Id;
353 -- E denotes a subtype with a dimension. Return the symbol representation
354 -- of the dimension vector.
356 function System_Of (E : Entity_Id) return System_Type;
357 -- E denotes a type, return associated system of the type if it has one
363 function "+" (Right : Whole) return Rational is
365 return Rational'(Numerator => Right,
369 function "+" (Left, Right : Rational) return Rational is
370 R : constant Rational :=
371 Rational'(Numerator => Left.Numerator * Right.Denominator +
372 Left.Denominator * Right.Numerator,
373 Denominator => Left.Denominator * Right.Denominator);
382 function "-" (Right : Rational) return Rational is
384 return Rational'(Numerator => -Right.Numerator,
385 Denominator => Right.Denominator);
388 function "-" (Left, Right : Rational) return Rational is
389 R : constant Rational :=
390 Rational'(Numerator => Left.Numerator * Right.Denominator -
391 Left.Denominator * Right.Numerator,
392 Denominator => Left.Denominator * Right.Denominator);
402 function "*" (Left, Right : Rational) return Rational is
403 R : constant Rational :=
404 Rational'(Numerator => Left.Numerator * Right.Numerator,
405 Denominator => Left.Denominator * Right.Denominator);
414 function "/" (Left, Right : Rational) return Rational is
415 R : constant Rational := abs Right;
416 L : Rational := Left;
419 if Right.Numerator < 0 then
420 L.Numerator := Whole (-Integer (L.Numerator));
423 return Reduce (Rational'(Numerator => L.Numerator * R.Denominator,
424 Denominator => L.Denominator * R.Numerator));
431 function "abs" (Right : Rational) return Rational is
433 return Rational'(Numerator => abs Right.Numerator,
434 Denominator => Right.Denominator);
437 ------------------------------
438 -- Analyze_Aspect_Dimension --
439 ------------------------------
441 -- with Dimension => (
442 -- [[Symbol =>] SYMBOL,]
444 -- [, DIMENSION_VALUE]
445 -- [, DIMENSION_VALUE]
446 -- [, DIMENSION_VALUE]
447 -- [, DIMENSION_VALUE]
448 -- [, DIMENSION_VALUE]
449 -- [, DIMENSION_VALUE]);
451 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
453 -- DIMENSION_VALUE ::=
455 -- | others => RATIONAL
456 -- | DISCRETE_CHOICE_LIST => RATIONAL
458 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
460 -- Note that when the dimensioned type is an integer type, then any
461 -- dimension value must be an integer literal.
463 procedure Analyze_Aspect_Dimension
468 Def_Id : constant Entity_Id := Defining_Identifier (N);
470 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
471 -- This array is used when processing ranges or Others_Choice as part of
472 -- the dimension aggregate.
474 Dimensions : Dimension_Type := Null_Dimension;
476 procedure Extract_Power
478 Position : Dimension_Position);
479 -- Given an expression with denotes a rational number, read the number
480 -- and associate it with Position in Dimensions.
482 function Position_In_System
484 System : System_Type) return Dimension_Position;
485 -- Given an identifier which denotes a dimension, return the position of
486 -- that dimension within System.
492 procedure Extract_Power
494 Position : Dimension_Position)
499 if Is_Integer_Type (Def_Id) then
500 -- Dimension value must be an integer literal
502 if Nkind (Expr) = N_Integer_Literal then
503 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
505 Error_Msg_N ("integer literal expected", Expr);
511 Dimensions (Position) := Create_Rational_From (Expr, True);
514 Processed (Position) := True;
517 ------------------------
518 -- Position_In_System --
519 ------------------------
521 function Position_In_System
523 System : System_Type) return Dimension_Position
525 Dimension_Name : constant Name_Id := Chars (Id);
528 for Position in System.Unit_Names'Range loop
529 if Dimension_Name = System.Unit_Names (Position) then
534 return Invalid_Position;
535 end Position_In_System;
542 Num_Choices : Nat := 0;
543 Num_Dimensions : Nat := 0;
544 Others_Seen : Boolean := False;
547 Symbol : String_Id := No_String;
548 Symbol_Expr : Node_Id;
549 System : System_Type;
553 -- Errors_Count is a count of errors detected by the compiler so far
554 -- just before the extraction of symbol, names and values in the
555 -- aggregate (Step 2).
557 -- At the end of the analysis, there is a check to verify that this
558 -- count equals to Serious_Errors_Detected i.e. no erros have been
559 -- encountered during the process. Otherwise the Dimension_Table is
562 -- Start of processing for Analyze_Aspect_Dimension
565 -- STEP 1: Legality of aspect
567 if Nkind (N) /= N_Subtype_Declaration then
568 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
572 Sub_Ind := Subtype_Indication (N);
573 Typ := Etype (Sub_Ind);
574 System := System_Of (Typ);
576 if Nkind (Sub_Ind) = N_Subtype_Indication then
578 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
582 -- The dimension declarations are useless if the parent type does not
583 -- declare a valid system.
585 if not Exists (System) then
587 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
591 if Nkind (Aggr) /= N_Aggregate then
592 Error_Msg_N ("aggregate expected", Aggr);
596 -- STEP 2: Symbol, Names and values extraction
598 -- Get the number of errors detected by the compiler so far
600 Errors_Count := Serious_Errors_Detected;
602 -- STEP 2a: Symbol extraction
604 -- The first entry in the aggregate may be the symbolic representation
607 -- Positional symbol argument
609 Symbol_Expr := First (Expressions (Aggr));
611 -- Named symbol argument
614 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
617 Symbol_Expr := Empty;
619 -- Component associations present
621 if Present (Component_Associations (Aggr)) then
622 Assoc := First (Component_Associations (Aggr));
623 Choice := First (Choices (Assoc));
625 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
627 -- Symbol component association is present
629 if Chars (Choice) = Name_Symbol then
630 Num_Choices := Num_Choices + 1;
631 Symbol_Expr := Expression (Assoc);
633 -- Verify symbol expression is a string or a character
635 if not Nkind_In (Symbol_Expr, N_Character_Literal,
638 Symbol_Expr := Empty;
640 ("symbol expression must be character or string",
644 -- Special error if no Symbol choice but expression is string
647 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
650 Num_Choices := Num_Choices + 1;
651 Error_Msg_N ("optional component Symbol expected, found&",
658 -- STEP 2b: Names and values extraction
660 -- Positional elements
662 Expr := First (Expressions (Aggr));
664 -- Skip the symbol expression when present
666 if Present (Symbol_Expr) and then Num_Choices = 0 then
670 Position := Low_Position_Bound;
671 while Present (Expr) loop
672 if Position > High_Position_Bound then
674 ("type& has more dimensions than system allows", Def_Id);
678 Extract_Power (Expr, Position);
680 Position := Position + 1;
681 Num_Dimensions := Num_Dimensions + 1;
688 Assoc := First (Component_Associations (Aggr));
690 -- Skip the symbol association when present
692 if Num_Choices = 1 then
696 while Present (Assoc) loop
697 Expr := Expression (Assoc);
699 Choice := First (Choices (Assoc));
700 while Present (Choice) loop
702 -- Identifier case: NAME => EXPRESSION
704 if Nkind (Choice) = N_Identifier then
705 Position := Position_In_System (Choice, System);
707 if Is_Invalid (Position) then
708 Error_Msg_N ("dimension name& not part of system", Choice);
710 Extract_Power (Expr, Position);
713 -- Range case: NAME .. NAME => EXPRESSION
715 elsif Nkind (Choice) = N_Range then
717 Low : constant Node_Id := Low_Bound (Choice);
718 High : constant Node_Id := High_Bound (Choice);
719 Low_Pos : Dimension_Position;
720 High_Pos : Dimension_Position;
723 if Nkind (Low) /= N_Identifier then
724 Error_Msg_N ("bound must denote a dimension name", Low);
726 elsif Nkind (High) /= N_Identifier then
727 Error_Msg_N ("bound must denote a dimension name", High);
730 Low_Pos := Position_In_System (Low, System);
731 High_Pos := Position_In_System (High, System);
733 if Is_Invalid (Low_Pos) then
734 Error_Msg_N ("dimension name& not part of system",
737 elsif Is_Invalid (High_Pos) then
738 Error_Msg_N ("dimension name& not part of system",
741 elsif Low_Pos > High_Pos then
742 Error_Msg_N ("expected low to high range", Choice);
745 for Position in Low_Pos .. High_Pos loop
746 Extract_Power (Expr, Position);
752 -- Others case: OTHERS => EXPRESSION
754 elsif Nkind (Choice) = N_Others_Choice then
755 if Present (Next (Choice)) or else Present (Prev (Choice)) then
757 ("OTHERS must appear alone in a choice list", Choice);
759 elsif Present (Next (Assoc)) then
761 ("OTHERS must appear last in an aggregate", Choice);
763 elsif Others_Seen then
764 Error_Msg_N ("multiple OTHERS not allowed", Choice);
767 -- Fill the non-processed dimensions with the default value
768 -- supplied by others.
770 for Position in Processed'Range loop
771 if not Processed (Position) then
772 Extract_Power (Expr, Position);
779 -- All other cases are erroneous declarations of dimension names
782 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
785 Num_Choices := Num_Choices + 1;
789 Num_Dimensions := Num_Dimensions + 1;
793 -- STEP 3: Consistency of system and dimensions
795 if Present (First (Expressions (Aggr)))
796 and then (First (Expressions (Aggr)) /= Symbol_Expr
797 or else Present (Next (Symbol_Expr)))
798 and then (Num_Choices > 1
799 or else (Num_Choices = 1 and then not Others_Seen))
802 ("named associations cannot follow positional associations", Aggr);
805 if Num_Dimensions > System.Count then
806 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
808 elsif Num_Dimensions < System.Count and then not Others_Seen then
809 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
812 -- STEP 4: Dimension symbol extraction
814 if Present (Symbol_Expr) then
815 if Nkind (Symbol_Expr) = N_Character_Literal then
817 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
818 Symbol := End_String;
821 Symbol := Strval (Symbol_Expr);
824 if String_Length (Symbol) = 0 then
825 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
829 -- STEP 5: Storage of extracted values
831 -- Check that no errors have been detected during the analysis
833 if Errors_Count = Serious_Errors_Detected then
835 -- Check for useless declaration
837 if Symbol = No_String and then not Exists (Dimensions) then
838 Error_Msg_N ("useless dimension declaration", Aggr);
841 if Symbol /= No_String then
842 Set_Symbol (Def_Id, Symbol);
845 if Exists (Dimensions) then
846 Set_Dimensions (Def_Id, Dimensions);
849 end Analyze_Aspect_Dimension;
851 -------------------------------------
852 -- Analyze_Aspect_Dimension_System --
853 -------------------------------------
855 -- with Dimension_System => (
865 -- [Unit_Name =>] IDENTIFIER,
866 -- [Unit_Symbol =>] SYMBOL,
867 -- [Dim_Symbol =>] SYMBOL)
869 procedure Analyze_Aspect_Dimension_System
874 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
875 -- Determine whether type declaration N denotes a numeric derived type
877 -------------------------------
878 -- Is_Derived_Numeric_Type --
879 -------------------------------
881 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
884 Nkind (N) = N_Full_Type_Declaration
885 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
886 and then Is_Numeric_Type
887 (Entity (Subtype_Indication (Type_Definition (N))));
888 end Is_Derived_Numeric_Type;
895 Dim_Symbol : Node_Id;
896 Dim_Symbols : Symbol_Array := No_Symbols;
897 Dim_System : System_Type := Null_System;
900 Unit_Names : Name_Array := No_Names;
901 Unit_Symbol : Node_Id;
902 Unit_Symbols : Symbol_Array := No_Symbols;
905 -- Errors_Count is a count of errors detected by the compiler so far
906 -- just before the extraction of names and symbols in the aggregate
909 -- At the end of the analysis, there is a check to verify that this
910 -- count equals Serious_Errors_Detected i.e. no errors have been
911 -- encountered during the process. Otherwise the System_Table is
914 -- Start of processing for Analyze_Aspect_Dimension_System
917 -- STEP 1: Legality of aspect
919 if not Is_Derived_Numeric_Type (N) then
921 ("aspect& must apply to numeric derived type declaration", N, Id);
925 if Nkind (Aggr) /= N_Aggregate then
926 Error_Msg_N ("aggregate expected", Aggr);
930 -- STEP 2: Structural verification of the dimension aggregate
932 if Present (Component_Associations (Aggr)) then
933 Error_Msg_N ("expected positional aggregate", Aggr);
937 -- STEP 3: Name and Symbol extraction
939 Dim_Aggr := First (Expressions (Aggr));
940 Errors_Count := Serious_Errors_Detected;
941 while Present (Dim_Aggr) loop
942 Position := Position + 1;
944 if Position > High_Position_Bound then
946 ("too many dimensions in system", Aggr);
950 if Nkind (Dim_Aggr) /= N_Aggregate then
951 Error_Msg_N ("aggregate expected", Dim_Aggr);
954 if Present (Component_Associations (Dim_Aggr))
955 and then Present (Expressions (Dim_Aggr))
957 Error_Msg_N ("mixed positional/named aggregate not allowed " &
961 -- Verify each dimension aggregate has three arguments
963 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
964 and then List_Length (Expressions (Dim_Aggr)) /= 3
967 ("three components expected in aggregate", Dim_Aggr);
970 -- Named dimension aggregate
972 if Present (Component_Associations (Dim_Aggr)) then
974 -- Check first argument denotes the unit name
976 Assoc := First (Component_Associations (Dim_Aggr));
977 Choice := First (Choices (Assoc));
978 Unit_Name := Expression (Assoc);
980 if Present (Next (Choice))
981 or else Nkind (Choice) /= N_Identifier
983 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
985 elsif Chars (Choice) /= Name_Unit_Name then
986 Error_Msg_N ("expected Unit_Name, found&", Choice);
989 -- Check the second argument denotes the unit symbol
992 Choice := First (Choices (Assoc));
993 Unit_Symbol := Expression (Assoc);
995 if Present (Next (Choice))
996 or else Nkind (Choice) /= N_Identifier
998 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1000 elsif Chars (Choice) /= Name_Unit_Symbol then
1001 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
1004 -- Check the third argument denotes the dimension symbol
1007 Choice := First (Choices (Assoc));
1008 Dim_Symbol := Expression (Assoc);
1010 if Present (Next (Choice))
1011 or else Nkind (Choice) /= N_Identifier
1013 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1015 elsif Chars (Choice) /= Name_Dim_Symbol then
1016 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1019 -- Positional dimension aggregate
1022 Unit_Name := First (Expressions (Dim_Aggr));
1023 Unit_Symbol := Next (Unit_Name);
1024 Dim_Symbol := Next (Unit_Symbol);
1027 -- Check the first argument for each dimension aggregate is
1030 if Nkind (Unit_Name) = N_Identifier then
1031 Unit_Names (Position) := Chars (Unit_Name);
1033 Error_Msg_N ("expected unit name", Unit_Name);
1036 -- Check the second argument for each dimension aggregate is
1037 -- a string or a character.
1042 N_Character_Literal)
1044 Error_Msg_N ("expected unit symbol (string or character)",
1050 if Nkind (Unit_Symbol) = N_String_Literal then
1051 Unit_Symbols (Position) := Strval (Unit_Symbol);
1058 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1059 Unit_Symbols (Position) := End_String;
1062 -- Verify that the string is not empty
1064 if String_Length (Unit_Symbols (Position)) = 0 then
1066 ("empty string not allowed here", Unit_Symbol);
1070 -- Check the third argument for each dimension aggregate is
1071 -- a string or a character.
1076 N_Character_Literal)
1078 Error_Msg_N ("expected dimension symbol (string or " &
1085 if Nkind (Dim_Symbol) = N_String_Literal then
1086 Dim_Symbols (Position) := Strval (Dim_Symbol);
1093 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1094 Dim_Symbols (Position) := End_String;
1097 -- Verify that the string is not empty
1099 if String_Length (Dim_Symbols (Position)) = 0 then
1101 ("empty string not allowed here", Dim_Symbol);
1110 -- STEP 4: Storage of extracted values
1112 -- Check that no errors have been detected during the analysis
1114 if Errors_Count = Serious_Errors_Detected then
1115 Dim_System.Type_Decl := N;
1116 Dim_System.Unit_Names := Unit_Names;
1117 Dim_System.Unit_Symbols := Unit_Symbols;
1118 Dim_System.Dim_Symbols := Dim_Symbols;
1119 Dim_System.Count := Position;
1120 System_Table.Append (Dim_System);
1122 end Analyze_Aspect_Dimension_System;
1124 -----------------------
1125 -- Analyze_Dimension --
1126 -----------------------
1128 -- This dispatch routine propagates dimensions for each node
1130 procedure Analyze_Dimension (N : Node_Id) is
1132 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1133 -- dimensions for nodes that don't come from source.
1135 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1140 when N_Assignment_Statement =>
1141 Analyze_Dimension_Assignment_Statement (N);
1144 Analyze_Dimension_Binary_Op (N);
1146 when N_Component_Declaration =>
1147 Analyze_Dimension_Component_Declaration (N);
1149 when N_Extended_Return_Statement =>
1150 Analyze_Dimension_Extended_Return_Statement (N);
1152 when N_Attribute_Reference |
1155 N_Indexed_Component |
1156 N_Qualified_Expression |
1157 N_Selected_Component |
1160 N_Unchecked_Type_Conversion =>
1161 Analyze_Dimension_Has_Etype (N);
1163 when N_Object_Declaration =>
1164 Analyze_Dimension_Object_Declaration (N);
1166 when N_Object_Renaming_Declaration =>
1167 Analyze_Dimension_Object_Renaming_Declaration (N);
1169 when N_Simple_Return_Statement =>
1170 if not Comes_From_Extended_Return_Statement (N) then
1171 Analyze_Dimension_Simple_Return_Statement (N);
1174 when N_Subtype_Declaration =>
1175 Analyze_Dimension_Subtype_Declaration (N);
1178 Analyze_Dimension_Unary_Op (N);
1180 when others => null;
1183 end Analyze_Dimension;
1185 ---------------------------------------
1186 -- Analyze_Dimension_Array_Aggregate --
1187 ---------------------------------------
1189 procedure Analyze_Dimension_Array_Aggregate
1191 Comp_Typ : Entity_Id)
1193 Comp_Ass : constant List_Id := Component_Associations (N);
1194 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1195 Exps : constant List_Id := Expressions (N);
1200 Error_Detected : Boolean := False;
1201 -- This flag is used in order to indicate if an error has been detected
1202 -- so far by the compiler in this routine.
1205 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1206 -- base type is not a dimensioned type.
1208 -- Note that here the original node must come from source since the
1209 -- original array aggregate may not have been entirely decorated.
1211 if Ada_Version < Ada_2012
1212 or else not Comes_From_Source (Original_Node (N))
1213 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1218 -- Check whether there is any positional component association
1220 if Is_Empty_List (Exps) then
1221 Comp := First (Comp_Ass);
1223 Comp := First (Exps);
1226 while Present (Comp) loop
1228 -- Get the expression from the component
1230 if Nkind (Comp) = N_Component_Association then
1231 Expr := Expression (Comp);
1236 -- Issue an error if the dimensions of the component type and the
1237 -- dimensions of the component mismatch.
1239 -- Note that we must ensure the expression has been fully analyzed
1240 -- since it may not be decorated at this point. We also don't want to
1241 -- issue the same error message multiple times on the same expression
1242 -- (may happen when an aggregate is converted into a positional
1245 if Comes_From_Source (Original_Node (Expr))
1246 and then Present (Etype (Expr))
1247 and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1248 and then Sloc (Comp) /= Sloc (Prev (Comp))
1250 -- Check if an error has already been encountered so far
1252 if not Error_Detected then
1253 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1254 Error_Detected := True;
1258 ("\expected dimension "
1259 & Dimensions_Msg_Of (Comp_Typ)
1261 & Dimensions_Msg_Of (Expr),
1265 -- Look at the named components right after the positional components
1267 if not Present (Next (Comp))
1268 and then List_Containing (Comp) = Exps
1270 Comp := First (Comp_Ass);
1275 end Analyze_Dimension_Array_Aggregate;
1277 --------------------------------------------
1278 -- Analyze_Dimension_Assignment_Statement --
1279 --------------------------------------------
1281 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1282 Lhs : constant Node_Id := Name (N);
1283 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1284 Rhs : constant Node_Id := Expression (N);
1285 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1287 procedure Error_Dim_Msg_For_Assignment_Statement
1291 -- Error using Error_Msg_N at node N. Output the dimensions of left
1292 -- and right hand sides.
1294 --------------------------------------------
1295 -- Error_Dim_Msg_For_Assignment_Statement --
1296 --------------------------------------------
1298 procedure Error_Dim_Msg_For_Assignment_Statement
1304 Error_Msg_N ("dimensions mismatch in assignment", N);
1305 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1306 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1307 end Error_Dim_Msg_For_Assignment_Statement;
1309 -- Start of processing for Analyze_Dimension_Assignment
1312 if Dims_Of_Lhs /= Dims_Of_Rhs then
1313 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1315 end Analyze_Dimension_Assignment_Statement;
1317 ---------------------------------
1318 -- Analyze_Dimension_Binary_Op --
1319 ---------------------------------
1321 -- Check and propagate the dimensions for binary operators
1322 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1324 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1325 N_Kind : constant Node_Kind := Nkind (N);
1327 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1328 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1329 -- dimensions of both operands.
1331 ---------------------------------
1332 -- Error_Dim_Msg_For_Binary_Op --
1333 ---------------------------------
1335 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1337 Error_Msg_NE ("both operands for operation& must have same " &
1341 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1342 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1343 end Error_Dim_Msg_For_Binary_Op;
1345 -- Start of processing for Analyze_Dimension_Binary_Op
1348 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1349 or else N_Kind in N_Multiplying_Operator
1350 or else N_Kind in N_Op_Compare
1353 L : constant Node_Id := Left_Opnd (N);
1354 Dims_Of_L : constant Dimension_Type := Dimensions_Of (L);
1355 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1356 R : constant Node_Id := Right_Opnd (N);
1357 Dims_Of_R : constant Dimension_Type := Dimensions_Of (R);
1358 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1359 Dims_Of_N : Dimension_Type := Null_Dimension;
1362 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1364 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1366 -- Check both operands have same dimension
1368 if Dims_Of_L /= Dims_Of_R then
1369 Error_Dim_Msg_For_Binary_Op (N, L, R);
1371 -- Check both operands are not dimensionless
1373 if Exists (Dims_Of_L) then
1374 Set_Dimensions (N, Dims_Of_L);
1378 -- N_Op_Multiply or N_Op_Divide case
1380 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1382 -- Check at least one operand is not dimensionless
1384 if L_Has_Dimensions or R_Has_Dimensions then
1386 -- Multiplication case
1388 -- Get both operands dimensions and add them
1390 if N_Kind = N_Op_Multiply then
1391 for Position in Dimension_Type'Range loop
1392 Dims_Of_N (Position) :=
1393 Dims_Of_L (Position) + Dims_Of_R (Position);
1398 -- Get both operands dimensions and subtract them
1401 for Position in Dimension_Type'Range loop
1402 Dims_Of_N (Position) :=
1403 Dims_Of_L (Position) - Dims_Of_R (Position);
1407 if Exists (Dims_Of_N) then
1408 Set_Dimensions (N, Dims_Of_N);
1412 -- Exponentiation case
1414 -- Note: a rational exponent is allowed for dimensioned operand
1416 elsif N_Kind = N_Op_Expon then
1418 -- Check the left operand is not dimensionless. Note that the
1419 -- value of the exponent must be known compile time. Otherwise,
1420 -- the exponentiation evaluation will return an error message.
1422 if L_Has_Dimensions then
1423 if not Compile_Time_Known_Value (R) then
1424 Error_Msg_N ("exponent of dimensioned operand must be " &
1425 "known at compile-time", N);
1429 Exponent_Value : Rational := Zero;
1432 -- Real operand case
1434 if Is_Real_Type (Etype (L)) then
1436 -- Define the exponent as a Rational number
1438 Exponent_Value := Create_Rational_From (R, False);
1440 -- Verify that the exponent cannot be interpreted
1441 -- as a rational, otherwise interpret the exponent
1444 if Exponent_Value = No_Rational then
1446 +Whole (UI_To_Int (Expr_Value (R)));
1449 -- Integer operand case.
1451 -- For integer operand, the exponent cannot be
1452 -- interpreted as a rational.
1455 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1458 for Position in Dimension_Type'Range loop
1459 Dims_Of_N (Position) :=
1460 Dims_Of_L (Position) * Exponent_Value;
1463 if Exists (Dims_Of_N) then
1464 Set_Dimensions (N, Dims_Of_N);
1471 -- For relational operations, only dimension checking is
1472 -- performed (no propagation).
1474 elsif N_Kind in N_Op_Compare then
1475 if (L_Has_Dimensions or R_Has_Dimensions)
1476 and then Dims_Of_L /= Dims_Of_R
1478 Error_Dim_Msg_For_Binary_Op (N, L, R);
1482 -- Removal of dimensions for each operands
1484 Remove_Dimensions (L);
1485 Remove_Dimensions (R);
1488 end Analyze_Dimension_Binary_Op;
1490 ----------------------------
1491 -- Analyze_Dimension_Call --
1492 ----------------------------
1494 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1495 Actuals : constant List_Id := Parameter_Associations (N);
1497 Dims_Of_Formal : Dimension_Type;
1499 Formal_Typ : Entity_Id;
1501 Error_Detected : Boolean := False;
1502 -- This flag is used in order to indicate if an error has been detected
1503 -- so far by the compiler in this routine.
1506 -- Aspect is an Ada 2012 feature. Nothing to do here if the list of
1507 -- actuals is empty.Note that there is no need to check dimensions for
1508 -- calls that don't come from source.
1510 if Ada_Version < Ada_2012
1511 or else not Comes_From_Source (N)
1512 or else Is_Empty_List (Actuals)
1517 -- Special processing for elementary functions
1519 -- For Sqrt call, the resulting dimensions equal to half the dimensions
1520 -- of the actual. For all other elementary calls, this routine check
1521 -- that every actual is dimensionless.
1523 if Nkind (N) = N_Function_Call then
1524 Elementary_Function_Calls : declare
1525 Dims_Of_Call : Dimension_Type;
1526 Ent : Entity_Id := Nam;
1528 function Is_Elementary_Function_Entity
1529 (Sub_Id : Entity_Id) return Boolean;
1530 -- Given Sub_Id, the original subprogram entity, return True if
1531 -- call is to an elementary function
1532 -- (see Ada.Numerics.Generic_Elementary_Functions).
1534 -----------------------------------
1535 -- Is_Elementary_Function_Entity --
1536 -----------------------------------
1538 function Is_Elementary_Function_Entity
1539 (Sub_Id : Entity_Id) return Boolean
1541 Loc : constant Source_Ptr := Sloc (Sub_Id);
1544 -- Is function entity in
1545 -- Ada.Numerics.Generic_Elementary_Functions?
1551 (Cunit_Entity (Get_Source_Unit (Loc)),
1552 Ada_Numerics_Generic_Elementary_Functions);
1553 end Is_Elementary_Function_Entity;
1555 -- Start of processing for Elementary_Function_Calls
1558 -- Get the original subprogram entity following the renaming chain
1560 if Present (Alias (Ent)) then
1564 -- Check the call is an Elementary function call
1566 if Is_Elementary_Function_Entity (Ent) then
1568 -- Sqrt function call case
1570 if Chars (Ent) = Name_Sqrt then
1571 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1573 -- Eavluates the resulting dimensions (i.e. half the
1574 -- dimensions of the actual).
1576 if Exists (Dims_Of_Call) then
1577 for Position in Dims_Of_Call'Range loop
1578 Dims_Of_Call (Position) :=
1579 Dims_Of_Call (Position) *
1580 Rational'(Numerator => 1,
1584 Set_Dimensions (N, Dims_Of_Call);
1587 -- All other elementary functions case. Note that every actual
1588 -- here should be dimensionless.
1591 Actual := First_Actual (N);
1592 while Present (Actual) loop
1593 if Exists (Dimensions_Of (Actual)) then
1595 -- Check if error has already been encountered so far
1597 if not Error_Detected then
1598 Error_Msg_NE ("dimensions mismatch in call of&",
1600 Error_Detected := True;
1603 Error_Msg_N ("\expected dimension [], found " &
1604 Dimensions_Msg_Of (Actual),
1608 Next_Actual (Actual);
1612 -- Nothing more to do for elementary functions
1616 end Elementary_Function_Calls;
1619 -- General case. Check, for each parameter, the dimensions of the actual
1620 -- and its corresponding formal match. Otherwise, complain.
1622 Actual := First_Actual (N);
1623 Formal := First_Formal (Nam);
1625 while Present (Formal) loop
1626 Formal_Typ := Etype (Formal);
1627 Dims_Of_Formal := Dimensions_Of (Formal_Typ);
1629 -- If the formal is not dimensionless, check dimensions of formal and
1630 -- actual match. Otherwise, complain.
1632 if Exists (Dims_Of_Formal)
1633 and then Dimensions_Of (Actual) /= Dims_Of_Formal
1635 -- Check if an error has already been encountered so far
1637 if not Error_Detected then
1638 Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
1639 Error_Detected := True;
1642 Error_Msg_N ("\expected dimension " &
1643 Dimensions_Msg_Of (Formal_Typ) & ", found " &
1644 Dimensions_Msg_Of (Actual),
1648 Next_Actual (Actual);
1649 Next_Formal (Formal);
1652 -- For function calls, propagate the dimensions from the returned type
1653 -- to the function call.
1655 if Nkind (N) = N_Function_Call then
1656 Analyze_Dimension_Has_Etype (N);
1658 end Analyze_Dimension_Call;
1660 ---------------------------------------------
1661 -- Analyze_Dimension_Component_Declaration --
1662 ---------------------------------------------
1664 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1665 Expr : constant Node_Id := Expression (N);
1666 Id : constant Entity_Id := Defining_Identifier (N);
1667 Etyp : constant Entity_Id := Etype (Id);
1668 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1669 Dims_Of_Expr : Dimension_Type;
1671 procedure Error_Dim_Msg_For_Component_Declaration
1675 -- Error using Error_Msg_N at node N. Output the dimensions of the
1676 -- type Etyp and the expression Expr of N.
1678 ---------------------------------------------
1679 -- Error_Dim_Msg_For_Component_Declaration --
1680 ---------------------------------------------
1682 procedure Error_Dim_Msg_For_Component_Declaration
1687 Error_Msg_N ("dimensions mismatch in component declaration", N);
1688 Error_Msg_N ("\expected dimension "
1689 & Dimensions_Msg_Of (Etyp)
1691 & Dimensions_Msg_Of (Expr),
1693 end Error_Dim_Msg_For_Component_Declaration;
1695 -- Start of processing for Analyze_Dimension_Component_Declaration
1698 -- Expression is present
1700 if Present (Expr) then
1701 Dims_Of_Expr := Dimensions_Of (Expr);
1703 -- Check dimensions match
1705 if Dims_Of_Etyp /= Dims_Of_Expr then
1706 -- Numeric literal case. Issue a warning if the object type is not
1707 -- dimensionless to indicate the literal is treated as if its
1708 -- dimension matches the type dimension.
1710 if Nkind_In (Original_Node (Expr), N_Real_Literal,
1713 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
1715 -- Issue a dimension mismatch error for all other cases
1718 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1722 -- Removal of dimensions in expression
1724 Remove_Dimensions (Expr);
1726 end Analyze_Dimension_Component_Declaration;
1728 -------------------------------------------------
1729 -- Analyze_Dimension_Extended_Return_Statement --
1730 -------------------------------------------------
1732 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1733 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
1734 Return_Etyp : constant Entity_Id :=
1735 Etype (Return_Applies_To (Return_Ent));
1736 Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
1737 Return_Obj_Decl : Node_Id;
1738 Return_Obj_Id : Entity_Id;
1739 Return_Obj_Typ : Entity_Id;
1741 procedure Error_Dim_Msg_For_Extended_Return_Statement
1743 Return_Etyp : Entity_Id;
1744 Return_Obj_Typ : Entity_Id);
1745 -- Error using Error_Msg_N at node N. Output the dimensions of the
1746 -- returned type Return_Etyp and the returned object type Return_Obj_Typ
1749 -------------------------------------------------
1750 -- Error_Dim_Msg_For_Extended_Return_Statement --
1751 -------------------------------------------------
1753 procedure Error_Dim_Msg_For_Extended_Return_Statement
1755 Return_Etyp : Entity_Id;
1756 Return_Obj_Typ : Entity_Id)
1759 Error_Msg_N ("dimensions mismatch in extended return statement", N);
1760 Error_Msg_N ("\expected dimension "
1761 & Dimensions_Msg_Of (Return_Etyp)
1763 & Dimensions_Msg_Of (Return_Obj_Typ),
1765 end Error_Dim_Msg_For_Extended_Return_Statement;
1767 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1770 if Present (Return_Obj_Decls) then
1771 Return_Obj_Decl := First (Return_Obj_Decls);
1772 while Present (Return_Obj_Decl) loop
1773 if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1774 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1776 if Is_Return_Object (Return_Obj_Id) then
1777 Return_Obj_Typ := Etype (Return_Obj_Id);
1779 -- Issue an error message if dimensions mismatch
1781 if Dimensions_Of (Return_Etyp) /=
1782 Dimensions_Of (Return_Obj_Typ)
1784 Error_Dim_Msg_For_Extended_Return_Statement
1785 (N, Return_Etyp, Return_Obj_Typ);
1791 Next (Return_Obj_Decl);
1794 end Analyze_Dimension_Extended_Return_Statement;
1796 -----------------------------------------------------
1797 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1798 -----------------------------------------------------
1800 procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
1802 Comp_Id : Entity_Id;
1803 Comp_Typ : Entity_Id;
1806 Error_Detected : Boolean := False;
1807 -- This flag is used in order to indicate if an error has been detected
1808 -- so far by the compiler in this routine.
1811 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1812 -- dimensions for aggregates that don't come from source.
1814 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1818 Comp := First (Component_Associations (N));
1819 while Present (Comp) loop
1820 Comp_Id := Entity (First (Choices (Comp)));
1821 Comp_Typ := Etype (Comp_Id);
1823 -- Check the component type is either a dimensioned type or a
1824 -- dimensioned subtype.
1826 if Has_Dimension_System (Base_Type (Comp_Typ)) then
1827 Expr := Expression (Comp);
1829 -- Issue an error if the dimensions of the component type and the
1830 -- dimensions of the component mismatch.
1832 if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
1834 -- Check if an error has already been encountered so far
1836 if not Error_Detected then
1838 -- Extension aggregate case
1840 if Nkind (N) = N_Extension_Aggregate then
1842 ("dimensions mismatch in extension aggregate", N);
1844 -- Record aggregate case
1848 ("dimensions mismatch in record aggregate", N);
1851 Error_Detected := True;
1855 ("\expected dimension "
1856 & Dimensions_Msg_Of (Comp_Typ)
1858 & Dimensions_Msg_Of (Expr),
1865 end Analyze_Dimension_Extension_Or_Record_Aggregate;
1867 -------------------------------
1868 -- Analyze_Dimension_Formals --
1869 -------------------------------
1871 procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
1872 Dims_Of_Typ : Dimension_Type;
1877 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1878 -- dimensions for sub specs that don't come from source.
1880 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1884 Formal := First (Formals);
1885 while Present (Formal) loop
1886 Typ := Parameter_Type (Formal);
1887 Dims_Of_Typ := Dimensions_Of (Typ);
1889 if Exists (Dims_Of_Typ) then
1891 Expr : constant Node_Id := Expression (Formal);
1894 -- Issue a warning if Expr is a numeric literal and if its
1895 -- dimensions differ with the dimensions of the formal type.
1898 and then Dims_Of_Typ /= Dimensions_Of (Expr)
1899 and then Nkind_In (Original_Node (Expr), N_Real_Literal,
1902 Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
1909 end Analyze_Dimension_Formals;
1911 ---------------------------------
1912 -- Analyze_Dimension_Has_Etype --
1913 ---------------------------------
1915 procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
1916 Etyp : constant Entity_Id := Etype (N);
1917 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1920 -- Propagation of the dimensions from the type
1922 if Exists (Dims_Of_Etyp) then
1923 Set_Dimensions (N, Dims_Of_Etyp);
1925 -- Propagation of the dimensions from the entity for identifier whose
1926 -- entity is a non-dimensionless consant.
1928 elsif Nkind (N) = N_Identifier
1929 and then Exists (Dimensions_Of (Entity (N)))
1931 Set_Dimensions (N, Dimensions_Of (Entity (N)));
1934 -- Removal of dimensions in expression
1938 when N_Attribute_Reference |
1939 N_Indexed_Component =>
1942 Exprs : constant List_Id := Expressions (N);
1945 if Present (Exprs) then
1946 Expr := First (Exprs);
1947 while Present (Expr) loop
1948 Remove_Dimensions (Expr);
1954 when N_Qualified_Expression |
1956 N_Unchecked_Type_Conversion =>
1957 Remove_Dimensions (Expression (N));
1959 when N_Selected_Component =>
1960 Remove_Dimensions (Selector_Name (N));
1962 when others => null;
1965 end Analyze_Dimension_Has_Etype;
1967 ------------------------------------------
1968 -- Analyze_Dimension_Object_Declaration --
1969 ------------------------------------------
1971 procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
1972 Expr : constant Node_Id := Expression (N);
1973 Id : constant Entity_Id := Defining_Identifier (N);
1974 Etyp : constant Entity_Id := Etype (Id);
1975 Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1976 Dim_Of_Expr : Dimension_Type;
1978 procedure Error_Dim_Msg_For_Object_Declaration
1982 -- Error using Error_Msg_N at node N. Output the dimensions of the
1983 -- type Etyp and of the expression Expr.
1985 ------------------------------------------
1986 -- Error_Dim_Msg_For_Object_Declaration --
1987 ------------------------------------------
1989 procedure Error_Dim_Msg_For_Object_Declaration
1994 Error_Msg_N ("dimensions mismatch in object declaration", N);
1996 ("\expected dimension "
1997 & Dimensions_Msg_Of (Etyp)
1999 & Dimensions_Msg_Of (Expr),
2001 end Error_Dim_Msg_For_Object_Declaration;
2003 -- Start of processing for Analyze_Dimension_Object_Declaration
2006 -- Expression is present
2008 if Present (Expr) then
2009 Dim_Of_Expr := Dimensions_Of (Expr);
2011 -- Check dimensions match
2013 if Dim_Of_Expr /= Dim_Of_Etyp then
2015 -- Numeric literal case. Issue a warning if the object type is not
2016 -- dimensionless to indicate the literal is treated as if its
2017 -- dimension matches the type dimension.
2019 if Nkind_In (Original_Node (Expr), N_Real_Literal,
2022 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
2024 -- Case of object is a constant whose type is a dimensioned type
2026 elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
2028 -- Propagate dimension from expression to object entity
2030 Set_Dimensions (Id, Dim_Of_Expr);
2032 -- For all other cases, issue an error message
2035 Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
2039 -- Removal of dimensions in expression
2041 Remove_Dimensions (Expr);
2043 end Analyze_Dimension_Object_Declaration;
2045 ---------------------------------------------------
2046 -- Analyze_Dimension_Object_Renaming_Declaration --
2047 ---------------------------------------------------
2049 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
2050 Renamed_Name : constant Node_Id := Name (N);
2051 Sub_Mark : constant Node_Id := Subtype_Mark (N);
2053 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2056 Renamed_Name : Node_Id);
2057 -- Error using Error_Msg_N at node N. Output the dimensions of
2058 -- Sub_Mark and of Renamed_Name.
2060 ---------------------------------------------------
2061 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2062 ---------------------------------------------------
2064 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2067 Renamed_Name : Node_Id) is
2069 Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
2071 ("\expected dimension "
2072 & Dimensions_Msg_Of (Sub_Mark)
2074 & Dimensions_Msg_Of (Renamed_Name),
2076 end Error_Dim_Msg_For_Object_Renaming_Declaration;
2078 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2081 if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
2082 Error_Dim_Msg_For_Object_Renaming_Declaration
2083 (N, Sub_Mark, Renamed_Name);
2085 end Analyze_Dimension_Object_Renaming_Declaration;
2087 -----------------------------------------------
2088 -- Analyze_Dimension_Simple_Return_Statement --
2089 -----------------------------------------------
2091 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
2092 Expr : constant Node_Id := Expression (N);
2093 Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
2094 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
2095 Return_Etyp : constant Entity_Id :=
2096 Etype (Return_Applies_To (Return_Ent));
2097 Dims_Of_Return_Etyp : constant Dimension_Type :=
2098 Dimensions_Of (Return_Etyp);
2100 procedure Error_Dim_Msg_For_Simple_Return_Statement
2102 Return_Etyp : Entity_Id;
2104 -- Error using Error_Msg_N at node N. Output the dimensions of the
2105 -- returned type Return_Etyp and the returned expression Expr of N.
2107 -----------------------------------------------
2108 -- Error_Dim_Msg_For_Simple_Return_Statement --
2109 -----------------------------------------------
2111 procedure Error_Dim_Msg_For_Simple_Return_Statement
2113 Return_Etyp : Entity_Id;
2117 Error_Msg_N ("dimensions mismatch in return statement", N);
2119 ("\expected dimension "
2120 & Dimensions_Msg_Of (Return_Etyp)
2122 & Dimensions_Msg_Of (Expr),
2124 end Error_Dim_Msg_For_Simple_Return_Statement;
2126 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
2129 if Dims_Of_Return_Etyp /= Dims_Of_Expr then
2130 Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
2131 Remove_Dimensions (Expr);
2133 end Analyze_Dimension_Simple_Return_Statement;
2135 -------------------------------------------
2136 -- Analyze_Dimension_Subtype_Declaration --
2137 -------------------------------------------
2139 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id) is
2140 Id : constant Entity_Id := Defining_Identifier (N);
2141 Dims_Of_Id : constant Dimension_Type := Dimensions_Of (Id);
2142 Dims_Of_Etyp : Dimension_Type;
2146 -- No constraint case in subtype declaration
2148 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
2149 Etyp := Etype (Subtype_Indication (N));
2150 Dims_Of_Etyp := Dimensions_Of (Etyp);
2152 if Exists (Dims_Of_Etyp) then
2154 -- If subtype already has a dimension (from Aspect_Dimension),
2155 -- it cannot inherit a dimension from its subtype.
2157 if Exists (Dims_Of_Id) then
2159 ("subtype& already" & Dimensions_Msg_Of (Id, True), N);
2162 Set_Dimensions (Id, Dims_Of_Etyp);
2163 Set_Symbol (Id, Symbol_Of (Etyp));
2167 -- Constraint present in subtype declaration
2170 Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
2171 Dims_Of_Etyp := Dimensions_Of (Etyp);
2173 if Exists (Dims_Of_Etyp) then
2174 Set_Dimensions (Id, Dims_Of_Etyp);
2175 Set_Symbol (Id, Symbol_Of (Etyp));
2178 end Analyze_Dimension_Subtype_Declaration;
2180 --------------------------------
2181 -- Analyze_Dimension_Unary_Op --
2182 --------------------------------
2184 procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
2187 when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
2189 R : constant Node_Id := Right_Opnd (N);
2192 -- Propagate the dimension if the operand is not dimensionless
2194 Move_Dimensions (R, N);
2197 when others => null;
2200 end Analyze_Dimension_Unary_Op;
2202 --------------------------
2203 -- Create_Rational_From --
2204 --------------------------
2206 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2208 -- A rational number is a number that can be expressed as the quotient or
2209 -- fraction a/b of two integers, where b is non-zero positive.
2211 function Create_Rational_From
2213 Complain : Boolean) return Rational
2215 Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
2216 Result : Rational := No_Rational;
2218 function Process_Minus (N : Node_Id) return Rational;
2219 -- Create a rational from a N_Op_Minus node
2221 function Process_Divide (N : Node_Id) return Rational;
2222 -- Create a rational from a N_Op_Divide node
2224 function Process_Literal (N : Node_Id) return Rational;
2225 -- Create a rational from a N_Integer_Literal node
2231 function Process_Minus (N : Node_Id) return Rational is
2232 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2236 -- Operand is an integer literal
2238 if Nkind (Right) = N_Integer_Literal then
2239 Result := -Process_Literal (Right);
2241 -- Operand is a divide operator
2243 elsif Nkind (Right) = N_Op_Divide then
2244 Result := -Process_Divide (Right);
2247 Result := No_Rational;
2253 --------------------
2254 -- Process_Divide --
2255 --------------------
2257 function Process_Divide (N : Node_Id) return Rational is
2258 Left : constant Node_Id := Original_Node (Left_Opnd (N));
2259 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2260 Left_Rat : Rational;
2261 Result : Rational := No_Rational;
2262 Right_Rat : Rational;
2265 -- Both left and right operands are an integer literal
2267 if Nkind (Left) = N_Integer_Literal
2268 and then Nkind (Right) = N_Integer_Literal
2270 Left_Rat := Process_Literal (Left);
2271 Right_Rat := Process_Literal (Right);
2272 Result := Left_Rat / Right_Rat;
2278 ---------------------
2279 -- Process_Literal --
2280 ---------------------
2282 function Process_Literal (N : Node_Id) return Rational is
2284 return +Whole (UI_To_Int (Intval (N)));
2285 end Process_Literal;
2287 -- Start of processing for Create_Rational_From
2290 -- Check the expression is either a division of two integers or an
2291 -- integer itself. Note that the check applies to the original node
2292 -- since the node could have already been rewritten.
2294 -- Integer literal case
2296 if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
2297 Result := Process_Literal (Or_Node_Of_Expr);
2299 -- Divide operator case
2301 elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
2302 Result := Process_Divide (Or_Node_Of_Expr);
2304 -- Minus operator case
2306 elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
2307 Result := Process_Minus (Or_Node_Of_Expr);
2310 -- When Expr cannot be interpreted as a rational and Complain is true,
2311 -- generate an error message.
2313 if Complain and then Result = No_Rational then
2314 Error_Msg_N ("rational expected", Expr);
2318 end Create_Rational_From;
2324 function Dimensions_Of (N : Node_Id) return Dimension_Type is
2326 return Dimension_Table.Get (N);
2329 -----------------------
2330 -- Dimensions_Msg_Of --
2331 -----------------------
2333 function Dimensions_Msg_Of
2335 Description_Needed : Boolean := False) return String
2337 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2338 Dimensions_Msg : Name_Id;
2339 System : System_Type;
2342 -- Initialization of Name_Buffer
2346 -- N is not dimensionless
2348 if Exists (Dims_Of_N) then
2349 System := System_Of (Base_Type (Etype (N)));
2351 -- When Description_Needed, add to string "has dimension " before the
2352 -- actual dimension.
2354 if Description_Needed then
2355 Add_Str_To_Name_Buffer ("has dimension ");
2358 Add_String_To_Name_Buffer
2359 (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
2361 -- N is dimensionless
2363 -- When Description_Needed, return "is dimensionless"
2365 elsif Description_Needed then
2366 Add_Str_To_Name_Buffer ("is dimensionless");
2368 -- Otherwise, return "[]"
2371 Add_Str_To_Name_Buffer ("[]");
2374 Dimensions_Msg := Name_Find;
2375 return Get_Name_String (Dimensions_Msg);
2376 end Dimensions_Msg_Of;
2378 --------------------------
2379 -- Dimension_Table_Hash --
2380 --------------------------
2382 function Dimension_Table_Hash
2383 (Key : Node_Id) return Dimension_Table_Range
2386 return Dimension_Table_Range (Key mod 511);
2387 end Dimension_Table_Hash;
2389 -------------------------------------
2390 -- Dim_Warning_For_Numeric_Literal --
2391 -------------------------------------
2393 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
2395 -- Initialize name buffer
2399 Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
2401 -- Insert a blank between the literal and the symbol
2402 Add_Str_To_Name_Buffer (" ");
2404 Add_String_To_Name_Buffer (Symbol_Of (Typ));
2406 Error_Msg_Name_1 := Name_Find;
2407 Error_Msg_N ("?assumed to be%%", N);
2408 end Dim_Warning_For_Numeric_Literal;
2410 ----------------------------------------
2411 -- Eval_Op_Expon_For_Dimensioned_Type --
2412 ----------------------------------------
2414 -- Evaluate the expon operator for real dimensioned type.
2416 -- Note that if the exponent is an integer (denominator = 1) the node is
2417 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2419 procedure Eval_Op_Expon_For_Dimensioned_Type
2423 R : constant Node_Id := Right_Opnd (N);
2424 R_Value : Rational := No_Rational;
2427 if Is_Real_Type (Btyp) then
2428 R_Value := Create_Rational_From (R, False);
2431 -- Check that the exponent is not an integer
2433 if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
2434 Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
2438 end Eval_Op_Expon_For_Dimensioned_Type;
2440 ------------------------------------------
2441 -- Eval_Op_Expon_With_Rational_Exponent --
2442 ------------------------------------------
2444 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2445 -- Rational and not only an Integer like for dimensionless operands. For
2446 -- that particular case, the left operand is rewritten as a function call
2447 -- using the function Expon_LLF from s-llflex.ads.
2449 procedure Eval_Op_Expon_With_Rational_Exponent
2451 Exponent_Value : Rational)
2453 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2454 L : constant Node_Id := Left_Opnd (N);
2455 Etyp_Of_L : constant Entity_Id := Etype (L);
2456 Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2457 Loc : constant Source_Ptr := Sloc (N);
2460 Dim_Power : Rational;
2461 List_Of_Dims : List_Id;
2462 New_Aspect : Node_Id;
2463 New_Aspects : List_Id;
2466 New_Subtyp_Decl_For_L : Node_Id;
2467 System : System_Type;
2470 -- Case when the operand is not dimensionless
2472 if Exists (Dims_Of_N) then
2474 -- Get the corresponding System_Type to know the exact number of
2475 -- dimensions in the system.
2477 System := System_Of (Btyp_Of_L);
2479 -- Generation of a new subtype with the proper dimensions
2481 -- In order to rewrite the operator as a type conversion, a new
2482 -- dimensioned subtype with the resulting dimensions of the
2483 -- exponentiation must be created.
2487 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2488 -- System : constant System_Id :=
2489 -- Get_Dimension_System_Id (Btyp_Of_L);
2490 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2491 -- Dimension_Systems.Table (System).Dimension_Count;
2493 -- subtype T is Btyp_Of_L
2496 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2497 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2499 -- Dims_Of_N (Num_Of_Dims).Numerator /
2500 -- Dims_Of_N (Num_Of_Dims).Denominator);
2502 -- Step 1: Generate the new aggregate for the aspect Dimension
2504 New_Aspects := Empty_List;
2505 List_Of_Dims := New_List;
2507 for Position in Dims_Of_N'First .. System.Count loop
2508 Dim_Power := Dims_Of_N (Position);
2509 Append_To (List_Of_Dims,
2510 Make_Op_Divide (Loc,
2512 Make_Integer_Literal (Loc,
2513 Int (Dim_Power.Numerator)),
2515 Make_Integer_Literal (Loc,
2516 Int (Dim_Power.Denominator))));
2519 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2522 Make_Aspect_Specification (Loc,
2523 Identifier => Make_Identifier (Loc, Name_Dimension),
2524 Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2526 -- Step 3: Make a temporary identifier for the new subtype
2528 New_Id := Make_Temporary (Loc, 'T');
2529 Set_Is_Internal (New_Id);
2531 -- Step 4: Declaration of the new subtype
2533 New_Subtyp_Decl_For_L :=
2534 Make_Subtype_Declaration (Loc,
2535 Defining_Identifier => New_Id,
2536 Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc));
2538 Append (New_Aspect, New_Aspects);
2539 Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
2540 Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2542 Analyze (New_Subtyp_Decl_For_L);
2544 -- Case where the operand is dimensionless
2547 New_Id := Btyp_Of_L;
2550 -- Replacement of N by New_N
2554 -- Actual_1 := Long_Long_Float (L),
2556 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2557 -- Long_Long_Float (Exponent_Value.Denominator);
2559 -- (T (Expon_LLF (Actual_1, Actual_2)));
2561 -- where T is the subtype declared in step 1
2563 -- The node is rewritten as a type conversion
2565 -- Step 1: Creation of the two parameters of Expon_LLF function call
2568 Make_Type_Conversion (Loc,
2569 Subtype_Mark => New_Reference_To (Standard_Long_Long_Float, Loc),
2570 Expression => Relocate_Node (L));
2573 Make_Op_Divide (Loc,
2575 Make_Real_Literal (Loc,
2576 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2578 Make_Real_Literal (Loc,
2579 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2581 -- Step 2: Creation of New_N
2584 Make_Type_Conversion (Loc,
2585 Subtype_Mark => New_Reference_To (New_Id, Loc),
2587 Make_Function_Call (Loc,
2588 Name => New_Reference_To (RTE (RE_Expon_LLF), Loc),
2589 Parameter_Associations => New_List (
2590 Actual_1, Actual_2)));
2592 -- Step 3: Rewrite N with the result
2595 Set_Etype (N, New_Id);
2596 Analyze_And_Resolve (N, New_Id);
2597 end Eval_Op_Expon_With_Rational_Exponent;
2603 function Exists (Dim : Dimension_Type) return Boolean is
2605 return Dim /= Null_Dimension;
2608 function Exists (Str : String_Id) return Boolean is
2610 return Str /= No_String;
2613 function Exists (Sys : System_Type) return Boolean is
2615 return Sys /= Null_System;
2618 ---------------------------------
2619 -- Expand_Put_Call_With_Symbol --
2620 ---------------------------------
2622 -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2623 -- (System.Dim.Integer_IO), the default string parameter must be rewritten
2624 -- to include the unit symbols (resp. dimension symbols) in the output
2625 -- of a dimensioned object. Note that if a value is already supplied for
2626 -- parameter Symbol, this routine doesn't do anything.
2628 -- Case 1. Item is dimensionless
2630 -- * Put : Item appears without a suffix
2632 -- * Put_Dim_Of : the output is []
2634 -- Obj : Mks_Type := 2.6;
2635 -- Put (Obj, 1, 1, 0);
2636 -- Put_Dim_Of (Obj);
2638 -- The corresponding outputs are:
2642 -- Case 2. Item has a dimension
2644 -- * Put : If the type of Item is a dimensioned subtype whose
2645 -- symbol is not empty, then the symbol appears as a
2646 -- suffix. Otherwise, a new string is created and appears
2647 -- as a suffix of Item. This string results in the
2648 -- successive concatanations between each unit symbol
2649 -- raised by its corresponding dimension power from the
2650 -- dimensions of Item.
2652 -- * Put_Dim_Of : The output is a new string resulting in the successive
2653 -- concatanations between each dimension symbol raised by
2654 -- its corresponding dimension power from the dimensions of
2657 -- subtype Random is Mks_Type
2664 -- Obj : Random := 5.0;
2666 -- Put_Dim_Of (Obj);
2668 -- The corresponding outputs are:
2669 -- $5.0 m**3.cd**(-1)
2672 procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
2673 Actuals : constant List_Id := Parameter_Associations (N);
2674 Loc : constant Source_Ptr := Sloc (N);
2675 Name_Call : constant Node_Id := Name (N);
2676 New_Actuals : constant List_Id := New_List;
2678 Dims_Of_Actual : Dimension_Type;
2680 New_Str_Lit : Node_Id := Empty;
2681 Symbols : String_Id;
2683 Is_Put_Dim_Of : Boolean := False;
2684 -- This flag is used in order to differentiate routines Put and
2685 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2686 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2688 function Has_Symbols return Boolean;
2689 -- Return True if the current Put call already has a parameter
2690 -- association for parameter "Symbols" with the correct string of
2693 function Is_Procedure_Put_Call return Boolean;
2694 -- Return True if the current call is a call of an instantiation of a
2695 -- procedure Put defined in the package System.Dim.Float_IO and
2696 -- System.Dim.Integer_IO.
2698 function Item_Actual return Node_Id;
2699 -- Return the item actual parameter node in the output call
2705 function Has_Symbols return Boolean is
2707 Actual_Str : Node_Id;
2710 Actual := First (Actuals);
2712 -- Look for a symbols parameter association in the list of actuals
2714 while Present (Actual) loop
2715 -- Positional parameter association case when the actual is a
2718 if Nkind (Actual) = N_String_Literal then
2719 Actual_Str := Actual;
2721 -- Named parameter association case when the selector name is
2724 elsif Nkind (Actual) = N_Parameter_Association
2725 and then Chars (Selector_Name (Actual)) = Name_Symbol
2727 Actual_Str := Explicit_Actual_Parameter (Actual);
2729 -- Ignore all other cases
2732 Actual_Str := Empty;
2735 if Present (Actual_Str) then
2736 -- Return True if the actual comes from source or if the string
2737 -- of symbols doesn't have the default value (i.e. it is "").
2739 if Comes_From_Source (Actual)
2740 or else String_Length (Strval (Actual_Str)) /= 0
2742 -- Complain only if the actual comes from source or if it
2743 -- hasn't been fully analyzed yet.
2745 if Comes_From_Source (Actual)
2746 or else not Analyzed (Actual)
2748 Error_Msg_N ("Symbol parameter should not be provided",
2750 Error_Msg_N ("\reserved for compiler use only", Actual);
2763 -- At this point, the call has no parameter association. Look to the
2764 -- last actual since the symbols parameter is the last one.
2766 return Nkind (Last (Actuals)) = N_String_Literal;
2769 ---------------------------
2770 -- Is_Procedure_Put_Call --
2771 ---------------------------
2773 function Is_Procedure_Put_Call return Boolean is
2778 -- There are three different Put (resp. Put_Dim_Of) routines in each
2779 -- generic dim IO package. Verify the current procedure call is one
2782 if Is_Entity_Name (Name_Call) then
2783 Ent := Entity (Name_Call);
2785 -- Get the original subprogram entity following the renaming chain
2787 if Present (Alias (Ent)) then
2793 -- Check the name of the entity subprogram is Put (resp.
2794 -- Put_Dim_Of) and verify this entity is located in either
2795 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2797 if Loc > No_Location
2798 and then Is_Dim_IO_Package_Entity
2799 (Cunit_Entity (Get_Source_Unit (Loc)))
2801 if Chars (Ent) = Name_Put_Dim_Of then
2802 Is_Put_Dim_Of := True;
2805 elsif Chars (Ent) = Name_Put then
2812 end Is_Procedure_Put_Call;
2818 function Item_Actual return Node_Id is
2822 -- Look for the item actual as a parameter association
2824 Actual := First (Actuals);
2825 while Present (Actual) loop
2826 if Nkind (Actual) = N_Parameter_Association
2827 and then Chars (Selector_Name (Actual)) = Name_Item
2829 return Explicit_Actual_Parameter (Actual);
2835 -- Case where the item has been defined without an association
2837 Actual := First (Actuals);
2839 -- Depending on the procedure Put, Item actual could be first or
2840 -- second in the list of actuals.
2842 if Has_Dimension_System (Base_Type (Etype (Actual))) then
2845 return Next (Actual);
2849 -- Start of processing for Expand_Put_Call_With_Symbol
2852 if Is_Procedure_Put_Call and then not Has_Symbols then
2853 Actual := Item_Actual;
2854 Dims_Of_Actual := Dimensions_Of (Actual);
2855 Etyp := Etype (Actual);
2859 if Is_Put_Dim_Of then
2861 -- Check that the item is not dimensionless
2863 -- Create the new String_Literal with the new String_Id generated
2864 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
2866 if Exists (Dims_Of_Actual) then
2868 Make_String_Literal (Loc,
2869 From_Dim_To_Str_Of_Dim_Symbols
2870 (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
2872 -- If dimensionless, the output is []
2876 Make_String_Literal (Loc, "[]");
2882 -- Add the symbol as a suffix of the value if the subtype has a
2883 -- unit symbol or if the parameter is not dimensionless.
2885 if Exists (Symbol_Of (Etyp)) then
2886 Symbols := Symbol_Of (Etyp);
2888 Symbols := From_Dim_To_Str_Of_Unit_Symbols
2889 (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
2892 -- Check Symbols exists
2894 if Exists (Symbols) then
2897 -- Put a space between the value and the dimension
2899 Store_String_Char (' ');
2900 Store_String_Chars (Symbols);
2901 New_Str_Lit := Make_String_Literal (Loc, End_String);
2905 if Present (New_Str_Lit) then
2907 -- Insert all actuals in New_Actuals
2909 Actual := First (Actuals);
2910 while Present (Actual) loop
2912 -- Copy every actuals in New_Actuals except the Symbols
2913 -- parameter association.
2915 if Nkind (Actual) = N_Parameter_Association
2916 and then Chars (Selector_Name (Actual)) /= Name_Symbol
2918 Append_To (New_Actuals,
2919 Make_Parameter_Association (Loc,
2920 Selector_Name => New_Copy (Selector_Name (Actual)),
2921 Explicit_Actual_Parameter =>
2922 New_Copy (Explicit_Actual_Parameter (Actual))));
2924 elsif Nkind (Actual) /= N_Parameter_Association then
2925 Append_To (New_Actuals, New_Copy (Actual));
2931 -- Create new Symbols param association and append to New_Actuals
2933 Append_To (New_Actuals,
2934 Make_Parameter_Association (Loc,
2935 Selector_Name => Make_Identifier (Loc, Name_Symbol),
2936 Explicit_Actual_Parameter => New_Str_Lit));
2938 -- Rewrite and analyze the procedure call
2941 Make_Procedure_Call_Statement (Loc,
2942 Name => New_Copy (Name_Call),
2943 Parameter_Associations => New_Actuals));
2948 end Expand_Put_Call_With_Symbol;
2950 ------------------------------------
2951 -- From_Dim_To_Str_Of_Dim_Symbols --
2952 ------------------------------------
2954 -- Given a dimension vector and the corresponding dimension system, create
2955 -- a String_Id to output dimension symbols corresponding to the dimensions
2956 -- Dims. If In_Error_Msg is True, there is a special handling for character
2957 -- asterisk * which is an insertion character in error messages.
2959 function From_Dim_To_Str_Of_Dim_Symbols
2960 (Dims : Dimension_Type;
2961 System : System_Type;
2962 In_Error_Msg : Boolean := False) return String_Id
2964 Dim_Power : Rational;
2965 First_Dim : Boolean := True;
2967 procedure Store_String_Oexpon;
2968 -- Store the expon operator symbol "**" in the string. In error
2969 -- messages, asterisk * is a special character and must be quoted
2970 -- to be placed literally into the message.
2972 -------------------------
2973 -- Store_String_Oexpon --
2974 -------------------------
2976 procedure Store_String_Oexpon is
2978 if In_Error_Msg then
2979 Store_String_Chars ("'*'*");
2981 Store_String_Chars ("**");
2983 end Store_String_Oexpon;
2985 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
2988 -- Initialization of the new String_Id
2992 -- Store the dimension symbols inside boxes
2994 Store_String_Char ('[');
2996 for Position in Dimension_Type'Range loop
2997 Dim_Power := Dims (Position);
2998 if Dim_Power /= Zero then
3003 Store_String_Char ('.');
3006 Store_String_Chars (System.Dim_Symbols (Position));
3008 -- Positive dimension case
3010 if Dim_Power.Numerator > 0 then
3013 if Dim_Power.Denominator = 1 then
3014 if Dim_Power.Numerator /= 1 then
3015 Store_String_Oexpon;
3016 Store_String_Int (Int (Dim_Power.Numerator));
3019 -- Rational case when denominator /= 1
3022 Store_String_Oexpon;
3023 Store_String_Char ('(');
3024 Store_String_Int (Int (Dim_Power.Numerator));
3025 Store_String_Char ('/');
3026 Store_String_Int (Int (Dim_Power.Denominator));
3027 Store_String_Char (')');
3030 -- Negative dimension case
3033 Store_String_Oexpon;
3034 Store_String_Char ('(');
3035 Store_String_Char ('-');
3036 Store_String_Int (Int (-Dim_Power.Numerator));
3040 if Dim_Power.Denominator = 1 then
3041 Store_String_Char (')');
3043 -- Rational case when denominator /= 1
3046 Store_String_Char ('/');
3047 Store_String_Int (Int (Dim_Power.Denominator));
3048 Store_String_Char (')');
3054 Store_String_Char (']');
3056 end From_Dim_To_Str_Of_Dim_Symbols;
3058 -------------------------------------
3059 -- From_Dim_To_Str_Of_Unit_Symbols --
3060 -------------------------------------
3062 -- Given a dimension vector and the corresponding dimension system,
3063 -- create a String_Id to output the unit symbols corresponding to the
3066 function From_Dim_To_Str_Of_Unit_Symbols
3067 (Dims : Dimension_Type;
3068 System : System_Type) return String_Id
3070 Dim_Power : Rational;
3071 First_Dim : Boolean := True;
3074 -- Return No_String if dimensionless
3076 if not Exists (Dims) then
3080 -- Initialization of the new String_Id
3084 for Position in Dimension_Type'Range loop
3085 Dim_Power := Dims (Position);
3087 if Dim_Power /= Zero then
3092 Store_String_Char ('.');
3095 Store_String_Chars (System.Unit_Symbols (Position));
3097 -- Positive dimension case
3099 if Dim_Power.Numerator > 0 then
3103 if Dim_Power.Denominator = 1 then
3104 if Dim_Power.Numerator /= 1 then
3105 Store_String_Chars ("**");
3106 Store_String_Int (Int (Dim_Power.Numerator));
3109 -- Rational case when denominator /= 1
3112 Store_String_Chars ("**");
3113 Store_String_Char ('(');
3114 Store_String_Int (Int (Dim_Power.Numerator));
3115 Store_String_Char ('/');
3116 Store_String_Int (Int (Dim_Power.Denominator));
3117 Store_String_Char (')');
3120 -- Negative dimension case
3123 Store_String_Chars ("**");
3124 Store_String_Char ('(');
3125 Store_String_Char ('-');
3126 Store_String_Int (Int (-Dim_Power.Numerator));
3130 if Dim_Power.Denominator = 1 then
3131 Store_String_Char (')');
3133 -- Rational case when denominator /= 1
3136 Store_String_Char ('/');
3137 Store_String_Int (Int (Dim_Power.Denominator));
3138 Store_String_Char (')');
3145 end From_Dim_To_Str_Of_Unit_Symbols;
3151 function GCD (Left, Right : Whole) return Int is
3171 --------------------------
3172 -- Has_Dimension_System --
3173 --------------------------
3175 function Has_Dimension_System (Typ : Entity_Id) return Boolean is
3177 return Exists (System_Of (Typ));
3178 end Has_Dimension_System;
3180 ------------------------------
3181 -- Is_Dim_IO_Package_Entity --
3182 ------------------------------
3184 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
3186 -- Check the package entity corresponds to System.Dim.Float_IO or
3187 -- System.Dim.Integer_IO.
3190 Is_RTU (E, System_Dim_Float_IO)
3191 or Is_RTU (E, System_Dim_Integer_IO);
3192 end Is_Dim_IO_Package_Entity;
3194 -------------------------------------
3195 -- Is_Dim_IO_Package_Instantiation --
3196 -------------------------------------
3198 function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
3199 Gen_Id : constant Node_Id := Name (N);
3202 -- Check that the instantiated package is either System.Dim.Float_IO
3203 -- or System.Dim.Integer_IO.
3206 Is_Entity_Name (Gen_Id)
3207 and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
3208 end Is_Dim_IO_Package_Instantiation;
3214 function Is_Invalid (Position : Dimension_Position) return Boolean is
3216 return Position = Invalid_Position;
3219 ---------------------
3220 -- Move_Dimensions --
3221 ---------------------
3223 procedure Move_Dimensions (From, To : Node_Id) is
3224 Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
3227 if Ada_Version < Ada_2012 then
3231 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3233 if Exists (Dims_Of_From) then
3234 Set_Dimensions (To, Dims_Of_From);
3235 Remove_Dimensions (From);
3237 end Move_Dimensions;
3243 function Reduce (X : Rational) return Rational is
3245 if X.Numerator = 0 then
3250 G : constant Int := GCD (X.Numerator, X.Denominator);
3252 return Rational'(Numerator => Whole (Int (X.Numerator) / G),
3253 Denominator => Whole (Int (X.Denominator) / G));
3257 -----------------------
3258 -- Remove_Dimensions --
3259 -----------------------
3261 procedure Remove_Dimensions (N : Node_Id) is
3262 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3264 if Exists (Dims_Of_N) then
3265 Dimension_Table.Remove (N);
3267 end Remove_Dimensions;
3269 -----------------------------------
3270 -- Remove_Dimension_In_Statement --
3271 -----------------------------------
3273 -- Removal of dimension in statement as part of the Analyze_Statements
3274 -- routine (see package Sem_Ch5).
3276 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3278 if Ada_Version < Ada_2012 then
3282 -- Remove dimension in parameter specifications for accept statement
3284 if Nkind (Stmt) = N_Accept_Statement then
3286 Param : Node_Id := First (Parameter_Specifications (Stmt));
3288 while Present (Param) loop
3289 Remove_Dimensions (Param);
3294 -- Remove dimension of name and expression in assignments
3296 elsif Nkind (Stmt) = N_Assignment_Statement then
3297 Remove_Dimensions (Expression (Stmt));
3298 Remove_Dimensions (Name (Stmt));
3300 end Remove_Dimension_In_Statement;
3302 --------------------
3303 -- Set_Dimensions --
3304 --------------------
3306 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3308 pragma Assert (OK_For_Dimension (Nkind (N)));
3309 pragma Assert (Exists (Val));
3311 Dimension_Table.Set (N, Val);
3318 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3320 Symbol_Table.Set (E, Val);
3323 ---------------------------------
3324 -- String_From_Numeric_Literal --
3325 ---------------------------------
3327 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3328 Loc : constant Source_Ptr := Sloc (N);
3329 Sbuffer : constant Source_Buffer_Ptr :=
3330 Source_Text (Get_Source_File_Index (Loc));
3331 Src_Ptr : Source_Ptr := Loc;
3332 C : Character := Sbuffer (Src_Ptr);
3333 -- Current source program character
3335 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3336 -- Return True if C belongs to a numeric literal
3338 -------------------------------
3339 -- Belong_To_Numeric_Literal --
3340 -------------------------------
3342 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3358 -- Make sure '+' or '-' is part of an exponent.
3362 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3364 return Prev_C = 'e' or else Prev_C = 'E';
3367 -- All other character doesn't belong to a numeric literal
3372 end Belong_To_Numeric_Literal;
3374 -- Start of processing for String_From_Numeric_Literal
3378 while Belong_To_Numeric_Literal (C) loop
3379 Store_String_Char (C);
3380 Src_Ptr := Src_Ptr + 1;
3381 C := Sbuffer (Src_Ptr);
3385 end String_From_Numeric_Literal;
3391 function Symbol_Of (E : Entity_Id) return String_Id is
3392 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3394 if Subtype_Symbol /= No_String then
3395 return Subtype_Symbol;
3397 return From_Dim_To_Str_Of_Unit_Symbols
3398 (Dimensions_Of (E), System_Of (Base_Type (E)));
3402 -----------------------
3403 -- Symbol_Table_Hash --
3404 -----------------------
3406 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3408 return Symbol_Table_Range (Key mod 511);
3409 end Symbol_Table_Hash;
3415 function System_Of (E : Entity_Id) return System_Type is
3416 Type_Decl : constant Node_Id := Parent (E);
3419 -- Look for Type_Decl in System_Table
3421 for Dim_Sys in 1 .. System_Table.Last loop
3422 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3423 return System_Table.Table (Dim_Sys);