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