]>
Commit | Line | Data |
---|---|---|
d6f39728 | 1 | ------------------------------------------------------------------------------ |
7189d17f | 2 | -- -- |
d6f39728 | 3 | -- GNAT COMPILER COMPONENTS -- |
4 | -- -- | |
5 | -- S E M _ C H 1 3 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fdd294d1 | 9 | -- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- |
d6f39728 | 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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d6f39728 | 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 -- | |
80df182a | 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. -- | |
d6f39728 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d6f39728 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
713c00d6 | 27 | with Checks; use Checks; |
d6f39728 | 28 | with Einfo; use Einfo; |
29 | with Errout; use Errout; | |
30 | with Exp_Tss; use Exp_Tss; | |
31 | with Exp_Util; use Exp_Util; | |
d6f39728 | 32 | with Lib; use Lib; |
83f8f0a6 | 33 | with Lib.Xref; use Lib.Xref; |
15ebb600 | 34 | with Namet; use Namet; |
d6f39728 | 35 | with Nlists; use Nlists; |
36 | with Nmake; use Nmake; | |
37 | with Opt; use Opt; | |
e0521a36 | 38 | with Restrict; use Restrict; |
39 | with Rident; use Rident; | |
d6f39728 | 40 | with Rtsfind; use Rtsfind; |
41 | with Sem; use Sem; | |
42 | with Sem_Ch8; use Sem_Ch8; | |
43 | with Sem_Eval; use Sem_Eval; | |
44 | with Sem_Res; use Sem_Res; | |
45 | with Sem_Type; use Sem_Type; | |
46 | with Sem_Util; use Sem_Util; | |
44e4341e | 47 | with Sem_Warn; use Sem_Warn; |
9dfe12ae | 48 | with Snames; use Snames; |
d6f39728 | 49 | with Stand; use Stand; |
50 | with Sinfo; use Sinfo; | |
d6f39728 | 51 | with Table; |
93735cb8 | 52 | with Targparm; use Targparm; |
d6f39728 | 53 | with Ttypes; use Ttypes; |
54 | with Tbuild; use Tbuild; | |
55 | with Urealp; use Urealp; | |
56 | ||
bfa5a9d9 | 57 | with GNAT.Heap_Sort_G; |
d6f39728 | 58 | |
59 | package body Sem_Ch13 is | |
60 | ||
61 | SSU : constant Pos := System_Storage_Unit; | |
62 | -- Convenient short hand for commonly used constant | |
63 | ||
64 | ----------------------- | |
65 | -- Local Subprograms -- | |
66 | ----------------------- | |
67 | ||
68 | procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); | |
69 | -- This routine is called after setting the Esize of type entity Typ. | |
1a34e48c | 70 | -- The purpose is to deal with the situation where an alignment has been |
d6f39728 | 71 | -- inherited from a derived type that is no longer appropriate for the |
72 | -- new Esize value. In this case, we reset the Alignment to unknown. | |
73 | ||
d6f39728 | 74 | procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); |
75 | -- Given two entities for record components or discriminants, checks | |
1a34e48c | 76 | -- if they have overlapping component clauses and issues errors if so. |
d6f39728 | 77 | |
78 | function Get_Alignment_Value (Expr : Node_Id) return Uint; | |
79 | -- Given the expression for an alignment value, returns the corresponding | |
80 | -- Uint value. If the value is inappropriate, then error messages are | |
81 | -- posted as required, and a value of No_Uint is returned. | |
82 | ||
83 | function Is_Operational_Item (N : Node_Id) return Boolean; | |
84 | -- A specification for a stream attribute is allowed before the full | |
85 | -- type is declared, as explained in AI-00137 and the corrigendum. | |
86 | -- Attributes that do not specify a representation characteristic are | |
87 | -- operational attributes. | |
88 | ||
9dfe12ae | 89 | function Address_Aliased_Entity (N : Node_Id) return Entity_Id; |
2866d595 | 90 | -- If expression N is of the form E'Address, return E |
9dfe12ae | 91 | |
44e4341e | 92 | procedure New_Stream_Subprogram |
d6f39728 | 93 | (N : Node_Id; |
94 | Ent : Entity_Id; | |
95 | Subp : Entity_Id; | |
9dfe12ae | 96 | Nam : TSS_Name_Type); |
44e4341e | 97 | -- Create a subprogram renaming of a given stream attribute to the |
98 | -- designated subprogram and then in the tagged case, provide this as a | |
99 | -- primitive operation, or in the non-tagged case make an appropriate TSS | |
100 | -- entry. This is more properly an expansion activity than just semantics, | |
101 | -- but the presence of user-defined stream functions for limited types is a | |
102 | -- legality check, which is why this takes place here rather than in | |
103 | -- exp_ch13, where it was previously. Nam indicates the name of the TSS | |
104 | -- function to be generated. | |
9dfe12ae | 105 | -- |
f15731c4 | 106 | -- To avoid elaboration anomalies with freeze nodes, for untagged types |
107 | -- we generate both a subprogram declaration and a subprogram renaming | |
108 | -- declaration, so that the attribute specification is handled as a | |
109 | -- renaming_as_body. For tagged types, the specification is one of the | |
110 | -- primitive specs. | |
111 | ||
d6f39728 | 112 | ---------------------------------------------- |
113 | -- Table for Validate_Unchecked_Conversions -- | |
114 | ---------------------------------------------- | |
115 | ||
116 | -- The following table collects unchecked conversions for validation. | |
117 | -- Entries are made by Validate_Unchecked_Conversion and then the | |
118 | -- call to Validate_Unchecked_Conversions does the actual error | |
119 | -- checking and posting of warnings. The reason for this delayed | |
120 | -- processing is to take advantage of back-annotations of size and | |
1a34e48c | 121 | -- alignment values performed by the back end. |
d6f39728 | 122 | |
123 | type UC_Entry is record | |
124 | Enode : Node_Id; -- node used for posting warnings | |
125 | Source : Entity_Id; -- source type for unchecked conversion | |
126 | Target : Entity_Id; -- target type for unchecked conversion | |
127 | end record; | |
128 | ||
129 | package Unchecked_Conversions is new Table.Table ( | |
130 | Table_Component_Type => UC_Entry, | |
131 | Table_Index_Type => Int, | |
132 | Table_Low_Bound => 1, | |
133 | Table_Initial => 50, | |
134 | Table_Increment => 200, | |
135 | Table_Name => "Unchecked_Conversions"); | |
136 | ||
83f8f0a6 | 137 | ---------------------------------------- |
138 | -- Table for Validate_Address_Clauses -- | |
139 | ---------------------------------------- | |
140 | ||
141 | -- If an address clause has the form | |
142 | ||
143 | -- for X'Address use Expr | |
144 | ||
145 | -- where Expr is of the form Y'Address or recursively is a reference | |
146 | -- to a constant of either of these forms, and X and Y are entities of | |
147 | -- objects, then if Y has a smaller alignment than X, that merits a | |
148 | -- warning about possible bad alignment. The following table collects | |
149 | -- address clauses of this kind. We put these in a table so that they | |
150 | -- can be checked after the back end has completed annotation of the | |
151 | -- alignments of objects, since we can catch more cases that way. | |
152 | ||
153 | type Address_Clause_Check_Record is record | |
154 | N : Node_Id; | |
155 | -- The address clause | |
156 | ||
157 | X : Entity_Id; | |
158 | -- The entity of the object overlaying Y | |
159 | ||
160 | Y : Entity_Id; | |
161 | -- The entity of the object being overlaid | |
162 | end record; | |
163 | ||
164 | package Address_Clause_Checks is new Table.Table ( | |
165 | Table_Component_Type => Address_Clause_Check_Record, | |
166 | Table_Index_Type => Int, | |
167 | Table_Low_Bound => 1, | |
168 | Table_Initial => 20, | |
169 | Table_Increment => 200, | |
170 | Table_Name => "Address_Clause_Checks"); | |
171 | ||
9dfe12ae | 172 | ---------------------------- |
173 | -- Address_Aliased_Entity -- | |
174 | ---------------------------- | |
175 | ||
176 | function Address_Aliased_Entity (N : Node_Id) return Entity_Id is | |
177 | begin | |
178 | if Nkind (N) = N_Attribute_Reference | |
179 | and then Attribute_Name (N) = Name_Address | |
180 | then | |
181 | declare | |
fdd294d1 | 182 | P : Node_Id; |
183 | ||
9dfe12ae | 184 | begin |
fdd294d1 | 185 | P := Prefix (N); |
186 | while Nkind_In (P, N_Selected_Component, N_Indexed_Component) loop | |
187 | P := Prefix (P); | |
9dfe12ae | 188 | end loop; |
189 | ||
fdd294d1 | 190 | if Is_Entity_Name (P) then |
191 | return Entity (P); | |
9dfe12ae | 192 | end if; |
193 | end; | |
194 | end if; | |
195 | ||
196 | return Empty; | |
197 | end Address_Aliased_Entity; | |
198 | ||
59ac57b5 | 199 | ----------------------------------------- |
200 | -- Adjust_Record_For_Reverse_Bit_Order -- | |
201 | ----------------------------------------- | |
202 | ||
203 | procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is | |
204 | Max_Machine_Scalar_Size : constant Uint := | |
205 | UI_From_Int | |
206 | (Standard_Long_Long_Integer_Size); | |
207 | -- We use this as the maximum machine scalar size in the sense of AI-133 | |
208 | ||
209 | Num_CC : Natural; | |
210 | Comp : Entity_Id; | |
211 | SSU : constant Uint := UI_From_Int (System_Storage_Unit); | |
212 | ||
213 | begin | |
214 | -- This first loop through components does two things. First it deals | |
215 | -- with the case of components with component clauses whose length is | |
216 | -- greater than the maximum machine scalar size (either accepting them | |
217 | -- or rejecting as needed). Second, it counts the number of components | |
218 | -- with component clauses whose length does not exceed this maximum for | |
219 | -- later processing. | |
220 | ||
221 | Num_CC := 0; | |
222 | Comp := First_Component_Or_Discriminant (R); | |
223 | while Present (Comp) loop | |
224 | declare | |
225 | CC : constant Node_Id := Component_Clause (Comp); | |
226 | Fbit : constant Uint := Static_Integer (First_Bit (CC)); | |
227 | ||
228 | begin | |
229 | if Present (CC) then | |
230 | ||
231 | -- Case of component with size > max machine scalar | |
232 | ||
233 | if Esize (Comp) > Max_Machine_Scalar_Size then | |
234 | ||
235 | -- Must begin on byte boundary | |
236 | ||
237 | if Fbit mod SSU /= 0 then | |
238 | Error_Msg_N | |
239 | ("illegal first bit value for reverse bit order", | |
240 | First_Bit (CC)); | |
241 | Error_Msg_Uint_1 := SSU; | |
242 | Error_Msg_Uint_2 := Max_Machine_Scalar_Size; | |
243 | ||
244 | Error_Msg_N | |
245 | ("\must be a multiple of ^ if size greater than ^", | |
246 | First_Bit (CC)); | |
247 | ||
248 | -- Must end on byte boundary | |
249 | ||
250 | elsif Esize (Comp) mod SSU /= 0 then | |
251 | Error_Msg_N | |
252 | ("illegal last bit value for reverse bit order", | |
253 | Last_Bit (CC)); | |
254 | Error_Msg_Uint_1 := SSU; | |
255 | Error_Msg_Uint_2 := Max_Machine_Scalar_Size; | |
256 | ||
257 | Error_Msg_N | |
258 | ("\must be a multiple of ^ if size greater than ^", | |
259 | Last_Bit (CC)); | |
260 | ||
261 | -- OK, give warning if enabled | |
262 | ||
263 | elsif Warn_On_Reverse_Bit_Order then | |
264 | Error_Msg_N | |
265 | ("multi-byte field specified with non-standard" | |
266 | & " Bit_Order?", CC); | |
267 | ||
268 | if Bytes_Big_Endian then | |
269 | Error_Msg_N | |
270 | ("\bytes are not reversed " | |
271 | & "(component is big-endian)?", CC); | |
272 | else | |
273 | Error_Msg_N | |
274 | ("\bytes are not reversed " | |
275 | & "(component is little-endian)?", CC); | |
276 | end if; | |
277 | end if; | |
278 | ||
279 | -- Case where size is not greater than max machine scalar. | |
280 | -- For now, we just count these. | |
281 | ||
282 | else | |
283 | Num_CC := Num_CC + 1; | |
284 | end if; | |
285 | end if; | |
286 | end; | |
287 | ||
288 | Next_Component_Or_Discriminant (Comp); | |
289 | end loop; | |
290 | ||
291 | -- We need to sort the component clauses on the basis of the Position | |
83f8f0a6 | 292 | -- values in the clause, so we can group clauses with the same Position. |
59ac57b5 | 293 | -- together to determine the relevant machine scalar size. |
294 | ||
295 | declare | |
296 | Comps : array (0 .. Num_CC) of Entity_Id; | |
1a34e48c | 297 | -- Array to collect component and discriminant entities. The data |
bfa5a9d9 | 298 | -- starts at index 1, the 0'th entry is for the sort routine. |
59ac57b5 | 299 | |
300 | function CP_Lt (Op1, Op2 : Natural) return Boolean; | |
bfa5a9d9 | 301 | -- Compare routine for Sort |
59ac57b5 | 302 | |
303 | procedure CP_Move (From : Natural; To : Natural); | |
bfa5a9d9 | 304 | -- Move routine for Sort |
305 | ||
306 | package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); | |
59ac57b5 | 307 | |
308 | Start : Natural; | |
309 | Stop : Natural; | |
310 | -- Start and stop positions in component list of set of components | |
311 | -- with the same starting position (that constitute components in | |
312 | -- a single machine scalar). | |
313 | ||
314 | MaxL : Uint; | |
315 | -- Maximum last bit value of any component in this set | |
316 | ||
317 | MSS : Uint; | |
318 | -- Corresponding machine scalar size | |
319 | ||
320 | ----------- | |
321 | -- CP_Lt -- | |
322 | ----------- | |
323 | ||
324 | function CP_Lt (Op1, Op2 : Natural) return Boolean is | |
325 | begin | |
326 | return Position (Component_Clause (Comps (Op1))) < | |
327 | Position (Component_Clause (Comps (Op2))); | |
328 | end CP_Lt; | |
329 | ||
330 | ------------- | |
331 | -- CP_Move -- | |
332 | ------------- | |
333 | ||
334 | procedure CP_Move (From : Natural; To : Natural) is | |
335 | begin | |
336 | Comps (To) := Comps (From); | |
337 | end CP_Move; | |
338 | ||
339 | begin | |
340 | -- Collect the component clauses | |
341 | ||
342 | Num_CC := 0; | |
343 | Comp := First_Component_Or_Discriminant (R); | |
344 | while Present (Comp) loop | |
345 | if Present (Component_Clause (Comp)) | |
346 | and then Esize (Comp) <= Max_Machine_Scalar_Size | |
347 | then | |
348 | Num_CC := Num_CC + 1; | |
349 | Comps (Num_CC) := Comp; | |
350 | end if; | |
351 | ||
352 | Next_Component_Or_Discriminant (Comp); | |
353 | end loop; | |
354 | ||
355 | -- Sort by ascending position number | |
356 | ||
bfa5a9d9 | 357 | Sorting.Sort (Num_CC); |
59ac57b5 | 358 | |
359 | -- We now have all the components whose size does not exceed the max | |
360 | -- machine scalar value, sorted by starting position. In this loop | |
361 | -- we gather groups of clauses starting at the same position, to | |
362 | -- process them in accordance with Ada 2005 AI-133. | |
363 | ||
364 | Stop := 0; | |
365 | while Stop < Num_CC loop | |
366 | Start := Stop + 1; | |
367 | Stop := Start; | |
368 | MaxL := | |
369 | Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); | |
370 | while Stop < Num_CC loop | |
371 | if Static_Integer | |
372 | (Position (Component_Clause (Comps (Stop + 1)))) = | |
373 | Static_Integer | |
374 | (Position (Component_Clause (Comps (Stop)))) | |
375 | then | |
376 | Stop := Stop + 1; | |
377 | MaxL := | |
378 | UI_Max | |
379 | (MaxL, | |
380 | Static_Integer | |
381 | (Last_Bit (Component_Clause (Comps (Stop))))); | |
382 | else | |
383 | exit; | |
384 | end if; | |
385 | end loop; | |
386 | ||
387 | -- Now we have a group of component clauses from Start to Stop | |
388 | -- whose positions are identical, and MaxL is the maximum last bit | |
389 | -- value of any of these components. | |
390 | ||
391 | -- We need to determine the corresponding machine scalar size. | |
392 | -- This loop assumes that machine scalar sizes are even, and that | |
393 | -- each possible machine scalar has twice as many bits as the | |
394 | -- next smaller one. | |
395 | ||
396 | MSS := Max_Machine_Scalar_Size; | |
397 | while MSS mod 2 = 0 | |
398 | and then (MSS / 2) >= SSU | |
399 | and then (MSS / 2) > MaxL | |
400 | loop | |
401 | MSS := MSS / 2; | |
402 | end loop; | |
403 | ||
404 | -- Here is where we fix up the Component_Bit_Offset value to | |
405 | -- account for the reverse bit order. Some examples of what needs | |
406 | -- to be done for the case of a machine scalar size of 8 are: | |
407 | ||
408 | -- First_Bit .. Last_Bit Component_Bit_Offset | |
409 | -- old new old new | |
410 | ||
411 | -- 0 .. 0 7 .. 7 0 7 | |
412 | -- 0 .. 1 6 .. 7 0 6 | |
413 | -- 0 .. 2 5 .. 7 0 5 | |
414 | -- 0 .. 7 0 .. 7 0 4 | |
415 | ||
416 | -- 1 .. 1 6 .. 6 1 6 | |
417 | -- 1 .. 4 3 .. 6 1 3 | |
418 | -- 4 .. 7 0 .. 3 4 0 | |
419 | ||
420 | -- The general rule is that the first bit is is obtained by | |
421 | -- subtracting the old ending bit from machine scalar size - 1. | |
422 | ||
423 | for C in Start .. Stop loop | |
424 | declare | |
425 | Comp : constant Entity_Id := Comps (C); | |
426 | CC : constant Node_Id := Component_Clause (Comp); | |
427 | LB : constant Uint := Static_Integer (Last_Bit (CC)); | |
428 | NFB : constant Uint := MSS - Uint_1 - LB; | |
429 | NLB : constant Uint := NFB + Esize (Comp) - 1; | |
430 | Pos : constant Uint := Static_Integer (Position (CC)); | |
431 | ||
432 | begin | |
433 | if Warn_On_Reverse_Bit_Order then | |
434 | Error_Msg_Uint_1 := MSS; | |
435 | Error_Msg_N | |
436 | ("?reverse bit order in machine " & | |
437 | "scalar of length^", First_Bit (CC)); | |
438 | Error_Msg_Uint_1 := NFB; | |
439 | Error_Msg_Uint_2 := NLB; | |
440 | ||
441 | if Bytes_Big_Endian then | |
442 | Error_Msg_NE | |
443 | ("?\big-endian range for component & is ^ .. ^", | |
444 | First_Bit (CC), Comp); | |
445 | else | |
446 | Error_Msg_NE | |
447 | ("?\little-endian range for component & is ^ .. ^", | |
448 | First_Bit (CC), Comp); | |
449 | end if; | |
450 | end if; | |
451 | ||
452 | Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); | |
453 | Set_Normalized_First_Bit (Comp, NFB mod SSU); | |
454 | end; | |
455 | end loop; | |
456 | end loop; | |
457 | end; | |
458 | end Adjust_Record_For_Reverse_Bit_Order; | |
459 | ||
d6f39728 | 460 | -------------------------------------- |
461 | -- Alignment_Check_For_Esize_Change -- | |
462 | -------------------------------------- | |
463 | ||
464 | procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is | |
465 | begin | |
466 | -- If the alignment is known, and not set by a rep clause, and is | |
467 | -- inconsistent with the size being set, then reset it to unknown, | |
468 | -- we assume in this case that the size overrides the inherited | |
469 | -- alignment, and that the alignment must be recomputed. | |
470 | ||
471 | if Known_Alignment (Typ) | |
472 | and then not Has_Alignment_Clause (Typ) | |
473 | and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0 | |
474 | then | |
475 | Init_Alignment (Typ); | |
476 | end if; | |
477 | end Alignment_Check_For_Esize_Change; | |
478 | ||
479 | ----------------------- | |
480 | -- Analyze_At_Clause -- | |
481 | ----------------------- | |
482 | ||
483 | -- An at clause is replaced by the corresponding Address attribute | |
484 | -- definition clause that is the preferred approach in Ada 95. | |
485 | ||
486 | procedure Analyze_At_Clause (N : Node_Id) is | |
177675a7 | 487 | CS : constant Boolean := Comes_From_Source (N); |
488 | ||
d6f39728 | 489 | begin |
177675a7 | 490 | -- This is an obsolescent feature |
491 | ||
e0521a36 | 492 | Check_Restriction (No_Obsolescent_Features, N); |
493 | ||
9dfe12ae | 494 | if Warn_On_Obsolescent_Feature then |
495 | Error_Msg_N | |
fbc67f84 | 496 | ("at clause is an obsolescent feature (RM J.7(2))?", N); |
9dfe12ae | 497 | Error_Msg_N |
d53a018a | 498 | ("\use address attribute definition clause instead?", N); |
9dfe12ae | 499 | end if; |
500 | ||
177675a7 | 501 | -- Rewrite as address clause |
502 | ||
d6f39728 | 503 | Rewrite (N, |
504 | Make_Attribute_Definition_Clause (Sloc (N), | |
505 | Name => Identifier (N), | |
506 | Chars => Name_Address, | |
507 | Expression => Expression (N))); | |
177675a7 | 508 | |
509 | -- We preserve Comes_From_Source, since logically the clause still | |
510 | -- comes from the source program even though it is changed in form. | |
511 | ||
512 | Set_Comes_From_Source (N, CS); | |
513 | ||
514 | -- Analyze rewritten clause | |
515 | ||
d6f39728 | 516 | Analyze_Attribute_Definition_Clause (N); |
517 | end Analyze_At_Clause; | |
518 | ||
519 | ----------------------------------------- | |
520 | -- Analyze_Attribute_Definition_Clause -- | |
521 | ----------------------------------------- | |
522 | ||
523 | procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is | |
524 | Loc : constant Source_Ptr := Sloc (N); | |
525 | Nam : constant Node_Id := Name (N); | |
526 | Attr : constant Name_Id := Chars (N); | |
527 | Expr : constant Node_Id := Expression (N); | |
528 | Id : constant Attribute_Id := Get_Attribute_Id (Attr); | |
529 | Ent : Entity_Id; | |
530 | U_Ent : Entity_Id; | |
531 | ||
532 | FOnly : Boolean := False; | |
533 | -- Reset to True for subtype specific attribute (Alignment, Size) | |
534 | -- and for stream attributes, i.e. those cases where in the call | |
535 | -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing | |
536 | -- rules are checked. Note that the case of stream attributes is not | |
537 | -- clear from the RM, but see AI95-00137. Also, the RM seems to | |
538 | -- disallow Storage_Size for derived task types, but that is also | |
539 | -- clearly unintentional. | |
540 | ||
9f373bb8 | 541 | procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); |
542 | -- Common processing for 'Read, 'Write, 'Input and 'Output attribute | |
543 | -- definition clauses. | |
544 | ||
177675a7 | 545 | ----------------------------------- |
546 | -- Analyze_Stream_TSS_Definition -- | |
547 | ----------------------------------- | |
548 | ||
9f373bb8 | 549 | procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is |
550 | Subp : Entity_Id := Empty; | |
551 | I : Interp_Index; | |
552 | It : Interp; | |
553 | Pnam : Entity_Id; | |
554 | ||
555 | Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); | |
556 | ||
557 | function Has_Good_Profile (Subp : Entity_Id) return Boolean; | |
558 | -- Return true if the entity is a subprogram with an appropriate | |
559 | -- profile for the attribute being defined. | |
560 | ||
561 | ---------------------- | |
562 | -- Has_Good_Profile -- | |
563 | ---------------------- | |
564 | ||
565 | function Has_Good_Profile (Subp : Entity_Id) return Boolean is | |
566 | F : Entity_Id; | |
567 | Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); | |
568 | Expected_Ekind : constant array (Boolean) of Entity_Kind := | |
569 | (False => E_Procedure, True => E_Function); | |
570 | Typ : Entity_Id; | |
571 | ||
572 | begin | |
573 | if Ekind (Subp) /= Expected_Ekind (Is_Function) then | |
574 | return False; | |
575 | end if; | |
576 | ||
577 | F := First_Formal (Subp); | |
578 | ||
579 | if No (F) | |
580 | or else Ekind (Etype (F)) /= E_Anonymous_Access_Type | |
581 | or else Designated_Type (Etype (F)) /= | |
582 | Class_Wide_Type (RTE (RE_Root_Stream_Type)) | |
583 | then | |
584 | return False; | |
585 | end if; | |
586 | ||
587 | if not Is_Function then | |
588 | Next_Formal (F); | |
589 | ||
590 | declare | |
591 | Expected_Mode : constant array (Boolean) of Entity_Kind := | |
592 | (False => E_In_Parameter, | |
593 | True => E_Out_Parameter); | |
594 | begin | |
595 | if Parameter_Mode (F) /= Expected_Mode (Is_Read) then | |
596 | return False; | |
597 | end if; | |
598 | end; | |
599 | ||
600 | Typ := Etype (F); | |
601 | ||
602 | else | |
603 | Typ := Etype (Subp); | |
604 | end if; | |
605 | ||
606 | return Base_Type (Typ) = Base_Type (Ent) | |
607 | and then No (Next_Formal (F)); | |
9f373bb8 | 608 | end Has_Good_Profile; |
609 | ||
610 | -- Start of processing for Analyze_Stream_TSS_Definition | |
611 | ||
612 | begin | |
613 | FOnly := True; | |
614 | ||
615 | if not Is_Type (U_Ent) then | |
616 | Error_Msg_N ("local name must be a subtype", Nam); | |
617 | return; | |
618 | end if; | |
619 | ||
620 | Pnam := TSS (Base_Type (U_Ent), TSS_Nam); | |
621 | ||
44e4341e | 622 | -- If Pnam is present, it can be either inherited from an ancestor |
623 | -- type (in which case it is legal to redefine it for this type), or | |
624 | -- be a previous definition of the attribute for the same type (in | |
625 | -- which case it is illegal). | |
626 | ||
627 | -- In the first case, it will have been analyzed already, and we | |
628 | -- can check that its profile does not match the expected profile | |
629 | -- for a stream attribute of U_Ent. In the second case, either Pnam | |
630 | -- has been analyzed (and has the expected profile), or it has not | |
631 | -- been analyzed yet (case of a type that has not been frozen yet | |
632 | -- and for which the stream attribute has been set using Set_TSS). | |
633 | ||
634 | if Present (Pnam) | |
635 | and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) | |
636 | then | |
9f373bb8 | 637 | Error_Msg_Sloc := Sloc (Pnam); |
638 | Error_Msg_Name_1 := Attr; | |
639 | Error_Msg_N ("% attribute already defined #", Nam); | |
640 | return; | |
641 | end if; | |
642 | ||
643 | Analyze (Expr); | |
644 | ||
645 | if Is_Entity_Name (Expr) then | |
646 | if not Is_Overloaded (Expr) then | |
647 | if Has_Good_Profile (Entity (Expr)) then | |
648 | Subp := Entity (Expr); | |
649 | end if; | |
650 | ||
651 | else | |
652 | Get_First_Interp (Expr, I, It); | |
9f373bb8 | 653 | while Present (It.Nam) loop |
654 | if Has_Good_Profile (It.Nam) then | |
655 | Subp := It.Nam; | |
656 | exit; | |
657 | end if; | |
658 | ||
659 | Get_Next_Interp (I, It); | |
660 | end loop; | |
661 | end if; | |
662 | end if; | |
663 | ||
664 | if Present (Subp) then | |
59ac57b5 | 665 | if Is_Abstract_Subprogram (Subp) then |
9f373bb8 | 666 | Error_Msg_N ("stream subprogram must not be abstract", Expr); |
667 | return; | |
668 | end if; | |
669 | ||
670 | Set_Entity (Expr, Subp); | |
671 | Set_Etype (Expr, Etype (Subp)); | |
672 | ||
44e4341e | 673 | New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); |
9f373bb8 | 674 | |
675 | else | |
676 | Error_Msg_Name_1 := Attr; | |
677 | Error_Msg_N ("incorrect expression for% attribute", Expr); | |
678 | end if; | |
679 | end Analyze_Stream_TSS_Definition; | |
680 | ||
681 | -- Start of processing for Analyze_Attribute_Definition_Clause | |
682 | ||
d6f39728 | 683 | begin |
fbc67f84 | 684 | if Ignore_Rep_Clauses then |
685 | Rewrite (N, Make_Null_Statement (Sloc (N))); | |
686 | return; | |
687 | end if; | |
688 | ||
d6f39728 | 689 | Analyze (Nam); |
690 | Ent := Entity (Nam); | |
691 | ||
692 | if Rep_Item_Too_Early (Ent, N) then | |
693 | return; | |
694 | end if; | |
695 | ||
9f373bb8 | 696 | -- Rep clause applies to full view of incomplete type or private type if |
697 | -- we have one (if not, this is a premature use of the type). However, | |
698 | -- certain semantic checks need to be done on the specified entity (i.e. | |
699 | -- the private view), so we save it in Ent. | |
d6f39728 | 700 | |
701 | if Is_Private_Type (Ent) | |
702 | and then Is_Derived_Type (Ent) | |
703 | and then not Is_Tagged_Type (Ent) | |
704 | and then No (Full_View (Ent)) | |
705 | then | |
9f373bb8 | 706 | -- If this is a private type whose completion is a derivation from |
707 | -- another private type, there is no full view, and the attribute | |
708 | -- belongs to the type itself, not its underlying parent. | |
d6f39728 | 709 | |
710 | U_Ent := Ent; | |
711 | ||
712 | elsif Ekind (Ent) = E_Incomplete_Type then | |
d5b349fa | 713 | |
9f373bb8 | 714 | -- The attribute applies to the full view, set the entity of the |
715 | -- attribute definition accordingly. | |
d5b349fa | 716 | |
d6f39728 | 717 | Ent := Underlying_Type (Ent); |
718 | U_Ent := Ent; | |
d5b349fa | 719 | Set_Entity (Nam, Ent); |
720 | ||
d6f39728 | 721 | else |
722 | U_Ent := Underlying_Type (Ent); | |
723 | end if; | |
724 | ||
725 | -- Complete other routine error checks | |
726 | ||
727 | if Etype (Nam) = Any_Type then | |
728 | return; | |
729 | ||
730 | elsif Scope (Ent) /= Current_Scope then | |
731 | Error_Msg_N ("entity must be declared in this scope", Nam); | |
732 | return; | |
733 | ||
f15731c4 | 734 | elsif No (U_Ent) then |
735 | U_Ent := Ent; | |
736 | ||
d6f39728 | 737 | elsif Is_Type (U_Ent) |
738 | and then not Is_First_Subtype (U_Ent) | |
739 | and then Id /= Attribute_Object_Size | |
740 | and then Id /= Attribute_Value_Size | |
741 | and then not From_At_Mod (N) | |
742 | then | |
743 | Error_Msg_N ("cannot specify attribute for subtype", Nam); | |
744 | return; | |
d6f39728 | 745 | end if; |
746 | ||
747 | -- Switch on particular attribute | |
748 | ||
749 | case Id is | |
750 | ||
751 | ------------- | |
752 | -- Address -- | |
753 | ------------- | |
754 | ||
755 | -- Address attribute definition clause | |
756 | ||
757 | when Attribute_Address => Address : begin | |
177675a7 | 758 | |
759 | -- A little error check, catch for X'Address use X'Address; | |
760 | ||
761 | if Nkind (Nam) = N_Identifier | |
762 | and then Nkind (Expr) = N_Attribute_Reference | |
763 | and then Attribute_Name (Expr) = Name_Address | |
764 | and then Nkind (Prefix (Expr)) = N_Identifier | |
765 | and then Chars (Nam) = Chars (Prefix (Expr)) | |
766 | then | |
767 | Error_Msg_NE | |
768 | ("address for & is self-referencing", Prefix (Expr), Ent); | |
769 | return; | |
770 | end if; | |
771 | ||
772 | -- Not that special case, carry on with analysis of expression | |
773 | ||
d6f39728 | 774 | Analyze_And_Resolve (Expr, RTE (RE_Address)); |
775 | ||
776 | if Present (Address_Clause (U_Ent)) then | |
777 | Error_Msg_N ("address already given for &", Nam); | |
778 | ||
779 | -- Case of address clause for subprogram | |
780 | ||
781 | elsif Is_Subprogram (U_Ent) then | |
d6f39728 | 782 | if Has_Homonym (U_Ent) then |
783 | Error_Msg_N | |
784 | ("address clause cannot be given " & | |
785 | "for overloaded subprogram", | |
786 | Nam); | |
83f8f0a6 | 787 | return; |
d6f39728 | 788 | end if; |
789 | ||
83f8f0a6 | 790 | -- For subprograms, all address clauses are permitted, and we |
791 | -- mark the subprogram as having a deferred freeze so that Gigi | |
792 | -- will not elaborate it too soon. | |
d6f39728 | 793 | |
794 | -- Above needs more comments, what is too soon about??? | |
795 | ||
796 | Set_Has_Delayed_Freeze (U_Ent); | |
797 | ||
798 | -- Case of address clause for entry | |
799 | ||
800 | elsif Ekind (U_Ent) = E_Entry then | |
d6f39728 | 801 | if Nkind (Parent (N)) = N_Task_Body then |
802 | Error_Msg_N | |
803 | ("entry address must be specified in task spec", Nam); | |
83f8f0a6 | 804 | return; |
d6f39728 | 805 | end if; |
806 | ||
807 | -- For entries, we require a constant address | |
808 | ||
809 | Check_Constant_Address_Clause (Expr, U_Ent); | |
810 | ||
83f8f0a6 | 811 | -- Special checks for task types |
812 | ||
f15731c4 | 813 | if Is_Task_Type (Scope (U_Ent)) |
814 | and then Comes_From_Source (Scope (U_Ent)) | |
815 | then | |
816 | Error_Msg_N | |
817 | ("?entry address declared for entry in task type", N); | |
818 | Error_Msg_N | |
819 | ("\?only one task can be declared of this type", N); | |
820 | end if; | |
821 | ||
83f8f0a6 | 822 | -- Entry address clauses are obsolescent |
823 | ||
e0521a36 | 824 | Check_Restriction (No_Obsolescent_Features, N); |
825 | ||
9dfe12ae | 826 | if Warn_On_Obsolescent_Feature then |
827 | Error_Msg_N | |
828 | ("attaching interrupt to task entry is an " & | |
fbc67f84 | 829 | "obsolescent feature (RM J.7.1)?", N); |
9dfe12ae | 830 | Error_Msg_N |
d53a018a | 831 | ("\use interrupt procedure instead?", N); |
9dfe12ae | 832 | end if; |
833 | ||
83f8f0a6 | 834 | -- Case of an address clause for a controlled object which we |
835 | -- consider to be erroneous. | |
9dfe12ae | 836 | |
83f8f0a6 | 837 | elsif Is_Controlled (Etype (U_Ent)) |
838 | or else Has_Controlled_Component (Etype (U_Ent)) | |
839 | then | |
9dfe12ae | 840 | Error_Msg_NE |
841 | ("?controlled object& must not be overlaid", Nam, U_Ent); | |
842 | Error_Msg_N | |
843 | ("\?Program_Error will be raised at run time", Nam); | |
844 | Insert_Action (Declaration_Node (U_Ent), | |
845 | Make_Raise_Program_Error (Loc, | |
846 | Reason => PE_Overlaid_Controlled_Object)); | |
83f8f0a6 | 847 | return; |
9dfe12ae | 848 | |
849 | -- Case of address clause for a (non-controlled) object | |
d6f39728 | 850 | |
851 | elsif | |
852 | Ekind (U_Ent) = E_Variable | |
853 | or else | |
854 | Ekind (U_Ent) = E_Constant | |
855 | then | |
856 | declare | |
83f8f0a6 | 857 | Expr : constant Node_Id := Expression (N); |
858 | Aent : constant Entity_Id := Address_Aliased_Entity (Expr); | |
859 | Ent_Y : constant Entity_Id := Find_Overlaid_Object (N); | |
d6f39728 | 860 | |
861 | begin | |
862 | -- Exported variables cannot have an address clause, | |
863 | -- because this cancels the effect of the pragma Export | |
864 | ||
865 | if Is_Exported (U_Ent) then | |
866 | Error_Msg_N | |
867 | ("cannot export object with address clause", Nam); | |
83f8f0a6 | 868 | return; |
d6f39728 | 869 | |
9dfe12ae | 870 | -- Overlaying controlled objects is erroneous |
871 | ||
872 | elsif Present (Aent) | |
83f8f0a6 | 873 | and then (Has_Controlled_Component (Etype (Aent)) |
874 | or else Is_Controlled (Etype (Aent))) | |
9dfe12ae | 875 | then |
876 | Error_Msg_N | |
83f8f0a6 | 877 | ("?cannot overlay with controlled object", Expr); |
9dfe12ae | 878 | Error_Msg_N |
879 | ("\?Program_Error will be raised at run time", Expr); | |
880 | Insert_Action (Declaration_Node (U_Ent), | |
881 | Make_Raise_Program_Error (Loc, | |
882 | Reason => PE_Overlaid_Controlled_Object)); | |
83f8f0a6 | 883 | return; |
9dfe12ae | 884 | |
885 | elsif Present (Aent) | |
886 | and then Ekind (U_Ent) = E_Constant | |
887 | and then Ekind (Aent) /= E_Constant | |
888 | then | |
889 | Error_Msg_N ("constant overlays a variable?", Expr); | |
890 | ||
891 | elsif Present (Renamed_Object (U_Ent)) then | |
892 | Error_Msg_N | |
893 | ("address clause not allowed" | |
fbc67f84 | 894 | & " for a renaming declaration (RM 13.1(6))", Nam); |
83f8f0a6 | 895 | return; |
9dfe12ae | 896 | |
d6f39728 | 897 | -- Imported variables can have an address clause, but then |
898 | -- the import is pretty meaningless except to suppress | |
899 | -- initializations, so we do not need such variables to | |
900 | -- be statically allocated (and in fact it causes trouble | |
901 | -- if the address clause is a local value). | |
902 | ||
903 | elsif Is_Imported (U_Ent) then | |
904 | Set_Is_Statically_Allocated (U_Ent, False); | |
905 | end if; | |
906 | ||
907 | -- We mark a possible modification of a variable with an | |
908 | -- address clause, since it is likely aliasing is occurring. | |
909 | ||
177675a7 | 910 | Note_Possible_Modification (Nam, Sure => False); |
d6f39728 | 911 | |
83f8f0a6 | 912 | -- Here we are checking for explicit overlap of one variable |
913 | -- by another, and if we find this then mark the overlapped | |
914 | -- variable as also being volatile to prevent unwanted | |
915 | -- optimizations. | |
d6f39728 | 916 | |
83f8f0a6 | 917 | if Present (Ent_Y) then |
918 | Set_Treat_As_Volatile (Ent_Y); | |
d6f39728 | 919 | end if; |
920 | ||
9dfe12ae | 921 | -- Legality checks on the address clause for initialized |
922 | -- objects is deferred until the freeze point, because | |
923 | -- a subsequent pragma might indicate that the object is | |
924 | -- imported and thus not initialized. | |
925 | ||
926 | Set_Has_Delayed_Freeze (U_Ent); | |
927 | ||
d6f39728 | 928 | if Is_Exported (U_Ent) then |
929 | Error_Msg_N | |
930 | ("& cannot be exported if an address clause is given", | |
931 | Nam); | |
932 | Error_Msg_N | |
933 | ("\define and export a variable " & | |
934 | "that holds its address instead", | |
935 | Nam); | |
936 | end if; | |
937 | ||
44e4341e | 938 | -- Entity has delayed freeze, so we will generate an |
939 | -- alignment check at the freeze point unless suppressed. | |
d6f39728 | 940 | |
44e4341e | 941 | if not Range_Checks_Suppressed (U_Ent) |
942 | and then not Alignment_Checks_Suppressed (U_Ent) | |
943 | then | |
944 | Set_Check_Address_Alignment (N); | |
945 | end if; | |
d6f39728 | 946 | |
947 | -- Kill the size check code, since we are not allocating | |
948 | -- the variable, it is somewhere else. | |
949 | ||
950 | Kill_Size_Check_Code (U_Ent); | |
951 | end; | |
952 | ||
83f8f0a6 | 953 | -- If the address clause is of the form: |
954 | ||
177675a7 | 955 | -- for Y'Address use X'Address |
83f8f0a6 | 956 | |
957 | -- or | |
958 | ||
177675a7 | 959 | -- Const : constant Address := X'Address; |
83f8f0a6 | 960 | -- ... |
177675a7 | 961 | -- for Y'Address use Const; |
83f8f0a6 | 962 | |
963 | -- then we make an entry in the table for checking the size and | |
964 | -- alignment of the overlaying variable. We defer this check | |
965 | -- till after code generation to take full advantage of the | |
966 | -- annotation done by the back end. This entry is only made if | |
967 | -- we have not already posted a warning about size/alignment | |
177675a7 | 968 | -- (some warnings of this type are posted in Checks), and if |
969 | -- the address clause comes from source. | |
83f8f0a6 | 970 | |
177675a7 | 971 | if Address_Clause_Overlay_Warnings |
972 | and then Comes_From_Source (N) | |
973 | then | |
83f8f0a6 | 974 | declare |
975 | Ent_X : Entity_Id := Empty; | |
976 | Ent_Y : Entity_Id := Empty; | |
977 | ||
978 | begin | |
979 | Ent_Y := Find_Overlaid_Object (N); | |
980 | ||
981 | if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then | |
982 | Ent_X := Entity (Name (N)); | |
177675a7 | 983 | Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); |
984 | ||
985 | -- If variable overlays a constant view, and we are | |
986 | -- warning on overlays, then mark the variable as | |
987 | -- overlaying a constant (we will give warnings later | |
988 | -- if this variable is assigned). | |
989 | ||
990 | if Is_Constant_Object (Ent_Y) | |
991 | and then Ekind (Ent_X) = E_Variable | |
992 | then | |
993 | Set_Overlays_Constant (Ent_X); | |
994 | end if; | |
83f8f0a6 | 995 | end if; |
996 | end; | |
997 | end if; | |
998 | ||
d6f39728 | 999 | -- Not a valid entity for an address clause |
1000 | ||
1001 | else | |
1002 | Error_Msg_N ("address cannot be given for &", Nam); | |
1003 | end if; | |
1004 | end Address; | |
1005 | ||
1006 | --------------- | |
1007 | -- Alignment -- | |
1008 | --------------- | |
1009 | ||
1010 | -- Alignment attribute definition clause | |
1011 | ||
1012 | when Attribute_Alignment => Alignment_Block : declare | |
9dfe12ae | 1013 | Align : constant Uint := Get_Alignment_Value (Expr); |
d6f39728 | 1014 | |
1015 | begin | |
1016 | FOnly := True; | |
1017 | ||
1018 | if not Is_Type (U_Ent) | |
1019 | and then Ekind (U_Ent) /= E_Variable | |
1020 | and then Ekind (U_Ent) /= E_Constant | |
1021 | then | |
1022 | Error_Msg_N ("alignment cannot be given for &", Nam); | |
1023 | ||
1024 | elsif Has_Alignment_Clause (U_Ent) then | |
1025 | Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); | |
1026 | Error_Msg_N ("alignment clause previously given#", N); | |
1027 | ||
1028 | elsif Align /= No_Uint then | |
1029 | Set_Has_Alignment_Clause (U_Ent); | |
1030 | Set_Alignment (U_Ent, Align); | |
1031 | end if; | |
1032 | end Alignment_Block; | |
1033 | ||
1034 | --------------- | |
1035 | -- Bit_Order -- | |
1036 | --------------- | |
1037 | ||
1038 | -- Bit_Order attribute definition clause | |
1039 | ||
1040 | when Attribute_Bit_Order => Bit_Order : declare | |
1041 | begin | |
1042 | if not Is_Record_Type (U_Ent) then | |
1043 | Error_Msg_N | |
1044 | ("Bit_Order can only be defined for record type", Nam); | |
1045 | ||
1046 | else | |
1047 | Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); | |
1048 | ||
1049 | if Etype (Expr) = Any_Type then | |
1050 | return; | |
1051 | ||
1052 | elsif not Is_Static_Expression (Expr) then | |
9dfe12ae | 1053 | Flag_Non_Static_Expr |
1054 | ("Bit_Order requires static expression!", Expr); | |
d6f39728 | 1055 | |
1056 | else | |
1057 | if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then | |
1058 | Set_Reverse_Bit_Order (U_Ent, True); | |
1059 | end if; | |
1060 | end if; | |
1061 | end if; | |
1062 | end Bit_Order; | |
1063 | ||
1064 | -------------------- | |
1065 | -- Component_Size -- | |
1066 | -------------------- | |
1067 | ||
1068 | -- Component_Size attribute definition clause | |
1069 | ||
1070 | when Attribute_Component_Size => Component_Size_Case : declare | |
1071 | Csize : constant Uint := Static_Integer (Expr); | |
1072 | Btype : Entity_Id; | |
1073 | Biased : Boolean; | |
1074 | New_Ctyp : Entity_Id; | |
1075 | Decl : Node_Id; | |
1076 | ||
1077 | begin | |
1078 | if not Is_Array_Type (U_Ent) then | |
1079 | Error_Msg_N ("component size requires array type", Nam); | |
1080 | return; | |
1081 | end if; | |
1082 | ||
1083 | Btype := Base_Type (U_Ent); | |
1084 | ||
1085 | if Has_Component_Size_Clause (Btype) then | |
1086 | Error_Msg_N | |
3062c401 | 1087 | ("component size clause for& previously given", Nam); |
d6f39728 | 1088 | |
1089 | elsif Csize /= No_Uint then | |
1090 | Check_Size (Expr, Component_Type (Btype), Csize, Biased); | |
1091 | ||
1092 | if Has_Aliased_Components (Btype) | |
1093 | and then Csize < 32 | |
1094 | and then Csize /= 8 | |
1095 | and then Csize /= 16 | |
1096 | then | |
1097 | Error_Msg_N | |
1098 | ("component size incorrect for aliased components", N); | |
1099 | return; | |
1100 | end if; | |
1101 | ||
1102 | -- For the biased case, build a declaration for a subtype | |
1103 | -- that will be used to represent the biased subtype that | |
1104 | -- reflects the biased representation of components. We need | |
1105 | -- this subtype to get proper conversions on referencing | |
3062c401 | 1106 | -- elements of the array. Note that component size clauses |
1107 | -- are ignored in VM mode. | |
1108 | ||
1109 | if VM_Target = No_VM then | |
1110 | if Biased then | |
1111 | New_Ctyp := | |
1112 | Make_Defining_Identifier (Loc, | |
1113 | Chars => | |
1114 | New_External_Name (Chars (U_Ent), 'C', 0, 'T')); | |
1115 | ||
1116 | Decl := | |
1117 | Make_Subtype_Declaration (Loc, | |
1118 | Defining_Identifier => New_Ctyp, | |
1119 | Subtype_Indication => | |
1120 | New_Occurrence_Of (Component_Type (Btype), Loc)); | |
1121 | ||
1122 | Set_Parent (Decl, N); | |
1123 | Analyze (Decl, Suppress => All_Checks); | |
1124 | ||
1125 | Set_Has_Delayed_Freeze (New_Ctyp, False); | |
1126 | Set_Esize (New_Ctyp, Csize); | |
1127 | Set_RM_Size (New_Ctyp, Csize); | |
1128 | Init_Alignment (New_Ctyp); | |
1129 | Set_Has_Biased_Representation (New_Ctyp, True); | |
1130 | Set_Is_Itype (New_Ctyp, True); | |
1131 | Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); | |
1132 | ||
1133 | Set_Component_Type (Btype, New_Ctyp); | |
1134 | end if; | |
1135 | ||
1136 | Set_Component_Size (Btype, Csize); | |
1137 | ||
1138 | -- For VM case, we ignore component size clauses | |
1139 | ||
1140 | else | |
1141 | -- Give a warning unless we are in GNAT mode, in which case | |
1142 | -- the warning is suppressed since it is not useful. | |
1143 | ||
1144 | if not GNAT_Mode then | |
1145 | Error_Msg_N | |
1146 | ("?component size ignored in this configuration", N); | |
1147 | end if; | |
d6f39728 | 1148 | end if; |
1149 | ||
d6f39728 | 1150 | Set_Has_Component_Size_Clause (Btype, True); |
1151 | Set_Has_Non_Standard_Rep (Btype, True); | |
1152 | end if; | |
1153 | end Component_Size_Case; | |
1154 | ||
1155 | ------------------ | |
1156 | -- External_Tag -- | |
1157 | ------------------ | |
1158 | ||
1159 | when Attribute_External_Tag => External_Tag : | |
1160 | begin | |
1161 | if not Is_Tagged_Type (U_Ent) then | |
1162 | Error_Msg_N ("should be a tagged type", Nam); | |
1163 | end if; | |
1164 | ||
1165 | Analyze_And_Resolve (Expr, Standard_String); | |
1166 | ||
1167 | if not Is_Static_Expression (Expr) then | |
9dfe12ae | 1168 | Flag_Non_Static_Expr |
1169 | ("static string required for tag name!", Nam); | |
d6f39728 | 1170 | end if; |
1171 | ||
15ebb600 | 1172 | if VM_Target = No_VM then |
1173 | Set_Has_External_Tag_Rep_Clause (U_Ent); | |
bfa5a9d9 | 1174 | elsif not Inspector_Mode then |
15ebb600 | 1175 | Error_Msg_Name_1 := Attr; |
1176 | Error_Msg_N | |
1177 | ("% attribute unsupported in this configuration", Nam); | |
1178 | end if; | |
fbc67f84 | 1179 | |
1180 | if not Is_Library_Level_Entity (U_Ent) then | |
1181 | Error_Msg_NE | |
1182 | ("?non-unique external tag supplied for &", N, U_Ent); | |
1183 | Error_Msg_N | |
1184 | ("?\same external tag applies to all subprogram calls", N); | |
1185 | Error_Msg_N | |
1186 | ("?\corresponding internal tag cannot be obtained", N); | |
1187 | end if; | |
d6f39728 | 1188 | end External_Tag; |
1189 | ||
1190 | ----------- | |
1191 | -- Input -- | |
1192 | ----------- | |
1193 | ||
9f373bb8 | 1194 | when Attribute_Input => |
1195 | Analyze_Stream_TSS_Definition (TSS_Stream_Input); | |
1196 | Set_Has_Specified_Stream_Input (Ent); | |
d6f39728 | 1197 | |
1198 | ------------------- | |
1199 | -- Machine_Radix -- | |
1200 | ------------------- | |
1201 | ||
1202 | -- Machine radix attribute definition clause | |
1203 | ||
1204 | when Attribute_Machine_Radix => Machine_Radix : declare | |
1205 | Radix : constant Uint := Static_Integer (Expr); | |
1206 | ||
1207 | begin | |
1208 | if not Is_Decimal_Fixed_Point_Type (U_Ent) then | |
1209 | Error_Msg_N ("decimal fixed-point type expected for &", Nam); | |
1210 | ||
1211 | elsif Has_Machine_Radix_Clause (U_Ent) then | |
1212 | Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); | |
1213 | Error_Msg_N ("machine radix clause previously given#", N); | |
1214 | ||
1215 | elsif Radix /= No_Uint then | |
1216 | Set_Has_Machine_Radix_Clause (U_Ent); | |
1217 | Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); | |
1218 | ||
1219 | if Radix = 2 then | |
1220 | null; | |
1221 | elsif Radix = 10 then | |
1222 | Set_Machine_Radix_10 (U_Ent); | |
1223 | else | |
1224 | Error_Msg_N ("machine radix value must be 2 or 10", Expr); | |
1225 | end if; | |
1226 | end if; | |
1227 | end Machine_Radix; | |
1228 | ||
1229 | ----------------- | |
1230 | -- Object_Size -- | |
1231 | ----------------- | |
1232 | ||
1233 | -- Object_Size attribute definition clause | |
1234 | ||
1235 | when Attribute_Object_Size => Object_Size : declare | |
bfa5a9d9 | 1236 | Size : constant Uint := Static_Integer (Expr); |
1237 | ||
d6f39728 | 1238 | Biased : Boolean; |
bfa5a9d9 | 1239 | pragma Warnings (Off, Biased); |
d6f39728 | 1240 | |
1241 | begin | |
1242 | if not Is_Type (U_Ent) then | |
1243 | Error_Msg_N ("Object_Size cannot be given for &", Nam); | |
1244 | ||
1245 | elsif Has_Object_Size_Clause (U_Ent) then | |
1246 | Error_Msg_N ("Object_Size already given for &", Nam); | |
1247 | ||
1248 | else | |
1249 | Check_Size (Expr, U_Ent, Size, Biased); | |
1250 | ||
1251 | if Size /= 8 | |
1252 | and then | |
1253 | Size /= 16 | |
1254 | and then | |
1255 | Size /= 32 | |
1256 | and then | |
1257 | UI_Mod (Size, 64) /= 0 | |
1258 | then | |
1259 | Error_Msg_N | |
1260 | ("Object_Size must be 8, 16, 32, or multiple of 64", | |
1261 | Expr); | |
1262 | end if; | |
1263 | ||
1264 | Set_Esize (U_Ent, Size); | |
1265 | Set_Has_Object_Size_Clause (U_Ent); | |
1266 | Alignment_Check_For_Esize_Change (U_Ent); | |
1267 | end if; | |
1268 | end Object_Size; | |
1269 | ||
1270 | ------------ | |
1271 | -- Output -- | |
1272 | ------------ | |
1273 | ||
9f373bb8 | 1274 | when Attribute_Output => |
1275 | Analyze_Stream_TSS_Definition (TSS_Stream_Output); | |
1276 | Set_Has_Specified_Stream_Output (Ent); | |
d6f39728 | 1277 | |
1278 | ---------- | |
1279 | -- Read -- | |
1280 | ---------- | |
1281 | ||
9f373bb8 | 1282 | when Attribute_Read => |
1283 | Analyze_Stream_TSS_Definition (TSS_Stream_Read); | |
1284 | Set_Has_Specified_Stream_Read (Ent); | |
d6f39728 | 1285 | |
1286 | ---------- | |
1287 | -- Size -- | |
1288 | ---------- | |
1289 | ||
1290 | -- Size attribute definition clause | |
1291 | ||
1292 | when Attribute_Size => Size : declare | |
1293 | Size : constant Uint := Static_Integer (Expr); | |
1294 | Etyp : Entity_Id; | |
1295 | Biased : Boolean; | |
1296 | ||
1297 | begin | |
1298 | FOnly := True; | |
1299 | ||
1300 | if Has_Size_Clause (U_Ent) then | |
1301 | Error_Msg_N ("size already given for &", Nam); | |
1302 | ||
1303 | elsif not Is_Type (U_Ent) | |
1304 | and then Ekind (U_Ent) /= E_Variable | |
1305 | and then Ekind (U_Ent) /= E_Constant | |
1306 | then | |
1307 | Error_Msg_N ("size cannot be given for &", Nam); | |
1308 | ||
1309 | elsif Is_Array_Type (U_Ent) | |
1310 | and then not Is_Constrained (U_Ent) | |
1311 | then | |
1312 | Error_Msg_N | |
1313 | ("size cannot be given for unconstrained array", Nam); | |
1314 | ||
1315 | elsif Size /= No_Uint then | |
d6f39728 | 1316 | if Is_Type (U_Ent) then |
1317 | Etyp := U_Ent; | |
1318 | else | |
1319 | Etyp := Etype (U_Ent); | |
1320 | end if; | |
1321 | ||
59ac57b5 | 1322 | -- Check size, note that Gigi is in charge of checking that the |
1323 | -- size of an array or record type is OK. Also we do not check | |
1324 | -- the size in the ordinary fixed-point case, since it is too | |
1325 | -- early to do so (there may be subsequent small clause that | |
1326 | -- affects the size). We can check the size if a small clause | |
1327 | -- has already been given. | |
d6f39728 | 1328 | |
1329 | if not Is_Ordinary_Fixed_Point_Type (U_Ent) | |
1330 | or else Has_Small_Clause (U_Ent) | |
1331 | then | |
1332 | Check_Size (Expr, Etyp, Size, Biased); | |
1333 | Set_Has_Biased_Representation (U_Ent, Biased); | |
1334 | end if; | |
1335 | ||
1336 | -- For types set RM_Size and Esize if possible | |
1337 | ||
1338 | if Is_Type (U_Ent) then | |
1339 | Set_RM_Size (U_Ent, Size); | |
1340 | ||
59ac57b5 | 1341 | -- For scalar types, increase Object_Size to power of 2, but |
1342 | -- not less than a storage unit in any case (i.e., normally | |
1343 | -- this means it will be byte addressable). | |
d6f39728 | 1344 | |
1345 | if Is_Scalar_Type (U_Ent) then | |
f15731c4 | 1346 | if Size <= System_Storage_Unit then |
1347 | Init_Esize (U_Ent, System_Storage_Unit); | |
d6f39728 | 1348 | elsif Size <= 16 then |
1349 | Init_Esize (U_Ent, 16); | |
1350 | elsif Size <= 32 then | |
1351 | Init_Esize (U_Ent, 32); | |
1352 | else | |
1353 | Set_Esize (U_Ent, (Size + 63) / 64 * 64); | |
1354 | end if; | |
1355 | ||
1356 | -- For all other types, object size = value size. The | |
1357 | -- backend will adjust as needed. | |
1358 | ||
1359 | else | |
1360 | Set_Esize (U_Ent, Size); | |
1361 | end if; | |
1362 | ||
1363 | Alignment_Check_For_Esize_Change (U_Ent); | |
1364 | ||
1365 | -- For objects, set Esize only | |
1366 | ||
1367 | else | |
9dfe12ae | 1368 | if Is_Elementary_Type (Etyp) then |
1369 | if Size /= System_Storage_Unit | |
1370 | and then | |
1371 | Size /= System_Storage_Unit * 2 | |
1372 | and then | |
1373 | Size /= System_Storage_Unit * 4 | |
1374 | and then | |
1375 | Size /= System_Storage_Unit * 8 | |
1376 | then | |
5c99c290 | 1377 | Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); |
87d5c1d0 | 1378 | Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; |
9dfe12ae | 1379 | Error_Msg_N |
5c99c290 | 1380 | ("size for primitive object must be a power of 2" |
87d5c1d0 | 1381 | & " in the range ^-^", N); |
9dfe12ae | 1382 | end if; |
1383 | end if; | |
1384 | ||
d6f39728 | 1385 | Set_Esize (U_Ent, Size); |
1386 | end if; | |
1387 | ||
1388 | Set_Has_Size_Clause (U_Ent); | |
1389 | end if; | |
1390 | end Size; | |
1391 | ||
1392 | ----------- | |
1393 | -- Small -- | |
1394 | ----------- | |
1395 | ||
1396 | -- Small attribute definition clause | |
1397 | ||
1398 | when Attribute_Small => Small : declare | |
1399 | Implicit_Base : constant Entity_Id := Base_Type (U_Ent); | |
1400 | Small : Ureal; | |
1401 | ||
1402 | begin | |
1403 | Analyze_And_Resolve (Expr, Any_Real); | |
1404 | ||
1405 | if Etype (Expr) = Any_Type then | |
1406 | return; | |
1407 | ||
1408 | elsif not Is_Static_Expression (Expr) then | |
9dfe12ae | 1409 | Flag_Non_Static_Expr |
1410 | ("small requires static expression!", Expr); | |
d6f39728 | 1411 | return; |
1412 | ||
1413 | else | |
1414 | Small := Expr_Value_R (Expr); | |
1415 | ||
1416 | if Small <= Ureal_0 then | |
1417 | Error_Msg_N ("small value must be greater than zero", Expr); | |
1418 | return; | |
1419 | end if; | |
1420 | ||
1421 | end if; | |
1422 | ||
1423 | if not Is_Ordinary_Fixed_Point_Type (U_Ent) then | |
1424 | Error_Msg_N | |
1425 | ("small requires an ordinary fixed point type", Nam); | |
1426 | ||
1427 | elsif Has_Small_Clause (U_Ent) then | |
1428 | Error_Msg_N ("small already given for &", Nam); | |
1429 | ||
1430 | elsif Small > Delta_Value (U_Ent) then | |
1431 | Error_Msg_N | |
1432 | ("small value must not be greater then delta value", Nam); | |
1433 | ||
1434 | else | |
1435 | Set_Small_Value (U_Ent, Small); | |
1436 | Set_Small_Value (Implicit_Base, Small); | |
1437 | Set_Has_Small_Clause (U_Ent); | |
1438 | Set_Has_Small_Clause (Implicit_Base); | |
1439 | Set_Has_Non_Standard_Rep (Implicit_Base); | |
1440 | end if; | |
1441 | end Small; | |
1442 | ||
d6f39728 | 1443 | ------------------ |
1444 | -- Storage_Pool -- | |
1445 | ------------------ | |
1446 | ||
1447 | -- Storage_Pool attribute definition clause | |
1448 | ||
1449 | when Attribute_Storage_Pool => Storage_Pool : declare | |
1450 | Pool : Entity_Id; | |
6b567c71 | 1451 | T : Entity_Id; |
d6f39728 | 1452 | |
1453 | begin | |
44e4341e | 1454 | if Ekind (U_Ent) = E_Access_Subprogram_Type then |
1455 | Error_Msg_N | |
1456 | ("storage pool cannot be given for access-to-subprogram type", | |
1457 | Nam); | |
1458 | return; | |
1459 | ||
1460 | elsif Ekind (U_Ent) /= E_Access_Type | |
d6f39728 | 1461 | and then Ekind (U_Ent) /= E_General_Access_Type |
1462 | then | |
44e4341e | 1463 | Error_Msg_N |
1464 | ("storage pool can only be given for access types", Nam); | |
d6f39728 | 1465 | return; |
1466 | ||
1467 | elsif Is_Derived_Type (U_Ent) then | |
1468 | Error_Msg_N | |
1469 | ("storage pool cannot be given for a derived access type", | |
1470 | Nam); | |
1471 | ||
1472 | elsif Has_Storage_Size_Clause (U_Ent) then | |
1473 | Error_Msg_N ("storage size already given for &", Nam); | |
1474 | return; | |
1475 | ||
1476 | elsif Present (Associated_Storage_Pool (U_Ent)) then | |
1477 | Error_Msg_N ("storage pool already given for &", Nam); | |
1478 | return; | |
1479 | end if; | |
1480 | ||
1481 | Analyze_And_Resolve | |
1482 | (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); | |
1483 | ||
6b567c71 | 1484 | if Nkind (Expr) = N_Type_Conversion then |
1485 | T := Etype (Expression (Expr)); | |
1486 | else | |
1487 | T := Etype (Expr); | |
1488 | end if; | |
1489 | ||
1490 | -- The Stack_Bounded_Pool is used internally for implementing | |
1491 | -- access types with a Storage_Size. Since it only work | |
1492 | -- properly when used on one specific type, we need to check | |
1a34e48c | 1493 | -- that it is not hijacked improperly: |
6b567c71 | 1494 | -- type T is access Integer; |
1495 | -- for T'Storage_Size use n; | |
1496 | -- type Q is access Float; | |
1497 | -- for Q'Storage_Size use T'Storage_Size; -- incorrect | |
1498 | ||
15ebb600 | 1499 | if RTE_Available (RE_Stack_Bounded_Pool) |
1500 | and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool) | |
1501 | then | |
1502 | Error_Msg_N ("non-shareable internal Pool", Expr); | |
6b567c71 | 1503 | return; |
1504 | end if; | |
1505 | ||
d6f39728 | 1506 | -- If the argument is a name that is not an entity name, then |
1507 | -- we construct a renaming operation to define an entity of | |
1508 | -- type storage pool. | |
1509 | ||
1510 | if not Is_Entity_Name (Expr) | |
1511 | and then Is_Object_Reference (Expr) | |
1512 | then | |
1513 | Pool := | |
1514 | Make_Defining_Identifier (Loc, | |
1515 | Chars => New_Internal_Name ('P')); | |
1516 | ||
1517 | declare | |
1518 | Rnode : constant Node_Id := | |
1519 | Make_Object_Renaming_Declaration (Loc, | |
1520 | Defining_Identifier => Pool, | |
1521 | Subtype_Mark => | |
1522 | New_Occurrence_Of (Etype (Expr), Loc), | |
1523 | Name => Expr); | |
1524 | ||
1525 | begin | |
1526 | Insert_Before (N, Rnode); | |
1527 | Analyze (Rnode); | |
1528 | Set_Associated_Storage_Pool (U_Ent, Pool); | |
1529 | end; | |
1530 | ||
1531 | elsif Is_Entity_Name (Expr) then | |
1532 | Pool := Entity (Expr); | |
1533 | ||
1534 | -- If pool is a renamed object, get original one. This can | |
1535 | -- happen with an explicit renaming, and within instances. | |
1536 | ||
1537 | while Present (Renamed_Object (Pool)) | |
1538 | and then Is_Entity_Name (Renamed_Object (Pool)) | |
1539 | loop | |
1540 | Pool := Entity (Renamed_Object (Pool)); | |
1541 | end loop; | |
1542 | ||
1543 | if Present (Renamed_Object (Pool)) | |
1544 | and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion | |
1545 | and then Is_Entity_Name (Expression (Renamed_Object (Pool))) | |
1546 | then | |
1547 | Pool := Entity (Expression (Renamed_Object (Pool))); | |
1548 | end if; | |
1549 | ||
6b567c71 | 1550 | Set_Associated_Storage_Pool (U_Ent, Pool); |
d6f39728 | 1551 | |
1552 | elsif Nkind (Expr) = N_Type_Conversion | |
1553 | and then Is_Entity_Name (Expression (Expr)) | |
1554 | and then Nkind (Original_Node (Expr)) = N_Attribute_Reference | |
1555 | then | |
1556 | Pool := Entity (Expression (Expr)); | |
6b567c71 | 1557 | Set_Associated_Storage_Pool (U_Ent, Pool); |
d6f39728 | 1558 | |
1559 | else | |
1560 | Error_Msg_N ("incorrect reference to a Storage Pool", Expr); | |
1561 | return; | |
1562 | end if; | |
1563 | end Storage_Pool; | |
1564 | ||
44e4341e | 1565 | ------------------ |
1566 | -- Storage_Size -- | |
1567 | ------------------ | |
1568 | ||
1569 | -- Storage_Size attribute definition clause | |
1570 | ||
1571 | when Attribute_Storage_Size => Storage_Size : declare | |
1572 | Btype : constant Entity_Id := Base_Type (U_Ent); | |
1573 | Sprag : Node_Id; | |
1574 | ||
1575 | begin | |
1576 | if Is_Task_Type (U_Ent) then | |
1577 | Check_Restriction (No_Obsolescent_Features, N); | |
1578 | ||
1579 | if Warn_On_Obsolescent_Feature then | |
1580 | Error_Msg_N | |
1581 | ("storage size clause for task is an " & | |
fbc67f84 | 1582 | "obsolescent feature (RM J.9)?", N); |
44e4341e | 1583 | Error_Msg_N |
1584 | ("\use Storage_Size pragma instead?", N); | |
1585 | end if; | |
1586 | ||
1587 | FOnly := True; | |
1588 | end if; | |
1589 | ||
1590 | if not Is_Access_Type (U_Ent) | |
1591 | and then Ekind (U_Ent) /= E_Task_Type | |
1592 | then | |
1593 | Error_Msg_N ("storage size cannot be given for &", Nam); | |
1594 | ||
1595 | elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then | |
1596 | Error_Msg_N | |
1597 | ("storage size cannot be given for a derived access type", | |
1598 | Nam); | |
1599 | ||
1600 | elsif Has_Storage_Size_Clause (Btype) then | |
1601 | Error_Msg_N ("storage size already given for &", Nam); | |
1602 | ||
1603 | else | |
1604 | Analyze_And_Resolve (Expr, Any_Integer); | |
1605 | ||
1606 | if Is_Access_Type (U_Ent) then | |
1607 | if Present (Associated_Storage_Pool (U_Ent)) then | |
1608 | Error_Msg_N ("storage pool already given for &", Nam); | |
1609 | return; | |
1610 | end if; | |
1611 | ||
1612 | if Compile_Time_Known_Value (Expr) | |
1613 | and then Expr_Value (Expr) = 0 | |
1614 | then | |
1615 | Set_No_Pool_Assigned (Btype); | |
1616 | end if; | |
1617 | ||
1618 | else -- Is_Task_Type (U_Ent) | |
1619 | Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); | |
1620 | ||
1621 | if Present (Sprag) then | |
1622 | Error_Msg_Sloc := Sloc (Sprag); | |
1623 | Error_Msg_N | |
1624 | ("Storage_Size already specified#", Nam); | |
1625 | return; | |
1626 | end if; | |
1627 | end if; | |
1628 | ||
1629 | Set_Has_Storage_Size_Clause (Btype); | |
1630 | end if; | |
1631 | end Storage_Size; | |
1632 | ||
7189d17f | 1633 | ----------------- |
1634 | -- Stream_Size -- | |
1635 | ----------------- | |
1636 | ||
1637 | when Attribute_Stream_Size => Stream_Size : declare | |
1638 | Size : constant Uint := Static_Integer (Expr); | |
1639 | ||
1640 | begin | |
15ebb600 | 1641 | if Ada_Version <= Ada_95 then |
1642 | Check_Restriction (No_Implementation_Attributes, N); | |
1643 | end if; | |
1644 | ||
7189d17f | 1645 | if Has_Stream_Size_Clause (U_Ent) then |
1646 | Error_Msg_N ("Stream_Size already given for &", Nam); | |
1647 | ||
1648 | elsif Is_Elementary_Type (U_Ent) then | |
1649 | if Size /= System_Storage_Unit | |
1650 | and then | |
1651 | Size /= System_Storage_Unit * 2 | |
1652 | and then | |
1653 | Size /= System_Storage_Unit * 4 | |
1654 | and then | |
1655 | Size /= System_Storage_Unit * 8 | |
1656 | then | |
1657 | Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); | |
1658 | Error_Msg_N | |
1659 | ("stream size for elementary type must be a" | |
1660 | & " power of 2 and at least ^", N); | |
1661 | ||
1662 | elsif RM_Size (U_Ent) > Size then | |
1663 | Error_Msg_Uint_1 := RM_Size (U_Ent); | |
1664 | Error_Msg_N | |
1665 | ("stream size for elementary type must be a" | |
1666 | & " power of 2 and at least ^", N); | |
1667 | end if; | |
1668 | ||
1669 | Set_Has_Stream_Size_Clause (U_Ent); | |
1670 | ||
1671 | else | |
1672 | Error_Msg_N ("Stream_Size cannot be given for &", Nam); | |
1673 | end if; | |
1674 | end Stream_Size; | |
1675 | ||
d6f39728 | 1676 | ---------------- |
1677 | -- Value_Size -- | |
1678 | ---------------- | |
1679 | ||
1680 | -- Value_Size attribute definition clause | |
1681 | ||
1682 | when Attribute_Value_Size => Value_Size : declare | |
1683 | Size : constant Uint := Static_Integer (Expr); | |
1684 | Biased : Boolean; | |
1685 | ||
1686 | begin | |
1687 | if not Is_Type (U_Ent) then | |
1688 | Error_Msg_N ("Value_Size cannot be given for &", Nam); | |
1689 | ||
1690 | elsif Present | |
1691 | (Get_Attribute_Definition_Clause | |
1692 | (U_Ent, Attribute_Value_Size)) | |
1693 | then | |
1694 | Error_Msg_N ("Value_Size already given for &", Nam); | |
1695 | ||
59ac57b5 | 1696 | elsif Is_Array_Type (U_Ent) |
1697 | and then not Is_Constrained (U_Ent) | |
1698 | then | |
1699 | Error_Msg_N | |
1700 | ("Value_Size cannot be given for unconstrained array", Nam); | |
1701 | ||
d6f39728 | 1702 | else |
1703 | if Is_Elementary_Type (U_Ent) then | |
1704 | Check_Size (Expr, U_Ent, Size, Biased); | |
1705 | Set_Has_Biased_Representation (U_Ent, Biased); | |
1706 | end if; | |
1707 | ||
1708 | Set_RM_Size (U_Ent, Size); | |
1709 | end if; | |
1710 | end Value_Size; | |
1711 | ||
1712 | ----------- | |
1713 | -- Write -- | |
1714 | ----------- | |
1715 | ||
9f373bb8 | 1716 | when Attribute_Write => |
1717 | Analyze_Stream_TSS_Definition (TSS_Stream_Write); | |
1718 | Set_Has_Specified_Stream_Write (Ent); | |
d6f39728 | 1719 | |
1720 | -- All other attributes cannot be set | |
1721 | ||
1722 | when others => | |
1723 | Error_Msg_N | |
1724 | ("attribute& cannot be set with definition clause", N); | |
d6f39728 | 1725 | end case; |
1726 | ||
1727 | -- The test for the type being frozen must be performed after | |
1728 | -- any expression the clause has been analyzed since the expression | |
1729 | -- itself might cause freezing that makes the clause illegal. | |
1730 | ||
1731 | if Rep_Item_Too_Late (U_Ent, N, FOnly) then | |
1732 | return; | |
1733 | end if; | |
1734 | end Analyze_Attribute_Definition_Clause; | |
1735 | ||
1736 | ---------------------------- | |
1737 | -- Analyze_Code_Statement -- | |
1738 | ---------------------------- | |
1739 | ||
1740 | procedure Analyze_Code_Statement (N : Node_Id) is | |
1741 | HSS : constant Node_Id := Parent (N); | |
1742 | SBody : constant Node_Id := Parent (HSS); | |
1743 | Subp : constant Entity_Id := Current_Scope; | |
1744 | Stmt : Node_Id; | |
1745 | Decl : Node_Id; | |
1746 | StmtO : Node_Id; | |
1747 | DeclO : Node_Id; | |
1748 | ||
1749 | begin | |
1750 | -- Analyze and check we get right type, note that this implements the | |
1751 | -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that | |
1752 | -- is the only way that Asm_Insn could possibly be visible. | |
1753 | ||
1754 | Analyze_And_Resolve (Expression (N)); | |
1755 | ||
1756 | if Etype (Expression (N)) = Any_Type then | |
1757 | return; | |
1758 | elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then | |
1759 | Error_Msg_N ("incorrect type for code statement", N); | |
1760 | return; | |
1761 | end if; | |
1762 | ||
44e4341e | 1763 | Check_Code_Statement (N); |
1764 | ||
d6f39728 | 1765 | -- Make sure we appear in the handled statement sequence of a |
1766 | -- subprogram (RM 13.8(3)). | |
1767 | ||
1768 | if Nkind (HSS) /= N_Handled_Sequence_Of_Statements | |
1769 | or else Nkind (SBody) /= N_Subprogram_Body | |
1770 | then | |
1771 | Error_Msg_N | |
1772 | ("code statement can only appear in body of subprogram", N); | |
1773 | return; | |
1774 | end if; | |
1775 | ||
1776 | -- Do remaining checks (RM 13.8(3)) if not already done | |
1777 | ||
1778 | if not Is_Machine_Code_Subprogram (Subp) then | |
1779 | Set_Is_Machine_Code_Subprogram (Subp); | |
1780 | ||
1781 | -- No exception handlers allowed | |
1782 | ||
1783 | if Present (Exception_Handlers (HSS)) then | |
1784 | Error_Msg_N | |
1785 | ("exception handlers not permitted in machine code subprogram", | |
1786 | First (Exception_Handlers (HSS))); | |
1787 | end if; | |
1788 | ||
1789 | -- No declarations other than use clauses and pragmas (we allow | |
1790 | -- certain internally generated declarations as well). | |
1791 | ||
1792 | Decl := First (Declarations (SBody)); | |
1793 | while Present (Decl) loop | |
1794 | DeclO := Original_Node (Decl); | |
1795 | if Comes_From_Source (DeclO) | |
fdd294d1 | 1796 | and not Nkind_In (DeclO, N_Pragma, |
1797 | N_Use_Package_Clause, | |
1798 | N_Use_Type_Clause, | |
1799 | N_Implicit_Label_Declaration) | |
d6f39728 | 1800 | then |
1801 | Error_Msg_N | |
1802 | ("this declaration not allowed in machine code subprogram", | |
1803 | DeclO); | |
1804 | end if; | |
1805 | ||
1806 | Next (Decl); | |
1807 | end loop; | |
1808 | ||
1809 | -- No statements other than code statements, pragmas, and labels. | |
1810 | -- Again we allow certain internally generated statements. | |
1811 | ||
1812 | Stmt := First (Statements (HSS)); | |
1813 | while Present (Stmt) loop | |
1814 | StmtO := Original_Node (Stmt); | |
1815 | if Comes_From_Source (StmtO) | |
fdd294d1 | 1816 | and then not Nkind_In (StmtO, N_Pragma, |
1817 | N_Label, | |
1818 | N_Code_Statement) | |
d6f39728 | 1819 | then |
1820 | Error_Msg_N | |
1821 | ("this statement is not allowed in machine code subprogram", | |
1822 | StmtO); | |
1823 | end if; | |
1824 | ||
1825 | Next (Stmt); | |
1826 | end loop; | |
1827 | end if; | |
d6f39728 | 1828 | end Analyze_Code_Statement; |
1829 | ||
1830 | ----------------------------------------------- | |
1831 | -- Analyze_Enumeration_Representation_Clause -- | |
1832 | ----------------------------------------------- | |
1833 | ||
1834 | procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is | |
1835 | Ident : constant Node_Id := Identifier (N); | |
1836 | Aggr : constant Node_Id := Array_Aggregate (N); | |
1837 | Enumtype : Entity_Id; | |
1838 | Elit : Entity_Id; | |
1839 | Expr : Node_Id; | |
1840 | Assoc : Node_Id; | |
1841 | Choice : Node_Id; | |
1842 | Val : Uint; | |
1843 | Err : Boolean := False; | |
1844 | ||
1845 | Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); | |
1846 | Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); | |
1847 | Min : Uint; | |
1848 | Max : Uint; | |
1849 | ||
1850 | begin | |
fbc67f84 | 1851 | if Ignore_Rep_Clauses then |
1852 | return; | |
1853 | end if; | |
1854 | ||
d6f39728 | 1855 | -- First some basic error checks |
1856 | ||
1857 | Find_Type (Ident); | |
1858 | Enumtype := Entity (Ident); | |
1859 | ||
1860 | if Enumtype = Any_Type | |
1861 | or else Rep_Item_Too_Early (Enumtype, N) | |
1862 | then | |
1863 | return; | |
1864 | else | |
1865 | Enumtype := Underlying_Type (Enumtype); | |
1866 | end if; | |
1867 | ||
1868 | if not Is_Enumeration_Type (Enumtype) then | |
1869 | Error_Msg_NE | |
1870 | ("enumeration type required, found}", | |
1871 | Ident, First_Subtype (Enumtype)); | |
1872 | return; | |
1873 | end if; | |
1874 | ||
9dfe12ae | 1875 | -- Ignore rep clause on generic actual type. This will already have |
1876 | -- been flagged on the template as an error, and this is the safest | |
1877 | -- way to ensure we don't get a junk cascaded message in the instance. | |
1878 | ||
1879 | if Is_Generic_Actual_Type (Enumtype) then | |
1880 | return; | |
1881 | ||
1882 | -- Type must be in current scope | |
1883 | ||
1884 | elsif Scope (Enumtype) /= Current_Scope then | |
d6f39728 | 1885 | Error_Msg_N ("type must be declared in this scope", Ident); |
1886 | return; | |
1887 | ||
9dfe12ae | 1888 | -- Type must be a first subtype |
1889 | ||
d6f39728 | 1890 | elsif not Is_First_Subtype (Enumtype) then |
1891 | Error_Msg_N ("cannot give enumeration rep clause for subtype", N); | |
1892 | return; | |
1893 | ||
9dfe12ae | 1894 | -- Ignore duplicate rep clause |
1895 | ||
d6f39728 | 1896 | elsif Has_Enumeration_Rep_Clause (Enumtype) then |
1897 | Error_Msg_N ("duplicate enumeration rep clause ignored", N); | |
1898 | return; | |
1899 | ||
7189d17f | 1900 | -- Don't allow rep clause for standard [wide_[wide_]]character |
9dfe12ae | 1901 | |
177675a7 | 1902 | elsif Is_Standard_Character_Type (Enumtype) then |
d6f39728 | 1903 | Error_Msg_N ("enumeration rep clause not allowed for this type", N); |
9dfe12ae | 1904 | return; |
1905 | ||
d9125581 | 1906 | -- Check that the expression is a proper aggregate (no parentheses) |
1907 | ||
1908 | elsif Paren_Count (Aggr) /= 0 then | |
1909 | Error_Msg | |
1910 | ("extra parentheses surrounding aggregate not allowed", | |
1911 | First_Sloc (Aggr)); | |
1912 | return; | |
1913 | ||
9dfe12ae | 1914 | -- All tests passed, so set rep clause in place |
d6f39728 | 1915 | |
1916 | else | |
1917 | Set_Has_Enumeration_Rep_Clause (Enumtype); | |
1918 | Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); | |
1919 | end if; | |
1920 | ||
1921 | -- Now we process the aggregate. Note that we don't use the normal | |
1922 | -- aggregate code for this purpose, because we don't want any of the | |
1923 | -- normal expansion activities, and a number of special semantic | |
1924 | -- rules apply (including the component type being any integer type) | |
1925 | ||
d6f39728 | 1926 | Elit := First_Literal (Enumtype); |
1927 | ||
1928 | -- First the positional entries if any | |
1929 | ||
1930 | if Present (Expressions (Aggr)) then | |
1931 | Expr := First (Expressions (Aggr)); | |
1932 | while Present (Expr) loop | |
1933 | if No (Elit) then | |
1934 | Error_Msg_N ("too many entries in aggregate", Expr); | |
1935 | return; | |
1936 | end if; | |
1937 | ||
1938 | Val := Static_Integer (Expr); | |
1939 | ||
d9125581 | 1940 | -- Err signals that we found some incorrect entries processing |
1941 | -- the list. The final checks for completeness and ordering are | |
1942 | -- skipped in this case. | |
1943 | ||
d6f39728 | 1944 | if Val = No_Uint then |
1945 | Err := True; | |
d6f39728 | 1946 | elsif Val < Lo or else Hi < Val then |
1947 | Error_Msg_N ("value outside permitted range", Expr); | |
1948 | Err := True; | |
1949 | end if; | |
1950 | ||
1951 | Set_Enumeration_Rep (Elit, Val); | |
1952 | Set_Enumeration_Rep_Expr (Elit, Expr); | |
1953 | Next (Expr); | |
1954 | Next (Elit); | |
1955 | end loop; | |
1956 | end if; | |
1957 | ||
1958 | -- Now process the named entries if present | |
1959 | ||
1960 | if Present (Component_Associations (Aggr)) then | |
1961 | Assoc := First (Component_Associations (Aggr)); | |
1962 | while Present (Assoc) loop | |
1963 | Choice := First (Choices (Assoc)); | |
1964 | ||
1965 | if Present (Next (Choice)) then | |
1966 | Error_Msg_N | |
1967 | ("multiple choice not allowed here", Next (Choice)); | |
1968 | Err := True; | |
1969 | end if; | |
1970 | ||
1971 | if Nkind (Choice) = N_Others_Choice then | |
1972 | Error_Msg_N ("others choice not allowed here", Choice); | |
1973 | Err := True; | |
1974 | ||
1975 | elsif Nkind (Choice) = N_Range then | |
1976 | -- ??? should allow zero/one element range here | |
1977 | Error_Msg_N ("range not allowed here", Choice); | |
1978 | Err := True; | |
1979 | ||
1980 | else | |
1981 | Analyze_And_Resolve (Choice, Enumtype); | |
1982 | ||
1983 | if Is_Entity_Name (Choice) | |
1984 | and then Is_Type (Entity (Choice)) | |
1985 | then | |
1986 | Error_Msg_N ("subtype name not allowed here", Choice); | |
1987 | Err := True; | |
1988 | -- ??? should allow static subtype with zero/one entry | |
1989 | ||
1990 | elsif Etype (Choice) = Base_Type (Enumtype) then | |
1991 | if not Is_Static_Expression (Choice) then | |
9dfe12ae | 1992 | Flag_Non_Static_Expr |
1993 | ("non-static expression used for choice!", Choice); | |
d6f39728 | 1994 | Err := True; |
1995 | ||
1996 | else | |
1997 | Elit := Expr_Value_E (Choice); | |
1998 | ||
1999 | if Present (Enumeration_Rep_Expr (Elit)) then | |
2000 | Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); | |
2001 | Error_Msg_NE | |
2002 | ("representation for& previously given#", | |
2003 | Choice, Elit); | |
2004 | Err := True; | |
2005 | end if; | |
2006 | ||
2007 | Set_Enumeration_Rep_Expr (Elit, Choice); | |
2008 | ||
2009 | Expr := Expression (Assoc); | |
2010 | Val := Static_Integer (Expr); | |
2011 | ||
2012 | if Val = No_Uint then | |
2013 | Err := True; | |
2014 | ||
2015 | elsif Val < Lo or else Hi < Val then | |
2016 | Error_Msg_N ("value outside permitted range", Expr); | |
2017 | Err := True; | |
2018 | end if; | |
2019 | ||
2020 | Set_Enumeration_Rep (Elit, Val); | |
2021 | end if; | |
2022 | end if; | |
2023 | end if; | |
2024 | ||
2025 | Next (Assoc); | |
2026 | end loop; | |
2027 | end if; | |
2028 | ||
2029 | -- Aggregate is fully processed. Now we check that a full set of | |
2030 | -- representations was given, and that they are in range and in order. | |
2031 | -- These checks are only done if no other errors occurred. | |
2032 | ||
2033 | if not Err then | |
2034 | Min := No_Uint; | |
2035 | Max := No_Uint; | |
2036 | ||
2037 | Elit := First_Literal (Enumtype); | |
2038 | while Present (Elit) loop | |
2039 | if No (Enumeration_Rep_Expr (Elit)) then | |
2040 | Error_Msg_NE ("missing representation for&!", N, Elit); | |
2041 | ||
2042 | else | |
2043 | Val := Enumeration_Rep (Elit); | |
2044 | ||
2045 | if Min = No_Uint then | |
2046 | Min := Val; | |
2047 | end if; | |
2048 | ||
2049 | if Val /= No_Uint then | |
2050 | if Max /= No_Uint and then Val <= Max then | |
2051 | Error_Msg_NE | |
2052 | ("enumeration value for& not ordered!", | |
2053 | Enumeration_Rep_Expr (Elit), Elit); | |
2054 | end if; | |
2055 | ||
2056 | Max := Val; | |
2057 | end if; | |
2058 | ||
2059 | -- If there is at least one literal whose representation | |
2060 | -- is not equal to the Pos value, then note that this | |
2061 | -- enumeration type has a non-standard representation. | |
2062 | ||
2063 | if Val /= Enumeration_Pos (Elit) then | |
2064 | Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); | |
2065 | end if; | |
2066 | end if; | |
2067 | ||
2068 | Next (Elit); | |
2069 | end loop; | |
2070 | ||
2071 | -- Now set proper size information | |
2072 | ||
2073 | declare | |
2074 | Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); | |
2075 | ||
2076 | begin | |
2077 | if Has_Size_Clause (Enumtype) then | |
2078 | if Esize (Enumtype) >= Minsize then | |
2079 | null; | |
2080 | ||
2081 | else | |
2082 | Minsize := | |
2083 | UI_From_Int (Minimum_Size (Enumtype, Biased => True)); | |
2084 | ||
2085 | if Esize (Enumtype) < Minsize then | |
2086 | Error_Msg_N ("previously given size is too small", N); | |
2087 | ||
2088 | else | |
2089 | Set_Has_Biased_Representation (Enumtype); | |
2090 | end if; | |
2091 | end if; | |
2092 | ||
2093 | else | |
2094 | Set_RM_Size (Enumtype, Minsize); | |
2095 | Set_Enum_Esize (Enumtype); | |
2096 | end if; | |
2097 | ||
2098 | Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); | |
2099 | Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); | |
2100 | Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); | |
2101 | end; | |
2102 | end if; | |
2103 | ||
2104 | -- We repeat the too late test in case it froze itself! | |
2105 | ||
2106 | if Rep_Item_Too_Late (Enumtype, N) then | |
2107 | null; | |
2108 | end if; | |
d6f39728 | 2109 | end Analyze_Enumeration_Representation_Clause; |
2110 | ||
2111 | ---------------------------- | |
2112 | -- Analyze_Free_Statement -- | |
2113 | ---------------------------- | |
2114 | ||
2115 | procedure Analyze_Free_Statement (N : Node_Id) is | |
2116 | begin | |
2117 | Analyze (Expression (N)); | |
2118 | end Analyze_Free_Statement; | |
2119 | ||
2120 | ------------------------------------------ | |
2121 | -- Analyze_Record_Representation_Clause -- | |
2122 | ------------------------------------------ | |
2123 | ||
2124 | procedure Analyze_Record_Representation_Clause (N : Node_Id) is | |
2125 | Loc : constant Source_Ptr := Sloc (N); | |
2126 | Ident : constant Node_Id := Identifier (N); | |
2127 | Rectype : Entity_Id; | |
2128 | Fent : Entity_Id; | |
2129 | CC : Node_Id; | |
2130 | Posit : Uint; | |
2131 | Fbit : Uint; | |
2132 | Lbit : Uint; | |
2133 | Hbit : Uint := Uint_0; | |
2134 | Comp : Entity_Id; | |
2135 | Ocomp : Entity_Id; | |
2136 | Biased : Boolean; | |
2137 | ||
2138 | Max_Bit_So_Far : Uint; | |
ea61a7ea | 2139 | -- Records the maximum bit position so far. If all field positions |
d6f39728 | 2140 | -- are monotonically increasing, then we can skip the circuit for |
2141 | -- checking for overlap, since no overlap is possible. | |
2142 | ||
2143 | Overlap_Check_Required : Boolean; | |
2144 | -- Used to keep track of whether or not an overlap check is required | |
2145 | ||
2146 | Ccount : Natural := 0; | |
2147 | -- Number of component clauses in record rep clause | |
2148 | ||
639e37b0 | 2149 | CR_Pragma : Node_Id := Empty; |
2150 | -- Points to N_Pragma node if Complete_Representation pragma present | |
2151 | ||
d6f39728 | 2152 | begin |
fbc67f84 | 2153 | if Ignore_Rep_Clauses then |
2154 | return; | |
2155 | end if; | |
2156 | ||
d6f39728 | 2157 | Find_Type (Ident); |
2158 | Rectype := Entity (Ident); | |
2159 | ||
2160 | if Rectype = Any_Type | |
2161 | or else Rep_Item_Too_Early (Rectype, N) | |
2162 | then | |
2163 | return; | |
2164 | else | |
2165 | Rectype := Underlying_Type (Rectype); | |
2166 | end if; | |
2167 | ||
2168 | -- First some basic error checks | |
2169 | ||
2170 | if not Is_Record_Type (Rectype) then | |
2171 | Error_Msg_NE | |
2172 | ("record type required, found}", Ident, First_Subtype (Rectype)); | |
2173 | return; | |
2174 | ||
2175 | elsif Is_Unchecked_Union (Rectype) then | |
2176 | Error_Msg_N | |
2177 | ("record rep clause not allowed for Unchecked_Union", N); | |
2178 | ||
2179 | elsif Scope (Rectype) /= Current_Scope then | |
2180 | Error_Msg_N ("type must be declared in this scope", N); | |
2181 | return; | |
2182 | ||
2183 | elsif not Is_First_Subtype (Rectype) then | |
2184 | Error_Msg_N ("cannot give record rep clause for subtype", N); | |
2185 | return; | |
2186 | ||
2187 | elsif Has_Record_Rep_Clause (Rectype) then | |
2188 | Error_Msg_N ("duplicate record rep clause ignored", N); | |
2189 | return; | |
2190 | ||
2191 | elsif Rep_Item_Too_Late (Rectype, N) then | |
2192 | return; | |
2193 | end if; | |
2194 | ||
2195 | if Present (Mod_Clause (N)) then | |
2196 | declare | |
2197 | Loc : constant Source_Ptr := Sloc (N); | |
2198 | M : constant Node_Id := Mod_Clause (N); | |
2199 | P : constant List_Id := Pragmas_Before (M); | |
d6f39728 | 2200 | AtM_Nod : Node_Id; |
2201 | ||
9dfe12ae | 2202 | Mod_Val : Uint; |
2203 | pragma Warnings (Off, Mod_Val); | |
2204 | ||
d6f39728 | 2205 | begin |
e0521a36 | 2206 | Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); |
2207 | ||
9dfe12ae | 2208 | if Warn_On_Obsolescent_Feature then |
2209 | Error_Msg_N | |
fbc67f84 | 2210 | ("mod clause is an obsolescent feature (RM J.8)?", N); |
9dfe12ae | 2211 | Error_Msg_N |
d53a018a | 2212 | ("\use alignment attribute definition clause instead?", N); |
9dfe12ae | 2213 | end if; |
2214 | ||
d6f39728 | 2215 | if Present (P) then |
2216 | Analyze_List (P); | |
2217 | end if; | |
2218 | ||
fbc67f84 | 2219 | -- In ASIS_Mode mode, expansion is disabled, but we must convert |
2220 | -- the Mod clause into an alignment clause anyway, so that the | |
2221 | -- back-end can compute and back-annotate properly the size and | |
2222 | -- alignment of types that may include this record. | |
d6f39728 | 2223 | |
15ebb600 | 2224 | -- This seems dubious, this destroys the source tree in a manner |
2225 | -- not detectable by ASIS ??? | |
2226 | ||
d6f39728 | 2227 | if Operating_Mode = Check_Semantics |
9dfe12ae | 2228 | and then ASIS_Mode |
d6f39728 | 2229 | then |
2230 | AtM_Nod := | |
2231 | Make_Attribute_Definition_Clause (Loc, | |
2232 | Name => New_Reference_To (Base_Type (Rectype), Loc), | |
2233 | Chars => Name_Alignment, | |
2234 | Expression => Relocate_Node (Expression (M))); | |
2235 | ||
2236 | Set_From_At_Mod (AtM_Nod); | |
2237 | Insert_After (N, AtM_Nod); | |
2238 | Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); | |
2239 | Set_Mod_Clause (N, Empty); | |
2240 | ||
2241 | else | |
2242 | -- Get the alignment value to perform error checking | |
2243 | ||
2244 | Mod_Val := Get_Alignment_Value (Expression (M)); | |
2245 | ||
2246 | end if; | |
2247 | end; | |
2248 | end if; | |
2249 | ||
3062c401 | 2250 | -- For untagged types, clear any existing component clauses for the |
2251 | -- type. If the type is derived, this is what allows us to override | |
2252 | -- a rep clause for the parent. For type extensions, the representation | |
2253 | -- of the inherited components is inherited, so we want to keep previous | |
2254 | -- component clauses for completeness. | |
d6f39728 | 2255 | |
3062c401 | 2256 | if not Is_Tagged_Type (Rectype) then |
2257 | Comp := First_Component_Or_Discriminant (Rectype); | |
2258 | while Present (Comp) loop | |
2259 | Set_Component_Clause (Comp, Empty); | |
2260 | Next_Component_Or_Discriminant (Comp); | |
2261 | end loop; | |
2262 | end if; | |
d6f39728 | 2263 | |
2264 | -- All done if no component clauses | |
2265 | ||
2266 | CC := First (Component_Clauses (N)); | |
2267 | ||
2268 | if No (CC) then | |
2269 | return; | |
2270 | end if; | |
2271 | ||
15ebb600 | 2272 | -- If a tag is present, then create a component clause that places it |
2273 | -- at the start of the record (otherwise gigi may place it after other | |
2274 | -- fields that have rep clauses). | |
d6f39728 | 2275 | |
59ac57b5 | 2276 | Fent := First_Entity (Rectype); |
2277 | ||
d6f39728 | 2278 | if Nkind (Fent) = N_Defining_Identifier |
2279 | and then Chars (Fent) = Name_uTag | |
2280 | then | |
2281 | Set_Component_Bit_Offset (Fent, Uint_0); | |
2282 | Set_Normalized_Position (Fent, Uint_0); | |
2283 | Set_Normalized_First_Bit (Fent, Uint_0); | |
2284 | Set_Normalized_Position_Max (Fent, Uint_0); | |
2285 | Init_Esize (Fent, System_Address_Size); | |
2286 | ||
2287 | Set_Component_Clause (Fent, | |
2288 | Make_Component_Clause (Loc, | |
2289 | Component_Name => | |
2290 | Make_Identifier (Loc, | |
2291 | Chars => Name_uTag), | |
2292 | ||
2293 | Position => | |
2294 | Make_Integer_Literal (Loc, | |
2295 | Intval => Uint_0), | |
2296 | ||
2297 | First_Bit => | |
2298 | Make_Integer_Literal (Loc, | |
2299 | Intval => Uint_0), | |
2300 | ||
2301 | Last_Bit => | |
2302 | Make_Integer_Literal (Loc, | |
2303 | UI_From_Int (System_Address_Size)))); | |
2304 | ||
2305 | Ccount := Ccount + 1; | |
2306 | end if; | |
2307 | ||
f15731c4 | 2308 | -- A representation like this applies to the base type |
d6f39728 | 2309 | |
2310 | Set_Has_Record_Rep_Clause (Base_Type (Rectype)); | |
2311 | Set_Has_Non_Standard_Rep (Base_Type (Rectype)); | |
2312 | Set_Has_Specified_Layout (Base_Type (Rectype)); | |
2313 | ||
2314 | Max_Bit_So_Far := Uint_Minus_1; | |
2315 | Overlap_Check_Required := False; | |
2316 | ||
2317 | -- Process the component clauses | |
2318 | ||
2319 | while Present (CC) loop | |
2320 | ||
639e37b0 | 2321 | -- Pragma |
d6f39728 | 2322 | |
2323 | if Nkind (CC) = N_Pragma then | |
2324 | Analyze (CC); | |
2325 | ||
639e37b0 | 2326 | -- The only pragma of interest is Complete_Representation |
2327 | ||
fdd294d1 | 2328 | if Pragma_Name (CC) = Name_Complete_Representation then |
639e37b0 | 2329 | CR_Pragma := CC; |
2330 | end if; | |
2331 | ||
d6f39728 | 2332 | -- Processing for real component clause |
2333 | ||
2334 | else | |
2335 | Ccount := Ccount + 1; | |
2336 | Posit := Static_Integer (Position (CC)); | |
2337 | Fbit := Static_Integer (First_Bit (CC)); | |
2338 | Lbit := Static_Integer (Last_Bit (CC)); | |
2339 | ||
2340 | if Posit /= No_Uint | |
2341 | and then Fbit /= No_Uint | |
2342 | and then Lbit /= No_Uint | |
2343 | then | |
2344 | if Posit < 0 then | |
2345 | Error_Msg_N | |
2346 | ("position cannot be negative", Position (CC)); | |
2347 | ||
2348 | elsif Fbit < 0 then | |
2349 | Error_Msg_N | |
2350 | ("first bit cannot be negative", First_Bit (CC)); | |
2351 | ||
177675a7 | 2352 | -- The Last_Bit specified in a component clause must not be |
2353 | -- less than the First_Bit minus one (RM-13.5.1(10)). | |
2354 | ||
2355 | elsif Lbit < Fbit - 1 then | |
2356 | Error_Msg_N | |
2357 | ("last bit cannot be less than first bit minus one", | |
2358 | Last_Bit (CC)); | |
2359 | ||
d6f39728 | 2360 | -- Values look OK, so find the corresponding record component |
2361 | -- Even though the syntax allows an attribute reference for | |
2362 | -- implementation-defined components, GNAT does not allow the | |
2363 | -- tag to get an explicit position. | |
2364 | ||
2365 | elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then | |
d6f39728 | 2366 | if Attribute_Name (Component_Name (CC)) = Name_Tag then |
2367 | Error_Msg_N ("position of tag cannot be specified", CC); | |
2368 | else | |
2369 | Error_Msg_N ("illegal component name", CC); | |
2370 | end if; | |
2371 | ||
2372 | else | |
2373 | Comp := First_Entity (Rectype); | |
2374 | while Present (Comp) loop | |
2375 | exit when Chars (Comp) = Chars (Component_Name (CC)); | |
2376 | Next_Entity (Comp); | |
2377 | end loop; | |
2378 | ||
2379 | if No (Comp) then | |
2380 | ||
2381 | -- Maybe component of base type that is absent from | |
2382 | -- statically constrained first subtype. | |
2383 | ||
2384 | Comp := First_Entity (Base_Type (Rectype)); | |
2385 | while Present (Comp) loop | |
2386 | exit when Chars (Comp) = Chars (Component_Name (CC)); | |
2387 | Next_Entity (Comp); | |
2388 | end loop; | |
2389 | end if; | |
2390 | ||
2391 | if No (Comp) then | |
2392 | Error_Msg_N | |
2393 | ("component clause is for non-existent field", CC); | |
2394 | ||
2395 | elsif Present (Component_Clause (Comp)) then | |
3062c401 | 2396 | |
1a34e48c | 2397 | -- Diagnose duplicate rep clause, or check consistency |
fdd294d1 | 2398 | -- if this is an inherited component. In a double fault, |
3062c401 | 2399 | -- there may be a duplicate inconsistent clause for an |
2400 | -- inherited component. | |
2401 | ||
fdd294d1 | 2402 | if Scope (Original_Record_Component (Comp)) = Rectype |
2403 | or else Parent (Component_Clause (Comp)) = N | |
3062c401 | 2404 | then |
2405 | Error_Msg_Sloc := Sloc (Component_Clause (Comp)); | |
2406 | Error_Msg_N ("component clause previously given#", CC); | |
2407 | ||
2408 | else | |
2409 | declare | |
2410 | Rep1 : constant Node_Id := Component_Clause (Comp); | |
3062c401 | 2411 | begin |
2412 | if Intval (Position (Rep1)) /= | |
2413 | Intval (Position (CC)) | |
2414 | or else Intval (First_Bit (Rep1)) /= | |
2415 | Intval (First_Bit (CC)) | |
2416 | or else Intval (Last_Bit (Rep1)) /= | |
2417 | Intval (Last_Bit (CC)) | |
2418 | then | |
2419 | Error_Msg_N ("component clause inconsistent " | |
2420 | & "with representation of ancestor", CC); | |
3062c401 | 2421 | elsif Warn_On_Redundant_Constructs then |
2422 | Error_Msg_N ("?redundant component clause " | |
2423 | & "for inherited component!", CC); | |
2424 | end if; | |
2425 | end; | |
2426 | end if; | |
d6f39728 | 2427 | |
2428 | else | |
83f8f0a6 | 2429 | -- Make reference for field in record rep clause and set |
2430 | -- appropriate entity field in the field identifier. | |
2431 | ||
2432 | Generate_Reference | |
2433 | (Comp, Component_Name (CC), Set_Ref => False); | |
2434 | Set_Entity (Component_Name (CC), Comp); | |
2435 | ||
2866d595 | 2436 | -- Update Fbit and Lbit to the actual bit number |
d6f39728 | 2437 | |
2438 | Fbit := Fbit + UI_From_Int (SSU) * Posit; | |
2439 | Lbit := Lbit + UI_From_Int (SSU) * Posit; | |
2440 | ||
2441 | if Fbit <= Max_Bit_So_Far then | |
2442 | Overlap_Check_Required := True; | |
2443 | else | |
2444 | Max_Bit_So_Far := Lbit; | |
2445 | end if; | |
2446 | ||
2447 | if Has_Size_Clause (Rectype) | |
2448 | and then Esize (Rectype) <= Lbit | |
2449 | then | |
2450 | Error_Msg_N | |
2451 | ("bit number out of range of specified size", | |
2452 | Last_Bit (CC)); | |
2453 | else | |
2454 | Set_Component_Clause (Comp, CC); | |
2455 | Set_Component_Bit_Offset (Comp, Fbit); | |
2456 | Set_Esize (Comp, 1 + (Lbit - Fbit)); | |
2457 | Set_Normalized_First_Bit (Comp, Fbit mod SSU); | |
2458 | Set_Normalized_Position (Comp, Fbit / SSU); | |
2459 | ||
2460 | Set_Normalized_Position_Max | |
2461 | (Fent, Normalized_Position (Fent)); | |
2462 | ||
2463 | if Is_Tagged_Type (Rectype) | |
2464 | and then Fbit < System_Address_Size | |
2465 | then | |
2466 | Error_Msg_NE | |
2467 | ("component overlaps tag field of&", | |
2468 | CC, Rectype); | |
2469 | end if; | |
2470 | ||
ea61a7ea | 2471 | -- This information is also set in the corresponding |
2472 | -- component of the base type, found by accessing the | |
2473 | -- Original_Record_Component link if it is present. | |
d6f39728 | 2474 | |
2475 | Ocomp := Original_Record_Component (Comp); | |
2476 | ||
2477 | if Hbit < Lbit then | |
2478 | Hbit := Lbit; | |
2479 | end if; | |
2480 | ||
2481 | Check_Size | |
2482 | (Component_Name (CC), | |
2483 | Etype (Comp), | |
2484 | Esize (Comp), | |
2485 | Biased); | |
2486 | ||
2487 | Set_Has_Biased_Representation (Comp, Biased); | |
2488 | ||
2489 | if Present (Ocomp) then | |
2490 | Set_Component_Clause (Ocomp, CC); | |
2491 | Set_Component_Bit_Offset (Ocomp, Fbit); | |
2492 | Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); | |
2493 | Set_Normalized_Position (Ocomp, Fbit / SSU); | |
2494 | Set_Esize (Ocomp, 1 + (Lbit - Fbit)); | |
2495 | ||
2496 | Set_Normalized_Position_Max | |
2497 | (Ocomp, Normalized_Position (Ocomp)); | |
2498 | ||
2499 | Set_Has_Biased_Representation | |
2500 | (Ocomp, Has_Biased_Representation (Comp)); | |
2501 | end if; | |
2502 | ||
2503 | if Esize (Comp) < 0 then | |
2504 | Error_Msg_N ("component size is negative", CC); | |
2505 | end if; | |
2506 | end if; | |
2507 | end if; | |
2508 | end if; | |
2509 | end if; | |
2510 | end if; | |
2511 | ||
2512 | Next (CC); | |
2513 | end loop; | |
2514 | ||
2515 | -- Now that we have processed all the component clauses, check for | |
fdd294d1 | 2516 | -- overlap. We have to leave this till last, since the components can |
2517 | -- appear in any arbitrary order in the representation clause. | |
d6f39728 | 2518 | |
2519 | -- We do not need this check if all specified ranges were monotonic, | |
2520 | -- as recorded by Overlap_Check_Required being False at this stage. | |
2521 | ||
fdd294d1 | 2522 | -- This first section checks if there are any overlapping entries at |
2523 | -- all. It does this by sorting all entries and then seeing if there are | |
2524 | -- any overlaps. If there are none, then that is decisive, but if there | |
2525 | -- are overlaps, they may still be OK (they may result from fields in | |
2526 | -- different variants). | |
d6f39728 | 2527 | |
2528 | if Overlap_Check_Required then | |
2529 | Overlap_Check1 : declare | |
2530 | ||
2531 | OC_Fbit : array (0 .. Ccount) of Uint; | |
fdd294d1 | 2532 | -- First-bit values for component clauses, the value is the offset |
2533 | -- of the first bit of the field from start of record. The zero | |
2534 | -- entry is for use in sorting. | |
d6f39728 | 2535 | |
2536 | OC_Lbit : array (0 .. Ccount) of Uint; | |
fdd294d1 | 2537 | -- Last-bit values for component clauses, the value is the offset |
2538 | -- of the last bit of the field from start of record. The zero | |
2539 | -- entry is for use in sorting. | |
d6f39728 | 2540 | |
2541 | OC_Count : Natural := 0; | |
2542 | -- Count of entries in OC_Fbit and OC_Lbit | |
2543 | ||
2544 | function OC_Lt (Op1, Op2 : Natural) return Boolean; | |
bfa5a9d9 | 2545 | -- Compare routine for Sort |
d6f39728 | 2546 | |
2547 | procedure OC_Move (From : Natural; To : Natural); | |
bfa5a9d9 | 2548 | -- Move routine for Sort |
2549 | ||
2550 | package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); | |
d6f39728 | 2551 | |
2552 | function OC_Lt (Op1, Op2 : Natural) return Boolean is | |
2553 | begin | |
2554 | return OC_Fbit (Op1) < OC_Fbit (Op2); | |
2555 | end OC_Lt; | |
2556 | ||
2557 | procedure OC_Move (From : Natural; To : Natural) is | |
2558 | begin | |
2559 | OC_Fbit (To) := OC_Fbit (From); | |
2560 | OC_Lbit (To) := OC_Lbit (From); | |
2561 | end OC_Move; | |
2562 | ||
2563 | begin | |
2564 | CC := First (Component_Clauses (N)); | |
2565 | while Present (CC) loop | |
2566 | if Nkind (CC) /= N_Pragma then | |
2567 | Posit := Static_Integer (Position (CC)); | |
2568 | Fbit := Static_Integer (First_Bit (CC)); | |
2569 | Lbit := Static_Integer (Last_Bit (CC)); | |
2570 | ||
2571 | if Posit /= No_Uint | |
2572 | and then Fbit /= No_Uint | |
2573 | and then Lbit /= No_Uint | |
2574 | then | |
2575 | OC_Count := OC_Count + 1; | |
2576 | Posit := Posit * SSU; | |
2577 | OC_Fbit (OC_Count) := Fbit + Posit; | |
2578 | OC_Lbit (OC_Count) := Lbit + Posit; | |
2579 | end if; | |
2580 | end if; | |
2581 | ||
2582 | Next (CC); | |
2583 | end loop; | |
2584 | ||
bfa5a9d9 | 2585 | Sorting.Sort (OC_Count); |
d6f39728 | 2586 | |
2587 | Overlap_Check_Required := False; | |
2588 | for J in 1 .. OC_Count - 1 loop | |
2589 | if OC_Lbit (J) >= OC_Fbit (J + 1) then | |
2590 | Overlap_Check_Required := True; | |
2591 | exit; | |
2592 | end if; | |
2593 | end loop; | |
2594 | end Overlap_Check1; | |
2595 | end if; | |
2596 | ||
fdd294d1 | 2597 | -- If Overlap_Check_Required is still True, then we have to do the full |
2598 | -- scale overlap check, since we have at least two fields that do | |
2599 | -- overlap, and we need to know if that is OK since they are in | |
2600 | -- different variant, or whether we have a definite problem. | |
d6f39728 | 2601 | |
2602 | if Overlap_Check_Required then | |
2603 | Overlap_Check2 : declare | |
2604 | C1_Ent, C2_Ent : Entity_Id; | |
2605 | -- Entities of components being checked for overlap | |
2606 | ||
2607 | Clist : Node_Id; | |
2608 | -- Component_List node whose Component_Items are being checked | |
2609 | ||
2610 | Citem : Node_Id; | |
2611 | -- Component declaration for component being checked | |
2612 | ||
2613 | begin | |
2614 | C1_Ent := First_Entity (Base_Type (Rectype)); | |
2615 | ||
2616 | -- Loop through all components in record. For each component check | |
2617 | -- for overlap with any of the preceding elements on the component | |
fdd294d1 | 2618 | -- list containing the component and also, if the component is in |
d6f39728 | 2619 | -- a variant, check against components outside the case structure. |
2620 | -- This latter test is repeated recursively up the variant tree. | |
2621 | ||
2622 | Main_Component_Loop : while Present (C1_Ent) loop | |
2623 | if Ekind (C1_Ent) /= E_Component | |
2624 | and then Ekind (C1_Ent) /= E_Discriminant | |
2625 | then | |
2626 | goto Continue_Main_Component_Loop; | |
2627 | end if; | |
2628 | ||
2629 | -- Skip overlap check if entity has no declaration node. This | |
2630 | -- happens with discriminants in constrained derived types. | |
2631 | -- Probably we are missing some checks as a result, but that | |
2632 | -- does not seem terribly serious ??? | |
2633 | ||
2634 | if No (Declaration_Node (C1_Ent)) then | |
2635 | goto Continue_Main_Component_Loop; | |
2636 | end if; | |
2637 | ||
2638 | Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); | |
2639 | ||
2640 | -- Loop through component lists that need checking. Check the | |
2641 | -- current component list and all lists in variants above us. | |
2642 | ||
2643 | Component_List_Loop : loop | |
2644 | ||
2645 | -- If derived type definition, go to full declaration | |
fdd294d1 | 2646 | -- If at outer level, check discriminants if there are any. |
d6f39728 | 2647 | |
2648 | if Nkind (Clist) = N_Derived_Type_Definition then | |
2649 | Clist := Parent (Clist); | |
2650 | end if; | |
2651 | ||
2652 | -- Outer level of record definition, check discriminants | |
2653 | ||
fdd294d1 | 2654 | if Nkind_In (Clist, N_Full_Type_Declaration, |
2655 | N_Private_Type_Declaration) | |
d6f39728 | 2656 | then |
2657 | if Has_Discriminants (Defining_Identifier (Clist)) then | |
2658 | C2_Ent := | |
2659 | First_Discriminant (Defining_Identifier (Clist)); | |
2660 | ||
2661 | while Present (C2_Ent) loop | |
2662 | exit when C1_Ent = C2_Ent; | |
2663 | Check_Component_Overlap (C1_Ent, C2_Ent); | |
2664 | Next_Discriminant (C2_Ent); | |
2665 | end loop; | |
2666 | end if; | |
2667 | ||
2668 | -- Record extension case | |
2669 | ||
2670 | elsif Nkind (Clist) = N_Derived_Type_Definition then | |
2671 | Clist := Empty; | |
2672 | ||
2673 | -- Otherwise check one component list | |
2674 | ||
2675 | else | |
2676 | Citem := First (Component_Items (Clist)); | |
2677 | ||
2678 | while Present (Citem) loop | |
2679 | if Nkind (Citem) = N_Component_Declaration then | |
2680 | C2_Ent := Defining_Identifier (Citem); | |
2681 | exit when C1_Ent = C2_Ent; | |
2682 | Check_Component_Overlap (C1_Ent, C2_Ent); | |
2683 | end if; | |
2684 | ||
2685 | Next (Citem); | |
2686 | end loop; | |
2687 | end if; | |
2688 | ||
2689 | -- Check for variants above us (the parent of the Clist can | |
2690 | -- be a variant, in which case its parent is a variant part, | |
2691 | -- and the parent of the variant part is a component list | |
2692 | -- whose components must all be checked against the current | |
fdd294d1 | 2693 | -- component for overlap). |
d6f39728 | 2694 | |
2695 | if Nkind (Parent (Clist)) = N_Variant then | |
2696 | Clist := Parent (Parent (Parent (Clist))); | |
2697 | ||
2698 | -- Check for possible discriminant part in record, this is | |
2699 | -- treated essentially as another level in the recursion. | |
fdd294d1 | 2700 | -- For this case the parent of the component list is the |
2701 | -- record definition, and its parent is the full type | |
2702 | -- declaration containing the discriminant specifications. | |
d6f39728 | 2703 | |
2704 | elsif Nkind (Parent (Clist)) = N_Record_Definition then | |
2705 | Clist := Parent (Parent ((Clist))); | |
2706 | ||
2707 | -- If neither of these two cases, we are at the top of | |
fdd294d1 | 2708 | -- the tree. |
d6f39728 | 2709 | |
2710 | else | |
2711 | exit Component_List_Loop; | |
2712 | end if; | |
2713 | end loop Component_List_Loop; | |
2714 | ||
2715 | <<Continue_Main_Component_Loop>> | |
2716 | Next_Entity (C1_Ent); | |
2717 | ||
2718 | end loop Main_Component_Loop; | |
2719 | end Overlap_Check2; | |
2720 | end if; | |
2721 | ||
fdd294d1 | 2722 | -- For records that have component clauses for all components, and whose |
2723 | -- size is less than or equal to 32, we need to know the size in the | |
2724 | -- front end to activate possible packed array processing where the | |
2725 | -- component type is a record. | |
d6f39728 | 2726 | |
fdd294d1 | 2727 | -- At this stage Hbit + 1 represents the first unused bit from all the |
2728 | -- component clauses processed, so if the component clauses are | |
d6f39728 | 2729 | -- complete, then this is the length of the record. |
2730 | ||
fdd294d1 | 2731 | -- For records longer than System.Storage_Unit, and for those where not |
2732 | -- all components have component clauses, the back end determines the | |
1a34e48c | 2733 | -- length (it may for example be appropriate to round up the size |
fdd294d1 | 2734 | -- to some convenient boundary, based on alignment considerations, etc). |
d6f39728 | 2735 | |
fdd294d1 | 2736 | if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then |
2737 | ||
2738 | -- Nothing to do if at least one component has no component clause | |
d6f39728 | 2739 | |
59ac57b5 | 2740 | Comp := First_Component_Or_Discriminant (Rectype); |
d6f39728 | 2741 | while Present (Comp) loop |
59ac57b5 | 2742 | exit when No (Component_Clause (Comp)); |
2743 | Next_Component_Or_Discriminant (Comp); | |
d6f39728 | 2744 | end loop; |
2745 | ||
2746 | -- If we fall out of loop, all components have component clauses | |
2747 | -- and so we can set the size to the maximum value. | |
2748 | ||
639e37b0 | 2749 | if No (Comp) then |
2750 | Set_RM_Size (Rectype, Hbit + 1); | |
2751 | end if; | |
2752 | end if; | |
2753 | ||
2754 | -- Check missing components if Complete_Representation pragma appeared | |
2755 | ||
2756 | if Present (CR_Pragma) then | |
59ac57b5 | 2757 | Comp := First_Component_Or_Discriminant (Rectype); |
639e37b0 | 2758 | while Present (Comp) loop |
59ac57b5 | 2759 | if No (Component_Clause (Comp)) then |
2760 | Error_Msg_NE | |
2761 | ("missing component clause for &", CR_Pragma, Comp); | |
639e37b0 | 2762 | end if; |
2763 | ||
59ac57b5 | 2764 | Next_Component_Or_Discriminant (Comp); |
639e37b0 | 2765 | end loop; |
15ebb600 | 2766 | |
fbc67f84 | 2767 | -- If no Complete_Representation pragma, warn if missing components |
15ebb600 | 2768 | |
fdd294d1 | 2769 | elsif Warn_On_Unrepped_Components then |
15ebb600 | 2770 | declare |
2771 | Num_Repped_Components : Nat := 0; | |
2772 | Num_Unrepped_Components : Nat := 0; | |
2773 | ||
2774 | begin | |
2775 | -- First count number of repped and unrepped components | |
2776 | ||
2777 | Comp := First_Component_Or_Discriminant (Rectype); | |
2778 | while Present (Comp) loop | |
2779 | if Present (Component_Clause (Comp)) then | |
2780 | Num_Repped_Components := Num_Repped_Components + 1; | |
2781 | else | |
2782 | Num_Unrepped_Components := Num_Unrepped_Components + 1; | |
2783 | end if; | |
2784 | ||
2785 | Next_Component_Or_Discriminant (Comp); | |
2786 | end loop; | |
2787 | ||
2788 | -- We are only interested in the case where there is at least one | |
2789 | -- unrepped component, and at least half the components have rep | |
2790 | -- clauses. We figure that if less than half have them, then the | |
87f9eef5 | 2791 | -- partial rep clause is really intentional. If the component |
2792 | -- type has no underlying type set at this point (as for a generic | |
2793 | -- formal type), we don't know enough to give a warning on the | |
2794 | -- component. | |
15ebb600 | 2795 | |
2796 | if Num_Unrepped_Components > 0 | |
2797 | and then Num_Unrepped_Components < Num_Repped_Components | |
2798 | then | |
2799 | Comp := First_Component_Or_Discriminant (Rectype); | |
2800 | while Present (Comp) loop | |
83f8f0a6 | 2801 | if No (Component_Clause (Comp)) |
3062c401 | 2802 | and then Comes_From_Source (Comp) |
87f9eef5 | 2803 | and then Present (Underlying_Type (Etype (Comp))) |
83f8f0a6 | 2804 | and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) |
2805 | or else Size_Known_At_Compile_Time | |
2806 | (Underlying_Type (Etype (Comp)))) | |
fdd294d1 | 2807 | and then not Has_Warnings_Off (Rectype) |
83f8f0a6 | 2808 | then |
15ebb600 | 2809 | Error_Msg_Sloc := Sloc (Comp); |
2810 | Error_Msg_NE | |
2811 | ("?no component clause given for & declared #", | |
2812 | N, Comp); | |
2813 | end if; | |
2814 | ||
2815 | Next_Component_Or_Discriminant (Comp); | |
2816 | end loop; | |
2817 | end if; | |
2818 | end; | |
d6f39728 | 2819 | end if; |
d6f39728 | 2820 | end Analyze_Record_Representation_Clause; |
2821 | ||
d6f39728 | 2822 | ----------------------------- |
2823 | -- Check_Component_Overlap -- | |
2824 | ----------------------------- | |
2825 | ||
2826 | procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is | |
2827 | begin | |
2828 | if Present (Component_Clause (C1_Ent)) | |
2829 | and then Present (Component_Clause (C2_Ent)) | |
2830 | then | |
fdd294d1 | 2831 | -- Exclude odd case where we have two tag fields in the same record, |
2832 | -- both at location zero. This seems a bit strange, but it seems to | |
2833 | -- happen in some circumstances ??? | |
d6f39728 | 2834 | |
2835 | if Chars (C1_Ent) = Name_uTag | |
2836 | and then Chars (C2_Ent) = Name_uTag | |
2837 | then | |
2838 | return; | |
2839 | end if; | |
2840 | ||
2841 | -- Here we check if the two fields overlap | |
2842 | ||
2843 | declare | |
2844 | S1 : constant Uint := Component_Bit_Offset (C1_Ent); | |
2845 | S2 : constant Uint := Component_Bit_Offset (C2_Ent); | |
2846 | E1 : constant Uint := S1 + Esize (C1_Ent); | |
2847 | E2 : constant Uint := S2 + Esize (C2_Ent); | |
2848 | ||
2849 | begin | |
2850 | if E2 <= S1 or else E1 <= S2 then | |
2851 | null; | |
2852 | else | |
2853 | Error_Msg_Node_2 := | |
2854 | Component_Name (Component_Clause (C2_Ent)); | |
2855 | Error_Msg_Sloc := Sloc (Error_Msg_Node_2); | |
2856 | Error_Msg_Node_1 := | |
2857 | Component_Name (Component_Clause (C1_Ent)); | |
2858 | Error_Msg_N | |
2859 | ("component& overlaps & #", | |
2860 | Component_Name (Component_Clause (C1_Ent))); | |
2861 | end if; | |
2862 | end; | |
2863 | end if; | |
2864 | end Check_Component_Overlap; | |
2865 | ||
2866 | ----------------------------------- | |
2867 | -- Check_Constant_Address_Clause -- | |
2868 | ----------------------------------- | |
2869 | ||
2870 | procedure Check_Constant_Address_Clause | |
2871 | (Expr : Node_Id; | |
2872 | U_Ent : Entity_Id) | |
2873 | is | |
2874 | procedure Check_At_Constant_Address (Nod : Node_Id); | |
fdd294d1 | 2875 | -- Checks that the given node N represents a name whose 'Address is |
2876 | -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the | |
2877 | -- address value is the same at the point of declaration of U_Ent and at | |
2878 | -- the time of elaboration of the address clause. | |
d6f39728 | 2879 | |
2880 | procedure Check_Expr_Constants (Nod : Node_Id); | |
fdd294d1 | 2881 | -- Checks that Nod meets the requirements for a constant address clause |
2882 | -- in the sense of the enclosing procedure. | |
d6f39728 | 2883 | |
2884 | procedure Check_List_Constants (Lst : List_Id); | |
2885 | -- Check that all elements of list Lst meet the requirements for a | |
2886 | -- constant address clause in the sense of the enclosing procedure. | |
2887 | ||
2888 | ------------------------------- | |
2889 | -- Check_At_Constant_Address -- | |
2890 | ------------------------------- | |
2891 | ||
2892 | procedure Check_At_Constant_Address (Nod : Node_Id) is | |
2893 | begin | |
2894 | if Is_Entity_Name (Nod) then | |
2895 | if Present (Address_Clause (Entity ((Nod)))) then | |
2896 | Error_Msg_NE | |
2897 | ("invalid address clause for initialized object &!", | |
2898 | Nod, U_Ent); | |
2899 | Error_Msg_NE | |
2900 | ("address for& cannot" & | |
fbc67f84 | 2901 | " depend on another address clause! (RM 13.1(22))!", |
d6f39728 | 2902 | Nod, U_Ent); |
2903 | ||
2904 | elsif In_Same_Source_Unit (Entity (Nod), U_Ent) | |
2905 | and then Sloc (U_Ent) < Sloc (Entity (Nod)) | |
2906 | then | |
2907 | Error_Msg_NE | |
2908 | ("invalid address clause for initialized object &!", | |
2909 | Nod, U_Ent); | |
2910 | Error_Msg_Name_1 := Chars (Entity (Nod)); | |
2911 | Error_Msg_Name_2 := Chars (U_Ent); | |
2912 | Error_Msg_N | |
fbc67f84 | 2913 | ("\% must be defined before % (RM 13.1(22))!", |
d6f39728 | 2914 | Nod); |
2915 | end if; | |
2916 | ||
2917 | elsif Nkind (Nod) = N_Selected_Component then | |
2918 | declare | |
2919 | T : constant Entity_Id := Etype (Prefix (Nod)); | |
2920 | ||
2921 | begin | |
2922 | if (Is_Record_Type (T) | |
2923 | and then Has_Discriminants (T)) | |
2924 | or else | |
2925 | (Is_Access_Type (T) | |
2926 | and then Is_Record_Type (Designated_Type (T)) | |
2927 | and then Has_Discriminants (Designated_Type (T))) | |
2928 | then | |
2929 | Error_Msg_NE | |
2930 | ("invalid address clause for initialized object &!", | |
2931 | Nod, U_Ent); | |
2932 | Error_Msg_N | |
2933 | ("\address cannot depend on component" & | |
fbc67f84 | 2934 | " of discriminated record (RM 13.1(22))!", |
d6f39728 | 2935 | Nod); |
2936 | else | |
2937 | Check_At_Constant_Address (Prefix (Nod)); | |
2938 | end if; | |
2939 | end; | |
2940 | ||
2941 | elsif Nkind (Nod) = N_Indexed_Component then | |
2942 | Check_At_Constant_Address (Prefix (Nod)); | |
2943 | Check_List_Constants (Expressions (Nod)); | |
2944 | ||
2945 | else | |
2946 | Check_Expr_Constants (Nod); | |
2947 | end if; | |
2948 | end Check_At_Constant_Address; | |
2949 | ||
2950 | -------------------------- | |
2951 | -- Check_Expr_Constants -- | |
2952 | -------------------------- | |
2953 | ||
2954 | procedure Check_Expr_Constants (Nod : Node_Id) is | |
e7b2d6bc | 2955 | Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); |
2956 | Ent : Entity_Id := Empty; | |
2957 | ||
d6f39728 | 2958 | begin |
2959 | if Nkind (Nod) in N_Has_Etype | |
2960 | and then Etype (Nod) = Any_Type | |
2961 | then | |
2962 | return; | |
2963 | end if; | |
2964 | ||
2965 | case Nkind (Nod) is | |
2966 | when N_Empty | N_Error => | |
2967 | return; | |
2968 | ||
2969 | when N_Identifier | N_Expanded_Name => | |
e7b2d6bc | 2970 | Ent := Entity (Nod); |
9dfe12ae | 2971 | |
2972 | -- We need to look at the original node if it is different | |
2973 | -- from the node, since we may have rewritten things and | |
2974 | -- substituted an identifier representing the rewrite. | |
2975 | ||
2976 | if Original_Node (Nod) /= Nod then | |
2977 | Check_Expr_Constants (Original_Node (Nod)); | |
2978 | ||
2979 | -- If the node is an object declaration without initial | |
2980 | -- value, some code has been expanded, and the expression | |
2981 | -- is not constant, even if the constituents might be | |
fdd294d1 | 2982 | -- acceptable, as in A'Address + offset. |
9dfe12ae | 2983 | |
e7b2d6bc | 2984 | if Ekind (Ent) = E_Variable |
fdd294d1 | 2985 | and then |
2986 | Nkind (Declaration_Node (Ent)) = N_Object_Declaration | |
9dfe12ae | 2987 | and then |
e7b2d6bc | 2988 | No (Expression (Declaration_Node (Ent))) |
2989 | then | |
2990 | Error_Msg_NE | |
2991 | ("invalid address clause for initialized object &!", | |
2992 | Nod, U_Ent); | |
2993 | ||
2994 | -- If entity is constant, it may be the result of expanding | |
2995 | -- a check. We must verify that its declaration appears | |
2996 | -- before the object in question, else we also reject the | |
2997 | -- address clause. | |
2998 | ||
2999 | elsif Ekind (Ent) = E_Constant | |
3000 | and then In_Same_Source_Unit (Ent, U_Ent) | |
3001 | and then Sloc (Ent) > Loc_U_Ent | |
9dfe12ae | 3002 | then |
3003 | Error_Msg_NE | |
3004 | ("invalid address clause for initialized object &!", | |
3005 | Nod, U_Ent); | |
3006 | end if; | |
e7b2d6bc | 3007 | |
9dfe12ae | 3008 | return; |
3009 | end if; | |
3010 | ||
2866d595 | 3011 | -- Otherwise look at the identifier and see if it is OK |
9dfe12ae | 3012 | |
e7b2d6bc | 3013 | if Ekind (Ent) = E_Named_Integer |
3014 | or else | |
3015 | Ekind (Ent) = E_Named_Real | |
3016 | or else | |
3017 | Is_Type (Ent) | |
3018 | then | |
3019 | return; | |
d6f39728 | 3020 | |
e7b2d6bc | 3021 | elsif |
3022 | Ekind (Ent) = E_Constant | |
3023 | or else | |
3024 | Ekind (Ent) = E_In_Parameter | |
3025 | then | |
fdd294d1 | 3026 | -- This is the case where we must have Ent defined before |
3027 | -- U_Ent. Clearly if they are in different units this | |
3028 | -- requirement is met since the unit containing Ent is | |
3029 | -- already processed. | |
d6f39728 | 3030 | |
e7b2d6bc | 3031 | if not In_Same_Source_Unit (Ent, U_Ent) then |
3032 | return; | |
d6f39728 | 3033 | |
fdd294d1 | 3034 | -- Otherwise location of Ent must be before the location |
3035 | -- of U_Ent, that's what prior defined means. | |
d6f39728 | 3036 | |
e7b2d6bc | 3037 | elsif Sloc (Ent) < Loc_U_Ent then |
3038 | return; | |
d6f39728 | 3039 | |
3040 | else | |
3041 | Error_Msg_NE | |
3042 | ("invalid address clause for initialized object &!", | |
3043 | Nod, U_Ent); | |
e7b2d6bc | 3044 | Error_Msg_Name_1 := Chars (Ent); |
3045 | Error_Msg_Name_2 := Chars (U_Ent); | |
3046 | Error_Msg_N | |
fbc67f84 | 3047 | ("\% must be defined before % (RM 13.1(22))!", |
e7b2d6bc | 3048 | Nod); |
3049 | end if; | |
9dfe12ae | 3050 | |
e7b2d6bc | 3051 | elsif Nkind (Original_Node (Nod)) = N_Function_Call then |
3052 | Check_Expr_Constants (Original_Node (Nod)); | |
3053 | ||
3054 | else | |
3055 | Error_Msg_NE | |
3056 | ("invalid address clause for initialized object &!", | |
3057 | Nod, U_Ent); | |
3058 | ||
3059 | if Comes_From_Source (Ent) then | |
3060 | Error_Msg_Name_1 := Chars (Ent); | |
3061 | Error_Msg_N | |
3062 | ("\reference to variable% not allowed" | |
fbc67f84 | 3063 | & " (RM 13.1(22))!", Nod); |
e7b2d6bc | 3064 | else |
3065 | Error_Msg_N | |
3066 | ("non-static expression not allowed" | |
fbc67f84 | 3067 | & " (RM 13.1(22))!", Nod); |
d6f39728 | 3068 | end if; |
e7b2d6bc | 3069 | end if; |
d6f39728 | 3070 | |
93735cb8 | 3071 | when N_Integer_Literal => |
3072 | ||
3073 | -- If this is a rewritten unchecked conversion, in a system | |
3074 | -- where Address is an integer type, always use the base type | |
3075 | -- for a literal value. This is user-friendly and prevents | |
3076 | -- order-of-elaboration issues with instances of unchecked | |
3077 | -- conversion. | |
3078 | ||
3079 | if Nkind (Original_Node (Nod)) = N_Function_Call then | |
3080 | Set_Etype (Nod, Base_Type (Etype (Nod))); | |
3081 | end if; | |
3082 | ||
3083 | when N_Real_Literal | | |
d6f39728 | 3084 | N_String_Literal | |
3085 | N_Character_Literal => | |
3086 | return; | |
3087 | ||
3088 | when N_Range => | |
3089 | Check_Expr_Constants (Low_Bound (Nod)); | |
3090 | Check_Expr_Constants (High_Bound (Nod)); | |
3091 | ||
3092 | when N_Explicit_Dereference => | |
3093 | Check_Expr_Constants (Prefix (Nod)); | |
3094 | ||
3095 | when N_Indexed_Component => | |
3096 | Check_Expr_Constants (Prefix (Nod)); | |
3097 | Check_List_Constants (Expressions (Nod)); | |
3098 | ||
3099 | when N_Slice => | |
3100 | Check_Expr_Constants (Prefix (Nod)); | |
3101 | Check_Expr_Constants (Discrete_Range (Nod)); | |
3102 | ||
3103 | when N_Selected_Component => | |
3104 | Check_Expr_Constants (Prefix (Nod)); | |
3105 | ||
3106 | when N_Attribute_Reference => | |
9dfe12ae | 3107 | if Attribute_Name (Nod) = Name_Address |
3108 | or else | |
3109 | Attribute_Name (Nod) = Name_Access | |
d6f39728 | 3110 | or else |
9dfe12ae | 3111 | Attribute_Name (Nod) = Name_Unchecked_Access |
d6f39728 | 3112 | or else |
9dfe12ae | 3113 | Attribute_Name (Nod) = Name_Unrestricted_Access |
d6f39728 | 3114 | then |
3115 | Check_At_Constant_Address (Prefix (Nod)); | |
3116 | ||
3117 | else | |
3118 | Check_Expr_Constants (Prefix (Nod)); | |
3119 | Check_List_Constants (Expressions (Nod)); | |
3120 | end if; | |
3121 | ||
3122 | when N_Aggregate => | |
3123 | Check_List_Constants (Component_Associations (Nod)); | |
3124 | Check_List_Constants (Expressions (Nod)); | |
3125 | ||
3126 | when N_Component_Association => | |
3127 | Check_Expr_Constants (Expression (Nod)); | |
3128 | ||
3129 | when N_Extension_Aggregate => | |
3130 | Check_Expr_Constants (Ancestor_Part (Nod)); | |
3131 | Check_List_Constants (Component_Associations (Nod)); | |
3132 | Check_List_Constants (Expressions (Nod)); | |
3133 | ||
3134 | when N_Null => | |
3135 | return; | |
3136 | ||
44e4341e | 3137 | when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => |
d6f39728 | 3138 | Check_Expr_Constants (Left_Opnd (Nod)); |
3139 | Check_Expr_Constants (Right_Opnd (Nod)); | |
3140 | ||
3141 | when N_Unary_Op => | |
3142 | Check_Expr_Constants (Right_Opnd (Nod)); | |
3143 | ||
3144 | when N_Type_Conversion | | |
3145 | N_Qualified_Expression | | |
3146 | N_Allocator => | |
3147 | Check_Expr_Constants (Expression (Nod)); | |
3148 | ||
3149 | when N_Unchecked_Type_Conversion => | |
3150 | Check_Expr_Constants (Expression (Nod)); | |
3151 | ||
fdd294d1 | 3152 | -- If this is a rewritten unchecked conversion, subtypes in |
3153 | -- this node are those created within the instance. To avoid | |
3154 | -- order of elaboration issues, replace them with their base | |
3155 | -- types. Note that address clauses can cause order of | |
3156 | -- elaboration problems because they are elaborated by the | |
3157 | -- back-end at the point of definition, and may mention | |
3158 | -- entities declared in between (as long as everything is | |
3159 | -- static). It is user-friendly to allow unchecked conversions | |
3160 | -- in this context. | |
d6f39728 | 3161 | |
3162 | if Nkind (Original_Node (Nod)) = N_Function_Call then | |
3163 | Set_Etype (Expression (Nod), | |
3164 | Base_Type (Etype (Expression (Nod)))); | |
3165 | Set_Etype (Nod, Base_Type (Etype (Nod))); | |
3166 | end if; | |
3167 | ||
3168 | when N_Function_Call => | |
3169 | if not Is_Pure (Entity (Name (Nod))) then | |
3170 | Error_Msg_NE | |
3171 | ("invalid address clause for initialized object &!", | |
3172 | Nod, U_Ent); | |
3173 | ||
3174 | Error_Msg_NE | |
fbc67f84 | 3175 | ("\function & is not pure (RM 13.1(22))!", |
d6f39728 | 3176 | Nod, Entity (Name (Nod))); |
3177 | ||
3178 | else | |
3179 | Check_List_Constants (Parameter_Associations (Nod)); | |
3180 | end if; | |
3181 | ||
3182 | when N_Parameter_Association => | |
3183 | Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); | |
3184 | ||
3185 | when others => | |
3186 | Error_Msg_NE | |
3187 | ("invalid address clause for initialized object &!", | |
3188 | Nod, U_Ent); | |
3189 | Error_Msg_NE | |
fbc67f84 | 3190 | ("\must be constant defined before& (RM 13.1(22))!", |
d6f39728 | 3191 | Nod, U_Ent); |
3192 | end case; | |
3193 | end Check_Expr_Constants; | |
3194 | ||
3195 | -------------------------- | |
3196 | -- Check_List_Constants -- | |
3197 | -------------------------- | |
3198 | ||
3199 | procedure Check_List_Constants (Lst : List_Id) is | |
3200 | Nod1 : Node_Id; | |
3201 | ||
3202 | begin | |
3203 | if Present (Lst) then | |
3204 | Nod1 := First (Lst); | |
3205 | while Present (Nod1) loop | |
3206 | Check_Expr_Constants (Nod1); | |
3207 | Next (Nod1); | |
3208 | end loop; | |
3209 | end if; | |
3210 | end Check_List_Constants; | |
3211 | ||
3212 | -- Start of processing for Check_Constant_Address_Clause | |
3213 | ||
3214 | begin | |
3215 | Check_Expr_Constants (Expr); | |
3216 | end Check_Constant_Address_Clause; | |
3217 | ||
3218 | ---------------- | |
3219 | -- Check_Size -- | |
3220 | ---------------- | |
3221 | ||
3222 | procedure Check_Size | |
3223 | (N : Node_Id; | |
3224 | T : Entity_Id; | |
3225 | Siz : Uint; | |
3226 | Biased : out Boolean) | |
3227 | is | |
3228 | UT : constant Entity_Id := Underlying_Type (T); | |
3229 | M : Uint; | |
3230 | ||
3231 | begin | |
3232 | Biased := False; | |
3233 | ||
ea61a7ea | 3234 | -- Dismiss cases for generic types or types with previous errors |
d6f39728 | 3235 | |
3236 | if No (UT) | |
3237 | or else UT = Any_Type | |
3238 | or else Is_Generic_Type (UT) | |
3239 | or else Is_Generic_Type (Root_Type (UT)) | |
d6f39728 | 3240 | then |
3241 | return; | |
3242 | ||
ea61a7ea | 3243 | -- Check case of bit packed array |
3244 | ||
3245 | elsif Is_Array_Type (UT) | |
3246 | and then Known_Static_Component_Size (UT) | |
3247 | and then Is_Bit_Packed_Array (UT) | |
3248 | then | |
3249 | declare | |
3250 | Asiz : Uint; | |
3251 | Indx : Node_Id; | |
3252 | Ityp : Entity_Id; | |
3253 | ||
3254 | begin | |
3255 | Asiz := Component_Size (UT); | |
3256 | Indx := First_Index (UT); | |
3257 | loop | |
3258 | Ityp := Etype (Indx); | |
3259 | ||
3260 | -- If non-static bound, then we are not in the business of | |
3261 | -- trying to check the length, and indeed an error will be | |
3262 | -- issued elsewhere, since sizes of non-static array types | |
3263 | -- cannot be set implicitly or explicitly. | |
3264 | ||
3265 | if not Is_Static_Subtype (Ityp) then | |
3266 | return; | |
3267 | end if; | |
3268 | ||
3269 | -- Otherwise accumulate next dimension | |
3270 | ||
3271 | Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - | |
3272 | Expr_Value (Type_Low_Bound (Ityp)) + | |
3273 | Uint_1); | |
3274 | ||
3275 | Next_Index (Indx); | |
3276 | exit when No (Indx); | |
3277 | end loop; | |
3278 | ||
3279 | if Asiz <= Siz then | |
3280 | return; | |
3281 | else | |
3282 | Error_Msg_Uint_1 := Asiz; | |
3283 | Error_Msg_NE | |
3284 | ("size for& too small, minimum allowed is ^", N, T); | |
37cb33b0 | 3285 | Set_Esize (T, Asiz); |
3286 | Set_RM_Size (T, Asiz); | |
ea61a7ea | 3287 | end if; |
3288 | end; | |
3289 | ||
3290 | -- All other composite types are ignored | |
3291 | ||
3292 | elsif Is_Composite_Type (UT) then | |
3293 | return; | |
3294 | ||
d6f39728 | 3295 | -- For fixed-point types, don't check minimum if type is not frozen, |
ea61a7ea | 3296 | -- since we don't know all the characteristics of the type that can |
3297 | -- affect the size (e.g. a specified small) till freeze time. | |
d6f39728 | 3298 | |
3299 | elsif Is_Fixed_Point_Type (UT) | |
3300 | and then not Is_Frozen (UT) | |
3301 | then | |
3302 | null; | |
3303 | ||
3304 | -- Cases for which a minimum check is required | |
3305 | ||
3306 | else | |
ea61a7ea | 3307 | -- Ignore if specified size is correct for the type |
3308 | ||
3309 | if Known_Esize (UT) and then Siz = Esize (UT) then | |
3310 | return; | |
3311 | end if; | |
3312 | ||
3313 | -- Otherwise get minimum size | |
3314 | ||
d6f39728 | 3315 | M := UI_From_Int (Minimum_Size (UT)); |
3316 | ||
3317 | if Siz < M then | |
3318 | ||
3319 | -- Size is less than minimum size, but one possibility remains | |
fdd294d1 | 3320 | -- that we can manage with the new size if we bias the type. |
d6f39728 | 3321 | |
3322 | M := UI_From_Int (Minimum_Size (UT, Biased => True)); | |
3323 | ||
3324 | if Siz < M then | |
3325 | Error_Msg_Uint_1 := M; | |
3326 | Error_Msg_NE | |
3327 | ("size for& too small, minimum allowed is ^", N, T); | |
37cb33b0 | 3328 | Set_Esize (T, M); |
3329 | Set_RM_Size (T, M); | |
d6f39728 | 3330 | else |
3331 | Biased := True; | |
3332 | end if; | |
3333 | end if; | |
3334 | end if; | |
3335 | end Check_Size; | |
3336 | ||
3337 | ------------------------- | |
3338 | -- Get_Alignment_Value -- | |
3339 | ------------------------- | |
3340 | ||
3341 | function Get_Alignment_Value (Expr : Node_Id) return Uint is | |
3342 | Align : constant Uint := Static_Integer (Expr); | |
3343 | ||
3344 | begin | |
3345 | if Align = No_Uint then | |
3346 | return No_Uint; | |
3347 | ||
3348 | elsif Align <= 0 then | |
3349 | Error_Msg_N ("alignment value must be positive", Expr); | |
3350 | return No_Uint; | |
3351 | ||
3352 | else | |
3353 | for J in Int range 0 .. 64 loop | |
3354 | declare | |
3355 | M : constant Uint := Uint_2 ** J; | |
3356 | ||
3357 | begin | |
3358 | exit when M = Align; | |
3359 | ||
3360 | if M > Align then | |
3361 | Error_Msg_N | |
3362 | ("alignment value must be power of 2", Expr); | |
3363 | return No_Uint; | |
3364 | end if; | |
3365 | end; | |
3366 | end loop; | |
3367 | ||
3368 | return Align; | |
3369 | end if; | |
3370 | end Get_Alignment_Value; | |
3371 | ||
d6f39728 | 3372 | ---------------- |
3373 | -- Initialize -- | |
3374 | ---------------- | |
3375 | ||
3376 | procedure Initialize is | |
3377 | begin | |
3378 | Unchecked_Conversions.Init; | |
3379 | end Initialize; | |
3380 | ||
3381 | ------------------------- | |
3382 | -- Is_Operational_Item -- | |
3383 | ------------------------- | |
3384 | ||
3385 | function Is_Operational_Item (N : Node_Id) return Boolean is | |
3386 | begin | |
3387 | if Nkind (N) /= N_Attribute_Definition_Clause then | |
3388 | return False; | |
3389 | else | |
3390 | declare | |
3391 | Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); | |
d6f39728 | 3392 | begin |
fdd294d1 | 3393 | return Id = Attribute_Input |
d6f39728 | 3394 | or else Id = Attribute_Output |
3395 | or else Id = Attribute_Read | |
f15731c4 | 3396 | or else Id = Attribute_Write |
3397 | or else Id = Attribute_External_Tag; | |
d6f39728 | 3398 | end; |
3399 | end if; | |
3400 | end Is_Operational_Item; | |
3401 | ||
3402 | ------------------ | |
3403 | -- Minimum_Size -- | |
3404 | ------------------ | |
3405 | ||
3406 | function Minimum_Size | |
3407 | (T : Entity_Id; | |
d5b349fa | 3408 | Biased : Boolean := False) return Nat |
d6f39728 | 3409 | is |
3410 | Lo : Uint := No_Uint; | |
3411 | Hi : Uint := No_Uint; | |
3412 | LoR : Ureal := No_Ureal; | |
3413 | HiR : Ureal := No_Ureal; | |
3414 | LoSet : Boolean := False; | |
3415 | HiSet : Boolean := False; | |
3416 | B : Uint; | |
3417 | S : Nat; | |
3418 | Ancest : Entity_Id; | |
f15731c4 | 3419 | R_Typ : constant Entity_Id := Root_Type (T); |
d6f39728 | 3420 | |
3421 | begin | |
3422 | -- If bad type, return 0 | |
3423 | ||
3424 | if T = Any_Type then | |
3425 | return 0; | |
3426 | ||
3427 | -- For generic types, just return zero. There cannot be any legitimate | |
3428 | -- need to know such a size, but this routine may be called with a | |
3429 | -- generic type as part of normal processing. | |
3430 | ||
f15731c4 | 3431 | elsif Is_Generic_Type (R_Typ) |
3432 | or else R_Typ = Any_Type | |
3433 | then | |
d6f39728 | 3434 | return 0; |
3435 | ||
93735cb8 | 3436 | -- Access types. Normally an access type cannot have a size smaller |
3437 | -- than the size of System.Address. The exception is on VMS, where | |
3438 | -- we have short and long addresses, and it is possible for an access | |
3439 | -- type to have a short address size (and thus be less than the size | |
3440 | -- of System.Address itself). We simply skip the check for VMS, and | |
fdd294d1 | 3441 | -- leave it to the back end to do the check. |
d6f39728 | 3442 | |
3443 | elsif Is_Access_Type (T) then | |
93735cb8 | 3444 | if OpenVMS_On_Target then |
3445 | return 0; | |
3446 | else | |
3447 | return System_Address_Size; | |
3448 | end if; | |
d6f39728 | 3449 | |
3450 | -- Floating-point types | |
3451 | ||
3452 | elsif Is_Floating_Point_Type (T) then | |
f15731c4 | 3453 | return UI_To_Int (Esize (R_Typ)); |
d6f39728 | 3454 | |
3455 | -- Discrete types | |
3456 | ||
3457 | elsif Is_Discrete_Type (T) then | |
3458 | ||
fdd294d1 | 3459 | -- The following loop is looking for the nearest compile time known |
3460 | -- bounds following the ancestor subtype chain. The idea is to find | |
3461 | -- the most restrictive known bounds information. | |
d6f39728 | 3462 | |
3463 | Ancest := T; | |
3464 | loop | |
3465 | if Ancest = Any_Type or else Etype (Ancest) = Any_Type then | |
3466 | return 0; | |
3467 | end if; | |
3468 | ||
3469 | if not LoSet then | |
3470 | if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then | |
3471 | Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); | |
3472 | LoSet := True; | |
3473 | exit when HiSet; | |
3474 | end if; | |
3475 | end if; | |
3476 | ||
3477 | if not HiSet then | |
3478 | if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then | |
3479 | Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); | |
3480 | HiSet := True; | |
3481 | exit when LoSet; | |
3482 | end if; | |
3483 | end if; | |
3484 | ||
3485 | Ancest := Ancestor_Subtype (Ancest); | |
3486 | ||
3487 | if No (Ancest) then | |
3488 | Ancest := Base_Type (T); | |
3489 | ||
3490 | if Is_Generic_Type (Ancest) then | |
3491 | return 0; | |
3492 | end if; | |
3493 | end if; | |
3494 | end loop; | |
3495 | ||
3496 | -- Fixed-point types. We can't simply use Expr_Value to get the | |
fdd294d1 | 3497 | -- Corresponding_Integer_Value values of the bounds, since these do not |
3498 | -- get set till the type is frozen, and this routine can be called | |
3499 | -- before the type is frozen. Similarly the test for bounds being static | |
3500 | -- needs to include the case where we have unanalyzed real literals for | |
3501 | -- the same reason. | |
d6f39728 | 3502 | |
3503 | elsif Is_Fixed_Point_Type (T) then | |
3504 | ||
fdd294d1 | 3505 | -- The following loop is looking for the nearest compile time known |
3506 | -- bounds following the ancestor subtype chain. The idea is to find | |
3507 | -- the most restrictive known bounds information. | |
d6f39728 | 3508 | |
3509 | Ancest := T; | |
3510 | loop | |
3511 | if Ancest = Any_Type or else Etype (Ancest) = Any_Type then | |
3512 | return 0; | |
3513 | end if; | |
3514 | ||
3062c401 | 3515 | -- Note: In the following two tests for LoSet and HiSet, it may |
3516 | -- seem redundant to test for N_Real_Literal here since normally | |
3517 | -- one would assume that the test for the value being known at | |
3518 | -- compile time includes this case. However, there is a glitch. | |
3519 | -- If the real literal comes from folding a non-static expression, | |
3520 | -- then we don't consider any non- static expression to be known | |
3521 | -- at compile time if we are in configurable run time mode (needed | |
3522 | -- in some cases to give a clearer definition of what is and what | |
3523 | -- is not accepted). So the test is indeed needed. Without it, we | |
3524 | -- would set neither Lo_Set nor Hi_Set and get an infinite loop. | |
3525 | ||
d6f39728 | 3526 | if not LoSet then |
3527 | if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal | |
3528 | or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) | |
3529 | then | |
3530 | LoR := Expr_Value_R (Type_Low_Bound (Ancest)); | |
3531 | LoSet := True; | |
3532 | exit when HiSet; | |
3533 | end if; | |
3534 | end if; | |
3535 | ||
3536 | if not HiSet then | |
3537 | if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal | |
3538 | or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) | |
3539 | then | |
3540 | HiR := Expr_Value_R (Type_High_Bound (Ancest)); | |
3541 | HiSet := True; | |
3542 | exit when LoSet; | |
3543 | end if; | |
3544 | end if; | |
3545 | ||
3546 | Ancest := Ancestor_Subtype (Ancest); | |
3547 | ||
3548 | if No (Ancest) then | |
3549 | Ancest := Base_Type (T); | |
3550 | ||
3551 | if Is_Generic_Type (Ancest) then | |
3552 | return 0; | |
3553 | end if; | |
3554 | end if; | |
3555 | end loop; | |
3556 | ||
3557 | Lo := UR_To_Uint (LoR / Small_Value (T)); | |
3558 | Hi := UR_To_Uint (HiR / Small_Value (T)); | |
3559 | ||
3560 | -- No other types allowed | |
3561 | ||
3562 | else | |
3563 | raise Program_Error; | |
3564 | end if; | |
3565 | ||
2866d595 | 3566 | -- Fall through with Hi and Lo set. Deal with biased case |
d6f39728 | 3567 | |
3568 | if (Biased and then not Is_Fixed_Point_Type (T)) | |
3569 | or else Has_Biased_Representation (T) | |
3570 | then | |
3571 | Hi := Hi - Lo; | |
3572 | Lo := Uint_0; | |
3573 | end if; | |
3574 | ||
3575 | -- Signed case. Note that we consider types like range 1 .. -1 to be | |
fdd294d1 | 3576 | -- signed for the purpose of computing the size, since the bounds have |
1a34e48c | 3577 | -- to be accommodated in the base type. |
d6f39728 | 3578 | |
3579 | if Lo < 0 or else Hi < 0 then | |
3580 | S := 1; | |
3581 | B := Uint_1; | |
3582 | ||
da253936 | 3583 | -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) |
3584 | -- Note that we accommodate the case where the bounds cross. This | |
d6f39728 | 3585 | -- can happen either because of the way the bounds are declared |
3586 | -- or because of the algorithm in Freeze_Fixed_Point_Type. | |
3587 | ||
3588 | while Lo < -B | |
3589 | or else Hi < -B | |
3590 | or else Lo >= B | |
3591 | or else Hi >= B | |
3592 | loop | |
3593 | B := Uint_2 ** S; | |
3594 | S := S + 1; | |
3595 | end loop; | |
3596 | ||
3597 | -- Unsigned case | |
3598 | ||
3599 | else | |
3600 | -- If both bounds are positive, make sure that both are represen- | |
3601 | -- table in the case where the bounds are crossed. This can happen | |
3602 | -- either because of the way the bounds are declared, or because of | |
3603 | -- the algorithm in Freeze_Fixed_Point_Type. | |
3604 | ||
3605 | if Lo > Hi then | |
3606 | Hi := Lo; | |
3607 | end if; | |
3608 | ||
da253936 | 3609 | -- S = size, (can accommodate 0 .. (2**size - 1)) |
d6f39728 | 3610 | |
3611 | S := 0; | |
3612 | while Hi >= Uint_2 ** S loop | |
3613 | S := S + 1; | |
3614 | end loop; | |
3615 | end if; | |
3616 | ||
3617 | return S; | |
3618 | end Minimum_Size; | |
3619 | ||
44e4341e | 3620 | --------------------------- |
3621 | -- New_Stream_Subprogram -- | |
3622 | --------------------------- | |
d6f39728 | 3623 | |
44e4341e | 3624 | procedure New_Stream_Subprogram |
3625 | (N : Node_Id; | |
3626 | Ent : Entity_Id; | |
3627 | Subp : Entity_Id; | |
3628 | Nam : TSS_Name_Type) | |
d6f39728 | 3629 | is |
3630 | Loc : constant Source_Ptr := Sloc (N); | |
9dfe12ae | 3631 | Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); |
f15731c4 | 3632 | Subp_Id : Entity_Id; |
d6f39728 | 3633 | Subp_Decl : Node_Id; |
3634 | F : Entity_Id; | |
3635 | Etyp : Entity_Id; | |
3636 | ||
44e4341e | 3637 | Defer_Declaration : constant Boolean := |
3638 | Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); | |
3639 | -- For a tagged type, there is a declaration for each stream attribute | |
3640 | -- at the freeze point, and we must generate only a completion of this | |
3641 | -- declaration. We do the same for private types, because the full view | |
3642 | -- might be tagged. Otherwise we generate a declaration at the point of | |
3643 | -- the attribute definition clause. | |
3644 | ||
f15731c4 | 3645 | function Build_Spec return Node_Id; |
3646 | -- Used for declaration and renaming declaration, so that this is | |
3647 | -- treated as a renaming_as_body. | |
3648 | ||
3649 | ---------------- | |
3650 | -- Build_Spec -- | |
3651 | ---------------- | |
3652 | ||
d5b349fa | 3653 | function Build_Spec return Node_Id is |
44e4341e | 3654 | Out_P : constant Boolean := (Nam = TSS_Stream_Read); |
3655 | Formals : List_Id; | |
3656 | Spec : Node_Id; | |
3657 | T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc); | |
3658 | ||
f15731c4 | 3659 | begin |
9dfe12ae | 3660 | Subp_Id := Make_Defining_Identifier (Loc, Sname); |
f15731c4 | 3661 | |
44e4341e | 3662 | -- S : access Root_Stream_Type'Class |
3663 | ||
3664 | Formals := New_List ( | |
3665 | Make_Parameter_Specification (Loc, | |
3666 | Defining_Identifier => | |
3667 | Make_Defining_Identifier (Loc, Name_S), | |
3668 | Parameter_Type => | |
3669 | Make_Access_Definition (Loc, | |
3670 | Subtype_Mark => | |
3671 | New_Reference_To ( | |
3672 | Designated_Type (Etype (F)), Loc)))); | |
3673 | ||
3674 | if Nam = TSS_Stream_Input then | |
3675 | Spec := Make_Function_Specification (Loc, | |
3676 | Defining_Unit_Name => Subp_Id, | |
3677 | Parameter_Specifications => Formals, | |
3678 | Result_Definition => T_Ref); | |
3679 | else | |
3680 | -- V : [out] T | |
f15731c4 | 3681 | |
44e4341e | 3682 | Append_To (Formals, |
3683 | Make_Parameter_Specification (Loc, | |
3684 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), | |
3685 | Out_Present => Out_P, | |
3686 | Parameter_Type => T_Ref)); | |
f15731c4 | 3687 | |
44e4341e | 3688 | Spec := Make_Procedure_Specification (Loc, |
3689 | Defining_Unit_Name => Subp_Id, | |
3690 | Parameter_Specifications => Formals); | |
3691 | end if; | |
f15731c4 | 3692 | |
44e4341e | 3693 | return Spec; |
3694 | end Build_Spec; | |
d6f39728 | 3695 | |
44e4341e | 3696 | -- Start of processing for New_Stream_Subprogram |
d6f39728 | 3697 | |
44e4341e | 3698 | begin |
3699 | F := First_Formal (Subp); | |
3700 | ||
3701 | if Ekind (Subp) = E_Procedure then | |
3702 | Etyp := Etype (Next_Formal (F)); | |
d6f39728 | 3703 | else |
44e4341e | 3704 | Etyp := Etype (Subp); |
d6f39728 | 3705 | end if; |
f15731c4 | 3706 | |
44e4341e | 3707 | -- Prepare subprogram declaration and insert it as an action on the |
3708 | -- clause node. The visibility for this entity is used to test for | |
3709 | -- visibility of the attribute definition clause (in the sense of | |
3710 | -- 8.3(23) as amended by AI-195). | |
9dfe12ae | 3711 | |
44e4341e | 3712 | if not Defer_Declaration then |
f15731c4 | 3713 | Subp_Decl := |
3714 | Make_Subprogram_Declaration (Loc, | |
3715 | Specification => Build_Spec); | |
44e4341e | 3716 | |
3717 | -- For a tagged type, there is always a visible declaration for each | |
15ebb600 | 3718 | -- stream TSS (it is a predefined primitive operation), and the |
44e4341e | 3719 | -- completion of this declaration occurs at the freeze point, which is |
3720 | -- not always visible at places where the attribute definition clause is | |
3721 | -- visible. So, we create a dummy entity here for the purpose of | |
3722 | -- tracking the visibility of the attribute definition clause itself. | |
3723 | ||
3724 | else | |
3725 | Subp_Id := | |
3726 | Make_Defining_Identifier (Loc, | |
3727 | Chars => New_External_Name (Sname, 'V')); | |
3728 | Subp_Decl := | |
3729 | Make_Object_Declaration (Loc, | |
3730 | Defining_Identifier => Subp_Id, | |
3731 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); | |
f15731c4 | 3732 | end if; |
3733 | ||
44e4341e | 3734 | Insert_Action (N, Subp_Decl); |
3735 | Set_Entity (N, Subp_Id); | |
3736 | ||
d6f39728 | 3737 | Subp_Decl := |
3738 | Make_Subprogram_Renaming_Declaration (Loc, | |
f15731c4 | 3739 | Specification => Build_Spec, |
3740 | Name => New_Reference_To (Subp, Loc)); | |
d6f39728 | 3741 | |
44e4341e | 3742 | if Defer_Declaration then |
d6f39728 | 3743 | Set_TSS (Base_Type (Ent), Subp_Id); |
3744 | else | |
3745 | Insert_Action (N, Subp_Decl); | |
3746 | Copy_TSS (Subp_Id, Base_Type (Ent)); | |
3747 | end if; | |
44e4341e | 3748 | end New_Stream_Subprogram; |
d6f39728 | 3749 | |
d6f39728 | 3750 | ------------------------ |
3751 | -- Rep_Item_Too_Early -- | |
3752 | ------------------------ | |
3753 | ||
80d4fec4 | 3754 | function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is |
d6f39728 | 3755 | begin |
44e4341e | 3756 | -- Cannot apply non-operational rep items to generic types |
d6f39728 | 3757 | |
f15731c4 | 3758 | if Is_Operational_Item (N) then |
3759 | return False; | |
3760 | ||
3761 | elsif Is_Type (T) | |
d6f39728 | 3762 | and then Is_Generic_Type (Root_Type (T)) |
3763 | then | |
3764 | Error_Msg_N | |
3765 | ("representation item not allowed for generic type", N); | |
3766 | return True; | |
3767 | end if; | |
3768 | ||
fdd294d1 | 3769 | -- Otherwise check for incomplete type |
d6f39728 | 3770 | |
3771 | if Is_Incomplete_Or_Private_Type (T) | |
3772 | and then No (Underlying_Type (T)) | |
3773 | then | |
3774 | Error_Msg_N | |
3775 | ("representation item must be after full type declaration", N); | |
3776 | return True; | |
3777 | ||
1a34e48c | 3778 | -- If the type has incomplete components, a representation clause is |
d6f39728 | 3779 | -- illegal but stream attributes and Convention pragmas are correct. |
3780 | ||
3781 | elsif Has_Private_Component (T) then | |
f15731c4 | 3782 | if Nkind (N) = N_Pragma then |
d6f39728 | 3783 | return False; |
3784 | else | |
3785 | Error_Msg_N | |
3786 | ("representation item must appear after type is fully defined", | |
3787 | N); | |
3788 | return True; | |
3789 | end if; | |
3790 | else | |
3791 | return False; | |
3792 | end if; | |
3793 | end Rep_Item_Too_Early; | |
3794 | ||
3795 | ----------------------- | |
3796 | -- Rep_Item_Too_Late -- | |
3797 | ----------------------- | |
3798 | ||
3799 | function Rep_Item_Too_Late | |
3800 | (T : Entity_Id; | |
3801 | N : Node_Id; | |
d5b349fa | 3802 | FOnly : Boolean := False) return Boolean |
d6f39728 | 3803 | is |
3804 | S : Entity_Id; | |
3805 | Parent_Type : Entity_Id; | |
3806 | ||
3807 | procedure Too_Late; | |
d53a018a | 3808 | -- Output the too late message. Note that this is not considered a |
3809 | -- serious error, since the effect is simply that we ignore the | |
3810 | -- representation clause in this case. | |
3811 | ||
3812 | -------------- | |
3813 | -- Too_Late -- | |
3814 | -------------- | |
d6f39728 | 3815 | |
3816 | procedure Too_Late is | |
3817 | begin | |
d53a018a | 3818 | Error_Msg_N ("|representation item appears too late!", N); |
d6f39728 | 3819 | end Too_Late; |
3820 | ||
3821 | -- Start of processing for Rep_Item_Too_Late | |
3822 | ||
3823 | begin | |
3824 | -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported | |
3825 | -- types, which may be frozen if they appear in a representation clause | |
3826 | -- for a local type. | |
3827 | ||
3828 | if Is_Frozen (T) | |
3829 | and then not From_With_Type (T) | |
3830 | then | |
3831 | Too_Late; | |
3832 | S := First_Subtype (T); | |
3833 | ||
3834 | if Present (Freeze_Node (S)) then | |
3835 | Error_Msg_NE | |
87d5c1d0 | 3836 | ("?no more representation items for }", Freeze_Node (S), S); |
d6f39728 | 3837 | end if; |
3838 | ||
3839 | return True; | |
3840 | ||
3841 | -- Check for case of non-tagged derived type whose parent either has | |
3842 | -- primitive operations, or is a by reference type (RM 13.1(10)). | |
3843 | ||
3844 | elsif Is_Type (T) | |
3845 | and then not FOnly | |
3846 | and then Is_Derived_Type (T) | |
3847 | and then not Is_Tagged_Type (T) | |
3848 | then | |
3849 | Parent_Type := Etype (Base_Type (T)); | |
3850 | ||
3851 | if Has_Primitive_Operations (Parent_Type) then | |
3852 | Too_Late; | |
3853 | Error_Msg_NE | |
3854 | ("primitive operations already defined for&!", N, Parent_Type); | |
3855 | return True; | |
3856 | ||
3857 | elsif Is_By_Reference_Type (Parent_Type) then | |
3858 | Too_Late; | |
3859 | Error_Msg_NE | |
3860 | ("parent type & is a by reference type!", N, Parent_Type); | |
3861 | return True; | |
3862 | end if; | |
3863 | end if; | |
3864 | ||
3062c401 | 3865 | -- No error, link item into head of chain of rep items for the entity, |
3866 | -- but avoid chaining if we have an overloadable entity, and the pragma | |
3867 | -- is one that can apply to multiple overloaded entities. | |
3868 | ||
3869 | if Is_Overloadable (T) | |
3870 | and then Nkind (N) = N_Pragma | |
3062c401 | 3871 | then |
fdd294d1 | 3872 | declare |
3873 | Pname : constant Name_Id := Pragma_Name (N); | |
3874 | begin | |
3875 | if Pname = Name_Convention or else | |
3876 | Pname = Name_Import or else | |
3877 | Pname = Name_Export or else | |
3878 | Pname = Name_External or else | |
3879 | Pname = Name_Interface | |
3880 | then | |
3881 | return False; | |
3882 | end if; | |
3883 | end; | |
3062c401 | 3884 | end if; |
3885 | ||
fdd294d1 | 3886 | Record_Rep_Item (T, N); |
d6f39728 | 3887 | return False; |
3888 | end Rep_Item_Too_Late; | |
3889 | ||
3890 | ------------------------- | |
3891 | -- Same_Representation -- | |
3892 | ------------------------- | |
3893 | ||
3894 | function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is | |
3895 | T1 : constant Entity_Id := Underlying_Type (Typ1); | |
3896 | T2 : constant Entity_Id := Underlying_Type (Typ2); | |
3897 | ||
3898 | begin | |
3899 | -- A quick check, if base types are the same, then we definitely have | |
3900 | -- the same representation, because the subtype specific representation | |
3901 | -- attributes (Size and Alignment) do not affect representation from | |
3902 | -- the point of view of this test. | |
3903 | ||
3904 | if Base_Type (T1) = Base_Type (T2) then | |
3905 | return True; | |
3906 | ||
3907 | elsif Is_Private_Type (Base_Type (T2)) | |
3908 | and then Base_Type (T1) = Full_View (Base_Type (T2)) | |
3909 | then | |
3910 | return True; | |
3911 | end if; | |
3912 | ||
3913 | -- Tagged types never have differing representations | |
3914 | ||
3915 | if Is_Tagged_Type (T1) then | |
3916 | return True; | |
3917 | end if; | |
3918 | ||
3919 | -- Representations are definitely different if conventions differ | |
3920 | ||
3921 | if Convention (T1) /= Convention (T2) then | |
3922 | return False; | |
3923 | end if; | |
3924 | ||
3925 | -- Representations are different if component alignments differ | |
3926 | ||
3927 | if (Is_Record_Type (T1) or else Is_Array_Type (T1)) | |
3928 | and then | |
3929 | (Is_Record_Type (T2) or else Is_Array_Type (T2)) | |
3930 | and then Component_Alignment (T1) /= Component_Alignment (T2) | |
3931 | then | |
3932 | return False; | |
3933 | end if; | |
3934 | ||
3935 | -- For arrays, the only real issue is component size. If we know the | |
3936 | -- component size for both arrays, and it is the same, then that's | |
3937 | -- good enough to know we don't have a change of representation. | |
3938 | ||
3939 | if Is_Array_Type (T1) then | |
3940 | if Known_Component_Size (T1) | |
3941 | and then Known_Component_Size (T2) | |
3942 | and then Component_Size (T1) = Component_Size (T2) | |
3943 | then | |
3944 | return True; | |
3945 | end if; | |
3946 | end if; | |
3947 | ||
3948 | -- Types definitely have same representation if neither has non-standard | |
3949 | -- representation since default representations are always consistent. | |
3950 | -- If only one has non-standard representation, and the other does not, | |
3951 | -- then we consider that they do not have the same representation. They | |
3952 | -- might, but there is no way of telling early enough. | |
3953 | ||
3954 | if Has_Non_Standard_Rep (T1) then | |
3955 | if not Has_Non_Standard_Rep (T2) then | |
3956 | return False; | |
3957 | end if; | |
3958 | else | |
3959 | return not Has_Non_Standard_Rep (T2); | |
3960 | end if; | |
3961 | ||
fdd294d1 | 3962 | -- Here the two types both have non-standard representation, and we need |
3963 | -- to determine if they have the same non-standard representation. | |
d6f39728 | 3964 | |
3965 | -- For arrays, we simply need to test if the component sizes are the | |
3966 | -- same. Pragma Pack is reflected in modified component sizes, so this | |
3967 | -- check also deals with pragma Pack. | |
3968 | ||
3969 | if Is_Array_Type (T1) then | |
3970 | return Component_Size (T1) = Component_Size (T2); | |
3971 | ||
3972 | -- Tagged types always have the same representation, because it is not | |
3973 | -- possible to specify different representations for common fields. | |
3974 | ||
3975 | elsif Is_Tagged_Type (T1) then | |
3976 | return True; | |
3977 | ||
3978 | -- Case of record types | |
3979 | ||
3980 | elsif Is_Record_Type (T1) then | |
3981 | ||
3982 | -- Packed status must conform | |
3983 | ||
3984 | if Is_Packed (T1) /= Is_Packed (T2) then | |
3985 | return False; | |
3986 | ||
3987 | -- Otherwise we must check components. Typ2 maybe a constrained | |
3988 | -- subtype with fewer components, so we compare the components | |
3989 | -- of the base types. | |
3990 | ||
3991 | else | |
3992 | Record_Case : declare | |
3993 | CD1, CD2 : Entity_Id; | |
3994 | ||
3995 | function Same_Rep return Boolean; | |
3996 | -- CD1 and CD2 are either components or discriminants. This | |
3997 | -- function tests whether the two have the same representation | |
3998 | ||
80d4fec4 | 3999 | -------------- |
4000 | -- Same_Rep -- | |
4001 | -------------- | |
4002 | ||
d6f39728 | 4003 | function Same_Rep return Boolean is |
4004 | begin | |
4005 | if No (Component_Clause (CD1)) then | |
4006 | return No (Component_Clause (CD2)); | |
4007 | ||
4008 | else | |
4009 | return | |
4010 | Present (Component_Clause (CD2)) | |
4011 | and then | |
4012 | Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) | |
4013 | and then | |
4014 | Esize (CD1) = Esize (CD2); | |
4015 | end if; | |
4016 | end Same_Rep; | |
4017 | ||
4018 | -- Start processing for Record_Case | |
4019 | ||
4020 | begin | |
4021 | if Has_Discriminants (T1) then | |
4022 | CD1 := First_Discriminant (T1); | |
4023 | CD2 := First_Discriminant (T2); | |
4024 | ||
9dfe12ae | 4025 | -- The number of discriminants may be different if the |
4026 | -- derived type has fewer (constrained by values). The | |
4027 | -- invisible discriminants retain the representation of | |
4028 | -- the original, so the discrepancy does not per se | |
4029 | -- indicate a different representation. | |
4030 | ||
4031 | while Present (CD1) | |
4032 | and then Present (CD2) | |
4033 | loop | |
d6f39728 | 4034 | if not Same_Rep then |
4035 | return False; | |
4036 | else | |
4037 | Next_Discriminant (CD1); | |
4038 | Next_Discriminant (CD2); | |
4039 | end if; | |
4040 | end loop; | |
4041 | end if; | |
4042 | ||
4043 | CD1 := First_Component (Underlying_Type (Base_Type (T1))); | |
4044 | CD2 := First_Component (Underlying_Type (Base_Type (T2))); | |
4045 | ||
4046 | while Present (CD1) loop | |
4047 | if not Same_Rep then | |
4048 | return False; | |
4049 | else | |
4050 | Next_Component (CD1); | |
4051 | Next_Component (CD2); | |
4052 | end if; | |
4053 | end loop; | |
4054 | ||
4055 | return True; | |
4056 | end Record_Case; | |
4057 | end if; | |
4058 | ||
4059 | -- For enumeration types, we must check each literal to see if the | |
4060 | -- representation is the same. Note that we do not permit enumeration | |
1a34e48c | 4061 | -- representation clauses for Character and Wide_Character, so these |
d6f39728 | 4062 | -- cases were already dealt with. |
4063 | ||
4064 | elsif Is_Enumeration_Type (T1) then | |
4065 | ||
4066 | Enumeration_Case : declare | |
4067 | L1, L2 : Entity_Id; | |
4068 | ||
4069 | begin | |
4070 | L1 := First_Literal (T1); | |
4071 | L2 := First_Literal (T2); | |
4072 | ||
4073 | while Present (L1) loop | |
4074 | if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then | |
4075 | return False; | |
4076 | else | |
4077 | Next_Literal (L1); | |
4078 | Next_Literal (L2); | |
4079 | end if; | |
4080 | end loop; | |
4081 | ||
4082 | return True; | |
4083 | ||
4084 | end Enumeration_Case; | |
4085 | ||
4086 | -- Any other types have the same representation for these purposes | |
4087 | ||
4088 | else | |
4089 | return True; | |
4090 | end if; | |
d6f39728 | 4091 | end Same_Representation; |
4092 | ||
4093 | -------------------- | |
4094 | -- Set_Enum_Esize -- | |
4095 | -------------------- | |
4096 | ||
4097 | procedure Set_Enum_Esize (T : Entity_Id) is | |
4098 | Lo : Uint; | |
4099 | Hi : Uint; | |
4100 | Sz : Nat; | |
4101 | ||
4102 | begin | |
4103 | Init_Alignment (T); | |
4104 | ||
4105 | -- Find the minimum standard size (8,16,32,64) that fits | |
4106 | ||
4107 | Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); | |
4108 | Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); | |
4109 | ||
4110 | if Lo < 0 then | |
4111 | if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then | |
f15731c4 | 4112 | Sz := Standard_Character_Size; -- May be > 8 on some targets |
d6f39728 | 4113 | |
4114 | elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then | |
4115 | Sz := 16; | |
4116 | ||
4117 | elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then | |
4118 | Sz := 32; | |
4119 | ||
4120 | else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); | |
4121 | Sz := 64; | |
4122 | end if; | |
4123 | ||
4124 | else | |
4125 | if Hi < Uint_2**08 then | |
f15731c4 | 4126 | Sz := Standard_Character_Size; -- May be > 8 on some targets |
d6f39728 | 4127 | |
4128 | elsif Hi < Uint_2**16 then | |
4129 | Sz := 16; | |
4130 | ||
4131 | elsif Hi < Uint_2**32 then | |
4132 | Sz := 32; | |
4133 | ||
4134 | else pragma Assert (Hi < Uint_2**63); | |
4135 | Sz := 64; | |
4136 | end if; | |
4137 | end if; | |
4138 | ||
4139 | -- That minimum is the proper size unless we have a foreign convention | |
4140 | -- and the size required is 32 or less, in which case we bump the size | |
4141 | -- up to 32. This is required for C and C++ and seems reasonable for | |
4142 | -- all other foreign conventions. | |
4143 | ||
4144 | if Has_Foreign_Convention (T) | |
4145 | and then Esize (T) < Standard_Integer_Size | |
4146 | then | |
4147 | Init_Esize (T, Standard_Integer_Size); | |
d6f39728 | 4148 | else |
4149 | Init_Esize (T, Sz); | |
4150 | end if; | |
d6f39728 | 4151 | end Set_Enum_Esize; |
4152 | ||
83f8f0a6 | 4153 | ------------------------------ |
4154 | -- Validate_Address_Clauses -- | |
4155 | ------------------------------ | |
4156 | ||
4157 | procedure Validate_Address_Clauses is | |
4158 | begin | |
4159 | for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop | |
4160 | declare | |
4161 | ACCR : Address_Clause_Check_Record | |
4162 | renames Address_Clause_Checks.Table (J); | |
4163 | ||
4164 | X_Alignment : Uint; | |
4165 | Y_Alignment : Uint; | |
4166 | ||
4167 | X_Size : Uint; | |
4168 | Y_Size : Uint; | |
4169 | ||
4170 | begin | |
4171 | -- Skip processing of this entry if warning already posted | |
4172 | ||
4173 | if not Address_Warning_Posted (ACCR.N) then | |
4174 | ||
4175 | -- Get alignments. Really we should always have the alignment | |
4176 | -- of the objects properly back annotated, but right now the | |
4177 | -- back end fails to back annotate for address clauses??? | |
4178 | ||
4179 | if Known_Alignment (ACCR.X) then | |
4180 | X_Alignment := Alignment (ACCR.X); | |
4181 | else | |
4182 | X_Alignment := Alignment (Etype (ACCR.X)); | |
4183 | end if; | |
4184 | ||
4185 | if Known_Alignment (ACCR.Y) then | |
4186 | Y_Alignment := Alignment (ACCR.Y); | |
4187 | else | |
4188 | Y_Alignment := Alignment (Etype (ACCR.Y)); | |
4189 | end if; | |
4190 | ||
4191 | -- Similarly obtain sizes | |
4192 | ||
4193 | if Known_Esize (ACCR.X) then | |
4194 | X_Size := Esize (ACCR.X); | |
4195 | else | |
4196 | X_Size := Esize (Etype (ACCR.X)); | |
4197 | end if; | |
4198 | ||
4199 | if Known_Esize (ACCR.Y) then | |
4200 | Y_Size := Esize (ACCR.Y); | |
4201 | else | |
4202 | Y_Size := Esize (Etype (ACCR.Y)); | |
4203 | end if; | |
4204 | ||
4205 | -- Check for large object overlaying smaller one | |
4206 | ||
4207 | if Y_Size > Uint_0 | |
4208 | and then X_Size > Uint_0 | |
4209 | and then X_Size > Y_Size | |
4210 | then | |
4211 | Error_Msg_N | |
4212 | ("?size for overlaid object is too small", ACCR.N); | |
4213 | Error_Msg_Uint_1 := X_Size; | |
4214 | Error_Msg_NE | |
4215 | ("\?size of & is ^", ACCR.N, ACCR.X); | |
4216 | Error_Msg_Uint_1 := Y_Size; | |
4217 | Error_Msg_NE | |
4218 | ("\?size of & is ^", ACCR.N, ACCR.Y); | |
4219 | ||
4220 | -- Check for inadequate alignment. Again the defensive check | |
4221 | -- on Y_Alignment should not be needed, but because of the | |
4222 | -- failure in back end annotation, we can have an alignment | |
4223 | -- of 0 here??? | |
4224 | ||
4225 | -- Note: we do not check alignments if we gave a size | |
4226 | -- warning, since it would likely be redundant. | |
4227 | ||
4228 | elsif Y_Alignment /= Uint_0 | |
4229 | and then Y_Alignment < X_Alignment | |
4230 | then | |
4231 | Error_Msg_NE | |
4232 | ("?specified address for& may be inconsistent " | |
4233 | & "with alignment", | |
4234 | ACCR.N, ACCR.X); | |
4235 | Error_Msg_N | |
4236 | ("\?program execution may be erroneous (RM 13.3(27))", | |
4237 | ACCR.N); | |
4238 | Error_Msg_Uint_1 := X_Alignment; | |
4239 | Error_Msg_NE | |
4240 | ("\?alignment of & is ^", | |
4241 | ACCR.N, ACCR.X); | |
4242 | Error_Msg_Uint_1 := Y_Alignment; | |
4243 | Error_Msg_NE | |
4244 | ("\?alignment of & is ^", | |
4245 | ACCR.N, ACCR.Y); | |
4246 | end if; | |
4247 | end if; | |
4248 | end; | |
4249 | end loop; | |
4250 | end Validate_Address_Clauses; | |
4251 | ||
d6f39728 | 4252 | ----------------------------------- |
4253 | -- Validate_Unchecked_Conversion -- | |
4254 | ----------------------------------- | |
4255 | ||
4256 | procedure Validate_Unchecked_Conversion | |
4257 | (N : Node_Id; | |
4258 | Act_Unit : Entity_Id) | |
4259 | is | |
4260 | Source : Entity_Id; | |
4261 | Target : Entity_Id; | |
4262 | Vnode : Node_Id; | |
4263 | ||
4264 | begin | |
4265 | -- Obtain source and target types. Note that we call Ancestor_Subtype | |
4266 | -- here because the processing for generic instantiation always makes | |
4267 | -- subtypes, and we want the original frozen actual types. | |
4268 | ||
4269 | -- If we are dealing with private types, then do the check on their | |
4270 | -- fully declared counterparts if the full declarations have been | |
4271 | -- encountered (they don't have to be visible, but they must exist!) | |
4272 | ||
4273 | Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); | |
4274 | ||
4275 | if Is_Private_Type (Source) | |
4276 | and then Present (Underlying_Type (Source)) | |
4277 | then | |
4278 | Source := Underlying_Type (Source); | |
4279 | end if; | |
4280 | ||
4281 | Target := Ancestor_Subtype (Etype (Act_Unit)); | |
4282 | ||
fdd294d1 | 4283 | -- If either type is generic, the instantiation happens within a generic |
4284 | -- unit, and there is nothing to check. The proper check | |
d6f39728 | 4285 | -- will happen when the enclosing generic is instantiated. |
4286 | ||
4287 | if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then | |
4288 | return; | |
4289 | end if; | |
4290 | ||
4291 | if Is_Private_Type (Target) | |
4292 | and then Present (Underlying_Type (Target)) | |
4293 | then | |
4294 | Target := Underlying_Type (Target); | |
4295 | end if; | |
4296 | ||
4297 | -- Source may be unconstrained array, but not target | |
4298 | ||
4299 | if Is_Array_Type (Target) | |
4300 | and then not Is_Constrained (Target) | |
4301 | then | |
4302 | Error_Msg_N | |
4303 | ("unchecked conversion to unconstrained array not allowed", N); | |
4304 | return; | |
4305 | end if; | |
4306 | ||
fbc67f84 | 4307 | -- Warn if conversion between two different convention pointers |
4308 | ||
4309 | if Is_Access_Type (Target) | |
4310 | and then Is_Access_Type (Source) | |
4311 | and then Convention (Target) /= Convention (Source) | |
4312 | and then Warn_On_Unchecked_Conversion | |
4313 | then | |
fdd294d1 | 4314 | -- Give warnings for subprogram pointers only on most targets. The |
4315 | -- exception is VMS, where data pointers can have different lengths | |
4316 | -- depending on the pointer convention. | |
4317 | ||
4318 | if Is_Access_Subprogram_Type (Target) | |
4319 | or else Is_Access_Subprogram_Type (Source) | |
4320 | or else OpenVMS_On_Target | |
4321 | then | |
4322 | Error_Msg_N | |
4323 | ("?conversion between pointers with different conventions!", N); | |
4324 | end if; | |
fbc67f84 | 4325 | end if; |
4326 | ||
3062c401 | 4327 | -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a |
4328 | -- warning when compiling GNAT-related sources. | |
4329 | ||
4330 | if Warn_On_Unchecked_Conversion | |
4331 | and then not In_Predefined_Unit (N) | |
4332 | and then RTU_Loaded (Ada_Calendar) | |
4333 | and then | |
4334 | (Chars (Source) = Name_Time | |
4335 | or else | |
4336 | Chars (Target) = Name_Time) | |
4337 | then | |
4338 | -- If Ada.Calendar is loaded and the name of one of the operands is | |
4339 | -- Time, there is a good chance that this is Ada.Calendar.Time. | |
4340 | ||
4341 | declare | |
4342 | Calendar_Time : constant Entity_Id := | |
4343 | Full_View (RTE (RO_CA_Time)); | |
4344 | begin | |
4345 | pragma Assert (Present (Calendar_Time)); | |
4346 | ||
4347 | if Source = Calendar_Time | |
4348 | or else Target = Calendar_Time | |
4349 | then | |
4350 | Error_Msg_N | |
4351 | ("?representation of 'Time values may change between " & | |
4352 | "'G'N'A'T versions", N); | |
4353 | end if; | |
4354 | end; | |
4355 | end if; | |
4356 | ||
fdd294d1 | 4357 | -- Make entry in unchecked conversion table for later processing by |
4358 | -- Validate_Unchecked_Conversions, which will check sizes and alignments | |
4359 | -- (using values set by the back-end where possible). This is only done | |
4360 | -- if the appropriate warning is active. | |
d6f39728 | 4361 | |
9dfe12ae | 4362 | if Warn_On_Unchecked_Conversion then |
4363 | Unchecked_Conversions.Append | |
4364 | (New_Val => UC_Entry' | |
4365 | (Enode => N, | |
4366 | Source => Source, | |
4367 | Target => Target)); | |
4368 | ||
4369 | -- If both sizes are known statically now, then back end annotation | |
4370 | -- is not required to do a proper check but if either size is not | |
4371 | -- known statically, then we need the annotation. | |
4372 | ||
4373 | if Known_Static_RM_Size (Source) | |
4374 | and then Known_Static_RM_Size (Target) | |
4375 | then | |
4376 | null; | |
4377 | else | |
4378 | Back_Annotate_Rep_Info := True; | |
4379 | end if; | |
4380 | end if; | |
d6f39728 | 4381 | |
fdd294d1 | 4382 | -- If unchecked conversion to access type, and access type is declared |
4383 | -- in the same unit as the unchecked conversion, then set the | |
4384 | -- No_Strict_Aliasing flag (no strict aliasing is implicit in this | |
4385 | -- situation). | |
28ed91d4 | 4386 | |
4387 | if Is_Access_Type (Target) and then | |
4388 | In_Same_Source_Unit (Target, N) | |
4389 | then | |
4390 | Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); | |
4391 | end if; | |
3d875462 | 4392 | |
4393 | -- Generate N_Validate_Unchecked_Conversion node for back end in | |
4394 | -- case the back end needs to perform special validation checks. | |
4395 | ||
fdd294d1 | 4396 | -- Shouldn't this be in Exp_Ch13, since the check only gets done |
3d875462 | 4397 | -- if we have full expansion and the back end is called ??? |
4398 | ||
4399 | Vnode := | |
4400 | Make_Validate_Unchecked_Conversion (Sloc (N)); | |
4401 | Set_Source_Type (Vnode, Source); | |
4402 | Set_Target_Type (Vnode, Target); | |
4403 | ||
fdd294d1 | 4404 | -- If the unchecked conversion node is in a list, just insert before it. |
4405 | -- If not we have some strange case, not worth bothering about. | |
3d875462 | 4406 | |
4407 | if Is_List_Member (N) then | |
d6f39728 | 4408 | Insert_After (N, Vnode); |
4409 | end if; | |
4410 | end Validate_Unchecked_Conversion; | |
4411 | ||
4412 | ------------------------------------ | |
4413 | -- Validate_Unchecked_Conversions -- | |
4414 | ------------------------------------ | |
4415 | ||
4416 | procedure Validate_Unchecked_Conversions is | |
4417 | begin | |
4418 | for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop | |
4419 | declare | |
4420 | T : UC_Entry renames Unchecked_Conversions.Table (N); | |
4421 | ||
4422 | Enode : constant Node_Id := T.Enode; | |
4423 | Source : constant Entity_Id := T.Source; | |
4424 | Target : constant Entity_Id := T.Target; | |
4425 | ||
4426 | Source_Siz : Uint; | |
4427 | Target_Siz : Uint; | |
4428 | ||
4429 | begin | |
fdd294d1 | 4430 | -- This validation check, which warns if we have unequal sizes for |
4431 | -- unchecked conversion, and thus potentially implementation | |
d6f39728 | 4432 | -- dependent semantics, is one of the few occasions on which we |
fdd294d1 | 4433 | -- use the official RM size instead of Esize. See description in |
4434 | -- Einfo "Handling of Type'Size Values" for details. | |
d6f39728 | 4435 | |
f15731c4 | 4436 | if Serious_Errors_Detected = 0 |
d6f39728 | 4437 | and then Known_Static_RM_Size (Source) |
4438 | and then Known_Static_RM_Size (Target) | |
4439 | then | |
4440 | Source_Siz := RM_Size (Source); | |
4441 | Target_Siz := RM_Size (Target); | |
4442 | ||
4443 | if Source_Siz /= Target_Siz then | |
d6f39728 | 4444 | Error_Msg_N |
fbc67f84 | 4445 | ("?types for unchecked conversion have different sizes!", |
d6f39728 | 4446 | Enode); |
4447 | ||
4448 | if All_Errors_Mode then | |
4449 | Error_Msg_Name_1 := Chars (Source); | |
4450 | Error_Msg_Uint_1 := Source_Siz; | |
4451 | Error_Msg_Name_2 := Chars (Target); | |
4452 | Error_Msg_Uint_2 := Target_Siz; | |
4453 | Error_Msg_N | |
4454 | ("\size of % is ^, size of % is ^?", Enode); | |
4455 | ||
4456 | Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); | |
4457 | ||
4458 | if Is_Discrete_Type (Source) | |
4459 | and then Is_Discrete_Type (Target) | |
4460 | then | |
4461 | if Source_Siz > Target_Siz then | |
4462 | Error_Msg_N | |
fbc67f84 | 4463 | ("\?^ high order bits of source will be ignored!", |
d6f39728 | 4464 | Enode); |
4465 | ||
9dfe12ae | 4466 | elsif Is_Unsigned_Type (Source) then |
d6f39728 | 4467 | Error_Msg_N |
fbc67f84 | 4468 | ("\?source will be extended with ^ high order " & |
4469 | "zero bits?!", Enode); | |
d6f39728 | 4470 | |
4471 | else | |
4472 | Error_Msg_N | |
fbc67f84 | 4473 | ("\?source will be extended with ^ high order " & |
4474 | "sign bits!", | |
d6f39728 | 4475 | Enode); |
4476 | end if; | |
4477 | ||
4478 | elsif Source_Siz < Target_Siz then | |
4479 | if Is_Discrete_Type (Target) then | |
4480 | if Bytes_Big_Endian then | |
4481 | Error_Msg_N | |
fbc67f84 | 4482 | ("\?target value will include ^ undefined " & |
4483 | "low order bits!", | |
d6f39728 | 4484 | Enode); |
4485 | else | |
4486 | Error_Msg_N | |
fbc67f84 | 4487 | ("\?target value will include ^ undefined " & |
4488 | "high order bits!", | |
d6f39728 | 4489 | Enode); |
4490 | end if; | |
4491 | ||
4492 | else | |
4493 | Error_Msg_N | |
fbc67f84 | 4494 | ("\?^ trailing bits of target value will be " & |
4495 | "undefined!", Enode); | |
d6f39728 | 4496 | end if; |
4497 | ||
4498 | else pragma Assert (Source_Siz > Target_Siz); | |
4499 | Error_Msg_N | |
fbc67f84 | 4500 | ("\?^ trailing bits of source will be ignored!", |
d6f39728 | 4501 | Enode); |
4502 | end if; | |
4503 | end if; | |
d6f39728 | 4504 | end if; |
4505 | end if; | |
4506 | ||
4507 | -- If both types are access types, we need to check the alignment. | |
4508 | -- If the alignment of both is specified, we can do it here. | |
4509 | ||
f15731c4 | 4510 | if Serious_Errors_Detected = 0 |
d6f39728 | 4511 | and then Ekind (Source) in Access_Kind |
4512 | and then Ekind (Target) in Access_Kind | |
4513 | and then Target_Strict_Alignment | |
4514 | and then Present (Designated_Type (Source)) | |
4515 | and then Present (Designated_Type (Target)) | |
4516 | then | |
4517 | declare | |
4518 | D_Source : constant Entity_Id := Designated_Type (Source); | |
4519 | D_Target : constant Entity_Id := Designated_Type (Target); | |
4520 | ||
4521 | begin | |
4522 | if Known_Alignment (D_Source) | |
4523 | and then Known_Alignment (D_Target) | |
4524 | then | |
4525 | declare | |
4526 | Source_Align : constant Uint := Alignment (D_Source); | |
4527 | Target_Align : constant Uint := Alignment (D_Target); | |
4528 | ||
4529 | begin | |
4530 | if Source_Align < Target_Align | |
4531 | and then not Is_Tagged_Type (D_Source) | |
4532 | then | |
d6f39728 | 4533 | Error_Msg_Uint_1 := Target_Align; |
4534 | Error_Msg_Uint_2 := Source_Align; | |
4535 | Error_Msg_Node_2 := D_Source; | |
4536 | Error_Msg_NE | |
fbc67f84 | 4537 | ("?alignment of & (^) is stricter than " & |
4538 | "alignment of & (^)!", Enode, D_Target); | |
d6f39728 | 4539 | |
4540 | if All_Errors_Mode then | |
4541 | Error_Msg_N | |
fbc67f84 | 4542 | ("\?resulting access value may have invalid " & |
4543 | "alignment!", Enode); | |
d6f39728 | 4544 | end if; |
d6f39728 | 4545 | end if; |
4546 | end; | |
4547 | end if; | |
4548 | end; | |
4549 | end if; | |
4550 | end; | |
4551 | end loop; | |
4552 | end Validate_Unchecked_Conversions; | |
4553 | ||
d6f39728 | 4554 | end Sem_Ch13; |