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 Sinfo
; use Sinfo
;
40 with Snames
; use Snames
;
41 with Stand
; use Stand
;
42 with Stringt
; use Stringt
;
44 with Tbuild
; use Tbuild
;
45 with Uintp
; use Uintp
;
46 with Urealp
; use Urealp
;
50 package body Sem_Dim
is
52 -------------------------
53 -- Rational arithmetic --
54 -------------------------
56 type Whole
is new Int
;
57 subtype Positive_Whole
is Whole
range 1 .. Whole
'Last;
59 type Rational
is record
61 Denominator
: Positive_Whole
;
64 Zero
: constant Rational
:= Rational
'(Numerator => 0,
67 No_Rational : constant Rational := Rational'(Numerator
=> 0,
69 -- Used to indicate an expression that cannot be interpreted as a rational
70 -- Returned value of the Create_Rational_From routine when parameter Expr
71 -- is not a static representation of a rational.
73 -- Rational constructors
75 function "+" (Right
: Whole
) return Rational
;
76 function GCD
(Left
, Right
: Whole
) return Int
;
77 function Reduce
(X
: Rational
) return Rational
;
79 -- Unary operator for Rational
81 function "-" (Right
: Rational
) return Rational
;
82 function "abs" (Right
: Rational
) return Rational
;
84 -- Rational operations for Rationals
86 function "+" (Left
, Right
: Rational
) return Rational
;
87 function "-" (Left
, Right
: Rational
) return Rational
;
88 function "*" (Left
, Right
: Rational
) return Rational
;
89 function "/" (Left
, Right
: Rational
) return Rational
;
95 Max_Number_Of_Dimensions
: constant := 7;
96 -- Maximum number of dimensions in a dimension system
98 High_Position_Bound
: constant := Max_Number_Of_Dimensions
;
99 Invalid_Position
: constant := 0;
100 Low_Position_Bound
: constant := 1;
102 subtype Dimension_Position
is
103 Nat
range Invalid_Position
.. High_Position_Bound
;
106 array (Dimension_Position
range
107 Low_Position_Bound
.. High_Position_Bound
) of Name_Id
;
108 -- A data structure used to store the names of all units within a system
110 No_Names
: constant Name_Array
:= (others => No_Name
);
113 array (Dimension_Position
range
114 Low_Position_Bound
.. High_Position_Bound
) of String_Id
;
115 -- A data structure used to store the symbols of all units within a system
117 No_Symbols
: constant Symbol_Array
:= (others => No_String
);
119 -- The following record should be documented field by field
121 type System_Type
is record
123 Unit_Names
: Name_Array
;
124 Unit_Symbols
: Symbol_Array
;
125 Dim_Symbols
: Symbol_Array
;
126 Count
: Dimension_Position
;
129 Null_System
: constant System_Type
:=
130 (Empty
, No_Names
, No_Symbols
, No_Symbols
, Invalid_Position
);
132 subtype System_Id
is Nat
;
134 -- The following table maps types to systems
136 package System_Table
is new Table
.Table
(
137 Table_Component_Type
=> System_Type
,
138 Table_Index_Type
=> System_Id
,
139 Table_Low_Bound
=> 1,
141 Table_Increment
=> 5,
142 Table_Name
=> "System_Table");
148 type Dimension_Type
is
149 array (Dimension_Position
range
150 Low_Position_Bound
.. High_Position_Bound
) of Rational
;
152 Null_Dimension
: constant Dimension_Type
:= (others => Zero
);
154 type Dimension_Table_Range
is range 0 .. 510;
155 function Dimension_Table_Hash
(Key
: Node_Id
) return Dimension_Table_Range
;
157 -- The following table associates nodes with dimensions
159 package Dimension_Table
is new
160 GNAT
.HTable
.Simple_HTable
161 (Header_Num
=> Dimension_Table_Range
,
162 Element
=> Dimension_Type
,
163 No_Element
=> Null_Dimension
,
165 Hash
=> Dimension_Table_Hash
,
172 type Symbol_Table_Range
is range 0 .. 510;
173 function Symbol_Table_Hash
(Key
: Entity_Id
) return Symbol_Table_Range
;
175 -- Each subtype with a dimension has a symbolic representation of the
176 -- related unit. This table establishes a relation between the subtype
179 package Symbol_Table
is new
180 GNAT
.HTable
.Simple_HTable
181 (Header_Num
=> Symbol_Table_Range
,
182 Element
=> String_Id
,
183 No_Element
=> No_String
,
185 Hash
=> Symbol_Table_Hash
,
188 -- The following array enumerates all contexts which may contain or
189 -- produce a dimension.
191 OK_For_Dimension
: constant array (Node_Kind
) of Boolean :=
192 (N_Attribute_Reference
=> True,
193 N_Defining_Identifier
=> True,
194 N_Function_Call
=> True,
195 N_Identifier
=> True,
196 N_Indexed_Component
=> True,
197 N_Integer_Literal
=> True,
204 N_Op_Multiply
=> True,
207 N_Op_Subtract
=> True,
208 N_Qualified_Expression
=> True,
209 N_Real_Literal
=> True,
210 N_Selected_Component
=> True,
212 N_Type_Conversion
=> True,
213 N_Unchecked_Type_Conversion
=> True,
217 -----------------------
218 -- Local Subprograms --
219 -----------------------
221 procedure Analyze_Dimension_Assignment_Statement
(N
: Node_Id
);
222 -- Subroutine of Analyze_Dimension for assignment statement. Check that the
223 -- dimensions of the left-hand side and the right-hand side of N match.
225 procedure Analyze_Dimension_Binary_Op
(N
: Node_Id
);
226 -- Subroutine of Analyze_Dimension for binary operators. Check the
227 -- dimensions of the right and the left operand permit the operation.
228 -- Then, evaluate the resulting dimensions for each binary operator.
230 procedure Analyze_Dimension_Component_Declaration
(N
: Node_Id
);
231 -- Subroutine of Analyze_Dimension for component declaration. Check that
232 -- the dimensions of the type of N and of the expression match.
234 procedure Analyze_Dimension_Extended_Return_Statement
(N
: Node_Id
);
235 -- Subroutine of Analyze_Dimension for extended return statement. Check
236 -- that the dimensions of the returned type and of the returned object
239 procedure Analyze_Dimension_Function_Call
(N
: Node_Id
);
240 -- Subroutine of Analyze_Dimension for function call. General case:
241 -- propagate the dimensions from the returned type to N. Elementary
242 -- function case (Ada.Numerics.Generic_Elementary_Functions): If N
243 -- is a Sqrt call, then evaluate the resulting dimensions as half the
244 -- dimensions of the parameter. Otherwise, verify that each parameters
245 -- are dimensionless.
247 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
);
248 -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by
250 -- N_Attribute_Reference
252 -- N_Indexed_Component
253 -- N_Qualified_Expression
254 -- N_Selected_Component
257 -- N_Unchecked_Type_Conversion
259 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
);
260 -- Subroutine of Analyze_Dimension for object declaration. Check that
261 -- the dimensions of the object type and the dimensions of the expression
262 -- (if expression is present) match. Note that when the expression is
263 -- a literal, no error is returned. This special case allows object
264 -- declaration such as: m : constant Length := 1.0;
266 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
);
267 -- Subroutine of Analyze_Dimension for object renaming declaration. Check
268 -- the dimensions of the type and of the renamed object name of N match.
270 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
);
271 -- Subroutine of Analyze_Dimension for simple return statement
272 -- Check that the dimensions of the returned type and of the returned
275 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
);
276 -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
277 -- dimensions from the parent type to the identifier of N. Note that if
278 -- both the identifier and the parent type of N are not dimensionless,
281 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
);
282 -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
283 -- Abs operators, propagate the dimensions from the operand to N.
285 function Create_Rational_From
287 Complain
: Boolean) return Rational
;
288 -- Given an arbitrary expression Expr, return a valid rational if Expr can
289 -- be interpreted as a rational. Otherwise return No_Rational and also an
290 -- error message if Complain is set to True.
292 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
;
293 -- Return the dimension vector of node N
295 function Dimensions_Msg_Of
(N
: Node_Id
) return String;
296 -- Given a node, return "has dimension" followed by the dimension symbols
297 -- of N or "is dimensionless" if N is dimensionless.
299 procedure Eval_Op_Expon_With_Rational_Exponent
301 Exponent_Value
: Rational
);
302 -- Evaluate the exponent it is a rational and the operand has a dimension
304 function Exists
(Dim
: Dimension_Type
) return Boolean;
305 -- Returns True iff Dim does not denote the null dimension
307 function Exists
(Sys
: System_Type
) return Boolean;
308 -- Returns True iff Sys does not denote the null system
310 function From_Dim_To_Str_Of_Dim_Symbols
311 (Dims
: Dimension_Type
;
312 System
: System_Type
;
313 In_Error_Msg
: Boolean := False) return String_Id
;
314 -- Given a dimension vector and a dimension system, return the proper
315 -- string of dimension symbols. If In_Error_Msg is True (i.e. the String_Id
316 -- will be used to issue an error message) then this routine has a special
317 -- handling for the insertion character asterisk * which must be precede by
318 -- a quote ' to to be placed literally into the message.
320 function From_Dim_To_Str_Of_Unit_Symbols
321 (Dims
: Dimension_Type
;
322 System
: System_Type
) return String_Id
;
323 -- Given a dimension vector and a dimension system, return the proper
324 -- string of unit symbols.
326 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean;
327 -- Return True if E is the package entity of System.Dim.Float_IO or
328 -- System.Dim.Integer_IO.
330 function Is_Invalid
(Position
: Dimension_Position
) return Boolean;
331 -- Return True if Pos denotes the invalid position
333 procedure Move_Dimensions
(From
: Node_Id
; To
: Node_Id
);
334 -- Copy dimension vector of From to To, delete dimension vector of From
336 procedure Remove_Dimensions
(N
: Node_Id
);
337 -- Remove the dimension vector of node N
339 procedure Set_Dimensions
(N
: Node_Id
; Val
: Dimension_Type
);
340 -- Associate a dimension vector with a node
342 procedure Set_Symbol
(E
: Entity_Id
; Val
: String_Id
);
343 -- Associate a symbol representation of a dimension vector with a subtype
345 function Symbol_Of
(E
: Entity_Id
) return String_Id
;
346 -- E denotes a subtype with a dimension. Return the symbol representation
347 -- of the dimension vector.
349 function System_Of
(E
: Entity_Id
) return System_Type
;
350 -- E denotes a type, return associated system of the type if it has one
356 function "+" (Right
: Whole
) return Rational
is
358 return Rational
'(Numerator => Right,
362 function "+" (Left, Right : Rational) return Rational is
363 R : constant Rational :=
364 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
+
365 Left
.Denominator
* Right
.Numerator
,
366 Denominator
=> Left
.Denominator
* Right
.Denominator
);
375 function "-" (Right
: Rational
) return Rational
is
377 return Rational
'(Numerator => -Right.Numerator,
378 Denominator => Right.Denominator);
381 function "-" (Left, Right : Rational) return Rational is
382 R : constant Rational :=
383 Rational'(Numerator
=> Left
.Numerator
* Right
.Denominator
-
384 Left
.Denominator
* Right
.Numerator
,
385 Denominator
=> Left
.Denominator
* Right
.Denominator
);
395 function "*" (Left
, Right
: Rational
) return Rational
is
396 R
: constant Rational
:=
397 Rational
'(Numerator => Left.Numerator * Right.Numerator,
398 Denominator => Left.Denominator * Right.Denominator);
407 function "/" (Left, Right : Rational) return Rational is
408 R : constant Rational := abs Right;
409 L : Rational := Left;
412 if Right.Numerator < 0 then
413 L.Numerator := Whole (-Integer (L.Numerator));
416 return Reduce (Rational'(Numerator
=> L
.Numerator
* R
.Denominator
,
417 Denominator
=> L
.Denominator
* R
.Numerator
));
424 function "abs" (Right
: Rational
) return Rational
is
426 return Rational
'(Numerator => abs Right.Numerator,
427 Denominator => Right.Denominator);
430 ------------------------------
431 -- Analyze_Aspect_Dimension --
432 ------------------------------
434 -- with Dimension => (
435 -- [[Symbol =>] SYMBOL,]
437 -- [, DIMENSION_VALUE]
438 -- [, DIMENSION_VALUE]
439 -- [, DIMENSION_VALUE]
440 -- [, DIMENSION_VALUE]
441 -- [, DIMENSION_VALUE]
442 -- [, DIMENSION_VALUE]);
444 -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL
446 -- DIMENSION_VALUE ::=
448 -- | others => RATIONAL
449 -- | DISCRETE_CHOICE_LIST => RATIONAL
451 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
453 -- Note that when the dimensioned type is an integer type, then any
454 -- dimension value must be an integer literal.
456 procedure Analyze_Aspect_Dimension
461 Def_Id : constant Entity_Id := Defining_Identifier (N);
463 Processed : array (Dimension_Type'Range) of Boolean := (others => False);
464 -- This array is used when processing ranges or Others_Choice as part of
465 -- the dimension aggregate.
467 Dimensions : Dimension_Type := Null_Dimension;
469 procedure Extract_Power
471 Position : Dimension_Position);
472 -- Given an expression with denotes a rational number, read the number
473 -- and associate it with Position in Dimensions.
475 function Position_In_System
477 System : System_Type) return Dimension_Position;
478 -- Given an identifier which denotes a dimension, return the position of
479 -- that dimension within System.
485 procedure Extract_Power
487 Position : Dimension_Position)
492 if Is_Integer_Type (Def_Id) then
493 -- Dimension value must be an integer literal
495 if Nkind (Expr) = N_Integer_Literal then
496 Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
498 Error_Msg_N ("integer literal expected", Expr);
504 Dimensions (Position) := Create_Rational_From (Expr, True);
507 Processed (Position) := True;
510 ------------------------
511 -- Position_In_System --
512 ------------------------
514 function Position_In_System
516 System : System_Type) return Dimension_Position
518 Dimension_Name : constant Name_Id := Chars (Id);
521 for Position in System.Unit_Names'Range loop
522 if Dimension_Name = System.Unit_Names (Position) then
527 return Invalid_Position;
528 end Position_In_System;
535 Num_Choices : Nat := 0;
536 Num_Dimensions : Nat := 0;
537 Others_Seen : Boolean := False;
540 Symbol : String_Id := No_String;
541 Symbol_Expr : Node_Id;
542 System : System_Type;
546 -- Errors_Count is a count of errors detected by the compiler so far
547 -- just before the extraction of symbol, names and values in the
548 -- aggregate (Step 2).
550 -- At the end of the analysis, there is a check to verify that this
551 -- count equals to Serious_Errors_Detected i.e. no erros have been
552 -- encountered during the process. Otherwise the Dimension_Table is
555 -- Start of processing for Analyze_Aspect_Dimension
558 -- STEP 1: Legality of aspect
560 if Nkind (N) /= N_Subtype_Declaration then
561 Error_Msg_NE ("aspect& must apply to subtype declaration", N, Id);
565 Sub_Ind := Subtype_Indication (N);
566 Typ := Etype (Sub_Ind);
567 System := System_Of (Typ);
569 if Nkind (Sub_Ind) = N_Subtype_Indication then
571 ("constraint not allowed with aspect&", Constraint (Sub_Ind), Id);
575 -- The dimension declarations are useless if the parent type does not
576 -- declare a valid system.
578 if not Exists (System) then
580 ("parent type of& lacks dimension system", Sub_Ind, Def_Id);
584 if Nkind (Aggr) /= N_Aggregate then
585 Error_Msg_N ("aggregate expected", Aggr);
589 -- STEP 2: Symbol, Names and values extraction
591 -- Get the number of errors detected by the compiler so far
593 Errors_Count := Serious_Errors_Detected;
595 -- STEP 2a: Symbol extraction
597 -- The first entry in the aggregate may be the symbolic representation
600 -- Positional symbol argument
602 Symbol_Expr := First (Expressions (Aggr));
604 -- Named symbol argument
607 or else not Nkind_In (Symbol_Expr, N_Character_Literal,
610 Symbol_Expr := Empty;
612 -- Component associations present
614 if Present (Component_Associations (Aggr)) then
615 Assoc := First (Component_Associations (Aggr));
616 Choice := First (Choices (Assoc));
618 if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
620 -- Symbol component association is present
622 if Chars (Choice) = Name_Symbol then
623 Num_Choices := Num_Choices + 1;
624 Symbol_Expr := Expression (Assoc);
626 -- Verify symbol expression is a string or a character
628 if not Nkind_In (Symbol_Expr, N_Character_Literal,
631 Symbol_Expr := Empty;
633 ("symbol expression must be character or string",
637 -- Special error if no Symbol choice but expression is string
640 elsif Nkind_In (Expression (Assoc), N_Character_Literal,
643 Num_Choices := Num_Choices + 1;
644 Error_Msg_N ("optional component Symbol expected, found&",
651 -- STEP 2b: Names and values extraction
653 -- Positional elements
655 Expr := First (Expressions (Aggr));
657 -- Skip the symbol expression when present
659 if Present (Symbol_Expr) and then Num_Choices = 0 then
663 Position := Low_Position_Bound;
664 while Present (Expr) loop
665 if Position > High_Position_Bound then
667 ("type& has more dimensions than system allows", Def_Id);
671 Extract_Power (Expr, Position);
673 Position := Position + 1;
674 Num_Dimensions := Num_Dimensions + 1;
681 Assoc := First (Component_Associations (Aggr));
683 -- Skip the symbol association when present
685 if Num_Choices = 1 then
689 while Present (Assoc) loop
690 Expr := Expression (Assoc);
692 Choice := First (Choices (Assoc));
693 while Present (Choice) loop
695 -- Identifier case: NAME => EXPRESSION
697 if Nkind (Choice) = N_Identifier then
698 Position := Position_In_System (Choice, System);
700 if Is_Invalid (Position) then
701 Error_Msg_N ("dimension name& not part of system", Choice);
703 Extract_Power (Expr, Position);
706 -- Range case: NAME .. NAME => EXPRESSION
708 elsif Nkind (Choice) = N_Range then
710 Low : constant Node_Id := Low_Bound (Choice);
711 High : constant Node_Id := High_Bound (Choice);
712 Low_Pos : Dimension_Position;
713 High_Pos : Dimension_Position;
716 if Nkind (Low) /= N_Identifier then
717 Error_Msg_N ("bound must denote a dimension name", Low);
719 elsif Nkind (High) /= N_Identifier then
720 Error_Msg_N ("bound must denote a dimension name", High);
723 Low_Pos := Position_In_System (Low, System);
724 High_Pos := Position_In_System (High, System);
726 if Is_Invalid (Low_Pos) then
727 Error_Msg_N ("dimension name& not part of system",
730 elsif Is_Invalid (High_Pos) then
731 Error_Msg_N ("dimension name& not part of system",
734 elsif Low_Pos > High_Pos then
735 Error_Msg_N ("expected low to high range", Choice);
738 for Position in Low_Pos .. High_Pos loop
739 Extract_Power (Expr, Position);
745 -- Others case: OTHERS => EXPRESSION
747 elsif Nkind (Choice) = N_Others_Choice then
748 if Present (Next (Choice)) or else Present (Prev (Choice)) then
750 ("OTHERS must appear alone in a choice list", Choice);
752 elsif Present (Next (Assoc)) then
754 ("OTHERS must appear last in an aggregate", Choice);
756 elsif Others_Seen then
757 Error_Msg_N ("multiple OTHERS not allowed", Choice);
760 -- Fill the non-processed dimensions with the default value
761 -- supplied by others.
763 for Position in Processed'Range loop
764 if not Processed (Position) then
765 Extract_Power (Expr, Position);
772 -- All other cases are erroneous declarations of dimension names
775 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
778 Num_Choices := Num_Choices + 1;
782 Num_Dimensions := Num_Dimensions + 1;
786 -- STEP 3: Consistency of system and dimensions
788 if Present (First (Expressions (Aggr)))
789 and then (First (Expressions (Aggr)) /= Symbol_Expr
790 or else Present (Next (Symbol_Expr)))
791 and then (Num_Choices > 1
792 or else (Num_Choices = 1 and then not Others_Seen))
795 ("named associations cannot follow positional associations", Aggr);
798 if Num_Dimensions > System.Count then
799 Error_Msg_N ("type& has more dimensions than system allows", Def_Id);
801 elsif Num_Dimensions < System.Count and then not Others_Seen then
802 Error_Msg_N ("type& has less dimensions than system allows", Def_Id);
805 -- STEP 4: Dimension symbol extraction
807 if Present (Symbol_Expr) then
808 if Nkind (Symbol_Expr) = N_Character_Literal then
810 Store_String_Char (UI_To_CC (Char_Literal_Value (Symbol_Expr)));
811 Symbol := End_String;
814 Symbol := Strval (Symbol_Expr);
817 if String_Length (Symbol) = 0 then
818 Error_Msg_N ("empty string not allowed here", Symbol_Expr);
822 -- STEP 5: Storage of extracted values
824 -- Check that no errors have been detected during the analysis
826 if Errors_Count = Serious_Errors_Detected then
828 -- Check for useless declaration
830 if Symbol = No_String and then not Exists (Dimensions) then
831 Error_Msg_N ("useless dimension declaration", Aggr);
834 if Symbol /= No_String then
835 Set_Symbol (Def_Id, Symbol);
838 if Exists (Dimensions) then
839 Set_Dimensions (Def_Id, Dimensions);
842 end Analyze_Aspect_Dimension;
844 -------------------------------------
845 -- Analyze_Aspect_Dimension_System --
846 -------------------------------------
848 -- with Dimension_System => (
858 -- [Unit_Name =>] IDENTIFIER,
859 -- [Unit_Symbol =>] SYMBOL,
860 -- [Dim_Symbol =>] SYMBOL)
862 procedure Analyze_Aspect_Dimension_System
867 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean;
868 -- Determine whether type declaration N denotes a numeric derived type
870 -------------------------------
871 -- Is_Derived_Numeric_Type --
872 -------------------------------
874 function Is_Derived_Numeric_Type (N : Node_Id) return Boolean is
877 Nkind (N) = N_Full_Type_Declaration
878 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
879 and then Is_Numeric_Type
880 (Entity (Subtype_Indication (Type_Definition (N))));
881 end Is_Derived_Numeric_Type;
888 Dim_Symbol : Node_Id;
889 Dim_Symbols : Symbol_Array := No_Symbols;
890 Dim_System : System_Type := Null_System;
893 Unit_Names : Name_Array := No_Names;
894 Unit_Symbol : Node_Id;
895 Unit_Symbols : Symbol_Array := No_Symbols;
898 -- Errors_Count is a count of errors detected by the compiler so far
899 -- just before the extraction of names and symbols in the aggregate
902 -- At the end of the analysis, there is a check to verify that this
903 -- count equals Serious_Errors_Detected i.e. no errors have been
904 -- encountered during the process. Otherwise the System_Table is
907 -- Start of processing for Analyze_Aspect_Dimension_System
910 -- STEP 1: Legality of aspect
912 if not Is_Derived_Numeric_Type (N) then
914 ("aspect& must apply to numeric derived type declaration", N, Id);
918 if Nkind (Aggr) /= N_Aggregate then
919 Error_Msg_N ("aggregate expected", Aggr);
923 -- STEP 2: Structural verification of the dimension aggregate
925 if Present (Component_Associations (Aggr)) then
926 Error_Msg_N ("expected positional aggregate", Aggr);
930 -- STEP 3: Name and Symbol extraction
932 Dim_Aggr := First (Expressions (Aggr));
933 Errors_Count := Serious_Errors_Detected;
934 while Present (Dim_Aggr) loop
935 Position := Position + 1;
937 if Position > High_Position_Bound then
939 ("too many dimensions in system", Aggr);
943 if Nkind (Dim_Aggr) /= N_Aggregate then
944 Error_Msg_N ("aggregate expected", Dim_Aggr);
947 if Present (Component_Associations (Dim_Aggr))
948 and then Present (Expressions (Dim_Aggr))
950 Error_Msg_N ("mixed positional/named aggregate not allowed " &
954 -- Verify each dimension aggregate has three arguments
956 elsif List_Length (Component_Associations (Dim_Aggr)) /= 3
957 and then List_Length (Expressions (Dim_Aggr)) /= 3
960 ("three components expected in aggregate", Dim_Aggr);
963 -- Named dimension aggregate
965 if Present (Component_Associations (Dim_Aggr)) then
967 -- Check first argument denotes the unit name
969 Assoc := First (Component_Associations (Dim_Aggr));
970 Choice := First (Choices (Assoc));
971 Unit_Name := Expression (Assoc);
973 if Present (Next (Choice))
974 or else Nkind (Choice) /= N_Identifier
976 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
978 elsif Chars (Choice) /= Name_Unit_Name then
979 Error_Msg_N ("expected Unit_Name, found&", Choice);
982 -- Check the second argument denotes the unit symbol
985 Choice := First (Choices (Assoc));
986 Unit_Symbol := Expression (Assoc);
988 if Present (Next (Choice))
989 or else Nkind (Choice) /= N_Identifier
991 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
993 elsif Chars (Choice) /= Name_Unit_Symbol then
994 Error_Msg_N ("expected Unit_Symbol, found&", Choice);
997 -- Check the third argument denotes the dimension symbol
1000 Choice := First (Choices (Assoc));
1001 Dim_Symbol := Expression (Assoc);
1003 if Present (Next (Choice))
1004 or else Nkind (Choice) /= N_Identifier
1006 Error_Msg_NE ("wrong syntax for aspect&", Choice, Id);
1008 elsif Chars (Choice) /= Name_Dim_Symbol then
1009 Error_Msg_N ("expected Dim_Symbol, found&", Choice);
1012 -- Positional dimension aggregate
1015 Unit_Name := First (Expressions (Dim_Aggr));
1016 Unit_Symbol := Next (Unit_Name);
1017 Dim_Symbol := Next (Unit_Symbol);
1020 -- Check the first argument for each dimension aggregate is
1023 if Nkind (Unit_Name) = N_Identifier then
1024 Unit_Names (Position) := Chars (Unit_Name);
1026 Error_Msg_N ("expected unit name", Unit_Name);
1029 -- Check the second argument for each dimension aggregate is
1030 -- a string or a character.
1035 N_Character_Literal)
1037 Error_Msg_N ("expected unit symbol (string or character)",
1043 if Nkind (Unit_Symbol) = N_String_Literal then
1044 Unit_Symbols (Position) := Strval (Unit_Symbol);
1051 (UI_To_CC (Char_Literal_Value (Unit_Symbol)));
1052 Unit_Symbols (Position) := End_String;
1055 -- Verify that the string is not empty
1057 if String_Length (Unit_Symbols (Position)) = 0 then
1059 ("empty string not allowed here", Unit_Symbol);
1063 -- Check the third argument for each dimension aggregate is
1064 -- a string or a character.
1069 N_Character_Literal)
1071 Error_Msg_N ("expected dimension symbol (string or " &
1078 if Nkind (Dim_Symbol) = N_String_Literal then
1079 Dim_Symbols (Position) := Strval (Dim_Symbol);
1086 (UI_To_CC (Char_Literal_Value (Dim_Symbol)));
1087 Dim_Symbols (Position) := End_String;
1090 -- Verify that the string is not empty
1092 if String_Length (Dim_Symbols (Position)) = 0 then
1094 ("empty string not allowed here", Dim_Symbol);
1103 -- STEP 4: Storage of extracted values
1105 -- Check that no errors have been detected during the analysis
1107 if Errors_Count = Serious_Errors_Detected then
1108 Dim_System.Type_Decl := N;
1109 Dim_System.Unit_Names := Unit_Names;
1110 Dim_System.Unit_Symbols := Unit_Symbols;
1111 Dim_System.Dim_Symbols := Dim_Symbols;
1112 Dim_System.Count := Position;
1113 System_Table.Append (Dim_System);
1115 end Analyze_Aspect_Dimension_System;
1117 -----------------------
1118 -- Analyze_Dimension --
1119 -----------------------
1121 -- This dispatch routine propagates dimensions for each node
1123 procedure Analyze_Dimension (N : Node_Id) is
1125 -- Aspect is an Ada 2012 feature
1127 if Ada_Version < Ada_2012 then
1133 when N_Assignment_Statement =>
1134 Analyze_Dimension_Assignment_Statement (N);
1137 Analyze_Dimension_Binary_Op (N);
1139 when N_Component_Declaration =>
1140 Analyze_Dimension_Component_Declaration (N);
1142 when N_Extended_Return_Statement =>
1143 Analyze_Dimension_Extended_Return_Statement (N);
1145 when N_Function_Call =>
1146 Analyze_Dimension_Function_Call (N);
1148 when N_Attribute_Reference |
1150 N_Indexed_Component |
1151 N_Qualified_Expression |
1152 N_Selected_Component |
1155 N_Unchecked_Type_Conversion =>
1156 Analyze_Dimension_Has_Etype (N);
1158 when N_Object_Declaration =>
1159 Analyze_Dimension_Object_Declaration (N);
1161 when N_Object_Renaming_Declaration =>
1162 Analyze_Dimension_Object_Renaming_Declaration (N);
1164 when N_Simple_Return_Statement =>
1165 if not Comes_From_Extended_Return_Statement (N) then
1166 Analyze_Dimension_Simple_Return_Statement (N);
1169 when N_Subtype_Declaration =>
1170 Analyze_Dimension_Subtype_Declaration (N);
1173 Analyze_Dimension_Unary_Op (N);
1175 when others => null;
1178 end Analyze_Dimension;
1180 --------------------------------------------
1181 -- Analyze_Dimension_Assignment_Statement --
1182 --------------------------------------------
1184 procedure Analyze_Dimension_Assignment_Statement (N : Node_Id) is
1185 Lhs : constant Node_Id := Name (N);
1186 Dims_Of_Lhs : constant Dimension_Type := Dimensions_Of (Lhs);
1187 Rhs : constant Node_Id := Expression (N);
1188 Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
1190 procedure Error_Dim_Msg_For_Assignment_Statement
1194 -- Error using Error_Msg_N at node N. Output the dimensions of left
1195 -- and right hand sides.
1197 --------------------------------------------
1198 -- Error_Dim_Msg_For_Assignment_Statement --
1199 --------------------------------------------
1201 procedure Error_Dim_Msg_For_Assignment_Statement
1207 Error_Msg_N ("dimensions mismatch in assignment", N);
1208 Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N);
1209 Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N);
1210 end Error_Dim_Msg_For_Assignment_Statement;
1212 -- Start of processing for Analyze_Dimension_Assignment
1215 if Dims_Of_Lhs /= Dims_Of_Rhs then
1216 Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
1218 end Analyze_Dimension_Assignment_Statement;
1220 ---------------------------------
1221 -- Analyze_Dimension_Binary_Op --
1222 ---------------------------------
1224 -- Check and propagate the dimensions for binary operators
1225 -- Note that when the dimensions mismatch, no dimension is propagated to N.
1227 procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
1228 N_Kind : constant Node_Kind := Nkind (N);
1230 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
1231 -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
1232 -- dimensions of both operands.
1234 ---------------------------------
1235 -- Error_Dim_Msg_For_Binary_Op --
1236 ---------------------------------
1238 procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
1240 Error_Msg_NE ("both operands for operation& must have same " &
1244 Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N);
1245 Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N);
1246 end Error_Dim_Msg_For_Binary_Op;
1248 -- Start of processing for Analyze_Dimension_Binary_Op
1251 if Nkind_In (N_Kind, N_Op_Add, N_Op_Expon, N_Op_Subtract)
1252 or else N_Kind in N_Multiplying_Operator
1253 or else N_Kind in N_Op_Compare
1256 L : constant Node_Id := Left_Opnd (N);
1257 Dims_Of_L : constant Dimension_Type := Dimensions_Of (L);
1258 L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
1259 R : constant Node_Id := Right_Opnd (N);
1260 Dims_Of_R : constant Dimension_Type := Dimensions_Of (R);
1261 R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
1262 Dims_Of_N : Dimension_Type := Null_Dimension;
1265 -- N_Op_Add, N_Op_Mod, N_Op_Rem or N_Op_Subtract case
1267 if Nkind_In (N, N_Op_Add, N_Op_Mod, N_Op_Rem, N_Op_Subtract) then
1269 -- Check both operands have same dimension
1271 if Dims_Of_L /= Dims_Of_R then
1272 Error_Dim_Msg_For_Binary_Op (N, L, R);
1274 -- Check both operands are not dimensionless
1276 if Exists (Dims_Of_L) then
1277 Set_Dimensions (N, Dims_Of_L);
1281 -- N_Op_Multiply or N_Op_Divide case
1283 elsif Nkind_In (N_Kind, N_Op_Multiply, N_Op_Divide) then
1285 -- Check at least one operand is not dimensionless
1287 if L_Has_Dimensions or R_Has_Dimensions then
1289 -- Multiplication case
1291 -- Get both operands dimensions and add them
1293 if N_Kind = N_Op_Multiply then
1294 for Position in Dimension_Type'Range loop
1295 Dims_Of_N (Position) :=
1296 Dims_Of_L (Position) + Dims_Of_R (Position);
1301 -- Get both operands dimensions and subtract them
1304 for Position in Dimension_Type'Range loop
1305 Dims_Of_N (Position) :=
1306 Dims_Of_L (Position) - Dims_Of_R (Position);
1310 if Exists (Dims_Of_N) then
1311 Set_Dimensions (N, Dims_Of_N);
1315 -- Exponentiation case
1317 -- Note: a rational exponent is allowed for dimensioned operand
1319 elsif N_Kind = N_Op_Expon then
1321 -- Check the left operand is not dimensionless. Note that the
1322 -- value of the exponent must be known compile time. Otherwise,
1323 -- the exponentiation evaluation will return an error message.
1325 if L_Has_Dimensions then
1326 if not Compile_Time_Known_Value (R) then
1327 Error_Msg_N ("exponent of dimensioned operand must be " &
1328 "known at compile-time", N);
1332 Exponent_Value : Rational := Zero;
1335 -- Real operand case
1337 if Is_Real_Type (Etype (L)) then
1339 -- Define the exponent as a Rational number
1341 Exponent_Value := Create_Rational_From (R, False);
1343 -- Verify that the exponent cannot be interpreted
1344 -- as a rational, otherwise interpret the exponent
1347 if Exponent_Value = No_Rational then
1349 +Whole (UI_To_Int (Expr_Value (R)));
1352 -- Integer operand case.
1354 -- For integer operand, the exponent cannot be
1355 -- interpreted as a rational.
1358 Exponent_Value := +Whole (UI_To_Int (Expr_Value (R)));
1361 for Position in Dimension_Type'Range loop
1362 Dims_Of_N (Position) :=
1363 Dims_Of_L (Position) * Exponent_Value;
1366 if Exists (Dims_Of_N) then
1367 Set_Dimensions (N, Dims_Of_N);
1374 -- For relational operations, only dimension checking is
1375 -- performed (no propagation).
1377 elsif N_Kind in N_Op_Compare then
1378 if (L_Has_Dimensions or R_Has_Dimensions)
1379 and then Dims_Of_L /= Dims_Of_R
1381 Error_Dim_Msg_For_Binary_Op (N, L, R);
1385 -- Removal of dimensions for each operands
1387 Remove_Dimensions (L);
1388 Remove_Dimensions (R);
1391 end Analyze_Dimension_Binary_Op;
1393 ---------------------------------------------
1394 -- Analyze_Dimension_Component_Declaration --
1395 ---------------------------------------------
1397 procedure Analyze_Dimension_Component_Declaration (N : Node_Id) is
1398 Expr : constant Node_Id := Expression (N);
1399 Id : constant Entity_Id := Defining_Identifier (N);
1400 Etyp : constant Entity_Id := Etype (Id);
1401 Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
1402 Dims_Of_Expr : Dimension_Type;
1404 procedure Error_Dim_Msg_For_Component_Declaration
1408 -- Error using Error_Msg_N at node N. Output the dimensions of the
1409 -- type Etyp and the expression Expr of N.
1411 ---------------------------------------------
1412 -- Error_Dim_Msg_For_Component_Declaration --
1413 ---------------------------------------------
1415 procedure Error_Dim_Msg_For_Component_Declaration
1420 Error_Msg_N ("dimensions mismatch in component declaration", N);
1421 Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N);
1422 Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N);
1423 end Error_Dim_Msg_For_Component_Declaration;
1425 -- Start of processing for Analyze_Dimension_Component_Declaration
1428 if Present (Expr) then
1429 Dims_Of_Expr := Dimensions_Of (Expr);
1431 -- Return an error if the dimension of the expression and the
1432 -- dimension of the type mismatch.
1434 if Dims_Of_Etyp /= Dims_Of_Expr then
1435 Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
1438 -- Removal of dimensions in expression
1440 Remove_Dimensions (Expr);
1442 end Analyze_Dimension_Component_Declaration;
1444 -------------------------------------------------
1445 -- Analyze_Dimension_Extended_Return_Statement --
1446 -------------------------------------------------
1448 procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is
1449 Return_Ent : constant Entity_Id :=
1450 Return_Statement_Entity (N);
1451 Return_Etyp : constant Entity_Id :=
1452 Etype (Return_Applies_To (Return_Ent));
1453 Dims_Of_Return_Etyp : constant Dimension_Type :=
1454 Dimensions_Of (Return_Etyp);
1455 Return_Obj_Decls : constant List_Id :=
1456 Return_Object_Declarations (N);
1457 Dims_Of_Return_Obj_Id : Dimension_Type;
1458 Return_Obj_Decl : Node_Id;
1459 Return_Obj_Id : Entity_Id;
1461 procedure Error_Dim_Msg_For_Extended_Return_Statement
1463 Return_Etyp : Entity_Id;
1464 Return_Obj_Id : Entity_Id);
1465 -- Error using Error_Msg_N at node N. Output the dimensions of the
1466 -- returned type Return_Etyp and the returned object Return_Obj_Id of N.
1468 -------------------------------------------------
1469 -- Error_Dim_Msg_For_Extended_Return_Statement --
1470 -------------------------------------------------
1472 procedure Error_Dim_Msg_For_Extended_Return_Statement
1474 Return_Etyp : Entity_Id;
1475 Return_Obj_Id : Entity_Id)
1478 Error_Msg_N ("dimensions mismatch in extended return statement", N);
1479 Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
1480 Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id),
1482 end Error_Dim_Msg_For_Extended_Return_Statement;
1484 -- Start of processing for Analyze_Dimension_Extended_Return_Statement
1487 if Present (Return_Obj_Decls) then
1488 Return_Obj_Decl := First (Return_Obj_Decls);
1489 while Present (Return_Obj_Decl) loop
1490 if Nkind (Return_Obj_Decl) = N_Object_Declaration then
1491 Return_Obj_Id := Defining_Identifier (Return_Obj_Decl);
1493 if Is_Return_Object (Return_Obj_Id) then
1494 Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
1496 if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
1497 Error_Dim_Msg_For_Extended_Return_Statement
1498 (N, Return_Etyp, Return_Obj_Id);
1504 Next (Return_Obj_Decl);
1507 end Analyze_Dimension_Extended_Return_Statement;
1509 -------------------------------------
1510 -- Analyze_Dimension_Function_Call --
1511 -------------------------------------
1513 -- Propagate the dimensions from the returned type to the call node. Note
1514 -- that there is a special treatment for elementary function calls. Indeed
1515 -- for Sqrt call, the resulting dimensions equal to half the dimensions of
1516 -- the actual, and for other elementary calls, this routine check that
1517 -- every actuals are dimensionless.
1519 procedure Analyze_Dimension_Function_Call (N : Node_Id) is
1520 Actuals : constant List_Id := Parameter_Associations (N);
1521 Name_Call : constant Node_Id := Name (N);
1523 Dims_Of_Actual : Dimension_Type;
1524 Dims_Of_Call : Dimension_Type;
1527 function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
1528 -- Given E, the original subprogram entity, return True if call is to an
1529 -- elementary function (see Ada.Numerics.Generic_Elementary_Functions).
1531 -----------------------------------
1532 -- Is_Elementary_Function_Entity --
1533 -----------------------------------
1535 function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
1536 Loc : constant Source_Ptr := Sloc (E);
1539 -- Is function entity in Ada.Numerics.Generic_Elementary_Functions?
1545 (Cunit_Entity (Get_Source_Unit (Loc)),
1546 Ada_Numerics_Generic_Elementary_Functions);
1547 end Is_Elementary_Function_Entity;
1549 -- Start of processing for Analyze_Dimension_Function_Call
1552 -- Look for elementary function call
1554 if Is_Entity_Name (Name_Call) then
1555 Ent := Entity (Name_Call);
1557 -- Get the original subprogram entity following the renaming chain
1559 if Present (Alias (Ent)) then
1563 -- Elementary function case
1565 if Is_Elementary_Function_Entity (Ent) then
1567 -- Sqrt function call case
1569 if Chars (Ent) = Name_Sqrt then
1570 Dims_Of_Call := Dimensions_Of (First (Actuals));
1572 if Exists (Dims_Of_Call) then
1573 for Position in Dims_Of_Call'Range loop
1574 Dims_Of_Call (Position) :=
1575 Dims_Of_Call (Position) * Rational'(Numerator
=> 1,
1579 Set_Dimensions
(N
, Dims_Of_Call
);
1582 -- All other elementary functions case. Note that every actual
1583 -- here should be dimensionless.
1586 Actual
:= First
(Actuals
);
1587 while Present
(Actual
) loop
1588 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
1590 if Exists
(Dims_Of_Actual
) then
1591 Error_Msg_NE
("parameter of& must be dimensionless",
1593 Error_Msg_N
("\parameter " & Dimensions_Msg_Of
(Actual
),
1607 Analyze_Dimension_Has_Etype
(N
);
1608 end Analyze_Dimension_Function_Call
;
1610 ---------------------------------
1611 -- Analyze_Dimension_Has_Etype --
1612 ---------------------------------
1614 procedure Analyze_Dimension_Has_Etype
(N
: Node_Id
) is
1615 Etyp
: constant Entity_Id
:= Etype
(N
);
1616 Dims_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1619 -- Propagation of the dimensions from the type
1621 if Exists
(Dims_Of_Etyp
) then
1622 Set_Dimensions
(N
, Dims_Of_Etyp
);
1624 -- Propagation of the dimensions from the entity for identifier whose
1625 -- entity is a non-dimensionless consant.
1627 elsif Nkind
(N
) = N_Identifier
1628 and then Exists
(Dimensions_Of
(Entity
(N
)))
1630 Set_Dimensions
(N
, Dimensions_Of
(Entity
(N
)));
1633 -- Removal of dimensions in expression
1637 when N_Attribute_Reference |
1638 N_Indexed_Component
=>
1641 Exprs
: constant List_Id
:= Expressions
(N
);
1644 if Present
(Exprs
) then
1645 Expr
:= First
(Exprs
);
1646 while Present
(Expr
) loop
1647 Remove_Dimensions
(Expr
);
1653 when N_Qualified_Expression |
1655 N_Unchecked_Type_Conversion
=>
1656 Remove_Dimensions
(Expression
(N
));
1658 when N_Selected_Component
=>
1659 Remove_Dimensions
(Selector_Name
(N
));
1661 when others => null;
1664 end Analyze_Dimension_Has_Etype
;
1666 ------------------------------------------
1667 -- Analyze_Dimension_Object_Declaration --
1668 ------------------------------------------
1670 procedure Analyze_Dimension_Object_Declaration
(N
: Node_Id
) is
1671 Expr
: constant Node_Id
:= Expression
(N
);
1672 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1673 Etyp
: constant Entity_Id
:= Etype
(Id
);
1674 Dim_Of_Etyp
: constant Dimension_Type
:= Dimensions_Of
(Etyp
);
1675 Dim_Of_Expr
: Dimension_Type
;
1677 procedure Error_Dim_Msg_For_Object_Declaration
1681 -- Error using Error_Msg_N at node N. Output the dimensions of the
1682 -- type Etyp and of the expression Expr.
1684 ------------------------------------------
1685 -- Error_Dim_Msg_For_Object_Declaration --
1686 ------------------------------------------
1688 procedure Error_Dim_Msg_For_Object_Declaration
1693 Error_Msg_N
("dimensions mismatch in object declaration", N
);
1694 Error_Msg_N
("\object type " & Dimensions_Msg_Of
(Etyp
), N
);
1695 Error_Msg_N
("\object expression " & Dimensions_Msg_Of
(Expr
), N
);
1696 end Error_Dim_Msg_For_Object_Declaration
;
1698 -- Start of processing for Analyze_Dimension_Object_Declaration
1701 -- Expression is present
1703 if Present
(Expr
) then
1704 Dim_Of_Expr
:= Dimensions_Of
(Expr
);
1706 -- Case when expression is not a literal and when dimensions of the
1707 -- expression and of the type mismatch
1709 if not Nkind_In
(Original_Node
(Expr
),
1712 and then Dim_Of_Expr
/= Dim_Of_Etyp
1714 -- Propagate the dimension from the expression to the object
1715 -- entity when the object is a constant whose type is a
1716 -- dimensioned type.
1718 if Constant_Present
(N
) and then not Exists
(Dim_Of_Etyp
) then
1719 Set_Dimensions
(Id
, Dim_Of_Expr
);
1721 -- Otherwise, issue an error message
1724 Error_Dim_Msg_For_Object_Declaration
(N
, Etyp
, Expr
);
1728 -- Removal of dimensions in expression
1730 Remove_Dimensions
(Expr
);
1732 end Analyze_Dimension_Object_Declaration
;
1734 ---------------------------------------------------
1735 -- Analyze_Dimension_Object_Renaming_Declaration --
1736 ---------------------------------------------------
1738 procedure Analyze_Dimension_Object_Renaming_Declaration
(N
: Node_Id
) is
1739 Renamed_Name
: constant Node_Id
:= Name
(N
);
1740 Sub_Mark
: constant Node_Id
:= Subtype_Mark
(N
);
1742 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
1745 Renamed_Name
: Node_Id
);
1746 -- Error using Error_Msg_N at node N. Output the dimensions of
1747 -- Sub_Mark and of Renamed_Name.
1749 ---------------------------------------------------
1750 -- Error_Dim_Msg_For_Object_Renaming_Declaration --
1751 ---------------------------------------------------
1753 procedure Error_Dim_Msg_For_Object_Renaming_Declaration
1756 Renamed_Name
: Node_Id
) is
1758 Error_Msg_N
("dimensions mismatch in object renaming declaration",
1760 Error_Msg_N
("\type " & Dimensions_Msg_Of
(Sub_Mark
), N
);
1761 Error_Msg_N
("\renamed object " & Dimensions_Msg_Of
(Renamed_Name
),
1763 end Error_Dim_Msg_For_Object_Renaming_Declaration
;
1765 -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
1768 if Dimensions_Of
(Renamed_Name
) /= Dimensions_Of
(Sub_Mark
) then
1769 Error_Dim_Msg_For_Object_Renaming_Declaration
1770 (N
, Sub_Mark
, Renamed_Name
);
1772 end Analyze_Dimension_Object_Renaming_Declaration
;
1774 -----------------------------------------------
1775 -- Analyze_Dimension_Simple_Return_Statement --
1776 -----------------------------------------------
1778 procedure Analyze_Dimension_Simple_Return_Statement
(N
: Node_Id
) is
1779 Expr
: constant Node_Id
:= Expression
(N
);
1780 Dims_Of_Expr
: constant Dimension_Type
:= Dimensions_Of
(Expr
);
1781 Return_Ent
: constant Entity_Id
:= Return_Statement_Entity
(N
);
1782 Return_Etyp
: constant Entity_Id
:=
1783 Etype
(Return_Applies_To
(Return_Ent
));
1784 Dims_Of_Return_Etyp
: constant Dimension_Type
:=
1785 Dimensions_Of
(Return_Etyp
);
1787 procedure Error_Dim_Msg_For_Simple_Return_Statement
1789 Return_Etyp
: Entity_Id
;
1791 -- Error using Error_Msg_N at node N. Output the dimensions of the
1792 -- returned type Return_Etyp and the returned expression Expr of N.
1794 -----------------------------------------------
1795 -- Error_Dim_Msg_For_Simple_Return_Statement --
1796 -----------------------------------------------
1798 procedure Error_Dim_Msg_For_Simple_Return_Statement
1800 Return_Etyp
: Entity_Id
;
1804 Error_Msg_N
("dimensions mismatch in return statement", N
);
1805 Error_Msg_N
("\returned type " & Dimensions_Msg_Of
(Return_Etyp
), N
);
1806 Error_Msg_N
("\returned expression " & Dimensions_Msg_Of
(Expr
), N
);
1807 end Error_Dim_Msg_For_Simple_Return_Statement
;
1809 -- Start of processing for Analyze_Dimension_Simple_Return_Statement
1812 if Dims_Of_Return_Etyp
/= Dims_Of_Expr
then
1813 Error_Dim_Msg_For_Simple_Return_Statement
(N
, Return_Etyp
, Expr
);
1814 Remove_Dimensions
(Expr
);
1816 end Analyze_Dimension_Simple_Return_Statement
;
1818 -------------------------------------------
1819 -- Analyze_Dimension_Subtype_Declaration --
1820 -------------------------------------------
1822 procedure Analyze_Dimension_Subtype_Declaration
(N
: Node_Id
) is
1823 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1824 Dims_Of_Id
: constant Dimension_Type
:= Dimensions_Of
(Id
);
1825 Dims_Of_Etyp
: Dimension_Type
;
1829 -- No constraint case in subtype declaration
1831 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
1832 Etyp
:= Etype
(Subtype_Indication
(N
));
1833 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
1835 if Exists
(Dims_Of_Etyp
) then
1837 -- If subtype already has a dimension (from Aspect_Dimension),
1838 -- it cannot inherit a dimension from its subtype.
1840 if Exists
(Dims_Of_Id
) then
1841 Error_Msg_N
("subtype& already" & Dimensions_Msg_Of
(Id
), N
);
1843 Set_Dimensions
(Id
, Dims_Of_Etyp
);
1844 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
1848 -- Constraint present in subtype declaration
1851 Etyp
:= Etype
(Subtype_Mark
(Subtype_Indication
(N
)));
1852 Dims_Of_Etyp
:= Dimensions_Of
(Etyp
);
1854 if Exists
(Dims_Of_Etyp
) then
1855 Set_Dimensions
(Id
, Dims_Of_Etyp
);
1856 Set_Symbol
(Id
, Symbol_Of
(Etyp
));
1859 end Analyze_Dimension_Subtype_Declaration
;
1861 --------------------------------
1862 -- Analyze_Dimension_Unary_Op --
1863 --------------------------------
1865 procedure Analyze_Dimension_Unary_Op
(N
: Node_Id
) is
1868 when N_Op_Plus | N_Op_Minus | N_Op_Abs
=>
1870 R
: constant Node_Id
:= Right_Opnd
(N
);
1873 -- Propagate the dimension if the operand is not dimensionless
1875 Move_Dimensions
(R
, N
);
1878 when others => null;
1881 end Analyze_Dimension_Unary_Op
;
1883 --------------------------
1884 -- Create_Rational_From --
1885 --------------------------
1887 -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
1889 -- A rational number is a number that can be expressed as the quotient or
1890 -- fraction a/b of two integers, where b is non-zero positive.
1892 function Create_Rational_From
1894 Complain
: Boolean) return Rational
1896 Or_Node_Of_Expr
: constant Node_Id
:= Original_Node
(Expr
);
1897 Result
: Rational
:= No_Rational
;
1899 function Process_Minus
(N
: Node_Id
) return Rational
;
1900 -- Create a rational from a N_Op_Minus node
1902 function Process_Divide
(N
: Node_Id
) return Rational
;
1903 -- Create a rational from a N_Op_Divide node
1905 function Process_Literal
(N
: Node_Id
) return Rational
;
1906 -- Create a rational from a N_Integer_Literal node
1912 function Process_Minus
(N
: Node_Id
) return Rational
is
1913 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
1917 -- Operand is an integer literal
1919 if Nkind
(Right
) = N_Integer_Literal
then
1920 Result
:= -Process_Literal
(Right
);
1922 -- Operand is a divide operator
1924 elsif Nkind
(Right
) = N_Op_Divide
then
1925 Result
:= -Process_Divide
(Right
);
1928 Result
:= No_Rational
;
1934 --------------------
1935 -- Process_Divide --
1936 --------------------
1938 function Process_Divide
(N
: Node_Id
) return Rational
is
1939 Left
: constant Node_Id
:= Original_Node
(Left_Opnd
(N
));
1940 Right
: constant Node_Id
:= Original_Node
(Right_Opnd
(N
));
1941 Left_Rat
: Rational
;
1942 Result
: Rational
:= No_Rational
;
1943 Right_Rat
: Rational
;
1946 -- Both left and right operands are an integer literal
1948 if Nkind
(Left
) = N_Integer_Literal
1949 and then Nkind
(Right
) = N_Integer_Literal
1951 Left_Rat
:= Process_Literal
(Left
);
1952 Right_Rat
:= Process_Literal
(Right
);
1953 Result
:= Left_Rat
/ Right_Rat
;
1959 ---------------------
1960 -- Process_Literal --
1961 ---------------------
1963 function Process_Literal
(N
: Node_Id
) return Rational
is
1965 return +Whole
(UI_To_Int
(Intval
(N
)));
1966 end Process_Literal
;
1968 -- Start of processing for Create_Rational_From
1971 -- Check the expression is either a division of two integers or an
1972 -- integer itself. Note that the check applies to the original node
1973 -- since the node could have already been rewritten.
1975 -- Integer literal case
1977 if Nkind
(Or_Node_Of_Expr
) = N_Integer_Literal
then
1978 Result
:= Process_Literal
(Or_Node_Of_Expr
);
1980 -- Divide operator case
1982 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Divide
then
1983 Result
:= Process_Divide
(Or_Node_Of_Expr
);
1985 -- Minus operator case
1987 elsif Nkind
(Or_Node_Of_Expr
) = N_Op_Minus
then
1988 Result
:= Process_Minus
(Or_Node_Of_Expr
);
1991 -- When Expr cannot be interpreted as a rational and Complain is true,
1992 -- generate an error message.
1994 if Complain
and then Result
= No_Rational
then
1995 Error_Msg_N
("rational expected", Expr
);
1999 end Create_Rational_From
;
2005 function Dimensions_Of
(N
: Node_Id
) return Dimension_Type
is
2007 return Dimension_Table
.Get
(N
);
2010 -----------------------
2011 -- Dimensions_Msg_Of --
2012 -----------------------
2014 function Dimensions_Msg_Of
(N
: Node_Id
) return String is
2015 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2016 Dimensions_Msg
: Name_Id
;
2017 System
: System_Type
;
2020 -- Initialization of Name_Buffer
2024 if Exists
(Dims_Of_N
) then
2025 System
:= System_Of
(Base_Type
(Etype
(N
)));
2026 Add_Str_To_Name_Buffer
("has dimension ");
2027 Add_String_To_Name_Buffer
2028 (From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_N
, System
, True));
2030 Add_Str_To_Name_Buffer
("is dimensionless");
2033 Dimensions_Msg
:= Name_Find
;
2034 return Get_Name_String
(Dimensions_Msg
);
2035 end Dimensions_Msg_Of
;
2037 --------------------------
2038 -- Dimension_Table_Hash --
2039 --------------------------
2041 function Dimension_Table_Hash
2042 (Key
: Node_Id
) return Dimension_Table_Range
2045 return Dimension_Table_Range
(Key
mod 511);
2046 end Dimension_Table_Hash
;
2048 ----------------------------------------
2049 -- Eval_Op_Expon_For_Dimensioned_Type --
2050 ----------------------------------------
2052 -- Evaluate the expon operator for real dimensioned type.
2054 -- Note that if the exponent is an integer (denominator = 1) the node is
2055 -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
2057 procedure Eval_Op_Expon_For_Dimensioned_Type
2061 R
: constant Node_Id
:= Right_Opnd
(N
);
2062 R_Value
: Rational
:= No_Rational
;
2065 if Is_Real_Type
(Btyp
) then
2066 R_Value
:= Create_Rational_From
(R
, False);
2069 -- Check that the exponent is not an integer
2071 if R_Value
/= No_Rational
and then R_Value
.Denominator
/= 1 then
2072 Eval_Op_Expon_With_Rational_Exponent
(N
, R_Value
);
2076 end Eval_Op_Expon_For_Dimensioned_Type
;
2078 ------------------------------------------
2079 -- Eval_Op_Expon_With_Rational_Exponent --
2080 ------------------------------------------
2082 -- For dimensioned operand in exponentiation, exponent is allowed to be a
2083 -- Rational and not only an Integer like for dimensionless operands. For
2084 -- that particular case, the left operand is rewritten as a function call
2085 -- using the function Expon_LLF from s-llflex.ads.
2087 procedure Eval_Op_Expon_With_Rational_Exponent
2089 Exponent_Value
: Rational
)
2091 Dims_Of_N
: constant Dimension_Type
:= Dimensions_Of
(N
);
2092 L
: constant Node_Id
:= Left_Opnd
(N
);
2093 Etyp_Of_L
: constant Entity_Id
:= Etype
(L
);
2094 Btyp_Of_L
: constant Entity_Id
:= Base_Type
(Etyp_Of_L
);
2095 Loc
: constant Source_Ptr
:= Sloc
(N
);
2098 Dim_Power
: Rational
;
2099 List_Of_Dims
: List_Id
;
2100 New_Aspect
: Node_Id
;
2101 New_Aspects
: List_Id
;
2104 New_Subtyp_Decl_For_L
: Node_Id
;
2105 System
: System_Type
;
2108 -- Case when the operand is not dimensionless
2110 if Exists
(Dims_Of_N
) then
2112 -- Get the corresponding System_Type to know the exact number of
2113 -- dimensions in the system.
2115 System
:= System_Of
(Btyp_Of_L
);
2117 -- Generation of a new subtype with the proper dimensions
2119 -- In order to rewrite the operator as a type conversion, a new
2120 -- dimensioned subtype with the resulting dimensions of the
2121 -- exponentiation must be created.
2125 -- Btyp_Of_L : constant Entity_Id := Base_Type (Etyp_Of_L);
2126 -- System : constant System_Id :=
2127 -- Get_Dimension_System_Id (Btyp_Of_L);
2128 -- Num_Of_Dims : constant Number_Of_Dimensions :=
2129 -- Dimension_Systems.Table (System).Dimension_Count;
2131 -- subtype T is Btyp_Of_L
2134 -- Dims_Of_N (1).Numerator / Dims_Of_N (1).Denominator,
2135 -- Dims_Of_N (2).Numerator / Dims_Of_N (2).Denominator,
2137 -- Dims_Of_N (Num_Of_Dims).Numerator /
2138 -- Dims_Of_N (Num_Of_Dims).Denominator);
2140 -- Step 1: Generate the new aggregate for the aspect Dimension
2142 New_Aspects
:= Empty_List
;
2143 List_Of_Dims
:= New_List
;
2145 for Position
in Dims_Of_N
'First .. System
.Count
loop
2146 Dim_Power
:= Dims_Of_N
(Position
);
2147 Append_To
(List_Of_Dims
,
2148 Make_Op_Divide
(Loc
,
2150 Make_Integer_Literal
(Loc
,
2151 Int
(Dim_Power
.Numerator
)),
2153 Make_Integer_Literal
(Loc
,
2154 Int
(Dim_Power
.Denominator
))));
2157 -- Step 2: Create the new Aspect Specification for Aspect Dimension
2160 Make_Aspect_Specification
(Loc
,
2161 Identifier
=> Make_Identifier
(Loc
, Name_Dimension
),
2162 Expression
=> Make_Aggregate
(Loc
, Expressions
=> List_Of_Dims
));
2164 -- Step 3: Make a temporary identifier for the new subtype
2166 New_Id
:= Make_Temporary
(Loc
, 'T');
2167 Set_Is_Internal
(New_Id
);
2169 -- Step 4: Declaration of the new subtype
2171 New_Subtyp_Decl_For_L
:=
2172 Make_Subtype_Declaration
(Loc
,
2173 Defining_Identifier
=> New_Id
,
2174 Subtype_Indication
=> New_Occurrence_Of
(Btyp_Of_L
, Loc
));
2176 Append
(New_Aspect
, New_Aspects
);
2177 Set_Parent
(New_Aspects
, New_Subtyp_Decl_For_L
);
2178 Set_Aspect_Specifications
(New_Subtyp_Decl_For_L
, New_Aspects
);
2180 Analyze
(New_Subtyp_Decl_For_L
);
2182 -- Case where the operand is dimensionless
2185 New_Id
:= Btyp_Of_L
;
2188 -- Replacement of N by New_N
2192 -- Actual_1 := Long_Long_Float (L),
2194 -- Actual_2 := Long_Long_Float (Exponent_Value.Numerator) /
2195 -- Long_Long_Float (Exponent_Value.Denominator);
2197 -- (T (Expon_LLF (Actual_1, Actual_2)));
2199 -- where T is the subtype declared in step 1
2201 -- The node is rewritten as a type conversion
2203 -- Step 1: Creation of the two parameters of Expon_LLF function call
2206 Make_Type_Conversion
(Loc
,
2207 Subtype_Mark
=> New_Reference_To
(Standard_Long_Long_Float
, Loc
),
2208 Expression
=> Relocate_Node
(L
));
2211 Make_Op_Divide
(Loc
,
2213 Make_Real_Literal
(Loc
,
2214 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Numerator
)))),
2216 Make_Real_Literal
(Loc
,
2217 UR_From_Uint
(UI_From_Int
(Int
(Exponent_Value
.Denominator
)))));
2219 -- Step 2: Creation of New_N
2222 Make_Type_Conversion
(Loc
,
2223 Subtype_Mark
=> New_Reference_To
(New_Id
, Loc
),
2225 Make_Function_Call
(Loc
,
2226 Name
=> New_Reference_To
(RTE
(RE_Expon_LLF
), Loc
),
2227 Parameter_Associations
=> New_List
(
2228 Actual_1
, Actual_2
)));
2230 -- Step 3: Rewrite N with the result
2233 Set_Etype
(N
, New_Id
);
2234 Analyze_And_Resolve
(N
, New_Id
);
2235 end Eval_Op_Expon_With_Rational_Exponent
;
2241 function Exists
(Dim
: Dimension_Type
) return Boolean is
2243 return Dim
/= Null_Dimension
;
2246 function Exists
(Sys
: System_Type
) return Boolean is
2248 return Sys
/= Null_System
;
2251 ---------------------------------
2252 -- Expand_Put_Call_With_Symbol --
2253 ---------------------------------
2255 -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
2256 -- (System.Dim.Integer_IO), the default string parameter must be rewritten
2257 -- to include the unit symbols (resp. dimension symbols) in the output
2258 -- of a dimensioned object. Note that if a value is already supplied for
2259 -- parameter Symbol, this routine doesn't do anything.
2261 -- Case 1. Item is dimensionless
2263 -- * Put : Item appears without a suffix
2265 -- * Put_Dim_Of : the output is []
2267 -- Obj : Mks_Type := 2.6;
2268 -- Put (Obj, 1, 1, 0);
2269 -- Put_Dim_Of (Obj);
2271 -- The corresponding outputs are:
2275 -- Case 2. Item has a dimension
2277 -- * Put : If the type of Item is a dimensioned subtype whose
2278 -- symbol is not empty, then the symbol appears as a
2279 -- suffix. Otherwise, a new string is created and appears
2280 -- as a suffix of Item. This string results in the
2281 -- successive concatanations between each unit symbol
2282 -- raised by its corresponding dimension power from the
2283 -- dimensions of Item.
2285 -- * Put_Dim_Of : The output is a new string resulting in the successive
2286 -- concatanations between each dimension symbol raised by
2287 -- its corresponding dimension power from the dimensions of
2290 -- subtype Random is Mks_Type
2297 -- Obj : Random := 5.0;
2299 -- Put_Dim_Of (Obj);
2301 -- The corresponding outputs are:
2302 -- $5.0 m**3.cd**(-1)
2305 procedure Expand_Put_Call_With_Symbol
(N
: Node_Id
) is
2306 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2307 Loc
: constant Source_Ptr
:= Sloc
(N
);
2308 Name_Call
: constant Node_Id
:= Name
(N
);
2309 New_Actuals
: constant List_Id
:= New_List
;
2311 Dims_Of_Actual
: Dimension_Type
;
2313 New_Str_Lit
: Node_Id
:= Empty
;
2314 System
: System_Type
;
2316 Is_Put_Dim_Of
: Boolean := False;
2317 -- This flag is used in order to differentiate routines Put and
2318 -- Put_Dim_Of. Set to True if the procedure is one of the Put_Dim_Of
2319 -- defined in System.Dim.Float_IO or System.Dim.Integer_IO.
2321 function Has_Symbols
return Boolean;
2322 -- Return True if the current Put call already has a parameter
2323 -- association for parameter "Symbols" with the correct string of
2326 function Is_Procedure_Put_Call
return Boolean;
2327 -- Return True if the current call is a call of an instantiation of a
2328 -- procedure Put defined in the package System.Dim.Float_IO and
2329 -- System.Dim.Integer_IO.
2331 function Item_Actual
return Node_Id
;
2332 -- Return the item actual parameter node in the output call
2338 function Has_Symbols
return Boolean is
2342 Actual
:= First
(Actuals
);
2344 -- Look for a symbols parameter association in the list of actuals
2346 while Present
(Actual
) loop
2347 if Nkind
(Actual
) = N_Parameter_Association
2348 and then Chars
(Selector_Name
(Actual
)) = Name_Symbol
2350 -- Return True if the actual comes from source or if the string
2351 -- of symbols doesn't have the default value (i.e. it is "").
2353 return Comes_From_Source
(Actual
)
2356 (Strval
(Explicit_Actual_Parameter
(Actual
))) /= 0;
2362 -- At this point, the call has no parameter association. Look to the
2363 -- last actual since the symbols parameter is the last one.
2365 return Nkind
(Last
(Actuals
)) = N_String_Literal
;
2368 ---------------------------
2369 -- Is_Procedure_Put_Call --
2370 ---------------------------
2372 function Is_Procedure_Put_Call
return Boolean is
2377 -- There are three different Put (resp. Put_Dim_Of) routines in each
2378 -- generic dim IO package. Verify the current procedure call is one
2381 if Is_Entity_Name
(Name_Call
) then
2382 Ent
:= Entity
(Name_Call
);
2384 -- Get the original subprogram entity following the renaming chain
2386 if Present
(Alias
(Ent
)) then
2392 -- Check the name of the entity subprogram is Put (resp.
2393 -- Put_Dim_Of) and verify this entity is located in either
2394 -- System.Dim.Float_IO or System.Dim.Integer_IO.
2396 if Loc
> No_Location
2397 and then Is_Dim_IO_Package_Entity
2398 (Cunit_Entity
(Get_Source_Unit
(Loc
)))
2400 if Chars
(Ent
) = Name_Put_Dim_Of
then
2401 Is_Put_Dim_Of
:= True;
2404 elsif Chars
(Ent
) = Name_Put
then
2411 end Is_Procedure_Put_Call
;
2417 function Item_Actual
return Node_Id
is
2421 -- Look for the item actual as a parameter association
2423 Actual
:= First
(Actuals
);
2424 while Present
(Actual
) loop
2425 if Nkind
(Actual
) = N_Parameter_Association
2426 and then Chars
(Selector_Name
(Actual
)) = Name_Item
2428 return Explicit_Actual_Parameter
(Actual
);
2434 -- Case where the item has been defined without an association
2436 Actual
:= First
(Actuals
);
2438 -- Depending on the procedure Put, Item actual could be first or
2439 -- second in the list of actuals.
2441 if Has_Dimension_System
(Base_Type
(Etype
(Actual
))) then
2444 return Next
(Actual
);
2448 -- Start of processing for Expand_Put_Call_With_Symbol
2451 if Is_Procedure_Put_Call
and then not Has_Symbols
then
2452 Actual
:= Item_Actual
;
2453 Dims_Of_Actual
:= Dimensions_Of
(Actual
);
2454 Etyp
:= Etype
(Actual
);
2458 if Is_Put_Dim_Of
then
2460 -- Check that the item is not dimensionless
2462 -- Create the new String_Literal with the new String_Id generated
2463 -- by the routine From_Dim_To_Str_Of_Dim_Symbols.
2465 if Exists
(Dims_Of_Actual
) then
2466 System
:= System_Of
(Base_Type
(Etyp
));
2468 Make_String_Literal
(Loc
,
2469 From_Dim_To_Str_Of_Dim_Symbols
(Dims_Of_Actual
, System
));
2471 -- If dimensionless, the output is []
2475 Make_String_Literal
(Loc
, "[]");
2481 -- Add the symbol as a suffix of the value if the subtype has a
2482 -- unit symbol or if the parameter is not dimensionless.
2484 if Symbol_Of
(Etyp
) /= No_String
then
2487 -- Put a space between the value and the dimension
2489 Store_String_Char
(' ');
2490 Store_String_Chars
(Symbol_Of
(Etyp
));
2491 New_Str_Lit
:= Make_String_Literal
(Loc
, End_String
);
2493 -- Check that the item is not dimensionless
2495 -- Create the new String_Literal with the new String_Id generated
2496 -- by the routine From_Dim_To_Str_Of_Unit_Symbols.
2498 elsif Exists
(Dims_Of_Actual
) then
2499 System
:= System_Of
(Base_Type
(Etyp
));
2501 Make_String_Literal
(Loc
,
2502 From_Dim_To_Str_Of_Unit_Symbols
(Dims_Of_Actual
, System
));
2506 if Present
(New_Str_Lit
) then
2508 -- Insert all actuals in New_Actuals
2510 Actual
:= First
(Actuals
);
2511 while Present
(Actual
) loop
2513 -- Copy every actuals in New_Actuals except the Symbols
2514 -- parameter association.
2516 if Nkind
(Actual
) = N_Parameter_Association
2517 and then Chars
(Selector_Name
(Actual
)) /= Name_Symbol
2519 Append_To
(New_Actuals
,
2520 Make_Parameter_Association
(Loc
,
2521 Selector_Name
=> New_Copy
(Selector_Name
(Actual
)),
2522 Explicit_Actual_Parameter
=>
2523 New_Copy
(Explicit_Actual_Parameter
(Actual
))));
2525 elsif Nkind
(Actual
) /= N_Parameter_Association
then
2526 Append_To
(New_Actuals
, New_Copy
(Actual
));
2532 -- Create new Symbols param association and append to New_Actuals
2534 Append_To
(New_Actuals
,
2535 Make_Parameter_Association
(Loc
,
2536 Selector_Name
=> Make_Identifier
(Loc
, Name_Symbol
),
2537 Explicit_Actual_Parameter
=> New_Str_Lit
));
2539 -- Rewrite and analyze the procedure call
2542 Make_Procedure_Call_Statement
(Loc
,
2543 Name
=> New_Copy
(Name_Call
),
2544 Parameter_Associations
=> New_Actuals
));
2549 end Expand_Put_Call_With_Symbol
;
2551 ------------------------------------
2552 -- From_Dim_To_Str_Of_Dim_Symbols --
2553 ------------------------------------
2555 -- Given a dimension vector and the corresponding dimension system, create
2556 -- a String_Id to output dimension symbols corresponding to the dimensions
2557 -- Dims. If In_Error_Msg is True, there is a special handling for character
2558 -- asterisk * which is an insertion character in error messages.
2560 function From_Dim_To_Str_Of_Dim_Symbols
2561 (Dims
: Dimension_Type
;
2562 System
: System_Type
;
2563 In_Error_Msg
: Boolean := False) return String_Id
2565 Dim_Power
: Rational
;
2566 First_Dim
: Boolean := True;
2568 procedure Store_String_Oexpon
;
2569 -- Store the expon operator symbol "**" in the string. In error
2570 -- messages, asterisk * is a special character and must be quoted
2571 -- to be placed literally into the message.
2573 -------------------------
2574 -- Store_String_Oexpon --
2575 -------------------------
2577 procedure Store_String_Oexpon
is
2579 if In_Error_Msg
then
2580 Store_String_Chars
("'*'*");
2582 Store_String_Chars
("**");
2584 end Store_String_Oexpon
;
2586 -- Start of processing for From_Dim_To_Str_Of_Dim_Symbols
2589 -- Initialization of the new String_Id
2593 -- Store the dimension symbols inside boxes
2595 Store_String_Char
('[');
2597 for Position
in Dimension_Type
'Range loop
2598 Dim_Power
:= Dims
(Position
);
2599 if Dim_Power
/= Zero
then
2604 Store_String_Char
('.');
2607 Store_String_Chars
(System
.Dim_Symbols
(Position
));
2609 -- Positive dimension case
2611 if Dim_Power
.Numerator
> 0 then
2614 if Dim_Power
.Denominator
= 1 then
2615 if Dim_Power
.Numerator
/= 1 then
2616 Store_String_Oexpon
;
2617 Store_String_Int
(Int
(Dim_Power
.Numerator
));
2620 -- Rational case when denominator /= 1
2623 Store_String_Oexpon
;
2624 Store_String_Char
('(');
2625 Store_String_Int
(Int
(Dim_Power
.Numerator
));
2626 Store_String_Char
('/');
2627 Store_String_Int
(Int
(Dim_Power
.Denominator
));
2628 Store_String_Char
(')');
2631 -- Negative dimension case
2634 Store_String_Oexpon
;
2635 Store_String_Char
('(');
2636 Store_String_Char
('-');
2637 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
2641 if Dim_Power
.Denominator
= 1 then
2642 Store_String_Char
(')');
2644 -- Rational case when denominator /= 1
2647 Store_String_Char
('/');
2648 Store_String_Int
(Int
(Dim_Power
.Denominator
));
2649 Store_String_Char
(')');
2655 Store_String_Char
(']');
2657 end From_Dim_To_Str_Of_Dim_Symbols
;
2659 -------------------------------------
2660 -- From_Dim_To_Str_Of_Unit_Symbols --
2661 -------------------------------------
2663 -- Given a dimension vector and the corresponding dimension system,
2664 -- create a String_Id to output the unit symbols corresponding to the
2667 function From_Dim_To_Str_Of_Unit_Symbols
2668 (Dims
: Dimension_Type
;
2669 System
: System_Type
) return String_Id
2671 Dim_Power
: Rational
;
2672 First_Dim
: Boolean := True;
2675 -- Initialization of the new String_Id
2679 -- Put a space between the value and the symbols
2681 Store_String_Char
(' ');
2683 for Position
in Dimension_Type
'Range loop
2684 Dim_Power
:= Dims
(Position
);
2686 if Dim_Power
/= Zero
then
2691 Store_String_Char
('.');
2694 Store_String_Chars
(System
.Unit_Symbols
(Position
));
2696 -- Positive dimension case
2698 if Dim_Power
.Numerator
> 0 then
2702 if Dim_Power
.Denominator
= 1 then
2703 if Dim_Power
.Numerator
/= 1 then
2704 Store_String_Chars
("**");
2705 Store_String_Int
(Int
(Dim_Power
.Numerator
));
2708 -- Rational case when denominator /= 1
2711 Store_String_Chars
("**");
2712 Store_String_Char
('(');
2713 Store_String_Int
(Int
(Dim_Power
.Numerator
));
2714 Store_String_Char
('/');
2715 Store_String_Int
(Int
(Dim_Power
.Denominator
));
2716 Store_String_Char
(')');
2719 -- Negative dimension case
2722 Store_String_Chars
("**");
2723 Store_String_Char
('(');
2724 Store_String_Char
('-');
2725 Store_String_Int
(Int
(-Dim_Power
.Numerator
));
2729 if Dim_Power
.Denominator
= 1 then
2730 Store_String_Char
(')');
2732 -- Rational case when denominator /= 1
2735 Store_String_Char
('/');
2736 Store_String_Int
(Int
(Dim_Power
.Denominator
));
2737 Store_String_Char
(')');
2744 end From_Dim_To_Str_Of_Unit_Symbols
;
2750 function GCD
(Left
, Right
: Whole
) return Int
is
2770 --------------------------
2771 -- Has_Dimension_System --
2772 --------------------------
2774 function Has_Dimension_System
(Typ
: Entity_Id
) return Boolean is
2776 return Exists
(System_Of
(Typ
));
2777 end Has_Dimension_System
;
2779 ------------------------------
2780 -- Is_Dim_IO_Package_Entity --
2781 ------------------------------
2783 function Is_Dim_IO_Package_Entity
(E
: Entity_Id
) return Boolean is
2785 -- Check the package entity corresponds to System.Dim.Float_IO or
2786 -- System.Dim.Integer_IO.
2789 Is_RTU
(E
, System_Dim_Float_IO
)
2790 or Is_RTU
(E
, System_Dim_Integer_IO
);
2791 end Is_Dim_IO_Package_Entity
;
2793 -------------------------------------
2794 -- Is_Dim_IO_Package_Instantiation --
2795 -------------------------------------
2797 function Is_Dim_IO_Package_Instantiation
(N
: Node_Id
) return Boolean is
2798 Gen_Id
: constant Node_Id
:= Name
(N
);
2801 -- Check that the instantiated package is either System.Dim.Float_IO
2802 -- or System.Dim.Integer_IO.
2805 Is_Entity_Name
(Gen_Id
)
2806 and then Is_Dim_IO_Package_Entity
(Entity
(Gen_Id
));
2807 end Is_Dim_IO_Package_Instantiation
;
2813 function Is_Invalid
(Position
: Dimension_Position
) return Boolean is
2815 return Position
= Invalid_Position
;
2818 ---------------------
2819 -- Move_Dimensions --
2820 ---------------------
2822 procedure Move_Dimensions
(From
, To
: Node_Id
) is
2823 Dims_Of_From
: constant Dimension_Type
:= Dimensions_Of
(From
);
2826 -- Copy the dimension of 'From to 'To' and remove dimension of 'From'
2828 if Exists
(Dims_Of_From
) then
2829 Set_Dimensions
(To
, Dims_Of_From
);
2830 Remove_Dimensions
(From
);
2832 end Move_Dimensions
;
2838 function Reduce
(X
: Rational
) return Rational
is
2840 if X
.Numerator
= 0 then
2845 G
: constant Int
:= GCD
(X
.Numerator
, X
.Denominator
);
2847 return Rational
'(Numerator => Whole (Int (X.Numerator) / G),
2848 Denominator => Whole (Int (X.Denominator) / G));
2852 -----------------------
2853 -- Remove_Dimensions --
2854 -----------------------
2856 procedure Remove_Dimensions (N : Node_Id) is
2857 Dims_Of_N : constant Dimension_Type := Dimensions_Of (N);
2859 if Exists (Dims_Of_N) then
2860 Dimension_Table.Remove (N);
2862 end Remove_Dimensions;
2864 ------------------------------
2865 -- Remove_Dimension_In_Call --
2866 ------------------------------
2868 procedure Remove_Dimension_In_Call (Call : Node_Id) is
2872 if Ada_Version < Ada_2012 then
2876 Actual := First (Parameter_Associations (Call));
2878 while Present (Actual) loop
2879 Remove_Dimensions (Actual);
2882 end Remove_Dimension_In_Call;
2884 -----------------------------------
2885 -- Remove_Dimension_In_Statement --
2886 -----------------------------------
2888 -- Removal of dimension in statement as part of the Analyze_Statements
2889 -- routine (see package Sem_Ch5).
2891 procedure Remove_Dimension_In_Statement (Stmt : Node_Id) is
2893 if Ada_Version < Ada_2012 then
2897 -- Remove dimension in parameter specifications for accept statement
2899 if Nkind (Stmt) = N_Accept_Statement then
2901 Param : Node_Id := First (Parameter_Specifications (Stmt));
2903 while Present (Param) loop
2904 Remove_Dimensions (Param);
2909 -- Remove dimension of name and expression in assignments
2911 elsif Nkind (Stmt) = N_Assignment_Statement then
2912 Remove_Dimensions (Expression (Stmt));
2913 Remove_Dimensions (Name (Stmt));
2915 end Remove_Dimension_In_Statement;
2917 --------------------
2918 -- Set_Dimensions --
2919 --------------------
2921 procedure Set_Dimensions (N : Node_Id; Val : Dimension_Type) is
2923 pragma Assert (OK_For_Dimension (Nkind (N)));
2924 pragma Assert (Exists (Val));
2926 Dimension_Table.Set (N, Val);
2933 procedure Set_Symbol (E : Entity_Id; Val : String_Id) is
2935 Symbol_Table.Set (E, Val);
2942 function Symbol_Of (E : Entity_Id) return String_Id is
2944 return Symbol_Table.Get (E);
2947 -----------------------
2948 -- Symbol_Table_Hash --
2949 -----------------------
2951 function Symbol_Table_Hash (Key : Entity_Id) return Symbol_Table_Range is
2953 return Symbol_Table_Range (Key mod 511);
2954 end Symbol_Table_Hash;
2960 function System_Of (E : Entity_Id) return System_Type is
2961 Type_Decl : constant Node_Id := Parent (E);
2964 -- Look for Type_Decl in System_Table
2966 for Dim_Sys in 1 .. System_Table.Last loop
2967 if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
2968 return System_Table.Table (Dim_Sys);