]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- C S T A N D -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
bb10b891 | 9 | -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
f8726f2b | 27 | with Back_End; use Back_End; |
70482933 RK |
28 | with Csets; use Csets; |
29 | with Debug; use Debug; | |
30 | with Einfo; use Einfo; | |
31 | with Layout; use Layout; | |
32 | with Namet; use Namet; | |
33 | with Nlists; use Nlists; | |
34 | with Nmake; use Nmake; | |
35 | with Opt; use Opt; | |
9596236a | 36 | with Output; use Output; |
fbf5a39b | 37 | with Targparm; use Targparm; |
70482933 RK |
38 | with Tbuild; use Tbuild; |
39 | with Ttypes; use Ttypes; | |
f1f9fe30 | 40 | with Scn; |
70482933 RK |
41 | with Sem_Mech; use Sem_Mech; |
42 | with Sem_Util; use Sem_Util; | |
43 | with Sinfo; use Sinfo; | |
44 | with Snames; use Snames; | |
45 | with Stand; use Stand; | |
46 | with Uintp; use Uintp; | |
47 | with Urealp; use Urealp; | |
48 | ||
49 | package body CStand is | |
50 | ||
51 | Stloc : constant Source_Ptr := Standard_Location; | |
52 | Staloc : constant Source_Ptr := Standard_ASCII_Location; | |
53 | -- Standard abbreviations used throughout this package | |
54 | ||
f8726f2b AC |
55 | Back_End_Float_Types : List_Id := No_List; |
56 | -- List used for any floating point supported by the back end. This needs | |
57 | -- to be at the library level, because the call back procedures retrieving | |
58 | -- this information are at that level. | |
59 | ||
70482933 RK |
60 | ----------------------- |
61 | -- Local Subprograms -- | |
62 | ----------------------- | |
63 | ||
f8726f2b AC |
64 | procedure Build_Float_Type |
65 | (E : Entity_Id; | |
66 | Siz : Int; | |
67 | Rep : Float_Rep_Kind; | |
68 | Digs : Int); | |
70482933 | 69 | -- Procedure to build standard predefined float base type. The first |
f8726f2b AC |
70 | -- parameter is the entity for the type, and the second parameter is the |
71 | -- size in bits. The third parameter indicates the kind of representation | |
72 | -- to be used. The fourth parameter is the digits value. Each type | |
73 | -- is added to the list of predefined floating point types. | |
70482933 RK |
74 | |
75 | procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int); | |
76 | -- Procedure to build standard predefined signed integer subtype. The | |
77 | -- first parameter is the entity for the subtype. The second parameter | |
78 | -- is the size in bits. The corresponding base type is not built by | |
79 | -- this routine but instead must be built by the caller where needed. | |
80 | ||
f8726f2b AC |
81 | procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id); |
82 | -- Build a floating point type, copying representation details from From. | |
83 | -- This is used to create predefined floating point types based on | |
84 | -- available types in the back end. | |
85 | ||
70482933 RK |
86 | procedure Create_Operators; |
87 | -- Make entries for each of the predefined operators in Standard | |
88 | ||
89 | procedure Create_Unconstrained_Base_Type | |
90 | (E : Entity_Id; | |
91 | K : Entity_Kind); | |
92 | -- The predefined signed integer types are constrained subtypes which | |
93 | -- must have a corresponding unconstrained base type. This type is almost | |
94 | -- useless. The only place it has semantics is Subtypes_Statically_Match. | |
95 | -- Consequently, we arrange for it to be identical apart from the setting | |
96 | -- of the constrained bit. This routine takes an entity E for the Type, | |
97 | -- copies it to estabish the base type, then resets the Ekind of the | |
98 | -- original entity to K (the Ekind for the subtype). The Etype field of | |
99 | -- E is set by the call (to point to the created base type entity), and | |
100 | -- also the Is_Constrained flag of E is set. | |
101 | -- | |
102 | -- To understand the exact requirement for this, see RM 3.5.4(11) which | |
103 | -- makes it clear that Integer, for example, is constrained, with the | |
104 | -- constraint bounds matching the bounds of the (unconstrained) base | |
105 | -- type. The point is that Integer and Integer'Base have identical | |
106 | -- bounds, but do not statically match, since a subtype with constraints | |
107 | -- never matches a subtype with no constraints. | |
108 | ||
f8726f2b AC |
109 | function Find_Back_End_Float_Type (Name : String) return Entity_Id; |
110 | -- Return the first float type in Back_End_Float_Types with the given name. | |
111 | -- Names of entities in back end types, are either type names of C | |
112 | -- predefined types (all lower case), or mode names (upper case). | |
113 | -- These are not generally valid identifier names. | |
114 | ||
70482933 RK |
115 | function Identifier_For (S : Standard_Entity_Type) return Node_Id; |
116 | -- Returns an identifier node with the same name as the defining | |
117 | -- identifier corresponding to the given Standard_Entity_Type value | |
118 | ||
119 | procedure Make_Component | |
120 | (Rec : Entity_Id; | |
121 | Typ : Entity_Id; | |
122 | Nam : String); | |
123 | -- Build a record component with the given type and name, and append to | |
124 | -- the list of components of Rec. | |
125 | ||
126 | function Make_Formal | |
127 | (Typ : Entity_Id; | |
891a6e79 | 128 | Formal_Name : String) return Entity_Id; |
70482933 RK |
129 | -- Construct entity for subprogram formal with given name and type |
130 | ||
131 | function Make_Integer (V : Uint) return Node_Id; | |
132 | -- Builds integer literal with given value | |
133 | ||
134 | procedure Make_Name (Id : Entity_Id; Nam : String); | |
135 | -- Make an entry in the names table for Nam, and set as Chars field of Id | |
136 | ||
137 | function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id; | |
a2cb348e | 138 | -- Build entity for standard operator with given name and type |
70482933 RK |
139 | |
140 | function New_Standard_Entity | |
891a6e79 | 141 | (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id; |
70482933 RK |
142 | -- Builds a new entity for Standard |
143 | ||
9596236a AC |
144 | procedure Print_Standard; |
145 | -- Print representation of package Standard if switch set | |
146 | ||
f8726f2b AC |
147 | procedure Register_Float_Type |
148 | (Name : C_String; -- Nul-terminated string with name of type | |
149 | Digs : Natural; -- Nr or digits for floating point, 0 otherwise | |
150 | Complex : Boolean; -- True iff type has real and imaginary parts | |
151 | Count : Natural; -- Number of elements in vector, 0 otherwise | |
152 | Float_Rep : Float_Rep_Kind; -- Representation used for fpt type | |
153 | Size : Positive; -- Size of representation in bits | |
154 | Alignment : Natural); -- Required alignment in bits | |
155 | pragma Convention (C, Register_Float_Type); | |
156 | -- Call back to allow the back end to register available types. | |
157 | -- This call back currently creates predefined floating point base types | |
158 | -- for any floating point types reported by the back end, and adds them | |
159 | -- to the list of predefined float types. | |
160 | ||
70482933 RK |
161 | procedure Set_Integer_Bounds |
162 | (Id : Entity_Id; | |
163 | Typ : Entity_Id; | |
164 | Lb : Uint; | |
165 | Hb : Uint); | |
166 | -- Procedure to set bounds for integer type or subtype. Id is the entity | |
167 | -- whose bounds and type are to be set. The Typ parameter is the Etype | |
168 | -- value for the entity (which will be the same as Id for all predefined | |
169 | -- integer base types. The third and fourth parameters are the bounds. | |
170 | ||
171 | ---------------------- | |
172 | -- Build_Float_Type -- | |
173 | ---------------------- | |
174 | ||
f8726f2b AC |
175 | procedure Build_Float_Type |
176 | (E : Entity_Id; | |
177 | Siz : Int; | |
178 | Rep : Float_Rep_Kind; | |
179 | Digs : Int) | |
180 | is | |
70482933 RK |
181 | begin |
182 | Set_Type_Definition (Parent (E), | |
183 | Make_Floating_Point_Definition (Stloc, | |
184 | Digits_Expression => Make_Integer (UI_From_Int (Digs)))); | |
23c799b1 | 185 | |
70482933 RK |
186 | Set_Ekind (E, E_Floating_Point_Type); |
187 | Set_Etype (E, E); | |
f8726f2b | 188 | Set_Float_Rep (E, Rep); |
70482933 | 189 | Init_Size (E, Siz); |
15ce9ca2 | 190 | Set_Elem_Alignment (E); |
70482933 RK |
191 | Init_Digits_Value (E, Digs); |
192 | Set_Float_Bounds (E); | |
193 | Set_Is_Frozen (E); | |
194 | Set_Is_Public (E); | |
195 | Set_Size_Known_At_Compile_Time (E); | |
196 | end Build_Float_Type; | |
197 | ||
f8726f2b AC |
198 | ------------------------ |
199 | -- Find_Back_End_Float_Type -- | |
200 | ------------------------ | |
201 | ||
202 | function Find_Back_End_Float_Type (Name : String) return Entity_Id is | |
203 | N : Node_Id := First (Back_End_Float_Types); | |
204 | ||
205 | begin | |
206 | while Present (N) and then Get_Name_String (Chars (N)) /= Name loop | |
207 | Next (N); | |
208 | end loop; | |
209 | ||
210 | return Entity_Id (N); | |
211 | end Find_Back_End_Float_Type; | |
212 | ||
70482933 RK |
213 | ------------------------------- |
214 | -- Build_Signed_Integer_Type -- | |
215 | ------------------------------- | |
216 | ||
217 | procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int) is | |
218 | U2Siz1 : constant Uint := 2 ** (Siz - 1); | |
219 | Lbound : constant Uint := -U2Siz1; | |
220 | Ubound : constant Uint := U2Siz1 - 1; | |
221 | ||
222 | begin | |
223 | Set_Type_Definition (Parent (E), | |
224 | Make_Signed_Integer_Type_Definition (Stloc, | |
225 | Low_Bound => Make_Integer (Lbound), | |
226 | High_Bound => Make_Integer (Ubound))); | |
227 | ||
228 | Set_Ekind (E, E_Signed_Integer_Type); | |
229 | Set_Etype (E, E); | |
230 | Init_Size (E, Siz); | |
15ce9ca2 | 231 | Set_Elem_Alignment (E); |
70482933 RK |
232 | Set_Integer_Bounds (E, E, Lbound, Ubound); |
233 | Set_Is_Frozen (E); | |
234 | Set_Is_Public (E); | |
235 | Set_Is_Known_Valid (E); | |
236 | Set_Size_Known_At_Compile_Time (E); | |
237 | end Build_Signed_Integer_Type; | |
238 | ||
f8726f2b AC |
239 | --------------------- |
240 | -- Copy_Float_Type -- | |
241 | --------------------- | |
242 | ||
243 | procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id) is | |
244 | begin | |
245 | Build_Float_Type (To, UI_To_Int (Esize (From)), Float_Rep (From), | |
246 | UI_To_Int (Digits_Value (From))); | |
247 | end Copy_Float_Type; | |
248 | ||
70482933 RK |
249 | ---------------------- |
250 | -- Create_Operators -- | |
251 | ---------------------- | |
252 | ||
253 | -- Each operator has an abbreviated signature. The formals have the names | |
254 | -- LEFT and RIGHT. Their types are not actually used for resolution. | |
255 | ||
256 | procedure Create_Operators is | |
257 | Op_Node : Entity_Id; | |
258 | ||
87b3f81f AC |
259 | -- The following tables define the binary and unary operators and their |
260 | -- corresponding result type. | |
70482933 RK |
261 | |
262 | Binary_Ops : constant array (S_Binary_Ops) of Name_Id := | |
87b3f81f AC |
263 | |
264 | -- There is one entry here for each binary operator, except for the | |
82c80734 RD |
265 | -- case of concatenation, where there are three entries, one for a |
266 | -- String result, one for Wide_String, and one for Wide_Wide_String. | |
87b3f81f AC |
267 | |
268 | (Name_Op_Add, | |
269 | Name_Op_And, | |
270 | Name_Op_Concat, | |
271 | Name_Op_Concat, | |
82c80734 | 272 | Name_Op_Concat, |
87b3f81f AC |
273 | Name_Op_Divide, |
274 | Name_Op_Eq, | |
275 | Name_Op_Expon, | |
276 | Name_Op_Ge, | |
277 | Name_Op_Gt, | |
278 | Name_Op_Le, | |
279 | Name_Op_Lt, | |
280 | Name_Op_Mod, | |
281 | Name_Op_Multiply, | |
282 | Name_Op_Ne, | |
283 | Name_Op_Or, | |
284 | Name_Op_Rem, | |
285 | Name_Op_Subtract, | |
286 | Name_Op_Xor); | |
70482933 RK |
287 | |
288 | Bin_Op_Types : constant array (S_Binary_Ops) of Entity_Id := | |
87b3f81f AC |
289 | |
290 | -- This table has the corresponding result types. The entries are | |
291 | -- ordered so they correspond to the Binary_Ops array above. | |
292 | ||
82c80734 RD |
293 | (Universal_Integer, -- Add |
294 | Standard_Boolean, -- And | |
295 | Standard_String, -- Concat (String) | |
296 | Standard_Wide_String, -- Concat (Wide_String) | |
297 | Standard_Wide_Wide_String, -- Concat (Wide_Wide_String) | |
298 | Universal_Integer, -- Divide | |
299 | Standard_Boolean, -- Eq | |
300 | Universal_Integer, -- Expon | |
301 | Standard_Boolean, -- Ge | |
302 | Standard_Boolean, -- Gt | |
303 | Standard_Boolean, -- Le | |
304 | Standard_Boolean, -- Lt | |
305 | Universal_Integer, -- Mod | |
306 | Universal_Integer, -- Multiply | |
307 | Standard_Boolean, -- Ne | |
308 | Standard_Boolean, -- Or | |
309 | Universal_Integer, -- Rem | |
310 | Universal_Integer, -- Subtract | |
311 | Standard_Boolean); -- Xor | |
70482933 RK |
312 | |
313 | Unary_Ops : constant array (S_Unary_Ops) of Name_Id := | |
87b3f81f AC |
314 | |
315 | -- There is one entry here for each unary operator | |
316 | ||
317 | (Name_Op_Abs, | |
318 | Name_Op_Subtract, | |
319 | Name_Op_Not, | |
320 | Name_Op_Add); | |
70482933 RK |
321 | |
322 | Unary_Op_Types : constant array (S_Unary_Ops) of Entity_Id := | |
70482933 | 323 | |
87b3f81f AC |
324 | -- This table has the corresponding result types. The entries are |
325 | -- ordered so they correspond to the Unary_Ops array above. | |
326 | ||
327 | (Universal_Integer, -- Abs | |
328 | Universal_Integer, -- Subtract | |
329 | Standard_Boolean, -- Not | |
330 | Universal_Integer); -- Add | |
70482933 RK |
331 | |
332 | begin | |
333 | for J in S_Binary_Ops loop | |
334 | Op_Node := New_Operator (Binary_Ops (J), Bin_Op_Types (J)); | |
335 | SE (J) := Op_Node; | |
336 | Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node); | |
337 | Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); | |
338 | end loop; | |
339 | ||
340 | for J in S_Unary_Ops loop | |
341 | Op_Node := New_Operator (Unary_Ops (J), Unary_Op_Types (J)); | |
342 | SE (J) := Op_Node; | |
343 | Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); | |
344 | end loop; | |
345 | ||
346 | -- For concatenation, we create a separate operator for each | |
347 | -- array type. This simplifies the resolution of the component- | |
348 | -- component concatenation operation. In Standard, we set the types | |
82c80734 | 349 | -- of the formals for string, wide [wide]_string, concatenations. |
70482933 RK |
350 | |
351 | Set_Etype (First_Entity (Standard_Op_Concat), Standard_String); | |
352 | Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String); | |
353 | ||
354 | Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String); | |
355 | Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); | |
82c80734 RD |
356 | |
357 | Set_Etype (First_Entity (Standard_Op_Concatww), | |
879e23f0 | 358 | Standard_Wide_Wide_String); |
82c80734 RD |
359 | |
360 | Set_Etype (Last_Entity (Standard_Op_Concatww), | |
879e23f0 | 361 | Standard_Wide_Wide_String); |
70482933 RK |
362 | end Create_Operators; |
363 | ||
364 | --------------------- | |
365 | -- Create_Standard -- | |
366 | --------------------- | |
367 | ||
368 | -- The tree for the package Standard is prefixed to all compilations. | |
369 | -- Several entities required by semantic analysis are denoted by global | |
f8726f2b AC |
370 | -- variables that are initialized to point to the corresponding occurrences |
371 | -- in Standard. The visible entities of Standard are created here. Special | |
372 | -- entities maybe created here as well or may be created from the semantics | |
373 | -- module. By not adding them to the Decls list of Standard they will not | |
374 | -- be visible to Ada programs. | |
70482933 RK |
375 | |
376 | procedure Create_Standard is | |
91b1417d | 377 | Decl_S : constant List_Id := New_List; |
70482933 RK |
378 | -- List of declarations in Standard |
379 | ||
91b1417d | 380 | Decl_A : constant List_Id := New_List; |
70482933 RK |
381 | -- List of declarations in ASCII |
382 | ||
383 | Decl : Node_Id; | |
384 | Pspec : Node_Id; | |
385 | Tdef_Node : Node_Id; | |
386 | Ident_Node : Node_Id; | |
387 | Ccode : Char_Code; | |
388 | E_Id : Entity_Id; | |
389 | R_Node : Node_Id; | |
390 | B_Node : Node_Id; | |
391 | ||
392 | procedure Build_Exception (S : Standard_Entity_Type); | |
393 | -- Procedure to declare given entity as an exception | |
394 | ||
f8726f2b AC |
395 | procedure Create_Back_End_Float_Types; |
396 | -- Initialize the Back_End_Float_Types list by having the back end | |
397 | -- enumerate all available types and building type entities for them. | |
398 | ||
399 | procedure Create_Float_Types; | |
400 | -- Creates entities for all predefined floating point types, and | |
401 | -- adds these to the Predefined_Float_Types list in package Standard. | |
402 | ||
17bb3f18 | 403 | procedure Pack_String_Type (String_Type : Entity_Id); |
5b599df4 AC |
404 | -- Generate proper tree for pragma Pack that applies to given type, and |
405 | -- mark type as having the pragma. | |
17bb3f18 | 406 | |
70482933 RK |
407 | --------------------- |
408 | -- Build_Exception -- | |
409 | --------------------- | |
410 | ||
411 | procedure Build_Exception (S : Standard_Entity_Type) is | |
412 | begin | |
413 | Set_Ekind (Standard_Entity (S), E_Exception); | |
414 | Set_Etype (Standard_Entity (S), Standard_Exception_Type); | |
415 | Set_Exception_Code (Standard_Entity (S), Uint_0); | |
416 | Set_Is_Public (Standard_Entity (S), True); | |
417 | ||
418 | Decl := | |
419 | Make_Exception_Declaration (Stloc, | |
420 | Defining_Identifier => Standard_Entity (S)); | |
421 | Append (Decl, Decl_S); | |
422 | end Build_Exception; | |
423 | ||
f8726f2b AC |
424 | --------------------------- |
425 | -- Create_Back_End_Float_Types -- | |
426 | --------------------------- | |
427 | ||
428 | procedure Create_Back_End_Float_Types is | |
429 | begin | |
430 | Back_End_Float_Types := No_List; | |
431 | Register_Back_End_Types (Register_Float_Type'Access); | |
432 | end Create_Back_End_Float_Types; | |
433 | ||
434 | ------------------------ | |
435 | -- Create_Float_Types -- | |
436 | ------------------------ | |
437 | ||
438 | procedure Create_Float_Types is | |
439 | begin | |
440 | -- Create type definition nodes for predefined float types | |
441 | ||
442 | Copy_Float_Type (Standard_Short_Float, | |
443 | Find_Back_End_Float_Type ("float")); | |
444 | ||
445 | Copy_Float_Type (Standard_Float, Standard_Short_Float); | |
446 | ||
447 | Copy_Float_Type (Standard_Long_Float, | |
448 | Find_Back_End_Float_Type ("double")); | |
449 | ||
450 | Predefined_Float_Types := New_List | |
451 | (Standard_Short_Float, Standard_Float, Standard_Long_Float); | |
452 | ||
453 | -- ??? For now, we don't have a good way to tell the widest float | |
454 | -- type with hardware support. Basically, GCC knows the size of that | |
455 | -- type, but on x86-64 there often are two or three 128-bit types, | |
456 | -- one double extended that has 18 decimal digits, a 128-bit quad | |
457 | -- precision type with 33 digits and possibly a 128-bit decimal float | |
458 | -- type with 34 digits. As a workaround, we define Long_Long_Float as | |
459 | -- C's "long double" if that type exists and has at most 18 digits, | |
460 | -- or otherwise the same as Long_Float. | |
461 | ||
462 | declare | |
463 | Max_HW_Digs : constant := 18; | |
464 | LF_Digs : constant Pos := | |
465 | UI_To_Int (Digits_Value (Standard_Long_Float)); | |
466 | LLF : Entity_Id := Find_Back_End_Float_Type ("long double"); | |
467 | N : Node_Id := First (Back_End_Float_Types); | |
468 | ||
469 | begin | |
15b682ca | 470 | if Present (LLF) and then Digits_Value (LLF) > Max_HW_Digs then |
f8726f2b AC |
471 | LLF := Empty; |
472 | end if; | |
473 | ||
474 | while No (LLF) and then Present (N) loop | |
475 | if UI_To_Int (Digits_Value (N)) in LF_Digs + 1 .. Max_HW_Digs | |
476 | and then Machine_Radix_Value (N) = Uint_2 | |
477 | then | |
478 | LLF := N; | |
479 | end if; | |
480 | ||
481 | Next (N); | |
482 | end loop; | |
483 | ||
484 | if No (LLF) then | |
485 | LLF := Standard_Long_Float; | |
486 | end if; | |
487 | ||
488 | Copy_Float_Type (Standard_Long_Long_Float, LLF); | |
489 | ||
490 | Append (Standard_Long_Long_Float, Predefined_Float_Types); | |
491 | end; | |
492 | ||
493 | Append_List (Back_End_Float_Types, To => Predefined_Float_Types); | |
494 | end Create_Float_Types; | |
495 | ||
17bb3f18 RD |
496 | ---------------------- |
497 | -- Pack_String_Type -- | |
498 | ---------------------- | |
499 | ||
500 | procedure Pack_String_Type (String_Type : Entity_Id) is | |
501 | Prag : constant Node_Id := | |
879e23f0 AC |
502 | Make_Pragma (Stloc, |
503 | Chars => Name_Pack, | |
504 | Pragma_Argument_Associations => | |
505 | New_List ( | |
506 | Make_Pragma_Argument_Association (Stloc, | |
507 | Expression => | |
508 | New_Occurrence_Of (String_Type, Stloc)))); | |
17bb3f18 RD |
509 | begin |
510 | Append (Prag, Decl_S); | |
511 | Record_Rep_Item (String_Type, Prag); | |
5b599df4 | 512 | Set_Has_Pragma_Pack (String_Type, True); |
17bb3f18 RD |
513 | end Pack_String_Type; |
514 | ||
70482933 RK |
515 | -- Start of processing for Create_Standard |
516 | ||
517 | begin | |
f1f9fe30 AC |
518 | -- Initialize scanner for internal scans of literals |
519 | ||
520 | Scn.Initialize_Scanner (No_Unit, Internal_Source_File); | |
70482933 RK |
521 | |
522 | -- First step is to create defining identifiers for each entity | |
523 | ||
524 | for S in Standard_Entity_Type loop | |
525 | declare | |
526 | S_Name : constant String := Standard_Entity_Type'Image (S); | |
527 | -- Name of entity (note we skip S_ at the start) | |
528 | ||
529 | Ident_Node : Node_Id; | |
530 | -- Defining identifier node | |
531 | ||
532 | begin | |
533 | Ident_Node := New_Standard_Entity; | |
534 | Make_Name (Ident_Node, S_Name (3 .. S_Name'Length)); | |
535 | Standard_Entity (S) := Ident_Node; | |
536 | end; | |
537 | end loop; | |
538 | ||
539 | -- Create package declaration node for package Standard | |
540 | ||
541 | Standard_Package_Node := New_Node (N_Package_Declaration, Stloc); | |
542 | ||
543 | Pspec := New_Node (N_Package_Specification, Stloc); | |
544 | Set_Specification (Standard_Package_Node, Pspec); | |
545 | ||
546 | Set_Defining_Unit_Name (Pspec, Standard_Standard); | |
547 | Set_Visible_Declarations (Pspec, Decl_S); | |
548 | ||
549 | Set_Ekind (Standard_Standard, E_Package); | |
550 | Set_Is_Pure (Standard_Standard); | |
551 | Set_Is_Compilation_Unit (Standard_Standard); | |
552 | ||
454a86dc | 553 | -- Create type/subtype declaration nodes for standard types |
70482933 RK |
554 | |
555 | for S in S_Types loop | |
454a86dc RD |
556 | |
557 | -- Subtype declaration case | |
558 | ||
559 | if S = S_Natural or else S = S_Positive then | |
560 | Decl := New_Node (N_Subtype_Declaration, Stloc); | |
561 | Set_Subtype_Indication (Decl, | |
562 | New_Occurrence_Of (Standard_Integer, Stloc)); | |
563 | ||
564 | -- Full type declaration case | |
565 | ||
566 | else | |
567 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
568 | end if; | |
569 | ||
70482933 RK |
570 | Set_Is_Frozen (Standard_Entity (S)); |
571 | Set_Is_Public (Standard_Entity (S)); | |
454a86dc | 572 | Set_Defining_Identifier (Decl, Standard_Entity (S)); |
70482933 RK |
573 | Append (Decl, Decl_S); |
574 | end loop; | |
575 | ||
f8726f2b AC |
576 | Create_Back_End_Float_Types; |
577 | ||
70482933 RK |
578 | -- Create type definition node for type Boolean. The Size is set to |
579 | -- 1 as required by Ada 95 and current ARG interpretations for Ada/83. | |
580 | ||
581 | -- Note: Object_Size of Boolean is 8. This means that we do NOT in | |
582 | -- general know that Boolean variables have valid values, so we do | |
583 | -- not set the Is_Known_Valid flag. | |
584 | ||
585 | Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); | |
586 | Set_Literals (Tdef_Node, New_List); | |
587 | Append (Standard_False, Literals (Tdef_Node)); | |
588 | Append (Standard_True, Literals (Tdef_Node)); | |
589 | Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node); | |
590 | ||
591 | Set_Ekind (Standard_Boolean, E_Enumeration_Type); | |
592 | Set_First_Literal (Standard_Boolean, Standard_False); | |
593 | Set_Etype (Standard_Boolean, Standard_Boolean); | |
07fc65c4 | 594 | Init_Esize (Standard_Boolean, Standard_Character_Size); |
70482933 | 595 | Init_RM_Size (Standard_Boolean, 1); |
15ce9ca2 | 596 | Set_Elem_Alignment (Standard_Boolean); |
70482933 RK |
597 | |
598 | Set_Is_Unsigned_Type (Standard_Boolean); | |
599 | Set_Size_Known_At_Compile_Time (Standard_Boolean); | |
bd29d519 | 600 | Set_Has_Pragma_Ordered (Standard_Boolean); |
70482933 RK |
601 | |
602 | Set_Ekind (Standard_True, E_Enumeration_Literal); | |
603 | Set_Etype (Standard_True, Standard_Boolean); | |
604 | Set_Enumeration_Pos (Standard_True, Uint_1); | |
605 | Set_Enumeration_Rep (Standard_True, Uint_1); | |
606 | Set_Is_Known_Valid (Standard_True, True); | |
607 | ||
608 | Set_Ekind (Standard_False, E_Enumeration_Literal); | |
609 | Set_Etype (Standard_False, Standard_Boolean); | |
610 | Set_Enumeration_Pos (Standard_False, Uint_0); | |
611 | Set_Enumeration_Rep (Standard_False, Uint_0); | |
612 | Set_Is_Known_Valid (Standard_False, True); | |
613 | ||
614 | -- For the bounds of Boolean, we create a range node corresponding to | |
615 | ||
616 | -- range False .. True | |
617 | ||
618 | -- where the occurrences of the literals must point to the | |
a99ada67 | 619 | -- corresponding definition. |
70482933 RK |
620 | |
621 | R_Node := New_Node (N_Range, Stloc); | |
622 | B_Node := New_Node (N_Identifier, Stloc); | |
623 | Set_Chars (B_Node, Chars (Standard_False)); | |
624 | Set_Entity (B_Node, Standard_False); | |
625 | Set_Etype (B_Node, Standard_Boolean); | |
626 | Set_Is_Static_Expression (B_Node); | |
627 | Set_Low_Bound (R_Node, B_Node); | |
628 | ||
629 | B_Node := New_Node (N_Identifier, Stloc); | |
630 | Set_Chars (B_Node, Chars (Standard_True)); | |
631 | Set_Entity (B_Node, Standard_True); | |
632 | Set_Etype (B_Node, Standard_Boolean); | |
633 | Set_Is_Static_Expression (B_Node); | |
634 | Set_High_Bound (R_Node, B_Node); | |
635 | ||
636 | Set_Scalar_Range (Standard_Boolean, R_Node); | |
637 | Set_Etype (R_Node, Standard_Boolean); | |
638 | Set_Parent (R_Node, Standard_Boolean); | |
639 | ||
aa720a54 AC |
640 | -- Record entity identifiers for boolean literals in the |
641 | -- Boolean_Literals array, for easy reference during expansion. | |
642 | ||
643 | Boolean_Literals := (False => Standard_False, True => Standard_True); | |
644 | ||
70482933 RK |
645 | -- Create type definition nodes for predefined integer types |
646 | ||
647 | Build_Signed_Integer_Type | |
648 | (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size); | |
649 | ||
650 | Build_Signed_Integer_Type | |
651 | (Standard_Short_Integer, Standard_Short_Integer_Size); | |
652 | ||
653 | Build_Signed_Integer_Type | |
654 | (Standard_Integer, Standard_Integer_Size); | |
655 | ||
656 | declare | |
657 | LIS : Nat; | |
70482933 RK |
658 | begin |
659 | if Debug_Flag_M then | |
660 | LIS := 64; | |
661 | else | |
662 | LIS := Standard_Long_Integer_Size; | |
663 | end if; | |
664 | ||
665 | Build_Signed_Integer_Type (Standard_Long_Integer, LIS); | |
666 | end; | |
667 | ||
668 | Build_Signed_Integer_Type | |
669 | (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); | |
670 | ||
671 | Create_Unconstrained_Base_Type | |
672 | (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); | |
673 | ||
674 | Create_Unconstrained_Base_Type | |
675 | (Standard_Short_Integer, E_Signed_Integer_Subtype); | |
676 | ||
677 | Create_Unconstrained_Base_Type | |
678 | (Standard_Integer, E_Signed_Integer_Subtype); | |
679 | ||
680 | Create_Unconstrained_Base_Type | |
681 | (Standard_Long_Integer, E_Signed_Integer_Subtype); | |
682 | ||
683 | Create_Unconstrained_Base_Type | |
684 | (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); | |
685 | ||
f8726f2b | 686 | Create_Float_Types; |
70482933 RK |
687 | |
688 | -- Create type definition node for type Character. Note that we do not | |
689 | -- set the Literals field, since type Character is handled with special | |
690 | -- routine that do not need a literal list. | |
691 | ||
692 | Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); | |
693 | Set_Type_Definition (Parent (Standard_Character), Tdef_Node); | |
694 | ||
695 | Set_Ekind (Standard_Character, E_Enumeration_Type); | |
696 | Set_Etype (Standard_Character, Standard_Character); | |
07fc65c4 GB |
697 | Init_Esize (Standard_Character, Standard_Character_Size); |
698 | Init_RM_Size (Standard_Character, 8); | |
15ce9ca2 | 699 | Set_Elem_Alignment (Standard_Character); |
70482933 | 700 | |
bd29d519 | 701 | Set_Has_Pragma_Ordered (Standard_Character); |
70482933 RK |
702 | Set_Is_Unsigned_Type (Standard_Character); |
703 | Set_Is_Character_Type (Standard_Character); | |
704 | Set_Is_Known_Valid (Standard_Character); | |
705 | Set_Size_Known_At_Compile_Time (Standard_Character); | |
706 | ||
a2cb348e | 707 | -- Create the bounds for type Character |
70482933 RK |
708 | |
709 | R_Node := New_Node (N_Range, Stloc); | |
710 | ||
711 | -- Low bound for type Character (Standard.Nul) | |
712 | ||
713 | B_Node := New_Node (N_Character_Literal, Stloc); | |
714 | Set_Is_Static_Expression (B_Node); | |
715 | Set_Chars (B_Node, No_Name); | |
82c80734 RD |
716 | Set_Char_Literal_Value (B_Node, Uint_0); |
717 | Set_Entity (B_Node, Empty); | |
70482933 RK |
718 | Set_Etype (B_Node, Standard_Character); |
719 | Set_Low_Bound (R_Node, B_Node); | |
720 | ||
721 | -- High bound for type Character | |
722 | ||
723 | B_Node := New_Node (N_Character_Literal, Stloc); | |
724 | Set_Is_Static_Expression (B_Node); | |
725 | Set_Chars (B_Node, No_Name); | |
82c80734 RD |
726 | Set_Char_Literal_Value (B_Node, UI_From_Int (16#FF#)); |
727 | Set_Entity (B_Node, Empty); | |
70482933 RK |
728 | Set_Etype (B_Node, Standard_Character); |
729 | Set_High_Bound (R_Node, B_Node); | |
730 | ||
731 | Set_Scalar_Range (Standard_Character, R_Node); | |
732 | Set_Etype (R_Node, Standard_Character); | |
733 | Set_Parent (R_Node, Standard_Character); | |
734 | ||
735 | -- Create type definition for type Wide_Character. Note that we do not | |
736 | -- set the Literals field, since type Wide_Character is handled with | |
737 | -- special routines that do not need a literal list. | |
738 | ||
739 | Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); | |
740 | Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node); | |
741 | ||
742 | Set_Ekind (Standard_Wide_Character, E_Enumeration_Type); | |
743 | Set_Etype (Standard_Wide_Character, Standard_Wide_Character); | |
744 | Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size); | |
745 | ||
15ce9ca2 | 746 | Set_Elem_Alignment (Standard_Wide_Character); |
bd29d519 | 747 | Set_Has_Pragma_Ordered (Standard_Wide_Character); |
70482933 RK |
748 | Set_Is_Unsigned_Type (Standard_Wide_Character); |
749 | Set_Is_Character_Type (Standard_Wide_Character); | |
750 | Set_Is_Known_Valid (Standard_Wide_Character); | |
751 | Set_Size_Known_At_Compile_Time (Standard_Wide_Character); | |
752 | ||
a2cb348e | 753 | -- Create the bounds for type Wide_Character |
70482933 RK |
754 | |
755 | R_Node := New_Node (N_Range, Stloc); | |
756 | ||
757 | -- Low bound for type Wide_Character | |
758 | ||
759 | B_Node := New_Node (N_Character_Literal, Stloc); | |
760 | Set_Is_Static_Expression (B_Node); | |
761 | Set_Chars (B_Node, No_Name); -- ??? | |
82c80734 RD |
762 | Set_Char_Literal_Value (B_Node, Uint_0); |
763 | Set_Entity (B_Node, Empty); | |
70482933 RK |
764 | Set_Etype (B_Node, Standard_Wide_Character); |
765 | Set_Low_Bound (R_Node, B_Node); | |
766 | ||
767 | -- High bound for type Wide_Character | |
768 | ||
769 | B_Node := New_Node (N_Character_Literal, Stloc); | |
770 | Set_Is_Static_Expression (B_Node); | |
771 | Set_Chars (B_Node, No_Name); -- ??? | |
82c80734 RD |
772 | Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#)); |
773 | Set_Entity (B_Node, Empty); | |
70482933 RK |
774 | Set_Etype (B_Node, Standard_Wide_Character); |
775 | Set_High_Bound (R_Node, B_Node); | |
776 | ||
777 | Set_Scalar_Range (Standard_Wide_Character, R_Node); | |
778 | Set_Etype (R_Node, Standard_Wide_Character); | |
779 | Set_Parent (R_Node, Standard_Wide_Character); | |
780 | ||
82c80734 RD |
781 | -- Create type definition for type Wide_Wide_Character. Note that we |
782 | -- do not set the Literals field, since type Wide_Wide_Character is | |
783 | -- handled with special routines that do not need a literal list. | |
784 | ||
785 | Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); | |
786 | Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node); | |
787 | ||
788 | Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type); | |
789 | Set_Etype (Standard_Wide_Wide_Character, | |
790 | Standard_Wide_Wide_Character); | |
791 | Init_Size (Standard_Wide_Wide_Character, | |
792 | Standard_Wide_Wide_Character_Size); | |
793 | ||
794 | Set_Elem_Alignment (Standard_Wide_Wide_Character); | |
bd29d519 | 795 | Set_Has_Pragma_Ordered (Standard_Wide_Wide_Character); |
82c80734 RD |
796 | Set_Is_Unsigned_Type (Standard_Wide_Wide_Character); |
797 | Set_Is_Character_Type (Standard_Wide_Wide_Character); | |
798 | Set_Is_Known_Valid (Standard_Wide_Wide_Character); | |
799 | Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character); | |
bfc8aa81 | 800 | Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character); |
82c80734 RD |
801 | |
802 | -- Create the bounds for type Wide_Wide_Character | |
803 | ||
804 | R_Node := New_Node (N_Range, Stloc); | |
805 | ||
806 | -- Low bound for type Wide_Wide_Character | |
807 | ||
808 | B_Node := New_Node (N_Character_Literal, Stloc); | |
809 | Set_Is_Static_Expression (B_Node); | |
810 | Set_Chars (B_Node, No_Name); -- ??? | |
811 | Set_Char_Literal_Value (B_Node, Uint_0); | |
812 | Set_Entity (B_Node, Empty); | |
813 | Set_Etype (B_Node, Standard_Wide_Wide_Character); | |
814 | Set_Low_Bound (R_Node, B_Node); | |
815 | ||
816 | -- High bound for type Wide_Wide_Character | |
817 | ||
818 | B_Node := New_Node (N_Character_Literal, Stloc); | |
819 | Set_Is_Static_Expression (B_Node); | |
820 | Set_Chars (B_Node, No_Name); -- ??? | |
821 | Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#)); | |
822 | Set_Entity (B_Node, Empty); | |
823 | Set_Etype (B_Node, Standard_Wide_Wide_Character); | |
824 | Set_High_Bound (R_Node, B_Node); | |
825 | ||
826 | Set_Scalar_Range (Standard_Wide_Wide_Character, R_Node); | |
827 | Set_Etype (R_Node, Standard_Wide_Wide_Character); | |
828 | Set_Parent (R_Node, Standard_Wide_Wide_Character); | |
829 | ||
70482933 RK |
830 | -- Create type definition node for type String |
831 | ||
832 | Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); | |
9bc43c53 | 833 | |
a397db96 AC |
834 | declare |
835 | CompDef_Node : Node_Id; | |
836 | begin | |
837 | CompDef_Node := New_Node (N_Component_Definition, Stloc); | |
82c80734 RD |
838 | Set_Aliased_Present (CompDef_Node, False); |
839 | Set_Access_Definition (CompDef_Node, Empty); | |
840 | Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character)); | |
a397db96 AC |
841 | Set_Component_Definition (Tdef_Node, CompDef_Node); |
842 | end; | |
9bc43c53 | 843 | |
70482933 RK |
844 | Set_Subtype_Marks (Tdef_Node, New_List); |
845 | Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); | |
846 | Set_Type_Definition (Parent (Standard_String), Tdef_Node); | |
847 | ||
bb10b891 AC |
848 | Set_Ekind (Standard_String, E_String_Type); |
849 | Set_Etype (Standard_String, Standard_String); | |
850 | Set_Component_Type (Standard_String, Standard_Character); | |
851 | Set_Component_Size (Standard_String, Uint_8); | |
852 | Init_Size_Align (Standard_String); | |
853 | Set_Alignment (Standard_String, Uint_1); | |
ea7f928b | 854 | Pack_String_Type (Standard_String); |
70482933 | 855 | |
41ccd2d8 GD |
856 | -- On targets where a storage unit is larger than a byte (such as AAMP), |
857 | -- pragma Pack has a real effect on the representation of type String, | |
858 | -- and the type must be marked as having a nonstandard representation. | |
859 | ||
860 | if System_Storage_Unit > Uint_8 then | |
861 | Set_Has_Non_Standard_Rep (Standard_String); | |
862 | Set_Has_Pragma_Pack (Standard_String); | |
863 | end if; | |
864 | ||
70482933 RK |
865 | -- Set index type of String |
866 | ||
867 | E_Id := First | |
868 | (Subtype_Marks (Type_Definition (Parent (Standard_String)))); | |
869 | Set_First_Index (Standard_String, E_Id); | |
870 | Set_Entity (E_Id, Standard_Positive); | |
871 | Set_Etype (E_Id, Standard_Positive); | |
872 | ||
873 | -- Create type definition node for type Wide_String | |
874 | ||
875 | Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); | |
82c80734 | 876 | |
a397db96 AC |
877 | declare |
878 | CompDef_Node : Node_Id; | |
879 | begin | |
880 | CompDef_Node := New_Node (N_Component_Definition, Stloc); | |
881 | Set_Aliased_Present (CompDef_Node, False); | |
6e937c1c | 882 | Set_Access_Definition (CompDef_Node, Empty); |
a397db96 AC |
883 | Set_Subtype_Indication (CompDef_Node, |
884 | Identifier_For (S_Wide_Character)); | |
885 | Set_Component_Definition (Tdef_Node, CompDef_Node); | |
886 | end; | |
82c80734 | 887 | |
70482933 RK |
888 | Set_Subtype_Marks (Tdef_Node, New_List); |
889 | Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); | |
890 | Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); | |
891 | ||
bb10b891 AC |
892 | Set_Ekind (Standard_Wide_String, E_String_Type); |
893 | Set_Etype (Standard_Wide_String, Standard_Wide_String); | |
894 | Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); | |
895 | Set_Component_Size (Standard_Wide_String, Uint_16); | |
896 | Init_Size_Align (Standard_Wide_String); | |
ea7f928b | 897 | Pack_String_Type (Standard_Wide_String); |
70482933 RK |
898 | |
899 | -- Set index type of Wide_String | |
900 | ||
901 | E_Id := First | |
902 | (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); | |
903 | Set_First_Index (Standard_Wide_String, E_Id); | |
904 | Set_Entity (E_Id, Standard_Positive); | |
905 | Set_Etype (E_Id, Standard_Positive); | |
906 | ||
82c80734 RD |
907 | -- Create type definition node for type Wide_Wide_String |
908 | ||
909 | Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); | |
910 | ||
911 | declare | |
912 | CompDef_Node : Node_Id; | |
913 | begin | |
914 | CompDef_Node := New_Node (N_Component_Definition, Stloc); | |
915 | Set_Aliased_Present (CompDef_Node, False); | |
916 | Set_Access_Definition (CompDef_Node, Empty); | |
917 | Set_Subtype_Indication (CompDef_Node, | |
918 | Identifier_For (S_Wide_Wide_Character)); | |
919 | Set_Component_Definition (Tdef_Node, CompDef_Node); | |
920 | end; | |
921 | ||
922 | Set_Subtype_Marks (Tdef_Node, New_List); | |
923 | Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); | |
924 | Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node); | |
925 | ||
bfc8aa81 RD |
926 | Set_Ekind (Standard_Wide_Wide_String, E_String_Type); |
927 | Set_Etype (Standard_Wide_Wide_String, | |
928 | Standard_Wide_Wide_String); | |
929 | Set_Component_Type (Standard_Wide_Wide_String, | |
930 | Standard_Wide_Wide_Character); | |
931 | Set_Component_Size (Standard_Wide_Wide_String, Uint_32); | |
932 | Init_Size_Align (Standard_Wide_Wide_String); | |
933 | Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); | |
ea7f928b | 934 | Pack_String_Type (Standard_Wide_Wide_String); |
82c80734 RD |
935 | |
936 | -- Set index type of Wide_Wide_String | |
937 | ||
938 | E_Id := First | |
939 | (Subtype_Marks (Type_Definition (Parent (Standard_Wide_Wide_String)))); | |
940 | Set_First_Index (Standard_Wide_Wide_String, E_Id); | |
941 | Set_Entity (E_Id, Standard_Positive); | |
942 | Set_Etype (E_Id, Standard_Positive); | |
943 | ||
3d6c3bd7 | 944 | -- Setup entity for Natural |
70482933 RK |
945 | |
946 | Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); | |
947 | Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); | |
948 | Init_Esize (Standard_Natural, Standard_Integer_Size); | |
949 | Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1); | |
15ce9ca2 | 950 | Set_Elem_Alignment (Standard_Natural); |
70482933 RK |
951 | Set_Size_Known_At_Compile_Time |
952 | (Standard_Natural); | |
953 | Set_Integer_Bounds (Standard_Natural, | |
954 | Typ => Base_Type (Standard_Integer), | |
955 | Lb => Uint_0, | |
956 | Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); | |
957 | Set_Is_Constrained (Standard_Natural); | |
70482933 | 958 | |
454a86dc | 959 | -- Setup entity for Positive |
70482933 RK |
960 | |
961 | Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); | |
962 | Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); | |
963 | Init_Esize (Standard_Positive, Standard_Integer_Size); | |
964 | Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1); | |
15ce9ca2 | 965 | Set_Elem_Alignment (Standard_Positive); |
70482933 RK |
966 | |
967 | Set_Size_Known_At_Compile_Time (Standard_Positive); | |
968 | ||
969 | Set_Integer_Bounds (Standard_Positive, | |
970 | Typ => Base_Type (Standard_Integer), | |
971 | Lb => Uint_1, | |
972 | Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); | |
973 | Set_Is_Constrained (Standard_Positive); | |
70482933 RK |
974 | |
975 | -- Create declaration for package ASCII | |
976 | ||
977 | Decl := New_Node (N_Package_Declaration, Stloc); | |
978 | Append (Decl, Decl_S); | |
979 | ||
980 | Pspec := New_Node (N_Package_Specification, Stloc); | |
981 | Set_Specification (Decl, Pspec); | |
982 | ||
983 | Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII)); | |
984 | Set_Ekind (Standard_Entity (S_ASCII), E_Package); | |
70482933 RK |
985 | Set_Visible_Declarations (Pspec, Decl_A); |
986 | ||
987 | -- Create control character definitions in package ASCII. Note that | |
988 | -- the character literal entries created here correspond to literal | |
989 | -- values that are impossible in the source, but can be represented | |
990 | -- internally with no difficulties. | |
991 | ||
992 | Ccode := 16#00#; | |
993 | ||
994 | for S in S_ASCII_Names loop | |
995 | Decl := New_Node (N_Object_Declaration, Staloc); | |
996 | Set_Constant_Present (Decl, True); | |
997 | ||
998 | declare | |
fbf5a39b | 999 | A_Char : constant Entity_Id := Standard_Entity (S); |
70482933 RK |
1000 | Expr_Decl : Node_Id; |
1001 | ||
1002 | begin | |
1003 | Set_Sloc (A_Char, Staloc); | |
1004 | Set_Ekind (A_Char, E_Constant); | |
fbf5a39b | 1005 | Set_Never_Set_In_Source (A_Char, True); |
70482933 RK |
1006 | Set_Is_True_Constant (A_Char, True); |
1007 | Set_Etype (A_Char, Standard_Character); | |
1008 | Set_Scope (A_Char, Standard_Entity (S_ASCII)); | |
1009 | Set_Is_Immediately_Visible (A_Char, False); | |
1010 | Set_Is_Public (A_Char, True); | |
1011 | Set_Is_Known_Valid (A_Char, True); | |
1012 | ||
1013 | Append_Entity (A_Char, Standard_Entity (S_ASCII)); | |
1014 | Set_Defining_Identifier (Decl, A_Char); | |
1015 | ||
1016 | Set_Object_Definition (Decl, Identifier_For (S_Character)); | |
1017 | Expr_Decl := New_Node (N_Character_Literal, Staloc); | |
1018 | Set_Expression (Decl, Expr_Decl); | |
1019 | ||
1020 | Set_Is_Static_Expression (Expr_Decl); | |
1021 | Set_Chars (Expr_Decl, No_Name); | |
1022 | Set_Etype (Expr_Decl, Standard_Character); | |
82c80734 | 1023 | Set_Char_Literal_Value (Expr_Decl, UI_From_Int (Int (Ccode))); |
70482933 RK |
1024 | end; |
1025 | ||
1026 | Append (Decl, Decl_A); | |
1027 | ||
1028 | -- Increment character code, dealing with non-contiguities | |
1029 | ||
1030 | Ccode := Ccode + 1; | |
1031 | ||
1032 | if Ccode = 16#20# then | |
1033 | Ccode := 16#21#; | |
1034 | elsif Ccode = 16#27# then | |
1035 | Ccode := 16#3A#; | |
1036 | elsif Ccode = 16#3C# then | |
1037 | Ccode := 16#3F#; | |
1038 | elsif Ccode = 16#41# then | |
1039 | Ccode := 16#5B#; | |
1040 | end if; | |
1041 | end loop; | |
1042 | ||
1043 | -- Create semantic phase entities | |
1044 | ||
1045 | Standard_Void_Type := New_Standard_Entity; | |
1046 | Set_Ekind (Standard_Void_Type, E_Void); | |
1047 | Set_Etype (Standard_Void_Type, Standard_Void_Type); | |
70482933 RK |
1048 | Set_Scope (Standard_Void_Type, Standard_Standard); |
1049 | Make_Name (Standard_Void_Type, "_void_type"); | |
1050 | ||
1051 | -- The type field of packages is set to void | |
1052 | ||
1053 | Set_Etype (Standard_Standard, Standard_Void_Type); | |
1054 | Set_Etype (Standard_ASCII, Standard_Void_Type); | |
1055 | ||
1056 | -- Standard_A_String is actually used in generated code, so it has a | |
1057 | -- type name that is reasonable, but does not overlap any Ada name. | |
1058 | ||
1059 | Standard_A_String := New_Standard_Entity; | |
1060 | Set_Ekind (Standard_A_String, E_Access_Type); | |
1061 | Set_Scope (Standard_A_String, Standard_Standard); | |
1062 | Set_Etype (Standard_A_String, Standard_A_String); | |
1063 | ||
1064 | if Debug_Flag_6 then | |
1065 | Init_Size (Standard_A_String, System_Address_Size); | |
1066 | else | |
1067 | Init_Size (Standard_A_String, System_Address_Size * 2); | |
1068 | end if; | |
1069 | ||
1070 | Init_Alignment (Standard_A_String); | |
1071 | ||
1072 | Set_Directly_Designated_Type | |
1073 | (Standard_A_String, Standard_String); | |
1074 | Make_Name (Standard_A_String, "access_string"); | |
1075 | ||
1076 | Standard_A_Char := New_Standard_Entity; | |
1077 | Set_Ekind (Standard_A_Char, E_Access_Type); | |
1078 | Set_Scope (Standard_A_Char, Standard_Standard); | |
1079 | Set_Etype (Standard_A_Char, Standard_A_String); | |
1080 | Init_Size (Standard_A_Char, System_Address_Size); | |
15ce9ca2 | 1081 | Set_Elem_Alignment (Standard_A_Char); |
70482933 RK |
1082 | |
1083 | Set_Directly_Designated_Type (Standard_A_Char, Standard_Character); | |
1084 | Make_Name (Standard_A_Char, "access_character"); | |
1085 | ||
4c8e94ab GD |
1086 | -- Standard_Debug_Renaming_Type is used for the special objects created |
1087 | -- to encode the names occurring in renaming declarations for use by the | |
1088 | -- debugger (see exp_dbug.adb). The type is a zero-sized subtype of | |
1089 | -- Standard.Integer. | |
1090 | ||
1091 | Standard_Debug_Renaming_Type := New_Standard_Entity; | |
1092 | ||
1093 | Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype); | |
1094 | Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard); | |
1095 | Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer)); | |
8dc2ddaf RD |
1096 | Init_Esize (Standard_Debug_Renaming_Type, 0); |
1097 | Init_RM_Size (Standard_Debug_Renaming_Type, 0); | |
4c8e94ab | 1098 | Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type); |
8dc2ddaf RD |
1099 | Set_Integer_Bounds (Standard_Debug_Renaming_Type, |
1100 | Typ => Base_Type (Standard_Debug_Renaming_Type), | |
4c8e94ab GD |
1101 | Lb => Uint_1, |
1102 | Hb => Uint_0); | |
8dc2ddaf | 1103 | Set_Is_Constrained (Standard_Debug_Renaming_Type); |
4c8e94ab GD |
1104 | Set_Has_Size_Clause (Standard_Debug_Renaming_Type); |
1105 | ||
8dc2ddaf | 1106 | Make_Name (Standard_Debug_Renaming_Type, "_renaming_type"); |
4c8e94ab | 1107 | |
70482933 RK |
1108 | -- Note on type names. The type names for the following special types |
1109 | -- are constructed so that they will look reasonable should they ever | |
1110 | -- appear in error messages etc, although in practice the use of the | |
1111 | -- special insertion character } for types results in special handling | |
1112 | -- of these type names in any case. The blanks in these names would | |
1113 | -- trouble in Gigi, but that's OK here, since none of these types | |
1114 | -- should ever get through to Gigi! Attributes of these types are | |
1115 | -- filled out to minimize problems with cascaded errors (for example, | |
1116 | -- Any_Integer is given reasonable and consistent type and size values) | |
1117 | ||
1118 | Any_Type := New_Standard_Entity; | |
1119 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1120 | Set_Defining_Identifier (Decl, Any_Type); | |
1121 | Set_Scope (Any_Type, Standard_Standard); | |
1122 | Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size); | |
1123 | Make_Name (Any_Type, "any type"); | |
1124 | ||
1125 | Any_Id := New_Standard_Entity; | |
1126 | Set_Ekind (Any_Id, E_Variable); | |
1127 | Set_Scope (Any_Id, Standard_Standard); | |
1128 | Set_Etype (Any_Id, Any_Type); | |
b11e8d6f RD |
1129 | Init_Esize (Any_Id); |
1130 | Init_Alignment (Any_Id); | |
70482933 RK |
1131 | Make_Name (Any_Id, "any id"); |
1132 | ||
1133 | Any_Access := New_Standard_Entity; | |
1134 | Set_Ekind (Any_Access, E_Access_Type); | |
1135 | Set_Scope (Any_Access, Standard_Standard); | |
1136 | Set_Etype (Any_Access, Any_Access); | |
1137 | Init_Size (Any_Access, System_Address_Size); | |
15ce9ca2 | 1138 | Set_Elem_Alignment (Any_Access); |
70482933 RK |
1139 | Make_Name (Any_Access, "an access type"); |
1140 | ||
f1f9fe30 AC |
1141 | Any_Character := New_Standard_Entity; |
1142 | Set_Ekind (Any_Character, E_Enumeration_Type); | |
1143 | Set_Scope (Any_Character, Standard_Standard); | |
1144 | Set_Etype (Any_Character, Any_Character); | |
1145 | Set_Is_Unsigned_Type (Any_Character); | |
1146 | Set_Is_Character_Type (Any_Character); | |
1147 | Init_Esize (Any_Character, Standard_Character_Size); | |
1148 | Init_RM_Size (Any_Character, 8); | |
15ce9ca2 | 1149 | Set_Elem_Alignment (Any_Character); |
f1f9fe30 AC |
1150 | Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); |
1151 | Make_Name (Any_Character, "a character type"); | |
1152 | ||
70482933 RK |
1153 | Any_Array := New_Standard_Entity; |
1154 | Set_Ekind (Any_Array, E_String_Type); | |
1155 | Set_Scope (Any_Array, Standard_Standard); | |
1156 | Set_Etype (Any_Array, Any_Array); | |
1157 | Set_Component_Type (Any_Array, Any_Character); | |
1158 | Init_Size_Align (Any_Array); | |
1159 | Make_Name (Any_Array, "an array type"); | |
1160 | ||
1161 | Any_Boolean := New_Standard_Entity; | |
1162 | Set_Ekind (Any_Boolean, E_Enumeration_Type); | |
1163 | Set_Scope (Any_Boolean, Standard_Standard); | |
1164 | Set_Etype (Any_Boolean, Standard_Boolean); | |
07fc65c4 | 1165 | Init_Esize (Any_Boolean, Standard_Character_Size); |
70482933 | 1166 | Init_RM_Size (Any_Boolean, 1); |
15ce9ca2 | 1167 | Set_Elem_Alignment (Any_Boolean); |
70482933 RK |
1168 | Set_Is_Unsigned_Type (Any_Boolean); |
1169 | Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); | |
1170 | Make_Name (Any_Boolean, "a boolean type"); | |
1171 | ||
70482933 RK |
1172 | Any_Composite := New_Standard_Entity; |
1173 | Set_Ekind (Any_Composite, E_Array_Type); | |
1174 | Set_Scope (Any_Composite, Standard_Standard); | |
1175 | Set_Etype (Any_Composite, Any_Composite); | |
1176 | Set_Component_Size (Any_Composite, Uint_0); | |
1177 | Set_Component_Type (Any_Composite, Standard_Integer); | |
1178 | Init_Size_Align (Any_Composite); | |
1179 | Make_Name (Any_Composite, "a composite type"); | |
1180 | ||
1181 | Any_Discrete := New_Standard_Entity; | |
1182 | Set_Ekind (Any_Discrete, E_Signed_Integer_Type); | |
1183 | Set_Scope (Any_Discrete, Standard_Standard); | |
1184 | Set_Etype (Any_Discrete, Any_Discrete); | |
1185 | Init_Size (Any_Discrete, Standard_Integer_Size); | |
15ce9ca2 | 1186 | Set_Elem_Alignment (Any_Discrete); |
70482933 RK |
1187 | Make_Name (Any_Discrete, "a discrete type"); |
1188 | ||
1189 | Any_Fixed := New_Standard_Entity; | |
1190 | Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type); | |
1191 | Set_Scope (Any_Fixed, Standard_Standard); | |
1192 | Set_Etype (Any_Fixed, Any_Fixed); | |
1193 | Init_Size (Any_Fixed, Standard_Integer_Size); | |
15ce9ca2 | 1194 | Set_Elem_Alignment (Any_Fixed); |
70482933 RK |
1195 | Make_Name (Any_Fixed, "a fixed-point type"); |
1196 | ||
1197 | Any_Integer := New_Standard_Entity; | |
1198 | Set_Ekind (Any_Integer, E_Signed_Integer_Type); | |
1199 | Set_Scope (Any_Integer, Standard_Standard); | |
1200 | Set_Etype (Any_Integer, Standard_Long_Long_Integer); | |
1201 | Init_Size (Any_Integer, Standard_Long_Long_Integer_Size); | |
15ce9ca2 | 1202 | Set_Elem_Alignment (Any_Integer); |
70482933 RK |
1203 | |
1204 | Set_Integer_Bounds | |
1205 | (Any_Integer, | |
1206 | Typ => Base_Type (Standard_Integer), | |
1207 | Lb => Uint_0, | |
1208 | Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); | |
1209 | Make_Name (Any_Integer, "an integer type"); | |
1210 | ||
1211 | Any_Modular := New_Standard_Entity; | |
1212 | Set_Ekind (Any_Modular, E_Modular_Integer_Type); | |
1213 | Set_Scope (Any_Modular, Standard_Standard); | |
1214 | Set_Etype (Any_Modular, Standard_Long_Long_Integer); | |
1215 | Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); | |
15ce9ca2 | 1216 | Set_Elem_Alignment (Any_Modular); |
70482933 RK |
1217 | Set_Is_Unsigned_Type (Any_Modular); |
1218 | Make_Name (Any_Modular, "a modular type"); | |
1219 | ||
1220 | Any_Numeric := New_Standard_Entity; | |
1221 | Set_Ekind (Any_Numeric, E_Signed_Integer_Type); | |
1222 | Set_Scope (Any_Numeric, Standard_Standard); | |
1223 | Set_Etype (Any_Numeric, Standard_Long_Long_Integer); | |
1224 | Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); | |
15ce9ca2 | 1225 | Set_Elem_Alignment (Any_Numeric); |
70482933 RK |
1226 | Make_Name (Any_Numeric, "a numeric type"); |
1227 | ||
1228 | Any_Real := New_Standard_Entity; | |
1229 | Set_Ekind (Any_Real, E_Floating_Point_Type); | |
1230 | Set_Scope (Any_Real, Standard_Standard); | |
1231 | Set_Etype (Any_Real, Standard_Long_Long_Float); | |
9eea4346 GB |
1232 | Init_Size (Any_Real, |
1233 | UI_To_Int (Esize (Standard_Long_Long_Float))); | |
15ce9ca2 | 1234 | Set_Elem_Alignment (Any_Real); |
70482933 RK |
1235 | Make_Name (Any_Real, "a real type"); |
1236 | ||
1237 | Any_Scalar := New_Standard_Entity; | |
1238 | Set_Ekind (Any_Scalar, E_Signed_Integer_Type); | |
1239 | Set_Scope (Any_Scalar, Standard_Standard); | |
1240 | Set_Etype (Any_Scalar, Any_Scalar); | |
1241 | Init_Size (Any_Scalar, Standard_Integer_Size); | |
15ce9ca2 | 1242 | Set_Elem_Alignment (Any_Scalar); |
70482933 RK |
1243 | Make_Name (Any_Scalar, "a scalar type"); |
1244 | ||
1245 | Any_String := New_Standard_Entity; | |
1246 | Set_Ekind (Any_String, E_String_Type); | |
1247 | Set_Scope (Any_String, Standard_Standard); | |
1248 | Set_Etype (Any_String, Any_String); | |
1249 | Set_Component_Type (Any_String, Any_Character); | |
1250 | Init_Size_Align (Any_String); | |
1251 | Make_Name (Any_String, "a string type"); | |
1252 | ||
1253 | declare | |
1254 | Index : Node_Id; | |
70482933 RK |
1255 | |
1256 | begin | |
1257 | Index := | |
1258 | Make_Range (Stloc, | |
1259 | Low_Bound => Make_Integer (Uint_0), | |
1260 | High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); | |
70482933 RK |
1261 | Set_Etype (Index, Standard_Integer); |
1262 | Set_First_Index (Any_String, Index); | |
1263 | end; | |
1264 | ||
1265 | Standard_Integer_8 := New_Standard_Entity; | |
1266 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1267 | Set_Defining_Identifier (Decl, Standard_Integer_8); | |
1268 | Make_Name (Standard_Integer_8, "integer_8"); | |
1269 | Set_Scope (Standard_Integer_8, Standard_Standard); | |
1270 | Build_Signed_Integer_Type (Standard_Integer_8, 8); | |
1271 | ||
1272 | Standard_Integer_16 := New_Standard_Entity; | |
1273 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1274 | Set_Defining_Identifier (Decl, Standard_Integer_16); | |
1275 | Make_Name (Standard_Integer_16, "integer_16"); | |
1276 | Set_Scope (Standard_Integer_16, Standard_Standard); | |
1277 | Build_Signed_Integer_Type (Standard_Integer_16, 16); | |
1278 | ||
1279 | Standard_Integer_32 := New_Standard_Entity; | |
1280 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1281 | Set_Defining_Identifier (Decl, Standard_Integer_32); | |
1282 | Make_Name (Standard_Integer_32, "integer_32"); | |
1283 | Set_Scope (Standard_Integer_32, Standard_Standard); | |
1284 | Build_Signed_Integer_Type (Standard_Integer_32, 32); | |
1285 | ||
1286 | Standard_Integer_64 := New_Standard_Entity; | |
1287 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1288 | Set_Defining_Identifier (Decl, Standard_Integer_64); | |
1289 | Make_Name (Standard_Integer_64, "integer_64"); | |
1290 | Set_Scope (Standard_Integer_64, Standard_Standard); | |
1291 | Build_Signed_Integer_Type (Standard_Integer_64, 64); | |
1292 | ||
1293 | Standard_Unsigned := New_Standard_Entity; | |
1294 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1295 | Set_Defining_Identifier (Decl, Standard_Unsigned); | |
1296 | Make_Name (Standard_Unsigned, "unsigned"); | |
1297 | ||
1298 | Set_Ekind (Standard_Unsigned, E_Modular_Integer_Type); | |
1299 | Set_Scope (Standard_Unsigned, Standard_Standard); | |
1300 | Set_Etype (Standard_Unsigned, Standard_Unsigned); | |
1301 | Init_Size (Standard_Unsigned, Standard_Integer_Size); | |
15ce9ca2 | 1302 | Set_Elem_Alignment (Standard_Unsigned); |
70482933 RK |
1303 | Set_Modulus (Standard_Unsigned, |
1304 | Uint_2 ** Standard_Integer_Size); | |
70482933 | 1305 | Set_Is_Unsigned_Type (Standard_Unsigned); |
fbf5a39b AC |
1306 | Set_Size_Known_At_Compile_Time |
1307 | (Standard_Unsigned); | |
8dc2ddaf | 1308 | Set_Is_Known_Valid (Standard_Unsigned, True); |
70482933 RK |
1309 | |
1310 | R_Node := New_Node (N_Range, Stloc); | |
fbf5a39b AC |
1311 | Set_Low_Bound (R_Node, Make_Integer (Uint_0)); |
1312 | Set_High_Bound (R_Node, Make_Integer (Modulus (Standard_Unsigned) - 1)); | |
1313 | Set_Etype (Low_Bound (R_Node), Standard_Unsigned); | |
1314 | Set_Etype (High_Bound (R_Node), Standard_Unsigned); | |
70482933 RK |
1315 | Set_Scalar_Range (Standard_Unsigned, R_Node); |
1316 | ||
1317 | -- Note: universal integer and universal real are constructed as fully | |
1318 | -- formed signed numeric types, with parameters corresponding to the | |
1319 | -- longest runtime types (Long_Long_Integer and Long_Long_Float). This | |
1320 | -- allows Gigi to properly process references to universal types that | |
1321 | -- are not folded at compile time. | |
1322 | ||
1323 | Universal_Integer := New_Standard_Entity; | |
1324 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1325 | Set_Defining_Identifier (Decl, Universal_Integer); | |
1326 | Make_Name (Universal_Integer, "universal_integer"); | |
1327 | Set_Scope (Universal_Integer, Standard_Standard); | |
1328 | Build_Signed_Integer_Type | |
1329 | (Universal_Integer, Standard_Long_Long_Integer_Size); | |
1330 | ||
1331 | Universal_Real := New_Standard_Entity; | |
1332 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1333 | Set_Defining_Identifier (Decl, Universal_Real); | |
1334 | Make_Name (Universal_Real, "universal_real"); | |
1335 | Set_Scope (Universal_Real, Standard_Standard); | |
f8726f2b | 1336 | Copy_Float_Type (Universal_Real, Standard_Long_Long_Float); |
70482933 RK |
1337 | |
1338 | -- Note: universal fixed, unlike universal integer and universal real, | |
1339 | -- is never used at runtime, so it does not need to have bounds set. | |
1340 | ||
1341 | Universal_Fixed := New_Standard_Entity; | |
1342 | Decl := New_Node (N_Full_Type_Declaration, Stloc); | |
1343 | Set_Defining_Identifier (Decl, Universal_Fixed); | |
1344 | Make_Name (Universal_Fixed, "universal_fixed"); | |
1345 | Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type); | |
1346 | Set_Etype (Universal_Fixed, Universal_Fixed); | |
1347 | Set_Scope (Universal_Fixed, Standard_Standard); | |
1348 | Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size); | |
15ce9ca2 | 1349 | Set_Elem_Alignment (Universal_Fixed); |
70482933 RK |
1350 | Set_Size_Known_At_Compile_Time |
1351 | (Universal_Fixed); | |
1352 | ||
17c5c8a5 | 1353 | -- Create type declaration for Duration, using a 64-bit size. The |
fbf5a39b | 1354 | -- delta and size values depend on the mode set in system.ads. |
70482933 RK |
1355 | |
1356 | Build_Duration : declare | |
891a6e79 AC |
1357 | Dlo : Uint; |
1358 | Dhi : Uint; | |
1359 | Delta_Val : Ureal; | |
70482933 RK |
1360 | |
1361 | begin | |
fbf5a39b AC |
1362 | -- In 32 bit mode, the size is 32 bits, and the delta and |
1363 | -- small values are set to 20 milliseconds (20.0**(10.0**(-3)). | |
1364 | ||
1365 | if Duration_32_Bits_On_Target then | |
6510f4c9 GB |
1366 | Dlo := Intval (Type_Low_Bound (Standard_Integer_32)); |
1367 | Dhi := Intval (Type_High_Bound (Standard_Integer_32)); | |
fbf5a39b AC |
1368 | Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10); |
1369 | ||
1370 | -- In standard 64-bit mode, the size is 64-bits and the delta and | |
a5b62485 | 1371 | -- small values are set to nanoseconds (1.0**(10.0**(-9)) |
17c5c8a5 | 1372 | |
6510f4c9 GB |
1373 | else |
1374 | Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); | |
1375 | Dhi := Intval (Type_High_Bound (Standard_Integer_64)); | |
1376 | Delta_Val := UR_From_Components (Uint_1, Uint_9, 10); | |
1377 | end if; | |
1378 | ||
891a6e79 | 1379 | Tdef_Node := Make_Ordinary_Fixed_Point_Definition (Stloc, |
70482933 RK |
1380 | Delta_Expression => Make_Real_Literal (Stloc, Delta_Val), |
1381 | Real_Range_Specification => | |
1382 | Make_Real_Range_Specification (Stloc, | |
1383 | Low_Bound => Make_Real_Literal (Stloc, | |
1384 | Realval => Dlo * Delta_Val), | |
1385 | High_Bound => Make_Real_Literal (Stloc, | |
891a6e79 AC |
1386 | Realval => Dhi * Delta_Val))); |
1387 | ||
1388 | Set_Type_Definition (Parent (Standard_Duration), Tdef_Node); | |
70482933 | 1389 | |
6510f4c9 GB |
1390 | Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); |
1391 | Set_Etype (Standard_Duration, Standard_Duration); | |
1392 | ||
fbf5a39b | 1393 | if Duration_32_Bits_On_Target then |
6510f4c9 GB |
1394 | Init_Size (Standard_Duration, 32); |
1395 | else | |
1396 | Init_Size (Standard_Duration, 64); | |
1397 | end if; | |
1398 | ||
15ce9ca2 | 1399 | Set_Elem_Alignment (Standard_Duration); |
70482933 RK |
1400 | Set_Delta_Value (Standard_Duration, Delta_Val); |
1401 | Set_Small_Value (Standard_Duration, Delta_Val); | |
1402 | Set_Scalar_Range (Standard_Duration, | |
1403 | Real_Range_Specification | |
891a6e79 | 1404 | (Type_Definition (Parent (Standard_Duration)))); |
70482933 RK |
1405 | |
1406 | -- Normally it does not matter that nodes in package Standard are | |
1407 | -- not marked as analyzed. The Scalar_Range of the fixed-point | |
1408 | -- type Standard_Duration is an exception, because of the special | |
1409 | -- test made in Freeze.Freeze_Fixed_Point_Type. | |
1410 | ||
1411 | Set_Analyzed (Scalar_Range (Standard_Duration)); | |
1412 | ||
1413 | Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration); | |
1414 | Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration); | |
1415 | ||
1416 | Set_Is_Static_Expression (Type_High_Bound (Standard_Duration)); | |
1417 | Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration)); | |
1418 | ||
1419 | Set_Corresponding_Integer_Value | |
1420 | (Type_High_Bound (Standard_Duration), Dhi); | |
1421 | ||
1422 | Set_Corresponding_Integer_Value | |
1423 | (Type_Low_Bound (Standard_Duration), Dlo); | |
1424 | ||
1425 | Set_Size_Known_At_Compile_Time (Standard_Duration); | |
1426 | end Build_Duration; | |
1427 | ||
1428 | -- Build standard exception type. Note that the type name here is | |
1429 | -- actually used in the generated code, so it must be set correctly | |
1430 | ||
e6f69614 AC |
1431 | -- ??? Also note that the Import_Code component is now declared |
1432 | -- as a System.Standard_Library.Exception_Code to enforce run-time | |
1433 | -- library implementation consistency. It's too early here to resort | |
1434 | -- to rtsfind to get the proper node for that type, so we use the | |
1435 | -- closest possible available type node at hand instead. We should | |
1436 | -- probably be fixing this up at some point. | |
1437 | ||
70482933 RK |
1438 | Standard_Exception_Type := New_Standard_Entity; |
1439 | Set_Ekind (Standard_Exception_Type, E_Record_Type); | |
1440 | Set_Etype (Standard_Exception_Type, Standard_Exception_Type); | |
1441 | Set_Scope (Standard_Exception_Type, Standard_Standard); | |
fbf5a39b | 1442 | Set_Stored_Constraint |
70482933 RK |
1443 | (Standard_Exception_Type, No_Elist); |
1444 | Init_Size_Align (Standard_Exception_Type); | |
1445 | Set_Size_Known_At_Compile_Time | |
1446 | (Standard_Exception_Type, True); | |
1447 | Make_Name (Standard_Exception_Type, "exception"); | |
1448 | ||
a2cb348e RD |
1449 | Make_Component |
1450 | (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others"); | |
1451 | Make_Component | |
1452 | (Standard_Exception_Type, Standard_Character, "Lang"); | |
1453 | Make_Component | |
1454 | (Standard_Exception_Type, Standard_Natural, "Name_Length"); | |
1455 | Make_Component | |
1456 | (Standard_Exception_Type, Standard_A_Char, "Full_Name"); | |
1457 | Make_Component | |
1458 | (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); | |
1459 | Make_Component | |
1460 | (Standard_Exception_Type, Standard_Unsigned, "Import_Code"); | |
1461 | Make_Component | |
1462 | (Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); | |
1463 | ||
1464 | -- Build tree for record declaration, for use by the back-end | |
70482933 RK |
1465 | |
1466 | declare | |
1467 | Comp_List : List_Id; | |
1468 | Comp : Entity_Id; | |
1469 | ||
1470 | begin | |
1471 | Comp := First_Entity (Standard_Exception_Type); | |
1472 | Comp_List := New_List; | |
70482933 RK |
1473 | while Present (Comp) loop |
1474 | Append ( | |
1475 | Make_Component_Declaration (Stloc, | |
1476 | Defining_Identifier => Comp, | |
a397db96 AC |
1477 | Component_Definition => |
1478 | Make_Component_Definition (Stloc, | |
1479 | Aliased_Present => False, | |
1480 | Subtype_Indication => New_Occurrence_Of (Etype (Comp), | |
1481 | Stloc))), | |
70482933 RK |
1482 | Comp_List); |
1483 | ||
1484 | Next_Entity (Comp); | |
1485 | end loop; | |
1486 | ||
1487 | Decl := Make_Full_Type_Declaration (Stloc, | |
1488 | Defining_Identifier => Standard_Exception_Type, | |
1489 | Type_Definition => | |
1490 | Make_Record_Definition (Stloc, | |
1491 | End_Label => Empty, | |
1492 | Component_List => | |
1493 | Make_Component_List (Stloc, | |
1494 | Component_Items => Comp_List))); | |
1495 | end; | |
1496 | ||
1497 | Append (Decl, Decl_S); | |
1498 | ||
fbf5a39b AC |
1499 | Layout_Type (Standard_Exception_Type); |
1500 | ||
70482933 RK |
1501 | -- Create declarations of standard exceptions |
1502 | ||
1503 | Build_Exception (S_Constraint_Error); | |
1504 | Build_Exception (S_Program_Error); | |
1505 | Build_Exception (S_Storage_Error); | |
1506 | Build_Exception (S_Tasking_Error); | |
1507 | ||
1508 | -- Numeric_Error is a normal exception in Ada 83, but in Ada 95 | |
0ab80019 | 1509 | -- it is a renaming of Constraint_Error. Is this test too early??? |
70482933 | 1510 | |
0ab80019 | 1511 | if Ada_Version = Ada_83 then |
70482933 RK |
1512 | Build_Exception (S_Numeric_Error); |
1513 | ||
1514 | else | |
1515 | Decl := New_Node (N_Exception_Renaming_Declaration, Stloc); | |
1516 | E_Id := Standard_Entity (S_Numeric_Error); | |
1517 | ||
1518 | Set_Ekind (E_Id, E_Exception); | |
1519 | Set_Exception_Code (E_Id, Uint_0); | |
1520 | Set_Etype (E_Id, Standard_Exception_Type); | |
1521 | Set_Is_Public (E_Id); | |
1522 | Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); | |
1523 | ||
1524 | Set_Defining_Identifier (Decl, E_Id); | |
1525 | Append (Decl, Decl_S); | |
1526 | ||
1527 | Ident_Node := New_Node (N_Identifier, Stloc); | |
1528 | Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); | |
1529 | Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); | |
1530 | Set_Name (Decl, Ident_Node); | |
1531 | end if; | |
1532 | ||
1533 | -- Abort_Signal is an entity that does not get made visible | |
1534 | ||
1535 | Abort_Signal := New_Standard_Entity; | |
1536 | Set_Chars (Abort_Signal, Name_uAbort_Signal); | |
1537 | Set_Ekind (Abort_Signal, E_Exception); | |
1538 | Set_Exception_Code (Abort_Signal, Uint_0); | |
1539 | Set_Etype (Abort_Signal, Standard_Exception_Type); | |
1540 | Set_Scope (Abort_Signal, Standard_Standard); | |
1541 | Set_Is_Public (Abort_Signal, True); | |
1542 | Decl := | |
1543 | Make_Exception_Declaration (Stloc, | |
1544 | Defining_Identifier => Abort_Signal); | |
1545 | ||
1546 | -- Create defining identifiers for shift operator entities. Note | |
1547 | -- that these entities are used only for marking shift operators | |
1548 | -- generated internally, and hence need no structure, just a name | |
1549 | -- and a unique identity. | |
1550 | ||
1551 | Standard_Op_Rotate_Left := New_Standard_Entity; | |
1552 | Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left); | |
1553 | Set_Ekind (Standard_Op_Rotate_Left, E_Operator); | |
1554 | ||
1555 | Standard_Op_Rotate_Right := New_Standard_Entity; | |
1556 | Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right); | |
1557 | Set_Ekind (Standard_Op_Rotate_Right, E_Operator); | |
1558 | ||
1559 | Standard_Op_Shift_Left := New_Standard_Entity; | |
1560 | Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left); | |
1561 | Set_Ekind (Standard_Op_Shift_Left, E_Operator); | |
1562 | ||
1563 | Standard_Op_Shift_Right := New_Standard_Entity; | |
1564 | Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right); | |
1565 | Set_Ekind (Standard_Op_Shift_Right, E_Operator); | |
1566 | ||
1567 | Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity; | |
1568 | Set_Chars (Standard_Op_Shift_Right_Arithmetic, | |
1569 | Name_Shift_Right_Arithmetic); | |
1570 | Set_Ekind (Standard_Op_Shift_Right_Arithmetic, | |
1571 | E_Operator); | |
1572 | ||
1573 | -- Create standard operator declarations | |
1574 | ||
1575 | Create_Operators; | |
1576 | ||
1577 | -- Initialize visibility table with entities in Standard | |
1578 | ||
1579 | for E in Standard_Entity_Type loop | |
1580 | if Ekind (Standard_Entity (E)) /= E_Operator then | |
1581 | Set_Name_Entity_Id | |
1582 | (Chars (Standard_Entity (E)), Standard_Entity (E)); | |
1583 | Set_Homonym (Standard_Entity (E), Empty); | |
1584 | end if; | |
1585 | ||
1586 | if E not in S_ASCII_Names then | |
1587 | Set_Scope (Standard_Entity (E), Standard_Standard); | |
1588 | Set_Is_Immediately_Visible (Standard_Entity (E)); | |
1589 | end if; | |
1590 | end loop; | |
1591 | ||
1592 | -- The predefined package Standard itself does not have a scope; | |
1593 | -- it is the only entity in the system not to have one, and this | |
1594 | -- is what identifies the package to Gigi. | |
1595 | ||
1596 | Set_Scope (Standard_Standard, Empty); | |
1597 | ||
1598 | -- Set global variables indicating last Id values and version | |
1599 | ||
1600 | Last_Standard_Node_Id := Last_Node_Id; | |
1601 | Last_Standard_List_Id := Last_List_Id; | |
1602 | ||
5c736541 RD |
1603 | -- The Error node has an Etype of Any_Type to help error recovery |
1604 | ||
1605 | Set_Etype (Error, Any_Type); | |
9596236a AC |
1606 | |
1607 | -- Print representation of standard if switch set | |
1608 | ||
1609 | if Opt.Print_Standard then | |
1610 | Print_Standard; | |
1611 | end if; | |
70482933 RK |
1612 | end Create_Standard; |
1613 | ||
1614 | ------------------------------------ | |
1615 | -- Create_Unconstrained_Base_Type -- | |
1616 | ------------------------------------ | |
1617 | ||
1618 | procedure Create_Unconstrained_Base_Type | |
1619 | (E : Entity_Id; | |
1620 | K : Entity_Kind) | |
1621 | is | |
1622 | New_Ent : constant Entity_Id := New_Copy (E); | |
1623 | ||
1624 | begin | |
fbf5a39b AC |
1625 | Set_Ekind (E, K); |
1626 | Set_Is_Constrained (E, True); | |
1627 | Set_Is_First_Subtype (E, True); | |
1628 | Set_Etype (E, New_Ent); | |
70482933 RK |
1629 | |
1630 | Append_Entity (New_Ent, Standard_Standard); | |
1631 | Set_Is_Constrained (New_Ent, False); | |
1632 | Set_Etype (New_Ent, New_Ent); | |
1633 | Set_Is_Known_Valid (New_Ent, True); | |
1634 | ||
1635 | if K = E_Signed_Integer_Subtype then | |
1636 | Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent); | |
1637 | Set_Etype (High_Bound (Scalar_Range (E)), New_Ent); | |
1638 | end if; | |
1639 | ||
1640 | end Create_Unconstrained_Base_Type; | |
1641 | ||
1642 | -------------------- | |
1643 | -- Identifier_For -- | |
1644 | -------------------- | |
1645 | ||
1646 | function Identifier_For (S : Standard_Entity_Type) return Node_Id is | |
1647 | Ident_Node : Node_Id; | |
70482933 RK |
1648 | begin |
1649 | Ident_Node := New_Node (N_Identifier, Stloc); | |
1650 | Set_Chars (Ident_Node, Chars (Standard_Entity (S))); | |
1651 | return Ident_Node; | |
1652 | end Identifier_For; | |
1653 | ||
1654 | -------------------- | |
1655 | -- Make_Component -- | |
1656 | -------------------- | |
1657 | ||
1658 | procedure Make_Component | |
1659 | (Rec : Entity_Id; | |
1660 | Typ : Entity_Id; | |
1661 | Nam : String) | |
1662 | is | |
fbf5a39b | 1663 | Id : constant Entity_Id := New_Standard_Entity; |
70482933 RK |
1664 | |
1665 | begin | |
1666 | Set_Ekind (Id, E_Component); | |
1667 | Set_Etype (Id, Typ); | |
1668 | Set_Scope (Id, Rec); | |
1669 | Init_Component_Location (Id); | |
1670 | ||
1671 | Set_Original_Record_Component (Id, Id); | |
1672 | Make_Name (Id, Nam); | |
1673 | Append_Entity (Id, Rec); | |
1674 | end Make_Component; | |
1675 | ||
1676 | ----------------- | |
1677 | -- Make_Formal -- | |
1678 | ----------------- | |
1679 | ||
1680 | function Make_Formal | |
1681 | (Typ : Entity_Id; | |
891a6e79 | 1682 | Formal_Name : String) return Entity_Id |
70482933 RK |
1683 | is |
1684 | Formal : Entity_Id; | |
1685 | ||
1686 | begin | |
1687 | Formal := New_Standard_Entity; | |
1688 | ||
1689 | Set_Ekind (Formal, E_In_Parameter); | |
1690 | Set_Mechanism (Formal, Default_Mechanism); | |
1691 | Set_Scope (Formal, Standard_Standard); | |
1692 | Set_Etype (Formal, Typ); | |
1693 | Make_Name (Formal, Formal_Name); | |
1694 | ||
1695 | return Formal; | |
1696 | end Make_Formal; | |
1697 | ||
1698 | ------------------ | |
1699 | -- Make_Integer -- | |
1700 | ------------------ | |
1701 | ||
1702 | function Make_Integer (V : Uint) return Node_Id is | |
1703 | N : constant Node_Id := Make_Integer_Literal (Stloc, V); | |
70482933 RK |
1704 | begin |
1705 | Set_Is_Static_Expression (N); | |
1706 | return N; | |
1707 | end Make_Integer; | |
1708 | ||
1709 | --------------- | |
1710 | -- Make_Name -- | |
1711 | --------------- | |
1712 | ||
1713 | procedure Make_Name (Id : Entity_Id; Nam : String) is | |
1714 | begin | |
1715 | for J in 1 .. Nam'Length loop | |
1716 | Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1))); | |
1717 | end loop; | |
1718 | ||
1719 | Name_Len := Nam'Length; | |
1720 | Set_Chars (Id, Name_Find); | |
1721 | end Make_Name; | |
1722 | ||
1723 | ------------------ | |
1724 | -- New_Operator -- | |
1725 | ------------------ | |
1726 | ||
1727 | function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is | |
1728 | Ident_Node : Entity_Id; | |
1729 | ||
1730 | begin | |
1731 | Ident_Node := Make_Defining_Identifier (Stloc, Op); | |
1732 | ||
1733 | Set_Is_Pure (Ident_Node, True); | |
1734 | Set_Ekind (Ident_Node, E_Operator); | |
1735 | Set_Etype (Ident_Node, Typ); | |
1736 | Set_Scope (Ident_Node, Standard_Standard); | |
1737 | Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op)); | |
1738 | Set_Convention (Ident_Node, Convention_Intrinsic); | |
1739 | ||
1740 | Set_Is_Immediately_Visible (Ident_Node, True); | |
1741 | Set_Is_Intrinsic_Subprogram (Ident_Node, True); | |
1742 | ||
1743 | Set_Name_Entity_Id (Op, Ident_Node); | |
1744 | Append_Entity (Ident_Node, Standard_Standard); | |
1745 | return Ident_Node; | |
1746 | end New_Operator; | |
1747 | ||
1748 | ------------------------- | |
1749 | -- New_Standard_Entity -- | |
1750 | ------------------------- | |
1751 | ||
1752 | function New_Standard_Entity | |
891a6e79 | 1753 | (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id |
70482933 RK |
1754 | is |
1755 | E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc); | |
1756 | ||
1757 | begin | |
1758 | -- All standard entities are Pure and Public | |
1759 | ||
1760 | Set_Is_Pure (E); | |
1761 | Set_Is_Public (E); | |
1762 | ||
1763 | -- All standard entity names are analyzed manually, and are thus | |
1764 | -- frozen as soon as they are created. | |
1765 | ||
1766 | Set_Is_Frozen (E); | |
1767 | ||
1768 | -- Set debug information required for all standard types | |
1769 | ||
1770 | Set_Needs_Debug_Info (E); | |
1771 | ||
1772 | -- All standard entities are built with fully qualified names, so | |
1773 | -- set the flag to prevent an abortive attempt at requalification! | |
1774 | ||
1775 | Set_Has_Qualified_Name (E); | |
1776 | ||
1777 | -- Return newly created entity to be completed by caller | |
1778 | ||
1779 | return E; | |
1780 | end New_Standard_Entity; | |
1781 | ||
9596236a AC |
1782 | -------------------- |
1783 | -- Print_Standard -- | |
1784 | -------------------- | |
1785 | ||
1786 | procedure Print_Standard is | |
1787 | ||
1788 | procedure P (Item : String) renames Output.Write_Line; | |
1789 | -- Short-hand, since we do a lot of line writes here! | |
1790 | ||
1791 | procedure P_Int_Range (Size : Pos); | |
1792 | -- Prints the range of an integer based on its Size | |
1793 | ||
1794 | procedure P_Float_Range (Id : Entity_Id); | |
1795 | -- Prints the bounds range for the given float type entity | |
1796 | ||
c7f0d2c0 AC |
1797 | procedure P_Float_Type (Id : Entity_Id); |
1798 | -- Prints the type declaration of the given float type entity | |
1799 | ||
1800 | procedure P_Mixed_Name (Id : Name_Id); | |
1801 | -- Prints Id in mixed case | |
1802 | ||
9596236a AC |
1803 | ------------------- |
1804 | -- P_Float_Range -- | |
1805 | ------------------- | |
1806 | ||
1807 | procedure P_Float_Range (Id : Entity_Id) is | |
9596236a AC |
1808 | begin |
1809 | Write_Str (" range "); | |
d32e3cee GB |
1810 | UR_Write (Realval (Type_Low_Bound (Id))); |
1811 | Write_Str (" .. "); | |
1812 | UR_Write (Realval (Type_High_Bound (Id))); | |
9596236a AC |
1813 | Write_Str (";"); |
1814 | Write_Eol; | |
1815 | end P_Float_Range; | |
1816 | ||
c7f0d2c0 AC |
1817 | ------------------ |
1818 | -- P_Float_Type -- | |
1819 | ------------------ | |
1820 | ||
1821 | procedure P_Float_Type (Id : Entity_Id) is | |
1822 | begin | |
1823 | Write_Str (" type "); | |
1824 | P_Mixed_Name (Chars (Id)); | |
1825 | Write_Str (" is digits "); | |
1826 | Write_Int (UI_To_Int (Digits_Value (Id))); | |
1827 | Write_Eol; | |
1828 | P_Float_Range (Id); | |
1829 | Write_Str (" for "); | |
1830 | P_Mixed_Name (Chars (Id)); | |
1831 | Write_Str ("'Size use "); | |
1832 | Write_Int (UI_To_Int (RM_Size (Id))); | |
1833 | Write_Line (";"); | |
1834 | Write_Eol; | |
1835 | end P_Float_Type; | |
1836 | ||
9596236a AC |
1837 | ----------------- |
1838 | -- P_Int_Range -- | |
1839 | ----------------- | |
1840 | ||
1841 | procedure P_Int_Range (Size : Pos) is | |
1842 | begin | |
1843 | Write_Str (" is range -(2 **"); | |
1844 | Write_Int (Size - 1); | |
1845 | Write_Str (")"); | |
1846 | Write_Str (" .. +(2 **"); | |
1847 | Write_Int (Size - 1); | |
1848 | Write_Str (" - 1);"); | |
1849 | Write_Eol; | |
1850 | end P_Int_Range; | |
1851 | ||
c7f0d2c0 AC |
1852 | ------------------ |
1853 | -- P_Mixed_Name -- | |
1854 | ------------------ | |
1855 | ||
1856 | procedure P_Mixed_Name (Id : Name_Id) is | |
1857 | begin | |
1858 | Get_Name_String (Id); | |
1859 | ||
1860 | for J in 1 .. Name_Len loop | |
1861 | if J = 1 or else Name_Buffer (J - 1) = '_' then | |
1862 | Name_Buffer (J) := Fold_Upper (Name_Buffer (J)); | |
1863 | end if; | |
1864 | end loop; | |
1865 | ||
1866 | Write_Str (Name_Buffer (1 .. Name_Len)); | |
1867 | end P_Mixed_Name; | |
1868 | ||
9596236a AC |
1869 | -- Start of processing for Print_Standard |
1870 | ||
1871 | begin | |
1872 | P ("-- Representation of package Standard"); | |
1873 | Write_Eol; | |
1874 | P ("-- This is not accurate Ada, since new base types cannot be "); | |
1875 | P ("-- created, but the listing shows the target dependent"); | |
1876 | P ("-- characteristics of the Standard types for this compiler"); | |
1877 | Write_Eol; | |
1878 | ||
1879 | P ("package Standard is"); | |
efde9617 | 1880 | P ("pragma Pure (Standard);"); |
9596236a AC |
1881 | Write_Eol; |
1882 | ||
1883 | P (" type Boolean is (False, True);"); | |
1884 | P (" for Boolean'Size use 1;"); | |
1885 | P (" for Boolean use (False => 0, True => 1);"); | |
1886 | Write_Eol; | |
1887 | ||
1888 | -- Integer types | |
1889 | ||
1890 | Write_Str (" type Integer"); | |
1891 | P_Int_Range (Standard_Integer_Size); | |
1892 | Write_Str (" for Integer'Size use "); | |
1893 | Write_Int (Standard_Integer_Size); | |
1894 | P (";"); | |
1895 | Write_Eol; | |
1896 | ||
1897 | P (" subtype Natural is Integer range 0 .. Integer'Last;"); | |
1898 | P (" subtype Positive is Integer range 1 .. Integer'Last;"); | |
1899 | Write_Eol; | |
1900 | ||
1901 | Write_Str (" type Short_Short_Integer"); | |
1902 | P_Int_Range (Standard_Short_Short_Integer_Size); | |
1903 | Write_Str (" for Short_Short_Integer'Size use "); | |
1904 | Write_Int (Standard_Short_Short_Integer_Size); | |
1905 | P (";"); | |
1906 | Write_Eol; | |
1907 | ||
1908 | Write_Str (" type Short_Integer"); | |
1909 | P_Int_Range (Standard_Short_Integer_Size); | |
1910 | Write_Str (" for Short_Integer'Size use "); | |
1911 | Write_Int (Standard_Short_Integer_Size); | |
1912 | P (";"); | |
1913 | Write_Eol; | |
1914 | ||
1915 | Write_Str (" type Long_Integer"); | |
1916 | P_Int_Range (Standard_Long_Integer_Size); | |
1917 | Write_Str (" for Long_Integer'Size use "); | |
1918 | Write_Int (Standard_Long_Integer_Size); | |
1919 | P (";"); | |
1920 | Write_Eol; | |
1921 | ||
1922 | Write_Str (" type Long_Long_Integer"); | |
1923 | P_Int_Range (Standard_Long_Long_Integer_Size); | |
1924 | Write_Str (" for Long_Long_Integer'Size use "); | |
1925 | Write_Int (Standard_Long_Long_Integer_Size); | |
1926 | P (";"); | |
1927 | Write_Eol; | |
1928 | ||
1929 | -- Floating point types | |
1930 | ||
c7f0d2c0 AC |
1931 | P_Float_Type (Standard_Short_Float); |
1932 | P_Float_Type (Standard_Float); | |
1933 | P_Float_Type (Standard_Long_Float); | |
1934 | P_Float_Type (Standard_Long_Long_Float); | |
9596236a AC |
1935 | |
1936 | P (" type Character is (...)"); | |
1937 | Write_Str (" for Character'Size use "); | |
1938 | Write_Int (Standard_Character_Size); | |
1939 | P (";"); | |
1940 | P (" -- See RM A.1(35) for details of this type"); | |
1941 | Write_Eol; | |
1942 | ||
1943 | P (" type Wide_Character is (...)"); | |
1944 | Write_Str (" for Wide_Character'Size use "); | |
1945 | Write_Int (Standard_Wide_Character_Size); | |
1946 | P (";"); | |
1947 | P (" -- See RM A.1(36) for details of this type"); | |
1948 | Write_Eol; | |
1949 | ||
82c80734 | 1950 | P (" type Wide_Wide_Character is (...)"); |
5b6a0e43 | 1951 | Write_Str (" for Wide_Wide_Character'Size use "); |
82c80734 RD |
1952 | Write_Int (Standard_Wide_Wide_Character_Size); |
1953 | P (";"); | |
1954 | P (" -- See RM A.1(36) for details of this type"); | |
1955 | ||
9596236a AC |
1956 | P (" type String is array (Positive range <>) of Character;"); |
1957 | P (" pragma Pack (String);"); | |
1958 | Write_Eol; | |
1959 | ||
1960 | P (" type Wide_String is array (Positive range <>)" & | |
1961 | " of Wide_Character;"); | |
1962 | P (" pragma Pack (Wide_String);"); | |
1963 | Write_Eol; | |
1964 | ||
82c80734 RD |
1965 | P (" type Wide_Wide_String is array (Positive range <>)" & |
1966 | " of Wide_Wide_Character;"); | |
1967 | P (" pragma Pack (Wide_Wide_String);"); | |
1968 | Write_Eol; | |
1969 | ||
3d6c3bd7 GB |
1970 | -- We only have one representation each for 32-bit and 64-bit sizes, |
1971 | -- so select the right one based on Duration_32_Bits_On_Target. | |
9596236a AC |
1972 | |
1973 | if Duration_32_Bits_On_Target then | |
1974 | P (" type Duration is delta 0.020"); | |
1975 | P (" range -((2 ** 31 - 1) * 0.020) .."); | |
1976 | P (" +((2 ** 31 - 1) * 0.020);"); | |
1977 | P (" for Duration'Small use 0.020;"); | |
3d6c3bd7 | 1978 | |
9596236a AC |
1979 | else |
1980 | P (" type Duration is delta 0.000000001"); | |
1981 | P (" range -((2 ** 63 - 1) * 0.000000001) .."); | |
1982 | P (" +((2 ** 63 - 1) * 0.000000001);"); | |
1983 | P (" for Duration'Small use 0.000000001;"); | |
1984 | end if; | |
1985 | ||
1986 | Write_Eol; | |
1987 | ||
1988 | P (" Constraint_Error : exception;"); | |
1989 | P (" Program_Error : exception;"); | |
1990 | P (" Storage_Error : exception;"); | |
1991 | P (" Tasking_Error : exception;"); | |
1992 | P (" Numeric_Error : exception renames Constraint_Error;"); | |
1993 | Write_Eol; | |
1994 | ||
1995 | P ("end Standard;"); | |
1996 | end Print_Standard; | |
1997 | ||
f8726f2b AC |
1998 | ------------------------- |
1999 | -- Register_Float_Type -- | |
2000 | ------------------------- | |
2001 | ||
2002 | procedure Register_Float_Type | |
2003 | (Name : C_String; | |
2004 | Digs : Natural; | |
2005 | Complex : Boolean; | |
2006 | Count : Natural; | |
2007 | Float_Rep : Float_Rep_Kind; | |
2008 | Size : Positive; | |
2009 | Alignment : Natural) | |
2010 | is | |
15b682ca GB |
2011 | T : String (1 .. Name'Length); |
2012 | Last : Natural := 0; | |
2013 | ||
2014 | procedure Dump; | |
2015 | -- Dump information given by the back end for the type to register | |
2016 | ||
2017 | procedure Dump is | |
2018 | begin | |
2019 | Write_Str ("type " & T (1 .. Last) & " is "); | |
2020 | ||
2021 | if Count > 0 then | |
2022 | Write_Str ("array (1 .. "); | |
2023 | Write_Int (Int (Count)); | |
2024 | ||
2025 | if Complex then | |
2026 | Write_Str (", 1 .. 2"); | |
2027 | end if; | |
2028 | ||
2029 | Write_Str (") of "); | |
2030 | ||
2031 | elsif Complex then | |
2032 | Write_Str ("array (1 .. 2) of "); | |
2033 | end if; | |
2034 | ||
2035 | if Digs > 0 then | |
2036 | Write_Str ("digits "); | |
2037 | Write_Int (Int (Digs)); | |
2038 | Write_Line (";"); | |
2039 | ||
2040 | Write_Str ("pragma Float_Representation ("); | |
2041 | ||
2042 | case Float_Rep is | |
2043 | when IEEE_Binary => Write_Str ("IEEE"); | |
2044 | when VAX_Native => | |
2045 | case Digs is | |
2046 | when 6 => Write_Str ("VAXF"); | |
2047 | when 9 => Write_Str ("VAXD"); | |
2048 | when 15 => Write_Str ("VAXG"); | |
2049 | when others => Write_Str ("VAX_"); Write_Int (Int (Digs)); | |
2050 | end case; | |
2051 | when AAMP => Write_Str ("AAMP"); | |
2052 | end case; | |
2053 | Write_Line (", " & T & ");"); | |
2054 | ||
2055 | else | |
2056 | Write_Str ("mod 2**"); | |
2057 | Write_Int (Int (Size / Positive'Max (1, Count))); | |
2058 | Write_Line (";"); | |
2059 | end if; | |
2060 | ||
2061 | Write_Str ("for " & T & "'Size use "); | |
2062 | Write_Int (Int (Size)); | |
2063 | Write_Line (";"); | |
2064 | ||
2065 | Write_Str ("for " & T & "'Alignment use "); | |
2066 | Write_Int (Int (Alignment / 8)); | |
2067 | Write_Line (";"); | |
2068 | end Dump; | |
f8726f2b AC |
2069 | |
2070 | begin | |
15b682ca GB |
2071 | for J in T'Range loop |
2072 | T (J) := Name (Name'First + J - 1); | |
2073 | if T (J) = ASCII.NUL then | |
f8726f2b AC |
2074 | Last := J - 1; |
2075 | exit; | |
2076 | end if; | |
2077 | end loop; | |
2078 | ||
15b682ca GB |
2079 | if Debug_Flag_Dot_B then |
2080 | Dump; | |
2081 | end if; | |
2082 | ||
f8726f2b AC |
2083 | if Digs > 0 and then not Complex and then Count = 0 then |
2084 | declare | |
2085 | Ent : constant Entity_Id := New_Standard_Entity; | |
2086 | Esize : constant Pos := Pos ((Size + Alignment - 1) | |
2087 | / Alignment * Alignment); | |
2088 | begin | |
2089 | Set_Defining_Identifier | |
2090 | (New_Node (N_Full_Type_Declaration, Stloc), Ent); | |
15b682ca | 2091 | Make_Name (Ent, T (1 .. Last)); |
f8726f2b AC |
2092 | Set_Scope (Ent, Standard_Standard); |
2093 | Build_Float_Type (Ent, Esize, Float_Rep, Pos (Digs)); | |
2094 | Set_RM_Size (Ent, UI_From_Int (Int (Size))); | |
2095 | Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8))); | |
2096 | ||
2097 | if No (Back_End_Float_Types) then | |
2098 | Back_End_Float_Types := New_List (Ent); | |
2099 | ||
2100 | else | |
2101 | Append (Ent, Back_End_Float_Types); | |
2102 | end if; | |
2103 | end; | |
2104 | end if; | |
2105 | end Register_Float_Type; | |
2106 | ||
70482933 RK |
2107 | ---------------------- |
2108 | -- Set_Float_Bounds -- | |
2109 | ---------------------- | |
2110 | ||
2111 | procedure Set_Float_Bounds (Id : Entity_Id) is | |
d32e3cee | 2112 | L : Node_Id; |
70482933 RK |
2113 | -- Low bound of literal value |
2114 | ||
d32e3cee | 2115 | H : Node_Id; |
70482933 RK |
2116 | -- High bound of literal value |
2117 | ||
d32e3cee | 2118 | R : Node_Id; |
70482933 RK |
2119 | -- Range specification |
2120 | ||
d32e3cee GB |
2121 | Radix : constant Uint := Machine_Radix_Value (Id); |
2122 | Mantissa : constant Uint := Machine_Mantissa_Value (Id); | |
2123 | Emax : constant Uint := Machine_Emax_Value (Id); | |
2124 | Significand : constant Uint := Radix ** Mantissa - 1; | |
2125 | Exponent : constant Uint := Emax - Mantissa; | |
70482933 RK |
2126 | |
2127 | begin | |
2128 | -- Note: for the call from Cstand to initially create the types in | |
23c799b1 GB |
2129 | -- Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt |
2130 | -- will adjust these types appropriately VAX_Native if a pragma | |
2131 | -- Float_Representation (VAX_Float) is used. | |
70482933 | 2132 | |
d32e3cee GB |
2133 | H := Make_Float_Literal (Stloc, Radix, Significand, Exponent); |
2134 | L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent); | |
70482933 RK |
2135 | |
2136 | Set_Etype (L, Id); | |
2137 | Set_Is_Static_Expression (L); | |
2138 | ||
2139 | Set_Etype (H, Id); | |
2140 | Set_Is_Static_Expression (H); | |
2141 | ||
2142 | R := New_Node (N_Range, Stloc); | |
2143 | Set_Low_Bound (R, L); | |
2144 | Set_High_Bound (R, H); | |
2145 | Set_Includes_Infinities (R, True); | |
2146 | Set_Scalar_Range (Id, R); | |
2147 | Set_Etype (R, Id); | |
2148 | Set_Parent (R, Id); | |
2149 | end Set_Float_Bounds; | |
2150 | ||
2151 | ------------------------ | |
2152 | -- Set_Integer_Bounds -- | |
2153 | ------------------------ | |
2154 | ||
2155 | procedure Set_Integer_Bounds | |
2156 | (Id : Entity_Id; | |
2157 | Typ : Entity_Id; | |
2158 | Lb : Uint; | |
2159 | Hb : Uint) | |
2160 | is | |
2161 | L : Node_Id; -- Low bound of literal value | |
2162 | H : Node_Id; -- High bound of literal value | |
2163 | R : Node_Id; -- Range specification | |
2164 | ||
2165 | begin | |
2166 | L := Make_Integer (Lb); | |
2167 | H := Make_Integer (Hb); | |
2168 | ||
2169 | Set_Etype (L, Typ); | |
2170 | Set_Etype (H, Typ); | |
2171 | ||
2172 | R := New_Node (N_Range, Stloc); | |
2173 | Set_Low_Bound (R, L); | |
2174 | Set_High_Bound (R, H); | |
2175 | Set_Scalar_Range (Id, R); | |
2176 | Set_Etype (R, Typ); | |
2177 | Set_Parent (R, Id); | |
2178 | Set_Is_Unsigned_Type (Id, Lb >= 0); | |
2179 | end Set_Integer_Bounds; | |
2180 | ||
2181 | end CStand; |