?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.c-torture/execute/20020307-1.c: New test.
[official-gcc.git] / gcc / ada / cstand.adb
blob75378b579f71a2fd07b506d1226379c6c97e1c6a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- C S T A N D --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision$
10 -- --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
28
29 with Atree; use Atree;
30 with Csets; use Csets;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Layout; use Layout;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt; use Opt;
38 with Tbuild; use Tbuild;
39 with Ttypes; use Ttypes;
40 with Ttypef; use Ttypef;
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
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
58
59 procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int);
60 -- Procedure to build standard predefined float base type. The first
61 -- parameter is the entity for the type, and the second parameter
62 -- is the size in bits. The third parameter is the digits value.
63
64 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int);
65 -- Procedure to build standard predefined signed integer subtype. The
66 -- first parameter is the entity for the subtype. The second parameter
67 -- is the size in bits. The corresponding base type is not built by
68 -- this routine but instead must be built by the caller where needed.
69
70 procedure Create_Operators;
71 -- Make entries for each of the predefined operators in Standard
72
73 procedure Create_Unconstrained_Base_Type
74 (E : Entity_Id;
75 K : Entity_Kind);
76 -- The predefined signed integer types are constrained subtypes which
77 -- must have a corresponding unconstrained base type. This type is almost
78 -- useless. The only place it has semantics is Subtypes_Statically_Match.
79 -- Consequently, we arrange for it to be identical apart from the setting
80 -- of the constrained bit. This routine takes an entity E for the Type,
81 -- copies it to estabish the base type, then resets the Ekind of the
82 -- original entity to K (the Ekind for the subtype). The Etype field of
83 -- E is set by the call (to point to the created base type entity), and
84 -- also the Is_Constrained flag of E is set.
85 --
86 -- To understand the exact requirement for this, see RM 3.5.4(11) which
87 -- makes it clear that Integer, for example, is constrained, with the
88 -- constraint bounds matching the bounds of the (unconstrained) base
89 -- type. The point is that Integer and Integer'Base have identical
90 -- bounds, but do not statically match, since a subtype with constraints
91 -- never matches a subtype with no constraints.
92
93 function Identifier_For (S : Standard_Entity_Type) return Node_Id;
94 -- Returns an identifier node with the same name as the defining
95 -- identifier corresponding to the given Standard_Entity_Type value
96
97 procedure Make_Component
98 (Rec : Entity_Id;
99 Typ : Entity_Id;
100 Nam : String);
101 -- Build a record component with the given type and name, and append to
102 -- the list of components of Rec.
103
104 function Make_Formal
105 (Typ : Entity_Id;
106 Formal_Name : String)
107 return Entity_Id;
108 -- Construct entity for subprogram formal with given name and type
109
110 function Make_Integer (V : Uint) return Node_Id;
111 -- Builds integer literal with given value
112
113 procedure Make_Name (Id : Entity_Id; Nam : String);
114 -- Make an entry in the names table for Nam, and set as Chars field of Id
115
116 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id;
117 -- Build entity for standard operator with given name and type.
118
119 function New_Standard_Entity
120 (New_Node_Kind : Node_Kind := N_Defining_Identifier)
121 return Entity_Id;
122 -- Builds a new entity for Standard
123
124 procedure Set_Integer_Bounds
125 (Id : Entity_Id;
126 Typ : Entity_Id;
127 Lb : Uint;
128 Hb : Uint);
129 -- Procedure to set bounds for integer type or subtype. Id is the entity
130 -- whose bounds and type are to be set. The Typ parameter is the Etype
131 -- value for the entity (which will be the same as Id for all predefined
132 -- integer base types. The third and fourth parameters are the bounds.
133
134 ----------------------
135 -- Build_Float_Type --
136 ----------------------
137
138 procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int) is
139 begin
140 Set_Type_Definition (Parent (E),
141 Make_Floating_Point_Definition (Stloc,
142 Digits_Expression => Make_Integer (UI_From_Int (Digs))));
143 Set_Ekind (E, E_Floating_Point_Type);
144 Set_Etype (E, E);
145 Init_Size (E, Siz);
146 Set_Prim_Alignment (E);
147 Init_Digits_Value (E, Digs);
148 Set_Float_Bounds (E);
149 Set_Is_Frozen (E);
150 Set_Is_Public (E);
151 Set_Size_Known_At_Compile_Time (E);
152 end Build_Float_Type;
153
154 -------------------------------
155 -- Build_Signed_Integer_Type --
156 -------------------------------
157
158 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int) is
159 U2Siz1 : constant Uint := 2 ** (Siz - 1);
160 Lbound : constant Uint := -U2Siz1;
161 Ubound : constant Uint := U2Siz1 - 1;
162
163 begin
164 Set_Type_Definition (Parent (E),
165 Make_Signed_Integer_Type_Definition (Stloc,
166 Low_Bound => Make_Integer (Lbound),
167 High_Bound => Make_Integer (Ubound)));
168
169 Set_Ekind (E, E_Signed_Integer_Type);
170 Set_Etype (E, E);
171 Init_Size (E, Siz);
172 Set_Prim_Alignment (E);
173 Set_Integer_Bounds (E, E, Lbound, Ubound);
174 Set_Is_Frozen (E);
175 Set_Is_Public (E);
176 Set_Is_Known_Valid (E);
177 Set_Size_Known_At_Compile_Time (E);
178 end Build_Signed_Integer_Type;
179
180 ----------------------
181 -- Create_Operators --
182 ----------------------
183
184 -- Each operator has an abbreviated signature. The formals have the names
185 -- LEFT and RIGHT. Their types are not actually used for resolution.
186
187 procedure Create_Operators is
188 Op_Node : Entity_Id;
189
190 -- Following list has two entries for concatenation, to include
191 -- explicitly the operation on wide strings.
192
193 Binary_Ops : constant array (S_Binary_Ops) of Name_Id :=
194 (Name_Op_Add, Name_Op_And, Name_Op_Concat, Name_Op_Concat,
195 Name_Op_Divide, Name_Op_Eq, Name_Op_Expon, Name_Op_Ge,
196 Name_Op_Gt, Name_Op_Le, Name_Op_Lt, Name_Op_Mod,
197 Name_Op_Multiply, Name_Op_Ne, Name_Op_Or, Name_Op_Rem,
198 Name_Op_Subtract, Name_Op_Xor);
199
200 Bin_Op_Types : constant array (S_Binary_Ops) of Entity_Id :=
201 (Universal_Integer, Standard_Boolean,
202 Standard_String, Standard_Wide_String,
203 Universal_Integer, Standard_Boolean,
204 Universal_Integer, Standard_Boolean,
205 Standard_Boolean, Standard_Boolean,
206 Standard_Boolean, Universal_Integer,
207 Universal_Integer, Standard_Boolean,
208 Standard_Boolean, Universal_Integer,
209 Universal_Integer, Standard_Boolean);
210
211 Unary_Ops : constant array (S_Unary_Ops) of Name_Id :=
212 (Name_Op_Abs, Name_Op_Subtract, Name_Op_Not, Name_Op_Add);
213
214 Unary_Op_Types : constant array (S_Unary_Ops) of Entity_Id :=
215 (Universal_Integer, Universal_Integer,
216 Standard_Boolean, Universal_Integer);
217
218 -- Corresponding to Abs, Minus, Not, and Plus.
219
220 begin
221 for J in S_Binary_Ops loop
222 Op_Node := New_Operator (Binary_Ops (J), Bin_Op_Types (J));
223 SE (J) := Op_Node;
224 Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node);
225 Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node);
226 end loop;
227
228 for J in S_Unary_Ops loop
229 Op_Node := New_Operator (Unary_Ops (J), Unary_Op_Types (J));
230 SE (J) := Op_Node;
231 Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node);
232 end loop;
233
234 -- For concatenation, we create a separate operator for each
235 -- array type. This simplifies the resolution of the component-
236 -- component concatenation operation. In Standard, we set the types
237 -- of the formals for string and wide string concatenation.
238
239 Set_Etype (First_Entity (Standard_Op_Concat), Standard_String);
240 Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String);
241
242 Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String);
243 Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String);
244
245 end Create_Operators;
246
247 ---------------------
248 -- Create_Standard --
249 ---------------------
250
251 -- The tree for the package Standard is prefixed to all compilations.
252 -- Several entities required by semantic analysis are denoted by global
253 -- variables that are initialized to point to the corresponding
254 -- occurrences in STANDARD. The visible entities of STANDARD are
255 -- created here. The private entities defined in STANDARD are created
256 -- by Initialize_Standard in the semantics module.
257
258 procedure Create_Standard is
259 Decl_S : List_Id;
260 -- List of declarations in Standard
261
262 Decl_A : List_Id;
263 -- List of declarations in ASCII
264
265 Decl : Node_Id;
266 Pspec : Node_Id;
267 Tdef_Node : Node_Id;
268 Ident_Node : Node_Id;
269 Ccode : Char_Code;
270 E_Id : Entity_Id;
271 R_Node : Node_Id;
272 B_Node : Node_Id;
273
274 procedure Build_Exception (S : Standard_Entity_Type);
275 -- Procedure to declare given entity as an exception
276
277 ---------------------
278 -- Build_Exception --
279 ---------------------
280
281 procedure Build_Exception (S : Standard_Entity_Type) is
282 begin
283 Set_Ekind (Standard_Entity (S), E_Exception);
284 Set_Etype (Standard_Entity (S), Standard_Exception_Type);
285 Set_Exception_Code (Standard_Entity (S), Uint_0);
286 Set_Is_Public (Standard_Entity (S), True);
287
288 Decl :=
289 Make_Exception_Declaration (Stloc,
290 Defining_Identifier => Standard_Entity (S));
291 Append (Decl, Decl_S);
292 end Build_Exception;
293
294 -- Start of processing for Create_Standard
295
296 begin
297 Decl_S := New_List;
298
299 -- First step is to create defining identifiers for each entity
300
301 for S in Standard_Entity_Type loop
302 declare
303 S_Name : constant String := Standard_Entity_Type'Image (S);
304 -- Name of entity (note we skip S_ at the start)
305
306 Ident_Node : Node_Id;
307 -- Defining identifier node
308
309 begin
310 Ident_Node := New_Standard_Entity;
311 Make_Name (Ident_Node, S_Name (3 .. S_Name'Length));
312 Standard_Entity (S) := Ident_Node;
313 end;
314 end loop;
315
316 -- Create package declaration node for package Standard
317
318 Standard_Package_Node := New_Node (N_Package_Declaration, Stloc);
319
320 Pspec := New_Node (N_Package_Specification, Stloc);
321 Set_Specification (Standard_Package_Node, Pspec);
322
323 Set_Defining_Unit_Name (Pspec, Standard_Standard);
324 Set_Visible_Declarations (Pspec, Decl_S);
325
326 Set_Ekind (Standard_Standard, E_Package);
327 Set_Is_Pure (Standard_Standard);
328 Set_Is_Compilation_Unit (Standard_Standard);
329
330 -- Create type declaration nodes for standard types
331
332 for S in S_Types loop
333 Decl := New_Node (N_Full_Type_Declaration, Stloc);
334 Set_Defining_Identifier (Decl, Standard_Entity (S));
335 Set_Is_Frozen (Standard_Entity (S));
336 Set_Is_Public (Standard_Entity (S));
337 Append (Decl, Decl_S);
338 end loop;
339
340 -- Create type definition node for type Boolean. The Size is set to
341 -- 1 as required by Ada 95 and current ARG interpretations for Ada/83.
342
343 -- Note: Object_Size of Boolean is 8. This means that we do NOT in
344 -- general know that Boolean variables have valid values, so we do
345 -- not set the Is_Known_Valid flag.
346
347 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
348 Set_Literals (Tdef_Node, New_List);
349 Append (Standard_False, Literals (Tdef_Node));
350 Append (Standard_True, Literals (Tdef_Node));
351 Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node);
352
353 Set_Ekind (Standard_Boolean, E_Enumeration_Type);
354 Set_First_Literal (Standard_Boolean, Standard_False);
355 Set_Etype (Standard_Boolean, Standard_Boolean);
356 Init_Esize (Standard_Boolean, 8);
357 Init_RM_Size (Standard_Boolean, 1);
358 Set_Prim_Alignment (Standard_Boolean);
359
360 Set_Is_Unsigned_Type (Standard_Boolean);
361 Set_Size_Known_At_Compile_Time (Standard_Boolean);
362
363 Set_Ekind (Standard_True, E_Enumeration_Literal);
364 Set_Etype (Standard_True, Standard_Boolean);
365 Set_Enumeration_Pos (Standard_True, Uint_1);
366 Set_Enumeration_Rep (Standard_True, Uint_1);
367 Set_Is_Known_Valid (Standard_True, True);
368
369 Set_Ekind (Standard_False, E_Enumeration_Literal);
370 Set_Etype (Standard_False, Standard_Boolean);
371 Set_Enumeration_Pos (Standard_False, Uint_0);
372 Set_Enumeration_Rep (Standard_False, Uint_0);
373 Set_Is_Known_Valid (Standard_False, True);
374
375 -- For the bounds of Boolean, we create a range node corresponding to
376
377 -- range False .. True
378
379 -- where the occurrences of the literals must point to the
380 -- corresponding definition.
381
382 R_Node := New_Node (N_Range, Stloc);
383 B_Node := New_Node (N_Identifier, Stloc);
384 Set_Chars (B_Node, Chars (Standard_False));
385 Set_Entity (B_Node, Standard_False);
386 Set_Etype (B_Node, Standard_Boolean);
387 Set_Is_Static_Expression (B_Node);
388 Set_Low_Bound (R_Node, B_Node);
389
390 B_Node := New_Node (N_Identifier, Stloc);
391 Set_Chars (B_Node, Chars (Standard_True));
392 Set_Entity (B_Node, Standard_True);
393 Set_Etype (B_Node, Standard_Boolean);
394 Set_Is_Static_Expression (B_Node);
395 Set_High_Bound (R_Node, B_Node);
396
397 Set_Scalar_Range (Standard_Boolean, R_Node);
398 Set_Etype (R_Node, Standard_Boolean);
399 Set_Parent (R_Node, Standard_Boolean);
400
401 -- Create type definition nodes for predefined integer types
402
403 Build_Signed_Integer_Type
404 (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size);
405
406 Build_Signed_Integer_Type
407 (Standard_Short_Integer, Standard_Short_Integer_Size);
408
409 Build_Signed_Integer_Type
410 (Standard_Integer, Standard_Integer_Size);
411
412 declare
413 LIS : Nat;
414
415 begin
416 if Debug_Flag_M then
417 LIS := 64;
418 else
419 LIS := Standard_Long_Integer_Size;
420 end if;
421
422 Build_Signed_Integer_Type (Standard_Long_Integer, LIS);
423 end;
424
425 Build_Signed_Integer_Type
426 (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size);
427
428 Create_Unconstrained_Base_Type
429 (Standard_Short_Short_Integer, E_Signed_Integer_Subtype);
430
431 Create_Unconstrained_Base_Type
432 (Standard_Short_Integer, E_Signed_Integer_Subtype);
433
434 Create_Unconstrained_Base_Type
435 (Standard_Integer, E_Signed_Integer_Subtype);
436
437 Create_Unconstrained_Base_Type
438 (Standard_Long_Integer, E_Signed_Integer_Subtype);
439
440 Create_Unconstrained_Base_Type
441 (Standard_Long_Long_Integer, E_Signed_Integer_Subtype);
442
443 -- Create type definition nodes for predefined float types
444
445 Build_Float_Type
446 (Standard_Short_Float,
447 Standard_Short_Float_Size,
448 Standard_Short_Float_Digits);
449
450 Build_Float_Type
451 (Standard_Float,
452 Standard_Float_Size,
453 Standard_Float_Digits);
454
455 Build_Float_Type
456 (Standard_Long_Float,
457 Standard_Long_Float_Size,
458 Standard_Long_Float_Digits);
459
460 Build_Float_Type
461 (Standard_Long_Long_Float,
462 Standard_Long_Long_Float_Size,
463 Standard_Long_Long_Float_Digits);
464
465 -- Create type definition node for type Character. Note that we do not
466 -- set the Literals field, since type Character is handled with special
467 -- routine that do not need a literal list.
468
469 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
470 Set_Type_Definition (Parent (Standard_Character), Tdef_Node);
471
472 Set_Ekind (Standard_Character, E_Enumeration_Type);
473 Set_Etype (Standard_Character, Standard_Character);
474 Init_Size (Standard_Character, Standard_Character_Size);
475 Set_Prim_Alignment (Standard_Character);
476
477 Set_Is_Unsigned_Type (Standard_Character);
478 Set_Is_Character_Type (Standard_Character);
479 Set_Is_Known_Valid (Standard_Character);
480 Set_Size_Known_At_Compile_Time (Standard_Character);
481
482 -- Create the bounds for type Character.
483
484 R_Node := New_Node (N_Range, Stloc);
485
486 -- Low bound for type Character (Standard.Nul)
487
488 B_Node := New_Node (N_Character_Literal, Stloc);
489 Set_Is_Static_Expression (B_Node);
490 Set_Chars (B_Node, No_Name);
491 Set_Char_Literal_Value (B_Node, 16#00#);
492 Set_Entity (B_Node, Empty);
493 Set_Etype (B_Node, Standard_Character);
494 Set_Low_Bound (R_Node, B_Node);
495
496 -- High bound for type Character
497
498 B_Node := New_Node (N_Character_Literal, Stloc);
499 Set_Is_Static_Expression (B_Node);
500 Set_Chars (B_Node, No_Name);
501 Set_Char_Literal_Value (B_Node, 16#FF#);
502 Set_Entity (B_Node, Empty);
503 Set_Etype (B_Node, Standard_Character);
504 Set_High_Bound (R_Node, B_Node);
505
506 Set_Scalar_Range (Standard_Character, R_Node);
507 Set_Etype (R_Node, Standard_Character);
508 Set_Parent (R_Node, Standard_Character);
509
510 -- Create type definition for type Wide_Character. Note that we do not
511 -- set the Literals field, since type Wide_Character is handled with
512 -- special routines that do not need a literal list.
513
514 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
515 Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node);
516
517 Set_Ekind (Standard_Wide_Character, E_Enumeration_Type);
518 Set_Etype (Standard_Wide_Character, Standard_Wide_Character);
519 Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size);
520
521 Set_Prim_Alignment (Standard_Wide_Character);
522 Set_Is_Unsigned_Type (Standard_Wide_Character);
523 Set_Is_Character_Type (Standard_Wide_Character);
524 Set_Is_Known_Valid (Standard_Wide_Character);
525 Set_Size_Known_At_Compile_Time (Standard_Wide_Character);
526
527 -- Create the bounds for type Wide_Character.
528
529 R_Node := New_Node (N_Range, Stloc);
530
531 -- Low bound for type Wide_Character
532
533 B_Node := New_Node (N_Character_Literal, Stloc);
534 Set_Is_Static_Expression (B_Node);
535 Set_Chars (B_Node, No_Name); -- ???
536 Set_Char_Literal_Value (B_Node, 16#0000#);
537 Set_Entity (B_Node, Empty);
538 Set_Etype (B_Node, Standard_Wide_Character);
539 Set_Low_Bound (R_Node, B_Node);
540
541 -- High bound for type Wide_Character
542
543 B_Node := New_Node (N_Character_Literal, Stloc);
544 Set_Is_Static_Expression (B_Node);
545 Set_Chars (B_Node, No_Name); -- ???
546 Set_Char_Literal_Value (B_Node, 16#FFFF#);
547 Set_Entity (B_Node, Empty);
548 Set_Etype (B_Node, Standard_Wide_Character);
549 Set_High_Bound (R_Node, B_Node);
550
551 Set_Scalar_Range (Standard_Wide_Character, R_Node);
552 Set_Etype (R_Node, Standard_Wide_Character);
553 Set_Parent (R_Node, Standard_Wide_Character);
554
555 -- Create type definition node for type String
556
557 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
558 Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Character));
559 Set_Subtype_Marks (Tdef_Node, New_List);
560 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
561 Set_Type_Definition (Parent (Standard_String), Tdef_Node);
562
563 Set_Ekind (Standard_String, E_String_Type);
564 Set_Etype (Standard_String, Standard_String);
565 Set_Component_Type (Standard_String, Standard_Character);
566 Set_Component_Size (Standard_String, Uint_8);
567 Init_Size_Align (Standard_String);
568
569 -- Set index type of String
570
571 E_Id := First
572 (Subtype_Marks (Type_Definition (Parent (Standard_String))));
573 Set_First_Index (Standard_String, E_Id);
574 Set_Entity (E_Id, Standard_Positive);
575 Set_Etype (E_Id, Standard_Positive);
576
577 -- Create type definition node for type Wide_String
578
579 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
580 Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Wide_Character));
581 Set_Subtype_Marks (Tdef_Node, New_List);
582 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
583 Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
584
585 Set_Ekind (Standard_Wide_String, E_String_Type);
586 Set_Etype (Standard_Wide_String, Standard_Wide_String);
587 Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
588 Set_Component_Size (Standard_Wide_String, Uint_16);
589 Init_Size_Align (Standard_Wide_String);
590
591 -- Set index type of Wide_String
592
593 E_Id := First
594 (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String))));
595 Set_First_Index (Standard_Wide_String, E_Id);
596 Set_Entity (E_Id, Standard_Positive);
597 Set_Etype (E_Id, Standard_Positive);
598
599 -- Create subtype declaration for Natural
600
601 Decl := New_Node (N_Subtype_Declaration, Stloc);
602 Set_Defining_Identifier (Decl, Standard_Natural);
603 Set_Subtype_Indication (Decl,
604 New_Occurrence_Of (Standard_Integer, Stloc));
605 Append (Decl, Decl_S);
606
607 Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype);
608 Set_Etype (Standard_Natural, Base_Type (Standard_Integer));
609 Init_Esize (Standard_Natural, Standard_Integer_Size);
610 Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1);
611 Set_Prim_Alignment (Standard_Natural);
612 Set_Size_Known_At_Compile_Time
613 (Standard_Natural);
614 Set_Integer_Bounds (Standard_Natural,
615 Typ => Base_Type (Standard_Integer),
616 Lb => Uint_0,
617 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
618 Set_Is_Constrained (Standard_Natural);
619 Set_Is_Frozen (Standard_Natural);
620 Set_Is_Public (Standard_Natural);
621
622 -- Create subtype declaration for Positive
623
624 Decl := New_Node (N_Subtype_Declaration, Stloc);
625 Set_Defining_Identifier (Decl, Standard_Positive);
626 Set_Subtype_Indication (Decl,
627 New_Occurrence_Of (Standard_Integer, Stloc));
628 Append (Decl, Decl_S);
629
630 Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
631 Set_Etype (Standard_Positive, Base_Type (Standard_Integer));
632 Init_Esize (Standard_Positive, Standard_Integer_Size);
633 Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1);
634 Set_Prim_Alignment (Standard_Positive);
635
636 Set_Size_Known_At_Compile_Time (Standard_Positive);
637
638 Set_Integer_Bounds (Standard_Positive,
639 Typ => Base_Type (Standard_Integer),
640 Lb => Uint_1,
641 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
642 Set_Is_Constrained (Standard_Positive);
643 Set_Is_Frozen (Standard_Positive);
644 Set_Is_Public (Standard_Positive);
645
646 -- Create declaration for package ASCII
647
648 Decl := New_Node (N_Package_Declaration, Stloc);
649 Append (Decl, Decl_S);
650
651 Pspec := New_Node (N_Package_Specification, Stloc);
652 Set_Specification (Decl, Pspec);
653
654 Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII));
655 Set_Ekind (Standard_Entity (S_ASCII), E_Package);
656 Decl_A := New_List; -- for ASCII declarations
657 Set_Visible_Declarations (Pspec, Decl_A);
658
659 -- Create control character definitions in package ASCII. Note that
660 -- the character literal entries created here correspond to literal
661 -- values that are impossible in the source, but can be represented
662 -- internally with no difficulties.
663
664 Ccode := 16#00#;
665
666 for S in S_ASCII_Names loop
667 Decl := New_Node (N_Object_Declaration, Staloc);
668 Set_Constant_Present (Decl, True);
669
670 declare
671 A_Char : Entity_Id := Standard_Entity (S);
672 Expr_Decl : Node_Id;
673
674 begin
675 Set_Sloc (A_Char, Staloc);
676 Set_Ekind (A_Char, E_Constant);
677 Set_Not_Source_Assigned (A_Char, True);
678 Set_Is_True_Constant (A_Char, True);
679 Set_Etype (A_Char, Standard_Character);
680 Set_Scope (A_Char, Standard_Entity (S_ASCII));
681 Set_Is_Immediately_Visible (A_Char, False);
682 Set_Is_Public (A_Char, True);
683 Set_Is_Known_Valid (A_Char, True);
684
685 Append_Entity (A_Char, Standard_Entity (S_ASCII));
686 Set_Defining_Identifier (Decl, A_Char);
687
688 Set_Object_Definition (Decl, Identifier_For (S_Character));
689 Expr_Decl := New_Node (N_Character_Literal, Staloc);
690 Set_Expression (Decl, Expr_Decl);
691
692 Set_Is_Static_Expression (Expr_Decl);
693 Set_Chars (Expr_Decl, No_Name);
694 Set_Etype (Expr_Decl, Standard_Character);
695 Set_Char_Literal_Value (Expr_Decl, Ccode);
696 end;
697
698 Append (Decl, Decl_A);
699
700 -- Increment character code, dealing with non-contiguities
701
702 Ccode := Ccode + 1;
703
704 if Ccode = 16#20# then
705 Ccode := 16#21#;
706 elsif Ccode = 16#27# then
707 Ccode := 16#3A#;
708 elsif Ccode = 16#3C# then
709 Ccode := 16#3F#;
710 elsif Ccode = 16#41# then
711 Ccode := 16#5B#;
712 end if;
713 end loop;
714
715 -- Create semantic phase entities
716
717 Standard_Void_Type := New_Standard_Entity;
718 Set_Ekind (Standard_Void_Type, E_Void);
719 Set_Etype (Standard_Void_Type, Standard_Void_Type);
720 Init_Size_Align (Standard_Void_Type);
721 Set_Scope (Standard_Void_Type, Standard_Standard);
722 Make_Name (Standard_Void_Type, "_void_type");
723
724 -- The type field of packages is set to void
725
726 Set_Etype (Standard_Standard, Standard_Void_Type);
727 Set_Etype (Standard_ASCII, Standard_Void_Type);
728
729 -- Standard_A_String is actually used in generated code, so it has a
730 -- type name that is reasonable, but does not overlap any Ada name.
731
732 Standard_A_String := New_Standard_Entity;
733 Set_Ekind (Standard_A_String, E_Access_Type);
734 Set_Scope (Standard_A_String, Standard_Standard);
735 Set_Etype (Standard_A_String, Standard_A_String);
736
737 if Debug_Flag_6 then
738 Init_Size (Standard_A_String, System_Address_Size);
739 else
740 Init_Size (Standard_A_String, System_Address_Size * 2);
741 end if;
742
743 Init_Alignment (Standard_A_String);
744
745 Set_Directly_Designated_Type
746 (Standard_A_String, Standard_String);
747 Make_Name (Standard_A_String, "access_string");
748
749 Standard_A_Char := New_Standard_Entity;
750 Set_Ekind (Standard_A_Char, E_Access_Type);
751 Set_Scope (Standard_A_Char, Standard_Standard);
752 Set_Etype (Standard_A_Char, Standard_A_String);
753 Init_Size (Standard_A_Char, System_Address_Size);
754 Set_Prim_Alignment (Standard_A_Char);
755
756 Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
757 Make_Name (Standard_A_Char, "access_character");
758
759 -- Note on type names. The type names for the following special types
760 -- are constructed so that they will look reasonable should they ever
761 -- appear in error messages etc, although in practice the use of the
762 -- special insertion character } for types results in special handling
763 -- of these type names in any case. The blanks in these names would
764 -- trouble in Gigi, but that's OK here, since none of these types
765 -- should ever get through to Gigi! Attributes of these types are
766 -- filled out to minimize problems with cascaded errors (for example,
767 -- Any_Integer is given reasonable and consistent type and size values)
768
769 Any_Type := New_Standard_Entity;
770 Decl := New_Node (N_Full_Type_Declaration, Stloc);
771 Set_Defining_Identifier (Decl, Any_Type);
772 Set_Scope (Any_Type, Standard_Standard);
773 Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size);
774 Make_Name (Any_Type, "any type");
775
776 Any_Id := New_Standard_Entity;
777 Set_Ekind (Any_Id, E_Variable);
778 Set_Scope (Any_Id, Standard_Standard);
779 Set_Etype (Any_Id, Any_Type);
780 Init_Size_Align (Any_Id);
781 Make_Name (Any_Id, "any id");
782
783 Any_Access := New_Standard_Entity;
784 Set_Ekind (Any_Access, E_Access_Type);
785 Set_Scope (Any_Access, Standard_Standard);
786 Set_Etype (Any_Access, Any_Access);
787 Init_Size (Any_Access, System_Address_Size);
788 Set_Prim_Alignment (Any_Access);
789 Make_Name (Any_Access, "an access type");
790
791 Any_Array := New_Standard_Entity;
792 Set_Ekind (Any_Array, E_String_Type);
793 Set_Scope (Any_Array, Standard_Standard);
794 Set_Etype (Any_Array, Any_Array);
795 Set_Component_Type (Any_Array, Any_Character);
796 Init_Size_Align (Any_Array);
797 Make_Name (Any_Array, "an array type");
798
799 Any_Boolean := New_Standard_Entity;
800 Set_Ekind (Any_Boolean, E_Enumeration_Type);
801 Set_Scope (Any_Boolean, Standard_Standard);
802 Set_Etype (Any_Boolean, Standard_Boolean);
803 Init_Esize (Any_Boolean, 8);
804 Init_RM_Size (Any_Boolean, 1);
805 Set_Prim_Alignment (Any_Boolean);
806 Set_Is_Unsigned_Type (Any_Boolean);
807 Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
808 Make_Name (Any_Boolean, "a boolean type");
809
810 Any_Character := New_Standard_Entity;
811 Set_Ekind (Any_Character, E_Enumeration_Type);
812 Set_Scope (Any_Character, Standard_Standard);
813 Set_Etype (Any_Character, Any_Character);
814 Set_Is_Unsigned_Type (Any_Character);
815 Set_Is_Character_Type (Any_Character);
816 Init_Size (Any_Character, Standard_Character_Size);
817 Set_Prim_Alignment (Any_Character);
818 Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
819 Make_Name (Any_Character, "a character type");
820
821 Any_Composite := New_Standard_Entity;
822 Set_Ekind (Any_Composite, E_Array_Type);
823 Set_Scope (Any_Composite, Standard_Standard);
824 Set_Etype (Any_Composite, Any_Composite);
825 Set_Component_Size (Any_Composite, Uint_0);
826 Set_Component_Type (Any_Composite, Standard_Integer);
827 Init_Size_Align (Any_Composite);
828 Make_Name (Any_Composite, "a composite type");
829
830 Any_Discrete := New_Standard_Entity;
831 Set_Ekind (Any_Discrete, E_Signed_Integer_Type);
832 Set_Scope (Any_Discrete, Standard_Standard);
833 Set_Etype (Any_Discrete, Any_Discrete);
834 Init_Size (Any_Discrete, Standard_Integer_Size);
835 Set_Prim_Alignment (Any_Discrete);
836 Make_Name (Any_Discrete, "a discrete type");
837
838 Any_Fixed := New_Standard_Entity;
839 Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type);
840 Set_Scope (Any_Fixed, Standard_Standard);
841 Set_Etype (Any_Fixed, Any_Fixed);
842 Init_Size (Any_Fixed, Standard_Integer_Size);
843 Set_Prim_Alignment (Any_Fixed);
844 Make_Name (Any_Fixed, "a fixed-point type");
845
846 Any_Integer := New_Standard_Entity;
847 Set_Ekind (Any_Integer, E_Signed_Integer_Type);
848 Set_Scope (Any_Integer, Standard_Standard);
849 Set_Etype (Any_Integer, Standard_Long_Long_Integer);
850 Init_Size (Any_Integer, Standard_Long_Long_Integer_Size);
851 Set_Prim_Alignment (Any_Integer);
852
853 Set_Integer_Bounds
854 (Any_Integer,
855 Typ => Base_Type (Standard_Integer),
856 Lb => Uint_0,
857 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
858 Make_Name (Any_Integer, "an integer type");
859
860 Any_Modular := New_Standard_Entity;
861 Set_Ekind (Any_Modular, E_Modular_Integer_Type);
862 Set_Scope (Any_Modular, Standard_Standard);
863 Set_Etype (Any_Modular, Standard_Long_Long_Integer);
864 Init_Size (Any_Modular, Standard_Long_Long_Integer_Size);
865 Set_Prim_Alignment (Any_Modular);
866 Set_Is_Unsigned_Type (Any_Modular);
867 Make_Name (Any_Modular, "a modular type");
868
869 Any_Numeric := New_Standard_Entity;
870 Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
871 Set_Scope (Any_Numeric, Standard_Standard);
872 Set_Etype (Any_Numeric, Standard_Long_Long_Integer);
873 Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size);
874 Set_Prim_Alignment (Any_Numeric);
875 Make_Name (Any_Numeric, "a numeric type");
876
877 Any_Real := New_Standard_Entity;
878 Set_Ekind (Any_Real, E_Floating_Point_Type);
879 Set_Scope (Any_Real, Standard_Standard);
880 Set_Etype (Any_Real, Standard_Long_Long_Float);
881 Init_Size (Any_Real, Standard_Long_Long_Float_Size);
882 Set_Prim_Alignment (Any_Real);
883 Make_Name (Any_Real, "a real type");
884
885 Any_Scalar := New_Standard_Entity;
886 Set_Ekind (Any_Scalar, E_Signed_Integer_Type);
887 Set_Scope (Any_Scalar, Standard_Standard);
888 Set_Etype (Any_Scalar, Any_Scalar);
889 Init_Size (Any_Scalar, Standard_Integer_Size);
890 Set_Prim_Alignment (Any_Scalar);
891 Make_Name (Any_Scalar, "a scalar type");
892
893 Any_String := New_Standard_Entity;
894 Set_Ekind (Any_String, E_String_Type);
895 Set_Scope (Any_String, Standard_Standard);
896 Set_Etype (Any_String, Any_String);
897 Set_Component_Type (Any_String, Any_Character);
898 Init_Size_Align (Any_String);
899 Make_Name (Any_String, "a string type");
900
901 declare
902 Index : Node_Id;
903 Indexes : List_Id;
904
905 begin
906 Index :=
907 Make_Range (Stloc,
908 Low_Bound => Make_Integer (Uint_0),
909 High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
910 Indexes := New_List (Index);
911 Set_Etype (Index, Standard_Integer);
912 Set_First_Index (Any_String, Index);
913 end;
914
915 Standard_Integer_8 := New_Standard_Entity;
916 Decl := New_Node (N_Full_Type_Declaration, Stloc);
917 Set_Defining_Identifier (Decl, Standard_Integer_8);
918 Make_Name (Standard_Integer_8, "integer_8");
919 Set_Scope (Standard_Integer_8, Standard_Standard);
920 Build_Signed_Integer_Type (Standard_Integer_8, 8);
921
922 Standard_Integer_16 := New_Standard_Entity;
923 Decl := New_Node (N_Full_Type_Declaration, Stloc);
924 Set_Defining_Identifier (Decl, Standard_Integer_16);
925 Make_Name (Standard_Integer_16, "integer_16");
926 Set_Scope (Standard_Integer_16, Standard_Standard);
927 Build_Signed_Integer_Type (Standard_Integer_16, 16);
928
929 Standard_Integer_32 := New_Standard_Entity;
930 Decl := New_Node (N_Full_Type_Declaration, Stloc);
931 Set_Defining_Identifier (Decl, Standard_Integer_32);
932 Make_Name (Standard_Integer_32, "integer_32");
933 Set_Scope (Standard_Integer_32, Standard_Standard);
934 Build_Signed_Integer_Type (Standard_Integer_32, 32);
935
936 Standard_Integer_64 := New_Standard_Entity;
937 Decl := New_Node (N_Full_Type_Declaration, Stloc);
938 Set_Defining_Identifier (Decl, Standard_Integer_64);
939 Make_Name (Standard_Integer_64, "integer_64");
940 Set_Scope (Standard_Integer_64, Standard_Standard);
941 Build_Signed_Integer_Type (Standard_Integer_64, 64);
942
943 Standard_Unsigned := New_Standard_Entity;
944 Decl := New_Node (N_Full_Type_Declaration, Stloc);
945 Set_Defining_Identifier (Decl, Standard_Unsigned);
946 Make_Name (Standard_Unsigned, "unsigned");
947
948 Set_Ekind (Standard_Unsigned, E_Modular_Integer_Type);
949 Set_Scope (Standard_Unsigned, Standard_Standard);
950 Set_Etype (Standard_Unsigned, Standard_Unsigned);
951 Init_Size (Standard_Unsigned, Standard_Integer_Size);
952 Set_Prim_Alignment (Standard_Unsigned);
953 Set_Modulus (Standard_Unsigned,
954 Uint_2 ** Standard_Integer_Size);
955
956 Set_Is_Unsigned_Type (Standard_Unsigned);
957
958 R_Node := New_Node (N_Range, Stloc);
959 Set_Low_Bound (R_Node,
960 Make_Integer_Literal (Stloc, 0));
961 Set_High_Bound (R_Node,
962 Make_Integer_Literal (Stloc, Modulus (Standard_Unsigned)));
963 Set_Scalar_Range (Standard_Unsigned, R_Node);
964
965 -- Note: universal integer and universal real are constructed as fully
966 -- formed signed numeric types, with parameters corresponding to the
967 -- longest runtime types (Long_Long_Integer and Long_Long_Float). This
968 -- allows Gigi to properly process references to universal types that
969 -- are not folded at compile time.
970
971 Universal_Integer := New_Standard_Entity;
972 Decl := New_Node (N_Full_Type_Declaration, Stloc);
973 Set_Defining_Identifier (Decl, Universal_Integer);
974 Make_Name (Universal_Integer, "universal_integer");
975 Set_Scope (Universal_Integer, Standard_Standard);
976 Build_Signed_Integer_Type
977 (Universal_Integer, Standard_Long_Long_Integer_Size);
978
979 Universal_Real := New_Standard_Entity;
980 Decl := New_Node (N_Full_Type_Declaration, Stloc);
981 Set_Defining_Identifier (Decl, Universal_Real);
982 Make_Name (Universal_Real, "universal_real");
983 Set_Scope (Universal_Real, Standard_Standard);
984 Build_Float_Type
985 (Universal_Real,
986 Standard_Long_Long_Float_Size,
987 Standard_Long_Long_Float_Digits);
988
989 -- Note: universal fixed, unlike universal integer and universal real,
990 -- is never used at runtime, so it does not need to have bounds set.
991
992 Universal_Fixed := New_Standard_Entity;
993 Decl := New_Node (N_Full_Type_Declaration, Stloc);
994 Set_Defining_Identifier (Decl, Universal_Fixed);
995 Make_Name (Universal_Fixed, "universal_fixed");
996 Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type);
997 Set_Etype (Universal_Fixed, Universal_Fixed);
998 Set_Scope (Universal_Fixed, Standard_Standard);
999 Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size);
1000 Set_Prim_Alignment (Universal_Fixed);
1001 Set_Size_Known_At_Compile_Time
1002 (Universal_Fixed);
1003
1004 -- Create type declaration for Duration, using a 64-bit size. The
1005 -- delta value depends on the mode we are running in:
1006
1007 -- Normal mode or No_Run_Time mode when word size is 64 bits:
1008 -- 10**(-9) seconds, size is 64 bits
1009
1010 -- No_Run_Time mode when word size is 32 bits:
1011 -- 10**(-4) seconds, oize is 32 bits
1012
1013 Build_Duration : declare
1014 Dlo : Uint;
1015 Dhi : Uint;
1016 Delta_Val : Ureal;
1017 Use_32_Bits : constant Boolean :=
1018 No_Run_Time and then System_Word_Size = 32;
1019
1020 begin
1021 if Use_32_Bits then
1022 Dlo := Intval (Type_Low_Bound (Standard_Integer_32));
1023 Dhi := Intval (Type_High_Bound (Standard_Integer_32));
1024 Delta_Val := UR_From_Components (Uint_1, Uint_4, 10);
1025
1026 else
1027 Dlo := Intval (Type_Low_Bound (Standard_Integer_64));
1028 Dhi := Intval (Type_High_Bound (Standard_Integer_64));
1029 Delta_Val := UR_From_Components (Uint_1, Uint_9, 10);
1030 end if;
1031
1032 Decl :=
1033 Make_Full_Type_Declaration (Stloc,
1034 Defining_Identifier => Standard_Duration,
1035 Type_Definition =>
1036 Make_Ordinary_Fixed_Point_Definition (Stloc,
1037 Delta_Expression => Make_Real_Literal (Stloc, Delta_Val),
1038 Real_Range_Specification =>
1039 Make_Real_Range_Specification (Stloc,
1040 Low_Bound => Make_Real_Literal (Stloc,
1041 Realval => Dlo * Delta_Val),
1042 High_Bound => Make_Real_Literal (Stloc,
1043 Realval => Dhi * Delta_Val))));
1044
1045 Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
1046 Set_Etype (Standard_Duration, Standard_Duration);
1047
1048 if Use_32_Bits then
1049 Init_Size (Standard_Duration, 32);
1050 else
1051 Init_Size (Standard_Duration, 64);
1052 end if;
1053
1054 Set_Prim_Alignment (Standard_Duration);
1055 Set_Delta_Value (Standard_Duration, Delta_Val);
1056 Set_Small_Value (Standard_Duration, Delta_Val);
1057 Set_Scalar_Range (Standard_Duration,
1058 Real_Range_Specification
1059 (Type_Definition (Decl)));
1060
1061 -- Normally it does not matter that nodes in package Standard are
1062 -- not marked as analyzed. The Scalar_Range of the fixed-point
1063 -- type Standard_Duration is an exception, because of the special
1064 -- test made in Freeze.Freeze_Fixed_Point_Type.
1065
1066 Set_Analyzed (Scalar_Range (Standard_Duration));
1067
1068 Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration);
1069 Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration);
1070
1071 Set_Is_Static_Expression (Type_High_Bound (Standard_Duration));
1072 Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration));
1073
1074 Set_Corresponding_Integer_Value
1075 (Type_High_Bound (Standard_Duration), Dhi);
1076
1077 Set_Corresponding_Integer_Value
1078 (Type_Low_Bound (Standard_Duration), Dlo);
1079
1080 Set_Size_Known_At_Compile_Time (Standard_Duration);
1081 end Build_Duration;
1082
1083 -- Build standard exception type. Note that the type name here is
1084 -- actually used in the generated code, so it must be set correctly
1085
1086 Standard_Exception_Type := New_Standard_Entity;
1087 Set_Ekind (Standard_Exception_Type, E_Record_Type);
1088 Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
1089 Set_Scope (Standard_Exception_Type, Standard_Standard);
1090 Set_Girder_Constraint
1091 (Standard_Exception_Type, No_Elist);
1092 Init_Size_Align (Standard_Exception_Type);
1093 Set_Size_Known_At_Compile_Time
1094 (Standard_Exception_Type, True);
1095 Make_Name (Standard_Exception_Type, "exception");
1096
1097 Make_Component (Standard_Exception_Type, Standard_Boolean,
1098 "Not_Handled_By_Others");
1099 Make_Component (Standard_Exception_Type, Standard_Character, "Lang");
1100 Make_Component (Standard_Exception_Type, Standard_Natural,
1101 "Name_Length");
1102 Make_Component (Standard_Exception_Type, Standard_A_Char,
1103 "Full_Name");
1104 Make_Component (Standard_Exception_Type, Standard_A_Char,
1105 "HTable_Ptr");
1106 Make_Component (Standard_Exception_Type, Standard_Integer,
1107 "Import_Code");
1108
1109 -- Build tree for record declaration, for use by the back-end.
1110
1111 declare
1112 Comp_List : List_Id;
1113 Comp : Entity_Id;
1114
1115 begin
1116 Comp := First_Entity (Standard_Exception_Type);
1117 Comp_List := New_List;
1118
1119 while Present (Comp) loop
1120 Append (
1121 Make_Component_Declaration (Stloc,
1122 Defining_Identifier => Comp,
1123 Subtype_Indication => New_Occurrence_Of (Etype (Comp), Stloc)),
1124 Comp_List);
1125
1126 Next_Entity (Comp);
1127 end loop;
1128
1129 Decl := Make_Full_Type_Declaration (Stloc,
1130 Defining_Identifier => Standard_Exception_Type,
1131 Type_Definition =>
1132 Make_Record_Definition (Stloc,
1133 End_Label => Empty,
1134 Component_List =>
1135 Make_Component_List (Stloc,
1136 Component_Items => Comp_List)));
1137 end;
1138
1139 Append (Decl, Decl_S);
1140
1141 -- Create declarations of standard exceptions
1142
1143 Build_Exception (S_Constraint_Error);
1144 Build_Exception (S_Program_Error);
1145 Build_Exception (S_Storage_Error);
1146 Build_Exception (S_Tasking_Error);
1147
1148 -- Numeric_Error is a normal exception in Ada 83, but in Ada 95
1149 -- it is a renaming of Constraint_Error
1150
1151 if Ada_83 then
1152 Build_Exception (S_Numeric_Error);
1153
1154 else
1155 Decl := New_Node (N_Exception_Renaming_Declaration, Stloc);
1156 E_Id := Standard_Entity (S_Numeric_Error);
1157
1158 Set_Ekind (E_Id, E_Exception);
1159 Set_Exception_Code (E_Id, Uint_0);
1160 Set_Etype (E_Id, Standard_Exception_Type);
1161 Set_Is_Public (E_Id);
1162 Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error));
1163
1164 Set_Defining_Identifier (Decl, E_Id);
1165 Append (Decl, Decl_S);
1166
1167 Ident_Node := New_Node (N_Identifier, Stloc);
1168 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
1169 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
1170 Set_Name (Decl, Ident_Node);
1171 end if;
1172
1173 -- Abort_Signal is an entity that does not get made visible
1174
1175 Abort_Signal := New_Standard_Entity;
1176 Set_Chars (Abort_Signal, Name_uAbort_Signal);
1177 Set_Ekind (Abort_Signal, E_Exception);
1178 Set_Exception_Code (Abort_Signal, Uint_0);
1179 Set_Etype (Abort_Signal, Standard_Exception_Type);
1180 Set_Scope (Abort_Signal, Standard_Standard);
1181 Set_Is_Public (Abort_Signal, True);
1182 Decl :=
1183 Make_Exception_Declaration (Stloc,
1184 Defining_Identifier => Abort_Signal);
1185
1186 -- Create defining identifiers for shift operator entities. Note
1187 -- that these entities are used only for marking shift operators
1188 -- generated internally, and hence need no structure, just a name
1189 -- and a unique identity.
1190
1191 Standard_Op_Rotate_Left := New_Standard_Entity;
1192 Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left);
1193 Set_Ekind (Standard_Op_Rotate_Left, E_Operator);
1194
1195 Standard_Op_Rotate_Right := New_Standard_Entity;
1196 Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right);
1197 Set_Ekind (Standard_Op_Rotate_Right, E_Operator);
1198
1199 Standard_Op_Shift_Left := New_Standard_Entity;
1200 Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left);
1201 Set_Ekind (Standard_Op_Shift_Left, E_Operator);
1202
1203 Standard_Op_Shift_Right := New_Standard_Entity;
1204 Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right);
1205 Set_Ekind (Standard_Op_Shift_Right, E_Operator);
1206
1207 Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity;
1208 Set_Chars (Standard_Op_Shift_Right_Arithmetic,
1209 Name_Shift_Right_Arithmetic);
1210 Set_Ekind (Standard_Op_Shift_Right_Arithmetic,
1211 E_Operator);
1212
1213 -- Create standard operator declarations
1214
1215 Create_Operators;
1216
1217 -- Initialize visibility table with entities in Standard
1218
1219 for E in Standard_Entity_Type loop
1220 if Ekind (Standard_Entity (E)) /= E_Operator then
1221 Set_Name_Entity_Id
1222 (Chars (Standard_Entity (E)), Standard_Entity (E));
1223 Set_Homonym (Standard_Entity (E), Empty);
1224 end if;
1225
1226 if E not in S_ASCII_Names then
1227 Set_Scope (Standard_Entity (E), Standard_Standard);
1228 Set_Is_Immediately_Visible (Standard_Entity (E));
1229 end if;
1230 end loop;
1231
1232 -- The predefined package Standard itself does not have a scope;
1233 -- it is the only entity in the system not to have one, and this
1234 -- is what identifies the package to Gigi.
1235
1236 Set_Scope (Standard_Standard, Empty);
1237
1238 -- Set global variables indicating last Id values and version
1239
1240 Last_Standard_Node_Id := Last_Node_Id;
1241 Last_Standard_List_Id := Last_List_Id;
1242
1243 -- The Error node has an Etype of Any_Type to help error recovery
1244
1245 Set_Etype (Error, Any_Type);
1246 end Create_Standard;
1247
1248 ------------------------------------
1249 -- Create_Unconstrained_Base_Type --
1250 ------------------------------------
1251
1252 procedure Create_Unconstrained_Base_Type
1253 (E : Entity_Id;
1254 K : Entity_Kind)
1255 is
1256 New_Ent : constant Entity_Id := New_Copy (E);
1257
1258 begin
1259 Set_Ekind (E, K);
1260 Set_Is_Constrained (E, True);
1261 Set_Etype (E, New_Ent);
1262
1263 Append_Entity (New_Ent, Standard_Standard);
1264 Set_Is_Constrained (New_Ent, False);
1265 Set_Etype (New_Ent, New_Ent);
1266 Set_Is_Known_Valid (New_Ent, True);
1267
1268 if K = E_Signed_Integer_Subtype then
1269 Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent);
1270 Set_Etype (High_Bound (Scalar_Range (E)), New_Ent);
1271 end if;
1272
1273 end Create_Unconstrained_Base_Type;
1274
1275 --------------------
1276 -- Identifier_For --
1277 --------------------
1278
1279 function Identifier_For (S : Standard_Entity_Type) return Node_Id is
1280 Ident_Node : Node_Id;
1281
1282 begin
1283 Ident_Node := New_Node (N_Identifier, Stloc);
1284 Set_Chars (Ident_Node, Chars (Standard_Entity (S)));
1285 return Ident_Node;
1286 end Identifier_For;
1287
1288 --------------------
1289 -- Make_Component --
1290 --------------------
1291
1292 procedure Make_Component
1293 (Rec : Entity_Id;
1294 Typ : Entity_Id;
1295 Nam : String)
1296 is
1297 Id : Entity_Id := New_Standard_Entity;
1298
1299 begin
1300 Set_Ekind (Id, E_Component);
1301 Set_Etype (Id, Typ);
1302 Set_Scope (Id, Rec);
1303 Init_Component_Location (Id);
1304
1305 Set_Original_Record_Component (Id, Id);
1306 Make_Name (Id, Nam);
1307 Append_Entity (Id, Rec);
1308 end Make_Component;
1309
1310 -----------------
1311 -- Make_Formal --
1312 -----------------
1313
1314 function Make_Formal
1315 (Typ : Entity_Id;
1316 Formal_Name : String)
1317 return Entity_Id
1318 is
1319 Formal : Entity_Id;
1320
1321 begin
1322 Formal := New_Standard_Entity;
1323
1324 Set_Ekind (Formal, E_In_Parameter);
1325 Set_Mechanism (Formal, Default_Mechanism);
1326 Set_Scope (Formal, Standard_Standard);
1327 Set_Etype (Formal, Typ);
1328 Make_Name (Formal, Formal_Name);
1329
1330 return Formal;
1331 end Make_Formal;
1332
1333 ------------------
1334 -- Make_Integer --
1335 ------------------
1336
1337 function Make_Integer (V : Uint) return Node_Id is
1338 N : constant Node_Id := Make_Integer_Literal (Stloc, V);
1339
1340 begin
1341 Set_Is_Static_Expression (N);
1342 return N;
1343 end Make_Integer;
1344
1345 ---------------
1346 -- Make_Name --
1347 ---------------
1348
1349 procedure Make_Name (Id : Entity_Id; Nam : String) is
1350 begin
1351 for J in 1 .. Nam'Length loop
1352 Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1)));
1353 end loop;
1354
1355 Name_Len := Nam'Length;
1356 Set_Chars (Id, Name_Find);
1357 end Make_Name;
1358
1359 ------------------
1360 -- New_Operator --
1361 ------------------
1362
1363 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is
1364 Ident_Node : Entity_Id;
1365
1366 begin
1367 Ident_Node := Make_Defining_Identifier (Stloc, Op);
1368
1369 Set_Is_Pure (Ident_Node, True);
1370 Set_Ekind (Ident_Node, E_Operator);
1371 Set_Etype (Ident_Node, Typ);
1372 Set_Scope (Ident_Node, Standard_Standard);
1373 Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op));
1374 Set_Convention (Ident_Node, Convention_Intrinsic);
1375
1376 Set_Is_Immediately_Visible (Ident_Node, True);
1377 Set_Is_Intrinsic_Subprogram (Ident_Node, True);
1378
1379 Set_Name_Entity_Id (Op, Ident_Node);
1380 Append_Entity (Ident_Node, Standard_Standard);
1381 return Ident_Node;
1382 end New_Operator;
1383
1384 -------------------------
1385 -- New_Standard_Entity --
1386 -------------------------
1387
1388 function New_Standard_Entity
1389 (New_Node_Kind : Node_Kind := N_Defining_Identifier)
1390 return Entity_Id
1391 is
1392 E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc);
1393
1394 begin
1395 -- All standard entities are Pure and Public
1396
1397 Set_Is_Pure (E);
1398 Set_Is_Public (E);
1399
1400 -- All standard entity names are analyzed manually, and are thus
1401 -- frozen as soon as they are created.
1402
1403 Set_Is_Frozen (E);
1404
1405 -- Set debug information required for all standard types
1406
1407 Set_Needs_Debug_Info (E);
1408
1409 -- All standard entities are built with fully qualified names, so
1410 -- set the flag to prevent an abortive attempt at requalification!
1411
1412 Set_Has_Qualified_Name (E);
1413
1414 -- Return newly created entity to be completed by caller
1415
1416 return E;
1417 end New_Standard_Entity;
1418
1419 ----------------------
1420 -- Set_Float_Bounds --
1421 ----------------------
1422
1423 procedure Set_Float_Bounds (Id : Entity_Id) is
1424 L : Node_Id;
1425 -- Low bound of literal value
1426
1427 H : Node_Id;
1428 -- High bound of literal value
1429
1430 R : Node_Id;
1431 -- Range specification
1432
1433 Digs : constant Nat := UI_To_Int (Digits_Value (Id));
1434 -- Digits value, used to select bounds
1435
1436 begin
1437 -- Note: for the call from Cstand to initially create the types in
1438 -- Standard, Vax_Float will always be False. Circuitry in Sem_Vfpt
1439 -- will adjust these types appropriately in the Vax_Float case if
1440 -- a pragma Float_Representation (VAX_Float) is used.
1441
1442 if Vax_Float (Id) then
1443 if Digs = VAXFF_Digits then
1444 L := Real_Convert
1445 (VAXFF_First'Universal_Literal_String);
1446 H := Real_Convert
1447 (VAXFF_Last'Universal_Literal_String);
1448
1449 elsif Digs = VAXDF_Digits then
1450 L := Real_Convert
1451 (VAXDF_First'Universal_Literal_String);
1452 H := Real_Convert
1453 (VAXDF_Last'Universal_Literal_String);
1454
1455 else
1456 pragma Assert (Digs = VAXGF_Digits);
1457
1458 L := Real_Convert
1459 (VAXGF_First'Universal_Literal_String);
1460 H := Real_Convert
1461 (VAXGF_Last'Universal_Literal_String);
1462 end if;
1463
1464 elsif Is_AAMP_Float (Id) then
1465 if Digs = AAMPS_Digits then
1466 L := Real_Convert
1467 (AAMPS_First'Universal_Literal_String);
1468 H := Real_Convert
1469 (AAMPS_Last'Universal_Literal_String);
1470
1471 else
1472 pragma Assert (Digs = AAMPL_Digits);
1473 L := Real_Convert
1474 (AAMPL_First'Universal_Literal_String);
1475 H := Real_Convert
1476 (AAMPL_Last'Universal_Literal_String);
1477 end if;
1478
1479 elsif Digs = IEEES_Digits then
1480 L := Real_Convert
1481 (IEEES_First'Universal_Literal_String);
1482 H := Real_Convert
1483 (IEEES_Last'Universal_Literal_String);
1484
1485 elsif Digs = IEEEL_Digits then
1486 L := Real_Convert
1487 (IEEEL_First'Universal_Literal_String);
1488 H := Real_Convert
1489 (IEEEL_Last'Universal_Literal_String);
1490
1491 else
1492 pragma Assert (Digs = IEEEX_Digits);
1493
1494 L := Real_Convert
1495 (IEEEX_First'Universal_Literal_String);
1496 H := Real_Convert
1497 (IEEEX_Last'Universal_Literal_String);
1498 end if;
1499
1500 Set_Etype (L, Id);
1501 Set_Is_Static_Expression (L);
1502
1503 Set_Etype (H, Id);
1504 Set_Is_Static_Expression (H);
1505
1506 R := New_Node (N_Range, Stloc);
1507 Set_Low_Bound (R, L);
1508 Set_High_Bound (R, H);
1509 Set_Includes_Infinities (R, True);
1510 Set_Scalar_Range (Id, R);
1511 Set_Etype (R, Id);
1512 Set_Parent (R, Id);
1513 end Set_Float_Bounds;
1514
1515 ------------------------
1516 -- Set_Integer_Bounds --
1517 ------------------------
1518
1519 procedure Set_Integer_Bounds
1520 (Id : Entity_Id;
1521 Typ : Entity_Id;
1522 Lb : Uint;
1523 Hb : Uint)
1524 is
1525 L : Node_Id; -- Low bound of literal value
1526 H : Node_Id; -- High bound of literal value
1527 R : Node_Id; -- Range specification
1528
1529 begin
1530 L := Make_Integer (Lb);
1531 H := Make_Integer (Hb);
1532
1533 Set_Etype (L, Typ);
1534 Set_Etype (H, Typ);
1535
1536 R := New_Node (N_Range, Stloc);
1537 Set_Low_Bound (R, L);
1538 Set_High_Bound (R, H);
1539 Set_Scalar_Range (Id, R);
1540 Set_Etype (R, Typ);
1541 Set_Parent (R, Id);
1542 Set_Is_Unsigned_Type (Id, Lb >= 0);
1543 end Set_Integer_Bounds;
1544
1545 end CStand;
Mirror of the offical gcc git repository hosted at gcc.gnu.org