?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix date
[official-gcc.git] / gcc / ada / cstand.adb
blobfe480beb426b81d8cba7f104e8e40a7f7011e1e6
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-2017, 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 Elists; use Elists;
31 with Layout; use Layout;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
34 with Nmake; use Nmake;
35 with Opt; use Opt;
36 with Output; use Output;
37 with Set_Targ; use Set_Targ;
38 with Targparm; use Targparm;
39 with Tbuild; use Tbuild;
40 with Ttypes; use Ttypes;
41 with Sem_Mech; use Sem_Mech;
42 with Sem_Util; use Sem_Util;
43 with Sinfo; use Sinfo;
44 with Snames; use Snames;
45 with Stand; use Stand;
46 with Uintp; use Uintp;
47 with Urealp; use Urealp;
48
49 package body CStand is
50
51 Stloc : constant Source_Ptr := Standard_Location;
52 Staloc : constant Source_Ptr := Standard_ASCII_Location;
53 -- Standard abbreviations used throughout this package
54
55 Back_End_Float_Types : Elist_Id := No_Elist;
56 -- List used for any floating point supported by the back end. This needs
57 -- to be at the library level, because the call back procedures retrieving
58 -- this information are at that level.
59
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
63
64 procedure Build_Float_Type
65 (E : Entity_Id;
66 Siz : Int;
67 Rep : Float_Rep_Kind;
68 Digs : Int);
69 -- Procedure to build standard predefined float base type. The first
70 -- parameter is the entity for the type, and the second parameter is the
71 -- size in bits. The third parameter indicates the kind of representation
72 -- to be used. The fourth parameter is the digits value. Each type
73 -- is added to the list of predefined floating point types.
74
75 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Nat);
76 -- Procedure to build standard predefined signed integer subtype. The
77 -- first parameter is the entity for the subtype. The second parameter
78 -- is the size in bits. The corresponding base type is not built by
79 -- this routine but instead must be built by the caller where needed.
80
81 procedure Build_Unsigned_Integer_Type
82 (Uns : Entity_Id;
83 Siz : Nat;
84 Nam : String);
85 -- Procedure to build standard predefined unsigned integer subtype. These
86 -- subtypes are not user visible, but they are used internally. The first
87 -- parameter is the entity for the subtype. The second parameter is the
88 -- size in bits. The third parameter is an identifying name.
89
90 procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id);
91 -- Build a floating point type, copying representation details from From.
92 -- This is used to create predefined floating point types based on
93 -- available types in the back end.
94
95 procedure Create_Operators;
96 -- Make entries for each of the predefined operators in Standard
97
98 procedure Create_Unconstrained_Base_Type
99 (E : Entity_Id;
100 K : Entity_Kind);
101 -- The predefined signed integer types are constrained subtypes which
102 -- must have a corresponding unconstrained base type. This type is almost
103 -- useless. The only place it has semantics is Subtypes_Statically_Match.
104 -- Consequently, we arrange for it to be identical apart from the setting
105 -- of the constrained bit. This routine takes an entity E for the Type,
106 -- copies it to estabish the base type, then resets the Ekind of the
107 -- original entity to K (the Ekind for the subtype). The Etype field of
108 -- E is set by the call (to point to the created base type entity), and
109 -- also the Is_Constrained flag of E is set.
110 --
111 -- To understand the exact requirement for this, see RM 3.5.4(11) which
112 -- makes it clear that Integer, for example, is constrained, with the
113 -- constraint bounds matching the bounds of the (unconstrained) base
114 -- type. The point is that Integer and Integer'Base have identical
115 -- bounds, but do not statically match, since a subtype with constraints
116 -- never matches a subtype with no constraints.
117
118 function Find_Back_End_Float_Type (Name : String) return Entity_Id;
119 -- Return the first float type in Back_End_Float_Types with the given name.
120 -- Names of entities in back end types, are either type names of C
121 -- predefined types (all lower case), or mode names (upper case).
122 -- These are not generally valid identifier names.
123
124 function Identifier_For (S : Standard_Entity_Type) return Node_Id;
125 -- Returns an identifier node with the same name as the defining
126 -- identifier corresponding to the given Standard_Entity_Type value
127
128 procedure Make_Component
129 (Rec : Entity_Id;
130 Typ : Entity_Id;
131 Nam : String);
132 -- Build a record component with the given type and name, and append to
133 -- the list of components of Rec.
134
135 function Make_Formal
136 (Typ : Entity_Id;
137 Formal_Name : String) return Entity_Id;
138 -- Construct entity for subprogram formal with given name and type
139
140 function Make_Integer (V : Uint) return Node_Id;
141 -- Builds integer literal with given value
142
143 procedure Make_Name (Id : Entity_Id; Nam : String);
144 -- Make an entry in the names table for Nam, and set as Chars field of Id
145
146 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id;
147 -- Build entity for standard operator with given name and type
148
149 function New_Standard_Entity
150 (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
151 -- Builds a new entity for Standard
152
153 function New_Standard_Entity (S : String) return Entity_Id;
154 -- Builds a new entity for Standard with Nkind = N_Defining_Identifier,
155 -- and Chars of this defining identifier set to the given string S.
156
157 procedure Print_Standard;
158 -- Print representation of package Standard if switch set
159
160 procedure Register_Float_Type
161 (Name : String;
162 Digs : Positive;
163 Float_Rep : Float_Rep_Kind;
164 Precision : Positive;
165 Size : Positive;
166 Alignment : Natural);
167 -- Registers a single back end floating-point type (from FPT_Mode_Table in
168 -- Set_Targ). This will create a predefined floating-point base type for
169 -- one of the floating point types reported by the back end, and add it
170 -- to the list of predefined float types. Name is the name of the type
171 -- as a normal format (non-null-terminated) string. Digs is the number of
172 -- digits, which is always non-zero, since non-floating-point types were
173 -- filtered out earlier. Float_Rep indicates the kind of floating-point
174 -- type, and Precision, Size and Alignment are the precision, size and
175 -- alignment in bits.
176
177 procedure Set_Integer_Bounds
178 (Id : Entity_Id;
179 Typ : Entity_Id;
180 Lb : Uint;
181 Hb : Uint);
182 -- Procedure to set bounds for integer type or subtype. Id is the entity
183 -- whose bounds and type are to be set. The Typ parameter is the Etype
184 -- value for the entity (which will be the same as Id for all predefined
185 -- integer base types. The third and fourth parameters are the bounds.
186
187 ----------------------
188 -- Build_Float_Type --
189 ----------------------
190
191 procedure Build_Float_Type
192 (E : Entity_Id;
193 Siz : Int;
194 Rep : Float_Rep_Kind;
195 Digs : Int)
196 is
197 begin
198 Set_Type_Definition (Parent (E),
199 Make_Floating_Point_Definition (Stloc,
200 Digits_Expression => Make_Integer (UI_From_Int (Digs))));
201
202 Set_Ekind (E, E_Floating_Point_Type);
203 Set_Etype (E, E);
204 Set_Float_Rep (E, Rep);
205 Init_Size (E, Siz);
206 Set_Elem_Alignment (E);
207 Init_Digits_Value (E, Digs);
208 Set_Float_Bounds (E);
209 Set_Is_Frozen (E);
210 Set_Is_Public (E);
211 Set_Size_Known_At_Compile_Time (E);
212 end Build_Float_Type;
213
214 ------------------------------
215 -- Find_Back_End_Float_Type --
216 ------------------------------
217
218 function Find_Back_End_Float_Type (Name : String) return Entity_Id is
219 N : Elmt_Id;
220
221 begin
222 N := First_Elmt (Back_End_Float_Types);
223 while Present (N) and then Get_Name_String (Chars (Node (N))) /= Name
224 loop
225 Next_Elmt (N);
226 end loop;
227
228 return Node (N);
229 end Find_Back_End_Float_Type;
230
231 -------------------------------
232 -- Build_Signed_Integer_Type --
233 -------------------------------
234
235 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Nat) is
236 U2Siz1 : constant Uint := 2 ** (Siz - 1);
237 Lbound : constant Uint := -U2Siz1;
238 Ubound : constant Uint := U2Siz1 - 1;
239
240 begin
241 Set_Type_Definition (Parent (E),
242 Make_Signed_Integer_Type_Definition (Stloc,
243 Low_Bound => Make_Integer (Lbound),
244 High_Bound => Make_Integer (Ubound)));
245
246 Set_Ekind (E, E_Signed_Integer_Type);
247 Set_Etype (E, E);
248 Init_Size (E, Siz);
249 Set_Elem_Alignment (E);
250 Set_Integer_Bounds (E, E, Lbound, Ubound);
251 Set_Is_Frozen (E);
252 Set_Is_Public (E);
253 Set_Is_Known_Valid (E);
254 Set_Size_Known_At_Compile_Time (E);
255 end Build_Signed_Integer_Type;
256
257 ---------------------------------
258 -- Build_Unsigned_Integer_Type --
259 ---------------------------------
260
261 procedure Build_Unsigned_Integer_Type
262 (Uns : Entity_Id;
263 Siz : Nat;
264 Nam : String)
265 is
266 Decl : Node_Id;
267 R_Node : Node_Id;
268
269 begin
270 Decl := New_Node (N_Full_Type_Declaration, Stloc);
271 Set_Defining_Identifier (Decl, Uns);
272 Make_Name (Uns, Nam);
273
274 Set_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 R_Node := New_Node (N_Range, Stloc);
285 Set_Low_Bound (R_Node, Make_Integer (Uint_0));
286 Set_High_Bound (R_Node, Make_Integer (Modulus (Uns) - 1));
287 Set_Etype (Low_Bound (R_Node), Uns);
288 Set_Etype (High_Bound (R_Node), Uns);
289 Set_Scalar_Range (Uns, R_Node);
290 end Build_Unsigned_Integer_Type;
291
292 ---------------------
293 -- Copy_Float_Type --
294 ---------------------
295
296 procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id) is
297 begin
298 Build_Float_Type (To, UI_To_Int (Esize (From)), Float_Rep (From),
299 UI_To_Int (Digits_Value (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 Set_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 : Node_Id;
548 Dummy : List_Id;
549
550 begin
551 Index :=
552 Make_Range (Sloc (E),
553 Low_Bound => Make_Integer (Uint_0),
554 High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
555 Set_Etype (Index, Standard_Integer);
556 Set_First_Index (E, Index);
557
558 -- Make sure Index is a list as required, so Next_Index is Empty
559
560 Dummy := New_List (Index);
561 end Make_Dummy_Index;
562
563 ----------------------
564 -- Pack_String_Type --
565 ----------------------
566
567 procedure Pack_String_Type (String_Type : Entity_Id) is
568 Prag : constant Node_Id :=
569 Make_Pragma (Stloc,
570 Chars => Name_Pack,
571 Pragma_Argument_Associations =>
572 New_List (
573 Make_Pragma_Argument_Association (Stloc,
574 Expression => New_Occurrence_Of (String_Type, Stloc))));
575 begin
576 Append (Prag, Decl_S);
577 Record_Rep_Item (String_Type, Prag);
578 Set_Has_Pragma_Pack (String_Type, True);
579 end Pack_String_Type;
580
581 -- Start of processing for Create_Standard
582
583 begin
584 -- First step is to create defining identifiers for each entity
585
586 for S in Standard_Entity_Type loop
587 declare
588 S_Name : constant String := Standard_Entity_Type'Image (S);
589 -- Name of entity (note we skip S_ at the start)
590
591 Ident_Node : Node_Id;
592 -- Defining identifier node
593
594 begin
595 Ident_Node := New_Standard_Entity;
596 Make_Name (Ident_Node, 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 Set_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 Set_Ekind (Standard_Boolean, E_Enumeration_Type);
654 Set_First_Literal (Standard_Boolean, Standard_False);
655 Set_Etype (Standard_Boolean, Standard_Boolean);
656 Init_Esize (Standard_Boolean, Standard_Character_Size);
657 Init_RM_Size (Standard_Boolean, 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 Set_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 Set_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
712 Build_Signed_Integer_Type
713 (Standard_Short_Integer, Standard_Short_Integer_Size);
714 Set_Is_Implementation_Defined (Standard_Short_Integer);
715
716 Build_Signed_Integer_Type
717 (Standard_Integer, Standard_Integer_Size);
718
719 Build_Signed_Integer_Type
720 (Standard_Long_Integer, Standard_Long_Integer_Size);
721
722 Build_Signed_Integer_Type
723 (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size);
724 Set_Is_Implementation_Defined (Standard_Long_Long_Integer);
725
726 Create_Unconstrained_Base_Type
727 (Standard_Short_Short_Integer, E_Signed_Integer_Subtype);
728 Set_Is_Implementation_Defined (Standard_Short_Short_Integer);
729
730 Create_Unconstrained_Base_Type
731 (Standard_Short_Integer, E_Signed_Integer_Subtype);
732
733 Create_Unconstrained_Base_Type
734 (Standard_Integer, E_Signed_Integer_Subtype);
735
736 Create_Unconstrained_Base_Type
737 (Standard_Long_Integer, E_Signed_Integer_Subtype);
738
739 Create_Unconstrained_Base_Type
740 (Standard_Long_Long_Integer, E_Signed_Integer_Subtype);
741 Set_Is_Implementation_Defined (Standard_Short_Short_Integer);
742
743 Create_Float_Types;
744
745 -- Create type definition node for type Character. Note that we do not
746 -- set the Literals field, since type Character is handled with special
747 -- routine that do not need a literal list.
748
749 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
750 Set_Type_Definition (Parent (Standard_Character), Tdef_Node);
751
752 Set_Ekind (Standard_Character, E_Enumeration_Type);
753 Set_Etype (Standard_Character, Standard_Character);
754 Init_Esize (Standard_Character, Standard_Character_Size);
755 Init_RM_Size (Standard_Character, 8);
756 Set_Elem_Alignment (Standard_Character);
757
758 Set_Has_Pragma_Ordered (Standard_Character);
759 Set_Is_Unsigned_Type (Standard_Character);
760 Set_Is_Character_Type (Standard_Character);
761 Set_Is_Known_Valid (Standard_Character);
762 Set_Size_Known_At_Compile_Time (Standard_Character);
763
764 -- Create the bounds for type Character
765
766 R_Node := New_Node (N_Range, Stloc);
767
768 -- Low bound for type Character (Standard.Nul)
769
770 B_Node := New_Node (N_Character_Literal, Stloc);
771 Set_Is_Static_Expression (B_Node);
772 Set_Chars (B_Node, No_Name);
773 Set_Char_Literal_Value (B_Node, Uint_0);
774 Set_Entity (B_Node, Empty);
775 Set_Etype (B_Node, Standard_Character);
776 Set_Low_Bound (R_Node, B_Node);
777
778 -- High bound for type Character
779
780 B_Node := New_Node (N_Character_Literal, Stloc);
781 Set_Is_Static_Expression (B_Node);
782 Set_Chars (B_Node, No_Name);
783 Set_Char_Literal_Value (B_Node, UI_From_Int (16#FF#));
784 Set_Entity (B_Node, Empty);
785 Set_Etype (B_Node, Standard_Character);
786 Set_High_Bound (R_Node, B_Node);
787
788 Set_Scalar_Range (Standard_Character, R_Node);
789 Set_Etype (R_Node, Standard_Character);
790 Set_Parent (R_Node, Standard_Character);
791
792 -- Create type definition for type Wide_Character. Note that we do not
793 -- set the Literals field, since type Wide_Character is handled with
794 -- special routines that do not need a literal list.
795
796 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
797 Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node);
798
799 Set_Ekind (Standard_Wide_Character, E_Enumeration_Type);
800 Set_Etype (Standard_Wide_Character, Standard_Wide_Character);
801 Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size);
802
803 Set_Elem_Alignment (Standard_Wide_Character);
804 Set_Has_Pragma_Ordered (Standard_Wide_Character);
805 Set_Is_Unsigned_Type (Standard_Wide_Character);
806 Set_Is_Character_Type (Standard_Wide_Character);
807 Set_Is_Known_Valid (Standard_Wide_Character);
808 Set_Size_Known_At_Compile_Time (Standard_Wide_Character);
809
810 -- Create the bounds for type Wide_Character
811
812 R_Node := New_Node (N_Range, Stloc);
813
814 -- Low bound for type Wide_Character
815
816 B_Node := New_Node (N_Character_Literal, Stloc);
817 Set_Is_Static_Expression (B_Node);
818 Set_Chars (B_Node, No_Name); -- ???
819 Set_Char_Literal_Value (B_Node, Uint_0);
820 Set_Entity (B_Node, Empty);
821 Set_Etype (B_Node, Standard_Wide_Character);
822 Set_Low_Bound (R_Node, B_Node);
823
824 -- High bound for type Wide_Character
825
826 B_Node := New_Node (N_Character_Literal, Stloc);
827 Set_Is_Static_Expression (B_Node);
828 Set_Chars (B_Node, No_Name); -- ???
829 Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#));
830 Set_Entity (B_Node, Empty);
831 Set_Etype (B_Node, Standard_Wide_Character);
832 Set_High_Bound (R_Node, B_Node);
833
834 Set_Scalar_Range (Standard_Wide_Character, R_Node);
835 Set_Etype (R_Node, Standard_Wide_Character);
836 Set_Parent (R_Node, Standard_Wide_Character);
837
838 -- Create type definition for type Wide_Wide_Character. Note that we
839 -- do not set the Literals field, since type Wide_Wide_Character is
840 -- handled with special routines that do not need a literal list.
841
842 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
843 Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node);
844
845 Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type);
846 Set_Etype (Standard_Wide_Wide_Character,
847 Standard_Wide_Wide_Character);
848 Init_Size (Standard_Wide_Wide_Character,
849 Standard_Wide_Wide_Character_Size);
850
851 Set_Elem_Alignment (Standard_Wide_Wide_Character);
852 Set_Has_Pragma_Ordered (Standard_Wide_Wide_Character);
853 Set_Is_Unsigned_Type (Standard_Wide_Wide_Character);
854 Set_Is_Character_Type (Standard_Wide_Wide_Character);
855 Set_Is_Known_Valid (Standard_Wide_Wide_Character);
856 Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character);
857 Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character);
858
859 -- Create the bounds for type Wide_Wide_Character
860
861 R_Node := New_Node (N_Range, Stloc);
862
863 -- Low bound for type Wide_Wide_Character
864
865 B_Node := New_Node (N_Character_Literal, Stloc);
866 Set_Is_Static_Expression (B_Node);
867 Set_Chars (B_Node, No_Name); -- ???
868 Set_Char_Literal_Value (B_Node, Uint_0);
869 Set_Entity (B_Node, Empty);
870 Set_Etype (B_Node, Standard_Wide_Wide_Character);
871 Set_Low_Bound (R_Node, B_Node);
872
873 -- High bound for type Wide_Wide_Character
874
875 B_Node := New_Node (N_Character_Literal, Stloc);
876 Set_Is_Static_Expression (B_Node);
877 Set_Chars (B_Node, No_Name); -- ???
878 Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#));
879 Set_Entity (B_Node, Empty);
880 Set_Etype (B_Node, Standard_Wide_Wide_Character);
881 Set_High_Bound (R_Node, B_Node);
882
883 Set_Scalar_Range (Standard_Wide_Wide_Character, R_Node);
884 Set_Etype (R_Node, Standard_Wide_Wide_Character);
885 Set_Parent (R_Node, Standard_Wide_Wide_Character);
886
887 -- Create type definition node for type String
888
889 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
890
891 declare
892 CompDef_Node : Node_Id;
893 begin
894 CompDef_Node := New_Node (N_Component_Definition, Stloc);
895 Set_Aliased_Present (CompDef_Node, False);
896 Set_Access_Definition (CompDef_Node, Empty);
897 Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character));
898 Set_Component_Definition (Tdef_Node, CompDef_Node);
899 end;
900
901 Set_Subtype_Marks (Tdef_Node, New_List);
902 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
903 Set_Type_Definition (Parent (Standard_String), Tdef_Node);
904
905 Set_Ekind (Standard_String, E_Array_Type);
906 Set_Etype (Standard_String, Standard_String);
907 Set_Component_Type (Standard_String, Standard_Character);
908 Set_Component_Size (Standard_String, Uint_8);
909 Init_Size_Align (Standard_String);
910 Set_Alignment (Standard_String, Uint_1);
911 Pack_String_Type (Standard_String);
912
913 -- On targets where a storage unit is larger than a byte (such as AAMP),
914 -- pragma Pack has a real effect on the representation of type String,
915 -- and the type must be marked as having a nonstandard representation.
916
917 if System_Storage_Unit > Uint_8 then
918 Set_Has_Non_Standard_Rep (Standard_String);
919 Set_Has_Pragma_Pack (Standard_String);
920 end if;
921
922 -- Set index type of String
923
924 E_Id :=
925 First (Subtype_Marks (Type_Definition (Parent (Standard_String))));
926 Set_First_Index (Standard_String, E_Id);
927 Set_Entity (E_Id, Standard_Positive);
928 Set_Etype (E_Id, Standard_Positive);
929
930 -- Create type definition node for type Wide_String
931
932 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
933
934 declare
935 CompDef_Node : Node_Id;
936 begin
937 CompDef_Node := New_Node (N_Component_Definition, Stloc);
938 Set_Aliased_Present (CompDef_Node, False);
939 Set_Access_Definition (CompDef_Node, Empty);
940 Set_Subtype_Indication (CompDef_Node,
941 Identifier_For (S_Wide_Character));
942 Set_Component_Definition (Tdef_Node, CompDef_Node);
943 end;
944
945 Set_Subtype_Marks (Tdef_Node, New_List);
946 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
947 Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
948
949 Set_Ekind (Standard_Wide_String, E_Array_Type);
950 Set_Etype (Standard_Wide_String, Standard_Wide_String);
951 Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
952 Set_Component_Size (Standard_Wide_String, Uint_16);
953 Init_Size_Align (Standard_Wide_String);
954 Pack_String_Type (Standard_Wide_String);
955
956 -- Set index type of Wide_String
957
958 E_Id :=
959 First
960 (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String))));
961 Set_First_Index (Standard_Wide_String, E_Id);
962 Set_Entity (E_Id, Standard_Positive);
963 Set_Etype (E_Id, Standard_Positive);
964
965 -- Create type definition node for type Wide_Wide_String
966
967 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc);
968
969 declare
970 CompDef_Node : Node_Id;
971 begin
972 CompDef_Node := New_Node (N_Component_Definition, Stloc);
973 Set_Aliased_Present (CompDef_Node, False);
974 Set_Access_Definition (CompDef_Node, Empty);
975 Set_Subtype_Indication (CompDef_Node,
976 Identifier_For (S_Wide_Wide_Character));
977 Set_Component_Definition (Tdef_Node, CompDef_Node);
978 end;
979
980 Set_Subtype_Marks (Tdef_Node, New_List);
981 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
982 Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node);
983
984 Set_Ekind (Standard_Wide_Wide_String, E_Array_Type);
985 Set_Etype (Standard_Wide_Wide_String,
986 Standard_Wide_Wide_String);
987 Set_Component_Type (Standard_Wide_Wide_String,
988 Standard_Wide_Wide_Character);
989 Set_Component_Size (Standard_Wide_Wide_String, Uint_32);
990 Init_Size_Align (Standard_Wide_Wide_String);
991 Set_Is_Ada_2005_Only (Standard_Wide_Wide_String);
992 Pack_String_Type (Standard_Wide_Wide_String);
993
994 -- Set index type of Wide_Wide_String
995
996 E_Id :=
997 First
998 (Subtype_Marks
999 (Type_Definition (Parent (Standard_Wide_Wide_String))));
1000 Set_First_Index (Standard_Wide_Wide_String, E_Id);
1001 Set_Entity (E_Id, Standard_Positive);
1002 Set_Etype (E_Id, Standard_Positive);
1003
1004 -- Setup entity for Natural
1005
1006 Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype);
1007 Set_Etype (Standard_Natural, Base_Type (Standard_Integer));
1008 Init_Esize (Standard_Natural, Standard_Integer_Size);
1009 Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1);
1010 Set_Elem_Alignment (Standard_Natural);
1011 Set_Size_Known_At_Compile_Time
1012 (Standard_Natural);
1013 Set_Integer_Bounds (Standard_Natural,
1014 Typ => Base_Type (Standard_Integer),
1015 Lb => Uint_0,
1016 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
1017 Set_Is_Constrained (Standard_Natural);
1018
1019 -- Setup entity for Positive
1020
1021 Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
1022 Set_Etype (Standard_Positive, Base_Type (Standard_Integer));
1023 Init_Esize (Standard_Positive, Standard_Integer_Size);
1024 Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1);
1025 Set_Elem_Alignment (Standard_Positive);
1026
1027 Set_Size_Known_At_Compile_Time (Standard_Positive);
1028
1029 Set_Integer_Bounds (Standard_Positive,
1030 Typ => Base_Type (Standard_Integer),
1031 Lb => Uint_1,
1032 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
1033 Set_Is_Constrained (Standard_Positive);
1034
1035 -- Create declaration for package ASCII
1036
1037 Decl := New_Node (N_Package_Declaration, Stloc);
1038 Append (Decl, Decl_S);
1039
1040 Pspec := New_Node (N_Package_Specification, Stloc);
1041 Set_Specification (Decl, Pspec);
1042
1043 Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII));
1044 Set_Ekind (Standard_Entity (S_ASCII), E_Package);
1045 Set_Visible_Declarations (Pspec, Decl_A);
1046
1047 -- Create control character definitions in package ASCII. Note that
1048 -- the character literal entries created here correspond to literal
1049 -- values that are impossible in the source, but can be represented
1050 -- internally with no difficulties.
1051
1052 Ccode := 16#00#;
1053
1054 for S in S_ASCII_Names loop
1055 Decl := New_Node (N_Object_Declaration, Staloc);
1056 Set_Constant_Present (Decl, True);
1057
1058 declare
1059 A_Char : constant Entity_Id := Standard_Entity (S);
1060 Expr_Decl : Node_Id;
1061
1062 begin
1063 Set_Sloc (A_Char, Staloc);
1064 Set_Ekind (A_Char, E_Constant);
1065 Set_Never_Set_In_Source (A_Char, True);
1066 Set_Is_True_Constant (A_Char, True);
1067 Set_Etype (A_Char, Standard_Character);
1068 Set_Scope (A_Char, Standard_Entity (S_ASCII));
1069 Set_Is_Immediately_Visible (A_Char, False);
1070 Set_Is_Public (A_Char, True);
1071 Set_Is_Known_Valid (A_Char, True);
1072
1073 Append_Entity (A_Char, Standard_Entity (S_ASCII));
1074 Set_Defining_Identifier (Decl, A_Char);
1075
1076 Set_Object_Definition (Decl, Identifier_For (S_Character));
1077 Expr_Decl := New_Node (N_Character_Literal, Staloc);
1078 Set_Expression (Decl, Expr_Decl);
1079
1080 Set_Is_Static_Expression (Expr_Decl);
1081 Set_Chars (Expr_Decl, No_Name);
1082 Set_Etype (Expr_Decl, Standard_Character);
1083 Set_Char_Literal_Value (Expr_Decl, UI_From_Int (Int (Ccode)));
1084 end;
1085
1086 Append (Decl, Decl_A);
1087
1088 -- Increment character code, dealing with non-contiguities
1089
1090 Ccode := Ccode + 1;
1091
1092 if Ccode = 16#20# then
1093 Ccode := 16#21#;
1094 elsif Ccode = 16#27# then
1095 Ccode := 16#3A#;
1096 elsif Ccode = 16#3C# then
1097 Ccode := 16#3F#;
1098 elsif Ccode = 16#41# then
1099 Ccode := 16#5B#;
1100 end if;
1101 end loop;
1102
1103 -- Create semantic phase entities
1104
1105 Standard_Void_Type := New_Standard_Entity;
1106 Set_Ekind (Standard_Void_Type, E_Void);
1107 Set_Etype (Standard_Void_Type, Standard_Void_Type);
1108 Set_Scope (Standard_Void_Type, Standard_Standard);
1109 Make_Name (Standard_Void_Type, "_void_type");
1110
1111 -- The type field of packages is set to void
1112
1113 Set_Etype (Standard_Standard, Standard_Void_Type);
1114 Set_Etype (Standard_ASCII, Standard_Void_Type);
1115
1116 -- Standard_A_String is actually used in generated code, so it has a
1117 -- type name that is reasonable, but does not overlap any Ada name.
1118
1119 Standard_A_String := New_Standard_Entity;
1120 Set_Ekind (Standard_A_String, E_Access_Type);
1121 Set_Scope (Standard_A_String, Standard_Standard);
1122 Set_Etype (Standard_A_String, Standard_A_String);
1123
1124 if Debug_Flag_6 then
1125 Init_Size (Standard_A_String, System_Address_Size);
1126 else
1127 Init_Size (Standard_A_String, System_Address_Size * 2);
1128 end if;
1129
1130 Init_Alignment (Standard_A_String);
1131
1132 Set_Directly_Designated_Type
1133 (Standard_A_String, Standard_String);
1134 Make_Name (Standard_A_String, "access_string");
1135
1136 Standard_A_Char := New_Standard_Entity;
1137 Set_Ekind (Standard_A_Char, E_Access_Type);
1138 Set_Scope (Standard_A_Char, Standard_Standard);
1139 Set_Etype (Standard_A_Char, Standard_A_String);
1140 Init_Size (Standard_A_Char, System_Address_Size);
1141 Set_Elem_Alignment (Standard_A_Char);
1142
1143 Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
1144 Make_Name (Standard_A_Char, "access_character");
1145
1146 -- Standard_Debug_Renaming_Type is used for the special objects created
1147 -- to encode the names occurring in renaming declarations for use by the
1148 -- debugger (see exp_dbug.adb). The type is a zero-sized subtype of
1149 -- Standard.Integer.
1150
1151 Standard_Debug_Renaming_Type := New_Standard_Entity;
1152
1153 Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
1154 Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard);
1155 Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer));
1156 Init_Esize (Standard_Debug_Renaming_Type, 0);
1157 Init_RM_Size (Standard_Debug_Renaming_Type, 0);
1158 Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type);
1159 Set_Integer_Bounds (Standard_Debug_Renaming_Type,
1160 Typ => Base_Type (Standard_Debug_Renaming_Type),
1161 Lb => Uint_1,
1162 Hb => Uint_0);
1163 Set_Is_Constrained (Standard_Debug_Renaming_Type);
1164 Set_Has_Size_Clause (Standard_Debug_Renaming_Type);
1165
1166 Make_Name (Standard_Debug_Renaming_Type, "_renaming_type");
1167
1168 -- Note on type names. The type names for the following special types
1169 -- are constructed so that they will look reasonable should they ever
1170 -- appear in error messages etc, although in practice the use of the
1171 -- special insertion character } for types results in special handling
1172 -- of these type names in any case. The blanks in these names would
1173 -- trouble in Gigi, but that's OK here, since none of these types
1174 -- should ever get through to Gigi. Attributes of these types are
1175 -- filled out to minimize problems with cascaded errors (for example,
1176 -- Any_Integer is given reasonable and consistent type and size values)
1177
1178 Any_Type := New_Standard_Entity ("any type");
1179 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1180 Set_Defining_Identifier (Decl, Any_Type);
1181 Set_Scope (Any_Type, Standard_Standard);
1182 Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size);
1183
1184 Any_Id := New_Standard_Entity ("any id");
1185 Set_Ekind (Any_Id, E_Variable);
1186 Set_Scope (Any_Id, Standard_Standard);
1187 Set_Etype (Any_Id, Any_Type);
1188 Init_Esize (Any_Id);
1189 Init_Alignment (Any_Id);
1190
1191 Any_Access := New_Standard_Entity ("an access type");
1192 Set_Ekind (Any_Access, E_Access_Type);
1193 Set_Scope (Any_Access, Standard_Standard);
1194 Set_Etype (Any_Access, Any_Access);
1195 Init_Size (Any_Access, System_Address_Size);
1196 Set_Elem_Alignment (Any_Access);
1197 Set_Directly_Designated_Type
1198 (Any_Access, Any_Type);
1199
1200 Any_Character := New_Standard_Entity ("a character type");
1201 Set_Ekind (Any_Character, E_Enumeration_Type);
1202 Set_Scope (Any_Character, Standard_Standard);
1203 Set_Etype (Any_Character, Any_Character);
1204 Set_Is_Unsigned_Type (Any_Character);
1205 Set_Is_Character_Type (Any_Character);
1206 Init_Esize (Any_Character, Standard_Character_Size);
1207 Init_RM_Size (Any_Character, 8);
1208 Set_Elem_Alignment (Any_Character);
1209 Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
1210
1211 Any_Array := New_Standard_Entity ("an array type");
1212 Set_Ekind (Any_Array, E_Array_Type);
1213 Set_Scope (Any_Array, Standard_Standard);
1214 Set_Etype (Any_Array, Any_Array);
1215 Set_Component_Type (Any_Array, Any_Character);
1216 Init_Size_Align (Any_Array);
1217 Make_Dummy_Index (Any_Array);
1218
1219 Any_Boolean := New_Standard_Entity ("a boolean type");
1220 Set_Ekind (Any_Boolean, E_Enumeration_Type);
1221 Set_Scope (Any_Boolean, Standard_Standard);
1222 Set_Etype (Any_Boolean, Standard_Boolean);
1223 Init_Esize (Any_Boolean, Standard_Character_Size);
1224 Init_RM_Size (Any_Boolean, 1);
1225 Set_Elem_Alignment (Any_Boolean);
1226 Set_Is_Unsigned_Type (Any_Boolean);
1227 Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
1228
1229 Any_Composite := New_Standard_Entity ("a composite type");
1230 Set_Ekind (Any_Composite, E_Array_Type);
1231 Set_Scope (Any_Composite, Standard_Standard);
1232 Set_Etype (Any_Composite, Any_Composite);
1233 Set_Component_Size (Any_Composite, Uint_0);
1234 Set_Component_Type (Any_Composite, Standard_Integer);
1235 Init_Size_Align (Any_Composite);
1236
1237 Any_Discrete := New_Standard_Entity ("a discrete type");
1238 Set_Ekind (Any_Discrete, E_Signed_Integer_Type);
1239 Set_Scope (Any_Discrete, Standard_Standard);
1240 Set_Etype (Any_Discrete, Any_Discrete);
1241 Init_Size (Any_Discrete, Standard_Integer_Size);
1242 Set_Elem_Alignment (Any_Discrete);
1243
1244 Any_Fixed := New_Standard_Entity ("a fixed-point type");
1245 Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type);
1246 Set_Scope (Any_Fixed, Standard_Standard);
1247 Set_Etype (Any_Fixed, Any_Fixed);
1248 Init_Size (Any_Fixed, Standard_Integer_Size);
1249 Set_Elem_Alignment (Any_Fixed);
1250
1251 Any_Integer := New_Standard_Entity ("an integer type");
1252 Set_Ekind (Any_Integer, E_Signed_Integer_Type);
1253 Set_Scope (Any_Integer, Standard_Standard);
1254 Set_Etype (Any_Integer, Standard_Long_Long_Integer);
1255 Init_Size (Any_Integer, Standard_Long_Long_Integer_Size);
1256 Set_Elem_Alignment (Any_Integer);
1257
1258 Set_Integer_Bounds
1259 (Any_Integer,
1260 Typ => Base_Type (Standard_Integer),
1261 Lb => Uint_0,
1262 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
1263
1264 Any_Modular := New_Standard_Entity ("a modular type");
1265 Set_Ekind (Any_Modular, E_Modular_Integer_Type);
1266 Set_Scope (Any_Modular, Standard_Standard);
1267 Set_Etype (Any_Modular, Standard_Long_Long_Integer);
1268 Init_Size (Any_Modular, Standard_Long_Long_Integer_Size);
1269 Set_Elem_Alignment (Any_Modular);
1270 Set_Is_Unsigned_Type (Any_Modular);
1271
1272 Any_Numeric := New_Standard_Entity ("a numeric type");
1273 Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
1274 Set_Scope (Any_Numeric, Standard_Standard);
1275 Set_Etype (Any_Numeric, Standard_Long_Long_Integer);
1276 Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size);
1277 Set_Elem_Alignment (Any_Numeric);
1278
1279 Any_Real := New_Standard_Entity ("a real type");
1280 Set_Ekind (Any_Real, E_Floating_Point_Type);
1281 Set_Scope (Any_Real, Standard_Standard);
1282 Set_Etype (Any_Real, Standard_Long_Long_Float);
1283 Init_Size (Any_Real,
1284 UI_To_Int (Esize (Standard_Long_Long_Float)));
1285 Set_Elem_Alignment (Any_Real);
1286
1287 Any_Scalar := New_Standard_Entity ("a scalar type");
1288 Set_Ekind (Any_Scalar, E_Signed_Integer_Type);
1289 Set_Scope (Any_Scalar, Standard_Standard);
1290 Set_Etype (Any_Scalar, Any_Scalar);
1291 Init_Size (Any_Scalar, Standard_Integer_Size);
1292 Set_Elem_Alignment (Any_Scalar);
1293
1294 Any_String := New_Standard_Entity ("a string type");
1295 Set_Ekind (Any_String, E_Array_Type);
1296 Set_Scope (Any_String, Standard_Standard);
1297 Set_Etype (Any_String, Any_String);
1298 Set_Component_Type (Any_String, Any_Character);
1299 Init_Size_Align (Any_String);
1300 Make_Dummy_Index (Any_String);
1301
1302 Raise_Type := New_Standard_Entity ("raise type");
1303 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1304 Set_Defining_Identifier (Decl, Raise_Type);
1305 Set_Scope (Raise_Type, Standard_Standard);
1306 Build_Signed_Integer_Type (Raise_Type, Standard_Integer_Size);
1307
1308 Standard_Integer_8 := New_Standard_Entity ("integer_8");
1309 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1310 Set_Defining_Identifier (Decl, Standard_Integer_8);
1311 Set_Scope (Standard_Integer_8, Standard_Standard);
1312 Build_Signed_Integer_Type (Standard_Integer_8, 8);
1313
1314 Standard_Integer_16 := New_Standard_Entity ("integer_16");
1315 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1316 Set_Defining_Identifier (Decl, Standard_Integer_16);
1317 Set_Scope (Standard_Integer_16, Standard_Standard);
1318 Build_Signed_Integer_Type (Standard_Integer_16, 16);
1319
1320 Standard_Integer_32 := New_Standard_Entity ("integer_32");
1321 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1322 Set_Defining_Identifier (Decl, Standard_Integer_32);
1323 Set_Scope (Standard_Integer_32, Standard_Standard);
1324 Build_Signed_Integer_Type (Standard_Integer_32, 32);
1325
1326 Standard_Integer_64 := New_Standard_Entity ("integer_64");
1327 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1328 Set_Defining_Identifier (Decl, Standard_Integer_64);
1329 Set_Scope (Standard_Integer_64, Standard_Standard);
1330 Build_Signed_Integer_Type (Standard_Integer_64, 64);
1331
1332 -- Standard_*_Unsigned subtypes are not user visible, but they are
1333 -- used internally. They are unsigned types with the same length as
1334 -- the correspondingly named signed integer types.
1335
1336 Standard_Short_Short_Unsigned := New_Standard_Entity;
1337 Build_Unsigned_Integer_Type
1338 (Standard_Short_Short_Unsigned,
1339 Standard_Short_Short_Integer_Size,
1340 "short_short_unsigned");
1341
1342 Standard_Short_Unsigned := New_Standard_Entity;
1343 Build_Unsigned_Integer_Type
1344 (Standard_Short_Unsigned,
1345 Standard_Short_Integer_Size,
1346 "short_unsigned");
1347
1348 Standard_Unsigned := New_Standard_Entity;
1349 Build_Unsigned_Integer_Type
1350 (Standard_Unsigned,
1351 Standard_Integer_Size,
1352 "unsigned");
1353
1354 Standard_Long_Unsigned := New_Standard_Entity;
1355 Build_Unsigned_Integer_Type
1356 (Standard_Long_Unsigned,
1357 Standard_Long_Integer_Size,
1358 "long_unsigned");
1359
1360 Standard_Long_Long_Unsigned := New_Standard_Entity;
1361 Build_Unsigned_Integer_Type
1362 (Standard_Long_Long_Unsigned,
1363 Standard_Long_Long_Integer_Size,
1364 "long_long_unsigned");
1365
1366 -- Standard_Unsigned_64 is not user visible, but is used internally. It
1367 -- is an unsigned type mod 2**64, 64-bits unsigned, size is 64.
1368
1369 Standard_Unsigned_64 := New_Standard_Entity;
1370 Build_Unsigned_Integer_Type (Standard_Unsigned_64, 64, "unsigned_64");
1371
1372 -- Note: universal integer and universal real are constructed as fully
1373 -- formed signed numeric types, with parameters corresponding to the
1374 -- longest runtime types (Long_Long_Integer and Long_Long_Float). This
1375 -- allows Gigi to properly process references to universal types that
1376 -- are not folded at compile time.
1377
1378 Universal_Integer := New_Standard_Entity;
1379 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1380 Set_Defining_Identifier (Decl, Universal_Integer);
1381 Make_Name (Universal_Integer, "universal_integer");
1382 Set_Scope (Universal_Integer, Standard_Standard);
1383 Build_Signed_Integer_Type
1384 (Universal_Integer, Standard_Long_Long_Integer_Size);
1385
1386 Universal_Real := New_Standard_Entity;
1387 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1388 Set_Defining_Identifier (Decl, Universal_Real);
1389 Make_Name (Universal_Real, "universal_real");
1390 Set_Scope (Universal_Real, Standard_Standard);
1391 Copy_Float_Type (Universal_Real, Standard_Long_Long_Float);
1392
1393 -- Note: universal fixed, unlike universal integer and universal real,
1394 -- is never used at runtime, so it does not need to have bounds set.
1395
1396 Universal_Fixed := New_Standard_Entity;
1397 Decl := New_Node (N_Full_Type_Declaration, Stloc);
1398 Set_Defining_Identifier (Decl, Universal_Fixed);
1399 Make_Name (Universal_Fixed, "universal_fixed");
1400 Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type);
1401 Set_Etype (Universal_Fixed, Universal_Fixed);
1402 Set_Scope (Universal_Fixed, Standard_Standard);
1403 Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size);
1404 Set_Elem_Alignment (Universal_Fixed);
1405 Set_Size_Known_At_Compile_Time
1406 (Universal_Fixed);
1407
1408 -- Create type declaration for Duration, using a 64-bit size. The
1409 -- delta and size values depend on the mode set in system.ads.
1410
1411 Build_Duration : declare
1412 Dlo : Uint;
1413 Dhi : Uint;
1414 Delta_Val : Ureal;
1415
1416 begin
1417 -- In 32 bit mode, the size is 32 bits, and the delta and
1418 -- small values are set to 20 milliseconds (20.0*(10.0**(-3)).
1419
1420 if Duration_32_Bits_On_Target then
1421 Dlo := Intval (Type_Low_Bound (Standard_Integer_32));
1422 Dhi := Intval (Type_High_Bound (Standard_Integer_32));
1423 Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10);
1424
1425 -- In 64-bit mode, the size is 64-bits and the delta and
1426 -- small values are set to nanoseconds (1.0*(10.0**(-9)).
1427
1428 else
1429 Dlo := Intval (Type_Low_Bound (Standard_Integer_64));
1430 Dhi := Intval (Type_High_Bound (Standard_Integer_64));
1431 Delta_Val := UR_From_Components (Uint_1, Uint_9, 10);
1432 end if;
1433
1434 Tdef_Node := Make_Ordinary_Fixed_Point_Definition (Stloc,
1435 Delta_Expression => Make_Real_Literal (Stloc, Delta_Val),
1436 Real_Range_Specification =>
1437 Make_Real_Range_Specification (Stloc,
1438 Low_Bound => Make_Real_Literal (Stloc,
1439 Realval => Dlo * Delta_Val),
1440 High_Bound => Make_Real_Literal (Stloc,
1441 Realval => Dhi * Delta_Val)));
1442
1443 Set_Type_Definition (Parent (Standard_Duration), Tdef_Node);
1444
1445 Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
1446 Set_Etype (Standard_Duration, Standard_Duration);
1447
1448 if Duration_32_Bits_On_Target then
1449 Init_Size (Standard_Duration, 32);
1450 else
1451 Init_Size (Standard_Duration, 64);
1452 end if;
1453
1454 Set_Elem_Alignment (Standard_Duration);
1455 Set_Delta_Value (Standard_Duration, Delta_Val);
1456 Set_Small_Value (Standard_Duration, Delta_Val);
1457 Set_Scalar_Range (Standard_Duration,
1458 Real_Range_Specification
1459 (Type_Definition (Parent (Standard_Duration))));
1460
1461 -- Normally it does not matter that nodes in package Standard are
1462 -- not marked as analyzed. The Scalar_Range of the fixed-point type
1463 -- Standard_Duration is an exception, because of the special test
1464 -- made in Freeze.Freeze_Fixed_Point_Type.
1465
1466 Set_Analyzed (Scalar_Range (Standard_Duration));
1467
1468 Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration);
1469 Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration);
1470
1471 Set_Is_Static_Expression (Type_High_Bound (Standard_Duration));
1472 Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration));
1473
1474 Set_Corresponding_Integer_Value
1475 (Type_High_Bound (Standard_Duration), Dhi);
1476
1477 Set_Corresponding_Integer_Value
1478 (Type_Low_Bound (Standard_Duration), Dlo);
1479
1480 Set_Size_Known_At_Compile_Time (Standard_Duration);
1481 end Build_Duration;
1482
1483 -- Build standard exception type. Note that the type name here is
1484 -- actually used in the generated code, so it must be set correctly.
1485 -- The type Standard_Exception_Type must be consistent with the type
1486 -- System.Standard_Library.Exception_Data, as the latter is what is
1487 -- known by the run-time. Components of the record are documented in
1488 -- the declaration in System.Standard_Library.
1489
1490 Standard_Exception_Type := New_Standard_Entity;
1491 Set_Ekind (Standard_Exception_Type, E_Record_Type);
1492 Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
1493 Set_Scope (Standard_Exception_Type, Standard_Standard);
1494 Set_Stored_Constraint
1495 (Standard_Exception_Type, No_Elist);
1496 Init_Size_Align (Standard_Exception_Type);
1497 Set_Size_Known_At_Compile_Time
1498 (Standard_Exception_Type, True);
1499 Make_Name (Standard_Exception_Type, "exception");
1500
1501 Make_Component
1502 (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others");
1503 Make_Component
1504 (Standard_Exception_Type, Standard_Character, "Lang");
1505 Make_Component
1506 (Standard_Exception_Type, Standard_Natural, "Name_Length");
1507 Make_Component
1508 (Standard_Exception_Type, Standard_A_Char, "Full_Name");
1509 Make_Component
1510 (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
1511 Make_Component
1512 (Standard_Exception_Type, Standard_A_Char, "Foreign_Data");
1513 Make_Component
1514 (Standard_Exception_Type, Standard_A_Char, "Raise_Hook");
1515
1516 -- Build tree for record declaration, for use by the back-end
1517
1518 declare
1519 Comp_List : List_Id;
1520 Comp : Entity_Id;
1521
1522 begin
1523 Comp := First_Entity (Standard_Exception_Type);
1524 Comp_List := New_List;
1525 while Present (Comp) loop
1526 Append (
1527 Make_Component_Declaration (Stloc,
1528 Defining_Identifier => Comp,
1529 Component_Definition =>
1530 Make_Component_Definition (Stloc,
1531 Aliased_Present => False,
1532 Subtype_Indication => New_Occurrence_Of (Etype (Comp),
1533 Stloc))),
1534 Comp_List);
1535
1536 Next_Entity (Comp);
1537 end loop;
1538
1539 Decl := Make_Full_Type_Declaration (Stloc,
1540 Defining_Identifier => Standard_Exception_Type,
1541 Type_Definition =>
1542 Make_Record_Definition (Stloc,
1543 End_Label => Empty,
1544 Component_List =>
1545 Make_Component_List (Stloc,
1546 Component_Items => Comp_List)));
1547 end;
1548
1549 Append (Decl, Decl_S);
1550
1551 Layout_Type (Standard_Exception_Type);
1552
1553 -- Create declarations of standard exceptions
1554
1555 Build_Exception (S_Constraint_Error);
1556 Build_Exception (S_Program_Error);
1557 Build_Exception (S_Storage_Error);
1558 Build_Exception (S_Tasking_Error);
1559
1560 -- Numeric_Error is a normal exception in Ada 83, but in Ada 95
1561 -- it is a renaming of Constraint_Error. Is this test too early???
1562
1563 if Ada_Version = Ada_83 then
1564 Build_Exception (S_Numeric_Error);
1565
1566 else
1567 Decl := New_Node (N_Exception_Renaming_Declaration, Stloc);
1568 E_Id := Standard_Entity (S_Numeric_Error);
1569
1570 Set_Ekind (E_Id, E_Exception);
1571 Set_Etype (E_Id, Standard_Exception_Type);
1572 Set_Is_Public (E_Id);
1573 Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error));
1574
1575 Set_Defining_Identifier (Decl, E_Id);
1576 Append (Decl, Decl_S);
1577
1578 Ident_Node := New_Node (N_Identifier, Stloc);
1579 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
1580 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
1581 Set_Name (Decl, Ident_Node);
1582 end if;
1583
1584 -- Abort_Signal is an entity that does not get made visible
1585
1586 Abort_Signal := New_Standard_Entity;
1587 Set_Chars (Abort_Signal, Name_uAbort_Signal);
1588 Set_Ekind (Abort_Signal, E_Exception);
1589 Set_Etype (Abort_Signal, Standard_Exception_Type);
1590 Set_Scope (Abort_Signal, Standard_Standard);
1591 Set_Is_Public (Abort_Signal, True);
1592 Decl :=
1593 Make_Exception_Declaration (Stloc,
1594 Defining_Identifier => Abort_Signal);
1595
1596 -- Create defining identifiers for shift operator entities. Note
1597 -- that these entities are used only for marking shift operators
1598 -- generated internally, and hence need no structure, just a name
1599 -- and a unique identity.
1600
1601 Standard_Op_Rotate_Left := New_Standard_Entity;
1602 Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left);
1603 Set_Ekind (Standard_Op_Rotate_Left, E_Operator);
1604
1605 Standard_Op_Rotate_Right := New_Standard_Entity;
1606 Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right);
1607 Set_Ekind (Standard_Op_Rotate_Right, E_Operator);
1608
1609 Standard_Op_Shift_Left := New_Standard_Entity;
1610 Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left);
1611 Set_Ekind (Standard_Op_Shift_Left, E_Operator);
1612
1613 Standard_Op_Shift_Right := New_Standard_Entity;
1614 Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right);
1615 Set_Ekind (Standard_Op_Shift_Right, E_Operator);
1616
1617 Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity;
1618 Set_Chars (Standard_Op_Shift_Right_Arithmetic,
1619 Name_Shift_Right_Arithmetic);
1620 Set_Ekind (Standard_Op_Shift_Right_Arithmetic,
1621 E_Operator);
1622
1623 -- Create standard operator declarations
1624
1625 Create_Operators;
1626
1627 -- Initialize visibility table with entities in Standard
1628
1629 for E in Standard_Entity_Type loop
1630 if Ekind (Standard_Entity (E)) /= E_Operator then
1631 Set_Name_Entity_Id
1632 (Chars (Standard_Entity (E)), Standard_Entity (E));
1633 Set_Homonym (Standard_Entity (E), Empty);
1634 end if;
1635
1636 if E not in S_ASCII_Names then
1637 Set_Scope (Standard_Entity (E), Standard_Standard);
1638 Set_Is_Immediately_Visible (Standard_Entity (E));
1639 end if;
1640 end loop;
1641
1642 -- The predefined package Standard itself does not have a scope;
1643 -- it is the only entity in the system not to have one, and this
1644 -- is what identifies the package to Gigi.
1645
1646 Set_Scope (Standard_Standard, Empty);
1647
1648 -- Set global variables indicating last Id values and version
1649
1650 Last_Standard_Node_Id := Last_Node_Id;
1651 Last_Standard_List_Id := Last_List_Id;
1652
1653 -- The Error node has an Etype of Any_Type to help error recovery
1654
1655 Set_Etype (Error, Any_Type);
1656
1657 -- Print representation of standard if switch set
1658
1659 if Opt.Print_Standard then
1660 Print_Standard;
1661 end if;
1662 end Create_Standard;
1663
1664 ------------------------------------
1665 -- Create_Unconstrained_Base_Type --
1666 ------------------------------------
1667
1668 procedure Create_Unconstrained_Base_Type
1669 (E : Entity_Id;
1670 K : Entity_Kind)
1671 is
1672 New_Ent : constant Entity_Id := New_Copy (E);
1673
1674 begin
1675 Set_Ekind (E, K);
1676 Set_Is_Constrained (E, True);
1677 Set_Is_First_Subtype (E, True);
1678 Set_Etype (E, New_Ent);
1679
1680 Append_Entity (New_Ent, Standard_Standard);
1681 Set_Is_Constrained (New_Ent, False);
1682 Set_Etype (New_Ent, New_Ent);
1683 Set_Is_Known_Valid (New_Ent, True);
1684
1685 if K = E_Signed_Integer_Subtype then
1686 Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent);
1687 Set_Etype (High_Bound (Scalar_Range (E)), New_Ent);
1688 end if;
1689
1690 end Create_Unconstrained_Base_Type;
1691
1692 --------------------
1693 -- Identifier_For --
1694 --------------------
1695
1696 function Identifier_For (S : Standard_Entity_Type) return Node_Id is
1697 Ident_Node : Node_Id;
1698 begin
1699 Ident_Node := New_Node (N_Identifier, Stloc);
1700 Set_Chars (Ident_Node, Chars (Standard_Entity (S)));
1701 Set_Entity (Ident_Node, Standard_Entity (S));
1702 return Ident_Node;
1703 end Identifier_For;
1704
1705 --------------------
1706 -- Make_Component --
1707 --------------------
1708
1709 procedure Make_Component
1710 (Rec : Entity_Id;
1711 Typ : Entity_Id;
1712 Nam : String)
1713 is
1714 Id : constant Entity_Id := New_Standard_Entity;
1715
1716 begin
1717 Set_Ekind (Id, E_Component);
1718 Set_Etype (Id, Typ);
1719 Set_Scope (Id, Rec);
1720 Init_Component_Location (Id);
1721
1722 Set_Original_Record_Component (Id, Id);
1723 Make_Name (Id, Nam);
1724 Append_Entity (Id, Rec);
1725 end Make_Component;
1726
1727 -----------------
1728 -- Make_Formal --
1729 -----------------
1730
1731 function Make_Formal
1732 (Typ : Entity_Id;
1733 Formal_Name : String) return Entity_Id
1734 is
1735 Formal : Entity_Id;
1736
1737 begin
1738 Formal := New_Standard_Entity;
1739
1740 Set_Ekind (Formal, E_In_Parameter);
1741 Set_Mechanism (Formal, Default_Mechanism);
1742 Set_Scope (Formal, Standard_Standard);
1743 Set_Etype (Formal, Typ);
1744 Make_Name (Formal, Formal_Name);
1745
1746 return Formal;
1747 end Make_Formal;
1748
1749 ------------------
1750 -- Make_Integer --
1751 ------------------
1752
1753 function Make_Integer (V : Uint) return Node_Id is
1754 N : constant Node_Id := Make_Integer_Literal (Stloc, V);
1755 begin
1756 Set_Is_Static_Expression (N);
1757 return N;
1758 end Make_Integer;
1759
1760 ---------------
1761 -- Make_Name --
1762 ---------------
1763
1764 procedure Make_Name (Id : Entity_Id; Nam : String) is
1765 begin
1766 for J in 1 .. Nam'Length loop
1767 Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1)));
1768 end loop;
1769
1770 Name_Len := Nam'Length;
1771 Set_Chars (Id, Name_Find);
1772 end Make_Name;
1773
1774 ------------------
1775 -- New_Operator --
1776 ------------------
1777
1778 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is
1779 Ident_Node : Entity_Id;
1780
1781 begin
1782 Ident_Node := Make_Defining_Identifier (Stloc, Op);
1783
1784 Set_Is_Pure (Ident_Node, True);
1785 Set_Ekind (Ident_Node, E_Operator);
1786 Set_Etype (Ident_Node, Typ);
1787 Set_Scope (Ident_Node, Standard_Standard);
1788 Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op));
1789 Set_Convention (Ident_Node, Convention_Intrinsic);
1790
1791 Set_Is_Immediately_Visible (Ident_Node, True);
1792 Set_Is_Intrinsic_Subprogram (Ident_Node, True);
1793
1794 Set_Name_Entity_Id (Op, Ident_Node);
1795 Append_Entity (Ident_Node, Standard_Standard);
1796 return Ident_Node;
1797 end New_Operator;
1798
1799 -------------------------
1800 -- New_Standard_Entity --
1801 -------------------------
1802
1803 function New_Standard_Entity
1804 (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id
1805 is
1806 E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc);
1807
1808 begin
1809 -- All standard entities are Pure and Public
1810
1811 Set_Is_Pure (E);
1812 Set_Is_Public (E);
1813
1814 -- All standard entity names are analyzed manually, and are thus
1815 -- frozen as soon as they are created.
1816
1817 Set_Is_Frozen (E);
1818
1819 -- Set debug information required for all standard types
1820
1821 Set_Needs_Debug_Info (E);
1822
1823 -- All standard entities are built with fully qualified names, so
1824 -- set the flag to prevent an abortive attempt at requalification.
1825
1826 Set_Has_Qualified_Name (E);
1827
1828 -- Return newly created entity to be completed by caller
1829
1830 return E;
1831 end New_Standard_Entity;
1832
1833 function New_Standard_Entity (S : String) return Entity_Id is
1834 Ent : constant Entity_Id := New_Standard_Entity;
1835 begin
1836 Make_Name (Ent, S);
1837 return Ent;
1838 end New_Standard_Entity;
1839
1840 --------------------
1841 -- Print_Standard --
1842 --------------------
1843
1844 procedure Print_Standard is
1845
1846 procedure P (Item : String) renames Output.Write_Line;
1847 -- Short-hand, since we do a lot of line writes here
1848
1849 procedure P_Int_Range (Size : Pos);
1850 -- Prints the range of an integer based on its Size
1851
1852 procedure P_Float_Range (Id : Entity_Id);
1853 -- Prints the bounds range for the given float type entity
1854
1855 procedure P_Float_Type (Id : Entity_Id);
1856 -- Prints the type declaration of the given float type entity
1857
1858 procedure P_Mixed_Name (Id : Name_Id);
1859 -- Prints Id in mixed case
1860
1861 -------------------
1862 -- P_Float_Range --
1863 -------------------
1864
1865 procedure P_Float_Range (Id : Entity_Id) is
1866 begin
1867 Write_Str (" range ");
1868 UR_Write (Realval (Type_Low_Bound (Id)));
1869 Write_Str (" .. ");
1870 UR_Write (Realval (Type_High_Bound (Id)));
1871 Write_Str (";");
1872 Write_Eol;
1873 end P_Float_Range;
1874
1875 ------------------
1876 -- P_Float_Type --
1877 ------------------
1878
1879 procedure P_Float_Type (Id : Entity_Id) is
1880 begin
1881 Write_Str (" type ");
1882 P_Mixed_Name (Chars (Id));
1883 Write_Str (" is digits ");
1884 Write_Int (UI_To_Int (Digits_Value (Id)));
1885 Write_Eol;
1886 P_Float_Range (Id);
1887 Write_Str (" for ");
1888 P_Mixed_Name (Chars (Id));
1889 Write_Str ("'Size use ");
1890 Write_Int (UI_To_Int (RM_Size (Id)));
1891 Write_Line (";");
1892 Write_Eol;
1893 end P_Float_Type;
1894
1895 -----------------
1896 -- P_Int_Range --
1897 -----------------
1898
1899 procedure P_Int_Range (Size : Pos) is
1900 begin
1901 Write_Str (" is range -(2 **");
1902 Write_Int (Size - 1);
1903 Write_Str (")");
1904 Write_Str (" .. +(2 **");
1905 Write_Int (Size - 1);
1906 Write_Str (" - 1);");
1907 Write_Eol;
1908 end P_Int_Range;
1909
1910 ------------------
1911 -- P_Mixed_Name --
1912 ------------------
1913
1914 procedure P_Mixed_Name (Id : Name_Id) is
1915 begin
1916 Get_Name_String (Id);
1917
1918 for J in 1 .. Name_Len loop
1919 if J = 1 or else Name_Buffer (J - 1) = '_' then
1920 Name_Buffer (J) := Fold_Upper (Name_Buffer (J));
1921 end if;
1922 end loop;
1923
1924 Write_Str (Name_Buffer (1 .. Name_Len));
1925 end P_Mixed_Name;
1926
1927 -- Start of processing for Print_Standard
1928
1929 begin
1930 P ("-- Representation of package Standard");
1931 Write_Eol;
1932 P ("-- This is not accurate Ada, since new base types cannot be ");
1933 P ("-- created, but the listing shows the target dependent");
1934 P ("-- characteristics of the Standard types for this compiler");
1935 Write_Eol;
1936
1937 P ("package Standard is");
1938 P ("pragma Pure (Standard);");
1939 Write_Eol;
1940
1941 P (" type Boolean is (False, True);");
1942 P (" for Boolean'Size use 1;");
1943 P (" for Boolean use (False => 0, True => 1);");
1944 Write_Eol;
1945
1946 -- Integer types
1947
1948 Write_Str (" type Integer");
1949 P_Int_Range (Standard_Integer_Size);
1950 Write_Str (" for Integer'Size use ");
1951 Write_Int (Standard_Integer_Size);
1952 P (";");
1953 Write_Eol;
1954
1955 P (" subtype Natural is Integer range 0 .. Integer'Last;");
1956 P (" subtype Positive is Integer range 1 .. Integer'Last;");
1957 Write_Eol;
1958
1959 Write_Str (" type Short_Short_Integer");
1960 P_Int_Range (Standard_Short_Short_Integer_Size);
1961 Write_Str (" for Short_Short_Integer'Size use ");
1962 Write_Int (Standard_Short_Short_Integer_Size);
1963 P (";");
1964 Write_Eol;
1965
1966 Write_Str (" type Short_Integer");
1967 P_Int_Range (Standard_Short_Integer_Size);
1968 Write_Str (" for Short_Integer'Size use ");
1969 Write_Int (Standard_Short_Integer_Size);
1970 P (";");
1971 Write_Eol;
1972
1973 Write_Str (" type Long_Integer");
1974 P_Int_Range (Standard_Long_Integer_Size);
1975 Write_Str (" for Long_Integer'Size use ");
1976 Write_Int (Standard_Long_Integer_Size);
1977 P (";");
1978 Write_Eol;
1979
1980 Write_Str (" type Long_Long_Integer");
1981 P_Int_Range (Standard_Long_Long_Integer_Size);
1982 Write_Str (" for Long_Long_Integer'Size use ");
1983 Write_Int (Standard_Long_Long_Integer_Size);
1984 P (";");
1985 Write_Eol;
1986
1987 -- Floating point types
1988
1989 P_Float_Type (Standard_Short_Float);
1990 P_Float_Type (Standard_Float);
1991 P_Float_Type (Standard_Long_Float);
1992 P_Float_Type (Standard_Long_Long_Float);
1993
1994 P (" type Character is (...)");
1995 Write_Str (" for Character'Size use ");
1996 Write_Int (Standard_Character_Size);
1997 P (";");
1998 P (" -- See RM A.1(35) for details of this type");
1999 Write_Eol;
2000
2001 P (" type Wide_Character is (...)");
2002 Write_Str (" for Wide_Character'Size use ");
2003 Write_Int (Standard_Wide_Character_Size);
2004 P (";");
2005 P (" -- See RM A.1(36) for details of this type");
2006 Write_Eol;
2007
2008 P (" type Wide_Wide_Character is (...)");
2009 Write_Str (" for Wide_Wide_Character'Size use ");
2010 Write_Int (Standard_Wide_Wide_Character_Size);
2011 P (";");
2012 P (" -- See RM A.1(36) for details of this type");
2013
2014 P (" type String is array (Positive range <>) of Character;");
2015 P (" pragma Pack (String);");
2016 Write_Eol;
2017
2018 P (" type Wide_String is array (Positive range <>)" &
2019 " of Wide_Character;");
2020 P (" pragma Pack (Wide_String);");
2021 Write_Eol;
2022
2023 P (" type Wide_Wide_String is array (Positive range <>)" &
2024 " of Wide_Wide_Character;");
2025 P (" pragma Pack (Wide_Wide_String);");
2026 Write_Eol;
2027
2028 -- We only have one representation each for 32-bit and 64-bit sizes,
2029 -- so select the right one based on Duration_32_Bits_On_Target.
2030
2031 if Duration_32_Bits_On_Target then
2032 P (" type Duration is delta 0.020");
2033 P (" range -((2 ** 31) * 0.020) ..");
2034 P (" +((2 ** 31 - 1) * 0.020);");
2035 P (" for Duration'Small use 0.020;");
2036
2037 else
2038 P (" type Duration is delta 0.000000001");
2039 P (" range -((2 ** 63) * 0.000000001) ..");
2040 P (" +((2 ** 63 - 1) * 0.000000001);");
2041 P (" for Duration'Small use 0.000000001;");
2042 end if;
2043
2044 Write_Eol;
2045
2046 P (" Constraint_Error : exception;");
2047 P (" Program_Error : exception;");
2048 P (" Storage_Error : exception;");
2049 P (" Tasking_Error : exception;");
2050 P (" Numeric_Error : exception renames Constraint_Error;");
2051 Write_Eol;
2052
2053 P ("end Standard;");
2054 end Print_Standard;
2055
2056 -------------------------
2057 -- Register_Float_Type --
2058 -------------------------
2059
2060 procedure Register_Float_Type
2061 (Name : String;
2062 Digs : Positive;
2063 Float_Rep : Float_Rep_Kind;
2064 Precision : Positive;
2065 Size : Positive;
2066 Alignment : Natural)
2067 is
2068 Ent : constant Entity_Id := New_Standard_Entity;
2069
2070 begin
2071 Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent);
2072 Make_Name (Ent, Name);
2073 Set_Scope (Ent, Standard_Standard);
2074 Build_Float_Type (Ent, Int (Size), Float_Rep, Pos (Digs));
2075 Set_RM_Size (Ent, UI_From_Int (Int (Precision)));
2076 Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8)));
2077
2078 if No (Back_End_Float_Types) then
2079 Back_End_Float_Types := New_Elmt_List;
2080 end if;
2081
2082 Append_Elmt (Ent, Back_End_Float_Types);
2083 end Register_Float_Type;
2084
2085 ----------------------
2086 -- Set_Float_Bounds --
2087 ----------------------
2088
2089 procedure Set_Float_Bounds (Id : Entity_Id) is
2090 L : Node_Id;
2091 H : Node_Id;
2092 -- Low and high bounds of literal value
2093
2094 R : Node_Id;
2095 -- Range specification
2096
2097 Radix : constant Uint := Machine_Radix_Value (Id);
2098 Mantissa : constant Uint := Machine_Mantissa_Value (Id);
2099 Emax : constant Uint := Machine_Emax_Value (Id);
2100 Significand : constant Uint := Radix ** Mantissa - 1;
2101 Exponent : constant Uint := Emax - Mantissa;
2102
2103 begin
2104 H := Make_Float_Literal (Stloc, Radix, Significand, Exponent);
2105 L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent);
2106
2107 Set_Etype (L, Id);
2108 Set_Is_Static_Expression (L);
2109
2110 Set_Etype (H, Id);
2111 Set_Is_Static_Expression (H);
2112
2113 R := New_Node (N_Range, Stloc);
2114 Set_Low_Bound (R, L);
2115 Set_High_Bound (R, H);
2116 Set_Includes_Infinities (R, True);
2117 Set_Scalar_Range (Id, R);
2118 Set_Etype (R, Id);
2119 Set_Parent (R, Id);
2120 end Set_Float_Bounds;
2121
2122 ------------------------
2123 -- Set_Integer_Bounds --
2124 ------------------------
2125
2126 procedure Set_Integer_Bounds
2127 (Id : Entity_Id;
2128 Typ : Entity_Id;
2129 Lb : Uint;
2130 Hb : Uint)
2131 is
2132 L : Node_Id;
2133 H : Node_Id;
2134 -- Low and high bounds of literal value
2135
2136 R : Node_Id;
2137 -- Range specification
2138
2139 begin
2140 L := Make_Integer (Lb);
2141 H := Make_Integer (Hb);
2142
2143 Set_Etype (L, Typ);
2144 Set_Etype (H, Typ);
2145
2146 R := New_Node (N_Range, Stloc);
2147 Set_Low_Bound (R, L);
2148 Set_High_Bound (R, H);
2149 Set_Scalar_Range (Id, R);
2150 Set_Etype (R, Typ);
2151 Set_Parent (R, Id);
2152 Set_Is_Unsigned_Type (Id, Lb >= 0);
2153 end Set_Integer_Bounds;
2154
2155 end CStand;
Mirror of the offical gcc git repository hosted at gcc.gnu.org