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