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