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