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