1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2011-2015, 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;
30 with Exp_Util; use Exp_Util;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
34 with Nmake; use Nmake;
36 with Rtsfind; use Rtsfind;
38 with Sem_Eval; use Sem_Eval;
39 with Sem_Res; use Sem_Res;
40 with Sem_Util; use Sem_Util;
41 with Sinfo; use Sinfo;
42 with Sinput; use Sinput;
43 with Snames; use Snames;
44 with Stand; use Stand;
45 with Stringt; use Stringt;
47 with Tbuild; use Tbuild;
48 with Uintp; use Uintp;
49 with Urealp; use Urealp;
53 package body Sem_Dim is
55 -------------------------
56 -- Rational Arithmetic --
57 -------------------------
59 type Whole is new Int;
60 subtype Positive_Whole is Whole range 1 .. Whole'Last;
62 type Rational is record
64 Denominator : Positive_Whole;
67 Zero : constant Rational := Rational'(Numerator => 0,
70 No_Rational : constant Rational := Rational'(Numerator => 0,
72 -- Used to indicate an expression that cannot be interpreted as a rational
73 -- Returned value of the Create_Rational_From routine when parameter Expr
74 -- is not a static representation of a rational.
76 -- Rational constructors
78 function "+" (Right : Whole) return Rational;
79 function GCD (Left, Right : Whole) return Int;
80 function Reduce (X : Rational) return Rational;
82 -- Unary operator for Rational
84 function "-" (Right : Rational) return Rational;
85 function "abs" (Right : Rational) return Rational;
87 -- Rational operations for Rationals
89 function "+" (Left, Right : Rational) return Rational;
90 function "-" (Left, Right : Rational) return Rational;
91 function "*" (Left, Right : Rational) return Rational;
92 function "/" (Left, Right : Rational) return Rational;
98 Max_Number_Of_Dimensions : constant := 7;
99 -- Maximum number of dimensions in a dimension system
101 High_Position_Bound : constant := Max_Number_Of_Dimensions;
102 Invalid_Position : constant := 0;
103 Low_Position_Bound : constant := 1;
105 subtype Dimension_Position is
106 Nat range Invalid_Position .. High_Position_Bound;
109 array (Dimension_Position range
110 Low_Position_Bound .. High_Position_Bound) of Name_Id;
111 -- Store the names of all units within a system
113 No_Names : constant Name_Array := (others => No_Name);
116 array (Dimension_Position range
117 Low_Position_Bound .. High_Position_Bound) of String_Id;
118 -- Store the symbols of all units within a system
120 No_Symbols : constant Symbol_Array := (others => No_String);
122 -- The following record should be documented field by field
124 type System_Type is record
126 Unit_Names : Name_Array;
127 Unit_Symbols : Symbol_Array;
128 Dim_Symbols : Symbol_Array;
129 Count : Dimension_Position;
132 Null_System : constant System_Type :=
133 (Empty, No_Names, No_Symbols, No_Symbols, Invalid_Position);
135 subtype System_Id is Nat;
137 -- The following table maps types to systems
139 package System_Table is new Table.Table (
140 Table_Component_Type => System_Type,
141 Table_Index_Type => System_Id,
142 Table_Low_Bound => 1,
144 Table_Increment => 5,
145 Table_Name => "System_Table");
151 type Dimension_Type is
152 array (Dimension_Position range
153 Low_Position_Bound .. High_Position_Bound) of Rational;
155 Null_Dimension : constant Dimension_Type := (others => Zero);
157 type Dimension_Table_Range is range 0 .. 510;
158 function Dimension_Table_Hash (Key : Node_Id) return Dimension_Table_Range;
160 -- The following table associates nodes with dimensions
162 package Dimension_Table is new
163 GNAT.HTable.Simple_HTable
164 (Header_Num => Dimension_Table_Range,
165 Element => Dimension_Type,
166 No_Element => Null_Dimension,
168 Hash => Dimension_Table_Hash,
175 type Symbol_Table_Range is range 0 .. 510;
176 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range;
178 -- Each subtype with a dimension has a symbolic representation of the
179 -- related unit. This table establishes a relation between the subtype
182 package Symbol_Table is new
183 GNAT.HTable.Simple_HTable
184 (Header_Num => Symbol_Table_Range,
185 Element => String_Id,
186 No_Element => No_String,
188 Hash => Symbol_Table_Hash,
191 -- The following array enumerates all contexts which may contain or
192 -- produce a dimension.
194 OK_For_Dimension : constant array (Node_Kind) of Boolean :=
195 (N_Attribute_Reference => True,
196 N_Expanded_Name => True,
197 N_Defining_Identifier => True,
198 N_Function_Call => True,
199 N_Identifier => True,
200 N_Indexed_Component => True,
201 N_Integer_Literal => True,
208 N_Op_Multiply => True,
211 N_Op_Subtract => True,
212 N_Qualified_Expression => True,
213 N_Real_Literal => True,
214 N_Selected_Component => True,
216 N_Type_Conversion => True,
217 N_Unchecked_Type_Conversion => True,
221 -----------------------
222 -- Local Subprograms --
223 -----------------------
225 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id);
226 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
227 -- dimensions of the left-hand side and the right-hand side of N match.
229 procedure Analyze_Dimension_Binary_Op (N : Node_Id);
230 -- Subroutine of Analyze_Dimension for binary operators. Check the
231 -- dimensions of the right and the left operand permit the operation.
232 -- Then, evaluate the resulting dimensions for each binary operator.
234 procedure Analyze_Dimension_Component_Declaration (N : Node_Id);
235 -- Subroutine of Analyze_Dimension for component declaration. Check that
236 -- the dimensions of the type of N and of the expression match.
238 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id);
239 -- Subroutine of Analyze_Dimension for extended return statement. Check
240 -- that the dimensions of the returned type and of the returned object
243 procedure Analyze_Dimension_Has_Etype (N : Node_Id);
244 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
246 -- N_Attribute_Reference
248 -- N_Indexed_Component
249 -- N_Qualified_Expression
250 -- N_Selected_Component
253 -- N_Unchecked_Type_Conversion
255 procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
256 -- Subroutine of Analyze_Dimension for object declaration. Check that
257 -- the dimensions of the object type and the dimensions of the expression
258 -- (if expression is present) match. Note that when the expression is
259 -- a literal, no error is returned. This special case allows object
260 -- declaration such as: m : constant Length := 1.0;
262 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
263 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
264 -- the dimensions of the type and of the renamed object name of N match.
266 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id);
267 -- Subroutine of Analyze_Dimension for simple return statement
268 -- Check that the dimensions of the returned type and of the returned
271 procedure Analyze_Dimension_Subtype_Declaration (N : Node_Id);
272 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
273 -- dimensions from the parent type to the identifier of N. Note that if
274 -- both the identifier and the parent type of N are not dimensionless,
277 procedure Analyze_Dimension_Unary_Op (N : Node_Id);
278 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
279 -- Abs operators, propagate the dimensions from the operand to N.
281 function Create_Rational_From
283 Complain : Boolean) return Rational;
284 -- Given an arbitrary expression Expr, return a valid rational if Expr can
285 -- be interpreted as a rational. Otherwise return No_Rational and also an
286 -- error message if Complain is set to True.
288 function Dimensions_Of (N : Node_Id) return Dimension_Type;
289 -- Return the dimension vector of node N
291 function Dimensions_Msg_Of
293 Description_Needed : Boolean := False) return String;
294 -- Given a node N, return the dimension symbols of N, preceded by "has
295 -- dimension" if Description_Needed. if N is dimensionless, return "'[']",
296 -- or "is dimensionless" if Description_Needed.
298 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
299 -- Issue a warning on the given numeric literal N to indicate that the
300 -- compiler made the assumption that the literal is not dimensionless
301 -- but has the dimension of Typ.
303 procedure Eval_Op_Expon_With_Rational_Exponent
305 Exponent_Value : Rational);
306 -- Evaluate the exponent it is a rational and the operand has a dimension
308 function Exists (Dim : Dimension_Type) return Boolean;
309 -- Returns True iff Dim does not denote the null dimension
311 function Exists (Str : String_Id) return Boolean;
312 -- Returns True iff Str does not denote No_String
314 function Exists (Sys : System_Type) return Boolean;
315 -- Returns True iff Sys does not denote the null system
317 function From_Dim_To_Str_Of_Dim_Symbols
318 (Dims : Dimension_Type;
319 System : System_Type;
320 In_Error_Msg : Boolean := False) return String_Id;
321 -- Given a dimension vector and a dimension system, return the proper
322 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
323 -- will be used to issue an error message) then this routine has a special
324 -- handling for the insertion characters * or [ which must be preceded by
325 -- a quote ' to be placed literally into the message.
327 function From_Dim_To_Str_Of_Unit_Symbols
328 (Dims : Dimension_Type;
329 System : System_Type) return String_Id;
330 -- Given a dimension vector and a dimension system, return the proper
331 -- string of unit symbols.
333 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean;
334 -- Return True if E is the package entity of System.Dim.Float_IO or
335 -- System.Dim.Integer_IO.
337 function Is_Invalid (Position : Dimension_Position) return Boolean;
338 -- Return True if Pos denotes the invalid position
340 procedure Move_Dimensions (From : Node_Id; To : Node_Id);
341 -- Copy dimension vector of From to To and delete dimension vector of From
343 procedure Remove_Dimensions (N : Node_Id);
344 -- Remove the dimension vector of node N
346 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type);
347 -- Associate a dimension vector with a node
349 procedure Set_Symbol (E : Entity_Id; Val : String_Id);
350 -- Associate a symbol representation of a dimension vector with a subtype
352 function String_From_Numeric_Literal (N : Node_Id) return String_Id;
353 -- Return the string that corresponds to the numeric litteral N as it
354 -- appears in the source.
356 function Symbol_Of (E : Entity_Id) return String_Id;
357 -- E denotes a subtype with a dimension. Return the symbol representation
358 -- of the dimension vector.
360 function System_Of (E : Entity_Id) return System_Type;
361 -- E denotes a type, return associated system of the type if it has one
367 function "+" (Right : Whole) return Rational is
369 return Rational'(Numerator => Right, Denominator => 1);
372 function "+" (Left, Right : Rational) return Rational is
373 R : constant Rational :=
374 Rational'(Numerator => Left.Numerator * Right.Denominator +
375 Left.Denominator * Right.Numerator,
376 Denominator => Left.Denominator * Right.Denominator);
385 function "-" (Right : Rational) return Rational is
387 return Rational'(Numerator => -Right.Numerator,
388 Denominator => Right.Denominator);
391 function "-" (Left, Right : Rational) return Rational is
392 R : constant Rational :=
393 Rational'(Numerator => Left.Numerator * Right.Denominator -
394 Left.Denominator * Right.Numerator,
395 Denominator => Left.Denominator * Right.Denominator);
405 function "*" (Left, Right : Rational) return Rational is
406 R : constant Rational :=
407 Rational'(Numerator => Left.Numerator * Right.Numerator,
408 Denominator => Left.Denominator * Right.Denominator);
417 function "/" (Left, Right : Rational) return Rational is
418 R : constant Rational := abs Right;
419 L : Rational := Left;
422 if Right.Numerator < 0 then
423 L.Numerator := Whole (-Integer (L.Numerator));
426 return Reduce (Rational'(Numerator => L.Numerator * R.Denominator,
427 Denominator => L.Denominator * R.Numerator));
434 function "abs" (Right : Rational) return Rational is
436 return Rational'(Numerator => abs Right.Numerator,
437 Denominator => Right.Denominator);
440 ------------------------------
441 -- Analyze_Aspect_Dimension --
442 ------------------------------
445 -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value})
447 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
449 -- DIMENSION_VALUE ::=
451 -- | others => RATIONAL
452 -- | DISCRETE_CHOICE_LIST => RATIONAL
454 -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
456 -- Note that when the dimensioned type is an integer type, then any
457 -- dimension value must be an integer literal.
459 procedure Analyze_Aspect_Dimension
464 Def_Id : constant Entity_Id := Defining_Identifier (N);
466 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
467 -- This array is used when processing ranges or Others_Choice as part of
468 -- the dimension aggregate.
470 Dimensions : Dimension_Type := Null_Dimension;
472 procedure Extract_Power
474 Position : Dimension_Position);
475 -- Given an expression with denotes a rational number, read the number
476 -- and associate it with Position in Dimensions.
478 function Position_In_System
480 System : System_Type) return Dimension_Position;
481 -- Given an identifier which denotes a dimension, return the position of
482 -- that dimension within System.
488 procedure Extract_Power
490 Position : Dimension_Position)
495 if Is_Integer_Type (Def_Id) then
497 -- Dimension value must be an integer literal
499 if Nkind (Expr) = N_Integer_Literal then
500 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
502 Error_Msg_N ("integer literal expected", Expr);
508 Dimensions (Position) := Create_Rational_From (Expr, True);
511 Processed (Position) := True;
514 ------------------------
515 -- Position_In_System --
516 ------------------------
518 function Position_In_System
520 System : System_Type) return Dimension_Position
522 Dimension_Name : constant Name_Id := Chars (Id);
525 for Position in System.Unit_Names'Range loop
526 if Dimension_Name = System.Unit_Names (Position) then
531 return Invalid_Position;
532 end Position_In_System;
539 Num_Choices : Nat := 0;
540 Num_Dimensions : Nat := 0;
541 Others_Seen : Boolean := False;
544 Symbol : String_Id := No_String;
545 Symbol_Expr : Node_Id;
546 System : System_Type;
550 -- Errors_Count is a count of errors detected by the compiler so far
551 -- just before the extraction of symbol, names and values in the
552 -- aggregate (Step 2).
554 -- At the end of the analysis, there is a check to verify that this
555 -- count equals to Serious_Errors_Detected i.e. no erros have been
556 -- encountered during the process. Otherwise the Dimension_Table is
559 -- Start of processing for Analyze_Aspect_Dimension
562 -- STEP 1: Legality of aspect
564 if Nkind (N) /= N_Subtype_Declaration then
565 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
569 Sub_Ind := Subtype_Indication (N);
570 Typ := Etype (Sub_Ind);
571 System := System_Of (Typ);
573 if Nkind (Sub_Ind) = N_Subtype_Indication then
575 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
579 -- The dimension declarations are useless if the parent type does not
580 -- declare a valid system.
582 if not Exists (System) then
584 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
588 if Nkind (Aggr) /= N_Aggregate then
589 Error_Msg_N ("aggregate expected", Aggr);
593 -- STEP 2: Symbol, Names and values extraction
595 -- Get the number of errors detected by the compiler so far
597 Errors_Count := Serious_Errors_Detected;
599 -- STEP 2a: Symbol extraction
601 -- The first entry in the aggregate may be the symbolic representation
604 -- Positional symbol argument
606 Symbol_Expr := First (Expressions (Aggr));
608 -- Named symbol argument
611 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
614 Symbol_Expr := Empty;
616 -- Component associations present
618 if Present (Component_Associations (Aggr)) then
619 Assoc := First (Component_Associations (Aggr));
620 Choice := First (Choices (Assoc));
622 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
624 -- Symbol component association is present
626 if Chars (Choice) = Name_Symbol then
627 Num_Choices := Num_Choices + 1;
628 Symbol_Expr := Expression (Assoc);
630 -- Verify symbol expression is a string or a character
632 if not Nkind_In (Symbol_Expr, N_Character_Literal,
635 Symbol_Expr := Empty;
637 ("symbol expression must be character or string",
641 -- Special error if no Symbol choice but expression is string
644 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
647 Num_Choices := Num_Choices + 1;
649 ("optional component Symbol expected, found&", Choice);
655 -- STEP 2b: Names and values extraction
657 -- Positional elements
659 Expr := First (Expressions (Aggr));
661 -- Skip the symbol expression when present
663 if Present (Symbol_Expr) and then Num_Choices = 0 then
667 Position := Low_Position_Bound;
668 while Present (Expr) loop
669 if Position > High_Position_Bound then
671 ("type& has more dimensions than system allows", Def_Id);
675 Extract_Power (Expr, Position);
677 Position := Position + 1;
678 Num_Dimensions := Num_Dimensions + 1;
685 Assoc := First (Component_Associations (Aggr));
687 -- Skip the symbol association when present
689 if Num_Choices = 1 then
693 while Present (Assoc) loop
694 Expr := Expression (Assoc);
696 Choice := First (Choices (Assoc));
697 while Present (Choice) loop
699 -- Identifier case: NAME => EXPRESSION
701 if Nkind (Choice) = N_Identifier then
702 Position := Position_In_System (Choice, System);
704 if Is_Invalid (Position) then
705 Error_Msg_N ("dimension name& not part of system", Choice);
707 Extract_Power (Expr, Position);
710 -- Range case: NAME .. NAME => EXPRESSION
712 elsif Nkind (Choice) = N_Range then
714 Low : constant Node_Id := Low_Bound (Choice);
715 High : constant Node_Id := High_Bound (Choice);
716 Low_Pos : Dimension_Position;
717 High_Pos : Dimension_Position;
720 if Nkind (Low) /= N_Identifier then
721 Error_Msg_N ("bound must denote a dimension name", Low);
723 elsif Nkind (High) /= N_Identifier then
724 Error_Msg_N ("bound must denote a dimension name", High);
727 Low_Pos := Position_In_System (Low, System);
728 High_Pos := Position_In_System (High, System);
730 if Is_Invalid (Low_Pos) then
731 Error_Msg_N ("dimension name& not part of system",
734 elsif Is_Invalid (High_Pos) then
735 Error_Msg_N ("dimension name& not part of system",
738 elsif Low_Pos > High_Pos then
739 Error_Msg_N ("expected low to high range", Choice);
742 for Position in Low_Pos .. High_Pos loop
743 Extract_Power (Expr, Position);
749 -- Others case: OTHERS => EXPRESSION
751 elsif Nkind (Choice) = N_Others_Choice then
752 if Present (Next (Choice)) or else Present (Prev (Choice)) then
754 ("OTHERS must appear alone in a choice list", Choice);
756 elsif Present (Next (Assoc)) then
758 ("OTHERS must appear last in an aggregate", Choice);
760 elsif Others_Seen then
761 Error_Msg_N ("multiple OTHERS not allowed", Choice);
764 -- Fill the non-processed dimensions with the default value
765 -- supplied by others.
767 for Position in Processed'Range loop
768 if not Processed (Position) then
769 Extract_Power (Expr, Position);
776 -- All other cases are illegal declarations of dimension names
779 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
782 Num_Choices := Num_Choices + 1;
786 Num_Dimensions := Num_Dimensions + 1;
790 -- STEP 3: Consistency of system and dimensions
792 if Present (First (Expressions (Aggr)))
793 and then (First (Expressions (Aggr)) /= Symbol_Expr
794 or else Present (Next (Symbol_Expr)))
795 and then (Num_Choices > 1
796 or else (Num_Choices = 1 and then not Others_Seen))
799 ("named associations cannot follow positional associations", Aggr);
802 if Num_Dimensions > System.Count then
803 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
805 elsif Num_Dimensions < System.Count and then not Others_Seen then
806 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
809 -- STEP 4: Dimension symbol extraction
811 if Present (Symbol_Expr) then
812 if Nkind (Symbol_Expr) = N_Character_Literal then
814 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
815 Symbol := End_String;
818 Symbol := Strval (Symbol_Expr);
821 if String_Length (Symbol) = 0 then
822 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
826 -- STEP 5: Storage of extracted values
828 -- Check that no errors have been detected during the analysis
830 if Errors_Count = Serious_Errors_Detected then
832 -- Check for useless declaration
834 if Symbol = No_String and then not Exists (Dimensions) then
835 Error_Msg_N ("useless dimension declaration", Aggr);
838 if Symbol /= No_String then
839 Set_Symbol (Def_Id, Symbol);
842 if Exists (Dimensions) then
843 Set_Dimensions (Def_Id, Dimensions);
846 end Analyze_Aspect_Dimension;
848 -------------------------------------
849 -- Analyze_Aspect_Dimension_System --
850 -------------------------------------
852 -- with Dimension_System => (DIMENSION {, DIMENSION});
855 -- [Unit_Name =>] IDENTIFIER,
856 -- [Unit_Symbol =>] SYMBOL,
857 -- [Dim_Symbol =>] SYMBOL)
859 procedure Analyze_Aspect_Dimension_System
864 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
865 -- Determine whether type declaration N denotes a numeric derived type
867 -------------------------------
868 -- Is_Derived_Numeric_Type --
869 -------------------------------
871 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
874 Nkind (N) = N_Full_Type_Declaration
875 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
876 and then Is_Numeric_Type
877 (Entity (Subtype_Indication (Type_Definition (N))));
878 end Is_Derived_Numeric_Type;
885 Dim_Symbol : Node_Id;
886 Dim_Symbols : Symbol_Array := No_Symbols;
887 Dim_System : System_Type := Null_System;
890 Unit_Names : Name_Array := No_Names;
891 Unit_Symbol : Node_Id;
892 Unit_Symbols : Symbol_Array := No_Symbols;
895 -- Errors_Count is a count of errors detected by the compiler so far
896 -- just before the extraction of names and symbols in the aggregate
899 -- At the end of the analysis, there is a check to verify that this
900 -- count equals Serious_Errors_Detected i.e. no errors have been
901 -- encountered during the process. Otherwise the System_Table is
904 -- Start of processing for Analyze_Aspect_Dimension_System
907 -- STEP 1: Legality of aspect
909 if not Is_Derived_Numeric_Type (N) then
911 ("aspect& must apply to numeric derived type declaration", N, Id);
915 if Nkind (Aggr) /= N_Aggregate then
916 Error_Msg_N ("aggregate expected", Aggr);
920 -- STEP 2: Structural verification of the dimension aggregate
922 if Present (Component_Associations (Aggr)) then
923 Error_Msg_N ("expected positional aggregate", Aggr);
927 -- STEP 3: Name and Symbol extraction
929 Dim_Aggr := First (Expressions (Aggr));
930 Errors_Count := Serious_Errors_Detected;
931 while Present (Dim_Aggr) loop
932 Position := Position + 1;
934 if Position > High_Position_Bound then
935 Error_Msg_N ("too many dimensions in system", Aggr);
939 if Nkind (Dim_Aggr) /= N_Aggregate then
940 Error_Msg_N ("aggregate expected", Dim_Aggr);
943 if Present (Component_Associations (Dim_Aggr))
944 and then Present (Expressions (Dim_Aggr))
947 ("mixed positional/named aggregate not allowed here",
950 -- Verify each dimension aggregate has three arguments
952 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
953 and then List_Length (Expressions (Dim_Aggr)) /= 3
956 ("three components expected in aggregate", Dim_Aggr);
959 -- Named dimension aggregate
961 if Present (Component_Associations (Dim_Aggr)) then
963 -- Check first argument denotes the unit name
965 Assoc := First (Component_Associations (Dim_Aggr));
966 Choice := First (Choices (Assoc));
967 Unit_Name := Expression (Assoc);
969 if Present (Next (Choice))
970 or else Nkind (Choice) /= N_Identifier
972 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
974 elsif Chars (Choice) /= Name_Unit_Name then
975 Error_Msg_N ("expected Unit_Name, found&", Choice);
978 -- Check the second argument denotes the unit symbol
981 Choice := First (Choices (Assoc));
982 Unit_Symbol := Expression (Assoc);
984 if Present (Next (Choice))
985 or else Nkind (Choice) /= N_Identifier
987 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
989 elsif Chars (Choice) /= Name_Unit_Symbol then
990 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
993 -- Check the third argument denotes the dimension symbol
996 Choice := First (Choices (Assoc));
997 Dim_Symbol := Expression (Assoc);
999 if Present (Next (Choice))
1000 or else Nkind (Choice) /= N_Identifier
1002 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1003 elsif Chars (Choice) /= Name_Dim_Symbol then
1004 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1007 -- Positional dimension aggregate
1010 Unit_Name := First (Expressions (Dim_Aggr));
1011 Unit_Symbol := Next (Unit_Name);
1012 Dim_Symbol := Next (Unit_Symbol);
1015 -- Check the first argument for each dimension aggregate is
1018 if Nkind (Unit_Name) = N_Identifier then
1019 Unit_Names (Position) := Chars (Unit_Name);
1021 Error_Msg_N ("expected unit name", Unit_Name);
1024 -- Check the second argument for each dimension aggregate is
1025 -- a string or a character.
1027 if not Nkind_In (Unit_Symbol, N_String_Literal,
1028 N_Character_Literal)
1031 ("expected unit symbol (string or character)",
1037 if Nkind (Unit_Symbol) = N_String_Literal then
1038 Unit_Symbols (Position) := Strval (Unit_Symbol);
1045 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1046 Unit_Symbols (Position) := End_String;
1049 -- Verify that the string is not empty
1051 if String_Length (Unit_Symbols (Position)) = 0 then
1053 ("empty string not allowed here", Unit_Symbol);
1057 -- Check the third argument for each dimension aggregate is
1058 -- a string or a character.
1060 if not Nkind_In (Dim_Symbol, N_String_Literal,
1061 N_Character_Literal)
1064 ("expected dimension symbol (string or character)",
1070 if Nkind (Dim_Symbol) = N_String_Literal then
1071 Dim_Symbols (Position) := Strval (Dim_Symbol);
1078 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1079 Dim_Symbols (Position) := End_String;
1082 -- Verify that the string is not empty
1084 if String_Length (Dim_Symbols (Position)) = 0 then
1085 Error_Msg_N ("empty string not allowed here", Dim_Symbol);
1094 -- STEP 4: Storage of extracted values
1096 -- Check that no errors have been detected during the analysis
1098 if Errors_Count = Serious_Errors_Detected then
1099 Dim_System.Type_Decl := N;
1100 Dim_System.Unit_Names := Unit_Names;
1101 Dim_System.Unit_Symbols := Unit_Symbols;
1102 Dim_System.Dim_Symbols := Dim_Symbols;
1103 Dim_System.Count := Position;
1104 System_Table.Append (Dim_System);
1106 end Analyze_Aspect_Dimension_System;
1108 -----------------------
1109 -- Analyze_Dimension --
1110 -----------------------
1112 -- This dispatch routine propagates dimensions for each node
1114 procedure Analyze_Dimension (N : Node_Id) is
1116 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1117 -- dimensions for nodes that don't come from source.
1119 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1124 when N_Assignment_Statement =>
1125 Analyze_Dimension_Assignment_Statement (N);
1128 Analyze_Dimension_Binary_Op (N);
1130 when N_Component_Declaration =>
1131 Analyze_Dimension_Component_Declaration (N);
1133 when N_Extended_Return_Statement =>
1134 Analyze_Dimension_Extended_Return_Statement (N);
1136 when N_Attribute_Reference |
1140 N_Indexed_Component |
1141 N_Qualified_Expression |
1142 N_Selected_Component |
1145 N_Unchecked_Type_Conversion =>
1146 Analyze_Dimension_Has_Etype (N);
1148 when N_Object_Declaration =>
1149 Analyze_Dimension_Object_Declaration (N);
1151 when N_Object_Renaming_Declaration =>
1152 Analyze_Dimension_Object_Renaming_Declaration (N);
1154 when N_Simple_Return_Statement =>
1155 if not Comes_From_Extended_Return_Statement (N) then
1156 Analyze_Dimension_Simple_Return_Statement (N);
1159 when N_Subtype_Declaration =>
1160 Analyze_Dimension_Subtype_Declaration (N);
1163 Analyze_Dimension_Unary_Op (N);
1165 when others => null;
1168 end Analyze_Dimension;
1170 ---------------------------------------
1171 -- Analyze_Dimension_Array_Aggregate --
1172 ---------------------------------------
1174 procedure Analyze_Dimension_Array_Aggregate
1176 Comp_Typ : Entity_Id)
1178 Comp_Ass : constant List_Id := Component_Associations (N);
1179 Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ);
1180 Exps : constant List_Id := Expressions (N);
1185 Error_Detected : Boolean := False;
1186 -- This flag is used in order to indicate if an error has been detected
1187 -- so far by the compiler in this routine.
1190 -- Aspect is an Ada 2012 feature. Nothing to do here if the component
1191 -- base type is not a dimensioned type.
1193 -- Note that here the original node must come from source since the
1194 -- original array aggregate may not have been entirely decorated.
1196 if Ada_Version < Ada_2012
1197 or else not Comes_From_Source (Original_Node (N))
1198 or else not Has_Dimension_System (Base_Type (Comp_Typ))
1203 -- Check whether there is any positional component association
1205 if Is_Empty_List (Exps) then
1206 Comp := First (Comp_Ass);
1208 Comp := First (Exps);
1211 while Present (Comp) loop
1213 -- Get the expression from the component
1215 if Nkind (Comp) = N_Component_Association then
1216 Expr := Expression (Comp);
1221 -- Issue an error if the dimensions of the component type and the
1222 -- dimensions of the component mismatch.
1224 -- Note that we must ensure the expression has been fully analyzed
1225 -- since it may not be decorated at this point. We also don't want to
1226 -- issue the same error message multiple times on the same expression
1227 -- (may happen when an aggregate is converted into a positional
1230 if Comes_From_Source (Original_Node (Expr))
1231 and then Present (Etype (Expr))
1232 and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
1233 and then Sloc (Comp) /= Sloc (Prev (Comp))
1235 -- Check if an error has already been encountered so far
1237 if not Error_Detected then
1238 Error_Msg_N ("dimensions mismatch in array aggregate", N);
1239 Error_Detected := True;
1243 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1244 & ", found " & Dimensions_Msg_Of (Expr), Expr);
1247 -- Look at the named components right after the positional components
1249 if not Present (Next (Comp))
1250 and then List_Containing (Comp) = Exps
1252 Comp := First (Comp_Ass);
1257 end Analyze_Dimension_Array_Aggregate;
1259 --------------------------------------------
1260 -- Analyze_Dimension_Assignment_Statement --
1261 --------------------------------------------
1263 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1264 Lhs : constant Node_Id := Name (N);
1265 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1266 Rhs : constant Node_Id := Expression (N);
1267 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1269 procedure Error_Dim_Msg_For_Assignment_Statement
1273 -- Error using Error_Msg_N at node N. Output the dimensions of left
1274 -- and right hand sides.
1276 --------------------------------------------
1277 -- Error_Dim_Msg_For_Assignment_Statement --
1278 --------------------------------------------
1280 procedure Error_Dim_Msg_For_Assignment_Statement
1286 Error_Msg_N ("dimensions mismatch in assignment", N);
1287 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N);
1288 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N);
1289 end Error_Dim_Msg_For_Assignment_Statement;
1291 -- Start of processing for Analyze_Dimension_Assignment
1294 if Dims_Of_Lhs /= Dims_Of_Rhs then
1295 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1297 end Analyze_Dimension_Assignment_Statement;
1299 ---------------------------------
1300 -- Analyze_Dimension_Binary_Op --
1301 ---------------------------------
1303 -- Check and propagate the dimensions for binary operators
1304 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1306 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1307 N_Kind : constant Node_Kind := Nkind (N);
1309 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1310 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1311 -- dimensions of both operands.
1313 ---------------------------------
1314 -- Error_Dim_Msg_For_Binary_Op --
1315 ---------------------------------
1317 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1320 ("both operands for operation& must have same dimensions",
1322 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N);
1323 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N);
1324 end Error_Dim_Msg_For_Binary_Op;
1326 -- Start of processing for Analyze_Dimension_Binary_Op
1329 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1330 or else N_Kind in N_Multiplying_Operator
1331 or else N_Kind in N_Op_Compare
1334 L : constant Node_Id := Left_Opnd (N);
1335 Dims_Of_L : constant Dimension_Type := Dimensions_Of (L);
1336 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1337 R : constant Node_Id := Right_Opnd (N);
1338 Dims_Of_R : constant Dimension_Type := Dimensions_Of (R);
1339 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1340 Dims_Of_N : Dimension_Type := Null_Dimension;
1343 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1345 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1347 -- Check both operands have same dimension
1349 if Dims_Of_L /= Dims_Of_R then
1350 Error_Dim_Msg_For_Binary_Op (N, L, R);
1352 -- Check both operands are not dimensionless
1354 if Exists (Dims_Of_L) then
1355 Set_Dimensions (N, Dims_Of_L);
1359 -- N_Op_Multiply or N_Op_Divide case
1361 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1363 -- Check at least one operand is not dimensionless
1365 if L_Has_Dimensions or R_Has_Dimensions then
1367 -- Multiplication case
1369 -- Get both operands dimensions and add them
1371 if N_Kind = N_Op_Multiply then
1372 for Position in Dimension_Type'Range loop
1373 Dims_Of_N (Position) :=
1374 Dims_Of_L (Position) + Dims_Of_R (Position);
1379 -- Get both operands dimensions and subtract them
1382 for Position in Dimension_Type'Range loop
1383 Dims_Of_N (Position) :=
1384 Dims_Of_L (Position) - Dims_Of_R (Position);
1388 if Exists (Dims_Of_N) then
1389 Set_Dimensions (N, Dims_Of_N);
1393 -- Exponentiation case
1395 -- Note: a rational exponent is allowed for dimensioned operand
1397 elsif N_Kind = N_Op_Expon then
1399 -- Check the left operand is not dimensionless. Note that the
1400 -- value of the exponent must be known compile time. Otherwise,
1401 -- the exponentiation evaluation will return an error message.
1403 if L_Has_Dimensions then
1404 if not Compile_Time_Known_Value (R) then
1406 ("exponent of dimensioned operand must be "
1407 & "known at compile time", N);
1411 Exponent_Value : Rational := Zero;
1414 -- Real operand case
1416 if Is_Real_Type (Etype (L)) then
1418 -- Define the exponent as a Rational number
1420 Exponent_Value := Create_Rational_From (R, False);
1422 -- Verify that the exponent cannot be interpreted
1423 -- as a rational, otherwise interpret the exponent
1426 if Exponent_Value = No_Rational then
1428 +Whole (UI_To_Int (Expr_Value (R)));
1431 -- Integer operand case.
1433 -- For integer operand, the exponent cannot be
1434 -- interpreted as a rational.
1437 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1440 for Position in Dimension_Type'Range loop
1441 Dims_Of_N (Position) :=
1442 Dims_Of_L (Position) * Exponent_Value;
1445 if Exists (Dims_Of_N) then
1446 Set_Dimensions (N, Dims_Of_N);
1453 -- For relational operations, only dimension checking is
1454 -- performed (no propagation).
1456 elsif N_Kind in N_Op_Compare then
1457 if (L_Has_Dimensions or R_Has_Dimensions)
1458 and then Dims_Of_L /= Dims_Of_R
1460 Error_Dim_Msg_For_Binary_Op (N, L, R);
1464 -- Removal of dimensions for each operands
1466 Remove_Dimensions (L);
1467 Remove_Dimensions (R);
1470 end Analyze_Dimension_Binary_Op;
1472 ----------------------------
1473 -- Analyze_Dimension_Call --
1474 ----------------------------
1476 procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is
1477 Actuals : constant List_Id := Parameter_Associations (N);
1479 Dims_Of_Formal : Dimension_Type;
1481 Formal_Typ : Entity_Id;
1483 Error_Detected : Boolean := False;
1484 -- This flag is used in order to indicate if an error has been detected
1485 -- so far by the compiler in this routine.
1488 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1489 -- dimensions for calls that don't come from source, or those that may
1490 -- have semantic errors.
1492 if Ada_Version < Ada_2012
1493 or else not Comes_From_Source (N)
1494 or else Error_Posted (N)
1499 -- Check the dimensions of the actuals, if any
1501 if not Is_Empty_List (Actuals) then
1503 -- Special processing for elementary functions
1505 -- For Sqrt call, the resulting dimensions equal to half the
1506 -- dimensions of the actual. For all other elementary calls, this
1507 -- routine check that every actual is dimensionless.
1509 if Nkind (N) = N_Function_Call then
1510 Elementary_Function_Calls : declare
1511 Dims_Of_Call : Dimension_Type;
1512 Ent : Entity_Id := Nam;
1514 function Is_Elementary_Function_Entity
1515 (Sub_Id : Entity_Id) return Boolean;
1516 -- Given Sub_Id, the original subprogram entity, return True
1517 -- if call is to an elementary function (see Ada.Numerics.
1518 -- Generic_Elementary_Functions).
1520 -----------------------------------
1521 -- Is_Elementary_Function_Entity --
1522 -----------------------------------
1524 function Is_Elementary_Function_Entity
1525 (Sub_Id : Entity_Id) return Boolean
1527 Loc : constant Source_Ptr := Sloc (Sub_Id);
1530 -- Is entity in Ada.Numerics.Generic_Elementary_Functions?
1536 (Cunit_Entity (Get_Source_Unit (Loc)),
1537 Ada_Numerics_Generic_Elementary_Functions);
1538 end Is_Elementary_Function_Entity;
1540 -- Start of processing for Elementary_Function_Calls
1543 -- Get original subprogram entity following the renaming chain
1545 if Present (Alias (Ent)) then
1549 -- Check the call is an Elementary function call
1551 if Is_Elementary_Function_Entity (Ent) then
1553 -- Sqrt function call case
1555 if Chars (Ent) = Name_Sqrt then
1556 Dims_Of_Call := Dimensions_Of (First_Actual (N));
1558 -- Evaluates the resulting dimensions (i.e. half the
1559 -- dimensions of the actual).
1561 if Exists (Dims_Of_Call) then
1562 for Position in Dims_Of_Call'Range loop
1563 Dims_Of_Call (Position) :=
1564 Dims_Of_Call (Position) *
1565 Rational'(Numerator => 1, Denominator => 2);
1568 Set_Dimensions (N, Dims_Of_Call);
1571 -- All other elementary functions case. Note that every
1572 -- actual here should be dimensionless.
1575 Actual := First_Actual (N);
1576 while Present (Actual) loop
1577 if Exists (Dimensions_Of (Actual)) then
1579 -- Check if error has already been encountered
1581 if not Error_Detected then
1583 ("dimensions mismatch in call of&",
1585 Error_Detected := True;
1589 ("\expected dimension '['], found "
1590 & Dimensions_Msg_Of (Actual), Actual);
1593 Next_Actual (Actual);
1597 -- Nothing more to do for elementary functions
1601 end Elementary_Function_Calls;
1604 -- General case. Check, for each parameter, the dimensions of the
1605 -- actual and its corresponding formal match. Otherwise, complain.
1607 Actual := First_Actual (N);
1608 Formal := First_Formal (Nam);
1609 while Present (Formal) loop
1611 -- A missing corresponding actual indicates that the analysis of
1612 -- the call was aborted due to a previous error.
1615 Check_Error_Detected;
1619 Formal_Typ := Etype (Formal);
1620 Dims_Of_Formal := Dimensions_Of (Formal_Typ);
1622 -- If the formal is not dimensionless, check dimensions of formal
1623 -- and actual match. Otherwise, complain.
1625 if Exists (Dims_Of_Formal)
1626 and then Dimensions_Of (Actual) /= Dims_Of_Formal
1628 -- Check if an error has already been encountered so far
1630 if not Error_Detected then
1631 Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
1632 Error_Detected := True;
1636 ("\expected dimension " & Dimensions_Msg_Of (Formal_Typ)
1637 & ", found " & Dimensions_Msg_Of (Actual), Actual);
1640 Next_Actual (Actual);
1641 Next_Formal (Formal);
1645 -- For function calls, propagate the dimensions from the returned type
1647 if Nkind (N) = N_Function_Call then
1648 Analyze_Dimension_Has_Etype (N);
1650 end Analyze_Dimension_Call;
1652 ---------------------------------------------
1653 -- Analyze_Dimension_Component_Declaration --
1654 ---------------------------------------------
1656 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1657 Expr : constant Node_Id := Expression (N);
1658 Id : constant Entity_Id := Defining_Identifier (N);
1659 Etyp : constant Entity_Id := Etype (Id);
1660 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1661 Dims_Of_Expr : Dimension_Type;
1663 procedure Error_Dim_Msg_For_Component_Declaration
1667 -- Error using Error_Msg_N at node N. Output the dimensions of the
1668 -- type Etyp and the expression Expr of N.
1670 ---------------------------------------------
1671 -- Error_Dim_Msg_For_Component_Declaration --
1672 ---------------------------------------------
1674 procedure Error_Dim_Msg_For_Component_Declaration
1679 Error_Msg_N ("dimensions mismatch in component declaration", N);
1681 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
1682 & Dimensions_Msg_Of (Expr), Expr);
1683 end Error_Dim_Msg_For_Component_Declaration;
1685 -- Start of processing for Analyze_Dimension_Component_Declaration
1688 -- Expression is present
1690 if Present (Expr) then
1691 Dims_Of_Expr := Dimensions_Of (Expr);
1693 -- Check dimensions match
1695 if Dims_Of_Etyp /= Dims_Of_Expr then
1697 -- Numeric literal case. Issue a warning if the object type is not
1698 -- dimensionless to indicate the literal is treated as if its
1699 -- dimension matches the type dimension.
1701 if Nkind_In (Original_Node (Expr), N_Real_Literal,
1704 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
1706 -- Issue a dimension mismatch error for all other cases
1709 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1713 end Analyze_Dimension_Component_Declaration;
1715 -------------------------------------------------
1716 -- Analyze_Dimension_Extended_Return_Statement --
1717 -------------------------------------------------
1719 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1720 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
1721 Return_Etyp : constant Entity_Id :=
1722 Etype (Return_Applies_To (Return_Ent));
1723 Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N);
1724 Return_Obj_Decl : Node_Id;
1725 Return_Obj_Id : Entity_Id;
1726 Return_Obj_Typ : Entity_Id;
1728 procedure Error_Dim_Msg_For_Extended_Return_Statement
1730 Return_Etyp : Entity_Id;
1731 Return_Obj_Typ : Entity_Id);
1732 -- Error using Error_Msg_N at node N. Output dimensions of the returned
1733 -- type Return_Etyp and the returned object type Return_Obj_Typ of N.
1735 -------------------------------------------------
1736 -- Error_Dim_Msg_For_Extended_Return_Statement --
1737 -------------------------------------------------
1739 procedure Error_Dim_Msg_For_Extended_Return_Statement
1741 Return_Etyp : Entity_Id;
1742 Return_Obj_Typ : Entity_Id)
1745 Error_Msg_N ("dimensions mismatch in extended return statement", N);
1747 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
1748 & ", found " & Dimensions_Msg_Of (Return_Obj_Typ), N);
1749 end Error_Dim_Msg_For_Extended_Return_Statement;
1751 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1754 if Present (Return_Obj_Decls) then
1755 Return_Obj_Decl := First (Return_Obj_Decls);
1756 while Present (Return_Obj_Decl) loop
1757 if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1758 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1760 if Is_Return_Object (Return_Obj_Id) then
1761 Return_Obj_Typ := Etype (Return_Obj_Id);
1763 -- Issue an error message if dimensions mismatch
1765 if Dimensions_Of (Return_Etyp) /=
1766 Dimensions_Of (Return_Obj_Typ)
1768 Error_Dim_Msg_For_Extended_Return_Statement
1769 (N, Return_Etyp, Return_Obj_Typ);
1775 Next (Return_Obj_Decl);
1778 end Analyze_Dimension_Extended_Return_Statement;
1780 -----------------------------------------------------
1781 -- Analyze_Dimension_Extension_Or_Record_Aggregate --
1782 -----------------------------------------------------
1784 procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is
1786 Comp_Id : Entity_Id;
1787 Comp_Typ : Entity_Id;
1790 Error_Detected : Boolean := False;
1791 -- This flag is used in order to indicate if an error has been detected
1792 -- so far by the compiler in this routine.
1795 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1796 -- dimensions for aggregates that don't come from source, or if we are
1797 -- within an initialization procedure, whose expressions have been
1798 -- checked at the point of record declaration.
1800 if Ada_Version < Ada_2012
1801 or else not Comes_From_Source (N)
1802 or else Inside_Init_Proc
1807 Comp := First (Component_Associations (N));
1808 while Present (Comp) loop
1809 Comp_Id := Entity (First (Choices (Comp)));
1810 Comp_Typ := Etype (Comp_Id);
1812 -- Check the component type is either a dimensioned type or a
1813 -- dimensioned subtype.
1815 if Has_Dimension_System (Base_Type (Comp_Typ)) then
1816 Expr := Expression (Comp);
1818 -- Issue an error if the dimensions of the component type and the
1819 -- dimensions of the component mismatch.
1821 if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then
1823 -- Check if an error has already been encountered so far
1825 if not Error_Detected then
1827 -- Extension aggregate case
1829 if Nkind (N) = N_Extension_Aggregate then
1831 ("dimensions mismatch in extension aggregate", N);
1833 -- Record aggregate case
1837 ("dimensions mismatch in record aggregate", N);
1840 Error_Detected := True;
1844 ("\expected dimension " & Dimensions_Msg_Of (Comp_Typ)
1845 & ", found " & Dimensions_Msg_Of (Expr), Comp);
1851 end Analyze_Dimension_Extension_Or_Record_Aggregate;
1853 -------------------------------
1854 -- Analyze_Dimension_Formals --
1855 -------------------------------
1857 procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is
1858 Dims_Of_Typ : Dimension_Type;
1863 -- Aspect is an Ada 2012 feature. Note that there is no need to check
1864 -- dimensions for sub specs that don't come from source.
1866 if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
1870 Formal := First (Formals);
1871 while Present (Formal) loop
1872 Typ := Parameter_Type (Formal);
1873 Dims_Of_Typ := Dimensions_Of (Typ);
1875 if Exists (Dims_Of_Typ) then
1877 Expr : constant Node_Id := Expression (Formal);
1880 -- Issue a warning if Expr is a numeric literal and if its
1881 -- dimensions differ with the dimensions of the formal type.
1884 and then Dims_Of_Typ /= Dimensions_Of (Expr)
1885 and then Nkind_In (Original_Node (Expr), N_Real_Literal,
1888 Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ));
1895 end Analyze_Dimension_Formals;
1897 ---------------------------------
1898 -- Analyze_Dimension_Has_Etype --
1899 ---------------------------------
1901 procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
1902 Etyp : constant Entity_Id := Etype (N);
1903 Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp);
1906 -- General case. Propagation of the dimensions from the type
1908 if Exists (Dims_Of_Etyp) then
1909 Set_Dimensions (N, Dims_Of_Etyp);
1911 -- Identifier case. Propagate the dimensions from the entity for
1912 -- identifier whose entity is a non-dimensionless constant.
1914 elsif Nkind (N) = N_Identifier then
1915 Analyze_Dimension_Identifier : declare
1916 Id : constant Entity_Id := Entity (N);
1919 -- If Id is missing, abnormal tree, assume previous error
1922 Check_Error_Detected;
1925 elsif Ekind (Id) = E_Constant
1926 and then Exists (Dimensions_Of (Id))
1928 Set_Dimensions (N, Dimensions_Of (Id));
1930 end Analyze_Dimension_Identifier;
1932 -- Attribute reference case. Propagate the dimensions from the prefix.
1934 elsif Nkind (N) = N_Attribute_Reference
1935 and then Has_Dimension_System (Base_Type (Etyp))
1937 Dims_Of_Etyp := Dimensions_Of (Prefix (N));
1939 -- Check the prefix is not dimensionless
1941 if Exists (Dims_Of_Etyp) then
1942 Set_Dimensions (N, Dims_Of_Etyp);
1946 -- Removal of dimensions in expression
1949 when N_Attribute_Reference |
1950 N_Indexed_Component =>
1953 Exprs : constant List_Id := Expressions (N);
1955 if Present (Exprs) then
1956 Expr := First (Exprs);
1957 while Present (Expr) loop
1958 Remove_Dimensions (Expr);
1964 when N_Qualified_Expression |
1966 N_Unchecked_Type_Conversion =>
1967 Remove_Dimensions (Expression (N));
1969 when N_Selected_Component =>
1970 Remove_Dimensions (Selector_Name (N));
1972 when others => null;
1974 end Analyze_Dimension_Has_Etype;
1976 ------------------------------------------
1977 -- Analyze_Dimension_Object_Declaration --
1978 ------------------------------------------
1980 procedure Analyze_Dimension_Object_Declaration (N : Node_Id) is
1981 Expr : constant Node_Id := Expression (N);
1982 Id : constant Entity_Id := Defining_Identifier (N);
1983 Etyp : constant Entity_Id := Etype (Id);
1984 Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1985 Dim_Of_Expr : Dimension_Type;
1987 procedure Error_Dim_Msg_For_Object_Declaration
1991 -- Error using Error_Msg_N at node N. Output the dimensions of the
1992 -- type Etyp and of the expression Expr.
1994 ------------------------------------------
1995 -- Error_Dim_Msg_For_Object_Declaration --
1996 ------------------------------------------
1998 procedure Error_Dim_Msg_For_Object_Declaration
2003 Error_Msg_N ("dimensions mismatch in object declaration", N);
2005 ("\expected dimension " & Dimensions_Msg_Of (Etyp) & ", found "
2006 & Dimensions_Msg_Of (Expr), Expr);
2007 end Error_Dim_Msg_For_Object_Declaration;
2009 -- Start of processing for Analyze_Dimension_Object_Declaration
2012 -- Expression is present
2014 if Present (Expr) then
2015 Dim_Of_Expr := Dimensions_Of (Expr);
2017 -- Check dimensions match
2019 if Dim_Of_Expr /= Dim_Of_Etyp then
2021 -- Numeric literal case. Issue a warning if the object type is not
2022 -- dimensionless to indicate the literal is treated as if its
2023 -- dimension matches the type dimension.
2025 if Nkind_In (Original_Node (Expr), N_Real_Literal,
2028 Dim_Warning_For_Numeric_Literal (Expr, Etyp);
2030 -- Case of object is a constant whose type is a dimensioned type
2032 elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then
2034 -- Propagate dimension from expression to object entity
2036 Set_Dimensions (Id, Dim_Of_Expr);
2038 -- For all other cases, issue an error message
2041 Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
2045 -- Removal of dimensions in expression
2047 Remove_Dimensions (Expr);
2049 end Analyze_Dimension_Object_Declaration;
2051 ---------------------------------------------------
2052 -- Analyze_Dimension_Object_Renaming_Declaration --
2053 ---------------------------------------------------
2055 procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id) is
2056 Renamed_Name : constant Node_Id := Name (N);
2057 Sub_Mark : constant Node_Id := Subtype_Mark (N);
2059 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2062 Renamed_Name : Node_Id);
2063 -- Error using Error_Msg_N at node N. Output the dimensions of
2064 -- Sub_Mark and of Renamed_Name.
2066 ---------------------------------------------------
2067 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
2068 ---------------------------------------------------
2070 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
2073 Renamed_Name : Node_Id) is
2075 Error_Msg_N ("dimensions mismatch in object renaming declaration", N);
2077 ("\expected dimension " & Dimensions_Msg_Of (Sub_Mark) & ", found "
2078 & Dimensions_Msg_Of (Renamed_Name), Renamed_Name);
2079 end Error_Dim_Msg_For_Object_Renaming_Declaration;
2081 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
2084 if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
2085 Error_Dim_Msg_For_Object_Renaming_Declaration
2086 (N, Sub_Mark, Renamed_Name);
2088 end Analyze_Dimension_Object_Renaming_Declaration;
2090 -----------------------------------------------
2091 -- Analyze_Dimension_Simple_Return_Statement --
2092 -----------------------------------------------
2094 procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
2095 Expr : constant Node_Id := Expression (N);
2096 Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
2097 Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
2098 Return_Etyp : constant Entity_Id :=
2099 Etype (Return_Applies_To (Return_Ent));
2100 Dims_Of_Return_Etyp : constant Dimension_Type :=
2101 Dimensions_Of (Return_Etyp);
2103 procedure Error_Dim_Msg_For_Simple_Return_Statement
2105 Return_Etyp : Entity_Id;
2107 -- Error using Error_Msg_N at node N. Output the dimensions of the
2108 -- returned type Return_Etyp and the returned expression Expr of N.
2110 -----------------------------------------------
2111 -- Error_Dim_Msg_For_Simple_Return_Statement --
2112 -----------------------------------------------
2114 procedure Error_Dim_Msg_For_Simple_Return_Statement
2116 Return_Etyp : Entity_Id;
2120 Error_Msg_N ("dimensions mismatch in return statement", N);
2122 ("\expected dimension " & Dimensions_Msg_Of (Return_Etyp)
2123 & ", found " & Dimensions_Msg_Of (Expr), 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);
2161 Set_Dimensions (Id, Dims_Of_Etyp);
2162 Set_Symbol (Id, Symbol_Of (Etyp));
2166 -- Constraint present in subtype declaration
2169 Etyp := Etype (Subtype_Mark (Subtype_Indication (N)));
2170 Dims_Of_Etyp := Dimensions_Of (Etyp);
2172 if Exists (Dims_Of_Etyp) then
2173 Set_Dimensions (Id, Dims_Of_Etyp);
2174 Set_Symbol (Id, Symbol_Of (Etyp));
2177 end Analyze_Dimension_Subtype_Declaration;
2179 --------------------------------
2180 -- Analyze_Dimension_Unary_Op --
2181 --------------------------------
2183 procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
2186 when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
2188 -- Propagate the dimension if the operand is not dimensionless
2191 R : constant Node_Id := Right_Opnd (N);
2193 Move_Dimensions (R, N);
2196 when others => null;
2199 end Analyze_Dimension_Unary_Op;
2201 ---------------------
2202 -- Copy_Dimensions --
2203 ---------------------
2205 procedure Copy_Dimensions (From, To : Node_Id) is
2206 Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
2209 -- Ignore if not Ada 2012 or beyond
2211 if Ada_Version < Ada_2012 then
2214 -- For Ada 2012, Copy the dimension of 'From to 'To'
2216 elsif Exists (Dims_Of_From) then
2217 Set_Dimensions (To, Dims_Of_From);
2219 end Copy_Dimensions;
2221 --------------------------
2222 -- Create_Rational_From --
2223 --------------------------
2225 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
2227 -- A rational number is a number that can be expressed as the quotient or
2228 -- fraction a/b of two integers, where b is non-zero positive.
2230 function Create_Rational_From
2232 Complain : Boolean) return Rational
2234 Or_Node_Of_Expr : constant Node_Id := Original_Node (Expr);
2235 Result : Rational := No_Rational;
2237 function Process_Minus (N : Node_Id) return Rational;
2238 -- Create a rational from a N_Op_Minus node
2240 function Process_Divide (N : Node_Id) return Rational;
2241 -- Create a rational from a N_Op_Divide node
2243 function Process_Literal (N : Node_Id) return Rational;
2244 -- Create a rational from a N_Integer_Literal node
2250 function Process_Minus (N : Node_Id) return Rational is
2251 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2255 -- Operand is an integer literal
2257 if Nkind (Right) = N_Integer_Literal then
2258 Result := -Process_Literal (Right);
2260 -- Operand is a divide operator
2262 elsif Nkind (Right) = N_Op_Divide then
2263 Result := -Process_Divide (Right);
2266 Result := No_Rational;
2269 -- Provide minimal semantic information on dimension expressions,
2270 -- even though they have no run-time existence. This is for use by
2271 -- ASIS tools, in particular pretty-printing. If generating code
2272 -- standard operator resolution will take place.
2275 Set_Entity (N, Standard_Op_Minus);
2276 Set_Etype (N, Standard_Integer);
2282 --------------------
2283 -- Process_Divide --
2284 --------------------
2286 function Process_Divide (N : Node_Id) return Rational is
2287 Left : constant Node_Id := Original_Node (Left_Opnd (N));
2288 Right : constant Node_Id := Original_Node (Right_Opnd (N));
2289 Left_Rat : Rational;
2290 Result : Rational := No_Rational;
2291 Right_Rat : Rational;
2294 -- Both left and right operands are integer literals
2296 if Nkind (Left) = N_Integer_Literal
2298 Nkind (Right) = N_Integer_Literal
2300 Left_Rat := Process_Literal (Left);
2301 Right_Rat := Process_Literal (Right);
2302 Result := Left_Rat / Right_Rat;
2305 -- Provide minimal semantic information on dimension expressions,
2306 -- even though they have no run-time existence. This is for use by
2307 -- ASIS tools, in particular pretty-printing. If generating code
2308 -- standard operator resolution will take place.
2311 Set_Entity (N, Standard_Op_Divide);
2312 Set_Etype (N, Standard_Integer);
2318 ---------------------
2319 -- Process_Literal --
2320 ---------------------
2322 function Process_Literal (N : Node_Id) return Rational is
2324 return +Whole (UI_To_Int (Intval (N)));
2325 end Process_Literal;
2327 -- Start of processing for Create_Rational_From
2330 -- Check the expression is either a division of two integers or an
2331 -- integer itself. Note that the check applies to the original node
2332 -- since the node could have already been rewritten.
2334 -- Integer literal case
2336 if Nkind (Or_Node_Of_Expr) = N_Integer_Literal then
2337 Result := Process_Literal (Or_Node_Of_Expr);
2339 -- Divide operator case
2341 elsif Nkind (Or_Node_Of_Expr) = N_Op_Divide then
2342 Result := Process_Divide (Or_Node_Of_Expr);
2344 -- Minus operator case
2346 elsif Nkind (Or_Node_Of_Expr) = N_Op_Minus then
2347 Result := Process_Minus (Or_Node_Of_Expr);
2350 -- When Expr cannot be interpreted as a rational and Complain is true,
2351 -- generate an error message.
2353 if Complain and then Result = No_Rational then
2354 Error_Msg_N ("rational expected", Expr);
2358 end Create_Rational_From;
2364 function Dimensions_Of (N : Node_Id) return Dimension_Type is
2366 return Dimension_Table.Get (N);
2369 -----------------------
2370 -- Dimensions_Msg_Of --
2371 -----------------------
2373 function Dimensions_Msg_Of
2375 Description_Needed : Boolean := False) return String
2377 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2378 Dimensions_Msg : Name_Id;
2379 System : System_Type;
2382 -- Initialization of Name_Buffer
2386 -- N is not dimensionless
2388 if Exists (Dims_Of_N) then
2389 System := System_Of (Base_Type (Etype (N)));
2391 -- When Description_Needed, add to string "has dimension " before the
2392 -- actual dimension.
2394 if Description_Needed then
2395 Add_Str_To_Name_Buffer ("has dimension ");
2398 Add_String_To_Name_Buffer
2399 (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True));
2401 -- N is dimensionless
2403 -- When Description_Needed, return "is dimensionless"
2405 elsif Description_Needed then
2406 Add_Str_To_Name_Buffer ("is dimensionless");
2408 -- Otherwise, return "'[']"
2411 Add_Str_To_Name_Buffer ("'[']");
2414 Dimensions_Msg := Name_Find;
2415 return Get_Name_String (Dimensions_Msg);
2416 end Dimensions_Msg_Of;
2418 --------------------------
2419 -- Dimension_Table_Hash --
2420 --------------------------
2422 function Dimension_Table_Hash
2423 (Key : Node_Id) return Dimension_Table_Range
2426 return Dimension_Table_Range (Key mod 511);
2427 end Dimension_Table_Hash;
2429 -------------------------------------
2430 -- Dim_Warning_For_Numeric_Literal --
2431 -------------------------------------
2433 procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
2435 -- Initialize name buffer
2439 Add_String_To_Name_Buffer (String_From_Numeric_Literal (N));
2441 -- Insert a blank between the literal and the symbol
2443 Add_Str_To_Name_Buffer (" ");
2444 Add_String_To_Name_Buffer (Symbol_Of (Typ));
2446 Error_Msg_Name_1 := Name_Find;
2447 Error_Msg_N ("assumed to be%%??", N);
2448 end Dim_Warning_For_Numeric_Literal;
2450 ----------------------------------------
2451 -- Eval_Op_Expon_For_Dimensioned_Type --
2452 ----------------------------------------
2454 -- Evaluate the expon operator for real dimensioned type.
2456 -- Note that if the exponent is an integer (denominator = 1) the node is
2457 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2459 procedure Eval_Op_Expon_For_Dimensioned_Type
2463 R : constant Node_Id := Right_Opnd (N);
2464 R_Value : Rational := No_Rational;
2467 if Is_Real_Type (Btyp) then
2468 R_Value := Create_Rational_From (R, False);
2471 -- Check that the exponent is not an integer
2473 if R_Value /= No_Rational and then R_Value.Denominator /= 1 then
2474 Eval_Op_Expon_With_Rational_Exponent (N, R_Value);
2478 end Eval_Op_Expon_For_Dimensioned_Type;
2480 ------------------------------------------
2481 -- Eval_Op_Expon_With_Rational_Exponent --
2482 ------------------------------------------
2484 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2485 -- Rational and not only an Integer like for dimensionless operands. For
2486 -- that particular case, the left operand is rewritten as a function call
2487 -- using the function Expon_LLF from s-llflex.ads.
2489 procedure Eval_Op_Expon_With_Rational_Exponent
2491 Exponent_Value : Rational)
2493 Loc : constant Source_Ptr := Sloc (N);
2494 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2495 L : constant Node_Id := Left_Opnd (N);
2496 Etyp_Of_L : constant Entity_Id := Etype (L);
2497 Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2500 Dim_Power : Rational;
2501 List_Of_Dims : List_Id;
2502 New_Aspect : Node_Id;
2503 New_Aspects : List_Id;
2506 New_Subtyp_Decl_For_L : Node_Id;
2507 System : System_Type;
2510 -- Case when the operand is not dimensionless
2512 if Exists (Dims_Of_N) then
2514 -- Get the corresponding System_Type to know the exact number of
2515 -- dimensions in the system.
2517 System := System_Of (Btyp_Of_L);
2519 -- Generation of a new subtype with the proper dimensions
2521 -- In order to rewrite the operator as a type conversion, a new
2522 -- dimensioned subtype with the resulting dimensions of the
2523 -- exponentiation must be created.
2527 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2528 -- System : constant System_Id :=
2529 -- Get_Dimension_System_Id (Btyp_Of_L);
2530 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2531 -- Dimension_Systems.Table (System).Dimension_Count;
2533 -- subtype T is Btyp_Of_L
2536 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2537 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2539 -- Dims_Of_N (Num_Of_Dims).Numerator /
2540 -- Dims_Of_N (Num_Of_Dims).Denominator);
2542 -- Step 1: Generate the new aggregate for the aspect Dimension
2544 New_Aspects := Empty_List;
2546 List_Of_Dims := New_List;
2547 for Position in Dims_Of_N'First .. System.Count loop
2548 Dim_Power := Dims_Of_N (Position);
2549 Append_To (List_Of_Dims,
2550 Make_Op_Divide (Loc,
2552 Make_Integer_Literal (Loc, Int (Dim_Power.Numerator)),
2554 Make_Integer_Literal (Loc, Int (Dim_Power.Denominator))));
2557 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2560 Make_Aspect_Specification (Loc,
2561 Identifier => Make_Identifier (Loc, Name_Dimension),
2562 Expression => Make_Aggregate (Loc, Expressions => List_Of_Dims));
2564 -- Step 3: Make a temporary identifier for the new subtype
2566 New_Id := Make_Temporary (Loc, 'T');
2567 Set_Is_Internal (New_Id);
2569 -- Step 4: Declaration of the new subtype
2571 New_Subtyp_Decl_For_L :=
2572 Make_Subtype_Declaration (Loc,
2573 Defining_Identifier => New_Id,
2574 Subtype_Indication => New_Occurrence_Of (Btyp_Of_L, Loc));
2576 Append (New_Aspect, New_Aspects);
2577 Set_Parent (New_Aspects, New_Subtyp_Decl_For_L);
2578 Set_Aspect_Specifications (New_Subtyp_Decl_For_L, New_Aspects);
2580 Analyze (New_Subtyp_Decl_For_L);
2582 -- Case where the operand is dimensionless
2585 New_Id := Btyp_Of_L;
2588 -- Replacement of N by New_N
2592 -- Actual_1 := Long_Long_Float (L),
2594 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2595 -- Long_Long_Float (Exponent_Value.Denominator);
2597 -- (T (Expon_LLF (Actual_1, Actual_2)));
2599 -- where T is the subtype declared in step 1
2601 -- The node is rewritten as a type conversion
2603 -- Step 1: Creation of the two parameters of Expon_LLF function call
2606 Make_Type_Conversion (Loc,
2607 Subtype_Mark => New_Occurrence_Of (Standard_Long_Long_Float, Loc),
2608 Expression => Relocate_Node (L));
2611 Make_Op_Divide (Loc,
2613 Make_Real_Literal (Loc,
2614 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Numerator)))),
2616 Make_Real_Literal (Loc,
2617 UR_From_Uint (UI_From_Int (Int (Exponent_Value.Denominator)))));
2619 -- Step 2: Creation of New_N
2622 Make_Type_Conversion (Loc,
2623 Subtype_Mark => New_Occurrence_Of (New_Id, Loc),
2625 Make_Function_Call (Loc,
2626 Name => New_Occurrence_Of (RTE (RE_Expon_LLF), Loc),
2627 Parameter_Associations => New_List (
2628 Actual_1, Actual_2)));
2630 -- Step 3: Rewrite N with the result
2633 Set_Etype (N, New_Id);
2634 Analyze_And_Resolve (N, New_Id);
2635 end Eval_Op_Expon_With_Rational_Exponent;
2641 function Exists (Dim : Dimension_Type) return Boolean is
2643 return Dim /= Null_Dimension;
2646 function Exists (Str : String_Id) return Boolean is
2648 return Str /= No_String;
2651 function Exists (Sys : System_Type) return Boolean is
2653 return Sys /= Null_System;
2656 ---------------------------------
2657 -- Expand_Put_Call_With_Symbol --
2658 ---------------------------------
2660 -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2661 -- (System.Dim.Integer_IO), the default string parameter must be rewritten
2662 -- to include the unit symbols (resp. dimension symbols) in the output
2663 -- of a dimensioned object. Note that if a value is already supplied for
2664 -- parameter Symbol, this routine doesn't do anything.
2666 -- Case 1. Item is dimensionless
2668 -- * Put : Item appears without a suffix
2670 -- * Put_Dim_Of : the output is []
2672 -- Obj : Mks_Type := 2.6;
2673 -- Put (Obj, 1, 1, 0);
2674 -- Put_Dim_Of (Obj);
2676 -- The corresponding outputs are:
2680 -- Case 2. Item has a dimension
2682 -- * Put : If the type of Item is a dimensioned subtype whose
2683 -- symbol is not empty, then the symbol appears as a
2684 -- suffix. Otherwise, a new string is created and appears
2685 -- as a suffix of Item. This string results in the
2686 -- successive concatanations between each unit symbol
2687 -- raised by its corresponding dimension power from the
2688 -- dimensions of Item.
2690 -- * Put_Dim_Of : The output is a new string resulting in the successive
2691 -- concatanations between each dimension symbol raised by
2692 -- its corresponding dimension power from the dimensions of
2695 -- subtype Random is Mks_Type
2702 -- Obj : Random := 5.0;
2704 -- Put_Dim_Of (Obj);
2706 -- The corresponding outputs are:
2707 -- $5.0 m**3.cd**(-1)
2710 procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
2711 Actuals : constant List_Id := Parameter_Associations (N);
2712 Loc : constant Source_Ptr := Sloc (N);
2713 Name_Call : constant Node_Id := Name (N);
2714 New_Actuals : constant List_Id := New_List;
2716 Dims_Of_Actual : Dimension_Type;
2718 New_Str_Lit : Node_Id := Empty;
2719 Symbols : String_Id;
2721 Is_Put_Dim_Of : Boolean := False;
2722 -- This flag is used in order to differentiate routines Put and
2723 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2724 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2726 function Has_Symbols return Boolean;
2727 -- Return True if the current Put call already has a parameter
2728 -- association for parameter "Symbols" with the correct string of
2731 function Is_Procedure_Put_Call return Boolean;
2732 -- Return True if the current call is a call of an instantiation of a
2733 -- procedure Put defined in the package System.Dim.Float_IO and
2734 -- System.Dim.Integer_IO.
2736 function Item_Actual return Node_Id;
2737 -- Return the item actual parameter node in the output call
2743 function Has_Symbols return Boolean is
2745 Actual_Str : Node_Id;
2748 -- Look for a symbols parameter association in the list of actuals
2750 Actual := First (Actuals);
2751 while Present (Actual) loop
2753 -- Positional parameter association case when the actual is a
2756 if Nkind (Actual) = N_String_Literal then
2757 Actual_Str := Actual;
2759 -- Named parameter association case when selector name is Symbol
2761 elsif Nkind (Actual) = N_Parameter_Association
2762 and then Chars (Selector_Name (Actual)) = Name_Symbol
2764 Actual_Str := Explicit_Actual_Parameter (Actual);
2766 -- Ignore all other cases
2769 Actual_Str := Empty;
2772 if Present (Actual_Str) then
2774 -- Return True if the actual comes from source or if the string
2775 -- of symbols doesn't have the default value (i.e. it is "").
2777 if Comes_From_Source (Actual)
2778 or else String_Length (Strval (Actual_Str)) /= 0
2780 -- Complain only if the actual comes from source or if it
2781 -- hasn't been fully analyzed yet.
2783 if Comes_From_Source (Actual)
2784 or else not Analyzed (Actual)
2786 Error_Msg_N ("Symbol parameter should not be provided",
2788 Error_Msg_N ("\reserved for compiler use only", Actual);
2801 -- At this point, the call has no parameter association. Look to the
2802 -- last actual since the symbols parameter is the last one.
2804 return Nkind (Last (Actuals)) = N_String_Literal;
2807 ---------------------------
2808 -- Is_Procedure_Put_Call --
2809 ---------------------------
2811 function Is_Procedure_Put_Call return Boolean is
2816 -- There are three different Put (resp. Put_Dim_Of) routines in each
2817 -- generic dim IO package. Verify the current procedure call is one
2820 if Is_Entity_Name (Name_Call) then
2821 Ent := Entity (Name_Call);
2823 -- Get the original subprogram entity following the renaming chain
2825 if Present (Alias (Ent)) then
2831 -- Check the name of the entity subprogram is Put (resp.
2832 -- Put_Dim_Of) and verify this entity is located in either
2833 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2835 if Loc > No_Location
2836 and then Is_Dim_IO_Package_Entity
2837 (Cunit_Entity (Get_Source_Unit (Loc)))
2839 if Chars (Ent) = Name_Put_Dim_Of then
2840 Is_Put_Dim_Of := True;
2843 elsif Chars (Ent) = Name_Put then
2850 end Is_Procedure_Put_Call;
2856 function Item_Actual return Node_Id is
2860 -- Look for the item actual as a parameter association
2862 Actual := First (Actuals);
2863 while Present (Actual) loop
2864 if Nkind (Actual) = N_Parameter_Association
2865 and then Chars (Selector_Name (Actual)) = Name_Item
2867 return Explicit_Actual_Parameter (Actual);
2873 -- Case where the item has been defined without an association
2875 Actual := First (Actuals);
2877 -- Depending on the procedure Put, Item actual could be first or
2878 -- second in the list of actuals.
2880 if Has_Dimension_System (Base_Type (Etype (Actual))) then
2883 return Next (Actual);
2887 -- Start of processing for Expand_Put_Call_With_Symbol
2890 if Is_Procedure_Put_Call and then not Has_Symbols then
2891 Actual := Item_Actual;
2892 Dims_Of_Actual := Dimensions_Of (Actual);
2893 Etyp := Etype (Actual);
2897 if Is_Put_Dim_Of then
2899 -- Check that the item is not dimensionless
2901 -- Create the new String_Literal with the new String_Id generated
2902 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
2904 if Exists (Dims_Of_Actual) then
2906 Make_String_Literal (Loc,
2907 From_Dim_To_Str_Of_Dim_Symbols
2908 (Dims_Of_Actual, System_Of (Base_Type (Etyp))));
2910 -- If dimensionless, the output is []
2914 Make_String_Literal (Loc, "[]");
2920 -- Add the symbol as a suffix of the value if the subtype has a
2921 -- unit symbol or if the parameter is not dimensionless.
2923 if Exists (Symbol_Of (Etyp)) then
2924 Symbols := Symbol_Of (Etyp);
2926 Symbols := From_Dim_To_Str_Of_Unit_Symbols
2927 (Dims_Of_Actual, System_Of (Base_Type (Etyp)));
2930 -- Check Symbols exists
2932 if Exists (Symbols) then
2935 -- Put a space between the value and the dimension
2937 Store_String_Char (' ');
2938 Store_String_Chars (Symbols);
2939 New_Str_Lit := Make_String_Literal (Loc, End_String);
2943 if Present (New_Str_Lit) then
2945 -- Insert all actuals in New_Actuals
2947 Actual := First (Actuals);
2948 while Present (Actual) loop
2950 -- Copy every actuals in New_Actuals except the Symbols
2951 -- parameter association.
2953 if Nkind (Actual) = N_Parameter_Association
2954 and then Chars (Selector_Name (Actual)) /= Name_Symbol
2956 Append_To (New_Actuals,
2957 Make_Parameter_Association (Loc,
2958 Selector_Name => New_Copy (Selector_Name (Actual)),
2959 Explicit_Actual_Parameter =>
2960 New_Copy (Explicit_Actual_Parameter (Actual))));
2962 elsif Nkind (Actual) /= N_Parameter_Association then
2963 Append_To (New_Actuals, New_Copy (Actual));
2969 -- Create new Symbols param association and append to New_Actuals
2971 Append_To (New_Actuals,
2972 Make_Parameter_Association (Loc,
2973 Selector_Name => Make_Identifier (Loc, Name_Symbol),
2974 Explicit_Actual_Parameter => New_Str_Lit));
2976 -- Rewrite and analyze the procedure call
2979 Make_Procedure_Call_Statement (Loc,
2980 Name => New_Copy (Name_Call),
2981 Parameter_Associations => New_Actuals));
2986 end Expand_Put_Call_With_Symbol;
2988 ------------------------------------
2989 -- From_Dim_To_Str_Of_Dim_Symbols --
2990 ------------------------------------
2992 -- Given a dimension vector and the corresponding dimension system, create
2993 -- a String_Id to output dimension symbols corresponding to the dimensions
2994 -- Dims. If In_Error_Msg is True, there is a special handling for character
2995 -- asterisk * which is an insertion character in error messages.
2997 function From_Dim_To_Str_Of_Dim_Symbols
2998 (Dims : Dimension_Type;
2999 System : System_Type;
3000 In_Error_Msg : Boolean := False) return String_Id
3002 Dim_Power : Rational;
3003 First_Dim : Boolean := True;
3005 procedure Store_String_Oexpon;
3006 -- Store the expon operator symbol "**" in the string. In error
3007 -- messages, asterisk * is a special character and must be quoted
3008 -- to be placed literally into the message.
3010 -------------------------
3011 -- Store_String_Oexpon --
3012 -------------------------
3014 procedure Store_String_Oexpon is
3016 if In_Error_Msg then
3017 Store_String_Chars ("'*'*");
3019 Store_String_Chars ("**");
3021 end Store_String_Oexpon;
3023 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
3026 -- Initialization of the new String_Id
3030 -- Store the dimension symbols inside boxes
3032 if In_Error_Msg then
3033 Store_String_Chars ("'[");
3035 Store_String_Char ('[');
3038 for Position in Dimension_Type'Range loop
3039 Dim_Power := Dims (Position);
3040 if Dim_Power /= Zero then
3045 Store_String_Char ('.');
3048 Store_String_Chars (System.Dim_Symbols (Position));
3050 -- Positive dimension case
3052 if Dim_Power.Numerator > 0 then
3056 if Dim_Power.Denominator = 1 then
3057 if Dim_Power.Numerator /= 1 then
3058 Store_String_Oexpon;
3059 Store_String_Int (Int (Dim_Power.Numerator));
3062 -- Rational case when denominator /= 1
3065 Store_String_Oexpon;
3066 Store_String_Char ('(');
3067 Store_String_Int (Int (Dim_Power.Numerator));
3068 Store_String_Char ('/');
3069 Store_String_Int (Int (Dim_Power.Denominator));
3070 Store_String_Char (')');
3073 -- Negative dimension case
3076 Store_String_Oexpon;
3077 Store_String_Char ('(');
3078 Store_String_Char ('-');
3079 Store_String_Int (Int (-Dim_Power.Numerator));
3083 if Dim_Power.Denominator = 1 then
3084 Store_String_Char (')');
3086 -- Rational case when denominator /= 1
3089 Store_String_Char ('/');
3090 Store_String_Int (Int (Dim_Power.Denominator));
3091 Store_String_Char (')');
3097 if In_Error_Msg then
3098 Store_String_Chars ("']");
3100 Store_String_Char (']');
3104 end From_Dim_To_Str_Of_Dim_Symbols;
3106 -------------------------------------
3107 -- From_Dim_To_Str_Of_Unit_Symbols --
3108 -------------------------------------
3110 -- Given a dimension vector and the corresponding dimension system,
3111 -- create a String_Id to output the unit symbols corresponding to the
3114 function From_Dim_To_Str_Of_Unit_Symbols
3115 (Dims : Dimension_Type;
3116 System : System_Type) return String_Id
3118 Dim_Power : Rational;
3119 First_Dim : Boolean := True;
3122 -- Return No_String if dimensionless
3124 if not Exists (Dims) then
3128 -- Initialization of the new String_Id
3132 for Position in Dimension_Type'Range loop
3133 Dim_Power := Dims (Position);
3135 if Dim_Power /= Zero then
3139 Store_String_Char ('.');
3142 Store_String_Chars (System.Unit_Symbols (Position));
3144 -- Positive dimension case
3146 if Dim_Power.Numerator > 0 then
3150 if Dim_Power.Denominator = 1 then
3151 if Dim_Power.Numerator /= 1 then
3152 Store_String_Chars ("**");
3153 Store_String_Int (Int (Dim_Power.Numerator));
3156 -- Rational case when denominator /= 1
3159 Store_String_Chars ("**");
3160 Store_String_Char ('(');
3161 Store_String_Int (Int (Dim_Power.Numerator));
3162 Store_String_Char ('/');
3163 Store_String_Int (Int (Dim_Power.Denominator));
3164 Store_String_Char (')');
3167 -- Negative dimension case
3170 Store_String_Chars ("**");
3171 Store_String_Char ('(');
3172 Store_String_Char ('-');
3173 Store_String_Int (Int (-Dim_Power.Numerator));
3177 if Dim_Power.Denominator = 1 then
3178 Store_String_Char (')');
3180 -- Rational case when denominator /= 1
3183 Store_String_Char ('/');
3184 Store_String_Int (Int (Dim_Power.Denominator));
3185 Store_String_Char (')');
3192 end From_Dim_To_Str_Of_Unit_Symbols;
3198 function GCD (Left, Right : Whole) return Int is
3218 --------------------------
3219 -- Has_Dimension_System --
3220 --------------------------
3222 function Has_Dimension_System (Typ : Entity_Id) return Boolean is
3224 return Exists (System_Of (Typ));
3225 end Has_Dimension_System;
3227 ------------------------------
3228 -- Is_Dim_IO_Package_Entity --
3229 ------------------------------
3231 function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
3233 -- Check the package entity corresponds to System.Dim.Float_IO or
3234 -- System.Dim.Integer_IO.
3237 Is_RTU (E, System_Dim_Float_IO)
3239 Is_RTU (E, System_Dim_Integer_IO);
3240 end Is_Dim_IO_Package_Entity;
3242 -------------------------------------
3243 -- Is_Dim_IO_Package_Instantiation --
3244 -------------------------------------
3246 function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
3247 Gen_Id : constant Node_Id := Name (N);
3250 -- Check that the instantiated package is either System.Dim.Float_IO
3251 -- or System.Dim.Integer_IO.
3254 Is_Entity_Name (Gen_Id)
3255 and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
3256 end Is_Dim_IO_Package_Instantiation;
3262 function Is_Invalid (Position : Dimension_Position) return Boolean is
3264 return Position = Invalid_Position;
3267 ---------------------
3268 -- Move_Dimensions --
3269 ---------------------
3271 procedure Move_Dimensions (From, To : Node_Id) is
3273 if Ada_Version < Ada_2012 then
3277 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
3279 Copy_Dimensions (From, To);
3280 Remove_Dimensions (From);
3281 end Move_Dimensions;
3287 function Reduce (X : Rational) return Rational is
3289 if X.Numerator = 0 then
3294 G : constant Int := GCD (X.Numerator, X.Denominator);
3296 return Rational'(Numerator => Whole (Int (X.Numerator) / G),
3297 Denominator => Whole (Int (X.Denominator) / G));
3301 -----------------------
3302 -- Remove_Dimensions --
3303 -----------------------
3305 procedure Remove_Dimensions (N : Node_Id) is
3306 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
3308 if Exists (Dims_Of_N) then
3309 Dimension_Table.Remove (N);
3311 end Remove_Dimensions;
3313 -----------------------------------
3314 -- Remove_Dimension_In_Statement --
3315 -----------------------------------
3317 -- Removal of dimension in statement as part of the Analyze_Statements
3318 -- routine (see package Sem_Ch5).
3320 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
3322 if Ada_Version < Ada_2012 then
3326 -- Remove dimension in parameter specifications for accept statement
3328 if Nkind (Stmt) = N_Accept_Statement then
3330 Param : Node_Id := First (Parameter_Specifications (Stmt));
3332 while Present (Param) loop
3333 Remove_Dimensions (Param);
3338 -- Remove dimension of name and expression in assignments
3340 elsif Nkind (Stmt) = N_Assignment_Statement then
3341 Remove_Dimensions (Expression (Stmt));
3342 Remove_Dimensions (Name (Stmt));
3344 end Remove_Dimension_In_Statement;
3346 --------------------
3347 -- Set_Dimensions --
3348 --------------------
3350 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
3352 pragma Assert (OK_For_Dimension (Nkind (N)));
3353 pragma Assert (Exists (Val));
3355 Dimension_Table.Set (N, Val);
3362 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
3364 Symbol_Table.Set (E, Val);
3367 ---------------------------------
3368 -- String_From_Numeric_Literal --
3369 ---------------------------------
3371 function String_From_Numeric_Literal (N : Node_Id) return String_Id is
3372 Loc : constant Source_Ptr := Sloc (N);
3373 Sbuffer : constant Source_Buffer_Ptr :=
3374 Source_Text (Get_Source_File_Index (Loc));
3375 Src_Ptr : Source_Ptr := Loc;
3377 C : Character := Sbuffer (Src_Ptr);
3378 -- Current source program character
3380 function Belong_To_Numeric_Literal (C : Character) return Boolean;
3381 -- Return True if C belongs to a numeric literal
3383 -------------------------------
3384 -- Belong_To_Numeric_Literal --
3385 -------------------------------
3387 function Belong_To_Numeric_Literal (C : Character) return Boolean is
3403 -- Make sure '+' or '-' is part of an exponent.
3407 Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
3409 return Prev_C = 'e' or else Prev_C = 'E';
3412 -- All other character doesn't belong to a numeric literal
3417 end Belong_To_Numeric_Literal;
3419 -- Start of processing for String_From_Numeric_Literal
3423 while Belong_To_Numeric_Literal (C) loop
3424 Store_String_Char (C);
3425 Src_Ptr := Src_Ptr + 1;
3426 C := Sbuffer (Src_Ptr);
3430 end String_From_Numeric_Literal;
3436 function Symbol_Of (E : Entity_Id) return String_Id is
3437 Subtype_Symbol : constant String_Id := Symbol_Table.Get (E);
3439 if Subtype_Symbol /= No_String then
3440 return Subtype_Symbol;
3442 return From_Dim_To_Str_Of_Unit_Symbols
3443 (Dimensions_Of (E), System_Of (Base_Type (E)));
3447 -----------------------
3448 -- Symbol_Table_Hash --
3449 -----------------------
3451 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
3453 return Symbol_Table_Range (Key mod 511);
3454 end Symbol_Table_Hash;
3460 function System_Of (E : Entity_Id) return System_Type is
3461 Type_Decl : constant Node_Id := Parent (E);
3464 -- Look for Type_Decl in System_Table
3466 for Dim_Sys in 1 .. System_Table.Last loop
3467 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
3468 return System_Table.Table (Dim_Sys);