File : cprint.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- C P R I N T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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 Checks; use Checks;
28 with Csets; use Csets;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Tss; use Exp_Tss;
34 with Exp_Unst; use Exp_Unst;
35 with Exp_Util; use Exp_Util;
36 with Lib; use Lib;
37 with Namet; use Namet;
38 with Nlists; use Nlists;
39 with Opt; use Opt;
40 with Osint; use Osint;
41 with Osint.C; use Osint.C;
42 with Output; use Output;
43 with Restrict; use Restrict;
44 with Rident; use Rident;
45 with Sem;
46 with Sem_Aux; use Sem_Aux;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Mech; use Sem_Mech;
49 with Sem_Util; use Sem_Util;
50 with Sinfo; use Sinfo;
51 with Sinput; use Sinput;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Table;
56 with Ttypes; use Ttypes;
57 with Types; use Types;
58 with Uintp; use Uintp;
59 with Urealp; use Urealp;
60 with System.HTable; use System.HTable;
61
62 package body Cprint is
63 Current_Source_File : Source_File_Index;
64 -- Index of source file whose generated code is being dumped
65
66 Full_Code_Generation : Boolean := False;
67 -- True if we should generate C code for all constructs. If False, only
68 -- generate a C header for Ada specs.
69
70 Dump_Node : Node_Id := Empty;
71 -- This is set to the current node, used for printing line numbers
72
73 FLCache_N : Node_Id := Empty;
74 FLCache_FL : Physical_Line_Number;
75 FLCache_LL : Physical_Line_Number;
76 -- Cache for First_Line and Last_Line (N records last node for which any
77 -- of these subprograms were called, FL and LL record the corresponding
78 -- First and Last physical line numbers for this node).
79
80 Freeze_Level : Int := 0;
81 -- Keep track of freeze level (incremented on entry to freeze actions and
82 -- decremented on exit). Used to know if we are within freeze actions.
83
84 Indent : Nat := 0;
85 -- Number of columns for current line output indentation
86
87 Last_Line_Printed : Physical_Line_Number;
88 -- This keeps track of the physical line number of the last source line for
89 -- which Write_Source_Lines has processed #line/source output.
90
91 No_Physical_Line_Number : constant Physical_Line_Number :=
92 Physical_Line_Number'Last;
93 -- Used internally to indicate no line number available
94
95 In_Main_Unit : Boolean := False;
96 -- Indicates whether the current unit being processed is part of the
97 -- main unit. If this is the case, output all code; otherwise, output
98 -- only external declarations and types.
99
100 Library_Level : Boolean := True;
101 -- Indicates whether the current node is at library level
102
103 In_Package_Body_Init : Boolean := False;
104 -- Indicates whether the current node is located in the initialization of a
105 -- package body.
106
107 In_Search_Type_Ref : Boolean := False;
108 -- Indicates whether we are unnesting types of nested subprograms
109
110 Special_Elaboration_Code : Boolean := False;
111 -- Indicates whether we are generating code for statements part of the
112 -- elaboration code (outside an explicit 'begin ... end').
113
114 Current_Elab_Entity : Node_Id := Empty;
115 -- Current entity which needs to be elaborated. Only set when
116 -- Special_Elaboration_Code is True.
117
118 Current_Subp_Entity : Entity_Id := Empty;
119 -- Current subprogram for which Output_One_Body is generating code
120
121 In_Compound_Statement : Boolean := False;
122 -- Indicates whether we are processing a compound statement and, if so,
123 -- will generate different code if needed. This is used in particular to
124 -- emit an if-statement as an if-expression.
125
126 -- The following constants are used by Write_Uint. They are initialized as
127 -- shown when Source_Dump is called:
128
129 ints : Nat renames Standard_Integer_Size;
130 longs : Nat renames Standard_Long_Integer_Size;
131 lls : Nat renames Standard_Long_Long_Integer_Size;
132 -- Length in bits of int, long, long long
133
134 LNegInt : Uint; -- -(Uint_2 ** (ints - 1));
135 LPosInt : Uint; -- abs (LNegInt + 1);
136 LNegLong : Uint; -- -(Uint_2 ** (longs - 1));
137 LPosLong : Uint; -- abs (LNegLong + 1);
138 LNegLL : Uint; -- -(Uint_2 ** (lls - 1));
139 LPosLL : Uint; -- abs (LNegLL + 1);
140 -- Bounds of int, long, long long
141
142 LPosU : Uint; -- (Uint_2 ** ints) - 1;
143 LNegU : Uint; -- -LPosU;
144 LPosUL : Uint; -- (Uint_2 ** longs) - 1;
145 LNegUL : Uint; -- -LPosUL;
146 LPosULL : Uint; -- (Uint_2 ** lls) - 1;
147 LNegULL : Uint; -- -LPosULL;
148 -- Bounds of unsigned, long unsigned, long long unsigned
149
150 ------------------------------------------
151 -- Procedures for printing C constructs --
152 ------------------------------------------
153
154 procedure Cprint_And_List (List : List_Id);
155 -- Print the given list with items separated by vertical "and"
156
157 procedure Cprint_Bar_List (List : List_Id);
158 -- Print the given list with items separated by vertical bars
159
160 procedure Cprint_Call (Node : Node_Id);
161 -- Outputs a function or procedure call, with its parameters, dealing
162 -- with the case of passing addresses for OUT or IN OUT parameters
163
164 function Cprint_Comma_List (List : List_Id) return Integer;
165 procedure Cprint_Comma_List (List : List_Id);
166 -- Prints the nodes in a list, with separating commas. If the list is empty
167 -- then no output is generated.
168 -- The function version returns the number of nodes printed.
169
170 procedure Cprint_Copy
171 (Target : Node_Id;
172 Source : Node_Id;
173 Use_Memcpy : Boolean);
174 -- Print code which copies the contents of Source into Target. If
175 -- Use_Memcpy is True, the use of memcpy() is safe. Otherwise
176 -- memmove() will be used.
177
178 procedure Cprint_Declare
179 (Ent : Entity_Id;
180 Add_Access : Boolean := False;
181 Virtual_OK : Boolean := False;
182 Semicolon : Boolean := True);
183 -- Wrapper of Cprint_Reference which provides the following extra
184 -- functionality:
185 -- * Declare each entity just once
186 -- * If Semicolon is True then emit the closing semicolon and prepend
187 -- indentation if needed.
188
189 function Cprint_Reference
190 (Ent : Entity_Id;
191 Add_Access : Boolean := False;
192 Virtual_OK : Boolean := False) return Boolean;
193 -- Ent is either a type or object. This procedure prints either a typedef
194 -- declaration for a type, or a normal C declaration for an object. The
195 -- output does not include the terminating semicolon. If Add_Access is set
196 -- to true, then the type has an extra access, i.e. if we have A of type B
197 -- then a declaration for A of type *B is output. Note that there is no
198 -- indent call, the caller should call Indent if a new line is needed.
199 -- Virtual_OK deals with the case of unconstrained array types. When a
200 -- normal variable of such a type is declared, the bounds are present in
201 -- the type, and are the bounds to be output (case of Virtual_OK = False).
202 -- But in e.g. the formal of a call, the bounds come from the caller, and
203 -- if the type is unconstrained are to be output simply as []. In this
204 -- case Virtual_OK is set True. Bounds are also output as [] if the array
205 -- is variable length and Add_Access is True.
206
207 procedure Cprint_Difference (Val1 : Node_Id; Val2 : Uint; B : Boolean);
208 -- Outputs the value of Val1 - Val2, using a single integer value if the
209 -- value is known at compile time and otherwise prints val1 - val2. B
210 -- is True if parens should be used in the compound case, false otherwise.
211 -- ??? This routine should deal with overflow.
212
213 procedure Cprint_Difference
214 (Val1 : Node_Id;
215 Val2 : Node_Id;
216 Minus_One_Min : Boolean);
217 -- Same as above.
218 -- In addition, if Minus_One_Min is True, generate Max (Val2 - Val1, -1)
219 -- to ensure that we never generate a value below -1. In other words,
220 -- assume that this procedure is called to generate array bounds which
221 -- should never be negative (case of 'Last < 'First).
222 -- ??? This routine should deal with overflow.
223
224 procedure Cprint_Indented_List (List : List_Id);
225 -- Like Cprint_Line_List, except that the indentation level is increased
226 -- before outputting the list of items, and then decremented (back to its
227 -- original level) before returning to the caller.
228
229 procedure Cprint_Left_Opnd (N : Node_Id);
230 -- Print left operand of operator, parenthesizing if necessary. Note that
231 -- we fully parenthesize operator trees in the C output.
232
233 procedure Cprint_Node (Node : Node_Id; Declaration : Boolean := False);
234 -- Prints a single node. No new lines are output, except as required for
235 -- splitting lines that are too long to fit on a single physical line.
236 -- No output is generated at all if Node is Empty. No trailing or leading
237 -- blank characters are generated.
238 -- If Declaration is True then use the symbolic name associated with Node,
239 -- otherwise this subprogram is allowed to replace Node by its value in
240 -- case of e.g. a constant.
241
242 procedure Cprint_Node_List (List : List_Id; New_Lines : Boolean := False);
243 -- Prints the nodes in a list with no separating characters. This is used
244 -- in the case of lists of items which are printed on separate lines using
245 -- the current indentation amount. New_Lines controls the generation of
246 -- New_Line calls. If False, no New_Line calls are generated. If True,
247 -- then New_Line calls are generated as needed to ensure that each list
248 -- item starts at the beginning of a line.
249
250 procedure Cprint_Node_Paren (N : Node_Id);
251 -- Prints node, adding parentheses if N is an operator, or short circuit
252 -- operation or other subexpression which needs parenthesizing as an
253 -- operand (we always fully parenthesize expression trees in the C output).
254
255 procedure Cprint_Opt_Node (Node : Node_Id);
256 -- Same as normal Cprint_Node procedure, except that one leading blank is
257 -- output before the node if it is non-empty.
258
259 procedure Cprint_Opt_Node_List (List : List_Id);
260 -- Like Cprint_Node_List, but prints nothing if List = No_List
261
262 procedure Cprint_Right_Opnd (N : Node_Id);
263 -- Print right operand of operator, parenthesizing if necessary. Note that
264 -- we fully parenthesize operator trees in the C output.
265
266 procedure Cprint_Subprogram_Body (N : Node_Id);
267 -- Output subprogram body, including dealing with unnesting any subprograms
268 -- nested within this body for an outer level subprogram.
269
270 procedure Cprint_Sum (Val1 : Node_Id; Val2 : Uint; B : Boolean);
271 -- Outputs the value of Val1 + Val2, using a single integer value if the
272 -- value is known at compile time and otherwise prints (val1 + val2). B
273 -- is True if parens should be used in the compound case, false otherwise
274
275 procedure Cprint_Type_Name (Typ : Entity_Id; Use_Typedef : Boolean := True);
276 -- Output C representation of Ada type Typ.
277 -- If Use_Typedef is True, the Typ name is just printed since it is assumed
278 -- to be a typedef name. You can set it to False to avoid this behavior.
279 -- This is used when Cprint_Type_Name is called from typedef circuitry, to
280 -- avoid a typedef pointing to itself!
281
282 -----------------------
283 -- Local Subprograms --
284 -----------------------
285
286 procedure Append_Subprogram_Prefix (Spec : Node_Id);
287 -- Append "_ada_" to the name if this is a library-level subprogram,
288 -- so it can be invoked as a main subprogram from the bind module.
289
290 procedure Check_Definition (N : Node_Id; Error_Node : Node_Id := Empty);
291 -- Verify that N is previously defined and report an error on Error_Node
292 -- otherwise. If Error_Node is Empty the error is reported on N.
293
294 function Check_Sloc (S : Source_Ptr) return Boolean;
295 -- Return False if we are not in the current source file (e.g.
296 -- instantiation, inlining).
297
298 procedure Col_Check (N : Nat);
299 -- Check that at least N characters remain on current line, and if not,
300 -- then start an extra line with two characters extra indentation for
301 -- continuing text on the next line.
302
303 function Compound_Statement_Compatible (L : List_Id) return Boolean;
304 -- Return True if L contains only expressions or statements compatible
305 -- with compound statements.
306
307 procedure Declare_Subprogram_Types (N : Node_Id);
308 -- Force the declaration of the types of the subprogram formals
309 -- (including the return type of functions).
310
311 procedure Dump_Type (Typ : Entity_Id);
312 -- Dump type and indentation if Typ has not been dumped yet and it is
313 -- not defined in the Standard package. For private types dump their
314 -- full view and only when the names of the full_view and the partial
315 -- view differ dump also the partial view.
316
317 procedure Ensure_New_Line;
318 -- Ensure that we are the start of a newline with current indentation
319
320 function First_Line (N : Node_Id) return Physical_Line_Number;
321 -- Given a subtree, determines the first physical line number for any node
322 -- in the subtree. Returns No_Physical_Line_Number if no value found.
323
324 function Get_Full_View (Id : Entity_Id) return Entity_Id;
325 -- Return the full view of Id, or Id itself
326
327 function Last_Line (N : Node_Id) return Physical_Line_Number;
328 -- Given a subtree, determines the last physical line number for any node
329 -- in the subtree. Returns No_Physical_Line_Number if no value found.
330
331 procedure Get_First_Last_Line (N : Node_Id);
332 -- Determines first and last physical line number for subtree N, placing
333 -- the result in FLCache. Result is No_Physical_Line_Number if node N does
334 -- not come from current source file.
335
336 function Has_Non_Null_Statements (L : List_Id) return Boolean;
337 -- Return True if L has non null statements
338
339 function Has_Or_Inherits_Enum_Rep_Clause (E : Entity_Id) return Boolean;
340 -- Return True if the enumeration type E or some of its parents has an
341 -- enumeration representation clause.
342
343 function Has_Same_Int_Value (Val1 : Node_Id; Val2 : Node_Id) return Boolean;
344 -- Return True if Val1 and Val2 represent the same integer value
345
346 procedure Handle_Attribute (N : Node_Id);
347 -- Handle C generation of an attribute reference
348
349 procedure Handle_Raise (N : Node_Id);
350 -- Handle the C generation of N_Raise_Statement, N_Raise_Expression
351 -- and N_Raise_xxx_Error nodes.
352
353 function In_Instantiation (S : Source_Ptr) return Boolean;
354 -- Returns True if the source location corresponds with an instantiation
355
356 function Is_Enum_Literal_Of_Enclosing_Subprogram
357 (E : Entity_Id) return Boolean;
358 -- Returns True if E is an enumeration literal whose enumeration type is
359 -- defined in an enclosing subprogram.
360
361 function Is_Out_Mode_Access_Formal (E : Node_Id) return Boolean;
362 -- Returns True if E is an OUT or IN-OUT access formal
363
364 function Is_Packed_Array (Typ : Entity_Id) return Boolean;
365 -- Returns True if Typ is a packed array
366
367 function Is_Supported_Variable_Size_Record (Typ : Entity_Id) return Boolean;
368 -- Returns True if Typ is a record with discriminants whose last field is
369 -- an array which depends on its discriminants.
370
371 procedure Indent_Begin;
372 -- Increase indentation level
373
374 procedure Indent_End;
375 -- Decrease indentation level
376
377 function Last_Field (Typ : Node_Id) return Node_Id;
378 -- Return the last field of a given record type
379
380 procedure Output_Sizeof (Target : Node_Id; Source : Node_Id := Empty);
381 -- Output call to sizeof() taking the size of Target or Source, whichever
382 -- can be computed.
383
384 function Parens_Needed (N : Node_Id) return Boolean;
385 -- Returns True if N is in a context where it is not known to be safe to
386 -- leave an expression unparenthesized. This is conservative. False means
387 -- is is definitely safe to leave out parens, True means that parens may
388 -- be needed so they will be put in. Right now, the test is limited to
389 -- being the right side of an assignment.
390
391 function Pass_Pointer (Ent : Entity_Id) return Boolean;
392 -- Ent is the entity for a formal parameter. This function returns True if
393 -- the corresponding object must be passed by using a pointer in C (i.e. by
394 -- adding * in the definition of the formal, and & for calls). This is True
395 -- for OUT and IN OUT parameters and for by-ref types.
396 -- Note that it is never True for arrays, since in C, arrays are always
397 -- passed in pointer form in any case.
398
399 function Requires_Address (Typ : Node_Id) return Boolean;
400 -- Return True if an object of type Typ should have its address taken when
401 -- referencing it (to e.g. call memcmp() or memcmp()).
402
403 function Ultimate_Expression (N : Node_Id) return Node_Id;
404 -- Return the innermost expression of the given qualified expression, type
405 -- conversion, or unchecked type conversion N.
406
407 procedure Unimplemented_Attribute
408 (N : Node_Id;
409 Attr : Name_Id;
410 Context : String := "");
411 -- Called to output error string for given unimplemented attribute Attr,
412 -- and post error message on node N. Append Context to the error message.
413
414 type Bound_Kind is (Low, High);
415 -- Used to specify the bound value writen by Write_Array_Bound
416
417 procedure Write_Array_Bound
418 (Expr : Node_Id;
419 Bound : Bound_Kind;
420 Dimension : Pos);
421 -- Output the low bound or high bound of the given dimension of the fat
422 -- pointer or array available through Expr.
423
424 procedure Write_C_Char_Code (CC : Char_Code);
425 -- Write a given character in a suitable form for the C language.
426
427 procedure Write_Id (N : Node_Id);
428 -- N is a node with a Chars field. This procedure writes the name that
429 -- will be used in the generated code associated with the name. For a
430 -- node with no associated entity, this is simply the Chars field. For
431 -- the case where there is an entity associated with the node, we print
432 -- the name associated with the entity (since it may have been encoded).
433 -- One other special case is that an entity has an active external name
434 -- (i.e. an external name present with no address clause), then this
435 -- external name is output. This procedure also deals with outputting
436 -- declarations of referenced itypes, if not output earlier.
437
438 procedure Write_Integer_Type (Siz : Int; Signed : Boolean);
439 -- Output an integer type given the size Siz in bits, rounded to the next
440 -- power of two (8, 16, 32, 64). If Signed, reference integer_xx, otherwise
441 -- reference unsigned_xx.
442
443 procedure Write_Indent;
444 -- Start a new line and write indentation spacing
445
446 procedure Write_Indent_Str (S : String);
447 -- Start a new line and write indent spacing followed by given string
448
449 procedure Write_Name_Col_Check (N : Name_Id);
450 -- Write name (using Write_Name) with initial column check, and possible
451 -- initial Write_Indent (to get new line) if current line is too full.
452
453 procedure Write_Param_Specs (N : Node_Id);
454 -- Output parameter specifications for node (which is either a function or
455 -- procedure specification with a Parameter_Specifications field)
456
457 procedure Write_Source_Lines
458 (From : Physical_Line_Number;
459 To : Physical_Line_Number);
460 -- From, To are the start/end physical line numbers for the construct
461 -- whose C translation is about to be printed. This routine takes care of
462 -- generating required #line directives, and also in Dump_Source_Text mode,
463 -- prints non-comment source Ada lines as C comments.
464
465 procedure Write_Source_Lines (N : Node_Id);
466 -- Same, but From, To are First_Line, Last_Line of node N
467
468 procedure Write_Source_Lines (S : Source_Ptr);
469 -- Same, but From and To both correspond to the given Source_Ptr value
470
471 procedure Write_Source_Lines (From : Source_Ptr; To : Physical_Line_Number);
472 -- Same, but From is line corresponding to given source_Ptr value.
473
474 procedure Write_Str_Col_Check (S : String);
475 -- Write string (using Write_Str) with initial column check, and possible
476 -- initial Write_Indent (to get new line) if current line is too full.
477
478 procedure Write_Uint
479 (U : Uint;
480 Column_Check : Boolean := True;
481 Modular : Boolean := False);
482 -- Write Uint.
483 -- If Column_Check is True, perform initial column check and possible
484 -- initial Write_Indent (to get new line) if current line is too full.
485 -- The output is always in decimal. Takes care of special cases of the
486 -- largest negative number, and possible long integer output.
487 -- If Modular is True, output Uint as an unsigned C integer.
488
489 procedure Write_Unconstrained_Array_Prefix (N : Node_Id);
490 -- Given an unconstrained array expression N, write a reference to this
491 -- array, ready to be used as part of indexing or slicing this array.
492
493 procedure Write_Ureal_Col_Check (U : Ureal);
494 -- Write Ureal with column checks and a possible initial Write_Indent (to
495 -- get new line) if current line is too full.
496
497 procedure db (S : String; N : Int);
498 pragma Warnings (Off, db);
499 -- Debugging output, given string and integer value
500
501 type Header_Num is range 1 .. 4096;
502
503 function Hash (N : Node_Id) return Header_Num;
504 -- Simple Hash function for Node_Ids
505
506 package Enclosing_Subp_Table is new Simple_HTable
507 (Header_Num => Header_Num,
508 Element => Entity_Id,
509 No_Element => Empty,
510 Key => Node_Id,
511 Hash => Hash,
512 Equal => "=");
513 -- Hash table of entities, to record the enclosing function on which the
514 -- backend declares each entity.
515
516 package Entity_Table is new Simple_HTable
517 (Header_Num => Header_Num,
518 Element => Boolean,
519 No_Element => False,
520 Key => Node_Id,
521 Hash => Hash,
522 Equal => "=");
523 -- Hash table of entities, to record which entity has been dumped already
524
525 package Elaboration_Table is new Table.Table
526 (Table_Component_Type => Node_Id,
527 Table_Index_Type => Nat,
528 Table_Low_Bound => 1,
529 Table_Initial => 1024,
530 Table_Increment => 100,
531 Table_Name => "Elaboration_Table");
532 -- Table of statements part of the current elaboration procedure
533
534 package Macro_Table is new Table.Table
535 (Table_Component_Type => Node_Id,
536 Table_Index_Type => Nat,
537 Table_Low_Bound => 1,
538 Table_Initial => 512,
539 Table_Increment => 100,
540 Table_Name => "Macro_Table");
541 -- Table of macros part of the current scope
542
543 procedure Register_Entity (E : Entity_Id);
544 -- Register E in Enclosing_Subp_Table and Entity_Table
545
546 -------------------------------
547 -- Activation Record Support --
548 -------------------------------
549
550 -- Routines which facilitate handling the activation record of unnested
551 -- subprograms.
552
553 package AREC_Support is
554 function ARECnU (Subp_Id : Entity_Id) return Node_Id;
555 -- Return the uplink component of the given subprogram
556
557 function ARECnF (Subp_Id : Entity_Id) return Node_Id;
558 -- Return the extra formal that contains the pointer to the activation
559 -- record for uplevel references of the given subprogram.
560
561 function AREC_Entity (N : Node_Id) return Entity_Id;
562 -- Given an N_Identifier node N which references a field of an
563 -- activation record, return the entity of the corresponding formal.
564
565 function AREC_Subprogram (Formal : Entity_Id) return Entity_Id;
566 -- Return the subprogram that has a field in its activation record to
567 -- pass Formal to its nested subprograms.
568
569 function Get_AREC_Field (N : Node_Id) return Node_Id;
570 -- Given the AREC reference N return the AREC field
571
572 function Is_AREC_Reference (N : Node_Id) return Boolean;
573 -- Return True if N is a reference to an AREC field
574
575 procedure Write_Up_Level_Formal_Reference
576 (Subp : Entity_Id;
577 Formal : Entity_Id);
578 -- Write code that climbs through the activation record of the enclosing
579 -- subprograms and references the pointer to the fat pointer Formal
580 -- parameter of Subp.
581 end AREC_Support;
582 use AREC_Support;
583
584 ---------------------------
585 -- Back_End_Scopes_Stack --
586 ---------------------------
587
588 -- Stack associated with the generated code. Used to identify declarations
589 -- that requires the generation of extra scopes in order to generate C90
590 -- compliant code, since the front-end routine Insert_Actions may insert
591 -- temporaries in statement lists and C90 does not accept mixing
592 -- declarations and statements.
593
594 package Back_End_Scopes_Stack is
595 Extra_Scopes_Allowed : Boolean := True;
596 -- Enable/disable the ability to create extra scopes
597
598 procedure Open_Scope (With_Block : Boolean := True);
599 -- Make new scope stack entry in the top of the scopes stack and output
600 -- character '{' if With_Block is True. The new scope is enabled to
601 -- start processing declarations; it must be disabled by the caller
602 -- invoking the routine Set_In_Statements when it starts generating
603 -- code for the statements of this scope.
604
605 procedure Open_Extra_Scope;
606 -- Check if an extra scope is needed, and if true then output '{',
607 -- push a new scope stack entry, and mark it as extra scope.
608
609 procedure Close_Scope;
610 -- Remove from the top of the stack all the entries of inner extra
611 -- scopes (if any) and the first non-extra scope. Output '}' for
612 -- each closed scope that was opened with With_Block set to True.
613
614 procedure Close_Scope (Scop_Id : Nat);
615 -- Remove from the top of the stack all the entries of inner extra
616 -- scopes (if any) until the scope Scop_Id is removed from the stack.
617 -- Output '}' for each closed scope that was opened with With_Blocks
618 -- set to True.
619
620 function Current_Scope_Id return Nat;
621 -- Return the id of the current scope
622
623 function In_Declarations return Boolean;
624 -- Return True if we are processing the declarations of the scope in
625 -- the top of the stack.
626
627 procedure Set_In_Statements;
628 -- Remember in the top of the stack entry that we are processing its
629 -- declarations.
630 private
631 procedure Write_Scope_Stack;
632 -- For debugging purposes
633
634 procedure wss renames Write_Scope_Stack;
635 pragma Export (Ada, wss);
636 end Back_End_Scopes_Stack;
637 use Back_End_Scopes_Stack;
638
639 -----------------------------
640 -- Back_End_Itypes_Support --
641 -----------------------------
642
643 -- This package provides support to the back end to define extra itypes
644 -- not available in the tree. Currently it is used to generate an extra
645 -- itype associated with subprogram formals whose type is an access to
646 -- an unconstrained multidimensional array type (for unidimensional array
647 -- types this extra itype is not needed because the formal is defined as
648 -- a pointer to the component type).
649
650 package Back_End_Itypes_Support is
651 procedure Declare_Back_End_Itypes (Subp_Id : Entity_Id);
652 -- Declare back-end itypes associated with the formals of a subprogram
653 -- whose type is an access to a multidimensional unconstrained array
654
655 function Has_Back_End_AREC_Itype (E : Entity_Id) return Boolean;
656 -- Return True if E has an extra back-end AREC itype
657
658 function Has_Back_End_Itype (E : Entity_Id) return Boolean;
659 -- Return True if E has an extra back-end itype
660
661 procedure Write_Back_End_Itype_Id (E : Entity_Id);
662 -- Output the identifier of the back-end itype of E
663 end Back_End_Itypes_Support;
664 use Back_End_Itypes_Support;
665
666 --------------------------
667 -- Fat_Pointers_Support --
668 --------------------------
669
670 package Fat_Pointers_Support is
671 In_Fatptr_Constructor_Call : Boolean := False;
672 -- True if we are generating code invoking a fatptr constructor
673
674 function Has_Fat_Pointer (Typ : Entity_Id) return Boolean;
675 -- Return True if Typ is an unconstrained array type or an access to an
676 -- unconstrained array type.
677
678 function Is_Array_Formal (N : Node_Id) return Boolean;
679 function Is_Constrained_Array_Type (E : Entity_Id) return Boolean;
680 function Is_Unconstrained_Array_Formal (N : Node_Id) return Boolean;
681 function Is_Unconstrained_Array_Type (E : Entity_Id) return Boolean;
682 function Is_Unidimensional_Array_Type (E : Entity_Id) return Boolean;
683
684 procedure Write_Fatptr_Bounds (Expr : Node_Id; Typ : Entity_Id);
685 -- Output the low and high bounds of all the dimensions of the array
686 -- Expr separated by commas: {low-bound-N ,high-bound-N}
687
688 procedure Write_Fatptr_Compare (Lhs : Node_Id; Rhs : Node_Id);
689 -- Output code which compares the fat pointers associated with Lhs and
690 -- Rhs expressions. The comparison of fat pointers with constrained
691 -- arrays is supported.
692
693 procedure Write_Fatptr_Declare (Array_Type : Entity_Id);
694 -- Output the typedef declaration of a multidimensional unconstrained
695 -- array types.
696
697 procedure Write_Fatptr_Dereference;
698 -- Output a dereference of the fat pointer contents (i.e. ".all")
699
700 procedure Write_Fatptr_Indexed_Component (N : Node_Id);
701 -- N is an explicit dereference of a multidimensional unconstrained
702 -- array type. Output code which displaces the pointer to reference the
703 -- array element.
704
705 procedure Write_Fatptr_First (Array_Type : Entity_Id; Dimension : Pos);
706 procedure Write_Fatptr_Last (Array_Type : Entity_Id; Dimension : Pos);
707 -- Output a reference to the fat pointer field holding the value of the
708 -- First/Last Dimension of Array_Type.
709
710 procedure Write_Number_Of_Components
711 (Fatptr : Node_Id;
712 Array_Type : Entity_Id;
713 Dimension : Nat := 0);
714 -- Output code which computes the number of components of Array_Type
715 -- in the given Dimension. This routine is commonly used to generate
716 -- code which displaces the pointer to the base of an array to point
717 -- to a given indexed component. For example, for an array of 3x4x2,
718 -- the output generated for dimension 1 computes 4x2=8, for dimension
719 -- 2 computes 2, and for dimension 3 generates no output. Therefore,
720 -- it can be used to compute the total number of elements of an array
721 -- passing the value Dimension = 0.
722
723 procedure Write_Fatptr_Init
724 (Expr : Node_Id;
725 Typ : Entity_Id;
726 Use_Aggregate : Boolean := False);
727 -- Output code which initializes the fat pointer associated with Typ
728 -- using Expr. For unidimensional unconstrained arrays a call to the
729 -- constructor function is generated (unless Use_Aggregate is True);
730 -- for multidimensional unconstrained arrays an aggregate is generated.
731
732 procedure Write_Fatptr_Name (Array_Type : Entity_Id);
733 -- Output the name of the fatptr typedef associated with the given
734 -- unconstrained array type.
735 end Fat_Pointers_Support;
736 use Fat_Pointers_Support;
737
738 --------------------
739 -- Itypes_Support --
740 --------------------
741
742 package Itypes_Support is
743 procedure Check_No_Delayed_Itype_Decls;
744 -- Check that there are no pending itypes to output
745
746 procedure Dump_Delayed_Itype_Decls;
747 -- Output delayed derived itype declarations
748
749 procedure Register_Delayed_Itype_Decl (E : Entity_Id);
750 -- Register derived itypes whose declaration cannot be output because
751 -- their parent type has not been declared.
752
753 procedure Write_Itypes_In_Subtree (N : Entity_Id);
754 -- Write all the itypes defined in the subtree N which have not been
755 -- written yet.
756 end Itypes_Support;
757 use Itypes_Support;
758
759 -------------------------------
760 -- Activation Record Support --
761 -------------------------------
762
763 package body AREC_Support is
764
765 ------------
766 -- ARECnF --
767 ------------
768
769 function ARECnF (Subp_Id : Entity_Id) return Node_Id is
770 begin
771 return Subps.Table (Subp_Index (Subp_Id)).ARECnF;
772 end ARECnF;
773
774 ------------
775 -- ARECnU --
776 ------------
777
778 function ARECnU (Subp_Id : Entity_Id) return Node_Id is
779 begin
780 return Subps.Table (Subp_Index (Subp_Id)).ARECnU;
781 end ARECnU;
782
783 -----------------
784 -- AREC_Entity --
785 -----------------
786
787 function AREC_Entity (N : Node_Id) return Entity_Id is
788 Subp : Entity_Id := Current_Subp_Entity;
789
790 begin
791 pragma Assert (Nkind (N) = N_Identifier);
792 loop
793 declare
794 J : constant SI_Type := UI_To_Int (Subps_Index (Subp));
795 Elmt : Elmt_Id;
796 STJ : Subp_Entry renames Subps.Table (J);
797
798 begin
799 if Present (STJ.Uents) then
800 Elmt := First_Elmt (STJ.Uents);
801
802 while Present (Elmt) loop
803 if Entity (N) = Activation_Record_Component (Node (Elmt))
804 then
805 return Node (Elmt);
806 end if;
807
808 Next_Elmt (Elmt);
809 end loop;
810 end if;
811 end;
812
813 exit when No (Enclosing_Subprogram (Subp));
814 Subp := Enclosing_Subprogram (Subp);
815 end loop;
816
817 return Empty;
818 end AREC_Entity;
819
820 ---------------------
821 -- AREC_Subprogram --
822 ---------------------
823
824 function AREC_Subprogram (Formal : Entity_Id) return Entity_Id is
825 Subp : Entity_Id := Current_Subp_Entity;
826
827 begin
828 pragma Assert (Is_Formal (Formal));
829 loop
830 declare
831 J : constant SI_Type := UI_To_Int (Subps_Index (Subp));
832 Elmt : Elmt_Id;
833 STJ : Subp_Entry renames Subps.Table (J);
834
835 begin
836 if Present (STJ.Uents) then
837 Elmt := First_Elmt (STJ.Uents);
838
839 while Present (Elmt) loop
840 if Node (Elmt) = Formal then
841 return Subp;
842 end if;
843
844 Next_Elmt (Elmt);
845 end loop;
846 end if;
847 end;
848
849 exit when No (Enclosing_Subprogram (Subp));
850 Subp := Enclosing_Subprogram (Subp);
851 end loop;
852
853 return Empty;
854 end AREC_Subprogram;
855
856 --------------------
857 -- Get_AREC_Field --
858 --------------------
859
860 function Get_AREC_Field (N : Node_Id) return Node_Id is
861 begin
862 pragma Assert (Is_AREC_Reference (N));
863 return First (Expressions (N));
864 end Get_AREC_Field;
865
866 -----------------------
867 -- Is_AREC_Reference --
868 -----------------------
869
870 function Is_AREC_Reference (N : Node_Id) return Boolean is
871 Typ : constant Entity_Id := Etype (N);
872 Full_Typ : Entity_Id;
873 Expr : Node_Id;
874 Pref : Node_Id;
875
876 begin
877 if Is_Access_Type (Typ) then
878 Full_Typ := Get_Full_View (Designated_Type (Typ));
879 else
880 Full_Typ := Get_Full_View (Typ);
881 end if;
882
883 if Nkind (N) = N_Attribute_Reference
884 and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Deref
885 and then Is_Array_Type (Full_Typ)
886 and then Nkind (First (Expressions (N))) = N_Selected_Component
887 then
888 Expr := First (Expressions (N));
889
890 -- Locate the ultimate prefix
891
892 Pref := Prefix (Expr);
893 while Nkind_In (Pref, N_Explicit_Dereference,
894 N_Selected_Component)
895 loop
896 Pref := Prefix (Pref);
897 end loop;
898
899 if Nkind (Pref) = N_Identifier
900 and then Entity (Pref) = ARECnF (Current_Subp_Entity)
901 and then Present (AREC_Entity (Selector_Name (Expr)))
902 then
903 return True;
904 end if;
905 end if;
906
907 return False;
908 end Is_AREC_Reference;
909
910 -------------------------------------
911 -- Write_Up_Level_Formal_Reference --
912 -------------------------------------
913
914 procedure Write_Up_Level_Formal_Reference
915 (Subp : Entity_Id;
916 Formal : Entity_Id)
917 is
918 procedure Write_Up_Level_AREC_Access
919 (Current_Subp : Entity_Id;
920 Enclosing_Subp : Entity_Id);
921 -- Output code that climbs through the activation records from
922 -- Current_Subp to Enclosing_Subp.
923
924 --------------------------------
925 -- Write_Up_Level_AREC_Access --
926 --------------------------------
927
928 procedure Write_Up_Level_AREC_Access
929 (Current_Subp : Entity_Id;
930 Enclosing_Subp : Entity_Id)
931 is
932 begin
933 if Get_Level (Enclosing_Subp, Current_Subp) > 1 then
934 declare
935 Subp_Id : Entity_Id := Enclosing_Subprogram (Current_Subp);
936
937 begin
938 while Subp_Id /= Enclosing_Subp loop
939 Write_Id (ARECnU (Subp_Id));
940 Write_Str ("->");
941
942 Subp_Id := Enclosing_Subprogram (Subp_Id);
943 end loop;
944 end;
945 end if;
946 end Write_Up_Level_AREC_Access;
947
948 -- Start of processing for Write_Up_Level_Formal_Reference
949
950 begin
951 -- Generate
952 -- (*((_fatptr_UNCarray *) ARECnF->{ARECnU->})).
953
954 Write_Str ("(*((");
955 Write_Fatptr_Name (Get_Full_View (Etype (Formal)));
956 Write_Str (" *) ");
957
958 Write_Id (ARECnF (Subp));
959 Write_Str ("->");
960
961 Write_Up_Level_AREC_Access
962 (Current_Subp => Current_Subp_Entity,
963 Enclosing_Subp => AREC_Subprogram (Formal));
964
965 Write_Id (Formal);
966 Write_Str ("))");
967 end Write_Up_Level_Formal_Reference;
968 end AREC_Support;
969
970 ---------------------------
971 -- Back_End_Scopes_Stack --
972 ---------------------------
973
974 package body Back_End_Scopes_Stack is
975 Debug_Extra_Scope_Id : Int := -1;
976 -- Initialized to 0 to associate an Id to the extra scopes and output
977 -- C comments which facilitate seeing the locations in which the extra
978 -- scopes are opened/closed in the generated C file. Initialized to -1
979 -- to disable such extra output.
980
981 type Scope_Stack_Entry is record
982 Extra_Scope_Id : Nat;
983 -- For extra output
984
985 In_Declarations : Boolean;
986 -- True when we are processing declarations of this scope
987
988 Is_Extra_Scope : Boolean;
989 -- True when this scope was not generated by the front end
990
991 Last_Macro_Index : Nat;
992 -- Value of Macro_Table.Last when the scope is opened. Used to
993 -- undefine the macros defined in this scope and restore this
994 -- value when the scope is closed.
995
996 With_Block : Boolean;
997 -- True if opening this scope forces the output of '{' and closing
998 -- it forces the output of '}'
999 end record;
1000
1001 package Scope_Stack is new Table.Table (
1002 Table_Component_Type => Scope_Stack_Entry,
1003 Table_Index_Type => Nat,
1004 Table_Low_Bound => 1,
1005 Table_Initial => 128,
1006 Table_Increment => 100,
1007 Table_Name => "Cprint.Scope_Stack");
1008
1009 -----------------
1010 -- Close_Scope --
1011 -----------------
1012
1013 procedure Close_Scope is
1014 begin
1015 -- Exit from all the extra scopes
1016
1017 while Scope_Stack.Table (Scope_Stack.Last).Is_Extra_Scope loop
1018 Write_Indent;
1019 Write_Char ('}');
1020 Indent_End;
1021
1022 if Debug_Extra_Scope_Id >= 0 then
1023 Write_Str (" /* Extra scope ");
1024 Write_Int (Scope_Stack.Table (Scope_Stack.Last).Extra_Scope_Id);
1025 Write_Str (" */");
1026 Write_Indent;
1027 end if;
1028
1029 Scope_Stack.Decrement_Last;
1030 end loop;
1031
1032 declare
1033 SST : Scope_Stack_Entry renames
1034 Scope_Stack.Table (Scope_Stack.Last);
1035
1036 begin
1037 if SST.With_Block then
1038 Write_Char ('}');
1039
1040 for J in reverse SST.Last_Macro_Index + 1 .. Macro_Table.Last
1041 loop
1042 Write_Indent_Str ("#undef ");
1043 Write_Id (Macro_Table.Table (J));
1044 end loop;
1045
1046 Macro_Table.Set_Last (SST.Last_Macro_Index);
1047 end if;
1048 end;
1049
1050 -- And finally exit from the current scope
1051
1052 Scope_Stack.Decrement_Last;
1053 end Close_Scope;
1054
1055 -----------------
1056 -- Close_Scope --
1057 -----------------
1058
1059 procedure Close_Scope (Scop_Id : Nat) is
1060 begin
1061 loop
1062 Close_Scope;
1063 exit when Scope_Stack.Last < Scop_Id;
1064 end loop;
1065 end Close_Scope;
1066
1067 ----------------------
1068 -- Current_Scope_Id --
1069 ----------------------
1070
1071 function Current_Scope_Id return Nat is
1072 begin
1073 return Scope_Stack.Last;
1074 end Current_Scope_Id;
1075
1076 ---------------------
1077 -- In_Declarations --
1078 ---------------------
1079
1080 function In_Declarations return Boolean is
1081 begin
1082 return Scope_Stack.Table (Scope_Stack.Last).In_Declarations;
1083 end In_Declarations;
1084
1085 ----------------
1086 -- Open_Scope --
1087 ----------------
1088
1089 procedure Open_Scope (With_Block : Boolean := True) is
1090 C : constant Character := Last_Char;
1091 begin
1092 Scope_Stack.Increment_Last;
1093
1094 declare
1095 SST : Scope_Stack_Entry renames
1096 Scope_Stack.Table (Scope_Stack.Last);
1097
1098 begin
1099 SST.Extra_Scope_Id := 0;
1100 SST.In_Declarations := True;
1101 SST.Is_Extra_Scope := False;
1102 SST.Last_Macro_Index := Macro_Table.Last;
1103 SST.With_Block := With_Block;
1104
1105 if With_Block then
1106 if C = ';' or C = '}' or C = ASCII.NUL then
1107 Write_Indent;
1108 end if;
1109
1110 Write_Char ('{');
1111 end if;
1112 end;
1113 end Open_Scope;
1114
1115 ----------------------
1116 -- Open_Extra_Scope --
1117 ----------------------
1118
1119 procedure Open_Extra_Scope is
1120 begin
1121 -- Check cases in which there is no need to create the extra scope
1122
1123 if not Extra_Scopes_Allowed
1124 or else Library_Level
1125 or else Last_Char = '{'
1126 then
1127 return;
1128 end if;
1129
1130 Open_Scope;
1131 Scope_Stack.Table (Scope_Stack.Last).Is_Extra_Scope := True;
1132
1133 if Debug_Extra_Scope_Id >= 0 then
1134 Debug_Extra_Scope_Id := Debug_Extra_Scope_Id + 1;
1135
1136 Write_Str (" /* Extra scope ");
1137 Write_Int (Debug_Extra_Scope_Id);
1138 Write_Str (" */");
1139
1140 Scope_Stack.Table (Scope_Stack.Last).Extra_Scope_Id :=
1141 Debug_Extra_Scope_Id;
1142 end if;
1143
1144 Indent_Begin;
1145 end Open_Extra_Scope;
1146
1147 -----------------------
1148 -- Set_In_Statements --
1149 ------------------------
1150
1151 procedure Set_In_Statements is
1152 begin
1153 Scope_Stack.Table (Scope_Stack.Last).In_Declarations := False;
1154 end Set_In_Statements;
1155
1156 -----------------------
1157 -- Write_Scope_Stack --
1158 -----------------------
1159
1160 procedure Write_Scope_Stack is
1161 begin
1162 Write_Eol;
1163 Write_Str ("---------- Scope_Stack");
1164 Write_Eol;
1165
1166 for J in 1 .. Scope_Stack.Last loop
1167 if Scope_Stack.Table (J).Is_Extra_Scope then
1168 Write_Char ('*');
1169 else
1170 Write_Char (' ');
1171 end if;
1172
1173 Write_Int (J);
1174 Write_Char (':');
1175
1176 if Scope_Stack.Table (J).In_Declarations then
1177 Write_Str ("In_Decl");
1178 else
1179 Write_Str ("In_Stmts");
1180 end if;
1181
1182 if Scope_Stack.Table (J).With_Block then
1183 Write_Str (" with block");
1184 end if;
1185
1186 if Scope_Stack.Table (J).Is_Extra_Scope then
1187 Write_Str (" (Extra_Scope_Id = ");
1188 Write_Int (Scope_Stack.Table (J).Extra_Scope_Id);
1189 Write_Char (')');
1190 end if;
1191
1192 Write_Eol;
1193 end loop;
1194 end Write_Scope_Stack;
1195 end Back_End_Scopes_Stack;
1196
1197 -----------------------------
1198 -- Back_End_Itypes_Support --
1199 -----------------------------
1200
1201 package body Back_End_Itypes_Support is
1202 Entities_With_Back_End_Itype : Elist_Id := No_Elist;
1203 Entities_With_Back_End_AREC_Itype : Elist_Id := No_Elist;
1204
1205 procedure Register_Entity_With_Back_End_AREC_Itype (E : Entity_Id);
1206 -- Register E in the list of entities with extra AREC back-end itype
1207
1208 procedure Register_Entity_With_Back_End_Itype (E : Entity_Id);
1209 -- Register E in the list of entities with extra back-end itype
1210
1211 -----------------------------
1212 -- Declare_Back_End_Itypes --
1213 -----------------------------
1214
1215 procedure Declare_Back_End_Itypes (Subp_Id : Entity_Id) is
1216 function Back_End_Itypes_Needed return Boolean;
1217 -- Return True if Subp_Id needs back-end itypes
1218
1219 function Back_End_Itype_Needed (Formal : Entity_Id) return Boolean;
1220 -- Return True if Formal requires a back-end itype
1221
1222 procedure Declare_Itype (Formal : Node_Id; Typ : Entity_Id);
1223 -- Output the typedef which would correspond with the itype of an
1224 -- access to an unconstrained multidimensional array type.
1225
1226 procedure Declare_AREC_Itype (Subp : Entity_Id; Formal : Entity_Id);
1227 -- Output the typedef which would correspond with the itype of the
1228 -- unconstrained multidimensional array type Formal of the enclosing
1229 -- subprogram Subp.
1230
1231 ---------------------------
1232 -- Back_End_Itype_Needed --
1233 ---------------------------
1234
1235 function Back_End_Itype_Needed (Formal : Entity_Id) return Boolean is
1236 begin
1237 return
1238 Is_Access_Type (Etype (Formal))
1239 and then
1240 Is_Unconstrained_Array_Type
1241 (Get_Full_View (Designated_Type (Etype (Formal))))
1242 and then not
1243 Is_Unidimensional_Array_Type
1244 (Get_Full_View (Designated_Type (Etype (Formal))));
1245 end Back_End_Itype_Needed;
1246
1247 ----------------------------
1248 -- Back_End_Itypes_Needed --
1249 ----------------------------
1250
1251 function Back_End_Itypes_Needed return Boolean is
1252 Formal : Node_Id;
1253
1254 begin
1255 Formal := First_Formal_With_Extras (Subp_Id);
1256 while Present (Formal) loop
1257 if Back_End_Itype_Needed (Formal) then
1258 return True;
1259 end if;
1260
1261 Next_Formal_With_Extras (Formal);
1262 end loop;
1263
1264 -- For nested procedures check if the enclosing subprograms need
1265 -- back-end itypes for unconstrained array types.
1266
1267 declare
1268 E : Entity_Id;
1269 Elmt : Elmt_Id;
1270 Subp : Entity_Id;
1271 Subp_Idx : SI_Type;
1272
1273 begin
1274 Subp := Enclosing_Subprogram (Current_Subp_Entity);
1275 while Present (Subp) loop
1276 Subp_Idx := UI_To_Int (Subps_Index (Subp));
1277
1278 if Subp_Idx > 0
1279 and then Present (Subps.Table (Subp_Idx).Uents)
1280 then
1281 Elmt := First_Elmt (Subps.Table (Subp_Idx).Uents);
1282 while Present (Elmt) loop
1283 E := Node (Elmt);
1284
1285 if Is_Unconstrained_Array_Type
1286 (Get_Full_View (Etype (E)))
1287 then
1288 return True;
1289 end if;
1290
1291 Next_Elmt (Elmt);
1292 end loop;
1293 end if;
1294
1295 Subp := Enclosing_Subprogram (Subp);
1296 end loop;
1297 end;
1298
1299 return False;
1300 end Back_End_Itypes_Needed;
1301
1302 ------------------------
1303 -- Declare_AREC_Itype --
1304 ------------------------
1305
1306 procedure Declare_AREC_Itype (Subp : Entity_Id; Formal : Entity_Id) is
1307 Typ : constant Entity_Id := Get_Full_View (Etype (Formal));
1308
1309 begin
1310 Write_Indent;
1311
1312 -- Generate
1313 -- typedef <Component_Type> itypeId
1314 -- [(last[1]-first[1]) + 1]
1315 -- [(last[2]-first[2]) + 1]
1316 -- ...
1317
1318 Write_Indent;
1319 Write_Str ("typedef ");
1320 Write_Id (Component_Type (Typ));
1321 Write_Char (' ');
1322 Write_Id (Actual_Subtype (Formal));
1323
1324 declare
1325 Idx : Pos := 1;
1326 Ind : Node_Id := First_Index (Typ);
1327
1328 begin
1329 while Present (Ind) loop
1330 Write_Str_Col_Check ("[(");
1331 Write_Up_Level_Formal_Reference (Subp, Formal);
1332 Write_Char ('.');
1333 Write_Fatptr_Last (Typ, Idx);
1334
1335 Write_Str_Col_Check (" - ");
1336
1337 Write_Up_Level_Formal_Reference (Subp, Formal);
1338 Write_Char ('.');
1339 Write_Fatptr_First (Typ, Idx);
1340
1341 Write_Str_Col_Check (") + 1]");
1342
1343 Idx := Idx + 1;
1344 Next_Index (Ind);
1345 end loop;
1346
1347 Write_Char (';');
1348 end;
1349
1350 -- Remember that this entity is defined
1351
1352 Register_Entity_With_Back_End_AREC_Itype (Actual_Subtype (Formal));
1353 end Declare_AREC_Itype;
1354
1355 -------------------
1356 -- Declare_Itype --
1357 -------------------
1358
1359 procedure Declare_Itype (Formal : Node_Id; Typ : Entity_Id) is
1360 begin
1361 -- Generate
1362 -- typedef <Component_Type> itypeId
1363 -- [(last[1]-first[1]) + 1]
1364 -- [(last[2]-first[2]) + 1]
1365 -- ...
1366
1367 Write_Indent;
1368 Write_Str ("typedef ");
1369 Write_Id (Component_Type (Typ));
1370 Write_Char (' ');
1371 Write_Back_End_Itype_Id (Formal);
1372
1373 declare
1374 Idx : Pos := 1;
1375 Ind : Node_Id := First_Index (Typ);
1376
1377 begin
1378 while Present (Ind) loop
1379 Write_Str_Col_Check ("[(");
1380 Write_Id (Formal);
1381
1382 if Pass_Pointer (Formal) then
1383 Write_Str ("->");
1384 else
1385 Write_Char ('.');
1386 end if;
1387
1388 Write_Fatptr_Last (Typ, Idx);
1389 Write_Str_Col_Check (" - ");
1390 Write_Id (Formal);
1391
1392 if Pass_Pointer (Formal) then
1393 Write_Str ("->");
1394 else
1395 Write_Char ('.');
1396 end if;
1397
1398 Write_Fatptr_First (Typ, Idx);
1399 Write_Str_Col_Check (") + 1]");
1400
1401 Idx := Idx + 1;
1402 Next_Index (Ind);
1403 end loop;
1404
1405 Write_Char (';');
1406 end;
1407 end Declare_Itype;
1408
1409 -- Local variables
1410
1411 Formal : Node_Id;
1412
1413 -- Start of processing for Declare_Back_End_Itypes
1414
1415 begin
1416 if not Back_End_Itypes_Needed then
1417 return;
1418 end if;
1419
1420 Indent_Begin;
1421
1422 -- Declare itypes associated with the formals of Subp_Id
1423
1424 Formal := First_Formal_With_Extras (Subp_Id);
1425 while Present (Formal) loop
1426 if Back_End_Itype_Needed (Formal) then
1427 Register_Entity_With_Back_End_Itype (Formal);
1428 Declare_Itype (Formal,
1429 Get_Full_View (Designated_Type (Etype (Formal))));
1430 end if;
1431
1432 Next_Formal_With_Extras (Formal);
1433 end loop;
1434
1435 -- Declare itypes of unconstrained array type formals of enclosing
1436 -- subprograms.
1437
1438 declare
1439 E : Entity_Id;
1440 Elmt : Elmt_Id;
1441 Subp : Entity_Id;
1442 Subp_Idx : SI_Type;
1443
1444 begin
1445 Subp := Enclosing_Subprogram (Current_Subp_Entity);
1446 while Present (Subp) loop
1447 Subp_Idx := UI_To_Int (Subps_Index (Subp));
1448
1449 if Subp_Idx > 0
1450 and then Present (Subps.Table (Subp_Idx).Uents)
1451 then
1452 Elmt := First_Elmt (Subps.Table (Subp_Idx).Uents);
1453 while Present (Elmt) loop
1454 E := Node (Elmt);
1455
1456 if Is_Unconstrained_Array_Type
1457 (Get_Full_View (Etype (E)))
1458 then
1459 Declare_AREC_Itype
1460 (Subp => Subp_Id,
1461 Formal => E);
1462 end if;
1463
1464 Next_Elmt (Elmt);
1465 end loop;
1466 end if;
1467
1468 Subp := Enclosing_Subprogram (Subp);
1469 end loop;
1470 end;
1471
1472 Indent_End;
1473 end Declare_Back_End_Itypes;
1474
1475 -----------------------------
1476 -- Has_Back_End_AREC_Itype --
1477 -----------------------------
1478
1479 function Has_Back_End_AREC_Itype (E : Entity_Id) return Boolean is
1480 begin
1481 return Contains (Entities_With_Back_End_AREC_Itype, E);
1482 end Has_Back_End_AREC_Itype;
1483
1484 ------------------------
1485 -- Has_Back_End_Itype --
1486 ------------------------
1487
1488 function Has_Back_End_Itype (E : Entity_Id) return Boolean is
1489 begin
1490 return Contains (Entities_With_Back_End_Itype, E);
1491 end Has_Back_End_Itype;
1492
1493 ----------------------------------------------
1494 -- Register_Entity_With_Back_End_AREC_Itype --
1495 ----------------------------------------------
1496
1497 procedure Register_Entity_With_Back_End_AREC_Itype (E : Entity_Id) is
1498 begin
1499 Append_New_Elmt (E, Entities_With_Back_End_AREC_Itype);
1500 end Register_Entity_With_Back_End_AREC_Itype;
1501
1502 -----------------------------------------
1503 -- Register_Entity_With_Back_End_Itype --
1504 -----------------------------------------
1505
1506 procedure Register_Entity_With_Back_End_Itype (E : Entity_Id) is
1507 begin
1508 Append_New_Elmt (E, Entities_With_Back_End_Itype);
1509 end Register_Entity_With_Back_End_Itype;
1510
1511 -----------------------------
1512 -- Write_Back_End_Itype_Id --
1513 -----------------------------
1514
1515 procedure Write_Back_End_Itype_Id (E : Entity_Id) is
1516 pragma Assert (Has_Back_End_Itype (E));
1517 begin
1518 Write_Id (E);
1519 Write_Str ("_Ib");
1520 end Write_Back_End_Itype_Id;
1521 end Back_End_Itypes_Support;
1522
1523 --------------------------
1524 -- Fat_Pointers_Support --
1525 --------------------------
1526
1527 package body Fat_Pointers_Support is
1528 procedure Write_Attr_Index (Array_Type : Entity_Id; Dimension : Pos);
1529 -- Output the reference the Nth attribute of the fat pointer of a
1530 -- multidimensional array type.
1531
1532 procedure Write_Name_All;
1533 -- Output "all"
1534
1535 procedure Write_Name_First;
1536 -- Output "first"
1537
1538 procedure Write_Name_Last;
1539 -- Output "last"
1540
1541 ---------------------
1542 -- Has_Fat_Pointer --
1543 ---------------------
1544
1545 function Has_Fat_Pointer (Typ : Entity_Id) return Boolean is
1546 E : constant Entity_Id := Get_Full_View (Typ);
1547
1548 begin
1549 return Is_Unconstrained_Array_Type (E)
1550 or else
1551 (Is_Access_Type (E)
1552 and then Is_Array_Type (Get_Full_View (Designated_Type (E)))
1553 and then not
1554 Is_Constrained (Get_Full_View (Designated_Type (E))));
1555 end Has_Fat_Pointer;
1556
1557 ---------------------
1558 -- Is_Array_Formal --
1559 ---------------------
1560
1561 function Is_Array_Formal (N : Node_Id) return Boolean is
1562 Nod : Node_Id := N;
1563
1564 begin
1565 loop
1566 while Nkind_In (Nod, N_Attribute_Reference,
1567 N_Explicit_Dereference)
1568 loop
1569 Nod := Prefix (Nod);
1570 end loop;
1571
1572 if Nkind (Nod) in N_Has_Entity
1573 and then Present (Entity (Nod))
1574 and then Present (Renamed_Object (Get_Full_View (Entity (Nod))))
1575 then
1576 Nod := Renamed_Object (Get_Full_View (Entity (Nod)));
1577 end if;
1578
1579 exit when not Nkind_In (Nod, N_Attribute_Reference,
1580 N_Explicit_Dereference);
1581 end loop;
1582
1583 if Nkind (Nod) in N_Has_Entity
1584 and then Present (Entity (Nod))
1585 and then Is_Formal (Entity (Nod))
1586 then
1587 declare
1588 Typ : Entity_Id;
1589 begin
1590 Typ := Get_Full_View (Etype (Entity (Nod)));
1591
1592 if Is_Access_Type (Typ) then
1593 Typ := Get_Full_View (Designated_Type (Typ));
1594 end if;
1595
1596 return Is_Array_Type (Typ);
1597 end;
1598 else
1599 return False;
1600 end if;
1601 end Is_Array_Formal;
1602
1603 -------------------------------
1604 -- Is_Constrained_Array_Type --
1605 -------------------------------
1606
1607 function Is_Constrained_Array_Type (E : Entity_Id) return Boolean is
1608 begin
1609 return Is_Array_Type (E) and then Is_Constrained (E);
1610 end Is_Constrained_Array_Type;
1611
1612 -----------------------------------
1613 -- Is_Unconstrained_Array_Formal --
1614 -----------------------------------
1615
1616 function Is_Unconstrained_Array_Formal (N : Node_Id) return Boolean is
1617 begin
1618 return Is_Array_Formal (N) and then not Is_Constrained (Etype (N));
1619 end Is_Unconstrained_Array_Formal;
1620
1621 ---------------------------------
1622 -- Is_Unconstrained_Array_Type --
1623 ---------------------------------
1624
1625 function Is_Unconstrained_Array_Type (E : Entity_Id) return Boolean is
1626 begin
1627 return Is_Array_Type (E) and then not Is_Constrained (E);
1628 end Is_Unconstrained_Array_Type;
1629
1630 ----------------------------------
1631 -- Is_Unidimensional_Array_Type --
1632 ----------------------------------
1633
1634 function Is_Unidimensional_Array_Type (E : Entity_Id) return Boolean is
1635 Full_E : constant Entity_Id := Get_Full_View (E);
1636 begin
1637 return
1638 Is_Array_Type (Full_E)
1639 and then (No (First_Index (Full_E))
1640 or else No (Next_Index (First_Index (Full_E))));
1641 end Is_Unidimensional_Array_Type;
1642
1643 ----------------------
1644 -- Write_Attr_Index --
1645 ----------------------
1646
1647 procedure Write_Attr_Index (Array_Type : Entity_Id; Dimension : Pos) is
1648 begin
1649 if not Is_Unidimensional_Array_Type (Array_Type) then
1650 Write_Char ('[');
1651 Write_Int (Dimension - 1);
1652 Write_Char (']');
1653 end if;
1654 end Write_Attr_Index;
1655
1656 -------------------------
1657 -- Write_Fatptr_Bounds --
1658 -------------------------
1659
1660 procedure Write_Fatptr_Bounds (Expr : Node_Id; Typ : Entity_Id) is
1661 begin
1662 if Ekind (Typ) = E_String_Literal_Subtype then
1663 Write_Array_Bound (Expr, Low, 1);
1664 Write_Str (", ");
1665 Write_Array_Bound (Expr, High, 1);
1666
1667 else
1668 declare
1669 Idx : Nat := 1;
1670 Ind : Node_Id := First_Index (Typ);
1671
1672 begin
1673 while Present (Ind) loop
1674 Write_Array_Bound (Expr, Low, Idx);
1675 Write_Str (", ");
1676 Write_Array_Bound (Expr, High, Idx);
1677
1678 Idx := Idx + 1;
1679 Next_Index (Ind);
1680
1681 if Present (Ind) then
1682 Write_Str (", ");
1683 end if;
1684 end loop;
1685 end;
1686 end if;
1687 end Write_Fatptr_Bounds;
1688
1689 --------------------------
1690 -- Write_Fatptr_Compare --
1691 --------------------------
1692
1693 procedure Write_Fatptr_Compare (Lhs : Node_Id; Rhs : Node_Id) is
1694 Is_Access : Boolean := False;
1695
1696 procedure Write_Reference (N : Node_Id; Typ : Node_Id);
1697 -- Output a reference to N plus a dereference for fat pointers
1698
1699 ---------------------
1700 -- Write_Reference --
1701 ---------------------
1702
1703 procedure Write_Reference (N : Node_Id; Typ : Node_Id) is
1704 begin
1705 if Has_Fat_Pointer (Typ) then
1706 if Is_Access then
1707 Cprint_Node_Paren (N);
1708 else
1709 Cprint_Node (N);
1710 end if;
1711
1712 Write_Fatptr_Dereference;
1713 else
1714 Cprint_Node (N);
1715 end if;
1716 end Write_Reference;
1717
1718 -- Local variables
1719
1720 Lhs_Typ : Node_Id := Get_Full_View (Etype (Lhs));
1721 Rhs_Typ : Node_Id := Get_Full_View (Etype (Rhs));
1722
1723 -- Start of processing for Write_Fatptr_Compare
1724
1725 begin
1726 if Is_Access_Type (Lhs_Typ) then
1727 Lhs_Typ := Get_Full_View (Designated_Type (Lhs_Typ));
1728 Is_Access := True;
1729 end if;
1730
1731 if Is_Access_Type (Rhs_Typ) then
1732 Rhs_Typ := Get_Full_View (Designated_Type (Rhs_Typ));
1733 Is_Access := True;
1734 end if;
1735
1736 Write_Str_Col_Check ("(");
1737
1738 if Nkind (Rhs) = N_Null then
1739 Write_Reference (Lhs, Lhs_Typ);
1740 Write_Str (" == ");
1741 Write_Str ("NULL");
1742
1743 else
1744 -- Generate for access types:
1745 -- Lhs.all == Rhs.all
1746 -- && Lhs.first == Rhs.first
1747 -- && Lhs.last == Rhs.last
1748 --
1749 -- and for arrays:
1750 -- sizeof (Lhs) == sizeof(Rhs)
1751 -- && !memcmp(Lhs.all, Rhs.all, sizeof(...))
1752
1753 if Is_Access then
1754 Write_Reference (Lhs, Lhs_Typ);
1755 Write_Str (" == ");
1756 Write_Reference (Rhs, Rhs_Typ);
1757
1758 for Idx in 1 .. Number_Dimensions (Lhs_Typ) loop
1759 Write_Str_Col_Check (" && ");
1760 Cprint_Node (Lhs);
1761 Write_Str (".");
1762 Write_Fatptr_First (Lhs_Typ, Idx);
1763 Write_Str (" == ");
1764 Cprint_Node (Rhs);
1765 Write_Str (".");
1766 Write_Fatptr_First (Rhs_Typ, Idx);
1767 Write_Str_Col_Check (" && ");
1768 Cprint_Node (Lhs);
1769 Write_Str (".");
1770 Write_Fatptr_Last (Lhs_Typ, Idx);
1771 Write_Str (" == ");
1772 Cprint_Node (Rhs);
1773 Write_Str (".");
1774 Write_Fatptr_Last (Rhs_Typ, Idx);
1775 end loop;
1776
1777 else
1778 Output_Sizeof (Lhs);
1779 Write_Str_Col_Check (" == ");
1780 Output_Sizeof (Rhs);
1781 Write_Str_Col_Check (" && ");
1782
1783 Write_Str ("!memcmp(");
1784 Write_Reference (Lhs, Lhs_Typ);
1785 Write_Str (", ");
1786 Write_Reference (Rhs, Rhs_Typ);
1787 Write_Str (", ");
1788 Output_Sizeof (Lhs, Rhs);
1789 Write_Char (')');
1790 end if;
1791 end if;
1792
1793 Write_Char (')');
1794 end Write_Fatptr_Compare;
1795
1796 --------------------------
1797 -- Write_Fatptr_Declare --
1798 --------------------------
1799
1800 procedure Write_Fatptr_Declare (Array_Type : Entity_Id) is
1801 procedure Write_Array_Length (Length : Pos);
1802 -- Output the length of the array declaration
1803
1804 ------------------------
1805 -- Write_Array_Length --
1806 ------------------------
1807
1808 procedure Write_Array_Length (Length : Pos) is
1809 begin
1810 Write_Char ('[');
1811 Write_Int (Length);
1812 Write_Char (']');
1813 end Write_Array_Length;
1814
1815 -- Start of processing for Write_Fatptr_Declare
1816
1817 begin
1818 pragma Assert (Is_Array_Type (Array_Type)
1819 and then not Is_Unidimensional_Array_Type (Array_Type));
1820
1821 Write_Indent;
1822
1823 -- Generate:
1824
1825 -- typedef struct _<typeName> {
1826 -- <typeName> *all;
1827 -- integer_ptr_t first[N];
1828 -- integer_ptr_t last[N];
1829 -- } _fatptr_<typeName>;
1830
1831 Write_Str ("typedef struct _");
1832 Write_Id (Array_Type);
1833 Write_Str (" {");
1834
1835 Indent_Begin;
1836 Write_Indent;
1837
1838 Write_Id (Component_Type (Array_Type));
1839 Write_Str (" *");
1840 Write_Name_All;
1841 Write_Str (";");
1842
1843 Write_Indent;
1844 Write_Str ("integer_ptr_t ");
1845 Write_Name_First;
1846 Write_Array_Length (Number_Dimensions (Array_Type));
1847 Write_Char (';');
1848
1849 Write_Indent;
1850 Write_Str ("integer_ptr_t ");
1851 Write_Name_Last;
1852 Write_Array_Length (Number_Dimensions (Array_Type));
1853 Write_Char (';');
1854
1855 Indent_End;
1856 Write_Indent;
1857
1858 Write_Str ("} ");
1859 Write_Fatptr_Name (Array_Type);
1860 Write_Str (";");
1861 Write_Indent;
1862 end Write_Fatptr_Declare;
1863
1864 ------------------------------
1865 -- Write_Fatptr_Dereference --
1866 ------------------------------
1867
1868 procedure Write_Fatptr_Dereference is
1869 begin
1870 Write_Char ('.');
1871 Write_Name_All;
1872 end Write_Fatptr_Dereference;
1873
1874 ------------------------------------
1875 -- Write_Fatptr_Indexed_Component --
1876 ------------------------------------
1877
1878 procedure Write_Fatptr_Indexed_Component (N : Node_Id) is
1879 Pref : constant Node_Id := Ultimate_Expression (Prefix (N));
1880 Pref_Type : constant Entity_Id := Get_Full_View (Etype (Pref));
1881 Fatptr : constant Node_Id := Prefix (Pref);
1882
1883 begin
1884 pragma Assert
1885 (Nkind (N) = N_Indexed_Component
1886 and then Nkind (Pref) = N_Explicit_Dereference
1887 and then Is_Unconstrained_Array_Type (Pref_Type)
1888 and then not Is_Unidimensional_Array_Type (Pref_Type));
1889
1890 -- Generate code to dereference the resulting computed address
1891
1892 Write_Str ("(*("); -- Open parenthesis 1 & 2
1893
1894 -- In practice the following cast is currently not needed since the
1895 -- type of the pointer defined in the fat pointer struct associated
1896 -- with multidimensional arrays is a pointer to the component type,
1897 -- and the first component of the expression generated to compute
1898 -- the address of the indexed array component is precisely such fat
1899 -- pointer component (implicitly meaning in C that the arithmetic of
1900 -- C pointers will use such size to displace the pointer). However,
1901 -- we generate it to leave the code clear but also to facilitate the
1902 -- early detection of problems in case of changes in this area since
1903 -- the correct type of the pointer is essential to ensure that the
1904 -- resulting values computed by this routine are correct.
1905
1906 Write_Char ('(');
1907 Cprint_Node (Component_Type (Pref_Type));
1908 Write_Str ("*)");
1909
1910 -- The needed computation is simple: for each dimension generate code
1911 -- which displaces the pointer as many components as the number of
1912 -- components of each dimension multiplied by the index. As usual,
1913 -- given that in C arrays start at 0, the actual value of the index
1914 -- requires computing its distance to 'first.
1915
1916 Write_Char ('('); -- Open parenthesis 3
1917
1918 Cprint_Node (Fatptr);
1919 Write_Fatptr_Dereference;
1920
1921 declare
1922 Expr : Node_Id := First (Expressions (N));
1923 Idx : Pos := 1;
1924
1925 begin
1926 while Idx < Number_Dimensions (Pref_Type) loop
1927
1928 -- Generate:
1929 -- + (Expr - fatptr.first[idx]) * Number_Of_Components(Idx)
1930
1931 Write_Str_Col_Check (" + ");
1932
1933 Write_Char ('(');
1934 Cprint_Node (Expr);
1935 Write_Str_Col_Check (" - ");
1936 Cprint_Node (Fatptr);
1937 Write_Str (".");
1938 Write_Fatptr_First (Pref_Type, Idx);
1939 Write_Char (')');
1940
1941 Write_Str_Col_Check (" * ");
1942 Write_Number_Of_Components (Fatptr, Pref_Type, Idx);
1943
1944 Next (Expr);
1945 Idx := Idx + 1;
1946 end loop;
1947
1948 -- For the last index generate:
1949 -- + Expr - fatptr.first[n]
1950
1951 Write_Str_Col_Check (" + ");
1952 Cprint_Node (Expr);
1953 Write_Str_Col_Check (" - ");
1954 Cprint_Node (Fatptr);
1955 Write_Str (".");
1956 Write_Fatptr_First (Pref_Type, Idx);
1957 end;
1958
1959 Write_Str (")))"); -- Closing parenthesis 1, 2 & 3
1960 end Write_Fatptr_Indexed_Component;
1961
1962 ------------------------
1963 -- Write_Fatptr_First --
1964 ------------------------
1965
1966 procedure Write_Fatptr_First (Array_Type : Entity_Id; Dimension : Pos) is
1967 pragma Assert (Is_Unconstrained_Array_Type (Array_Type));
1968 begin
1969 Write_Name_First;
1970 Write_Attr_Index (Array_Type, Dimension);
1971 end Write_Fatptr_First;
1972
1973 -----------------------
1974 -- Write_Fatptr_Last --
1975 -----------------------
1976
1977 procedure Write_Fatptr_Last (Array_Type : Entity_Id; Dimension : Pos) is
1978 pragma Assert (Is_Unconstrained_Array_Type (Array_Type));
1979 begin
1980 Write_Name_Last;
1981 Write_Attr_Index (Array_Type, Dimension);
1982 end Write_Fatptr_Last;
1983
1984 --------------------------------
1985 -- Write_Number_of_Components --
1986 --------------------------------
1987
1988 procedure Write_Number_Of_Components
1989 (Fatptr : Node_Id;
1990 Array_Type : Entity_Id;
1991 Dimension : Nat := 0)
1992 is
1993 procedure Write_Fatptr_Length
1994 (Fatptr : Node_Id;
1995 Array_Type : Entity_Id;
1996 Dimension : Pos);
1997 -- Output code which computes the length of the array in the given
1998 -- dimension: Fatptr.last[dimension] - Fatptr.first[dimension] + 1
1999
2000 -------------------------
2001 -- Write_Fatptr_Length --
2002 -------------------------
2003
2004 procedure Write_Fatptr_Length
2005 (Fatptr : Node_Id;
2006 Array_Type : Entity_Id;
2007 Dimension : Pos)
2008 is
2009 begin
2010 Cprint_Node (Fatptr);
2011 Write_Str (".");
2012 Write_Fatptr_Last (Array_Type, Dimension);
2013
2014 Write_Str_Col_Check (" - ");
2015
2016 Cprint_Node (Fatptr);
2017 Write_Str (".");
2018 Write_Fatptr_First (Array_Type, Dimension);
2019
2020 Write_Str_Col_Check (" + 1");
2021 end Write_Fatptr_Length;
2022
2023 -- Local variables
2024
2025 Idx : Nat := 1;
2026 Ind : Node_Id := First_Index (Array_Type);
2027
2028 -- Start of processing for Write_Number_Of_Components
2029
2030 begin
2031 -- Locate the index of the given Dimension
2032
2033 while Idx <= Dimension loop
2034 Next_Index (Ind);
2035 Idx := Idx + 1;
2036 end loop;
2037
2038 -- Generate code which computes its number of components
2039
2040 while Idx <= Number_Dimensions (Array_Type) loop
2041 Write_Char ('(');
2042 Write_Fatptr_Length (Fatptr, Array_Type, Idx);
2043 Write_Char (')');
2044
2045 if Idx < Number_Dimensions (Array_Type) then
2046 Write_Str_Col_Check (" * ");
2047 end if;
2048
2049 Next_Index (Ind);
2050 Idx := Idx + 1;
2051 end loop;
2052 end Write_Number_Of_Components;
2053
2054 -----------------------
2055 -- Write_Fatptr_Init --
2056 -----------------------
2057
2058 procedure Write_Fatptr_Init
2059 (Expr : Node_Id;
2060 Typ : Entity_Id;
2061 Use_Aggregate : Boolean := False)
2062 is
2063 procedure Write_Array_Aggregate_Bounds (Expr : Node_Id);
2064 -- Output the low bound and high bound of all the dimensions of the
2065 -- type of Expr separated by commas:
2066 -- low-bound-1 {,low-bound-N} high-bound-1 {,high-bound-N}
2067
2068 procedure Write_Call_Fatptr_Constructor
2069 (Expr : Node_Id;
2070 Array_Type : Entity_Id);
2071 -- Generate a call to the constructor of Typ to initialize Expr
2072
2073 procedure Write_Fatptr_Aggregate
2074 (Expr : Node_Id;
2075 Array_Type : Entity_Id);
2076 -- Generate an aggregate of Typ to initialize Expr
2077
2078 ----------------------------------
2079 -- Write_Array_Aggregate_Bounds --
2080 ----------------------------------
2081
2082 procedure Write_Array_Aggregate_Bounds (Expr : Node_Id) is
2083 Typ : Node_Id;
2084
2085 begin
2086 Typ := Get_Full_View (Etype (Expr));
2087
2088 if Is_Access_Type (Typ) then
2089 Typ := Get_Full_View (Designated_Type (Typ));
2090 end if;
2091
2092 -- Initialize all the components of first[]
2093
2094 declare
2095 Idx : Nat := 1;
2096 Ind : Node_Id := First_Index (Typ);
2097
2098 begin
2099 while Present (Ind) loop
2100 Write_Array_Bound (Expr, Low, Idx);
2101 Write_Str (", ");
2102
2103 Idx := Idx + 1;
2104 Next_Index (Ind);
2105 end loop;
2106 end;
2107
2108 -- Initialize all the components of last[]
2109
2110 declare
2111 Idx : Nat := 1;
2112 Ind : Node_Id := First_Index (Typ);
2113
2114 begin
2115 while Present (Ind) loop
2116 Write_Array_Bound (Expr, High, Idx);
2117
2118 Idx := Idx + 1;
2119 Next_Index (Ind);
2120
2121 if Present (Ind) then
2122 Write_Str (", ");
2123 end if;
2124 end loop;
2125 end;
2126 end Write_Array_Aggregate_Bounds;
2127
2128 -----------------------------------
2129 -- Write_Call_Fatptr_Constructor --
2130 -----------------------------------
2131
2132 procedure Write_Call_Fatptr_Constructor
2133 (Expr : Node_Id;
2134 Array_Type : Entity_Id)
2135 is
2136 Close_Paren : Boolean := True;
2137 Expr_Typ : Entity_Id := Get_Full_View (Etype (Expr));
2138 Saved_Value : constant Boolean := In_Fatptr_Constructor_Call;
2139 U_Expr : constant Node_Id := Ultimate_Expression (Expr);
2140 U_Etyp : constant Entity_Id := Get_Full_View (Etype (U_Expr));
2141
2142 begin
2143 if Is_Access_Type (Expr_Typ) then
2144 Expr_Typ := Get_Full_View (Designated_Type (Expr_Typ));
2145 end if;
2146
2147 In_Fatptr_Constructor_Call := True;
2148
2149 Write_Str ("_fatptr_UNCarray_CONS ");
2150 Write_Str ("((void*)");
2151
2152 -- Null fat pointers are initialized with .all = NULL and all its
2153 -- bounds set to 0.
2154
2155 if Nkind (U_Expr) = N_Null then
2156 Write_Str ("NULL, ");
2157
2158 declare
2159 Ind : Node_Id := First_Index (Array_Type);
2160
2161 begin
2162 while Present (Ind) loop
2163 Write_Str ("0, 0");
2164 Next_Index (Ind);
2165
2166 if Present (Ind) then
2167 Write_Str (", ");
2168 end if;
2169 end loop;
2170 end;
2171
2172 elsif Nkind (U_Expr) = N_Allocator then
2173 Cprint_Node (U_Expr);
2174 Close_Paren := False;
2175
2176 elsif Nkind_In (Expr, N_Type_Conversion,
2177 N_Unchecked_Type_Conversion)
2178 then
2179 Cprint_Node (U_Expr);
2180
2181 if Has_Fat_Pointer (U_Etyp) then
2182 Write_Fatptr_Dereference;
2183 end if;
2184
2185 -- The bounds must be computed using the target type of the
2186 -- type conversion.
2187
2188 Write_Str (", ");
2189 Write_Fatptr_Bounds (Expr, Expr_Typ);
2190
2191 -- Common case
2192
2193 else
2194 Cprint_Node (Expr);
2195
2196 if Has_Fat_Pointer (Expr_Typ) then
2197 Write_Fatptr_Dereference;
2198 end if;
2199
2200 Write_Str (", ");
2201 Write_Fatptr_Bounds (Expr, Array_Type);
2202 end if;
2203
2204 if Close_Paren then
2205 Write_Str (")");
2206 end if;
2207
2208 In_Fatptr_Constructor_Call := Saved_Value;
2209 end Write_Call_Fatptr_Constructor;
2210
2211 ----------------------------
2212 -- Write_Fatptr_Aggregate --
2213 ----------------------------
2214
2215 procedure Write_Fatptr_Aggregate
2216 (Expr : Node_Id;
2217 Array_Type : Entity_Id)
2218 is
2219 U_Expr : constant Node_Id := Ultimate_Expression (Expr);
2220 U_Etyp : constant Entity_Id := Get_Full_View (Etype (U_Expr));
2221
2222 begin
2223 Write_Char ('(');
2224 Write_Fatptr_Name (Array_Type);
2225 Write_Char (')');
2226
2227 Write_Char ('{');
2228
2229 Write_Str ("(");
2230 Write_Id (Component_Type (Array_Type));
2231 Write_Str ("*) ");
2232
2233 if Nkind (U_Expr) = N_Null then
2234 Write_Str ("NULL");
2235
2236 elsif Nkind (U_Expr) = N_Allocator then
2237 Cprint_Node (U_Expr);
2238
2239 else
2240 Write_Str ("&");
2241 Cprint_Node (U_Expr);
2242
2243 if Has_Fat_Pointer (U_Etyp) then
2244 Write_Fatptr_Dereference;
2245 end if;
2246 end if;
2247
2248 Write_Str (", ");
2249
2250 -- The bounds must be computed using the type of the original
2251 -- expression.
2252
2253 Write_Array_Aggregate_Bounds (Expr);
2254 Write_Char ('}');
2255 end Write_Fatptr_Aggregate;
2256
2257 -- Local variable
2258
2259 Array_Type : Entity_Id;
2260
2261 -- Start of processing for Write_Fatptr_Init
2262
2263 begin
2264 if Is_Access_Type (Typ) then
2265 Array_Type := Designated_Type (Typ);
2266 else
2267 Array_Type := Typ;
2268 end if;
2269
2270 -- This routine must not be invoked with an attribute reference.
2271 -- Attribute_Reference() must be invoked by the caller (routine
2272 -- that takes care of invoking this one). The exception of this
2273 -- rule is attribute 'Deref since the use of this attribute in
2274 -- constrained array actuals may involve building a fat pointer
2275 -- using the type of the formal (cf. Cprint_Call).
2276
2277 pragma Assert (Nkind (Expr) /= N_Attribute_Reference
2278 or else
2279 Get_Attribute_Id (Attribute_Name (Expr)) = Attribute_Deref);
2280
2281 -- Ensure that it is correct to generate the code initializing a fat
2282 -- pointer.
2283
2284 pragma Assert (Is_Unconstrained_Array_Type (Array_Type));
2285
2286 -- Fat pointers of unidimensional arrays are initialized by means of
2287 -- the constructor to generate code compliant with C90.
2288
2289 if Is_Unidimensional_Array_Type (Array_Type)
2290 and then not Use_Aggregate
2291 then
2292 Write_Call_Fatptr_Constructor (Expr, Array_Type);
2293
2294 -- Fat pointers of multidimensional arrays are initialized by means
2295 -- of an aggregate.
2296
2297 else
2298 Write_Fatptr_Aggregate (Expr, Array_Type);
2299 end if;
2300 end Write_Fatptr_Init;
2301
2302 -----------------------
2303 -- Write_Fatptr_Name --
2304 -----------------------
2305
2306 procedure Write_Fatptr_Name (Array_Type : Entity_Id) is
2307 begin
2308 pragma Assert (Is_Unconstrained_Array_Type (Array_Type));
2309
2310 if Is_Unidimensional_Array_Type (Array_Type) then
2311 Write_Str ("_fatptr_UNCarray");
2312 else
2313 Write_Str ("_fatptr_");
2314 Cprint_Node (Array_Type, Declaration => True);
2315 end if;
2316 end Write_Fatptr_Name;
2317
2318 --------------------
2319 -- Write_Name_All --
2320 --------------------
2321
2322 procedure Write_Name_All is
2323 begin
2324 Write_Str ("all");
2325 end Write_Name_All;
2326
2327 ----------------------
2328 -- Write_Name_First --
2329 ----------------------
2330
2331 procedure Write_Name_First is
2332 begin
2333 Write_Str ("first");
2334 end Write_Name_First;
2335
2336 ---------------------
2337 -- Write_Name_Last --
2338 ---------------------
2339
2340 procedure Write_Name_Last is
2341 begin
2342 Write_Str ("last");
2343 end Write_Name_Last;
2344
2345 end Fat_Pointers_Support;
2346
2347 --------------------
2348 -- Itypes_Support --
2349 --------------------
2350
2351 package body Itypes_Support is
2352 Delayed_Itype_Decls : Elist_Id := No_Elist;
2353
2354 ----------------------------------
2355 -- Check_No_Delayed_Itype_Decls --
2356 ----------------------------------
2357
2358 procedure Check_No_Delayed_Itype_Decls is
2359 Elmt : Elmt_Id;
2360
2361 begin
2362 if Delayed_Itype_Decls /= No_Elist then
2363 Elmt := First_Elmt (Delayed_Itype_Decls);
2364 while Present (Elmt) loop
2365 Error_Msg_N ("unsupported type reference", Node (Elmt));
2366 Next_Elmt (Elmt);
2367 end loop;
2368 end if;
2369 end Check_No_Delayed_Itype_Decls;
2370
2371 ------------------------------
2372 -- Dump_Delayed_Itype_Decls --
2373 ------------------------------
2374
2375 procedure Dump_Delayed_Itype_Decls is
2376 Elmt : Elmt_Id;
2377 Itype : Entity_Id;
2378
2379 begin
2380 if No (Delayed_Itype_Decls) then
2381 return;
2382 end if;
2383
2384 Elmt := First_Elmt (Delayed_Itype_Decls);
2385 while Present (Elmt) loop
2386 Itype := Node (Elmt);
2387
2388 -- Ensure that its parent type has been output before generating
2389 -- the declaration of the Itype.
2390
2391 Dump_Type (Etype (Itype));
2392
2393 -- Cannot invoke here Dump_Type since it would append again Itype
2394 -- to the list of pending record subtypes thus entering into a
2395 -- never-ending loop. Hence we invoke directly Cprint_Declare().
2396
2397 Cprint_Declare (Itype);
2398
2399 Next_Elmt (Elmt);
2400 end loop;
2401
2402 Delayed_Itype_Decls := No_Elist;
2403 end Dump_Delayed_Itype_Decls;
2404
2405 ---------------------------------
2406 -- Register_Delayed_Itype_Decl --
2407 ---------------------------------
2408
2409 procedure Register_Delayed_Itype_Decl (E : Entity_Id) is
2410 begin
2411 Append_New_Elmt (E, Delayed_Itype_Decls);
2412 end Register_Delayed_Itype_Decl;
2413
2414 -----------------------------
2415 -- Write_Itypes_In_Subtree --
2416 -----------------------------
2417
2418 procedure Write_Itypes_In_Subtree (N : Node_Id) is
2419 function Search_Entities (N : Node_Id) return Traverse_Result;
2420 -- Subtree visitor which invokes Write_Itype with all the found
2421 -- entities.
2422
2423 procedure Write_Itype (Typ : Node_Id);
2424 -- Subsidiary of Search_Entities. If Typ is an Itype that has not
2425 -- been written yet, write it. If Typ is any other kind of entity
2426 -- or tree node, the call is ignored.
2427
2428 ---------------------
2429 -- Search_Entities --
2430 ---------------------
2431
2432 function Search_Entities (N : Node_Id) return Traverse_Result is
2433 Def_Id : constant Entity_Id :=
2434 Defining_Entity (N, Empty_On_Errors => True);
2435 begin
2436 if Present (Def_Id) then
2437 return Search_Entities (Def_Id);
2438 end if;
2439
2440 if Nkind (N) in N_Entity then
2441 Write_Itype (N);
2442 end if;
2443
2444 if Nkind (N) in N_Has_Etype then
2445 Write_Itype (Etype (N));
2446 end if;
2447
2448 return OK;
2449 end Search_Entities;
2450
2451 -----------------
2452 -- Write_Itype --
2453 -----------------
2454
2455 procedure Write_Itype (Typ : Node_Id) is
2456 begin
2457 if No (Typ)
2458 or else not Is_Itype (Typ)
2459 or else Entity_Table.Get (Typ)
2460 then
2461 return;
2462 end if;
2463
2464 -- Skip types depending on discriminants
2465
2466 if Size_Depends_On_Discriminant (Typ)
2467 or else (Is_Array_Type (Typ)
2468 and then Depends_On_Discriminant (First_Index (Typ)))
2469 then
2470 Register_Entity (Typ);
2471 return;
2472 end if;
2473
2474 pragma Assert (Nkind (Typ) in N_Entity);
2475 Cprint_Declare (Typ);
2476 end Write_Itype;
2477
2478 ------------------
2479 -- Write_Itypes --
2480 ------------------
2481
2482 procedure Write_Itypes is new Traverse_Proc (Search_Entities);
2483 -- Subtree visitor instantiation
2484
2485 -- Start of processing for Write_Itypes_In_Subtree
2486
2487 begin
2488 Write_Itypes (N);
2489 end Write_Itypes_In_Subtree;
2490 end Itypes_Support;
2491
2492 ----------------------
2493 -- Check_Definition --
2494 ----------------------
2495
2496 procedure Check_Definition (N : Node_Id; Error_Node : Node_Id := Empty) is
2497 procedure Check_Entity (E : Entity_Id);
2498 -- Check that entity E is already defined
2499
2500 procedure Check_Identifier (N : Node_Id);
2501 -- Check that the entity associated with this identifier is already
2502 -- defined.
2503
2504 function Is_BE_Visible_Type (E : Entity_Id) return Boolean;
2505 -- Return True if E is a type defined by the backend at library level or
2506 -- in the current subprogram.
2507
2508 procedure Report_Error (E : Entity_Id);
2509 -- Report the error associated with E. If Error_Node is not present the
2510 -- error is reported on N; otherwise it is reported on Error_Node.
2511
2512 ------------------
2513 -- Check_Entity --
2514 ------------------
2515
2516 procedure Check_Entity (E : Entity_Id) is
2517 begin
2518 -- No need to generate many errors on the same node
2519
2520 if Error_Posted (E) then
2521 return;
2522
2523 elsif (Is_Type (E) or else Ekind (E) = E_Constant)
2524 and then Error_Posted (Get_Full_View (E))
2525 then
2526 return;
2527 end if;
2528
2529 if Sloc (E) <= Standard_Location then
2530 null;
2531
2532 elsif not Is_Type (E) and then Entity_Table.Get (E) then
2533 null;
2534
2535 elsif Is_Type (E) and then Is_BE_Visible_Type (E) then
2536 null;
2537
2538 elsif Is_Type (E)
2539 and then Present (Full_View (E))
2540 and then Sloc (Get_Full_View (E)) <= Standard_Location
2541 then
2542 null;
2543
2544 elsif Is_Type (E)
2545 and then Present (Full_View (E))
2546 and then Is_BE_Visible_Type (Get_Full_View (E))
2547 then
2548 null;
2549
2550 elsif Ekind (E) = E_Constant
2551 and then
2552 (Sloc (Get_Full_View (E)) <= Standard_Location
2553 or else Entity_Table.Get (Get_Full_View (E)))
2554 then
2555 null;
2556
2557 elsif Is_Formal (E) and then Scope (E) = Current_Subp_Entity then
2558 null;
2559
2560 -- No check for enumeration literals defined in enclosing subprograms
2561 -- since in such a case we directly generate their value.
2562
2563 elsif Is_Enum_Literal_Of_Enclosing_Subprogram (E) then
2564 null;
2565
2566 elsif Ekind (E) = E_Enumeration_Literal then
2567 Check_Entity (Etype (E));
2568
2569 -- No check needed on the iterator defining identifier since it is
2570 -- safe.
2571
2572 elsif Nkind (Parent (E)) = N_Iterator_Specification then
2573 null;
2574
2575 else
2576 Report_Error (E);
2577
2578 if Is_Private_Type (E) then
2579 Set_Error_Posted (Get_Full_View (E));
2580 end if;
2581 end if;
2582 end Check_Entity;
2583
2584 ----------------------
2585 -- Check_Identifier --
2586 ----------------------
2587
2588 procedure Check_Identifier (N : Node_Id) is
2589 function In_Object_Declaration (N : Node_Id) return Boolean;
2590 -- Return True if N is part of an object declaration (excluding it
2591 -- initializing expression or renamed object).
2592
2593 ---------------------------
2594 -- In_Object_Declaration --
2595 ---------------------------
2596
2597 function In_Object_Declaration (N : Node_Id) return Boolean is
2598 Par : Node_Id := N;
2599 Prev : Node_Id := Empty;
2600
2601 begin
2602 while Present (Par) loop
2603 if Nkind (Par) = N_Object_Declaration then
2604 return No (Prev) or else Expression (Par) /= Prev;
2605
2606 elsif Nkind (Par) = N_Object_Renaming_Declaration then
2607 return No (Prev) or else Name (Par) /= Prev;
2608 end if;
2609
2610 Prev := Par;
2611 Par := Parent (Par);
2612 end loop;
2613
2614 return False;
2615 end In_Object_Declaration;
2616
2617 -- Local variables
2618
2619 E : constant Entity_Id := Entity (N);
2620
2621 -- Start of processing for Check_Identifier
2622
2623 begin
2624 -- Skip formals since they are safe if they correspond with the
2625 -- current subprogram, and they cannot be easily checked if we are
2626 -- in a nested subprogram.
2627
2628 if Is_Formal (E) then
2629 null;
2630
2631 -- Loop parameters are safe
2632
2633 elsif Ekind (E) = E_Loop_Parameter then
2634 null;
2635
2636 -- The identifier of an exit statement is safe
2637
2638 elsif Nkind (Parent (N)) = N_Exit_Statement
2639 and then Name (Parent (N)) = N
2640 then
2641 null;
2642
2643 -- The identifier of a goto statement is safe
2644
2645 elsif Nkind (Parent (N)) = N_Goto_Statement
2646 and then Name (Parent (N)) = N
2647 then
2648 null;
2649
2650 -- Skip object declarations and object renamings since the entity is
2651 -- still undefined.
2652
2653 elsif In_Object_Declaration (N) then
2654 null;
2655
2656 -- Skip references to AREC entities internally built by the back end
2657
2658 elsif Has_Back_End_AREC_Itype (E) then
2659 null;
2660
2661 elsif Nkind (Parent (N)) = N_Selected_Component then
2662 if N = Prefix (Parent (N)) then
2663 Check_Entity (E);
2664
2665 -- N is the selector name; locate the enclosing variable
2666
2667 else
2668 declare
2669 Pref : Node_Id := Prefix (Parent (N));
2670
2671 begin
2672 while Nkind (Pref) = N_Selected_Component loop
2673 Pref := Prefix (Pref);
2674 end loop;
2675
2676 -- For now we just check identifier prefixes
2677
2678 if Nkind (Pref) = N_Identifier then
2679 Check_Identifier (Pref);
2680 end if;
2681 end;
2682 end if;
2683 else
2684 Check_Entity (E);
2685 end if;
2686 end Check_Identifier;
2687
2688 ------------------------
2689 -- Is_BE_Visible_Type --
2690 ------------------------
2691
2692 function Is_BE_Visible_Type (E : Entity_Id) return Boolean is
2693 Enclosing_Subp : constant Entity_Id := Enclosing_Subp_Table.Get (E);
2694
2695 begin
2696 return
2697 Entity_Table.Get (E)
2698 and then
2699 (No (Enclosing_Subp)
2700 or else Enclosing_Subp = Current_Subp_Entity);
2701 end Is_BE_Visible_Type;
2702
2703 ------------------
2704 -- Report_Error --
2705 ------------------
2706
2707 procedure Report_Error (E : Entity_Id) is
2708 E_Node : Node_Id;
2709
2710 begin
2711 if Present (Error_Node) then
2712 E_Node := Error_Node;
2713 else
2714 E_Node := N;
2715 end if;
2716
2717 if Is_Type (E) and then not Is_BE_Visible_Type (E) then
2718 Error_Msg_N ("unsupported type reference", E);
2719
2720 elsif Is_Type (E)
2721 and then Present (Full_View (E))
2722 and then not Is_BE_Visible_Type (Get_Full_View (E))
2723 then
2724 Error_Msg_N ("unsupported type reference", E);
2725
2726 elsif Present (Current_Subp_Entity)
2727 and then not Is_Library_Level_Entity (Current_Subp_Entity)
2728 then
2729 if Is_Type (E) then
2730 Error_Msg_N
2731 ("unsupported reference to type defined in enclosing scope",
2732 E_Node);
2733
2734 elsif Comes_From_Source (N) then
2735 Error_Msg_N
2736 ("unsupported reference to entity defined in enclosing scope",
2737 E_Node);
2738 else
2739 Error_Msg_N
2740 ("unsupported reference to internal entity defined in " &
2741 "enclosing scope", E_Node);
2742 end if;
2743
2744 elsif Is_Itype (E) then
2745 Error_Msg_N ("unsupported type reference", E_Node);
2746 else
2747 Error_Msg_N ("unsupported entity reference", E_Node);
2748 end if;
2749
2750 Set_Error_Posted (N);
2751 end Report_Error;
2752
2753 -- Start of processing for Check_Definition
2754
2755 begin
2756 if Nkind (N) = N_Defining_Identifier then
2757 Check_Entity (N);
2758
2759 elsif Nkind (N) = N_Identifier then
2760 Check_Identifier (N);
2761
2762 elsif Nkind_In (N, N_Type_Conversion,
2763 N_Unchecked_Type_Conversion)
2764 and then Nkind (Ultimate_Expression (N)) = N_Identifier
2765 then
2766 Check_Identifier (Ultimate_Expression (N));
2767 end if;
2768 end Check_Definition;
2769
2770 ----------------
2771 -- Check_Sloc --
2772 ----------------
2773
2774 function Check_Sloc (S : Source_Ptr) return Boolean is
2775 begin
2776 return
2777 not In_Instantiation (S)
2778 and then Get_Source_File_Index (S) = Current_Source_File;
2779 end Check_Sloc;
2780
2781 ---------------
2782 -- Col_Check --
2783 ---------------
2784
2785 procedure Col_Check (N : Nat) is
2786 begin
2787 if N + Column > Sprint_Line_Limit then
2788 Write_Indent_Str (" ");
2789 end if;
2790 end Col_Check;
2791
2792 -----------------------------------
2793 -- Compound_Statement_Compatible --
2794 -----------------------------------
2795
2796 function Compound_Statement_Compatible (L : List_Id) return Boolean is
2797 Result : Boolean := True;
2798
2799 function Search_Complex_Node (Node : Node_Id) return Traverse_Result;
2800 -- Subtree visitor that looks for nodes incompatible with compound
2801 -- statements.
2802
2803 -------------------------
2804 -- Search_Complex_Node --
2805 -------------------------
2806
2807 function Search_Complex_Node (Node : Node_Id) return Traverse_Result is
2808 begin
2809 case Nkind (Node) is
2810 when N_Declaration | N_Statement_Other_Than_Procedure_Call =>
2811 if not Nkind_In (Node, N_Null_Statement, N_If_Statement) then
2812 Result := False;
2813 return Abandon;
2814 end if;
2815
2816 when others =>
2817 return OK;
2818 end case;
2819
2820 return OK;
2821 end Search_Complex_Node;
2822
2823 procedure Search is new Traverse_Proc (Search_Complex_Node);
2824 -- Subtree visitor instantiation
2825
2826 -- Local variables
2827
2828 N : Node_Id;
2829
2830 -- Start of processing for Compound_Statement_Compatible
2831
2832 begin
2833 if Is_Non_Empty_List (L) then
2834 N := First (L);
2835
2836 loop
2837 Search (N);
2838 Next (N);
2839 exit when N = Empty;
2840 end loop;
2841 end if;
2842
2843 return Result;
2844 end Compound_Statement_Compatible;
2845
2846 ---------------------
2847 -- Cprint_And_List --
2848 ---------------------
2849
2850 procedure Cprint_And_List (List : List_Id) is
2851 Node : Node_Id;
2852 begin
2853 if Is_Non_Empty_List (List) then
2854 Node := First (List);
2855 loop
2856 Cprint_Node (Node);
2857 Next (Node);
2858 exit when Node = Empty;
2859 Write_Str (" and ");
2860 end loop;
2861 end if;
2862 end Cprint_And_List;
2863
2864 ---------------------
2865 -- Cprint_Bar_List --
2866 ---------------------
2867
2868 procedure Cprint_Bar_List (List : List_Id) is
2869 Node : Node_Id;
2870 begin
2871 if Is_Non_Empty_List (List) then
2872 Node := First (List);
2873 loop
2874 Cprint_Node (Node);
2875 Next (Node);
2876 exit when Node = Empty;
2877 Write_Str (" | ");
2878 end loop;
2879 end if;
2880 end Cprint_Bar_List;
2881
2882 -----------------
2883 -- Cprint_Call --
2884 -----------------
2885
2886 procedure Cprint_Call (Node : Node_Id) is
2887 function Array_Cast_Needed
2888 (Formal : Node_Id;
2889 Actual : Node_Id) return Boolean;
2890 -- Return True if passing Actual to Formal requires casting
2891
2892 procedure Handle_Access_To_Constrained_Array
2893 (Formal : Node_Id;
2894 Actual : Node_Id);
2895 -- Handle C generation of an access-to-constrained-array actual
2896
2897 -----------------------
2898 -- Array_Cast_Needed --
2899 -----------------------
2900
2901 function Array_Cast_Needed
2902 (Formal : Node_Id;
2903 Actual : Node_Id) return Boolean
2904 is
2905 begin
2906 -- Add a cast on const array parameters to address C compiler
2907 -- warnings (and MISRA C compliance).
2908
2909 if Is_Entity_Name (Actual)
2910 and then Ekind (Entity (Actual)) = E_Constant
2911 and then Is_Unidimensional_Array_Type (Etype (Formal))
2912 then
2913 return True;
2914
2915 elsif Nkind (Actual) = N_Explicit_Dereference
2916 and then Is_Unidimensional_Array_Type (Etype (Formal))
2917 then
2918 return True;
2919
2920 else
2921 return False;
2922 end if;
2923 end Array_Cast_Needed;
2924
2925 ----------------------------------------
2926 -- Handle_Access_To_Constrained_Array --
2927 ----------------------------------------
2928
2929 procedure Handle_Access_To_Constrained_Array
2930 (Formal : Node_Id;
2931 Actual : Node_Id)
2932 is
2933 function Is_Access_Attribute_Reference (N : Node_Id) return Boolean;
2934 -- Return True if the attribute reference N corresponds with an
2935 -- access or address attribute.
2936
2937 -----------------------------------
2938 -- Is_Access_Attribute_Reference --
2939 -----------------------------------
2940
2941 function Is_Access_Attribute_Reference (N : Node_Id) return Boolean is
2942 pragma Assert (Nkind (N) = N_Attribute_Reference);
2943
2944 Attr_Id : constant Attribute_Id :=
2945 Get_Attribute_Id (Attribute_Name (N));
2946
2947 begin
2948 return
2949 Attr_Id = Attribute_Access or else
2950 Attr_Id = Attribute_Address or else
2951 Attr_Id = Attribute_Unchecked_Access or else
2952 Attr_Id = Attribute_Unrestricted_Access;
2953 end Is_Access_Attribute_Reference;
2954
2955 -- Local variables
2956
2957 Formal_Array_Type : constant Entity_Id :=
2958 Get_Full_View
2959 (Designated_Type (Etype (Formal)));
2960
2961 -- Start of processing for Handle_Access_To_Constrained_Array
2962
2963 begin
2964 if Etype (Formal) /= Etype (Actual)
2965 or else (Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
2966 and then Is_Constrained (Formal_Array_Type))
2967 then
2968 if Nkind (Original_Node (Actual)) = N_Allocator then
2969 Write_Char ('(');
2970 Write_Id (Etype (Formal));
2971 Write_Str (") ");
2972
2973 elsif Is_Out_Mode_Access_Formal (Formal) then
2974 null;
2975
2976 elsif Is_Unidimensional_Array_Type (Formal_Array_Type) then
2977 Write_Char ('(');
2978 Write_Id (Component_Type (Formal_Array_Type));
2979 Write_Str ("*) ");
2980 end if;
2981 end if;
2982
2983 -- When the prefix of an access/address attribute reference is an
2984 -- array, the prefix is a pointer to the array contents and hence
2985 -- there is no need to compute its address.
2986
2987 if Nkind (Actual) = N_Attribute_Reference
2988 and then Is_Access_Attribute_Reference (Actual)
2989 then
2990 Cprint_Node (Prefix (Actual));
2991
2992 -- When the actual and the formal are access to a multidimensional
2993 -- array type, and the formal is not an OUT or IN-OUT access type,
2994 -- the formal has been declared using the designated type and we
2995 -- pass the dereference of the actual.
2996
2997 elsif Etype (Formal) = Etype (Actual)
2998 and then not Is_Unidimensional_Array_Type (Formal_Array_Type)
2999 and then not Is_Out_Mode_Access_Formal (Formal)
3000 then
3001 Write_Char ('*');
3002 Cprint_Node (Actual);
3003
3004 elsif Has_Fat_Pointer (Etype (Actual)) then
3005 if Is_Unidimensional_Array_Type (Formal_Array_Type) then
3006 Cprint_Node (Actual);
3007 Write_Fatptr_Dereference;
3008
3009 -- Cast needed on access to multidimensional arrays to avoid
3010 -- warnings on the generated code.
3011
3012 else
3013 Write_Str ("*((");
3014 Write_Id (Formal_Array_Type);
3015 Write_Str ("*) ");
3016
3017 Cprint_Node (Actual);
3018 Write_Fatptr_Dereference;
3019
3020 Write_Char (')');
3021 end if;
3022
3023 -- Common output
3024
3025 else
3026 if Present (Formal) and then Pass_Pointer (Formal) then
3027 Write_Char ('&');
3028 end if;
3029
3030 Cprint_Node (Actual);
3031 end if;
3032 end Handle_Access_To_Constrained_Array;
3033
3034 -- Local variables
3035
3036 Actual : Node_Id;
3037 Formal : Node_Id := Empty;
3038 Call : Node_Id;
3039
3040 -- Start of processing for Cprint_Call
3041
3042 begin
3043 if Nkind (Name (Node)) not in N_Has_Entity then
3044
3045 -- Can happen in case of a rewritten node, e.g. for
3046 -- unchecked_conversion
3047
3048 Call := Name (Node);
3049
3050 if Nkind (Call) = N_Explicit_Dereference then
3051 Formal := First_Entity (Designated_Type (Etype (Prefix (Call))));
3052
3053 -- Report an error on unsupported cases
3054
3055 else
3056 declare
3057 S : constant String := Node_Kind'Image (Nkind (Call));
3058 begin
3059 Error_Msg_Strlen := S'Length;
3060 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
3061 Error_Msg_N ("unsupported call (~)", Node);
3062 end;
3063 end if;
3064
3065 else
3066 Call := Entity (Name (Node));
3067 Formal := First_Formal_With_Extras (Call);
3068 end if;
3069
3070 Cprint_Node (Call);
3071 Write_Char ('(');
3072
3073 Actual := First_Actual (Node);
3074 while Present (Actual) loop
3075 if Present (Formal) then
3076 if Has_Fat_Pointer (Etype (Formal)) then
3077 if not Has_Fat_Pointer (Etype (Ultimate_Expression (Actual)))
3078 then
3079 if Nkind (Actual) = N_Attribute_Reference
3080 and then
3081 Get_Attribute_Id
3082 (Attribute_Name (Actual)) /= Attribute_Deref
3083 then
3084 Handle_Attribute (Actual);
3085 else
3086 Write_Fatptr_Init (Actual, Etype (Formal));
3087 end if;
3088
3089 -- The actual parameter is a fat pointer
3090
3091 else
3092 if Pass_Pointer (Formal) then
3093 Write_Char ('&');
3094 end if;
3095
3096 if Nkind (Actual) = N_Explicit_Dereference then
3097 Cprint_Node (Prefix (Actual));
3098 else
3099 Cprint_Node (Actual);
3100 end if;
3101 end if;
3102
3103 elsif Is_Access_Type (Etype (Formal))
3104 and then Is_Array_Type
3105 (Get_Full_View (Designated_Type (Etype (Formal))))
3106 and then not Is_Unconstrained_Array_Type
3107 (Get_Full_View (Designated_Type (Etype (Formal))))
3108 then
3109 Handle_Access_To_Constrained_Array (Formal, Actual);
3110
3111 else
3112 if Pass_Pointer (Formal) then
3113 if Nkind (Actual) = N_Indexed_Component then
3114 Write_Char ('(');
3115 Write_Id (Etype (Formal));
3116 Write_Str ("*) ");
3117 end if;
3118
3119 Write_Char ('&');
3120 else
3121 if Array_Cast_Needed (Formal, Actual) then
3122 Write_Char ('(');
3123 Write_Id
3124 (Component_Type (Get_Full_View (Etype (Formal))));
3125 Write_Str ("*) ");
3126 end if;
3127 end if;
3128
3129 -- Strip extra type conversion when passing parameters by
3130 -- pointer.
3131
3132 if Nkind (Actual) = N_Type_Conversion
3133 and then Pass_Pointer (Formal)
3134 then
3135 Cprint_Node (Expression (Actual));
3136 else
3137 Cprint_Node (Actual);
3138 end if;
3139 end if;
3140
3141 Next_Formal_With_Extras (Formal);
3142
3143 else
3144 Cprint_Node (Actual);
3145 end if;
3146
3147 Next_Actual (Actual);
3148 exit when No (Actual);
3149
3150 Write_Str (", ");
3151 end loop;
3152
3153 Write_Char (')');
3154 end Cprint_Call;
3155
3156 -----------------------
3157 -- Cprint_Comma_List --
3158 -----------------------
3159
3160 function Cprint_Comma_List (List : List_Id) return Integer is
3161 Node : Node_Id;
3162 Num : Integer := 0;
3163
3164 begin
3165 if Is_Non_Empty_List (List) then
3166 Node := First (List);
3167 loop
3168 if Nkind (Node) /= N_Null_Statement then
3169 Cprint_Node (Node);
3170 Num := Num + 1;
3171
3172 if Last_Char = ';' then
3173 Delete_Last_Char;
3174 end if;
3175 end if;
3176
3177 Next (Node);
3178 exit when Node = Empty;
3179
3180 if Nkind (Node) /= N_Null_Statement then
3181 Write_Str (", ");
3182 end if;
3183 end loop;
3184 end if;
3185
3186 return Num;
3187 end Cprint_Comma_List;
3188
3189 procedure Cprint_Comma_List (List : List_Id) is
3190 Ignore : Integer;
3191 begin
3192 Ignore := Cprint_Comma_List (List);
3193 end Cprint_Comma_List;
3194
3195 -----------------
3196 -- Cprint_Copy --
3197 -----------------
3198
3199 procedure Cprint_Copy
3200 (Target : Node_Id;
3201 Source : Node_Id;
3202 Use_Memcpy : Boolean)
3203 is
3204 procedure Write_Param (Param : Node_Id; Param_Typ : Entity_Id);
3205 -- Output a parameter of the call to memcpy/memmove
3206
3207 -----------------
3208 -- Write_Param --
3209 -----------------
3210
3211 procedure Write_Param (Param : Node_Id; Param_Typ : Entity_Id) is
3212 Typ : Entity_Id;
3213
3214 begin
3215 if Is_Access_Type (Param_Typ) then
3216 Typ := Designated_Type (Param_Typ);
3217 else
3218 Typ := Param_Typ;
3219 end if;
3220
3221 if Requires_Address (Typ) then
3222 Write_Str ("&");
3223 Cprint_Node (Param, Declaration => True);
3224
3225 else
3226 if Is_Unconstrained_Array_Formal (Param)
3227 or else Is_Unconstrained_Array_Type (Typ)
3228 then
3229 Cprint_Node (Param, Declaration => True);
3230 Write_Fatptr_Dereference;
3231
3232 elsif Nkind (Param) = N_Slice
3233 and then Is_Unconstrained_Array_Formal (Prefix (Param))
3234 then
3235 Write_Unconstrained_Array_Prefix (Prefix (Param));
3236 Write_Str ("+");
3237
3238 if Nkind (Discrete_Range (Param)) = N_Range then
3239 Cprint_Node (Low_Bound (Discrete_Range (Param)));
3240 Write_Str ("-");
3241 Cprint_Node (Prefix (Param));
3242 Write_Str (".");
3243 Write_Fatptr_First (Etype (Prefix (Param)), 1);
3244
3245 else
3246 declare
3247 S : constant String :=
3248 Node_Kind'Image (Nkind (Discrete_Range (Param)));
3249
3250 begin
3251 Error_Msg_Strlen := S'Length;
3252 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
3253 Error_Msg_N ("unsupported kind of slice (~)", Source);
3254 end;
3255 end if;
3256 else
3257 Cprint_Node (Param, Declaration => True);
3258 end if;
3259 end if;
3260 end Write_Param;
3261
3262 -- Local variables
3263
3264 Target_Typ : constant Entity_Id := Get_Full_View (Etype (Target));
3265 Siz : Int;
3266 Src : Node_Id := Source;
3267 Src_Is_UC : Boolean := False;
3268 Src_Typ : Entity_Id;
3269 Use_Temp : Boolean := False;
3270
3271 -- Start of processing for Cprint_Copy
3272
3273 begin
3274 -- For nested type conversions and/or unchecked type conversions, take
3275 -- the innermost source.
3276
3277 if Nkind_In (Src, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3278 Src := Ultimate_Expression (Src);
3279 Src_Is_UC := True;
3280 end if;
3281
3282 Src_Typ := Get_Full_View (Etype (Src));
3283
3284 -- Use simple assignment for elementary objects or for an
3285 -- Unchecked_Conversion if Target_Typ is elementary.
3286
3287 if ((Ekind (Src_Typ) not in Composite_Kind or else Src_Is_UC)
3288 and then Ekind (Target_Typ) not in Composite_Kind)
3289 or else (Src_Typ = Target_Typ
3290 and then Is_Packed_Array (Src_Typ)
3291 and then Is_Integer_Type (Packed_Array_Impl_Type (Src_Typ)))
3292 then
3293 Cprint_Node (Target, Declaration => True);
3294
3295 if Is_Access_Type (Target_Typ)
3296 and then Has_Fat_Pointer (Target_Typ)
3297 and then not Has_Fat_Pointer (Src_Typ)
3298 then
3299 Write_Fatptr_Dereference;
3300 end if;
3301
3302 Write_Str (" = ");
3303
3304 if Is_Access_Type (Src_Typ)
3305 and then Has_Fat_Pointer (Src_Typ)
3306 and then not Has_Fat_Pointer (Target_Typ)
3307 then
3308 Write_Char ('(');
3309 Write_Id (Target_Typ);
3310 Write_Str (") ");
3311
3312 Cprint_Node (Source);
3313 Write_Fatptr_Dereference;
3314 else
3315 Cprint_Node (Source);
3316 end if;
3317
3318 -- Composite object kinds
3319
3320 else
3321 -- Use a simple assignment when the expression is a function
3322 -- returning a struct or a struct object/component.
3323
3324 if Is_Record_Type (Src_Typ)
3325 and then not Src_Is_UC
3326 and then Nkind_In (Src, N_Function_Call,
3327 N_Identifier,
3328 N_Selected_Component)
3329 then
3330 Cprint_Node (Target, Declaration => True);
3331 Write_Str (" = ");
3332 Cprint_Node (Src, Declaration => True);
3333
3334 -- Replace composite assignment by a call to memcpy() or memmove()
3335
3336 else
3337 -- Handle cases on which memcpy cannot work directly
3338
3339 if Nkind (Source) = N_Aggregate
3340 or else (Nkind (Source) = N_Qualified_Expression
3341 and then Nkind (Expression (Source)) = N_Aggregate)
3342 then
3343 Use_Temp := True;
3344
3345 Open_Scope;
3346 Write_Char (' ');
3347 Write_Itypes_In_Subtree (Src);
3348 Check_Definition (Src_Typ, Error_Node => Src);
3349 Cprint_Type_Name (Src_Typ);
3350 Write_Str (" _tmp = ");
3351 Cprint_Node (Src, Declaration => True);
3352 Write_Str (";");
3353 Write_Indent;
3354 Set_In_Statements;
3355
3356 else
3357 -- Packed record, since memcpy doesn't work on bitfields
3358
3359 if Nkind (Src) = N_Selected_Component
3360 and then Has_Non_Standard_Rep
3361 (Get_Full_View (Etype (Prefix (Src))))
3362 then
3363 Use_Temp := True;
3364 Siz :=
3365 UI_To_Int (Esize (Get_Full_View (Etype (Prefix (Src)))));
3366
3367 if Siz <= Uint_0 then
3368 Error_Msg_N
3369 ("unsupported record component reference", Src);
3370 end if;
3371
3372 -- Unchecked conversion of scalar type to composite type
3373
3374 elsif Nkind (Source) = N_Unchecked_Type_Conversion
3375 and then Is_Scalar_Type (Etype (Src))
3376 then
3377 Use_Temp := True;
3378 Siz := UI_To_Int (Esize (Src_Typ));
3379 end if;
3380
3381 if Use_Temp then
3382 Open_Scope;
3383 Write_Char (' ');
3384
3385 if Is_Discrete_Type (Etype (Src)) then
3386 Write_Integer_Type
3387 (Siz,
3388 Signed => not Is_Modular_Integer_Type (Etype (Src)));
3389
3390 else
3391 Check_Definition (Etype (Src), Error_Node => Src);
3392 Cprint_Type_Name (Etype (Src));
3393 end if;
3394
3395 Write_Str (" _tmp = ");
3396 Cprint_Node (Src, Declaration => True);
3397 Write_Str (";");
3398 Set_In_Statements;
3399 end if;
3400 end if;
3401
3402 if Last_Char = ';' then
3403 Write_Indent;
3404 end if;
3405
3406 if Use_Memcpy then
3407 Write_Str ("memcpy(");
3408 else
3409 Write_Str ("memmove(");
3410 end if;
3411
3412 Write_Param (Target, Target_Typ);
3413 Write_Str (", ");
3414
3415 if Use_Temp then
3416 Write_Str ("&_tmp");
3417 else
3418 Write_Param (Src, Src_Typ);
3419 end if;
3420
3421 Write_Str (", ");
3422 Output_Sizeof (Target, Source);
3423 Write_Char (')');
3424
3425 if Use_Temp then
3426 Write_Char (';');
3427 Close_Scope;
3428 end if;
3429 end if;
3430 end if;
3431
3432 -- After generating the assignment or the call to memcopy/memmove
3433 -- remember that we are now processing statements.
3434
3435 Set_In_Statements;
3436 end Cprint_Copy;
3437
3438 --------------------
3439 -- Cprint_Declare --
3440 --------------------
3441
3442 procedure Cprint_Declare
3443 (Ent : Entity_Id;
3444 Add_Access : Boolean := False;
3445 Virtual_OK : Boolean := False;
3446 Semicolon : Boolean := True)
3447 is
3448 Debug : constant Boolean := False;
3449 Need_Semicolon : Boolean;
3450
3451 begin
3452 -- Only declare each entity once
3453
3454 if Entity_Table.Get (Ent) then
3455 if Debug then
3456 Write_Str ("/* skipped: ");
3457 Cprint_Node (Ent);
3458 Write_Str (" */");
3459 end if;
3460
3461 return;
3462 end if;
3463
3464 Register_Entity (Ent);
3465
3466 if Semicolon and Last_Char /= ' ' then
3467 Write_Indent;
3468 end if;
3469
3470 Need_Semicolon :=
3471 Cprint_Reference
3472 (Ent, Add_Access => Add_Access, Virtual_OK => Virtual_OK);
3473
3474 if Semicolon and Need_Semicolon then
3475 Write_Char (';');
3476 end if;
3477 end Cprint_Declare;
3478
3479 -----------------------
3480 -- Cprint_Difference --
3481 -----------------------
3482
3483 procedure Cprint_Difference (Val1 : Node_Id; Val2 : Uint; B : Boolean) is
3484 Modular : constant Boolean := Is_Modular_Integer_Type (Etype (Val1));
3485 begin
3486 if Compile_Time_Known_Value (Val1) then
3487 Write_Uint (Expr_Value (Val1) - Val2, Modular => Modular);
3488
3489 elsif Val2 = Uint_0 then
3490 Cprint_Node (Val1);
3491
3492 elsif B then
3493 Write_Str_Col_Check ("(");
3494 Cprint_Node (Val1);
3495 Write_Str_Col_Check (" - ");
3496 Write_Uint (Val2, Modular => Modular);
3497 Write_Str_Col_Check (")");
3498
3499 else
3500 Cprint_Node (Val1);
3501 Write_Str_Col_Check (" - ");
3502 Write_Uint (Val2, Modular => Modular);
3503 end if;
3504 end Cprint_Difference;
3505
3506 procedure Cprint_Difference
3507 (Val1 : Node_Id;
3508 Val2 : Node_Id;
3509 Minus_One_Min : Boolean)
3510 is
3511 begin
3512 if Compile_Time_Known_Value (Val2) then
3513 Cprint_Difference (Val1, Expr_Value (Val2), Minus_One_Min);
3514
3515 elsif Is_Entity_Name (Val1) and then Is_Entity_Name (Val2)
3516 and then Entity (Val1) = Entity (Val2)
3517 then
3518 Write_Str_Col_Check ("0");
3519
3520 else
3521 -- When Minus_One_Min is True, then generate safeguard:
3522
3523 -- (Val1 < Val2 ? -1 : Val1 - Val2)
3524
3525 -- Note that we rely on the front end to remove side effects by
3526 -- stabilizing values into temporaries, so we do not need to worry
3527 -- about side effects here.
3528
3529 if Minus_One_Min then
3530 Write_Str_Col_Check ("(");
3531 Cprint_Node (Val1);
3532 Write_Str_Col_Check (" < (");
3533 Cprint_Node (Val2);
3534 Write_Str_Col_Check (") ? -1 : ");
3535 end if;
3536
3537 Cprint_Node (Val1);
3538 Write_Str_Col_Check (" - ");
3539
3540 -- Add parens around expression if needed
3541
3542 if Nkind_In (Val2, N_Identifier, N_Expanded_Name) then
3543 Cprint_Node (Val2);
3544 else
3545 Write_Str_Col_Check ("(");
3546 Cprint_Node (Val2);
3547 Write_Str_Col_Check (")");
3548 end if;
3549
3550 if Minus_One_Min then
3551 Write_Str_Col_Check (")");
3552 end if;
3553 end if;
3554 end Cprint_Difference;
3555
3556 --------------------------
3557 -- Cprint_Indented_List --
3558 --------------------------
3559
3560 procedure Cprint_Indented_List (List : List_Id) is
3561 begin
3562 Indent_Begin;
3563 Cprint_Node_List (List);
3564 Indent_End;
3565 end Cprint_Indented_List;
3566
3567 ----------------------
3568 -- Cprint_Left_Opnd --
3569 ----------------------
3570
3571 procedure Cprint_Left_Opnd (N : Node_Id) is
3572 Opnd : constant Node_Id := Left_Opnd (N);
3573 begin
3574 Cprint_Node_Paren (Opnd);
3575 end Cprint_Left_Opnd;
3576
3577 -----------------
3578 -- Cprint_Node --
3579 -----------------
3580
3581 procedure Cprint_Node (Node : Node_Id; Declaration : Boolean := False) is
3582 function Is_Raise_Statement (N : Node_Id) return Boolean;
3583 -- Return true if N is a raise statement or a raise expression
3584
3585 -----------------------
3586 -- Is_Raise_Statement --
3587 ------------------------
3588
3589 function Is_Raise_Statement (N : Node_Id) return Boolean is
3590 begin
3591 return Present (N)
3592 and then (Nkind (N) in N_Raise_xxx_Error
3593 or else Nkind (N) = N_Raise_Statement
3594 or else Nkind (N) = N_Raise_Expression);
3595 end Is_Raise_Statement;
3596
3597 -- Local variables
3598
3599 Save_Dump_Node : constant Node_Id := Dump_Node;
3600
3601 -- Start of processing for Cprint_Node
3602
3603 begin
3604 if Node = Empty then
3605 return;
3606 end if;
3607
3608 if Library_Level
3609 and then (Nkind (Node) in N_Statement_Other_Than_Procedure_Call
3610 or else Nkind (Node) in N_Subprogram_Call
3611 or else Nkind (Node) = N_Handled_Sequence_Of_Statements
3612 or else Nkind (Node) in N_Raise_xxx_Error
3613 or else Nkind (Node) = N_Raise_Statement)
3614 then
3615 -- Append to list of statements to put in the elaboration procedure
3616 -- if in main unit, otherwise simply ignore the statement.
3617
3618 if In_Main_Unit then
3619 Elaboration_Table.Append (Node);
3620 end if;
3621
3622 return;
3623 end if;
3624
3625 -- Remember that we start processing statements. Needed to enable the
3626 -- generation of extra scopes (if needed).
3627
3628 if In_Declarations
3629 and then
3630 (Nkind (Node) = N_Procedure_Call_Statement
3631 or else Nkind (Node) in N_Statement_Other_Than_Procedure_Call
3632 or else Nkind (Node) in N_Raise_xxx_Error)
3633 and then Nkind (Node) /= N_Null_Statement
3634 and then Extra_Scopes_Allowed
3635 then
3636 Set_In_Statements;
3637 end if;
3638
3639 -- Setup current dump node
3640
3641 Dump_Node := Node;
3642
3643 -- Select print circuit based on node kind
3644
3645 case Nkind (Node) is
3646 when N_Abort_Statement | N_Abortable_Part =>
3647 raise Program_Error;
3648
3649 when N_Abstract_Subprogram_Declaration =>
3650 null; -- not output in C code
3651
3652 when N_Accept_Alternative | N_Accept_Statement =>
3653 raise Program_Error;
3654
3655 when N_Access_Definition =>
3656 if Present (Access_To_Subprogram_Definition (Node)) then
3657 Cprint_Node
3658 (Access_To_Subprogram_Definition (Node), Declaration => True);
3659 else
3660 Write_Str_Col_Check ("* ");
3661 Cprint_Node (Subtype_Mark (Node), Declaration => True);
3662 end if;
3663
3664 when N_Access_To_Object_Definition |
3665 N_Access_Function_Definition |
3666 N_Access_Procedure_Definition =>
3667
3668 -- Processed by Cprint_Declare as part of processing the parent
3669 -- node (N_Full_Type_Declaration) or the itypes associated with
3670 -- anonymous access-to-subprogram types.
3671
3672 raise Program_Error;
3673
3674 when N_Aggregate =>
3675 if Null_Record_Present (Node) then
3676 null;
3677
3678 else
3679 Write_Str_Col_Check ("{");
3680
3681 if Present (Expressions (Node)) then
3682 Cprint_Comma_List (Expressions (Node));
3683
3684 if Present (Component_Associations (Node))
3685 and then not Is_Empty_List (Component_Associations (Node))
3686 then
3687 Write_Str (", ");
3688 end if;
3689 end if;
3690
3691 if Present (Component_Associations (Node))
3692 and then not Is_Empty_List (Component_Associations (Node))
3693 then
3694 Indent_Begin;
3695
3696 declare
3697 Nd : Node_Id;
3698 begin
3699 Nd := First (Component_Associations (Node));
3700
3701 loop
3702 Write_Indent;
3703 Cprint_Node (Nd);
3704 Next (Nd);
3705 exit when No (Nd);
3706 Write_Str (", ");
3707 end loop;
3708 end;
3709
3710 Indent_End;
3711 end if;
3712
3713 Write_Char ('}');
3714 end if;
3715
3716 when N_Allocator =>
3717
3718 -- For now, just handle case of identifier or qualified expression
3719 -- with no storage pool.
3720
3721 if No (Storage_Pool (Node)) then
3722 if Nkind_In (Expression (Node), N_Expanded_Name,
3723 N_Identifier,
3724 N_Qualified_Expression)
3725 then
3726 declare
3727 function Allocator_Name (N : Node_Id) return Node_Id;
3728 -- Return object name corresponding to the current
3729 -- allocator, from node N.
3730
3731 --------------------
3732 -- Allocator_Name --
3733 --------------------
3734
3735 function Allocator_Name (N : Node_Id) return Node_Id is
3736 begin
3737 case Nkind (N) is
3738 when N_Object_Declaration =>
3739 return Defining_Identifier (N);
3740
3741 when N_Assignment_Statement =>
3742 return Name (N);
3743
3744 when others =>
3745 return Empty;
3746 end case;
3747 end Allocator_Name;
3748
3749 Expr : constant Node_Id := Expression (Node);
3750 Typ : constant Node_Id := Get_Full_View (Etype (Expr));
3751 Field : Node_Id;
3752 N : Node_Id;
3753 Rng : Node_Id;
3754
3755 Extra_Paren : Boolean := False;
3756 Skip_N : Boolean := False;
3757
3758 begin
3759 Write_Str_Col_Check ("malloc(sizeof(");
3760 Check_Definition (Etype (Expr), Error_Node => Node);
3761 Cprint_Type_Name (Etype (Expr));
3762 Write_Char (')');
3763
3764 if Has_Discriminants (Typ) then
3765 Field := Last_Field (Typ);
3766
3767 if Has_Per_Object_Constraint (Field)
3768 and then Ekind (Etype (Field)) = E_Array_Subtype
3769 then
3770 -- For a record type with discriminants and whose
3771 -- last field depends on this discriminant,
3772 -- generate:
3773 -- malloc(sizeof(<type>+<size of last field>))
3774
3775 Write_Str (" + ");
3776 Rng := First_Index (Etype (Field));
3777
3778 if Nkind (Rng) = N_Range then
3779
3780 -- Note: we do not add +1 here since sizeof()
3781 -- already accounts for 1 element.
3782
3783 Write_Uint
3784 (Intval (High_Bound (Rng)) -
3785 Intval (Low_Bound (Rng)));
3786 Write_Str (" * sizeof(");
3787 Check_Definition
3788 (Component_Type (Etype (Field)),
3789 Error_Node => Field);
3790 Cprint_Type_Name
3791 (Component_Type (Etype (Field)));
3792 Write_Char (')');
3793
3794 else
3795 Error_Msg_N
3796 ("cannot compute size for field", Field);
3797 Write_Char ('0');
3798 end if;
3799 end if;
3800 end if;
3801
3802 Write_Char (')');
3803
3804 -- If we are invoking a fatptr constructor we must now
3805 -- provide the bounds.
3806
3807 if In_Fatptr_Constructor_Call then
3808 Write_Str (", ");
3809
3810 if Nkind (Expr) = N_Qualified_Expression then
3811 Write_Fatptr_Bounds (Expression (Expr),
3812 Get_Full_View (Etype (Expression (Expr))));
3813 else
3814 Write_Fatptr_Bounds (Expr,
3815 Get_Full_View (Etype (Expr)));
3816 end if;
3817
3818 Write_Char (')');
3819 end if;
3820
3821 if Nkind (Expr) = N_Qualified_Expression then
3822 if Nkind_In (Parent (Node), N_Assignment_Statement,
3823 N_Object_Declaration,
3824 N_Qualified_Expression,
3825 N_Simple_Return_Statement)
3826 then
3827 Write_Char (';');
3828 Write_Indent;
3829
3830 if Is_Composite_Type (Typ)
3831 and then (not Is_Unconstrained_Array_Type (Typ)
3832 or else Number_Dimensions (Typ) > 1)
3833 then
3834 Error_Msg_N
3835 ("unsupported expression (composite type) " &
3836 "in allocator", Node);
3837 end if;
3838
3839 Set_In_Statements;
3840
3841 if not Is_Unconstrained_Array_Type (Typ) then
3842 Write_Str ("*(");
3843 end if;
3844
3845 N := Allocator_Name (Parent (Node));
3846
3847 if No (N) then
3848 case Nkind (Parent (Node)) is
3849 when N_Simple_Return_Statement =>
3850 if not Is_Unconstrained_Array_Type (Typ)
3851 then
3852 Write_Str ("_tmp");
3853 end if;
3854
3855 Skip_N := True;
3856
3857 when N_Qualified_Expression =>
3858 N :=
3859 Allocator_Name (Parent (Parent (Node)));
3860
3861 if No (N) then
3862 N := Parent (Parent (Node));
3863
3864 if Nkind (N) = N_Allocator then
3865 N := Allocator_Name (Parent (N));
3866
3867 if Present (N) then
3868 Write_Str ("*(");
3869 Extra_Paren := True;
3870 end if;
3871 end if;
3872 end if;
3873
3874 when others =>
3875 raise Program_Error;
3876 end case;
3877 end if;
3878
3879 if not Skip_N and then No (N) then
3880 Error_Msg_N
3881 ("unsupported context for allocator", Node);
3882
3883 elsif Is_Unconstrained_Array_Type (Typ) then
3884 if Skip_N or else No (N) then
3885 Error_Msg_N
3886 ("unsupported context for allocator", Node);
3887 else
3888 Cprint_Copy
3889 (Target => N,
3890 Source => Expression (Expr),
3891 Use_Memcpy => True);
3892 end if;
3893 else
3894 if not Skip_N then
3895 Cprint_Node (N);
3896 end if;
3897
3898 if Extra_Paren then
3899 Write_Char (')');
3900 end if;
3901
3902 Write_Char (')');
3903 Write_Str (" = ");
3904 Cprint_Node (Expression (Expr));
3905 end if;
3906
3907 else
3908 declare
3909 S : constant String :=
3910 Node_Kind'Image (Nkind (Parent (Node)));
3911 begin
3912 Error_Msg_Strlen := S'Length;
3913 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
3914 Error_Msg_N
3915 ("unsupported context for allocator (~)",
3916 Node);
3917 end;
3918 end if;
3919 end if;
3920 end;
3921
3922 else
3923 declare
3924 S : constant String :=
3925 Node_Kind'Image (Nkind (Expression (Node)));
3926 begin
3927 Error_Msg_Strlen := S'Length;
3928 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
3929 Error_Msg_N ("unsupported kind of allocation (~)", Node);
3930 end;
3931
3932 Write_Str_Col_Check ("NULL /* new ");
3933 Cprint_Node (Expression (Node), Declaration => True);
3934 Write_Str_Col_Check (" */");
3935 end if;
3936
3937 -- Not a case we handle
3938
3939 else
3940 Error_Msg_N ("storage pools not supported", Node);
3941 Write_Str_Col_Check ("NULL /* new (via storage_pool) ");
3942 Cprint_Node (Expression (Node), Declaration => True);
3943 Write_Str_Col_Check (" */");
3944 end if;
3945
3946 when N_And_Then =>
3947 Cprint_Left_Opnd (Node);
3948 Write_Str (" && ");
3949 Cprint_Right_Opnd (Node);
3950
3951 -- Note: the following code for N_Aspect_Specification is not used,
3952 -- since we deal with aspects as part of a declaration.
3953
3954 when N_Aspect_Specification =>
3955 raise Program_Error;
3956
3957 when N_Assignment_Statement =>
3958 declare
3959 LHS : constant Node_Id := Name (Node);
3960 RHS : constant Node_Id := Expression (Node);
3961 Typ : constant Node_Id := Get_Full_View (Etype (LHS));
3962 Op : Character;
3963
3964 begin
3965 Write_Source_Lines (Node);
3966 Write_Indent;
3967 Write_Itypes_In_Subtree (Node);
3968
3969 -- Do not output LHS when RHS is a raise statement (to leave
3970 -- the C output cleaner).
3971
3972 if Is_Raise_Statement (RHS) then
3973 Cprint_Node (RHS);
3974
3975 elsif Ekind (Typ) in Composite_Kind
3976 or else Nkind (RHS) = N_Unchecked_Type_Conversion
3977 then
3978 -- memcpy() is only safe to use when both Forwards_OK and
3979 -- Backwards_OK are True.
3980
3981 Cprint_Copy
3982 (Target => LHS,
3983 Source => RHS,
3984 Use_Memcpy => Forwards_OK (Node)
3985 and then Backwards_OK (Node));
3986
3987 elsif Is_Access_Type (Typ)
3988 and then Has_Fat_Pointer (Typ)
3989 and then Nkind (RHS) = N_Allocator
3990 then
3991 Cprint_Node (LHS, Declaration => True);
3992 Write_Str (" = ");
3993 Write_Fatptr_Init (RHS, Typ);
3994
3995 -- Handle conversion of access-to-constrained-array type to
3996 -- access-to-unconstrained array type. The reverse case is
3997 -- handled when procesing the N_Type_Conversion node.
3998
3999 elsif Is_Access_Type (Typ)
4000 and then Has_Fat_Pointer (Typ)
4001 and then Nkind (RHS) = N_Type_Conversion
4002 and then not Has_Fat_Pointer (Etype (Expression (RHS)))
4003 then
4004 Cprint_Node (LHS, Declaration => True);
4005 Write_Str (" = ");
4006 Write_Fatptr_Init (Expression (RHS), Typ);
4007
4008 elsif Is_Access_Type (Typ)
4009 and then
4010 ((Is_Array_Formal (LHS) and then not Is_Array_Formal (RHS))
4011 or else
4012 (not Is_Array_Formal (LHS) and then Is_Array_Formal (RHS)))
4013 and then Is_Constrained_Array_Type
4014 (Get_Full_View (Designated_Type (Typ)))
4015 then
4016 Cprint_Node (LHS, Declaration => True);
4017 Write_Str (" = ");
4018
4019 if Is_Array_Formal (LHS) then
4020
4021 -- No casting needed for OUT and IN-OUT access formals
4022
4023 if Nkind (LHS) in N_Has_Entity
4024 and then Is_Out_Mode_Access_Formal (Entity (LHS))
4025 then
4026 null;
4027
4028 -- No casting needed for constrained multidimensional
4029 -- array types.
4030
4031 elsif Is_Unidimensional_Array_Type (Designated_Type (Typ))
4032 then
4033 Write_Char ('(');
4034 Write_Id
4035 (Component_Type
4036 (Get_Full_View (Designated_Type (Typ))));
4037 Write_Str ("*)");
4038 end if;
4039 else
4040 Write_Char ('(');
4041 Write_Id (Typ);
4042 Write_Char (')');
4043 end if;
4044
4045 Cprint_Node (RHS);
4046
4047 elsif Is_Access_Type (Typ)
4048 and then Is_AREC_Reference (LHS)
4049 then
4050 Cprint_Node (LHS, Declaration => True);
4051 Write_Str (" = (");
4052 Write_Id (Etype (Get_AREC_Field (LHS)));
4053 Write_Str (")");
4054 Cprint_Node (RHS);
4055
4056 else
4057 -- Use simple assignment
4058
4059 Cprint_Node (LHS, Declaration => True);
4060
4061 -- A special case, if we have X = X +/- const, convert to
4062 -- the more natural ++/-- or +=/-= notation in the C output.
4063
4064 if Is_Entity_Name (LHS)
4065 and then Nkind_In (RHS, N_Op_Add, N_Op_Subtract)
4066 and then Is_Entity_Name (Left_Opnd (RHS))
4067 and then Entity (LHS) = Entity (Left_Opnd (RHS))
4068 and then Nkind (Right_Opnd (RHS)) = N_Integer_Literal
4069 then
4070 if Nkind (RHS) = N_Op_Add then
4071 Op := '+';
4072 else
4073 Op := '-';
4074 end if;
4075
4076 if Intval (Right_Opnd (RHS)) = 1 then
4077 Write_Char (Op);
4078 Write_Char (Op);
4079 else
4080 Write_Char (' ');
4081 Write_Char (Op);
4082 Write_Str ("= ");
4083 Cprint_Node (Right_Opnd (RHS));
4084 end if;
4085
4086 elsif Is_Access_Type (Typ)
4087 and then Has_Fat_Pointer (Typ)
4088 and then Nkind (RHS) = N_Null
4089 then
4090 Write_Str (" = ");
4091 Write_Fatptr_Init (RHS, Typ);
4092
4093 elsif Is_Access_Type (Typ)
4094 and then not Has_Fat_Pointer (Typ)
4095 and then Has_Fat_Pointer (Etype (RHS))
4096 then
4097 Write_Str (" = ");
4098
4099 Write_Char ('(');
4100 Write_Id (Typ);
4101 Write_Str (") ");
4102
4103 Cprint_Node (RHS);
4104 Write_Fatptr_Dereference;
4105
4106 elsif Is_Access_Type (Typ)
4107 and then Typ /= Get_Full_View (Etype (RHS))
4108 then
4109 Write_Str (" = (");
4110 Write_Id (Typ);
4111 Write_Str (") ");
4112 Cprint_Node (RHS);
4113
4114 -- Normal case of C assignment
4115
4116 else
4117 Write_Str (" = ");
4118 Cprint_Node (RHS);
4119 end if;
4120 end if;
4121
4122 Write_Char (';');
4123 end;
4124
4125 when N_Asynchronous_Select | N_At_Clause =>
4126 raise Program_Error;
4127
4128 when N_Attribute_Definition_Clause =>
4129
4130 -- The only interesting case left after expansion is for Address
4131 -- clauses. We only deal with 'Address if the object has a Freeze
4132 -- node.
4133
4134 if Get_Attribute_Id (Chars (Node)) = Attribute_Address
4135 and then Present (Freeze_Node (Entity (Name (Node))))
4136 then
4137 if Special_Elaboration_Code then
4138 Write_Indent_Str ("_");
4139 Write_Id (Name (Node));
4140 Write_Str ("_address = ");
4141 Cprint_Node (Expression (Node));
4142 Write_Str (";");
4143
4144 else
4145 Write_Source_Lines (Node);
4146
4147 if Library_Level then
4148 Write_Indent_Str ("void *_");
4149 else
4150 Write_Indent_Str ("const void *_");
4151 end if;
4152
4153 Write_Id (Name (Node));
4154
4155 if Library_Level then
4156 Write_Str ("_address;");
4157 else
4158 Write_Str ("_address = ");
4159 Cprint_Node (Expression (Node));
4160 Write_Str (";");
4161 end if;
4162
4163 Write_Eol;
4164 Write_Str ("#define ");
4165 Write_Id (Name (Node));
4166 Write_Str (" (*(");
4167 Cprint_Node (Etype (Entity (Node)), Declaration => True);
4168 Write_Str ("*)_");
4169 Write_Id (Name (Node));
4170 Write_Str ("_address)");
4171 Write_Eol;
4172
4173 -- Record this macro so that it will be #undef'ed at the end
4174 -- of the current scope.
4175
4176 if not Library_Level then
4177 Macro_Table.Append (Name (Node));
4178 end if;
4179
4180 if Library_Level then
4181 Elaboration_Table.Append (Node);
4182 end if;
4183
4184 -- Remember that this entity is defined
4185
4186 Register_Entity (Entity (Name (Node)));
4187 end if;
4188 end if;
4189
4190 when N_Attribute_Reference =>
4191 Handle_Attribute (Node);
4192
4193 when N_Block_Statement =>
4194 Write_Source_Lines (Sloc (Node));
4195
4196 declare
4197 HSS : constant Node_Id := Handled_Statement_Sequence (Node);
4198 begin
4199 -- Detect case of dummy block with no declarations and a single
4200 -- statement. In this case we can omit the block junk.
4201
4202 if Is_Empty_List (Declarations (Node))
4203 and then List_Length (Statements (HSS)) = 1
4204 then
4205 Set_In_Statements;
4206 Cprint_Node (First (Statements (HSS)));
4207
4208 -- Normal case, we need a block
4209
4210 else
4211 Open_Scope;
4212
4213 if Present (Declarations (Node)) then
4214 Cprint_Indented_List (Declarations (Node));
4215 Write_Indent;
4216 end if;
4217
4218 Set_In_Statements;
4219 Cprint_Node (Handled_Statement_Sequence (Node));
4220
4221 Write_Indent;
4222 Close_Scope;
4223 end if;
4224
4225 -- C90 rejects declarations found after the block (therefore,
4226 -- remember that we will need to create extra blocks for them!)
4227
4228 Set_In_Statements;
4229 end;
4230
4231 when N_Body_Stub =>
4232 if Nkind_In (Node, N_Protected_Body_Stub, N_Task_Body_Stub) then
4233 raise Program_Error;
4234 end if;
4235
4236 -- No action if the separate unit is not available
4237
4238 if No (Library_Unit (Node)) then
4239 Error_Msg_N ("separate unit not available", Node);
4240 else
4241 Cprint_Node (Get_Body_From_Stub (Node));
4242 end if;
4243
4244 when N_Case_Expression =>
4245
4246 -- We should not see case expressions in a fully expanded tree,
4247 -- since they are always replaced by case statements.
4248
4249 raise Program_Error;
4250
4251 when N_Case_Expression_Alternative =>
4252 raise Program_Error;
4253
4254 when N_Case_Statement =>
4255 Write_Source_Lines (Sloc (Node), Last_Line (Expression (Node)));
4256
4257 declare
4258 Use_If : Boolean := False;
4259 Alt : Node_Id;
4260 Choice : Node_Id;
4261
4262 begin
4263 -- First we do a prescan to see if there are any ranges, if
4264 -- so, we will have to use an if/else translation since the C
4265 -- switch statement does not accomodate ranges. Note that we do
4266 -- not have to test the last alternative, since it translates
4267 -- to a default anyway without any range tests.
4268
4269 Alt := First (Alternatives (Node));
4270 Outer : while Present (Next (Alt)) loop
4271 Choice := First (Discrete_Choices (Alt));
4272 Inner : while Present (Choice) loop
4273 if Nkind (Choice) = N_Range
4274 or else (Is_Entity_Name (Choice)
4275 and then Is_Type (Entity (Choice)))
4276 then
4277 Use_If := True;
4278 exit Outer;
4279 end if;
4280
4281 Next (Choice);
4282 end loop Inner;
4283
4284 Next (Alt);
4285 end loop Outer;
4286
4287 -- Case where we have to use if's
4288
4289 if Use_If then
4290 Alt := First (Alternatives (Node));
4291 loop
4292 Write_Source_Lines
4293 (Sloc (Alt), Last_Line (Last (Discrete_Choices (Alt))));
4294
4295 -- First alternative, use if
4296
4297 if No (Prev (Alt)) then
4298 Write_Indent_Str ("if (");
4299
4300 -- All but last alternative, use else if
4301
4302 elsif Present (Next (Alt)) then
4303 Write_Indent_Str ("else if (");
4304
4305 -- Last alternative, use else and we are done
4306
4307 else
4308 Write_Indent_Str ("else ");
4309 Open_Scope;
4310 Cprint_Indented_List (Statements (Alt));
4311 Write_Source_Lines
4312 (Sloc (Node) +
4313 Text_Ptr (UI_To_Int (End_Span (Node))));
4314 Close_Scope;
4315 exit;
4316 end if;
4317
4318 Choice := First (Discrete_Choices (Alt));
4319 loop
4320 -- Simple expression, equality test
4321
4322 if not Nkind_In (Choice, N_Range, N_Subtype_Indication)
4323 and then (not Is_Entity_Name (Choice)
4324 or else not Is_Type (Entity (Choice)))
4325 then
4326 Cprint_Node (Expression (Node));
4327 Write_Str (" == ");
4328 Cprint_Node (Choice);
4329
4330 -- Range, do range test
4331
4332 else
4333 declare
4334 LBD : Node_Id;
4335 HBD : Node_Id;
4336
4337 begin
4338 case Nkind (Choice) is
4339 when N_Range =>
4340 LBD := Low_Bound (Choice);
4341 HBD := High_Bound (Choice);
4342
4343 when N_Subtype_Indication =>
4344 pragma Assert
4345 (Nkind (Constraint (Choice)) =
4346 N_Range_Constraint);
4347
4348 LBD :=
4349 Low_Bound (Range_Expression
4350 (Constraint (Choice)));
4351 HBD :=
4352 High_Bound (Range_Expression
4353 (Constraint (Choice)));
4354
4355 when others =>
4356 LBD := Type_Low_Bound (Entity (Choice));
4357 HBD := Type_High_Bound (Entity (Choice));
4358 end case;
4359
4360 Write_Char ('(');
4361 Cprint_Node (Expression (Node));
4362 Write_Str (" >= ");
4363 Write_Uint (Expr_Value (LBD));
4364 Write_Str (" && ");
4365 Cprint_Node (Expression (Node));
4366 Write_Str (" <= ");
4367 Write_Uint (Expr_Value (HBD));
4368 Write_Char (')');
4369 end;
4370 end if;
4371
4372 if Present (Next (Choice)) then
4373 Write_Str_Col_Check (" || ");
4374 Next (Choice);
4375 else
4376 exit;
4377 end if;
4378 end loop;
4379
4380 Write_Str (") ");
4381 Open_Scope;
4382 Cprint_Indented_List (Statements (Alt));
4383 Write_Indent;
4384 Close_Scope;
4385
4386 Next (Alt);
4387 end loop;
4388
4389 -- Case where we can use Switch
4390
4391 else
4392 Write_Indent_Str ("switch (");
4393 Cprint_Node (Expression (Node));
4394 Write_Str (") ");
4395 Open_Scope;
4396 Cprint_Indented_List (Alternatives (Node));
4397 Write_Source_Lines
4398 (Sloc (Node) + Text_Ptr (UI_To_Int (End_Span (Node))));
4399 Write_Indent;
4400 Close_Scope;
4401 end if;
4402 end;
4403
4404 when N_Case_Statement_Alternative =>
4405 Write_Source_Lines
4406 (Sloc (Node), Last_Line (Last (Discrete_Choices (Node))));
4407
4408 declare
4409 Choices : constant List_Id := Discrete_Choices (Node);
4410 Choice : Node_Id;
4411 Default : Boolean := False;
4412 Extra_Block : Boolean := False;
4413
4414 begin
4415 Choice := First (Choices);
4416 while Present (Choice) loop
4417 if Nkind (Choice) = N_Others_Choice then
4418 Write_Indent_Str ("default:");
4419 Default := True;
4420 else
4421 Write_Indent_Str ("case ");
4422 Cprint_Node (Choice);
4423 Write_Str (":");
4424 end if;
4425
4426 Next (Choice);
4427 end loop;
4428
4429 if Has_Non_Null_Statements (Statements (Node)) then
4430 if List_Length (Statements (Node)) > 1
4431 or else Nkind (First (Statements (Node))) =
4432 N_Object_Declaration
4433 then
4434 Write_Char (' ');
4435 Open_Scope;
4436 Extra_Block := True;
4437 end if;
4438
4439 Cprint_Indented_List (Statements (Node));
4440
4441 elsif Default then
4442 Write_Str (" /* No statement */");
4443 end if;
4444
4445 if Extra_Block then
4446 Write_Char (' ');
4447 Close_Scope;
4448 end if;
4449
4450 Indent_Begin;
4451 Write_Indent_Str ("break;");
4452 Indent_End;
4453 end;
4454
4455 when N_Character_Literal =>
4456 if Column > Sprint_Line_Limit - 2 then
4457 Write_Indent_Str (" ");
4458 end if;
4459
4460 -- If an Entity is present, it means that this was one of the
4461 -- literals in a user-defined character type. In that case, return
4462 -- the Enumeration_Rep of the entity. Otherwise, use the character
4463 -- code.
4464
4465 if Present (Entity (Node)) then
4466 Write_Uint (Enumeration_Rep (Entity (Node)));
4467 else
4468 Write_Char (''');
4469 Write_C_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
4470 Write_Char (''');
4471 end if;
4472
4473 when N_Code_Statement =>
4474 Write_Source_Lines (Node);
4475
4476 Write_Indent;
4477 Cprint_Node (Expression (Node));
4478 Write_Char (';');
4479
4480 when N_Compilation_Unit =>
4481 Cprint_Node_List (Context_Items (Node));
4482 Cprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
4483 Cprint_Node (Unit (Node));
4484
4485 if Present (Actions (Aux_Decls_Node (Node)))
4486 or else Present (Pragmas_After (Aux_Decls_Node (Node)))
4487 then
4488 Write_Indent;
4489 end if;
4490
4491 Cprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
4492 Cprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
4493
4494 when N_Compilation_Unit_Aux =>
4495 null; -- nothing to do, never used, see above
4496
4497 when N_Component_Association =>
4498 Cprint_Node (Expression (Node));
4499
4500 when N_Component_Clause =>
4501 raise Program_Error;
4502
4503 when N_Component_Definition =>
4504
4505 -- ???
4506 -- Ada 2005 (AI-230): Access definition components
4507
4508 if Present (Access_Definition (Node)) then
4509 Cprint_Node (Access_Definition (Node), Declaration => True);
4510 else
4511 pragma Assert (Present (Subtype_Indication (Node)));
4512
4513 -- Ada 2005 (AI-231)
4514
4515 Cprint_Node (Subtype_Indication (Node), Declaration => True);
4516 end if;
4517
4518 when N_Component_Declaration =>
4519 raise Program_Error;
4520
4521 when N_Component_List =>
4522
4523 -- ???
4524
4525 if Null_Present (Node) then
4526 Indent_Begin;
4527 Write_Indent_Str ("null");
4528 Write_Char (';');
4529 Indent_End;
4530
4531 else
4532 Cprint_Indented_List (Component_Items (Node));
4533 Cprint_Node (Variant_Part (Node), Declaration => True);
4534 end if;
4535
4536 when N_Compound_Statement =>
4537 if Is_Non_Empty_List (Actions (Node)) then
4538 Write_Char ('(');
4539 Cprint_Comma_List (Actions (Node));
4540 Write_Char (')');
4541 end if;
4542
4543 when N_Conditional_Entry_Call |
4544 N_Constrained_Array_Definition |
4545 N_Contract |
4546 N_Decimal_Fixed_Point_Definition
4547 =>
4548 raise Program_Error;
4549
4550 when N_Defining_Character_Literal =>
4551
4552 -- For enumeration literals of enumeration types that have a
4553 -- representation clause use directly their value.
4554
4555 if Ekind (Node) = E_Enumeration_Literal
4556 and then
4557 Has_Enumeration_Rep_Clause (Get_Full_View (Etype (Node)))
4558 then
4559 Write_Uint (Enumeration_Rep (Node));
4560 else
4561 Write_Name_Col_Check (Chars (Ultimate_Alias (Node)));
4562 end if;
4563
4564 when N_Defining_Identifier =>
4565
4566 -- Replace constant references by the direct values, to avoid
4567 -- a level of indirection for e.g. private values, and since
4568 -- we are not trying to generate human readable code, losing
4569 -- the reference to the constant object is not a problem. In
4570 -- addition, this allows generation of static values and static
4571 -- aggregates.
4572
4573 if Ekind (Node) = E_Constant
4574 and then not Declaration
4575 and then Is_Scalar_Type (Get_Full_View (Etype (Node)))
4576 then
4577 declare
4578 N : constant Node_Id := Get_Full_View (Node);
4579 Decl : constant Node_Id := Declaration_Node (N);
4580 Expr : Node_Id := Empty;
4581
4582 begin
4583 if Nkind (Decl) /= N_Object_Renaming_Declaration then
4584 Expr := Expression (Decl);
4585 end if;
4586
4587 if Present (Expr)
4588 and then Nkind_In (Expr, N_Character_Literal,
4589 N_Expanded_Name,
4590 N_Integer_Literal,
4591 N_Real_Literal)
4592 then
4593
4594 -- Add a cast to System.Address to avoid mismatch between
4595 -- integer and pointer.
4596
4597 if Is_Descendant_Of_Address (Etype (N)) then
4598 Write_Str ("(system__address)");
4599 end if;
4600
4601 Cprint_Node (Expr);
4602
4603 elsif Present (Expr)
4604 and then Nkind (Expr) = N_Identifier
4605 and then Ekind (Entity (Expr)) = E_Enumeration_Literal
4606 then
4607 Write_Uint (Enumeration_Rep (Entity (Expr)));
4608 else
4609 Write_Id (N);
4610 end if;
4611 end;
4612
4613 elsif Is_Formal (Node)
4614 and then Is_Unconstrained_Array_Type (Etype (Node))
4615 and then Present (Activation_Record_Component (Node))
4616 and then Present (Current_Subp_Entity)
4617 and then not Within_Scope (Node, Current_Subp_Entity)
4618 then
4619 Write_Up_Level_Formal_Reference
4620 (Subp => Current_Subp_Entity,
4621 Formal => Node);
4622
4623 -- For enumeration literals defined in the enclosing scope of a
4624 -- nested subprogram we directly generate their values. Thus, we
4625 -- avoid the need to duplicate the declaration of the enum in the
4626 -- enclosing subprograms.
4627
4628 elsif Is_Enum_Literal_Of_Enclosing_Subprogram (Node) then
4629 Write_Uint (Enumeration_Rep (Node));
4630
4631 -- For enumeration literals of enumeration types that have a
4632 -- representation clause use directly their value.
4633
4634 elsif Ekind (Node) = E_Enumeration_Literal
4635 and then Has_Or_Inherits_Enum_Rep_Clause (Etype (Node))
4636 then
4637 Write_Uint (Enumeration_Rep (Node));
4638
4639 else
4640 Write_Id (Node);
4641 end if;
4642
4643 when N_Defining_Operator_Symbol =>
4644 Write_Name_Col_Check (Chars (Node));
4645
4646 when N_Defining_Program_Unit_Name =>
4647 Cprint_Node (Defining_Identifier (Node));
4648
4649 when N_Delay_Alternative |
4650 N_Delay_Relative_Statement |
4651 N_Delay_Until_Statement
4652 =>
4653 raise Program_Error; -- should not occur in generated code
4654
4655 when N_Delta_Constraint =>
4656
4657 -- ???
4658
4659 Write_Str_Col_Check ("delta ");
4660 Cprint_Node (Delta_Expression (Node));
4661 Cprint_Opt_Node (Range_Constraint (Node));
4662
4663 when N_Derived_Type_Definition =>
4664
4665 -- ???
4666
4667 if Abstract_Present (Node) then
4668 Write_Str_Col_Check ("abstract ");
4669 end if;
4670
4671 Write_Str_Col_Check ("new ");
4672
4673 Cprint_Node (Subtype_Indication (Node), Declaration => True);
4674
4675 if Present (Interface_List (Node)) then
4676 Write_Str_Col_Check (" and ");
4677 Cprint_And_List (Interface_List (Node));
4678 Write_Str_Col_Check (" with ");
4679 end if;
4680
4681 if Present (Record_Extension_Part (Node)) then
4682 if No (Interface_List (Node)) then
4683 Write_Str_Col_Check (" with ");
4684 end if;
4685
4686 Cprint_Node (Record_Extension_Part (Node), Declaration => True);
4687 end if;
4688
4689 when N_Designator | N_Digits_Constraint =>
4690 raise Program_Error;
4691
4692 when N_Discriminant_Association =>
4693
4694 -- ???
4695
4696 if Present (Selector_Names (Node)) then
4697 Cprint_Bar_List (Selector_Names (Node));
4698 Write_Str (" => ");
4699 end if;
4700
4701 Cprint_Node (Expression (Node));
4702
4703 when N_Discriminant_Specification =>
4704
4705 -- ???
4706
4707 Cprint_Node (Discriminant_Type (Node), Declaration => True);
4708 Write_Char (' ');
4709 Cprint_Node (Defining_Identifier (Node), Declaration => True);
4710
4711 if Present (Expression (Node)) then
4712 Write_Str (" = ");
4713 Cprint_Node (Expression (Node));
4714 end if;
4715
4716 when N_Elsif_Part =>
4717 Write_Source_Lines (Sloc (Node), Last_Line (Condition (Node)));
4718 Write_Indent_Str ("else if (");
4719 Cprint_Node (Condition (Node));
4720 Write_Char (')');
4721
4722 Write_Char (' ');
4723 Open_Scope;
4724 Cprint_Indented_List (Then_Statements (Node));
4725 Write_Indent;
4726 Close_Scope;
4727
4728 when N_Empty =>
4729 null;
4730
4731 when N_Entry_Body |
4732 N_Entry_Body_Formal_Part |
4733 N_Entry_Call_Alternative |
4734 N_Entry_Call_Statement |
4735 N_Entry_Declaration |
4736 N_Entry_Index_Specification
4737 =>
4738 raise Program_Error; -- should not occur in generated code
4739
4740 when N_Enumeration_Representation_Clause |
4741 N_Enumeration_Type_Definition
4742 =>
4743 null; -- not output in C code
4744
4745 when N_Error =>
4746 Write_Str_Col_Check ("<error>");
4747
4748 when N_Exception_Handler =>
4749 null; -- not output in C code
4750
4751 when N_Exception_Declaration |
4752 N_Exception_Renaming_Declaration
4753 =>
4754 if not In_Declarations then
4755 Open_Extra_Scope;
4756 end if;
4757
4758 Write_Source_Lines (Node);
4759 Write_Indent;
4760
4761 if not In_Main_Unit then
4762 Write_Str ("extern ");
4763 end if;
4764
4765 Write_Str ("void* ");
4766 Cprint_Node (Defining_Identifier (Node));
4767 Write_Char (';');
4768
4769 -- Remember that this entity is defined
4770
4771 Register_Entity (Defining_Identifier (Node));
4772
4773 when N_Exit_Statement =>
4774 Write_Source_Lines (Node);
4775
4776 if Present (Condition (Node)) then
4777 Write_Indent_Str ("if (");
4778 Cprint_Node (Condition (Node));
4779 Write_Str (") ");
4780 Open_Scope;
4781 Indent_Begin;
4782 end if;
4783
4784 if No (Name (Node)) then
4785 Write_Indent_Str ("break;");
4786 else
4787 Write_Indent_Str ("goto ");
4788 Cprint_Node (Name (Node), Declaration => True);
4789 Write_Char (';');
4790 end if;
4791
4792 if Present (Condition (Node)) then
4793 Indent_End;
4794 Write_Indent;
4795 Close_Scope;
4796 end if;
4797
4798 when N_Expanded_Name =>
4799
4800 -- At this stage, all names should have been expanded, so any
4801 -- remaining expanded names can be handled via their Entity.
4802
4803 Cprint_Node (Entity (Node), Declaration);
4804
4805 when N_Explicit_Dereference =>
4806
4807 -- For subprogram types we generate a typedef and hence the
4808 -- explicit dereference is not needed.
4809
4810 if Ekind (Etype (Node)) = E_Subprogram_Type then
4811 null;
4812
4813 -- When the prefix of the explicit dereference is a reference to
4814 -- a multidimensional array formal we must not generate C code to
4815 -- dereference the pointer, because the formal has been defined in
4816 -- the profile of the C function as a C array (it is not defined
4817 -- as a pointer to the component).
4818
4819 elsif Is_Array_Formal (Prefix (Node))
4820 and then not
4821 Is_Unconstrained_Array_Type (Etype (Prefix (Node)))
4822 and then not
4823 Is_Unidimensional_Array_Type (Etype (Prefix (Node)))
4824 then
4825 null;
4826
4827 elsif Has_Fat_Pointer (Etype (Node))
4828 and then not Is_Access_Type (Etype (Node))
4829 then
4830 null;
4831
4832 else
4833 Write_Char ('*');
4834 end if;
4835
4836 Cprint_Node_Paren (Prefix (Node));
4837
4838 when N_Expression_With_Actions =>
4839 if Is_Non_Empty_List (Actions (Node)) then
4840
4841 -- Map N_Expression_With_Actions to a compound statement if it
4842 -- is simple enough, otherwise use a braced-group.
4843
4844 if Compound_Statement_Compatible (Actions (Node)) then
4845 declare
4846 Saved_In_Compound_Statement : constant Boolean :=
4847 In_Compound_Statement;
4848
4849 begin
4850 Write_Char ('(');
4851 In_Compound_Statement := True;
4852
4853 if Cprint_Comma_List (Actions (Node)) /= 0 then
4854 Write_Str (", ");
4855 end if;
4856
4857 In_Compound_Statement := Saved_In_Compound_Statement;
4858 Cprint_Node (Expression (Node));
4859 Write_Char (')');
4860 end;
4861
4862 else
4863 declare
4864 ESA_Value : constant Boolean := Extra_Scopes_Allowed;
4865
4866 begin
4867 -- Disable the support for generating extra scopes in
4868 -- this construct since they cause errors.
4869
4870 Extra_Scopes_Allowed := False;
4871
4872 -- Emit a warning about the nonportable construct, so
4873 -- that users will not be surprised to get an error on
4874 -- various non-GCC compilers.
4875
4876 Error_Msg_N
4877 ("?requires non-portable C construct: " &
4878 "braced-groups within expressions", Node);
4879
4880 Write_Str ("({");
4881 Cprint_Indented_List (Actions (Node));
4882
4883 if Last_Char /= ';' then
4884 Write_Char (';');
4885 end if;
4886
4887 Indent_Begin;
4888 Write_Indent;
4889 Cprint_Node (Expression (Node));
4890 Write_Str ("; })");
4891 Indent_End;
4892
4893 -- Restore the support for generating extra scopes
4894
4895 Extra_Scopes_Allowed := ESA_Value;
4896 end;
4897 end if;
4898 else
4899 Cprint_Node (Expression (Node));
4900 end if;
4901
4902 when N_Expression_Function =>
4903 Write_Indent;
4904 Cprint_Node (Specification (Node), Declaration => True);
4905 Write_Char (' ');
4906 Open_Scope;
4907 Indent_Begin;
4908 Write_Indent;
4909 Write_Str ("return ");
4910 Cprint_Node (Expression (Node));
4911 Write_Char (';');
4912 Indent_End;
4913 Close_Scope;
4914
4915 when N_Extended_Return_Statement =>
4916 raise Program_Error;
4917
4918 when N_Extension_Aggregate =>
4919
4920 -- ???
4921
4922 Write_Str_Col_Check ("(");
4923 Cprint_Node (Ancestor_Part (Node), Declaration => True);
4924 Write_Str_Col_Check (" with ");
4925
4926 if Null_Record_Present (Node) then
4927 Write_Str_Col_Check ("null record");
4928 else
4929 if Present (Expressions (Node)) then
4930 Cprint_Comma_List (Expressions (Node));
4931
4932 if Present (Component_Associations (Node)) then
4933 Write_Str (", ");
4934 end if;
4935 end if;
4936
4937 if Present (Component_Associations (Node)) then
4938 Cprint_Comma_List (Component_Associations (Node));
4939 end if;
4940 end if;
4941
4942 Write_Char (')');
4943
4944 when N_Floating_Point_Definition |
4945 N_Formal_Decimal_Fixed_Point_Definition |
4946 N_Formal_Derived_Type_Definition |
4947 N_Formal_Abstract_Subprogram_Declaration |
4948 N_Formal_Concrete_Subprogram_Declaration |
4949 N_Formal_Discrete_Type_Definition |
4950 N_Formal_Floating_Point_Definition |
4951 N_Formal_Modular_Type_Definition |
4952 N_Formal_Object_Declaration |
4953 N_Formal_Ordinary_Fixed_Point_Definition |
4954 N_Formal_Package_Declaration |
4955 N_Formal_Private_Type_Definition |
4956 N_Formal_Incomplete_Type_Definition |
4957 N_Formal_Signed_Integer_Type_Definition |
4958 N_Formal_Type_Declaration
4959 =>
4960 null; -- not output in C code
4961
4962 when N_Free_Statement =>
4963 Write_Source_Lines (Node);
4964 Write_Indent_Str ("free(");
4965 Cprint_Node (Expression (Node), Declaration => True);
4966 Write_Str (");");
4967
4968 when N_Freeze_Entity =>
4969 Freeze_Level := Freeze_Level + 1;
4970 Cprint_Node_List (Actions (Node));
4971 Freeze_Level := Freeze_Level - 1;
4972
4973 when N_Freeze_Generic_Entity =>
4974 null; -- not output in C code
4975
4976 when N_Full_Type_Declaration =>
4977 Write_Source_Lines (Node);
4978 Write_Itypes_In_Subtree (Node);
4979
4980 declare
4981 procedure Check_Components
4982 (Clist : Node_Id;
4983 Allow_Last_Field : Boolean);
4984 -- Check validity of components in Clist. Emit an error if a
4985 -- type whose size depends on a discriminant is found, unless
4986 -- Allow_Last_Field is True and this is the type of the last
4987 -- field in a record.
4988
4989 ----------------------
4990 -- Check_Components --
4991 ----------------------
4992
4993 procedure Check_Components
4994 (Clist : Node_Id;
4995 Allow_Last_Field : Boolean)
4996 is
4997 Comp : Node_Id;
4998 Comp2 : Node_Id;
4999 Disc : Node_Id;
5000 Discs : List_Id;
5001
5002 begin
5003 Comp := First (Component_Items (Clist));
5004 Comp_Loop : while Present (Comp) loop
5005 if Nkind (Comp) = N_Component_Declaration then
5006
5007 -- Check type of component
5008
5009 if Size_Depends_On_Discriminant
5010 (Get_Full_View
5011 (Etype (Defining_Identifier (Comp))))
5012 then
5013 if Allow_Last_Field then
5014 Discs := Discriminant_Specifications (Node);
5015
5016 if Present (Discs) then
5017 Disc := First (Discs);
5018 while Present (Disc) loop
5019 if Present (Expression (Disc)) then
5020 Error_Msg_N
5021 ("unsupported type: discriminant " &
5022 "with default value", Disc);
5023 exit;
5024 end if;
5025
5026 Next (Disc);
5027 end loop;
5028 end if;
5029
5030 Comp2 := Comp;
5031
5032 loop
5033 Next (Comp2);
5034
5035 exit when No (Comp2);
5036
5037 if Nkind (Comp2) = N_Component_Declaration
5038 then
5039 Error_Msg_N
5040 ("unsupported type: only the last field "
5041 & "may depend on a discriminant", Comp);
5042 exit Comp_Loop;
5043 end if;
5044 end loop;
5045 else
5046 Error_Msg_N
5047 ("unsupported type: field in variant part " &
5048 "cannot depend on a discriminant", Comp);
5049 end if;
5050
5051 exit Comp_Loop;
5052 end if;
5053 end if;
5054
5055 Next (Comp);
5056 end loop Comp_Loop;
5057
5058 if Present (Variant_Part (Clist)) then
5059 Comp := First (Variants (Variant_Part (Clist)));
5060
5061 while Present (Comp) loop
5062 Check_Components
5063 (Component_List (Comp), Allow_Last_Field => False);
5064 Next (Comp);
5065 end loop;
5066 end if;
5067 end Check_Components;
5068
5069 -- Local variables
5070
5071 Typ : constant Entity_Id := Defining_Identifier (Node);
5072
5073 begin
5074 -- If this is a first subtype, and base type is not the same as
5075 -- the first subtype, output a typedef for that as well.
5076
5077 if Is_First_Subtype (Typ) and then Base_Type (Typ) /= Typ then
5078 Cprint_Declare (Base_Type (Typ));
5079 end if;
5080
5081 if Has_Discriminants (Typ) then
5082
5083 -- Check that this is a supported type, for now:
5084 -- only the last field may depend on a discriminant (with
5085 -- no default value), so that we can map this type to a C
5086 -- type:
5087 -- typedef struct _<name> {
5088 -- field1;
5089 -- ...
5090 -- <type> last_field[1];
5091 -- } <name>;
5092
5093 Check_Components
5094 (Component_List (Type_Definition (Node)),
5095 Allow_Last_Field => True);
5096 end if;
5097
5098 -- Now the typedef for the type itself
5099
5100 Cprint_Declare (Typ);
5101
5102 if Is_Packed_Array (Typ) then
5103 Cprint_Declare (Packed_Array_Impl_Type (Typ));
5104 end if;
5105 end;
5106
5107 when N_Function_Call =>
5108 Cprint_Call (Node);
5109
5110 when N_Function_Instantiation =>
5111 null; -- not output in C code
5112
5113 when N_Function_Specification =>
5114 declare
5115 Designator : constant Entity_Id :=
5116 Unique_Defining_Entity (Node);
5117 Typ : constant Entity_Id := Etype (Designator);
5118
5119 begin
5120 Append_Subprogram_Prefix (Node);
5121 Declare_Subprogram_Types (Node);
5122
5123 if not Is_Public (Designator) then
5124 Write_Str_Col_Check ("static ");
5125 elsif Declaration then
5126 Write_Str_Col_Check ("extern ");
5127 end if;
5128
5129 if Is_Unconstrained_Array_Type (Typ) then
5130 Error_Msg_N
5131 ("function returning unconstrained arrays not "
5132 & "supported!!??", Result_Definition (Node));
5133 Write_Fatptr_Name (Typ);
5134 Write_Char (' ');
5135
5136 else
5137 Check_Definition (Typ,
5138 Error_Node => Result_Definition (Node));
5139 Cprint_Type_Name (Typ);
5140 Write_Char (' ');
5141 end if;
5142 end;
5143
5144 Cprint_Node (Defining_Unit_Name (Node), Declaration => True);
5145 Write_Param_Specs (Node);
5146
5147 -- Remember that this entity is defined
5148
5149 Register_Entity (Defining_Unit_Name (Node));
5150
5151 when N_Generic_Association |
5152 N_Generic_Function_Renaming_Declaration |
5153 N_Generic_Package_Declaration |
5154 N_Generic_Package_Renaming_Declaration |
5155 N_Generic_Procedure_Renaming_Declaration |
5156 N_Generic_Subprogram_Declaration
5157 =>
5158 if Nkind (Parent (Node)) = N_Compilation_Unit then
5159 Set_Has_No_Elaboration_Code (Parent (Node), True);
5160 end if;
5161
5162 when N_Goto_Statement =>
5163 Write_Source_Lines (Node);
5164 Write_Indent_Str ("goto ");
5165 Cprint_Node (Name (Node), Declaration => True);
5166 Write_Char (';');
5167
5168 if Nkind (Next (Node)) = N_Label then
5169 Write_Indent;
5170 end if;
5171
5172 when N_Handled_Sequence_Of_Statements =>
5173 declare
5174 Saved_Value : constant Boolean := In_Package_Body_Init;
5175
5176 begin
5177 In_Package_Body_Init :=
5178 Nkind (Parent (Node)) = N_Package_Body;
5179
5180 Cprint_Indented_List (Statements (Node));
5181
5182 if not Is_Empty_List (Exception_Handlers (Node)) then
5183 Error_Msg_N
5184 ("??exception handlers are ignored",
5185 First (Exception_Handlers (Node)));
5186 end if;
5187
5188 if Present (At_End_Proc (Node)) then
5189 Error_Msg_N
5190 ("clean up procedures not supported yet",
5191 At_End_Proc (Node));
5192 end if;
5193
5194 In_Package_Body_Init := Saved_Value;
5195 end;
5196
5197 when N_Identifier =>
5198
5199 -- If reference to parameter passed by pointer, add deference
5200
5201 if Is_Formal (Entity (Node))
5202 and then Pass_Pointer (Entity (Node))
5203 then
5204 Write_Str ("(*");
5205 Write_Id (Node);
5206 Write_Char (')');
5207
5208 -- Replace constant identifier by its expression when relevant
5209
5210 elsif not Declaration
5211 and then Nkind (Node) in N_Subexpr
5212 and then Nkind (Parent (Node)) /= N_Attribute_Reference
5213 then
5214 if Nkind_In (Node, N_Identifier,
5215 N_Type_Conversion,
5216 N_Unchecked_Type_Conversion)
5217 then
5218 Check_Definition (Node);
5219 end if;
5220
5221 Cprint_Node (Entity (Node));
5222
5223 else
5224 Check_Definition (Node);
5225 Write_Id (Node);
5226 end if;
5227
5228 when N_If_Expression =>
5229 declare
5230 Condition : constant Node_Id := First (Expressions (Node));
5231 Then_Expr : constant Node_Id := Next (Condition);
5232 Else_Expr : constant Node_Id := Next (Then_Expr);
5233
5234 begin
5235 Write_Char ('(');
5236 Cprint_Node (Condition);
5237 Write_Str (") ? ");
5238 Cprint_Node_Paren (Then_Expr);
5239 Write_Str (" : ");
5240 Cprint_Node_Paren (Else_Expr);
5241 end;
5242
5243 when N_If_Statement =>
5244 Write_Source_Lines (Sloc (Node), Last_Line (Condition (Node)));
5245
5246 if In_Compound_Statement then
5247 Write_Char ('(');
5248 Cprint_Node (Condition (Node));
5249 Write_Str (") ? (");
5250 Cprint_Comma_List (Then_Statements (Node));
5251 Write_Str (") : ");
5252
5253 if Present (Elsif_Parts (Node)) then
5254 declare
5255 Elsif_Part : Node_Id := First (Elsif_Parts (Node));
5256 begin
5257 loop
5258 Write_Char ('(');
5259 Cprint_Node (Condition (Elsif_Part));
5260 Write_Str (") ? (");
5261 Cprint_Comma_List (Then_Statements (Elsif_Part));
5262 Write_Str (") : ");
5263
5264 Next (Elsif_Part);
5265 exit when No (Elsif_Part);
5266 end loop;
5267 end;
5268 end if;
5269
5270 if Present (Else_Statements (Node)) then
5271 Write_Char ('(');
5272 Cprint_Comma_List (Else_Statements (Node));
5273 Write_Char (')');
5274 else
5275 -- Complete by a dummy value since if-expressions in C
5276 -- require an else part.
5277
5278 Write_Char ('0');
5279 end if;
5280 else
5281 Write_Indent_Str ("if (");
5282 Cprint_Node (Condition (Node));
5283 Write_Str_Col_Check (")");
5284
5285 Write_Char (' ');
5286 Open_Scope;
5287 Cprint_Indented_List (Then_Statements (Node));
5288
5289 if No (Elsif_Parts (Node))
5290 and then No (Else_Statements (Node))
5291 then
5292 Write_Source_Lines
5293 (Sloc (Node) + Text_Ptr (UI_To_Int (End_Span (Node))));
5294 end if;
5295
5296 Write_Indent;
5297 Close_Scope;
5298
5299 Cprint_Opt_Node_List (Elsif_Parts (Node));
5300
5301 if Present (Else_Statements (Node)) then
5302
5303 -- Guess where ELSE keyword is
5304
5305 declare
5306 FES : constant Physical_Line_Number :=
5307 First_Line (First (Else_Statements (Node)));
5308 begin
5309 if FES /= No_Physical_Line_Number then
5310 Write_Source_Lines (FES - 1, FES - 1);
5311 end if;
5312 end;
5313
5314 Write_Indent_Str ("else ");
5315 Open_Scope;
5316 Cprint_Indented_List (Else_Statements (Node));
5317
5318 Write_Source_Lines
5319 (Sloc (Node) + Text_Ptr (UI_To_Int (End_Span (Node))));
5320 Write_Indent;
5321 Close_Scope;
5322 end if;
5323 end if;
5324
5325 when N_Implicit_Label_Declaration =>
5326 null; -- not output in C code
5327
5328 when N_In =>
5329 if Present (Right_Opnd (Node)) then
5330 declare
5331 Rng : Node_Id := Right_Opnd (Node);
5332 begin
5333 if Nkind (Rng) = N_Identifier then
5334 Rng := Scalar_Range (Etype (Rng));
5335 end if;
5336
5337 Cprint_Left_Opnd (Node);
5338 Write_Str (" >= ");
5339 Cprint_Node (Low_Bound (Rng));
5340 Write_Str (" && ");
5341 Cprint_Left_Opnd (Node);
5342 Write_Str (" <= ");
5343 Cprint_Node (High_Bound (Rng));
5344 end;
5345 else
5346 Cprint_Bar_List (Alternatives (Node));
5347 end if;
5348
5349 when N_Incomplete_Type_Declaration |
5350 N_Index_Or_Discriminant_Constraint
5351 =>
5352 null; -- not output in C code
5353
5354 when N_Indexed_Component =>
5355 declare
5356 Pref : constant Node_Id := Ultimate_Expression (Prefix (Node));
5357
5358 begin
5359 -- For unidimensional arrays we directly use the pointer to the
5360 -- array components.
5361
5362 if Is_Unidimensional_Array_Type (Etype (Pref)) then
5363 if Is_Unconstrained_Array_Formal (Pref) then
5364 Write_Unconstrained_Array_Prefix (Pref);
5365
5366 -- Generate the standard C array index (i.e. arr[n])
5367
5368 elsif Is_Array_Formal (Pref) then
5369 Write_Char ('(');
5370 Cprint_Node (Pref);
5371 Write_Char (')');
5372
5373 elsif Nkind (Pref) = N_Explicit_Dereference then
5374 if Is_Unconstrained_Array_Type (Etype (Pref)) then
5375 Write_Unconstrained_Array_Prefix (Pref);
5376 else
5377 Write_Str ("(*");
5378 Cprint_Node_Paren (Prefix (Pref));
5379 Write_Char (')');
5380 end if;
5381
5382 else
5383 Cprint_Node_Paren (Pref);
5384 end if;
5385
5386 -- For multidimensional arrays we generate code that relies on
5387 -- the itype. This is not supported under ISO C90.
5388
5389 else
5390 if Is_Unconstrained_Array_Formal (Pref) then
5391 Write_Unconstrained_Array_Prefix (Pref);
5392
5393 elsif Is_Array_Formal (Pref) then
5394 Cprint_Node (Pref);
5395
5396 elsif Nkind (Pref) = N_Explicit_Dereference then
5397 if Is_Unconstrained_Array_Type (Etype (Pref)) then
5398 Write_Fatptr_Indexed_Component (Node);
5399
5400 -- No further code needed here since the previous call
5401 -- generates code which displaces the pointer to
5402 -- reference the indexed component.
5403
5404 goto Leave;
5405 else
5406 Write_Str ("(*");
5407 Cprint_Node_Paren (Prefix (Pref));
5408 Write_Char (')');
5409 end if;
5410 else
5411 Cprint_Node_Paren (Pref);
5412 end if;
5413 end if;
5414 end;
5415
5416 declare
5417 Pref : constant Node_Id := Prefix (Node);
5418 Typ : constant Node_Id := Get_Full_View (Etype (Pref));
5419 Idx : Nat;
5420 Ind : Node_Id;
5421 Sub : Node_Id;
5422
5423 Unconstr_Array_Prefix : Entity_Id := Empty;
5424
5425 begin
5426 if not Is_Constrained (Typ) then
5427 if Nkind (Pref) in N_Has_Entity
5428 and then Present (Entity (Pref))
5429 then
5430 Unconstr_Array_Prefix := Entity (Pref);
5431
5432 elsif Nkind (Pref) = N_Explicit_Dereference
5433 and then Nkind (Prefix (Pref)) in N_Has_Entity
5434 and then Present (Entity (Prefix (Pref)))
5435 then
5436 Unconstr_Array_Prefix := Entity (Prefix (Pref));
5437
5438 else
5439 Error_Msg_N
5440 ("unsupported kind of unconstrained array access",
5441 Node);
5442 end if;
5443 end if;
5444
5445 Sub := First (Expressions (Node));
5446 Ind := First_Index (Typ);
5447 Idx := 1;
5448
5449 loop
5450 Write_Char ('[');
5451
5452 if Present (Unconstr_Array_Prefix) then
5453 Cprint_Node (Sub);
5454 Write_Str_Col_Check (" - ");
5455
5456 -- Reference '.first' in the fat pointer
5457
5458 Cprint_Node (Unconstr_Array_Prefix);
5459 Write_Str (".");
5460 Write_Fatptr_First (Typ, Idx);
5461
5462 elsif Ekind (Typ) = E_String_Literal_Subtype then
5463 Cprint_Difference
5464 (Sub, String_Literal_Low_Bound (Typ),
5465 Minus_One_Min => False);
5466
5467 else
5468 Cprint_Difference
5469 (Sub, Type_Low_Bound (Etype (Ind)),
5470 Minus_One_Min => False);
5471 end if;
5472
5473 Write_Char (']');
5474 Next (Sub);
5475 exit when No (Sub);
5476 Next_Index (Ind);
5477 Idx := Idx + 1;
5478 end loop;
5479 end;
5480
5481 <<Leave>>
5482 null;
5483
5484 when N_Integer_Literal =>
5485
5486 -- Note: do not bother with writing in hex in C output for now
5487
5488 Write_Uint
5489 (U => Intval (Node),
5490 Modular => Is_Modular_Integer_Type (Etype (Node)));
5491
5492 when N_Iteration_Scheme =>
5493 raise Program_Error; -- handled as part of loop handling
5494
5495 when N_Iterator_Specification =>
5496
5497 -- Temporarily reporting an error on this kind of node since we
5498 -- have not tested yet this code???
5499
5500 Error_Msg_N ("unsupported kind of iterator", Node);
5501
5502 Write_Id (Defining_Identifier (Node));
5503
5504 if Present (Subtype_Indication (Node)) then
5505 Write_Str_Col_Check (" : ");
5506 Cprint_Node (Subtype_Indication (Node), Declaration => True);
5507 end if;
5508
5509 if Of_Present (Node) then
5510 Write_Str_Col_Check (" of ");
5511 else
5512 Write_Str_Col_Check (" in ");
5513 end if;
5514
5515 if Reverse_Present (Node) then
5516 Write_Str_Col_Check ("reverse ");
5517 end if;
5518
5519 Cprint_Node (Name (Node), Declaration => True);
5520
5521 when N_Itype_Reference =>
5522 Cprint_Declare (Itype (Node));
5523
5524 when N_Label =>
5525 Write_Source_Lines (Node);
5526 Write_Indent;
5527 Write_Id (Identifier (Node));
5528 Write_Str (": ;");
5529
5530 when N_Loop_Parameter_Specification =>
5531 raise Program_Error; -- handled by N_Loop_Statement
5532
5533 when N_Loop_Statement =>
5534 declare
5535 ISS : constant Node_Id := Iteration_Scheme (Node);
5536
5537 For_Loop_Var : Entity_Id := Empty;
5538 -- Set to defining identifier of for loop variable for FOR loop
5539
5540 LBD : Node_Id;
5541 HBD : Node_Id;
5542
5543 For_Loop_Reverse : Boolean;
5544 -- Set True if reverse for loop, False for normal for loop
5545
5546 Incr : String (1 .. 2) := "++";
5547 -- Change to "--" if reverse FOR loop
5548
5549 Use_While : Boolean := False;
5550 -- Set True if we have the case of a FOR loop that had to be
5551 -- expanded into a C while loop, and thus needs a statement
5552 -- adding at the end of the body that increments/decrements
5553 -- the loop variable.
5554
5555 begin
5556 -- Handle iteration scheme
5557
5558 if Present (ISS) then
5559 Write_Source_Lines (Sloc (Node), Last_Line (ISS));
5560
5561 -- WHILE loop case, generates C while
5562
5563 if Present (Condition (ISS)) then
5564 Write_Indent_Str ("while (");
5565 Cprint_Node (Condition (ISS));
5566 Write_Char (')');
5567
5568 -- FOR loop case
5569
5570 else
5571 -- For loops are tricky, consider this example:
5572
5573 -- for X in Integer range 1 .. N loop
5574
5575 -- Suppose we decide to translate this to C as
5576
5577 -- {
5578 -- int x;
5579 -- for (x = 1; x <= N; x++) {
5580 -- loop body
5581 -- }
5582 -- }
5583
5584 -- That seems right, but it does not work in the case
5585 -- where N = Integer'Last, since we will increment
5586 -- this value before the test, causing overflow. In the
5587 -- case where we have that possibility, the required
5588 -- translation is:
5589
5590 -- {
5591 -- int x = 1;
5592 -- boolean _cont = x <= N;
5593 -- while (_cont) {
5594 -- loop body
5595 -- }
5596 -- _cont = x != N;
5597 -- if (_cont) x++;
5598 -- }
5599 -- }
5600
5601 -- For performance reasons, we try to use 'for' loops
5602 -- where possible.
5603
5604 declare
5605 LPS : constant Node_Id :=
5606 Loop_Parameter_Specification (ISS);
5607 DSD : constant Node_Id :=
5608 Discrete_Subtype_Definition (LPS);
5609 Rng : Node_Id;
5610
5611 Comp : String (1 .. 4) := " <= ";
5612 -- Change to " >= " if reverse loop
5613
5614 Loop_Btype : Entity_Id;
5615 -- Base type of type of loop variable
5616
5617 OK : Boolean;
5618 Lo : Uint;
5619 Hi : Uint;
5620 -- Parameters for Determine_Range call
5621
5622 begin
5623 For_Loop_Var := Defining_Identifier (LPS);
5624 For_Loop_Reverse := Reverse_Present (LPS);
5625 Loop_Btype := Base_Type (Etype (For_Loop_Var));
5626
5627 case Nkind (DSD) is
5628 when N_Range =>
5629 Rng := DSD;
5630 when N_Subtype_Indication =>
5631 Rng := Range_Expression (Constraint (DSD));
5632 when others =>
5633 raise Program_Error;
5634 end case;
5635
5636 LBD := Low_Bound (Rng);
5637 HBD := High_Bound (Rng);
5638
5639 -- Set things up for reverse loop case
5640
5641 if For_Loop_Reverse then
5642 Incr := "--";
5643 Comp := " >= ";
5644
5645 declare
5646 Temp : constant Node_Id := LBD;
5647 begin
5648 LBD := HBD;
5649 HBD := Temp;
5650 end;
5651 end if;
5652
5653 -- Now see whether we need a do-while loop
5654
5655 Determine_Range
5656 (HBD, OK, Lo, Hi, Assume_Valid => True);
5657
5658 if For_Loop_Reverse then
5659 Use_While :=
5660 Lo <= Expr_Value (Type_Low_Bound (Loop_Btype));
5661 else
5662 Use_While :=
5663 Hi >= Expr_Value (Type_High_Bound (Loop_Btype));
5664 end if;
5665
5666 -- Create outer block defining the for variable and
5667 -- itypes.
5668
5669 Write_Indent;
5670 Open_Scope;
5671 Indent_Begin;
5672 Write_Indent;
5673
5674 -- Generate itype for loop variable, then declare the
5675 -- loop variable, then generate remaining itypes if
5676 -- any, since some itypes may reference the loop
5677 -- variable.
5678
5679 Write_Itypes_In_Subtree (Etype (For_Loop_Var));
5680 Write_Indent;
5681 Check_Definition (Etype (For_Loop_Var),
5682 Error_Node => For_Loop_Var);
5683 Cprint_Type_Name (Etype (For_Loop_Var));
5684 Write_Char (' ');
5685 Cprint_Node (For_Loop_Var, Declaration => True);
5686
5687 if Use_While then
5688 Write_Str (" = ");
5689 Cprint_Node (LBD);
5690 Write_Char (';');
5691 Write_Indent_Str ("boolean _cont = ");
5692 Cprint_Node (For_Loop_Var, Declaration => True);
5693 Write_Str (Comp);
5694 Cprint_Node (HBD);
5695 end if;
5696
5697 Write_Char (';');
5698 Write_Indent;
5699
5700 Set_In_Statements;
5701
5702 -- Case of using while loop
5703
5704 if Use_While then
5705 -- Write while header
5706
5707 Write_Indent_Str ("while (_cont)");
5708
5709 -- Case where we can use for loop safely
5710
5711 else
5712 Write_Indent_Str ("for (");
5713 Cprint_Node (For_Loop_Var, Declaration => True);
5714 Write_Str (" = ");
5715 Cprint_Node (LBD);
5716 Write_Str ("; ");
5717 Cprint_Node (For_Loop_Var, Declaration => True);
5718 Write_Str (Comp);
5719 Cprint_Node (HBD);
5720 Write_Str ("; ");
5721 Cprint_Node (For_Loop_Var, Declaration => True);
5722 Write_Str (Incr);
5723 Write_Char (')');
5724 end if;
5725 end;
5726 end if;
5727
5728 -- No iteration scheme present
5729
5730 else
5731 Write_Source_Lines (Sloc (Node));
5732 Write_Indent_Str ("while (true)");
5733 end if;
5734
5735 -- Output the loop body
5736
5737 Write_Char (' ');
5738 Open_Scope;
5739 Indent_Begin;
5740 Cprint_Node_List (Statements (Node));
5741
5742 -- End of while loop if needed
5743
5744 if Use_While then
5745 Write_Indent_Str ("_cont = ");
5746 Cprint_Node (For_Loop_Var, Declaration => True);
5747 Write_Str (" != ");
5748 Cprint_Node (HBD);
5749 Write_Char (';');
5750 Write_Indent_Str ("if (_cont) ");
5751 Cprint_Node (For_Loop_Var, Declaration => True);
5752 Write_Str (Incr);
5753 Write_Char (';');
5754 end if;
5755
5756 -- Deal with loop closure
5757
5758 Write_Source_Lines (End_Label (Node));
5759
5760 Indent_End;
5761 Write_Indent;
5762 Close_Scope;
5763
5764 -- Close the outer block if FOR case
5765
5766 if Present (For_Loop_Var) then
5767 Indent_End;
5768 Write_Indent;
5769 Close_Scope;
5770 end if;
5771
5772 -- Output label at end of loop as possible exit target
5773
5774 if Present (Identifier (Node))
5775 and then not Has_Created_Identifier (Node)
5776 then
5777 Write_Source_Lines (End_Label (Node));
5778 Write_Indent;
5779 Write_Id (Identifier (Node));
5780 Write_Str (": ;");
5781 end if;
5782 end;
5783
5784 when N_Mod_Clause =>
5785 raise Program_Error;
5786
5787 when N_Modular_Type_Definition =>
5788 raise Program_Error;
5789
5790 when N_Not_In =>
5791 if Present (Right_Opnd (Node)) then
5792 Cprint_Left_Opnd (Node);
5793 Write_Str ("<");
5794 Cprint_Node (Low_Bound (Right_Opnd (Node)));
5795 Write_Str (" && ");
5796 Cprint_Left_Opnd (Node);
5797 Write_Str (">");
5798 Cprint_Node (High_Bound (Right_Opnd (Node)));
5799 else
5800 Cprint_Bar_List (Alternatives (Node));
5801 end if;
5802
5803 when N_Null =>
5804 declare
5805 Typ : constant Entity_Id :=
5806 Get_Full_View (Etype (Node));
5807 begin
5808 if Has_Fat_Pointer (Typ) then
5809 Write_Fatptr_Init (Node, Typ);
5810 else
5811 Write_Str_Col_Check ("NULL");
5812 end if;
5813 end;
5814
5815 when N_Null_Statement =>
5816 Write_Source_Lines (Node);
5817
5818 if Comes_From_Source (Node)
5819 or else not Is_List_Member (Node)
5820 or else (No (Prev (Node)) and then No (Next (Node)))
5821 then
5822 if Nkind (Parent (Node)) /= N_Freeze_Entity then
5823 Write_Indent_Str ("{}");
5824 end if;
5825 end if;
5826
5827 when N_Number_Declaration =>
5828 null; -- not output in C code
5829
5830 when N_Object_Declaration =>
5831 declare
5832 function Expr_Init_With_Assignment
5833 (Node : Node_Id) return Boolean;
5834 -- Return True if the object declaration Node has an init
5835 -- expression which is initialized by the back end by means
5836 -- of a separate assigment statement. Used to avoid declaring
5837 -- the object as a constant.
5838
5839 function Requires_Elaboration (Expr : Node_Id) return Boolean;
5840 -- Determines if the given expression requires elaboration
5841 -- code.
5842
5843 -------------------------------
5844 -- Expr_Init_With_Assignment --
5845 -------------------------------
5846
5847 function Expr_Init_With_Assignment
5848 (Node : Node_Id) return Boolean
5849 is
5850 Id : constant Entity_Id := Defining_Identifier (Node);
5851 U_Expr : constant Node_Id :=
5852 Ultimate_Expression (Expression (Node));
5853 U_Typ : Entity_Id;
5854
5855 begin
5856 if No (U_Expr) then
5857 return False;
5858 end if;
5859
5860 U_Typ := Get_Full_View (Etype (U_Expr));
5861
5862 if Is_Access_Type (U_Typ) then
5863 U_Typ := Get_Full_View (Designated_Type (U_Typ));
5864 end if;
5865
5866 if Nkind (Original_Node (U_Expr)) = N_Allocator
5867 and then Nkind (Expression (Original_Node (U_Expr))) =
5868 N_Qualified_Expression
5869 then
5870 return True;
5871
5872 elsif Nkind (Original_Node (U_Expr)) = N_Allocator
5873 and then Is_Unconstrained_Array_Type (U_Typ)
5874 then
5875 return True;
5876
5877 elsif Nkind (U_Expr) = N_Slice then
5878 return True;
5879
5880 else
5881 if not Requires_Elaboration (U_Expr)
5882 and then not Is_Raise_Statement (U_Expr)
5883 then
5884 if Is_Array_Type (U_Typ)
5885 and then
5886 (Nkind (U_Expr) = N_Identifier
5887 or else
5888 (Nkind (U_Expr) = N_Qualified_Expression
5889 and then Nkind (Expression (U_Expr)) =
5890 N_Identifier))
5891 then
5892 return True;
5893
5894 elsif Nkind (Expression (Node)) =
5895 N_Unchecked_Type_Conversion
5896 and then Is_Composite_Type
5897 (Get_Full_View (Etype (Id)))
5898 then
5899 return True;
5900 end if;
5901 end if;
5902 end if;
5903
5904 return False;
5905 end Expr_Init_With_Assignment;
5906
5907 --------------------------
5908 -- Requires_Elaboration --
5909 --------------------------
5910
5911 function Requires_Elaboration (Expr : Node_Id) return Boolean is
5912 L : List_Id;
5913 N : Node_Id;
5914
5915 begin
5916 if Library_Level and then Present (Expr) then
5917 if Nkind (Expr) = N_Aggregate then
5918 L := Expressions (Expr);
5919
5920 if Present (L) then
5921 N := First (L);
5922 while Present (N) loop
5923 if Requires_Elaboration (N) then
5924 Error_Msg_N
5925 ("unsupported kind of aggregate", Expr);
5926 return True;
5927 end if;
5928
5929 Next (N);
5930 end loop;
5931 end if;
5932 else
5933 return Nkind (Expr) /= N_Aggregate
5934 and then (Nkind (Expr) /= N_Qualified_Expression
5935 or else Nkind (Expression (Expr)) /=
5936 N_Aggregate)
5937 and then not Compile_Time_Known_Value (Expr);
5938 end if;
5939 end if;
5940
5941 return False;
5942 end Requires_Elaboration;
5943
5944 -- Local variables
5945
5946 Id : constant Entity_Id := Defining_Identifier (Node);
5947 Nam : constant String := Get_Name_String (Chars (Id));
5948 Typ : constant Entity_Id := Get_Full_View (Etype (Id));
5949 Expr : Node_Id;
5950 Full : Node_Id;
5951
5952 begin
5953 Write_Itypes_In_Subtree (Node);
5954
5955 if not In_Declarations then
5956 Open_Extra_Scope;
5957 end if;
5958
5959 -- Nothing to do if this is a debug renaming type or an
5960 -- elaboration entity (x_E), or the object has already been
5961 -- processed, or there is an address clause on the object
5962 -- (will be handled as part of N_Attribute_Definition_Clause)
5963
5964 if Typ = Standard_Debug_Renaming_Type
5965 or else (Nam'Length >= 3
5966 and then Nam (Nam'Last - 1 .. Nam'Last) = "_E")
5967 or else (Entity_Table.Get (Node)
5968 and then not Special_Elaboration_Code)
5969 or else Present (Address_Clause (Defining_Identifier (Node)))
5970 then
5971 null;
5972
5973 -- Normal case
5974
5975 else
5976 Register_Entity (Node);
5977 Write_Source_Lines (Node);
5978 Write_Indent;
5979
5980 if not In_Main_Unit then
5981 Write_Str ("extern ");
5982 end if;
5983
5984 -- Case of elab procedure, replace a variable declaration
5985 -- by an assignment.
5986
5987 if Special_Elaboration_Code and Node = Current_Elab_Entity
5988 then
5989 Write_Id (Id);
5990 else
5991 if Constant_Present (Node) then
5992 Full := Full_View (Defining_Identifier (Node));
5993
5994 if Present (Full) then
5995 if In_Main_Unit then
5996 if not Library_Level then
5997 return;
5998 end if;
5999
6000 -- Ensure that we do not generate object
6001 -- declarations twice in case of public/private
6002 -- views.
6003
6004 else
6005 Register_Entity (Parent (Full));
6006 end if;
6007
6008 Expr :=
6009 Expression (Parent
6010 (Full_View (Defining_Identifier (Node))));
6011
6012 else
6013 Expr := Expression (Node);
6014 end if;
6015
6016 if not Requires_Elaboration (Expr) then
6017 if In_Main_Unit
6018 and then Library_Level
6019 and then No (Expression (Node))
6020 then
6021 Write_Str ("extern ");
6022 end if;
6023
6024 if Is_Statically_Allocated (Id) then
6025 Write_Str ("static ");
6026 end if;
6027
6028 -- If the Id is referenced by a nested subprogram
6029 -- it cannot be defined as constant since we need
6030 -- to store its address in the activation record
6031
6032 if not No_Initialization (Node)
6033 and then not Expr_Init_With_Assignment (Node)
6034 and then not Is_Uplevel_Referenced_Entity (Id)
6035 then
6036 Write_Str ("const ");
6037 end if;
6038 end if;
6039
6040 elsif Is_Statically_Allocated (Id) then
6041 Write_Str ("static ");
6042 end if;
6043
6044 Cprint_Declare (Id, Semicolon => False);
6045 end if;
6046
6047 -- Add initializer if present
6048
6049 Expr := Expression (Node);
6050
6051 if In_Main_Unit
6052 and then not No_Initialization (Node)
6053 and then Present (Expr)
6054 then
6055 if not Requires_Elaboration (Expr) then
6056 if Is_Raise_Statement (Expr) then
6057 Write_Char (';');
6058 Set_In_Statements;
6059
6060 Write_Indent;
6061 Cprint_Node (Expr);
6062
6063 elsif Is_Access_Type (Typ)
6064 and then Has_Fat_Pointer (Typ)
6065 then
6066 -- Initialize null fat pointers by means of
6067 -- aggregates.
6068
6069 if Nkind (Expr) = N_Null then
6070 Write_Str_Col_Check (" = ");
6071 Write_Fatptr_Init (Expr, Typ,
6072 Use_Aggregate => True);
6073
6074 -- The called function returns a fat pointer
6075
6076 elsif Nkind (Expr) = N_Function_Call then
6077 Write_Str_Col_Check (" = ");
6078 Cprint_Node (Expr);
6079
6080 else
6081 Write_Char (';');
6082 Set_In_Statements;
6083
6084 Write_Indent;
6085 Write_Id (Id);
6086 Write_Str (" = ");
6087
6088 if Nkind (Expr) = N_Attribute_Reference then
6089 Handle_Attribute (Expr);
6090 else
6091 Write_Fatptr_Init (Expr,
6092 Get_Full_View (Designated_Type (Typ)),
6093 Use_Aggregate => False);
6094 end if;
6095 end if;
6096
6097 -- Variable size records are handled separately from
6098 -- expressions initialized with assignments because:
6099 -- 1. They must not be defined constant
6100 -- 2. The semicolon must not be output since the
6101 -- declaration of this entity has just defined
6102 -- a macro (see Cprint_Reference).
6103
6104 elsif Is_Supported_Variable_Size_Record (Typ) then
6105 Write_Char (';');
6106 Set_In_Statements;
6107
6108 Write_Indent;
6109 Cprint_Copy
6110 (Target => Id,
6111 Source => Expr,
6112 Use_Memcpy => True);
6113
6114 elsif Expr_Init_With_Assignment (Node) then
6115 Write_Char (';');
6116 Set_In_Statements;
6117
6118 Write_Indent;
6119 Cprint_Copy
6120 (Target => Id,
6121 Source => Expr,
6122 Use_Memcpy => True);
6123
6124 else
6125 Write_Str_Col_Check (" = ");
6126 Cprint_Node (Expr);
6127 end if;
6128
6129 -- A library-level declaration and not a compile-time
6130 -- known value: defer initialization to elab proc.
6131
6132 else
6133 Elaboration_Table.Append (Node);
6134 end if;
6135 end if;
6136
6137 if Last_Char /= ASCII.NUL then
6138 Write_Char (';');
6139 end if;
6140 end if;
6141 end;
6142
6143 when N_Object_Renaming_Declaration =>
6144 Object_Renaming_Declaration : declare
6145 procedure Define_Renaming_Macro (Node : Node_Id);
6146 -- Defined the macro associated with the object renaming
6147 -- declaration Node.
6148
6149 ---------------------------
6150 -- Define_Renaming_Macro --
6151 ---------------------------
6152
6153 procedure Define_Renaming_Macro (Node : Node_Id) is
6154 begin
6155 Write_Eol;
6156 Write_Str ("#define ");
6157 Write_Id (Defining_Identifier (Node));
6158 Write_Str (" (");
6159 Cprint_Node (Name (Node));
6160 Write_Char (')');
6161 Write_Eol;
6162
6163 -- Record this macro so that it will be #undef'ed at the end
6164 -- of the current scope.
6165
6166 if not Library_Level then
6167 Macro_Table.Append (Defining_Identifier (Node));
6168 end if;
6169 end Define_Renaming_Macro;
6170
6171 -- Local variables
6172
6173 Def_Id : constant Node_Id := Defining_Identifier (Node);
6174
6175 -- Start of processing for Object_Renaming_Declaration
6176
6177 begin
6178 -- Most renamings are handled by the front end, handle
6179 -- remaining ones via preprocessor macros.
6180
6181 if not Is_Renaming_Of_Object (Def_Id) then
6182 if Nkind_In (Name (Node), N_Identifier, N_Expanded_Name) then
6183 Define_Renaming_Macro (Node);
6184 else
6185 Error_Msg_N ("unsupported kind of object renaming", Node);
6186 end if;
6187
6188 -- For internally generated renamings associated with iterators
6189 -- we need to generate the macro; in this case the front end
6190 -- does not perform the macro substitution done for entities
6191 -- that have set the attribute Is_Renaming_Of_Object (most
6192 -- probably to facilitate reporting errors/warnings on the
6193 -- iterator variable).
6194
6195 elsif not Comes_From_Source (Node)
6196 and then Present (Related_Expression (Def_Id))
6197 and then Nkind (Parent (Related_Expression (Def_Id))) =
6198 N_Iterator_Specification
6199 then
6200 Define_Renaming_Macro (Node);
6201 end if;
6202
6203 -- Remember that this entity is defined
6204
6205 Register_Entity (Defining_Identifier (Node));
6206 end Object_Renaming_Declaration;
6207
6208 when N_Op_Abs =>
6209 declare
6210 Typ : constant Entity_Id :=
6211 Matching_Standard_Type (Etype (Node));
6212 begin
6213 if Typ = Standard_Short_Short_Integer
6214 or else Typ = Standard_Short_Integer
6215 or else Typ = Standard_Integer
6216 or else Typ = Standard_Short_Short_Unsigned
6217 or else Typ = Standard_Short_Unsigned
6218 or else Typ = Standard_Unsigned
6219 then
6220 Write_Str ("abs(");
6221
6222 elsif Typ = Standard_Long_Integer
6223 or else Typ = Standard_Long_Unsigned
6224 then
6225 Write_Str ("labs(");
6226
6227 elsif Typ = Standard_Long_Long_Integer
6228 or else Typ = Standard_Long_Long_Unsigned
6229 then
6230 Write_Str ("llabs(");
6231
6232 elsif Typ = Standard_Short_Float
6233 or else Typ = Standard_Float
6234 then
6235 Write_Str ("fabsf(");
6236
6237 elsif Typ = Standard_Long_Float then
6238 Write_Str ("fabs(");
6239
6240 elsif Typ = Standard_Long_Long_Float then
6241 Write_Str ("fabsl(");
6242
6243 else
6244 raise Program_Error;
6245 end if;
6246
6247 Cprint_Right_Opnd (Node);
6248 Write_Char (')');
6249 end;
6250
6251 when N_Op_Add =>
6252 Cprint_Left_Opnd (Node);
6253 Write_Str (" + ");
6254 Cprint_Right_Opnd (Node);
6255
6256 when N_Op_And =>
6257 Cprint_Left_Opnd (Node);
6258 Write_Str (" & ");
6259 Cprint_Right_Opnd (Node);
6260
6261 when N_Op_Concat =>
6262 raise Program_Error; -- should always be expanded
6263
6264 when N_Op_Divide =>
6265 if Rounded_Result (Node) then
6266
6267 -- Note that we know the divisor is always positive (for fixed
6268 -- point), so we generate:
6269 -- ((left<0) ? (left - right/2)/right : (left + right/2)/right)
6270
6271 Write_Str ("((");
6272 Cprint_Left_Opnd (Node);
6273 Write_Str (" < 0) ? (");
6274
6275 Cprint_Left_Opnd (Node);
6276 Write_Str (" - ");
6277 Cprint_Right_Opnd (Node);
6278 Write_Str (" / 2) / ");
6279 Cprint_Right_Opnd (Node);
6280
6281 Write_Str (" : (");
6282
6283 Cprint_Left_Opnd (Node);
6284 Write_Str (" + ");
6285 Cprint_Right_Opnd (Node);
6286 Write_Str (" / 2) / ");
6287 Cprint_Right_Opnd (Node);
6288 Write_Char (')');
6289
6290 else
6291 Cprint_Left_Opnd (Node);
6292 Write_Str (" / ");
6293 Cprint_Right_Opnd (Node);
6294 end if;
6295
6296 when N_Op_Eq =>
6297 declare
6298 LHS : constant Node_Id := Left_Opnd (Node);
6299 RHS : constant Node_Id := Right_Opnd (Node);
6300 L_Typ : constant Node_Id := Get_Full_View (Etype (LHS));
6301 R_Typ : constant Node_Id := Get_Full_View (Etype (RHS));
6302
6303 begin
6304 if Has_Fat_Pointer (L_Typ)
6305 or else Has_Fat_Pointer (R_Typ)
6306 then
6307 Write_Fatptr_Compare (LHS, RHS);
6308
6309 elsif Ekind (L_Typ) in Composite_Kind then
6310 if Is_Entity_Name (LHS)
6311 or else Nkind_In (LHS, N_Explicit_Dereference,
6312 N_Indexed_Component,
6313 N_Selected_Component,
6314 N_Slice)
6315 then
6316 -- Replace composite equality by a call to memcmp(). Also
6317 -- compare sizes in case of different types.
6318
6319 if L_Typ /= R_Typ then
6320 Write_Char ('(');
6321 Output_Sizeof (LHS);
6322 Write_Str_Col_Check (" == ");
6323 Output_Sizeof (RHS);
6324 Write_Str_Col_Check (" && ");
6325 end if;
6326
6327 Write_Str ("!memcmp(");
6328
6329 if Nkind (LHS) = N_Explicit_Dereference then
6330 Cprint_Node (Prefix (LHS), Declaration => True);
6331 else
6332 if Requires_Address (L_Typ) then
6333 Write_Char ('&');
6334 end if;
6335
6336 Cprint_Node (LHS, Declaration => True);
6337 end if;
6338
6339 Write_Str (", ");
6340
6341 if Nkind (RHS) = N_Explicit_Dereference then
6342 Cprint_Node (Prefix (RHS), Declaration => True);
6343 else
6344 if Requires_Address (R_Typ) then
6345 Write_Char ('&');
6346 end if;
6347
6348 Cprint_Node (RHS, Declaration => True);
6349 end if;
6350
6351 Write_Str (", ");
6352 Output_Sizeof (LHS, RHS);
6353 Write_Char (')');
6354
6355 if L_Typ /= R_Typ then
6356 Write_Char (')');
6357 end if;
6358
6359 else
6360 declare
6361 S : constant String := Node_Kind'Image (Nkind (LHS));
6362 begin
6363 Error_Msg_Strlen := S'Length;
6364 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
6365 Error_Msg_N ("unsupported comparison (~)", Node);
6366 end;
6367 end if;
6368
6369 else
6370 Cprint_Left_Opnd (Node);
6371 Write_Str (" == ");
6372 Cprint_Right_Opnd (Node);
6373 end if;
6374 end;
6375
6376 when N_Op_Expon =>
6377
6378 -- Will probably never happen since expander uses a runtime call
6379
6380 Write_Str ("pow(");
6381 Cprint_Left_Opnd (Node);
6382 Write_Char (',');
6383 Cprint_Right_Opnd (Node);
6384 Write_Char (')');
6385
6386 when N_Op_Ge =>
6387 Cprint_Left_Opnd (Node);
6388 Write_Str (" >= ");
6389 Cprint_Right_Opnd (Node);
6390
6391 when N_Op_Gt =>
6392 Cprint_Left_Opnd (Node);
6393 Write_Str (" > ");
6394 Cprint_Right_Opnd (Node);
6395
6396 when N_Op_Le =>
6397 Cprint_Left_Opnd (Node);
6398 Write_Str (" <= ");
6399 Cprint_Right_Opnd (Node);
6400
6401 when N_Op_Lt =>
6402 Cprint_Left_Opnd (Node);
6403 Write_Str (" < ");
6404 Cprint_Right_Opnd (Node);
6405
6406 when N_Op_Minus =>
6407 Write_Str ("-");
6408 Cprint_Right_Opnd (Node);
6409
6410 when N_Op_Mod =>
6411 Cprint_Left_Opnd (Node);
6412 Write_Str (" % ");
6413 Cprint_Right_Opnd (Node);
6414
6415 when N_Op_Multiply =>
6416 Cprint_Left_Opnd (Node);
6417 Write_Str (" * ");
6418 Cprint_Right_Opnd (Node);
6419
6420 when N_Op_Ne =>
6421 declare
6422 LHS : constant Node_Id := Left_Opnd (Node);
6423 L_Typ : constant Node_Id := Get_Full_View (Etype (LHS));
6424 RHS : constant Node_Id := Right_Opnd (Node);
6425 R_Typ : constant Node_Id := Get_Full_View (Etype (RHS));
6426
6427 begin
6428 if Has_Fat_Pointer (L_Typ) or else Has_Fat_Pointer (R_Typ) then
6429 Write_Char ('!');
6430 Write_Fatptr_Compare (LHS, RHS);
6431
6432 elsif (Is_Entity_Name (LHS)
6433 or else Nkind (LHS) = N_Selected_Component)
6434 and then Ekind (L_Typ) in Composite_Kind
6435 then
6436 -- Replace composite equality by a call to memcmp()
6437
6438 if L_Typ /= R_Typ then
6439 Write_Char ('(');
6440 Output_Sizeof (LHS);
6441 Write_Str_Col_Check (" != ");
6442 Output_Sizeof (RHS);
6443 Write_Str_Col_Check (" || ");
6444 end if;
6445
6446 Write_Str ("memcmp(");
6447
6448 if Requires_Address (L_Typ) then
6449 Write_Char ('&');
6450 end if;
6451
6452 Cprint_Node (LHS, Declaration => True);
6453 Write_Str (", ");
6454
6455 if Requires_Address (R_Typ) then
6456 Write_Char ('&');
6457 end if;
6458
6459 Cprint_Node (RHS, Declaration => True);
6460 Write_Str (", ");
6461 Output_Sizeof (LHS, RHS);
6462 Write_Char (')');
6463
6464 if L_Typ /= R_Typ then
6465 Write_Char ('(');
6466 end if;
6467
6468 else
6469 Cprint_Left_Opnd (Node);
6470 Write_Str (" != ");
6471 Cprint_Right_Opnd (Node);
6472 end if;
6473 end;
6474
6475 when N_Op_Not =>
6476 if Is_Boolean_Type (Etype (Node)) then
6477 Write_Str ("!");
6478 elsif Is_Modular_Integer_Type (Etype (Node)) then
6479 Write_Str ("~");
6480 else
6481 Error_Msg_N ("unsupported NOT operator", Node);
6482 Write_Str ("/* unsupported NOT operator */ ~");
6483 end if;
6484
6485 Cprint_Right_Opnd (Node);
6486
6487 when N_Op_Or =>
6488 Cprint_Left_Opnd (Node);
6489 Write_Str (" | ");
6490 Cprint_Right_Opnd (Node);
6491
6492 when N_Op_Plus =>
6493 Write_Str ("+");
6494 Cprint_Right_Opnd (Node);
6495
6496 when N_Op_Rem =>
6497 Cprint_Left_Opnd (Node);
6498 Write_Str (" % ");
6499 Cprint_Right_Opnd (Node);
6500
6501 when N_Op_Rotate_Left | N_Op_Rotate_Right =>
6502
6503 -- Should have been rewritten in Modify_Tree_For_C mode
6504
6505 raise Program_Error;
6506
6507 when N_Op_Shift_Right =>
6508 Cprint_Left_Opnd (Node);
6509 Write_Str (" >> ");
6510 Cprint_Right_Opnd (Node);
6511
6512 when N_Op_Shift_Right_Arithmetic =>
6513
6514 -- Should have been rewritten in Modify_Tree_For_C mode
6515
6516 raise Program_Error;
6517
6518 when N_Op_Shift_Left =>
6519 Cprint_Left_Opnd (Node);
6520 Write_Str (" << ");
6521 Cprint_Right_Opnd (Node);
6522
6523 when N_Op_Subtract =>
6524 Cprint_Left_Opnd (Node);
6525 Write_Str (" - ");
6526 Cprint_Right_Opnd (Node);
6527
6528 when N_Op_Xor =>
6529 Cprint_Left_Opnd (Node);
6530 Write_Str (" ^ ");
6531 Cprint_Right_Opnd (Node);
6532
6533 when N_Operator_Symbol =>
6534
6535 -- Replaced by the corresponding N_Op_XX node by the expander
6536
6537 raise Program_Error;
6538
6539 when N_Ordinary_Fixed_Point_Definition =>
6540
6541 -- ???
6542
6543 Write_Str_Col_Check ("delta ");
6544 Cprint_Node (Delta_Expression (Node));
6545 Cprint_Opt_Node (Real_Range_Specification (Node));
6546
6547 when N_Or_Else =>
6548 Cprint_Left_Opnd (Node);
6549 Write_Str (" || ");
6550 Cprint_Right_Opnd (Node);
6551
6552 when N_Others_Choice =>
6553 raise Program_Error;
6554
6555 when N_Package_Body =>
6556 if Ekind (Corresponding_Spec (Node)) = E_Generic_Package then
6557 if Nkind (Parent (Node)) = N_Compilation_Unit then
6558 Set_Has_No_Elaboration_Code (Parent (Node), True);
6559 end if;
6560 else
6561 Cprint_Node_List (Declarations (Node));
6562 Ensure_New_Line;
6563
6564 declare
6565 Stmts : constant Node_Id :=
6566 Handled_Statement_Sequence (Node);
6567 Has_Stmts : constant Boolean :=
6568 Present (Stmts)
6569 and then Has_Non_Null_Statements
6570 (Statements (Stmts));
6571
6572 Unit : Node_Id;
6573
6574 begin
6575 -- Only generate elaboration procedures when in main unit.
6576
6577 if not In_Main_Unit then
6578 null;
6579
6580 -- For packages inside subprograms, generate elaboration
6581 -- code as standard code as part of the enclosing unit.
6582
6583 elsif not Library_Level then
6584 if Has_Stmts then
6585 Open_Scope;
6586 Set_In_Statements;
6587 Indent_Begin;
6588 Cprint_Node (Stmts);
6589 Indent_End;
6590 Ensure_New_Line;
6591 Close_Scope;
6592 end if;
6593
6594 elsif Nkind (Parent (Node)) /= N_Compilation_Unit then
6595 if Has_Stmts then
6596 Elaboration_Table.Append (Stmts);
6597 end if;
6598
6599 elsif Elaboration_Table.Last = 0
6600 and then not Has_Stmts
6601 then
6602 Set_Has_No_Elaboration_Code (Parent (Node), True);
6603
6604 else
6605 Unit := Defining_Unit_Name (Node);
6606
6607 if Nkind (Unit) = N_Defining_Program_Unit_Name then
6608 Unit := Defining_Identifier (Unit);
6609 end if;
6610
6611 Write_Indent_Str ("extern void ");
6612 Cprint_Node (Unit, Declaration => True);
6613 Write_Str ("___elabb();");
6614
6615 Write_Indent_Str ("void ");
6616 Cprint_Node (Unit, Declaration => True);
6617 Write_Str ("___elabb() ");
6618 Open_Scope;
6619
6620 Ensure_New_Line;
6621 Indent_Begin;
6622
6623 declare
6624 Save_Library_Level : constant Boolean := Library_Level;
6625 begin
6626 Library_Level := False;
6627 Special_Elaboration_Code := True;
6628
6629 for J in 1 .. Elaboration_Table.Last loop
6630 Current_Elab_Entity := Elaboration_Table.Table (J);
6631 Cprint_Node (Current_Elab_Entity);
6632 end loop;
6633
6634 Elaboration_Table.Set_Last (0);
6635 Current_Elab_Entity := Empty;
6636 Special_Elaboration_Code := False;
6637
6638 if Has_Stmts then
6639 Cprint_Node (Stmts);
6640 end if;
6641
6642 Library_Level := Save_Library_Level;
6643 end;
6644
6645 Indent_End;
6646 Ensure_New_Line;
6647 Write_Indent;
6648 Close_Scope;
6649 end if;
6650 end;
6651 end if;
6652
6653 when N_Package_Declaration =>
6654 Write_Indent;
6655 Cprint_Node (Specification (Node), Declaration => True);
6656
6657 when N_Package_Instantiation | N_Package_Renaming_Declaration =>
6658 if Nkind (Parent (Node)) = N_Compilation_Unit then
6659 Set_Has_No_Elaboration_Code (Parent (Node), True);
6660 end if;
6661
6662 when N_Package_Specification =>
6663 Write_Source_Lines (Node);
6664
6665 -- Open the new scope associated with this package specification
6666 -- to ensure that we are ready to start processing declarations
6667 -- (see Open_Scope). No explicit block is associated with this
6668 -- scope because:
6669 -- * for library level packages must not be generated
6670 -- * for nested packages the block is not needed
6671
6672 Open_Scope (With_Block => False);
6673
6674 declare
6675 Scope_Id : constant Nat := Current_Scope_Id;
6676
6677 begin
6678 Cprint_Node_List (Visible_Declarations (Node));
6679
6680 if Present (Private_Declarations (Node)) then
6681 Cprint_Node_List (Private_Declarations (Node));
6682 end if;
6683
6684 Set_In_Statements;
6685
6686 -- We can safely close this package scope if it has no inner
6687 -- back-end scopes to close.
6688
6689 if Current_Scope_Id = Scope_Id then
6690 Close_Scope;
6691
6692 -- For library level packages we can also close this scope and
6693 -- all its inner back-end scopes (if any)
6694
6695 elsif Is_Library_Level_Entity (Defining_Entity (Node)) then
6696 Close_Scope;
6697
6698 -- For nested packages we must defer closing it (and its extra
6699 -- scopes) since its extra back-end scopes may have been added
6700 -- to handle declarations which can be referenced from its
6701 -- enclosing scope.
6702
6703 else
6704 null;
6705 end if;
6706 end;
6707
6708 -- Only generate elaboration procedures for library-level packages
6709 -- and when part of the main unit.
6710
6711 if In_Main_Unit
6712 and then Nkind (Parent (Parent (Node))) = N_Compilation_Unit
6713 then
6714 if Elaboration_Table.Last = 0 then
6715 Set_Has_No_Elaboration_Code (Parent (Parent (Node)), True);
6716 else
6717 declare
6718 Unit : Node_Id := Defining_Unit_Name (Node);
6719 begin
6720 if Nkind (Unit) = N_Defining_Program_Unit_Name then
6721 Unit := Defining_Identifier (Unit);
6722 end if;
6723
6724 Write_Indent_Str ("extern void ");
6725 Cprint_Node (Unit, Declaration => True);
6726 Write_Str ("___elabs();");
6727
6728 Write_Indent_Str ("void ");
6729 Cprint_Node (Unit, Declaration => True);
6730 Write_Str ("___elabs() ");
6731 end;
6732
6733 Open_Scope;
6734 Ensure_New_Line;
6735 Indent_Begin;
6736
6737 declare
6738 Save_Library_Level : constant Boolean := Library_Level;
6739 begin
6740 Library_Level := False;
6741 Special_Elaboration_Code := True;
6742 Set_In_Statements;
6743
6744 for J in 1 .. Elaboration_Table.Last loop
6745 Current_Elab_Entity := Elaboration_Table.Table (J);
6746 Cprint_Node (Elaboration_Table.Table (J));
6747 end loop;
6748
6749 Current_Elab_Entity := Empty;
6750 Special_Elaboration_Code := False;
6751 Library_Level := Save_Library_Level;
6752 end;
6753
6754 Elaboration_Table.Set_Last (0);
6755 Indent_End;
6756 Ensure_New_Line;
6757 Write_Indent;
6758 Close_Scope;
6759 end if;
6760 end if;
6761
6762 when N_Parameter_Association =>
6763 raise Program_Error;
6764
6765 when N_Parameter_Specification =>
6766 declare
6767 Ent : constant Entity_Id := Defining_Identifier (Node);
6768 Typ : constant Entity_Id := Get_Full_View (Etype (Ent));
6769 Ignore : Boolean;
6770
6771 begin
6772 if (Is_Record_Type (Typ) or else Is_Descendant_Of_Address (Typ))
6773 and then Ekind (Ent) = E_In_Parameter
6774 and then not Is_Uplevel_Referenced_Entity (Ent)
6775 then
6776 Write_Str ("const ");
6777 end if;
6778
6779 Ignore :=
6780 Cprint_Reference
6781 (Ent, Add_Access => Pass_Pointer (Ent), Virtual_OK => True);
6782 end;
6783
6784 when N_Pop_Constraint_Error_Label |
6785 N_Pop_Program_Error_Label |
6786 N_Pop_Storage_Error_Label
6787 =>
6788 null;
6789
6790 when N_Private_Extension_Declaration | N_Private_Type_Declaration =>
6791
6792 -- We cannot delay declaration in C in general, and since we
6793 -- do not care about privacy in the generated code, go ahead
6794 -- and generate the type here.
6795
6796 Cprint_Declare (Full_View (Defining_Identifier (Node)));
6797
6798 when N_Push_Constraint_Error_Label |
6799 N_Push_Program_Error_Label |
6800 N_Push_Storage_Error_Label
6801 =>
6802 null;
6803
6804 when N_Pragma =>
6805
6806 -- We only output pragma Comment and we don't even do that if we
6807 -- are printing the full source, since there is no point.
6808
6809 if Pragma_Name (Node) = Name_Comment
6810 and then Is_Non_Empty_List (Pragma_Argument_Associations (Node))
6811 and then not Dump_Source_Text
6812 then
6813 -- Blank line, unless another Comment pragma precedes
6814
6815 if not Is_List_Member (Node)
6816 or else No (Prev (Node))
6817 or else Nkind (Prev (Node)) /= N_Pragma
6818 or else Pragma_Name (Prev (Node)) /= Name_Comment
6819 then
6820 Write_Eol;
6821 end if;
6822
6823 Write_Indent_Str ("/* ");
6824 String_To_Name_Buffer
6825 (Strval
6826 (Expression (First (Pragma_Argument_Associations (Node)))));
6827 Write_Str (Name_Buffer (1 .. Name_Len));
6828 Write_Str (" */");
6829
6830 -- Blank line unless another Comment pragma follows
6831
6832 if not Is_List_Member (Node)
6833 or else No (Next (Node))
6834 or else Nkind (Next (Node)) /= N_Pragma
6835 or else Pragma_Name (Next (Node)) /= Name_Comment
6836 then
6837 Write_Eol;
6838 end if;
6839 end if;
6840
6841 when N_Pragma_Argument_Association =>
6842 raise Program_Error;
6843
6844 when N_Procedure_Call_Statement =>
6845 Write_Source_Lines (Node);
6846 Write_Indent;
6847 Cprint_Call (Node);
6848 Write_Char (';');
6849
6850 when N_Procedure_Instantiation =>
6851 null; -- not output in C code
6852
6853 when N_Procedure_Specification =>
6854 declare
6855 Subp : constant Entity_Id := Unique_Defining_Entity (Node);
6856
6857 begin
6858 Append_Subprogram_Prefix (Node);
6859 Write_Source_Lines (Node);
6860 Declare_Subprogram_Types (Node);
6861
6862 if not Is_Public (Subp) then
6863 Write_Str_Col_Check ("static ");
6864 elsif Declaration then
6865 Write_Str_Col_Check ("extern ");
6866 end if;
6867
6868 Write_Str_Col_Check ("void ");
6869 Cprint_Node (Defining_Unit_Name (Node), Declaration => True);
6870 Write_Param_Specs (Node);
6871
6872 -- Remember that this entity is defined
6873
6874 Register_Entity (Defining_Unit_Name (Node));
6875 end;
6876
6877 when N_Protected_Body =>
6878 raise Program_Error;
6879
6880 when N_Protected_Definition | N_Protected_Type_Declaration =>
6881 raise Program_Error; -- handled by the expander
6882
6883 when N_Qualified_Expression =>
6884
6885 -- At the C level, we can ignore the qualification
6886
6887 Cprint_Node (Expression (Node));
6888
6889 when N_Quantified_Expression =>
6890 raise Program_Error; -- handled by the expander
6891
6892 when N_Raise_Expression =>
6893 Handle_Raise (Node);
6894
6895 when N_Raise_xxx_Error | N_Raise_Statement =>
6896 Write_Source_Lines (Node);
6897 Handle_Raise (Node);
6898
6899 when N_Range | N_Range_Constraint =>
6900 raise Program_Error;
6901
6902 when N_Real_Literal =>
6903 if Ekind (Etype (Node)) in Fixed_Point_Kind then
6904 Write_Uint (Corresponding_Integer_Value (Node));
6905 else
6906 Write_Ureal_Col_Check (Realval (Node));
6907 end if;
6908
6909 when N_Real_Range_Specification | N_Record_Definition =>
6910 raise Program_Error;
6911
6912 when N_Record_Representation_Clause =>
6913 declare
6914 Typ : constant Entity_Id := Etype (Identifier (Node));
6915
6916 begin
6917 -- Record representation clauses applied to derived types are
6918 -- not supported.
6919
6920 if Etype (Typ) /= Typ then
6921 Error_Msg_N
6922 ("unsupported representation clause on derived type",
6923 Node);
6924 end if;
6925 end;
6926
6927 when N_Reference =>
6928 if Nkind (Prefix (Node)) = N_Function_Call then
6929 Error_Msg_N ("unsupported kind of function call", Node);
6930 end if;
6931
6932 Write_Char ('&');
6933 Cprint_Node_Paren (Prefix (Node));
6934
6935 when N_Requeue_Statement |
6936 N_SCIL_Dispatch_Table_Tag_Init |
6937 N_SCIL_Dispatching_Call |
6938 N_SCIL_Membership_Test
6939 =>
6940 raise Program_Error;
6941
6942 when N_Simple_Return_Statement =>
6943 Write_Source_Lines (Node);
6944
6945 declare
6946 Expr : constant Node_Id := Expression (Node);
6947 begin
6948 if Present (Expr) then
6949 if Nkind (Expr) = N_Allocator then
6950 Open_Scope;
6951 Indent_Begin;
6952 Write_Indent;
6953 Check_Definition (Etype (Expr), Error_Node => Expr);
6954 Cprint_Type_Name (Etype (Expr));
6955 Write_Str (" _tmp = ");
6956 Cprint_Node (Expr);
6957 Write_Str (";");
6958 Write_Indent_Str ("return _tmp;");
6959 Indent_End;
6960 Close_Scope;
6961
6962 elsif Is_Array_Formal (Expr)
6963 and then Is_Access_Type (Etype (Entity (Expr)))
6964 and then Is_Constrained_Array_Type
6965 (Get_Full_View
6966 (Designated_Type (Etype (Entity (Expr)))))
6967 then
6968 Write_Indent_Str ("return ((");
6969 Write_Id (Etype (Expr));
6970 Write_Char (')');
6971 Cprint_Node (Expr);
6972 Write_Str (");");
6973 else
6974 Write_Indent_Str ("return (");
6975 Cprint_Node (Expr);
6976 Write_Str (");");
6977 end if;
6978 else
6979 Write_Indent_Str ("return;");
6980 end if;
6981 end;
6982
6983 when N_Selected_Component =>
6984
6985 -- If reference to parameter passed by pointer, use -> notation
6986
6987 if Is_Entity_Name (Prefix (Node))
6988 and then Present (Entity (Prefix (Node)))
6989 and then Is_Formal (Entity (Prefix (Node)))
6990 and then Pass_Pointer (Entity (Prefix (Node)))
6991 then
6992 -- For a->b, call Write_Id directly, we don't want Write_Node
6993 -- adding a star, this is a special case for handling params.
6994
6995 Write_Id (Entity (Prefix (Node)));
6996 Write_Str ("->");
6997
6998 -- Also use -> if prefix is explicit dereference
6999
7000 elsif Nkind (Prefix (Node)) = N_Explicit_Dereference then
7001 Cprint_Node_Paren (Prefix (Prefix (Node)));
7002 Write_Str ("->");
7003
7004 -- Normal case of using a.b
7005
7006 else
7007 Cprint_Node_Paren (Prefix (Node));
7008 Write_Char ('.');
7009 end if;
7010
7011 Cprint_Node (Selector_Name (Node), Declaration => True);
7012
7013 when N_Selective_Accept |
7014 N_Signed_Integer_Type_Definition |
7015 N_Single_Protected_Declaration |
7016 N_Single_Task_Declaration
7017 =>
7018 raise Program_Error;
7019
7020 when N_Slice =>
7021 declare
7022 Is_Access : Boolean;
7023 Lbd : Node_Id;
7024 Lo : Node_Id;
7025 N : Node_Id;
7026 Next : Node_Id;
7027 Rng : Node_Id;
7028 Same_Values : Boolean := False;
7029 Typ : Entity_Id;
7030
7031 begin
7032 N := Node;
7033
7034 -- Handle slices of slices by using the final (relevant) slice
7035
7036 if Nkind (Prefix (Node)) = N_Slice then
7037 loop
7038 Next := Prefix (N);
7039 exit when Nkind (Next) /= N_Slice;
7040 N := Next;
7041 end loop;
7042 end if;
7043
7044 Typ := Get_Full_View (Etype (Prefix (N)));
7045 Is_Access := Is_Access_Type (Typ);
7046
7047 if Is_Access then
7048 Typ := Get_Full_View (Directly_Designated_Type (Typ));
7049 end if;
7050
7051 if Ekind (Typ) = E_String_Literal_Subtype then
7052 Lbd := String_Literal_Low_Bound (Typ);
7053 else
7054 Lbd := Type_Low_Bound (Etype (First_Index (Typ)));
7055 end if;
7056
7057 Rng := Discrete_Range (Node);
7058
7059 -- We generate &arr[slice-low-bound - index-low-bound]
7060
7061 if Nkind (Rng) = N_Range then
7062 Lo := Low_Bound (Rng);
7063 else
7064 Lo := Type_Low_Bound (Etype (Rng));
7065 end if;
7066
7067 -- Omit & if prefix is an access type (for e.g. a function call
7068 -- that returns a pointer to an array).
7069
7070 if Is_Access then
7071 Cprint_Node_Paren (Prefix (N));
7072
7073 elsif Is_Unconstrained_Array_Type (Typ) then
7074 Write_Char ('&');
7075 Write_Unconstrained_Array_Prefix (Prefix (N));
7076 Write_Char ('[');
7077 Cprint_Node (Lo);
7078 Write_Str (" - ");
7079 Cprint_Node (Prefix (N));
7080 Write_Char ('.');
7081 Write_Fatptr_First (Typ, 1);
7082 Write_Char (']');
7083 Same_Values := True;
7084
7085 -- Generate simply arr instead of &arr[0]
7086
7087 elsif Has_Same_Int_Value (Lo, Lbd) then
7088 Cprint_Node_Paren (Prefix (N));
7089 Same_Values := True;
7090
7091 -- Normal case of an array, where we need the &
7092
7093 else
7094 Write_Char ('&');
7095 Cprint_Node_Paren (Prefix (N));
7096 end if;
7097
7098 if not Same_Values then
7099 Write_Char ('[');
7100 Cprint_Difference (Lo, Lbd, Minus_One_Min => False);
7101 Write_Char (']');
7102 end if;
7103 end;
7104
7105 when N_String_Literal =>
7106 declare
7107 Str : constant String_Id := Strval (Node);
7108 begin
7109 -- This test for line overflow is not quite right because of
7110 -- the business of escaping back slashes, but it's near enough.
7111
7112 if String_Length (Str) + Column > Sprint_Line_Limit then
7113 Write_Indent_Str (" ");
7114 end if;
7115
7116 -- Output string literal
7117
7118 Write_Char ('"');
7119
7120 for J in 1 .. String_Length (Str) loop
7121 Write_C_Char_Code (Get_String_Char (Str, J));
7122 end loop;
7123
7124 Write_Char ('"');
7125 end;
7126
7127 when N_Subprogram_Body =>
7128
7129 -- Skip generic subprograms
7130
7131 if Present (Corresponding_Spec (Node))
7132 and then Ekind (Corresponding_Spec (Node)) in
7133 Generic_Subprogram_Kind
7134 then
7135 null;
7136
7137 -- Skip writing of discriminant check function ???
7138
7139 elsif Is_Discriminant_Check_Function
7140 (Unique_Defining_Entity (Specification (Node)))
7141 then
7142 null;
7143
7144 -- Declare withed subprograms that have no spec and skip
7145 -- subprogram bodies outside of main units unless they are
7146 -- internally built public init-procs.
7147
7148 elsif not In_Main_Unit then
7149 if Acts_As_Spec (Node) then
7150 declare
7151 Subp : constant Entity_Id :=
7152 Unique_Defining_Entity (Specification (Node));
7153 begin
7154 if Nkind (Parent (Node)) = N_Compilation_Unit
7155 or else
7156 (Is_Init_Proc (Subp)
7157 and then Is_Public (Subp)
7158 and then not Is_Null_Init_Proc (Subp))
7159 then
7160 Cprint_Node (Specification (Node));
7161 Write_Str (";");
7162 end if;
7163 end;
7164 end if;
7165
7166 -- Otherwise write subprogram body
7167
7168 else
7169 Cprint_Subprogram_Body (Node);
7170 end if;
7171
7172 when N_Subprogram_Declaration =>
7173 declare
7174 Subp : constant Entity_Id := Unique_Defining_Entity (Node);
7175
7176 begin
7177 Write_Indent;
7178 Write_Itypes_In_Subtree (Specification (Node));
7179
7180 -- Do not print intrinsic subprogram as calls to those will be
7181 -- expanded.
7182
7183 if Convention (Subp) = Convention_Intrinsic
7184 or else Is_Intrinsic_Subprogram (Subp)
7185 then
7186 null;
7187
7188 -- Do not print functions that return arrays because they have
7189 -- been rewritten as procedures.
7190
7191 elsif Ekind (Subp) = E_Function
7192 and then Rewritten_For_C (Subp)
7193 then
7194 null;
7195
7196 -- Do not print C imported subprograms if -gnatd.5
7197
7198 elsif Debug_Flag_Dot_5
7199 and then Is_Imported (Subp)
7200 and then Convention (Subp) = Convention_C
7201 then
7202 null;
7203
7204 else
7205 if Last_Char = ';' then
7206 Write_Indent;
7207 end if;
7208
7209 Cprint_Node (Specification (Node), Declaration => True);
7210 Write_Char (';');
7211 end if;
7212 end;
7213
7214 when N_Subprogram_Renaming_Declaration =>
7215 null; -- not output in C code
7216
7217 when N_Subtype_Declaration =>
7218 declare
7219 Def_Id : constant Entity_Id := Defining_Identifier (Node);
7220
7221 begin
7222 -- For unidimensional unconstrained arrays the internal subtype
7223 -- generated by the front end is not needed by the generated
7224 -- C code since we directly use the pointer to the array
7225 -- components available in the fat pointer.
7226
7227 if Is_Internal (Def_Id)
7228 and then Ekind (Def_Id) = E_Array_Subtype
7229 and then Is_Unconstrained_Array_Type (Etype (Def_Id))
7230 and then No (Next_Index (First_Index (Def_Id)))
7231 then
7232 null;
7233 else
7234 Write_Source_Lines (Node);
7235 Cprint_Declare (Defining_Identifier (Node));
7236 end if;
7237 end;
7238
7239 when N_Subtype_Indication =>
7240
7241 -- Should have been handled higher up in tree
7242
7243 raise Program_Error;
7244
7245 when N_Subunit =>
7246
7247 -- This kind of node is not visible to the back end, since it has
7248 -- been replaced by the corresponding N_Body_Stub node.
7249
7250 null;
7251
7252 when N_Task_Body | N_Task_Definition =>
7253 raise Program_Error;
7254
7255 when N_Task_Type_Declaration =>
7256 null;
7257
7258 when N_Terminate_Alternative |
7259 N_Timed_Entry_Call |
7260 N_Triggering_Alternative
7261 =>
7262 raise Program_Error;
7263
7264 when N_Type_Conversion =>
7265 declare
7266 Typ : constant Entity_Id := Entity (Subtype_Mark (Node));
7267 Src_Typ : constant Entity_Id :=
7268 Get_Full_View (Etype (Expression (Node)));
7269
7270 begin
7271 -- Conversions from an access-to-constrained-array type to an
7272 -- access-to-unconstrained-array type must be handled when
7273 -- processing the parent node since they require initializing
7274 -- all the components of the target fat pointer.
7275
7276 if Is_Access_Type (Typ)
7277 and then Has_Fat_Pointer (Typ)
7278 and then not Has_Fat_Pointer (Etype (Expression (Node)))
7279 then
7280 Error_Msg_N
7281 ("unsupported conversion to access to unconstrained array",
7282 Node);
7283 end if;
7284
7285 -- Casting of array and record types not allowed in C
7286
7287 if not Is_Array_Type (Typ)
7288 and then not Is_Record_Type (Typ)
7289 then
7290 Write_Char ('(');
7291 Check_Definition (Typ, Error_Node => Subtype_Mark (Node));
7292 Cprint_Type_Name (Typ);
7293 Write_Char (')');
7294 end if;
7295
7296 -- Handle floating point rounding if needed
7297
7298 if Is_Integer_Type (Typ)
7299 and then Is_Floating_Point_Type (Src_Typ)
7300 and then not Float_Truncate (Node)
7301 then
7302 -- Apply same reasoning as described in
7303 -- gcc-interface/trans.c (convert_with_check, handling of
7304 -- !truncatep).
7305
7306 declare
7307 Point_5_Pred : constant String := "0.49999999999999994";
7308 -- Represents Long_Float'Pred (0.5)
7309
7310 begin
7311 Write_Char ('(');
7312 Cprint_Node_Paren (Expression (Node));
7313 Write_Str (" >= 0.0 ? ");
7314 Cprint_Node_Paren (Expression (Node));
7315 Write_Str (" + " & Point_5_Pred & " : ");
7316 Cprint_Node_Paren (Expression (Node));
7317 Write_Str (" - " & Point_5_Pred & ")");
7318 end;
7319
7320 else
7321 Cprint_Node_Paren (Expression (Node));
7322 end if;
7323
7324 if Is_Access_Type (Typ)
7325 and then not Has_Fat_Pointer (Typ)
7326 and then Has_Fat_Pointer (Etype (Expression (Node)))
7327 then
7328 Write_Fatptr_Dereference;
7329 end if;
7330 end;
7331
7332 when N_Unchecked_Expression =>
7333 raise Program_Error;
7334
7335 when N_Unchecked_Type_Conversion =>
7336 declare
7337 function Is_Pointer_Type (Typ : Entity_Id) return Boolean;
7338 -- Return True if Typ is an access type or descendant of
7339 -- System.Address.
7340
7341 ---------------------
7342 -- Is_Pointer_Type --
7343 ---------------------
7344
7345 function Is_Pointer_Type (Typ : Entity_Id) return Boolean is
7346 begin
7347 return Is_Access_Type (Typ)
7348 or else Is_Descendant_Of_Address (Typ);
7349 end Is_Pointer_Type;
7350
7351 -- Local variables
7352
7353 Target_Typ : constant Entity_Id :=
7354 Get_Full_View (Entity (Subtype_Mark (Node)));
7355 Parens_Needed : Natural := 0;
7356 Source : Node_Id;
7357 Source_Typ : Entity_Id;
7358
7359 begin
7360 -- In the case of nested unchecked type conversions we generate
7361 -- code that directly performs the cast of the innermost source
7362 -- type to the outermost target type. In this way the generated
7363 -- code is simpler and cleaner (the semantic analyzer has
7364 -- previously checked that they all match!).
7365
7366 Source := Expression (Node);
7367 while Nkind (Source) = N_Unchecked_Type_Conversion loop
7368 Source := Expression (Source);
7369 end loop;
7370
7371 Source_Typ := Get_Full_View (Etype (Source));
7372
7373 if Is_Packed_Array (Source_Typ) then
7374 Source_Typ := Packed_Array_Impl_Type (Source_Typ);
7375 end if;
7376
7377 -- No need to generate a cast if both types match. Compare base
7378 -- types, since in the generated C code all derived types and
7379 -- subtypes are equivalent.
7380
7381 if Base_Type (Source_Typ) = Base_Type (Target_Typ) then
7382 null;
7383
7384 -- Ignore array type conversions which are not supported in C,
7385 -- and assume this conversion is not needed. Is this always
7386 -- true???
7387
7388 elsif Ekind (Target_Typ) = E_Array_Subtype then
7389 null;
7390
7391 elsif
7392
7393 -- discrete <-> discrete
7394
7395 (Is_Discrete_Type (Source_Typ)
7396 and then Is_Discrete_Type (Target_Typ))
7397
7398 -- access/address <-> access/address
7399
7400 or else (Is_Pointer_Type (Source_Typ)
7401 and then Is_Pointer_Type (Target_Typ))
7402 then
7403 Write_Str ("((");
7404 Check_Definition (Target_Typ,
7405 Error_Node => Subtype_Mark (Node));
7406 Cprint_Type_Name (Target_Typ);
7407 Write_Str (")(");
7408 Parens_Needed := 2;
7409
7410 elsif Is_Composite_Type (Source_Typ)
7411 or else Is_Composite_Type (Target_Typ)
7412 or else Ekind (Source_Typ) /= Ekind (Target_Typ)
7413 then
7414 -- Strip extra type conversion
7415
7416 Source := Ultimate_Expression (Source);
7417
7418 if Is_Entity_Name (Source)
7419 and then Ekind (Entity (Source)) in Object_Kind
7420 then
7421 Write_Str ("(*(");
7422 Check_Definition (Target_Typ,
7423 Error_Node => Subtype_Mark (Node));
7424 Cprint_Type_Name (Target_Typ);
7425 Write_Str ("*)(&");
7426 Parens_Needed := 2;
7427
7428 -- ??? If source is not an object, should do a
7429 -- copy to a temporary. For now emit an error.
7430
7431 else
7432 Error_Msg_N ("unsupported unchecked_conversion", Node);
7433 end if;
7434 else
7435 Write_Str ("((");
7436 Check_Definition (Target_Typ,
7437 Error_Node => Subtype_Mark (Node));
7438 Cprint_Type_Name (Target_Typ);
7439 Write_Str (")(");
7440 Parens_Needed := 2;
7441 end if;
7442
7443 Cprint_Node_Paren (Source);
7444
7445 for J in 1 .. Parens_Needed loop
7446 Write_Char (')');
7447 end loop;
7448 end;
7449
7450 when N_Unconstrained_Array_Definition |
7451 N_Unused_At_Start |
7452 N_Unused_At_End
7453 =>
7454 raise Program_Error;
7455
7456 when N_Use_Package_Clause |
7457 N_Use_Type_Clause |
7458 N_Validate_Unchecked_Conversion
7459 =>
7460 null;
7461
7462 when N_Variant | N_Variant_Part =>
7463 raise Program_Error;
7464
7465 when N_With_Clause =>
7466
7467 -- "with" clauses can be ignored, since we are dumping all units
7468 -- inline.
7469
7470 null;
7471 end case;
7472
7473 Dump_Node := Save_Dump_Node;
7474 end Cprint_Node;
7475
7476 ----------------------
7477 -- Cprint_Node_List --
7478 ----------------------
7479
7480 procedure Cprint_Node_List (List : List_Id; New_Lines : Boolean := False) is
7481 Node : Node_Id;
7482
7483 begin
7484 if Is_Non_Empty_List (List) then
7485 Node := First (List);
7486
7487 loop
7488 Cprint_Node (Node);
7489 Next (Node);
7490 exit when Node = Empty;
7491 end loop;
7492 end if;
7493
7494 if New_Lines and then Column /= 1 then
7495 Write_Eol;
7496 end if;
7497 end Cprint_Node_List;
7498
7499 -----------------------
7500 -- Cprint_Node_Paren --
7501 -----------------------
7502
7503 procedure Cprint_Node_Paren (N : Node_Id) is
7504 begin
7505 -- Add parens if we have an operator or short circuit operation. But
7506 -- don't add the parens if already parenthesized, since we will get
7507 -- them anyway and don't add if definitely not needed.
7508
7509 if (Nkind (N) in N_Op
7510 or else Nkind_In (N, N_And_Then,
7511 N_Explicit_Dereference,
7512 N_If_Expression,
7513 N_In,
7514 N_Not_In,
7515 N_Or_Else))
7516 and then Parens_Needed (N)
7517 then
7518 Write_Char ('(');
7519 Cprint_Node (N);
7520 Write_Char (')');
7521 else
7522 Cprint_Node (N);
7523 end if;
7524 end Cprint_Node_Paren;
7525
7526 ---------------------
7527 -- Cprint_Opt_Node --
7528 ---------------------
7529
7530 procedure Cprint_Opt_Node (Node : Node_Id) is
7531 begin
7532 if Present (Node) then
7533 Write_Char (' ');
7534 Cprint_Node (Node);
7535 end if;
7536 end Cprint_Opt_Node;
7537
7538 --------------------------
7539 -- Cprint_Opt_Node_List --
7540 --------------------------
7541
7542 procedure Cprint_Opt_Node_List (List : List_Id) is
7543 begin
7544 if Present (List) then
7545 Cprint_Node_List (List);
7546 end if;
7547 end Cprint_Opt_Node_List;
7548
7549 ----------------------
7550 -- Cprint_Reference --
7551 ----------------------
7552
7553 function Cprint_Reference
7554 (Ent : Entity_Id;
7555 Add_Access : Boolean := False;
7556 Virtual_OK : Boolean := False) return Boolean
7557 is
7558 procedure Add_Star;
7559 -- Outputs '*' if Add_Access is True, otherwise does nothing
7560
7561 procedure Declare_Access_To_Array_Type (Typ : Entity_Id);
7562 -- Output the declaration of the access-to-array type Typ
7563
7564 procedure Declare_Access_Type (Typ : Entity_Id);
7565 -- Output the declaration of the discrete type Typ
7566
7567 procedure Declare_Array_Type
7568 (Typ : Entity_Id;
7569 Need_Semicolon : in out Boolean);
7570 -- Output the declaration of the array type Typ
7571
7572 procedure Declare_Discrete_Type (Typ : Entity_Id);
7573 -- Output the declaration of the discrete type Typ
7574
7575 procedure Declare_Record_Dependent_Types (Typ : Entity_Id);
7576 -- Force the declaration of the types of the dicriminants and components
7577 -- of the record type Typ.
7578
7579 procedure Declare_Record_Type (Typ : Entity_Id);
7580 -- Output the declaration of the record type Typ
7581
7582 procedure Write_Access_To_Subprogram_Decl (Typ : Entity_Id);
7583 -- Generate the C profile associated with an access-to-subprogram
7584 -- declaration.
7585 -- The caller is reponsible for adding "typedef " to the output before
7586 -- invoking this subprogram.
7587
7588 --------------
7589 -- Add_Star --
7590 --------------
7591
7592 procedure Add_Star is
7593 begin
7594 if Add_Access then
7595 Write_Char ('*');
7596 end if;
7597 end Add_Star;
7598
7599 -------------------------
7600 -- Declare_Access_Type --
7601 -------------------------
7602
7603 procedure Declare_Access_Type (Typ : Entity_Id) is
7604 begin
7605 if Ekind_In (Ent, E_Access_Protected_Subprogram_Type,
7606 E_Access_Subprogram_Type,
7607 E_Anonymous_Access_Subprogram_Type)
7608 then
7609 Write_Access_To_Subprogram_Decl (Typ);
7610
7611 elsif Is_Array_Type (Get_Full_View (Designated_Type (Typ))) then
7612 Declare_Access_To_Array_Type (Typ);
7613
7614 else
7615 if Is_Record_Type (Get_Full_View (Designated_Type (Typ))) then
7616 Write_Str ("struct _");
7617 end if;
7618
7619 declare
7620 DDT : Entity_Id := Get_Full_View (Designated_Type (Typ));
7621
7622 begin
7623 if Ekind (DDT) = E_Record_Subtype then
7624 DDT := Etype (DDT);
7625 end if;
7626
7627 Cprint_Type_Name (DDT);
7628 end;
7629
7630 -- For access-to-subprogram references there is no need to
7631 -- generate an explicit dereference, since we generate a typedef
7632 -- which has it (see Write_Access_To_Subprogram_Decl).
7633
7634 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
7635 Write_Str (" ");
7636 else
7637 Write_Str (" *");
7638 Add_Star;
7639 end if;
7640
7641 Cprint_Node (Ent, Declaration => True);
7642 end if;
7643 end Declare_Access_Type;
7644
7645 ------------------------
7646 -- Declare_Array_Type --
7647 ------------------------
7648
7649 procedure Declare_Array_Type
7650 (Typ : Entity_Id;
7651 Need_Semicolon : in out Boolean)
7652 is
7653 Indx : Node_Id;
7654 LBD : Node_Id;
7655 UBD : Node_Id;
7656 Val : Uint;
7657
7658 begin
7659 Check_Definition (Component_Type (Typ), Error_Node => Ent);
7660 Cprint_Type_Name (Component_Type (Typ));
7661 Write_Char (' ');
7662
7663 if not Is_Constrained (Typ) then
7664 Write_Char ('*');
7665 end if;
7666
7667 Cprint_Node (Ent, Declaration => True);
7668
7669 -- For multidimensional unconstrained array types, declare the
7670 -- typedef of its fat pointer.
7671
7672 if not Is_Constrained (Typ) then
7673 if not Is_Unidimensional_Array_Type (Typ) then
7674 Write_Char (';');
7675 Write_Indent;
7676
7677 Write_Fatptr_Declare (Ent);
7678 Need_Semicolon := False;
7679 end if;
7680
7681 -- Handle constrained array types
7682
7683 else
7684 -- Loop through subscripts
7685
7686 Indx := First_Index (Typ);
7687 loop
7688 Write_Char ('[');
7689
7690 if Is_Constrained (Typ) or not Virtual_OK then
7691 LBD := Type_Low_Bound (Etype (Indx));
7692 UBD := Type_High_Bound (Etype (Indx));
7693
7694 if Compile_Time_Known_Value (LBD) then
7695 if Compile_Time_Known_Value (UBD) then
7696 Val := Expr_Value (UBD) - Expr_Value (LBD) + Uint_1;
7697
7698 if Val < Uint_0 then
7699 Val := Uint_0;
7700 end if;
7701
7702 Write_Uint (Val);
7703
7704 elsif Expr_Value (LBD) = 1 then
7705 Cprint_Node (UBD);
7706
7707 elsif Expr_Value (LBD) < 1 then
7708 Cprint_Sum (UBD, 1 - Expr_Value (LBD), False);
7709
7710 else
7711 Cprint_Difference
7712 (UBD, Expr_Value (LBD) - 1, B => False);
7713 end if;
7714 else
7715 Cprint_Difference (UBD, LBD, Minus_One_Min => True);
7716 Write_Str (" + 1");
7717 end if;
7718 end if;
7719
7720 Write_Char (']');
7721
7722 Next_Index (Indx);
7723 exit when No (Indx);
7724 end loop;
7725 end if;
7726 end Declare_Array_Type;
7727
7728 ----------------------------------
7729 -- Declare_Access_To_Array_Type --
7730 ----------------------------------
7731
7732 procedure Declare_Access_To_Array_Type (Typ : Entity_Id) is
7733 begin
7734 -- For unconstrained array types, generate a typedef alias of this
7735 -- access type and the fat pointer of the array.
7736
7737 if not Is_Constrained (Get_Full_View (Designated_Type (Typ))) then
7738 Write_Fatptr_Name (Designated_Type (Typ));
7739 Write_Str (" ");
7740 Cprint_Node (Ent, Declaration => True);
7741
7742 -- Constrained array types
7743
7744 else
7745 Cprint_Type_Name (Designated_Type (Typ));
7746 Write_Char (' ');
7747
7748 -- No need to define a pointer to the array if this access type is
7749 -- an itype associated with a formal; otherwise we erroneously
7750 -- would generate the typedef of a pointer to a pointer.
7751
7752 if Is_Itype (Ent)
7753 and then Nkind_In (Associated_Node_For_Itype (Ent),
7754 N_Function_Specification,
7755 N_Procedure_Specification)
7756 then
7757 null;
7758 else
7759 Write_Char ('*');
7760 end if;
7761
7762 Cprint_Node (Ent, Declaration => True);
7763 end if;
7764 end Declare_Access_To_Array_Type;
7765
7766 ---------------------------
7767 -- Declare_Discrete_Type --
7768 ---------------------------
7769
7770 procedure Declare_Discrete_Type (Typ : Entity_Id) is
7771 begin
7772 Check_Definition (Typ, Error_Node => Ent);
7773 Cprint_Type_Name (Typ, Use_Typedef => Typ /= Ent);
7774 Write_Char (' ');
7775 Add_Star;
7776 Cprint_Node (Ent, Declaration => True);
7777
7778 if Is_Enumeration_Type (Typ)
7779 and then Sloc (Typ) > Standard_Location
7780 then
7781 Write_Char (';');
7782 Write_Indent;
7783
7784 declare
7785 Lit : Node_Id := First_Literal (Typ);
7786 begin
7787 pragma Assert (Present (Lit));
7788 Write_Str ("enum {");
7789
7790 loop
7791 Write_Id (Lit);
7792 Write_Char ('=');
7793 Write_Uint (Enumeration_Rep (Lit));
7794 Lit := Next_Literal (Lit);
7795
7796 exit when No (Lit);
7797
7798 Write_Str (", ");
7799 end loop;
7800
7801 Write_Str ("}");
7802 end;
7803 end if;
7804 end Declare_Discrete_Type;
7805
7806 ------------------------------------
7807 -- Declare_Record_Dependent_Types --
7808 ------------------------------------
7809
7810 procedure Declare_Record_Dependent_Types (Typ : Entity_Id) is
7811 procedure Declare_Component_Types (Clist : Node_Id);
7812 -- Recursive routine to declare the type of each list component
7813
7814 procedure Declare_Discriminant_Types (Typ : Node_Id);
7815 -- Declare the type of each discriminant of Typ
7816
7817 -----------------------------
7818 -- Declare_Component_Types --
7819 -----------------------------
7820
7821 procedure Declare_Component_Types (Clist : Node_Id) is
7822 Comp : Node_Id;
7823 Typ : Entity_Id;
7824 Var : Node_Id;
7825
7826 begin
7827 Comp := First (Component_Items (Clist));
7828 while Present (Comp) loop
7829
7830 -- Skip the declaration of component types defined in Standard
7831
7832 if Nkind (Comp) = N_Component_Declaration
7833 and then Sloc (Etype (Defining_Identifier (Comp))) >
7834 Standard_Location
7835 then
7836 Typ := Etype (Defining_Identifier (Comp));
7837
7838 -- Skip types depending on discriminants
7839
7840 if Size_Depends_On_Discriminant (Typ) then
7841 Register_Entity (Typ);
7842 else
7843 Dump_Type (Typ);
7844 end if;
7845
7846 if Is_Packed_Array (Typ) then
7847 Dump_Type (Packed_Array_Impl_Type (Typ));
7848 end if;
7849 end if;
7850
7851 Next (Comp);
7852 end loop;
7853
7854 -- Handle variant part
7855
7856 if Present (Variant_Part (Clist)) then
7857 Var := First (Variants (Variant_Part (Clist)));
7858
7859 while Present (Var) loop
7860 Declare_Component_Types (Component_List (Var));
7861 Next (Var);
7862 end loop;
7863 end if;
7864 end Declare_Component_Types;
7865
7866 --------------------------------
7867 -- Declare_Discriminant_Types --
7868 --------------------------------
7869
7870 procedure Declare_Discriminant_Types (Typ : Node_Id) is
7871 Discr : Entity_Id;
7872
7873 begin
7874 Discr := First_Discriminant (Typ);
7875
7876 while Present (Discr) loop
7877 Dump_Type (Etype (Discr));
7878 Next_Discriminant (Discr);
7879 end loop;
7880 end Declare_Discriminant_Types;
7881
7882 -- Local variables
7883
7884 Decl : constant Node_Id := Declaration_Node (Typ);
7885 RecD : Node_Id;
7886
7887 -- Start of processing for Declare_Record_Dependent_Types
7888
7889 begin
7890 if Nkind (Decl) = N_Full_Type_Declaration then
7891 if Has_Discriminants (Typ) then
7892 Declare_Discriminant_Types (Typ);
7893 end if;
7894
7895 RecD := Type_Definition (Decl);
7896
7897 if Nkind (RecD) = N_Record_Definition then
7898 Declare_Component_Types (Component_List (RecD));
7899 end if;
7900 else
7901 declare
7902 S : constant String := Node_Kind'Image (Nkind (Decl));
7903 begin
7904 Error_Msg_Strlen := S'Length;
7905 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
7906 Error_Msg_N ("unsupported type (~)", Decl);
7907 end;
7908
7909 Write_Str ("/* unsupported type */");
7910 end if;
7911 end Declare_Record_Dependent_Types;
7912
7913 -------------------------
7914 -- Declare_Record_Type --
7915 -------------------------
7916
7917 procedure Declare_Record_Type (Typ : Entity_Id) is
7918 begin
7919 -- For now not tagged
7920
7921 if Is_Tagged_Type (Typ) then
7922 Write_Str ("/* tagged */ ");
7923
7924 -- ??? raise Program_Error;
7925
7926 if not Full_Code_Generation then
7927 Error_Msg_N ("tagged types not supported", Typ);
7928 end if;
7929 end if;
7930
7931 Write_Str ("struct ");
7932
7933 if Is_Packed (Typ) and then not Full_Code_Generation then
7934 Error_Msg_N ("packed structs not supported", Typ);
7935 end if;
7936
7937 Write_Char ('_');
7938 Cprint_Node (Ent, Declaration => False);
7939 Write_Str (" {");
7940 Indent_Begin;
7941
7942 -- Output record components
7943
7944 Output_Components : declare
7945 Decl : constant Node_Id := Declaration_Node (Typ);
7946 Has_Rep_Clause : constant Boolean := Has_Non_Standard_Rep (Typ);
7947 Comp_Clauses : List_Id := No_List;
7948 RecD : Node_Id;
7949 Rep_Item : Node_Id;
7950
7951 procedure Output_Component_List (Clist : Node_Id);
7952 -- Recursive routine to output a component list
7953
7954 ---------------------------
7955 -- Output_Component_List --
7956 ---------------------------
7957
7958 procedure Output_Component_List (Clist : Node_Id) is
7959 Comp : Node_Id;
7960 FB : Uint;
7961 Ignore_Rep : Boolean := False;
7962 LB : Uint;
7963 Pad_Num : Int := 1;
7964 Pos : Uint;
7965 Prev_Bit : Uint := Uint_Minus_1;
7966 Prev_Pos : Uint := Uint_0;
7967 Rep_Clause : Node_Id := Empty;
7968 Siz : Uint;
7969 Typ : Entity_Id;
7970 Typ_Size : Uint;
7971 Var : Node_Id;
7972
7973 begin
7974 if Comp_Clauses /= No_List then
7975 Rep_Clause := First (Comp_Clauses);
7976 end if;
7977
7978 -- Output components (ignore types, pragmas etc)
7979
7980 Comp := First (Component_Items (Clist));
7981
7982 -- Look for relevant component clause if any
7983
7984 if Present (Comp) then
7985 loop
7986 exit when No (Rep_Clause)
7987 or else Entity (Component_Name (Rep_Clause)) =
7988 Defining_Identifier (Comp);
7989 Next (Rep_Clause);
7990 end loop;
7991 end if;
7992
7993 while Present (Comp) loop
7994 if Nkind (Comp) = N_Component_Declaration then
7995 Typ := Get_Full_View (Etype (Defining_Identifier (Comp)));
7996
7997 if Present (Rep_Clause) and then not Ignore_Rep then
7998
7999 -- Check that the rep clause has no holes since we
8000 -- only support this configuration for now. Also
8001 -- check that components are not larger than 64 bits.
8002
8003 FB := Intval (First_Bit (Rep_Clause));
8004 LB := Intval (Last_Bit (Rep_Clause));
8005 Pos := Intval (Position (Rep_Clause));
8006
8007 if ((FB = Uint_0
8008 and then Pos = Prev_Pos
8009 + (Prev_Bit + Uint_1) / Uint_8)
8010 or else (FB = Prev_Bit + Uint_1
8011 and then Pos = Prev_Pos))
8012 and then LB < Uint_64
8013 then
8014 -- Use type as-is if it is compatible with C
8015 -- bitfields (integer types).
8016
8017 Siz := LB - FB + Uint_1;
8018 Typ_Size := Esize (Typ);
8019
8020 if Is_Integer_Type (Typ)
8021 and then not Is_Descendant_Of_Address (Typ)
8022 then
8023 Write_Indent;
8024 Cprint_Declare
8025 (Defining_Identifier (Comp),
8026 Semicolon => False);
8027
8028 -- Replace type by an unsigned integer of the right
8029 -- size.
8030
8031 elsif Typ_Size > Uint_0 and then Typ_Size <= Uint_64
8032 then
8033 Write_Indent;
8034
8035 if Typ_Size <= Uint_32 then
8036 Write_Integer_Type (32, Signed => False);
8037 else
8038 Write_Integer_Type (64, Signed => False);
8039 end if;
8040
8041 Write_Char (' ');
8042 Cprint_Node
8043 (Defining_Identifier (Comp),
8044 Declaration => True);
8045
8046 else
8047 Cprint_Declare (Defining_Identifier (Comp));
8048 Error_Msg_N
8049 ("?unsupported representation clause, "
8050 & "assuming confirming", Rep_Clause);
8051 Ignore_Rep := True;
8052
8053 -- Reset Has_Non_Standard_Rep since we are
8054 -- ignoring it.
8055
8056 Set_Has_Non_Standard_Rep
8057 (Get_Full_View (Etype (Ent)), False);
8058 end if;
8059
8060 -- Handle some cases of padding, when the size of
8061 -- Typ is known by the front end.
8062
8063 if Typ_Size > Uint_0 and then Typ_Size < Siz then
8064 Siz := Siz - Typ_Size;
8065
8066 if Siz > Uint_64 then
8067 Error_Msg_N
8068 ("?unsupported representation clause, "
8069 & "assuming confirming", Rep_Clause);
8070 Ignore_Rep := True;
8071 Set_Has_Non_Standard_Rep
8072 (Get_Full_View (Etype (Ent)), False);
8073
8074 else
8075 Write_Str (" : ");
8076 Write_Uint (Typ_Size);
8077 Write_Char (';');
8078 Write_Indent;
8079
8080 if Siz <= Uint_32 then
8081 Write_Integer_Type (32, Signed => False);
8082 else
8083 Write_Integer_Type (64, Signed => False);
8084 end if;
8085
8086 Write_Str (" _pad");
8087 Write_Int (Pad_Num);
8088 Pad_Num := Pad_Num + 1;
8089 end if;
8090 end if;
8091
8092 if not Ignore_Rep then
8093 Write_Str (" : ");
8094 Write_Uint (Siz);
8095 Write_Char (';');
8096 Prev_Bit := LB;
8097 Prev_Pos := Pos;
8098 end if;
8099 else
8100 -- Skip error for runtime files for now???
8101
8102 if not In_Predefined_Unit (Rep_Clause) then
8103 Error_Msg_N
8104 ("?unsupported representation clause, " &
8105 "assuming confirming",
8106 Rep_Clause);
8107 Ignore_Rep := True;
8108 Set_Has_Non_Standard_Rep
8109 (Get_Full_View (Etype (Ent)), False);
8110 end if;
8111
8112 Cprint_Declare (Defining_Identifier (Comp));
8113 end if;
8114
8115 Next (Rep_Clause);
8116
8117 else
8118 if Size_Depends_On_Discriminant (Typ) then
8119 Write_Indent;
8120 Cprint_Node (Component_Type (Base_Type (Typ)));
8121 Write_Char (' ');
8122 Cprint_Node (Defining_Identifier (Comp));
8123 Write_Str ("[1];");
8124
8125 else
8126 Cprint_Declare (Defining_Identifier (Comp));
8127 end if;
8128 end if;
8129 end if;
8130
8131 Next (Comp);
8132 end loop;
8133
8134 -- Output variant part if present
8135
8136 if Present (Variant_Part (Clist)) then
8137
8138 -- ??? anonymous unions and structs are not supported by C90
8139
8140 Write_Indent_Str ("union {");
8141 Indent_Begin;
8142
8143 Var := First (Variants (Variant_Part (Clist)));
8144 while Present (Var) loop
8145 declare
8146 VCList : constant Node_Id := Component_List (Var);
8147 VCItems : constant List_Id := Component_Items (VCList);
8148
8149 begin
8150 -- If only one component in this component list, we
8151 -- can output it as a single member of the union.
8152
8153 if List_Length (VCItems) = 1 then
8154 Output_Component_List (VCList);
8155
8156 -- Otherwise we have more than one component, so we
8157 -- have to introduce a struct.
8158
8159 else
8160 Write_Indent_Str ("struct {");
8161 Indent_Begin;
8162 Output_Component_List (VCList);
8163 Indent_End;
8164 Write_Indent_Str ("};");
8165 end if;
8166 end;
8167
8168 Next (Var);
8169 end loop;
8170
8171 Indent_End;
8172 Write_Indent_Str ("};");
8173 end if;
8174 end Output_Component_List;
8175
8176 -- Start of output for Output_Components
8177
8178 begin
8179 -- For now, limit cases we handle???
8180
8181 if Nkind (Decl) = N_Full_Type_Declaration then
8182 RecD := Type_Definition (Decl);
8183
8184 if Nkind (RecD) = N_Record_Definition then
8185 if Has_Rep_Clause then
8186 Rep_Item := First_Rep_Item (Typ);
8187
8188 while Present (Rep_Item)
8189 and then Nkind (Rep_Item) /=
8190 N_Record_Representation_Clause
8191 loop
8192 Next_Rep_Item (Rep_Item);
8193 end loop;
8194
8195 if Present (Rep_Item) then
8196 Comp_Clauses := Component_Clauses (Rep_Item);
8197 end if;
8198 end if;
8199
8200 -- Output discriminants
8201
8202 declare
8203 Disc : Node_Id;
8204 begin
8205 if Present (Discriminant_Specifications (Decl)) then
8206 Disc := First (Discriminant_Specifications (Decl));
8207 while Present (Disc) loop
8208 Cprint_Declare (Defining_Identifier (Disc));
8209 Next (Disc);
8210 end loop;
8211 end if;
8212 end;
8213
8214 -- Output components
8215
8216 Output_Component_List (Component_List (RecD));
8217 end if;
8218 else
8219 declare
8220 S : constant String := Node_Kind'Image (Nkind (Decl));
8221 begin
8222 Error_Msg_Strlen := S'Length;
8223 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
8224 Error_Msg_N ("unsupported type (~)", Decl);
8225 end;
8226
8227 Error_Msg_N ("unsupported type", Decl);
8228 Write_Str ("/* unsupported type */");
8229 end if;
8230 end Output_Components;
8231
8232 Indent_End;
8233 Write_Indent_Str ("} ");
8234 Add_Star;
8235 Cprint_Node (Ent, Declaration => True);
8236 end Declare_Record_Type;
8237
8238 -------------------------------------
8239 -- Write_Access_To_Subprogram_Decl --
8240 -------------------------------------
8241
8242 procedure Write_Access_To_Subprogram_Decl (Typ : Entity_Id) is
8243 DT : constant Node_Id := Designated_Type (Typ);
8244 begin
8245 if Etype (DT) = Standard_Void_Type then
8246 Write_Str ("void ");
8247 else
8248 Write_Name_Col_Check (Chars (Etype (DT)));
8249 Write_Str (" ");
8250 end if;
8251
8252 Write_Str_Col_Check ("(*");
8253 Write_Id (Typ);
8254 Write_Str_Col_Check (")");
8255
8256 Write_Param_Specs (DT);
8257 end Write_Access_To_Subprogram_Decl;
8258
8259 -- Local variables
8260
8261 Need_Semicolon : Boolean := True;
8262 Original_Type : Entity_Id := Etype (Ent);
8263 Typ : Entity_Id := Get_Full_View (Original_Type);
8264
8265 -- Start of processing for Cprint_Reference
8266
8267 begin
8268 if Is_Type (Ent) then
8269 if not In_Declarations then
8270 Open_Extra_Scope;
8271 end if;
8272
8273 if (Is_Record_Type (Ent) or else Is_Array_Type (Ent))
8274 and then Reverse_Storage_Order (Ent)
8275 then
8276 Error_Msg_N ("non default storage order not supported", Ent);
8277 end if;
8278
8279 -- Declare types on which this type depends. This is required to
8280 -- handle private types since we generate the code of its full view
8281 -- when we see the partial view.
8282
8283 -- For record types ensure that the types of all the components are
8284 -- declared before we generate the corresponding C struct.
8285
8286 if Is_Record_Type (Typ) then
8287 Declare_Record_Dependent_Types (Typ);
8288
8289 -- For array types ensure that its component type is declared
8290
8291 elsif Is_Array_Type (Typ) then
8292 Dump_Type (Component_Type (Typ));
8293
8294 -- For access types ensure that its designated type is declared.
8295 -- Access-to-procedure types are obviously excluded; access-to-record
8296 -- types are excluded since Cprint_Reference has support for access-
8297 -- to-incomplete record types. For example:
8298
8299 -- type Rec;
8300 -- type Ptr is access all Rec;
8301 -- type Rec is record
8302 -- Next : Ptr;
8303 -- end record;
8304
8305 elsif Is_Access_Type (Typ) then
8306 if Etype (Designated_Type (Typ)) /= Standard_Void_Type
8307 and then not
8308 Is_Record_Type (Get_Full_View (Designated_Type (Typ)))
8309 then
8310 Dump_Type (Designated_Type (Typ));
8311 end if;
8312
8313 -- Ensure that the designated type of access-to-constrained-array
8314 -- types is defined.
8315
8316 if Ekind (Ent) = E_Access_Subtype
8317 and then Is_Constrained_Array_Type
8318 (Get_Full_View (Designated_Type (Ent)))
8319 then
8320 Dump_Type (Designated_Type (Ent));
8321 end if;
8322 end if;
8323
8324 if not Entity_Table.Get (Typ)
8325 and then (Entity_Is_In_Main_Unit (Typ) or else Is_Itype (Typ))
8326 then
8327 Cprint_Declare (Typ);
8328 Write_Indent;
8329
8330 elsif Last_Char = ';' or else Last_Char = '{' then
8331 Write_Indent;
8332 end if;
8333
8334 Write_Str ("typedef ");
8335
8336 else
8337 if Is_Packed_Array (Typ) then
8338 Typ := Packed_Array_Impl_Type (Typ);
8339 Original_Type := Typ;
8340
8341 if not Entity_Table.Get (Typ) then
8342 Cprint_Declare (Typ);
8343 Write_Indent;
8344 end if;
8345 end if;
8346 end if;
8347
8348 -- If type is not the identity (as occurs in the enumeration type case)
8349 -- nor an array subtype (since its length most probably differs), then
8350 -- use the typedef.
8351
8352 if Typ /= Ent and then Ekind (Ent) /= E_Array_Subtype then
8353 if Ekind (Ent) = E_Variable and then Has_Discriminants (Typ) then
8354 declare
8355 Field : constant Node_Id := Last_Field (Typ);
8356 Rng : Node_Id;
8357
8358 begin
8359 if Has_Per_Object_Constraint (Field)
8360 and then Ekind (Etype (Field)) = E_Array_Subtype
8361 then
8362 -- For an object declaration whose type is a record with
8363 -- discriminants and whose last field depends on this
8364 -- discriminant, generate:
8365 -- unsigned_8 _<id>[<size>];
8366 -- #define <id> (*(<type>)_<id>)
8367
8368 Write_Str ("unsigned_8 _");
8369 Cprint_Node (Ent, Declaration => True);
8370
8371 if In_Main_Unit then
8372 Write_Str ("[sizeof(");
8373 Check_Definition (Original_Type, Error_Node => Ent);
8374 Cprint_Node (Original_Type, Declaration => True);
8375 Write_Str (") + ");
8376 Rng := First_Index (Etype (Field));
8377
8378 if Nkind (Rng) = N_Range then
8379
8380 -- Note: we do not add +1 here since sizeof()
8381 -- already accounts for 1 element.
8382
8383 Write_Uint
8384 (Intval (High_Bound (Rng)) -
8385 Intval (Low_Bound (Rng)));
8386 Write_Str (" * sizeof(");
8387 Check_Definition (Component_Type (Etype (Field)),
8388 Error_Node => Field);
8389 Cprint_Type_Name (Component_Type (Etype (Field)));
8390 Write_Char (')');
8391
8392 else
8393 Error_Msg_N ("cannot compute size for field", Field);
8394 Write_Char ('0');
8395 end if;
8396
8397 Write_Str ("];");
8398 else
8399 Write_Str ("[];");
8400 end if;
8401
8402 Write_Eol;
8403 Write_Str ("#define ");
8404 Cprint_Node (Ent, Declaration => True);
8405 Write_Str (" (*(");
8406 Cprint_Node (Original_Type, Declaration => True);
8407 Write_Str (" *)_");
8408 Cprint_Node (Ent, Declaration => True);
8409 Write_Str (")");
8410 Write_Eol;
8411
8412 -- Record this macro so that it will be #undef'ed at the end
8413 -- of the current scope.
8414
8415 if not Library_Level then
8416 Macro_Table.Append (Ent);
8417 end if;
8418
8419 -- Remember that this entity is defined
8420
8421 Register_Entity (Ent);
8422
8423 return False;
8424 end if;
8425 end;
8426
8427 elsif Is_Formal (Ent)
8428 and then
8429 (Is_Array_Type (Typ)
8430 or else
8431 (Is_Access_Type (Typ)
8432 and then
8433 Is_Array_Type (Get_Full_View (Designated_Type (Typ)))))
8434 then
8435 declare
8436 Orig_Full_Type : constant Entity_Id :=
8437 Get_Full_View (Original_Type);
8438
8439 begin
8440 Check_Definition (Orig_Full_Type, Error_Node => Ent);
8441
8442 if Is_Access_Type (Typ) then
8443 if Is_Out_Mode_Access_Formal (Ent) then
8444 if Is_Unconstrained_Array_Type (Typ) then
8445 Write_Fatptr_Name (Orig_Full_Type);
8446 else
8447 Cprint_Node (Orig_Full_Type, Declaration => True);
8448 end if;
8449
8450 Write_Str ("* ");
8451 else
8452 declare
8453 DDT : constant Entity_Id :=
8454 Get_Full_View
8455 (Designated_Type (Orig_Full_Type));
8456 begin
8457 if Is_Constrained_Array_Type (DDT) then
8458 Write_Id (DDT);
8459 Write_Char (' ');
8460 else
8461 Write_Id (Orig_Full_Type);
8462 Write_Char (' ');
8463 Add_Star;
8464 end if;
8465 end;
8466 end if;
8467 else
8468 if Is_Unconstrained_Array_Type (Typ) then
8469 Write_Fatptr_Name (Orig_Full_Type);
8470 else
8471 Cprint_Node (Orig_Full_Type, Declaration => True);
8472 end if;
8473
8474 Write_Char (' ');
8475 end if;
8476 end;
8477
8478 Cprint_Node (Ent, Declaration => True);
8479 return Need_Semicolon;
8480 end if;
8481
8482 -- When declaring a scalar typedef, check whether the base type and
8483 -- the subtype have the same size, otherwise use a different base
8484 -- type.
8485
8486 if Is_Type (Ent)
8487 and then Is_Scalar_Type (Typ)
8488 and then Esize (Typ) /= Esize (Ent)
8489 then
8490 Write_Integer_Type
8491 (UI_To_Int (Esize (Ent)),
8492 Signed => not Is_Modular_Integer_Type (Ent));
8493
8494 elsif Ekind (Ent) = E_String_Literal_Subtype then
8495 Write_Str ("character");
8496
8497 -- Handle the declaration of access subtypes whose designated type
8498 -- is a constrained array type. This is specially needed if the
8499 -- access type is a subtype of an access-to-unconstrained-array type,
8500 -- since no fat pointer will be used with this access subtype (the
8501 -- bounds of the array type are available in the constrained
8502 -- designated type).
8503
8504 elsif Ekind (Ent) = E_Access_Subtype
8505 and then Is_Constrained_Array_Type
8506 (Get_Full_View (Designated_Type (Ent)))
8507 then
8508 Declare_Access_To_Array_Type (Ent);
8509 return Need_Semicolon;
8510
8511 elsif Ekind (Ent) = E_Private_Subtype then
8512 Check_Definition (Typ, Error_Node => Ent);
8513 Cprint_Node (Typ, Declaration => True);
8514
8515 -- Ensure that we do not generate dummy typedef declarations like
8516 -- typedef sometype sometype;
8517
8518 pragma Assert (Chars (Typ) /= Chars (Ent));
8519
8520 else
8521 Check_Definition (Original_Type, Error_Node => Ent);
8522 Cprint_Node (Original_Type, Declaration => True);
8523
8524 -- Ensure that we do not generate dummy typedef declarations like
8525 -- typedef sometype sometype;
8526
8527 pragma Assert (Chars (Original_Type) /= Chars (Ent));
8528 end if;
8529
8530 Write_Char (' ');
8531 Add_Star;
8532 Cprint_Node (Ent, Declaration => True);
8533
8534 if Ekind (Ent) = E_String_Literal_Subtype then
8535 declare
8536 Val : Uint := String_Literal_Length (Ent);
8537 begin
8538 Write_Str ("[");
8539
8540 if Val < Uint_0 then
8541 Val := Uint_0;
8542 end if;
8543
8544 Write_Uint (Val);
8545 Write_Char (']');
8546 end;
8547 end if;
8548
8549 -- Discrete type
8550
8551 elsif Is_Discrete_Type (Typ) then
8552 Declare_Discrete_Type (Typ);
8553
8554 -- Access type
8555
8556 elsif Is_Access_Type (Typ) then
8557 Declare_Access_Type (Typ);
8558
8559 -- Record type
8560
8561 elsif Is_Record_Type (Typ) then
8562 Declare_Record_Type (Typ);
8563
8564 -- Array type
8565
8566 elsif Is_Array_Type (Typ) then
8567 -- For array subtypes, directly use this entity to compute the length
8568 -- of the array.
8569
8570 if Ekind (Ent) = E_Array_Subtype then
8571 Declare_Array_Type (Ent, Need_Semicolon);
8572 else
8573 Declare_Array_Type (Typ, Need_Semicolon);
8574 end if;
8575
8576 elsif Is_Fixed_Point_Type (Typ) then
8577 if Etype (Typ) = Typ then
8578 Write_Integer_Type (UI_To_Int (Esize (Typ)), Signed => True);
8579 else
8580 Check_Definition (Typ, Error_Node => Ent);
8581 Cprint_Node (Typ, Declaration => True);
8582 end if;
8583
8584 Write_Char (' ');
8585 Add_Star;
8586 Cprint_Node (Ent, Declaration => True);
8587
8588 -- For anything else, other than a type declaration, assume we have
8589 -- typedef reference.
8590
8591 elsif Typ /= Ent then
8592 Check_Definition (Typ, Error_Node => Ent);
8593 Cprint_Node (Typ, Declaration => True);
8594 Write_Char (' ');
8595 Add_Star;
8596 Cprint_Node (Ent, Declaration => True);
8597
8598 -- Generate an error on other cases
8599
8600 else
8601 declare
8602 S : constant String := Entity_Kind'Image (Ekind (Typ));
8603 begin
8604 Error_Msg_Strlen := S'Length;
8605 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
8606 Error_Msg_N ("unsupported type (~)", Typ);
8607 end;
8608
8609 Need_Semicolon := False;
8610 end if;
8611
8612 return Need_Semicolon;
8613 end Cprint_Reference;
8614
8615 -----------------------
8616 -- Cprint_Right_Opnd --
8617 -----------------------
8618
8619 procedure Cprint_Right_Opnd (N : Node_Id) is
8620 Opnd : constant Node_Id := Right_Opnd (N);
8621 begin
8622 Cprint_Node_Paren (Opnd);
8623 end Cprint_Right_Opnd;
8624
8625 -----------------------------
8626 -- Append_Subpogram_Prefix --
8627 -----------------------------
8628
8629 procedure Append_Subprogram_Prefix (Spec : Node_Id) is
8630 function Name_String (Name : Name_Id) return String;
8631 -- Returns the name string associated with Name
8632
8633 function New_Name_Id (Name : String) return Name_Id;
8634 -- Returns a Name_Id corresponding to the given name string
8635
8636 -----------------
8637 -- Name_String --
8638 -----------------
8639
8640 function Name_String (Name : Name_Id) return String is
8641 begin
8642 pragma Assert (Name /= No_Name);
8643 return Get_Name_String (Name);
8644 end Name_String;
8645
8646 -----------------
8647 -- New_Name_Id --
8648 -----------------
8649
8650 function New_Name_Id (Name : String) return Name_Id is
8651 begin
8652 for J in 1 .. Name'Length loop
8653 Name_Buffer (J) := Name (Name'First + (J - 1));
8654 end loop;
8655
8656 Name_Len := Name'Length;
8657 return Name_Find;
8658 end New_Name_Id;
8659
8660 -- Local variables
8661
8662 Subp : constant Entity_Id := Unique_Defining_Entity (Spec);
8663
8664 -- Start of processing for Append_Subprogram_Prefix
8665
8666 begin
8667 if Is_Compilation_Unit (Subp) then
8668 declare
8669 Prefix : constant String := "_ada_";
8670 Subp_Name : Name_Id := Chars (Subp);
8671 Subp_Str : constant String := Name_String (Subp_Name);
8672
8673 begin
8674 -- Do not append the prefix if already done as part of processing
8675 -- its declaration.
8676
8677 if Subp_Str'Length <= Prefix'Length
8678 or else
8679 Subp_Str (Subp_Str'First ..
8680 Subp_Str'First + Prefix'Length - 1) /= Prefix
8681 then
8682 Subp_Name := New_Name_Id ("_ada_" & Name_String (Subp_Name));
8683 Set_Chars (Subp, Subp_Name);
8684 end if;
8685 end;
8686 end if;
8687 end Append_Subprogram_Prefix;
8688
8689 ----------------------------
8690 -- Cprint_Subprogram_Body --
8691 ----------------------------
8692
8693 -- Note: we already dealt with outputting the header for this subprogram
8694
8695 procedure Cprint_Subprogram_Body (N : Node_Id) is
8696 procedure Output_One_Body (Node : Node_Id);
8697 -- Output a single subprogram body, for this call, any subprogram nested
8698 -- within this subprogram will have been removed.
8699
8700 procedure Unnest_Types (Scop : Entity_Id; N : Node_Id);
8701 -- Force the declaration of the relevant types referenced in the tree N
8702 -- and which are not defined in the scope Scop.
8703
8704 procedure Unsupported_Nested_Subprogram (N : Node_Id);
8705 -- Locate the first inner nested subprogram and report the error on it
8706
8707 ---------------------
8708 -- Output_One_Body --
8709 ---------------------
8710
8711 procedure Output_One_Body (Node : Node_Id) is
8712 Prev_Id : constant Entity_Id := Current_Subp_Entity;
8713 Subp_Id : constant Entity_Id := Unique_Defining_Entity (Node);
8714 Scop_Id : Nat;
8715
8716 begin
8717 Unnest_Types (Subp_Id, Node);
8718
8719 Library_Level := False;
8720 Ensure_New_Line;
8721 Write_Source_Lines (Specification (Node));
8722
8723 Write_Indent;
8724 Cprint_Node (Declaration_Node (Subp_Id));
8725
8726 Write_Char (' ');
8727 Open_Scope;
8728 Scop_Id := Current_Scope_Id;
8729 Current_Subp_Entity := Subp_Id;
8730 Declare_Back_End_Itypes (Subp_Id);
8731
8732 if Is_Non_Empty_List (Declarations (Node)) then
8733 Cprint_Indented_List (Declarations (Node));
8734 end if;
8735
8736 Set_In_Statements;
8737 Cprint_Node (Handled_Statement_Sequence (Node));
8738
8739 -- #undef registered macros for this subprogram, if any
8740
8741 for J in 1 .. Macro_Table.Last loop
8742 Write_Indent_Str ("#undef ");
8743 Write_Id (Macro_Table.Table (J));
8744 end loop;
8745
8746 Macro_Table.Set_Last (0);
8747
8748 Write_Indent;
8749
8750 -- Close this scope plus all its inner scopes (that is, its extra
8751 -- back-end scopes and the deferred scopes of its nested packages;
8752 -- see Cprint_Node.N_Package_Specification).
8753
8754 Close_Scope (Scop_Id);
8755
8756 Library_Level := True;
8757 Current_Subp_Entity := Prev_Id;
8758 end Output_One_Body;
8759
8760 ------------------
8761 -- Unnest_Types --
8762 ------------------
8763
8764 procedure Unnest_Types (Scop : Entity_Id; N : Node_Id) is
8765 function Depends_On_Formals (Itype : Entity_Id) return Boolean;
8766 -- Return True if Itype is an array type whose definition depends on
8767 -- the formals of a subprogram.
8768
8769 function Search_Type_Refs (Node : Node_Id) return Traverse_Result;
8770 -- Subtree visitor which looks for relevant references to types
8771 -- and declare them.
8772
8773 ------------------------
8774 -- Depends_On_Formals --
8775 ------------------------
8776
8777 function Depends_On_Formals (Itype : Entity_Id) return Boolean is
8778 function References_Formal (N : Node_Id) return Boolean;
8779 -- Return True if N is 'First or 'Last applied to a subprogram
8780 -- formal.
8781
8782 -----------------------
8783 -- References_Formal --
8784 -----------------------
8785
8786 function References_Formal (N : Node_Id) return Boolean is
8787 begin
8788 return Nkind (N) = N_Attribute_Reference
8789 and then Nkind (Prefix (N)) in N_Has_Entity
8790 and then Is_Formal (Entity (Prefix (N)))
8791 and then
8792 (Get_Attribute_Id (Attribute_Name (N)) = Attribute_First
8793 or else
8794 Get_Attribute_Id (Attribute_Name (N)) = Attribute_Last);
8795 end References_Formal;
8796
8797 -- Start of processing for Depends_On_Formals
8798
8799 begin
8800 if not Is_Array_Type (Itype) then
8801 return False;
8802 end if;
8803
8804 declare
8805 Ind : Node_Id := First_Index (Itype);
8806
8807 begin
8808 while Present (Ind) loop
8809 if Nkind (Ind) = N_Range
8810 and then
8811 (References_Formal (Low_Bound (Ind))
8812 or else References_Formal (High_Bound (Ind)))
8813 then
8814 return True;
8815 end if;
8816
8817 Next_Index (Ind);
8818 end loop;
8819 end;
8820
8821 return False;
8822 end Depends_On_Formals;
8823
8824 ----------------------
8825 -- Search_Type_Refs --
8826 ----------------------
8827
8828 function Search_Type_Refs (Node : Node_Id) return Traverse_Result is
8829 Typ : Entity_Id := Empty;
8830
8831 begin
8832 case Nkind (Node) is
8833 when N_Attribute_Reference =>
8834 if Get_Attribute_Id (Attribute_Name (Node)) = Attribute_Deref
8835 then
8836 Typ := Get_Full_View (Etype (Prefix (Node)));
8837 end if;
8838
8839 when N_Type_Conversion =>
8840 Typ := Get_Full_View (Entity (Subtype_Mark (Node)));
8841
8842 when N_Unchecked_Type_Conversion =>
8843 Typ := Get_Full_View (Entity (Subtype_Mark (Node)));
8844
8845 -- For UCs we want to unnest as many types as possible to
8846 -- inline UCs in e.g. Cprint_Copy.
8847
8848 if Scope (Typ) /= Scop then
8849 Dump_Type (Typ);
8850 return OK;
8851 end if;
8852
8853 when N_Object_Declaration =>
8854 Typ := Get_Full_View (Etype (Defining_Identifier (Node)));
8855
8856 when others =>
8857 null;
8858 end case;
8859
8860 if Present (Typ)
8861 and then Scope_Depth_Value (Scope (Typ)) <
8862 Scope_Depth_Value (Scop)
8863 and then not Depends_On_Formals (Typ)
8864 then
8865 Dump_Type (Typ);
8866 end if;
8867
8868 return OK;
8869 end Search_Type_Refs;
8870
8871 procedure Search is new Traverse_Proc (Search_Type_Refs);
8872 -- Subtree visitor instantiation
8873
8874 -- Local variables
8875
8876 In_Search_Type_Ref_Save : constant Boolean := In_Search_Type_Ref;
8877
8878 -- Start of processing for Unnest_Types
8879
8880 begin
8881 In_Search_Type_Ref := True;
8882 Search (N);
8883 In_Search_Type_Ref := In_Search_Type_Ref_Save;
8884 end Unnest_Types;
8885
8886 -----------------------------------
8887 -- Unsupported_Nested_Subprogram --
8888 -----------------------------------
8889
8890 procedure Unsupported_Nested_Subprogram (N : Node_Id) is
8891 function Search_Subprogram (Node : Node_Id) return Traverse_Result;
8892 -- Subtree visitor which looks for the subprogram
8893
8894 -----------------------
8895 -- Search_Subprogram --
8896 -----------------------
8897
8898 function Search_Subprogram (Node : Node_Id) return Traverse_Result is
8899 begin
8900 if Node /= N
8901 and then Nkind (Node) = N_Subprogram_Body
8902
8903 -- Do not report the error on generic subprograms; the error
8904 -- will be reported only in their instantiations (to leave the
8905 -- output more clean).
8906
8907 and then not
8908 Is_Generic_Subprogram (Unique_Defining_Entity (Node))
8909 then
8910 Error_Msg_N ("unsupported kind of nested subprogram", Node);
8911 return Abandon;
8912 end if;
8913
8914 return OK;
8915 end Search_Subprogram;
8916
8917 procedure Search is new Traverse_Proc (Search_Subprogram);
8918 -- Subtree visitor instantiation
8919
8920 -- Start of processing for Unsupported_Nested_Subprogram
8921
8922 begin
8923 Search (N);
8924 end Unsupported_Nested_Subprogram;
8925
8926 -- Local declarations
8927
8928 Subp : constant Entity_Id := Unique_Defining_Entity (N);
8929
8930 -- Start of processing for Cprint_Subprogram_Body
8931
8932 begin
8933 if In_Package_Body_Init or else Present (Current_Subp_Entity) then
8934 Error_Msg_N ("unsupported kind of nested subprogram", N);
8935 return;
8936
8937 -- If no nested subprograms, just output the body
8938
8939 elsif not Has_Nested_Subprogram (Subp) then
8940 Output_One_Body (N);
8941 return;
8942
8943 -- Temporarily protect us against unsupported kind of nested subprograms
8944 -- (for example, subprograms defined in nested instantiations)???
8945
8946 elsif Subps_Index (Subp) = Uint_0 then
8947 Unsupported_Nested_Subprogram (N);
8948 return;
8949 end if;
8950
8951 -- Here we deal with a subprogram with nested subprograms
8952
8953 declare
8954 Subps_First : constant SI_Type := UI_To_Int (Subps_Index (Subp));
8955 Subps_Last : constant SI_Type := Subps.Table (Subps_First).Last;
8956 -- First and last indexes for Subps table entries for this nest
8957
8958 pragma Assert (Subps_First /= 0);
8959
8960 begin
8961 -- First step is to output the declarations for ARECnT and ARECnPT
8962 -- for each subprogram which define these entities for an activation
8963 -- record. These are generated at the outer level, so that they can
8964 -- be referenced by the unnested bodies. The ordering is important,
8965 -- since inner activation records refer to entities in outer records
8966 -- but the order of entries in Subp guarantees this is the case.
8967
8968 Output_AREC : for J in Subps_First .. Subps_Last loop
8969 declare
8970 STJ : Subp_Entry renames Subps.Table (J);
8971 Decls : constant List_Id := Declarations (STJ.Bod);
8972 Decl : Node_Id;
8973
8974 begin
8975 if Present (STJ.ARECnT) then
8976
8977 -- First declaration should be for ARECnT
8978
8979 Decl := Remove_Head (Decls);
8980 pragma Assert (Defining_Identifier (Decl) = STJ.ARECnT);
8981 Cprint_Node (Decl);
8982
8983 -- Second declaration should be for ARECnPT
8984
8985 Decl := Remove_Head (Decls);
8986 pragma Assert (Defining_Identifier (Decl) = STJ.ARECnPT);
8987 Cprint_Node (Decl);
8988 end if;
8989 end;
8990 end loop Output_AREC;
8991
8992 -- Next step is to generate headers for all the nested bodies, and
8993 -- also for the outer level body if it acts as its own spec. The
8994 -- order of these does not matter, since we have already output all
8995 -- the declarations they might reference.
8996
8997 Output_Headers : for J in Subps_First .. Subps_Last loop
8998 declare
8999 STJ : Subp_Entry renames Subps.Table (J);
9000
9001 begin
9002 if J /= Subps_First or else Acts_As_Spec (STJ.Bod) then
9003 Ensure_New_Line;
9004 Write_Source_Lines (Specification (STJ.Bod));
9005 Write_Indent;
9006 Cprint_Node (Declaration_Node (STJ.Ent));
9007 Write_Char (';');
9008
9009 -- If there is a separate subprogram specification, remove
9010 -- it, since we have now dealt with outputting this spec.
9011
9012 if Present (Corresponding_Spec (STJ.Bod)) then
9013 Remove (Parent
9014 (Declaration_Node (Corresponding_Spec (STJ.Bod))));
9015 end if;
9016 end if;
9017 end;
9018 end loop Output_Headers;
9019
9020 -- Now we can output the actual bodies, we do this in reverse order
9021 -- so that we deal with and remove the inner level bodies first. That
9022 -- way when we print the enclosing subprogram, the body is gone!
9023
9024 Output_Bodies : for J in reverse Subps_First + 1 .. Subps_Last loop
9025 declare
9026 STJ : Subp_Entry renames Subps.Table (J);
9027 begin
9028 Output_One_Body (STJ.Bod);
9029
9030 if Is_List_Member (STJ.Bod) then
9031 Remove (STJ.Bod);
9032 end if;
9033 end;
9034 end loop Output_Bodies;
9035
9036 -- And finally we output the outer level body and we are done
9037
9038 Output_One_Body (N);
9039 end;
9040 end Cprint_Subprogram_Body;
9041
9042 ----------------
9043 -- Cprint_Sum --
9044 ----------------
9045
9046 procedure Cprint_Sum (Val1 : Node_Id; Val2 : Uint; B : Boolean) is
9047 Modular : constant Boolean := Is_Modular_Integer_Type (Etype (Val1));
9048 begin
9049 if Compile_Time_Known_Value (Val1) then
9050 Write_Uint (Expr_Value (Val1) + Val2, Modular => Modular);
9051
9052 elsif Val2 = 0 then
9053 Cprint_Node (Val1);
9054
9055 elsif B then
9056 Write_Str_Col_Check ("(");
9057 Cprint_Node (Val1);
9058 Write_Str_Col_Check (" + ");
9059 Write_Uint (Val2, Modular => Modular);
9060 Write_Str_Col_Check (")");
9061
9062 else
9063 Cprint_Node (Val1);
9064 Write_Str_Col_Check (" + ");
9065 Write_Uint (Val2, Modular => Modular);
9066 end if;
9067 end Cprint_Sum;
9068
9069 ----------------------
9070 -- Cprint_Type_Name --
9071 ----------------------
9072
9073 procedure Cprint_Type_Name
9074 (Typ : Entity_Id;
9075 Use_Typedef : Boolean := True)
9076 is
9077 begin
9078 -- Print typedef name if available unless inhibited
9079
9080 if Use_Typedef then
9081 if Is_Packed_Array (Typ) then
9082 Cprint_Node (Packed_Array_Impl_Type (Typ));
9083 else
9084 Cprint_Node (Typ);
9085 end if;
9086
9087 -- System.Address and descendants
9088
9089 elsif Is_Descendant_Of_Address (Typ) then
9090 Write_Str ("void*");
9091
9092 -- Discrete types
9093
9094 elsif Is_Discrete_Type (Typ) and then Sloc (Typ) > Standard_Location then
9095 Write_Integer_Type
9096 (UI_To_Int (Esize (Typ)),
9097 Signed => not Is_Modular_Integer_Type (Typ));
9098
9099 -- One-dimensional unconstrained array type
9100
9101 elsif Is_Unconstrained_Array_Type (Typ)
9102 and then Number_Dimensions (Typ) = 1
9103 then
9104 Cprint_Type_Name (Component_Type (Typ));
9105 Write_Char ('*');
9106
9107 -- Constrained array type
9108
9109 elsif Is_Constrained_Array_Type (Typ) then
9110 declare
9111 Indx : Node_Id;
9112 LBD : Node_Id;
9113 UBD : Node_Id;
9114
9115 begin
9116 Cprint_Type_Name (Component_Type (Typ));
9117
9118 -- Loop through subscripts
9119
9120 Indx := First_Index (Typ);
9121 loop
9122 Write_Char ('[');
9123 LBD := Type_Low_Bound (Etype (Indx));
9124 UBD := Type_High_Bound (Etype (Indx));
9125
9126 if Compile_Time_Known_Value (LBD) then
9127 if Expr_Value (LBD) = 1 then
9128 Cprint_Node (UBD);
9129 else
9130 Cprint_Difference (UBD, Expr_Value (LBD) - 1, B => False);
9131 end if;
9132 else
9133 Cprint_Difference (UBD, LBD, Minus_One_Min => True);
9134 Write_Str (" + 1");
9135 end if;
9136
9137 Write_Char (']');
9138 Next_Index (Indx);
9139 exit when No (Indx);
9140 end loop;
9141 end;
9142
9143 -- Access type
9144
9145 elsif Is_Access_Type (Typ)
9146 and then (Is_Discrete_Type (Designated_Type (Typ))
9147 or else Is_Record_Type (Designated_Type (Typ)))
9148 then
9149 if Is_Record_Type (Designated_Type (Typ)) then
9150 Write_Str ("struct _");
9151 end if;
9152
9153 Cprint_Type_Name (Designated_Type (Typ));
9154 Write_Char ('*');
9155
9156 -- Otherwise assume we have typedef reference
9157
9158 else
9159 Cprint_Node (Typ);
9160 end if;
9161 end Cprint_Type_Name;
9162
9163 ------------------------------
9164 -- Declare_Subprogram_Types --
9165 ------------------------------
9166
9167 procedure Declare_Subprogram_Types (N : Node_Id) is
9168 Designator : constant Entity_Id := Unique_Defining_Entity (N);
9169 Formal : Node_Id;
9170
9171 begin
9172 -- Loop through formals (including any Extra_Formals)
9173
9174 if Nkind (N) in N_Entity and then Is_Itype (N) then
9175 Formal := First_Formal_With_Extras (N);
9176 else
9177 Formal := First_Formal_With_Extras (Unique_Defining_Entity (N));
9178 end if;
9179
9180 while Present (Formal) loop
9181 Dump_Type (Etype (Formal));
9182 Next_Formal_With_Extras (Formal);
9183 end loop;
9184
9185 if Ekind (Designator) = E_Function then
9186 Dump_Type (Etype (Designator));
9187 end if;
9188
9189 Dump_Delayed_Itype_Decls;
9190
9191 if Last_Char = ';' then
9192 Write_Indent;
9193 end if;
9194 end Declare_Subprogram_Types;
9195
9196 ---------------
9197 -- Dump_Type --
9198 ---------------
9199
9200 procedure Dump_Type (Typ : Entity_Id) is
9201 begin
9202 if not Entity_Table.Get (Typ)
9203 and then Sloc (Typ) > Standard_Location
9204 then
9205 -- Cannot dump record subtypes until their parent type has been
9206 -- declared. This situation occurs when Dump_Type() is invoked to
9207 -- output access to incomplete type declarations.
9208
9209 if Is_Itype (Typ)
9210 and then Ekind (Typ) = E_Record_Subtype
9211 and then not Entity_Table.Get (Etype (Typ))
9212 then
9213 Register_Delayed_Itype_Decl (Typ);
9214 return;
9215 end if;
9216
9217 if Is_Array_Type (Typ) then
9218 Dump_Type (Component_Type (Typ));
9219
9220 if Is_Packed_Array (Typ) then
9221 Dump_Type (Packed_Array_Impl_Type (Typ));
9222 end if;
9223 end if;
9224
9225 -- For private types the front end may assign different names to the
9226 -- entities of the partial and full view of private types, and the
9227 -- full view must be output before the partial view.
9228
9229 if Is_Private_Type (Typ) then
9230 declare
9231 Full : constant Node_Id := Get_Full_View (Typ);
9232 begin
9233 if Full /= Typ then
9234 Dump_Type (Get_Full_View (Typ));
9235
9236 if not Name_Equals (Chars (Get_Full_View (Typ)), Chars (Typ))
9237 then
9238 Cprint_Declare (Typ);
9239 end if;
9240 else
9241 Cprint_Declare (Typ);
9242 end if;
9243 end;
9244 else
9245 Cprint_Declare (Typ);
9246 end if;
9247
9248 if Is_Access_Type (Typ) then
9249 declare
9250 N : constant Node_Id :=
9251 Get_Full_View (Directly_Designated_Type (Typ));
9252 begin
9253 if Ekind (N) /= E_Subprogram_Type then
9254 Dump_Type (N);
9255 end if;
9256 end;
9257 end if;
9258 end if;
9259 end Dump_Type;
9260
9261 --------
9262 -- db --
9263 --------
9264
9265 procedure db (S : String; N : Int) is
9266 begin
9267 Write_Eol;
9268 Write_Eol;
9269 Write_Str (">>>>>>>>> ");
9270 Write_Str (S);
9271 Write_Str (" N = ");
9272 Write_Int (N);
9273 Write_Str (" <<<<<<<<<");
9274 Write_Eol;
9275 Write_Eol;
9276 end db;
9277
9278 ---------------------
9279 -- Ensure_New_Line --
9280 ---------------------
9281
9282 procedure Ensure_New_Line is
9283 begin
9284 if Column /= 1 then
9285 Write_Eol;
9286 end if;
9287
9288 for J in 1 .. Indent loop
9289 Write_Char (' ');
9290 end loop;
9291 end Ensure_New_Line;
9292
9293 ----------------
9294 -- First_Line --
9295 ----------------
9296
9297 function First_Line (N : Node_Id) return Physical_Line_Number is
9298 begin
9299 Get_First_Last_Line (N);
9300 return FLCache_FL;
9301 end First_Line;
9302
9303 -------------------
9304 -- Get_Full_View --
9305 -------------------
9306
9307 function Get_Full_View (Id : Entity_Id) return Entity_Id is
9308 begin
9309 if Id /= Standard_Void_Type
9310 and then (Is_Type (Id) or else Ekind (Id) = E_Constant)
9311 and then Present (Full_View (Id))
9312 then
9313 return Full_View (Id);
9314 else
9315 return Id;
9316 end if;
9317 end Get_Full_View;
9318
9319 -------------------------
9320 -- Get_First_Last_Line --
9321 -------------------------
9322
9323 procedure Get_First_Last_Line (N : Node_Id) is
9324 Loc : constant Source_Ptr := Sloc (N);
9325 First_Sloc : Source_Ptr;
9326 Last_Sloc : Source_Ptr;
9327
9328 function Process (N : Node_Id) return Traverse_Result;
9329 -- Process function for traversal
9330
9331 procedure Traverse is new Traverse_Proc (Process);
9332
9333 -------------
9334 -- Process --
9335 -------------
9336
9337 function Process (N : Node_Id) return Traverse_Result is
9338 Loc : constant Source_Ptr := Sloc (N);
9339
9340 begin
9341 if Loc > No_Location
9342 and then Get_Source_File_Index (Loc) = Current_Source_File
9343 then
9344 if First_Sloc = No_Location or else Loc < First_Sloc then
9345 First_Sloc := Loc;
9346 end if;
9347
9348 if Last_Sloc = No_Location or else Loc > Last_Sloc then
9349 Last_Sloc := Loc;
9350 end if;
9351 end if;
9352
9353 return OK;
9354 end Process;
9355
9356 -- Start of processing for Get_First_Last_Line
9357
9358 begin
9359 -- Nothing to do if this is cached value
9360
9361 if N = FLCache_N then
9362 return;
9363 else
9364 FLCache_N := N;
9365 end if;
9366
9367 -- If not from current source file, or no source location available,
9368 -- then set no line number results
9369
9370 if Loc <= No_Location
9371 or else Get_Source_File_Index (Loc) /= Current_Source_File
9372 then
9373 FLCache_FL := No_Physical_Line_Number;
9374 FLCache_LL := No_Physical_Line_Number;
9375 return;
9376 end if;
9377
9378 -- Otherwise do the traversal
9379
9380 First_Sloc := No_Location;
9381 Last_Sloc := No_Location;
9382 Traverse (N);
9383
9384 if First_Sloc = No_Location then
9385 FLCache_FL := No_Physical_Line_Number;
9386 else
9387 FLCache_FL := Get_Physical_Line_Number (First_Sloc);
9388 end if;
9389
9390 if Last_Sloc = No_Location then
9391 FLCache_LL := No_Physical_Line_Number;
9392 else
9393 FLCache_LL := Get_Physical_Line_Number (Last_Sloc);
9394 end if;
9395
9396 FLCache_N := N;
9397 end Get_First_Last_Line;
9398
9399 ----------------------
9400 -- Handle_Attribute --
9401 ----------------------
9402
9403 procedure Handle_Attribute (N : Node_Id) is
9404 Attr_Name : constant Name_Id := Attribute_Name (N);
9405 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Attr_Name);
9406 Attr_Prefix : constant Node_Id := Prefix (N);
9407 Prefix_Type : constant Entity_Id :=
9408 Get_Full_View (Etype (Attr_Prefix));
9409
9410 procedure Handle_First_Last (Id : Attribute_Id);
9411 -- Handle 'First/'Last attribute as specified by Id.
9412
9413 -----------------------
9414 -- Handle_First_Last --
9415 -----------------------
9416
9417 procedure Handle_First_Last (Id : Attribute_Id) is
9418 Expr : constant List_Id := Expressions (N);
9419 Idx : Nat := 1;
9420 Pass_Ptr : Boolean;
9421 Use_Paren : Boolean;
9422
9423 begin
9424 if Is_Array_Type (Prefix_Type) then
9425 if Present (Expr) then
9426 Idx := UI_To_Int (Intval (Nlists.First (Expr)));
9427 end if;
9428
9429 if Is_Unconstrained_Array_Type (Prefix_Type) then
9430 if Nkind (Attr_Prefix) in N_Has_Entity
9431 and then Present (Entity (Attr_Prefix))
9432 then
9433 Use_Paren := False;
9434 else
9435 Use_Paren := True;
9436 end if;
9437
9438 if Use_Paren then
9439 Write_Char ('(');
9440 end if;
9441
9442 if Nkind (Attr_Prefix) = N_Explicit_Dereference then
9443 Cprint_Node (Prefix (Attr_Prefix));
9444 Pass_Ptr := False;
9445 else
9446 Cprint_Node (Entity (Attr_Prefix));
9447 Pass_Ptr := Pass_Pointer (Entity (Attr_Prefix));
9448 end if;
9449
9450 if Use_Paren then
9451 Write_Char (')');
9452 end if;
9453
9454 if Pass_Ptr then
9455 Write_Str ("->");
9456 else
9457 Write_Char ('.');
9458 end if;
9459
9460 -- Reference the corresponding fat pointer value
9461
9462 if Id = Attribute_First then
9463 Write_Fatptr_First (Prefix_Type, Idx);
9464 else
9465 Write_Fatptr_Last (Prefix_Type, Idx);
9466 end if;
9467
9468 -- Selected components and identifiers
9469
9470 else
9471 declare
9472 Bound : Node_Id;
9473 Index : Node_Id := First_Index (Prefix_Type);
9474 Rng : Node_Id;
9475
9476 begin
9477 for J in 2 .. Idx loop
9478 Index := Next_Index (Index);
9479 end loop;
9480
9481 if Nkind (Index) = N_Subtype_Indication then
9482 Index := Range_Expression (Constraint (Index));
9483 end if;
9484
9485 if Nkind (Index) = N_Range then
9486 if Id = Attribute_First then
9487 Bound := Low_Bound (Index);
9488 else
9489 Bound := High_Bound (Index);
9490 end if;
9491
9492 if Nkind (Bound) = N_Identifier
9493 and then Present (Entity (Bound))
9494 then
9495 Bound := Entity (Bound);
9496
9497 if Ekind (Bound) = E_Discriminant then
9498 Write_Char ('(');
9499 Cprint_Node (Prefix (Attr_Prefix));
9500 Write_Str (").");
9501 end if;
9502 end if;
9503
9504 Check_Definition (Bound, Error_Node => N);
9505 Cprint_Node (Bound);
9506
9507 elsif Nkind (Index) = N_Identifier
9508 and then Present (Entity (Index))
9509 and then Nkind (Entity (Index)) = N_Defining_Identifier
9510 then
9511 Rng := Scalar_Range (Entity (Index));
9512
9513 case Nkind (Rng) is
9514 when N_Range =>
9515 null;
9516
9517 when N_Subtype_Indication =>
9518 Rng := Range_Expression (Constraint (Rng));
9519
9520 when others =>
9521 Unimplemented_Attribute
9522 (N, Attr_Name, Node_Kind'Image (Nkind (Rng)));
9523 end case;
9524
9525 if Id = Attribute_First then
9526 Check_Definition (Low_Bound (Rng), Error_Node => N);
9527 Cprint_Node (Low_Bound (Rng));
9528 else
9529 Check_Definition (High_Bound (Rng), Error_Node => N);
9530 Cprint_Node (High_Bound (Rng));
9531 end if;
9532 else
9533 Unimplemented_Attribute
9534 (N, Attr_Name, Node_Kind'Image (Nkind (Index)));
9535 end if;
9536 end;
9537 end if;
9538
9539 elsif Is_Scalar_Type (Prefix_Type) then
9540 if Id = Attribute_First then
9541 Check_Definition (Type_Low_Bound (Prefix_Type),
9542 Error_Node => N);
9543 Cprint_Node (Type_Low_Bound (Prefix_Type));
9544 else
9545 Check_Definition (Type_High_Bound (Prefix_Type),
9546 Error_Node => N);
9547 Cprint_Node (Type_High_Bound (Prefix_Type));
9548 end if;
9549 else
9550 Unimplemented_Attribute
9551 (N, Attr_Name, Entity_Kind'Image (Ekind (Prefix_Type)));
9552 end if;
9553 end Handle_First_Last;
9554
9555 -- Start of processing for Handle_Attribute
9556
9557 begin
9558 case Attr_Id is
9559
9560 -- Access (also Address, Code_Address, Unchecked_Access,
9561 -- Unrestricted_Access)
9562
9563 when Attribute_Access |
9564 Attribute_Address |
9565 Attribute_Code_Address |
9566 Attribute_Unchecked_Access |
9567 Attribute_Unrestricted_Access
9568 =>
9569 declare
9570 Typ : constant Entity_Id := Get_Full_View (Etype (N));
9571
9572 begin
9573 -- No need to generate "&" to obtain the address of an explicit
9574 -- dereference since "(Prefix.all)'Address" is equivalent to
9575 -- "Prefix".
9576
9577 if Nkind (Prefix (N)) = N_Explicit_Dereference then
9578 declare
9579 Typ : constant Entity_Id :=
9580 Get_Full_View (Etype (Prefix (Attr_Prefix)));
9581 begin
9582 Cprint_Node (Prefix (Attr_Prefix));
9583
9584 if Has_Fat_Pointer (Typ) then
9585 Write_Fatptr_Dereference;
9586 end if;
9587 end;
9588
9589 -- Fat pointer
9590
9591 elsif Is_Access_Type (Typ)
9592 and then Has_Fat_Pointer (Typ)
9593 then
9594 Write_Fatptr_Init (Attr_Prefix, Typ,
9595 Use_Aggregate =>
9596 Present (Parent (N))
9597 and then Nkind (Parent (N)) = N_Component_Association);
9598
9599 elsif Nkind (Attr_Prefix) in N_Has_Entity
9600 and then Present (Entity (Attr_Prefix))
9601 and then Present (Renamed_Object (Entity (Attr_Prefix)))
9602 and then Nkind (Renamed_Object (Entity (Attr_Prefix)))
9603 = N_Explicit_Dereference
9604 then
9605 Cprint_Node (Prefix (Renamed_Object (Entity (Attr_Prefix))));
9606
9607 -- Common case
9608
9609 else
9610 -- Add explicit cast for 'in' record parameters to disable
9611 -- warning about discarding 'const'.
9612
9613 if Nkind (Attr_Prefix) = N_Identifier
9614 and then Ekind (Entity (Attr_Prefix)) = E_In_Parameter
9615 and then Is_Record_Type (Prefix_Type)
9616 then
9617 Write_Char ('(');
9618 Check_Definition (Etype (Attr_Prefix), Error_Node => N);
9619 Cprint_Type_Name (Etype (Attr_Prefix));
9620 Write_Str (" *)");
9621
9622 -- Add a cast to System.Address to avoid mismatch between
9623 -- integer and pointer.
9624
9625 elsif Is_Descendant_Of_Address (Etype (N)) then
9626 Write_Str ("(system__address)");
9627 end if;
9628
9629 Write_Char ('&');
9630 Cprint_Node (Attr_Prefix);
9631 end if;
9632 end;
9633
9634 -- Deref
9635
9636 when Attribute_Deref =>
9637 -- typ'Deref (expr) => (*((typ *) expr))
9638
9639 Write_Str ("(*((");
9640 Cprint_Node (Attr_Prefix);
9641 Write_Str (" *)");
9642
9643 if Is_AREC_Reference (N)
9644 and then
9645 Is_Unconstrained_Array_Type
9646 (Etype (AREC_Entity (Selector_Name (Get_AREC_Field (N)))))
9647 then
9648 declare
9649 AREC_Formal_Type : constant Entity_Id :=
9650 Etype (AREC_Entity (Selector_Name (Get_AREC_Field (N))));
9651
9652 begin
9653 Write_Str (" (*(");
9654 Write_Fatptr_Name (AREC_Formal_Type);
9655 Write_Str ("*) ");
9656 Cprint_Node (First (Expressions (N)));
9657 Write_Str (")");
9658 Write_Fatptr_Dereference;
9659 Write_Str ("))");
9660 end;
9661 else
9662 Cprint_Node (First (Expressions (N)));
9663 Write_Str ("))");
9664 end if;
9665
9666 -- First/Last
9667
9668 when Attribute_First | Attribute_Last =>
9669 Handle_First_Last (Attr_Id);
9670
9671 when Attribute_Length | Attribute_Range_Length =>
9672 Write_Char ('(');
9673 Handle_First_Last (Attribute_Last);
9674 Write_Str (" < ");
9675 Handle_First_Last (Attribute_First);
9676 Write_Str (" ? 0 : ");
9677
9678 Handle_First_Last (Attribute_Last);
9679 Write_Str (" - ");
9680 Handle_First_Last (Attribute_First);
9681 Write_Str (" + 1)");
9682
9683 -- Pos/Val
9684
9685 when Attribute_Pos | Attribute_Val =>
9686 Write_Char ('(');
9687 Cprint_Node (Etype (N));
9688 Write_Char (')');
9689 Cprint_Node (First (Expressions (N)));
9690
9691 -- Pred
9692
9693 when Attribute_Pred =>
9694 Cprint_Difference
9695 (First (Expressions (N)), Uint_1, B => Parens_Needed (N));
9696
9697 -- Succ
9698
9699 when Attribute_Succ =>
9700 Cprint_Sum
9701 (First (Expressions (N)), Uint_1, Parens_Needed (N));
9702
9703 -- Size/Object_Size/Value_Size/Max_Size_In_Storage_Elements
9704
9705 when Attribute_Max_Size_In_Storage_Elements |
9706 Attribute_Object_Size |
9707 Attribute_Size |
9708 Attribute_Value_Size
9709 =>
9710 -- If this attribute is used as part of a runtime check, convert
9711 -- the expression explicitly to universal_integer, since the type
9712 -- of sizeof is size_t (an unsigned integer).
9713
9714 declare
9715 P : Node_Id := Parent (N);
9716 begin
9717 while Present (P)
9718 and then Nkind (P) not in N_Raise_xxx_Error
9719 loop
9720 P := Parent (P);
9721 end loop;
9722
9723 if Present (P) then
9724 Write_Str ("(universal_integer)");
9725 end if;
9726 end;
9727
9728 Write_Str ("sizeof(");
9729
9730 if Is_Packed_Array (Prefix_Type) then
9731 Cprint_Node (Packed_Array_Impl_Type (Prefix_Type));
9732 else
9733 Cprint_Node (Attr_Prefix);
9734 end if;
9735
9736 Write_Char (')');
9737
9738 if Attr_Id /= Attribute_Max_Size_In_Storage_Elements then
9739 Write_Str (" * 8");
9740 end if;
9741
9742 -- Review when sizeof() is usable, and when it's not???
9743 -- The following code could be used when sizeof() cannot:
9744
9745 -- declare
9746 -- Size : Uint;
9747 -- begin
9748 -- if Nkind (Attr_Prefix) in N_Entity
9749 -- and then Is_Type (Attr_Prefix)
9750 -- then
9751 -- Size := RM_Size (Attr_Prefix)
9752 -- else
9753 -- Size := Esize (Etype (Attr_Prefix));
9754 -- end if;
9755 --
9756 -- if Size /= No_Uint then
9757 -- Write_Int (UI_To_Int (Size));
9758 -- end if;
9759 -- end;
9760
9761 when Attribute_Machine =>
9762 if Comes_From_Source (N) then
9763 Unimplemented_Attribute (N, Attr_Name);
9764 else
9765 -- ??? For now, ignore 'Machine and output the expression
9766 -- itself on generated code, to support e.g. ** expansion.
9767
9768 Cprint_Node (First (Expressions (N)));
9769 end if;
9770
9771 when Attribute_Valid =>
9772 Write_Str ("isfinite(");
9773 Cprint_Node (Attr_Prefix);
9774 Write_Char (')');
9775
9776 -- No other cases handled for now???
9777
9778 when Attribute_Alignment | Attribute_Component_Size =>
9779 Unimplemented_Attribute (N, Attr_Name);
9780
9781 when Attribute_Rounding =>
9782 Unimplemented_Attribute (N, Attr_Name);
9783
9784 when Attribute_Bit |
9785 Attribute_Bit_Position |
9786 Attribute_First_Bit |
9787 Attribute_Last_Bit |
9788 Attribute_Position
9789 =>
9790 Unimplemented_Attribute (N, Attr_Name);
9791
9792 when Attribute_Constrained |
9793 Attribute_Mechanism_Code |
9794 Attribute_Null_Parameter |
9795 Attribute_Passed_By_Reference
9796 =>
9797 Unimplemented_Attribute (N, Attr_Name);
9798
9799 when others =>
9800 Unimplemented_Attribute (N, Attr_Name);
9801 end case;
9802 end Handle_Attribute;
9803
9804 ------------------
9805 -- Handle_Raise --
9806 ------------------
9807
9808 procedure Handle_Raise (N : Node_Id) is
9809 Last_Chance : constant String := "__gnat_last_chance_handler(NULL, 0)";
9810 begin
9811 case Nkind (N) is
9812 when N_Raise_Expression =>
9813 Write_Indent_Str (Last_Chance);
9814 when N_Raise_Statement =>
9815 Write_Indent_Str (Last_Chance & ";");
9816
9817 when N_Raise_xxx_Error =>
9818 if Present (Condition (N)) then
9819 if In_Compound_Statement then
9820 Write_Char ('(');
9821 Cprint_Node (Condition (N));
9822 Write_Str (") ? " & Last_Chance & " : 0");
9823
9824 else
9825 Write_Indent_Str ("if (");
9826 Cprint_Node (Condition (N));
9827 Write_Str_Col_Check (")");
9828 Indent_Begin;
9829 Write_Indent_Str (Last_Chance & ";");
9830 Indent_End;
9831 end if;
9832 else
9833 if In_Compound_Statement
9834 or else Nkind_In (Parent (N),
9835 N_Assignment_Statement,
9836 N_Object_Declaration)
9837 then
9838 Write_Indent_Str (Last_Chance);
9839 else
9840 Write_Indent_Str (Last_Chance & ";");
9841 end if;
9842 end if;
9843
9844 when others =>
9845 raise Program_Error;
9846 end case;
9847 end Handle_Raise;
9848
9849 -----------------------------
9850 -- Has_Non_Null_Statements --
9851 -----------------------------
9852
9853 function Has_Non_Null_Statements (L : List_Id) return Boolean is
9854 Node : Node_Id;
9855
9856 begin
9857 if Is_Non_Empty_List (L) then
9858 Node := First (L);
9859
9860 loop
9861 if Nkind (Node) /= N_Null_Statement then
9862 return True;
9863 end if;
9864
9865 Next (Node);
9866 exit when Node = Empty;
9867 end loop;
9868 end if;
9869
9870 return False;
9871 end Has_Non_Null_Statements;
9872
9873 -------------------------------------
9874 -- Has_Or_Inherits_Enum_Rep_Clause --
9875 -------------------------------------
9876
9877 function Has_Or_Inherits_Enum_Rep_Clause (E : Entity_Id) return Boolean is
9878 Typ : Entity_Id := Get_Full_View (E);
9879 Result : Boolean := Has_Enumeration_Rep_Clause (Typ);
9880
9881 begin
9882 while Get_Full_View (Etype (Typ)) /= Typ loop
9883 Typ := Get_Full_View (Etype (Typ));
9884 Result := Result or Has_Enumeration_Rep_Clause (Typ);
9885 end loop;
9886
9887 return Result;
9888 end Has_Or_Inherits_Enum_Rep_Clause;
9889
9890 ------------------------
9891 -- Has_Same_Int_Value --
9892 ------------------------
9893
9894 function Has_Same_Int_Value
9895 (Val1 : Node_Id;
9896 Val2 : Node_Id) return Boolean
9897 is
9898 begin
9899 return Compile_Time_Known_Value (Val1)
9900 and then Compile_Time_Known_Value (Val2)
9901 and then Expr_Value (Val1) = Expr_Value (Val2);
9902 end Has_Same_Int_Value;
9903
9904 ----------
9905 -- Hash --
9906 ----------
9907
9908 function Hash (N : Node_Id) return Header_Num is
9909 begin
9910 return Header_Num (1 + N mod Node_Id (Header_Num'Last));
9911 end Hash;
9912
9913 ------------------
9914 -- Indent_Begin --
9915 ------------------
9916
9917 procedure Indent_Begin is
9918 begin
9919 Indent := Indent + 2;
9920 end Indent_Begin;
9921
9922 ----------------
9923 -- Indent_End --
9924 ----------------
9925
9926 procedure Indent_End is
9927 begin
9928 Indent := Indent - 2;
9929 end Indent_End;
9930
9931 ----------------------
9932 -- In_Instantiation --
9933 ----------------------
9934
9935 function In_Instantiation (S : Source_Ptr) return Boolean is
9936 SI : constant Source_File_Index := Get_Source_File_Index (S);
9937 begin
9938 return Instantiation (SI) /= No_Location;
9939 end In_Instantiation;
9940
9941 ---------------------------------------------
9942 -- Is_Enum_Literal_Of_Enclosing_Subprogram --
9943 ---------------------------------------------
9944
9945 function Is_Enum_Literal_Of_Enclosing_Subprogram
9946 (E : Entity_Id) return Boolean
9947 is
9948 begin
9949 return Ekind (E) = E_Enumeration_Literal
9950 and then not Is_Library_Level_Entity (E)
9951 and then Present (Current_Subp_Entity)
9952 and then not Within_Scope (E, Current_Subp_Entity);
9953 end Is_Enum_Literal_Of_Enclosing_Subprogram;
9954
9955 -------------------------------
9956 -- Is_Out_Mode_Access_Formal --
9957 -------------------------------
9958
9959 function Is_Out_Mode_Access_Formal (E : Node_Id) return Boolean is
9960 begin
9961 return Is_Formal (E)
9962 and then Is_Access_Type (Etype (E))
9963 and then Ekind_In (E, E_In_Out_Parameter, E_Out_Parameter);
9964 end Is_Out_Mode_Access_Formal;
9965
9966 ---------------------
9967 -- Is_Packed_Array --
9968 ---------------------
9969
9970 function Is_Packed_Array (Typ : Entity_Id) return Boolean is
9971 begin
9972 return Is_Array_Type (Typ)
9973 and then Present (Packed_Array_Impl_Type (Typ));
9974 end Is_Packed_Array;
9975
9976 ---------------------------------------
9977 -- Is_Supported_Variable_Size_Record --
9978 ---------------------------------------
9979
9980 function Is_Supported_Variable_Size_Record
9981 (Typ : Entity_Id) return Boolean
9982 is
9983 Rng : Node_Id;
9984
9985 begin
9986 if Is_Record_Type (Typ)
9987 and then Has_Discriminants (Typ)
9988 and then Has_Per_Object_Constraint (Last_Field (Typ))
9989 and then Ekind (Etype (Last_Field (Typ))) = E_Array_Subtype
9990 then
9991 Rng := First_Index (Etype (Last_Field (Typ)));
9992
9993 -- We can compute the size only when the index specifies a range
9994
9995 if Nkind (Rng) = N_Range then
9996 return True;
9997 end if;
9998 end if;
9999
10000 return False;
10001 end Is_Supported_Variable_Size_Record;
10002
10003 ----------------
10004 -- Last_Field --
10005 ----------------
10006
10007 function Last_Field (Typ : Node_Id) return Node_Id is
10008 Field : Node_Id := First_Entity (Typ);
10009 Result : Node_Id := Empty;
10010
10011 begin
10012 while Present (Field) loop
10013 if Ekind (Field) in Object_Kind then
10014 Result := Field;
10015 end if;
10016
10017 Next_Entity (Field);
10018 end loop;
10019
10020 return Result;
10021 end Last_Field;
10022
10023 ---------------
10024 -- Last_Line --
10025 ---------------
10026
10027 function Last_Line (N : Node_Id) return Physical_Line_Number is
10028 begin
10029 Get_First_Last_Line (N);
10030 return FLCache_LL;
10031 end Last_Line;
10032
10033 -------------------
10034 -- Parens_Needed --
10035 -------------------
10036
10037 function Parens_Needed (N : Node_Id) return Boolean is
10038 P : constant Node_Id := Parent (N);
10039 begin
10040 if Nkind (P) = N_Assignment_Statement then
10041 return N /= Expression (P);
10042 else
10043 return True;
10044 end if;
10045 end Parens_Needed;
10046
10047 ------------------
10048 -- Pass_Pointer --
10049 ------------------
10050
10051 function Pass_Pointer (Ent : Entity_Id) return Boolean is
10052 Typ : constant Entity_Id := Get_Full_View (Etype (Ent));
10053 begin
10054 if Is_Array_Type (Typ) then
10055 return False;
10056
10057 elsif Ekind_In (Ent, E_In_Out_Parameter, E_Out_Parameter) then
10058 return True;
10059
10060 -- Pass "flexible arrays" (arrays whose size is determined by a
10061 -- discriminant) by reference.
10062
10063 elsif Has_Discriminants (Typ)
10064 and then Ekind (Etype (Last_Field (Typ))) = E_Array_Subtype
10065 then
10066 return True;
10067 else
10068 return Mechanism (Ent) = By_Reference;
10069 end if;
10070 end Pass_Pointer;
10071
10072 -------------------------
10073 -- Ultimate_Expression --
10074 -------------------------
10075
10076 function Ultimate_Expression (N : Node_Id) return Node_Id is
10077 Expr : Node_Id := N;
10078
10079 begin
10080 while Nkind_In (Expr, N_Qualified_Expression,
10081 N_Type_Conversion,
10082 N_Unchecked_Type_Conversion)
10083 loop
10084 Expr := Expression (Expr);
10085 end loop;
10086
10087 return Expr;
10088 end Ultimate_Expression;
10089
10090 -------------------
10091 -- Output_Sizeof --
10092 -------------------
10093
10094 procedure Output_Sizeof (Target : Node_Id; Source : Node_Id := Empty) is
10095 Need_Paren : Boolean := False;
10096 Source_Typ : Node_Id := Empty;
10097 Target_Typ : Node_Id := Get_Full_View (Etype (Target));
10098 Unconstr : Boolean := False;
10099
10100 begin
10101 if Has_Fat_Pointer (Target_Typ)
10102 and then Is_Access_Type (Target_Typ)
10103 then
10104 Target_Typ := Get_Full_View (Designated_Type (Target_Typ));
10105 end if;
10106
10107 if Present (Source) then
10108 Source_Typ := Get_Full_View (Etype (Source));
10109
10110 if Has_Fat_Pointer (Source_Typ)
10111 and then Is_Access_Type (Source_Typ)
10112 then
10113 Source_Typ := Get_Full_View (Designated_Type (Source_Typ));
10114 end if;
10115 end if;
10116
10117 -- In general use sizeof on the type of the expression, unless the type
10118 -- has not been output yet, in which case use the expression itself: LHS
10119 -- by default (ie. Target), except in the case of a subprogram parameter
10120 -- where we take the RHS (ie. Source).
10121
10122 if Entity_Table.Get (Target_Typ)
10123 and then (not Is_Array_Type (Target_Typ)
10124 or else Is_Constrained (Target_Typ))
10125 then
10126 Write_Str ("sizeof(");
10127 Cprint_Type_Name (Target_Typ);
10128 Need_Paren := True;
10129
10130 elsif Present (Source)
10131 and then Entity_Table.Get (Source_Typ)
10132 and then (not Is_Array_Type (Source_Typ)
10133 or else Is_Constrained (Source_Typ))
10134 then
10135 Write_Str ("sizeof(");
10136 Cprint_Type_Name (Source_Typ);
10137 Need_Paren := True;
10138
10139 elsif Present (Source)
10140 and then (Nkind (Source) /= N_Identifier
10141 or else Ekind (Entity (Source)) not in Formal_Kind)
10142 then
10143 if Nkind (Source) = N_String_Literal then
10144 Write_Int (String_Length (Strval (Source)));
10145 else
10146 Write_Str ("sizeof(");
10147 Cprint_Node (Source, Declaration => True);
10148 Need_Paren := True;
10149 end if;
10150
10151 elsif Is_Unconstrained_Array_Type (Target_Typ) then
10152 Write_Str ("sizeof(");
10153 Write_Id (Component_Type (Target_Typ));
10154 Unconstr := True;
10155 Need_Paren := True;
10156
10157 else
10158 if Nkind (Target) = N_String_Literal then
10159 Write_Int (String_Length (Strval (Target)));
10160 else
10161 Write_Str ("sizeof(");
10162 Cprint_Node (Target, Declaration => True);
10163 Need_Paren := True;
10164 end if;
10165 end if;
10166
10167 if Need_Paren then
10168 Write_Char (')');
10169 end if;
10170
10171 if Unconstr then
10172 Write_Str_Col_Check (" * ");
10173 Write_Number_Of_Components (Target, Target_Typ);
10174 end if;
10175 end Output_Sizeof;
10176
10177 ---------------------
10178 -- Register_Entity --
10179 ---------------------
10180
10181 procedure Register_Entity (E : Entity_Id) is
10182 begin
10183 Entity_Table.Set (E, True);
10184 Enclosing_Subp_Table.Set (E, Current_Subp_Entity);
10185 end Register_Entity;
10186
10187 ----------------------
10188 -- Requires_Address --
10189 ----------------------
10190
10191 function Requires_Address (Typ : Node_Id) return Boolean is
10192 begin
10193 return
10194 not Is_Array_Type (Typ)
10195 or else (Is_Packed_Array (Typ)
10196 and then Is_Integer_Type (Packed_Array_Impl_Type (Typ)));
10197 end Requires_Address;
10198
10199 -----------------
10200 -- Source_Dump --
10201 -----------------
10202
10203 procedure Source_Dump is
10204 procedure Cprint_Library_Item (U : Node_Id);
10205 -- Print C code for unit U
10206
10207 function File_To_Define (File : String) return String;
10208 -- Return a C define name from a given filename File
10209
10210 -------------------------
10211 -- Cprint_Library_Item --
10212 -------------------------
10213
10214 procedure Cprint_Library_Item (U : Node_Id) is
10215 procedure Gen_Define_Source_File;
10216 -- Define macro associated with the current source file
10217
10218 procedure Gen_End_Define_Source_File;
10219 -- Close the definition of the macro associated with the current
10220 -- source file
10221
10222 ----------------------------
10223 -- Gen_Define_Source_File --
10224 ----------------------------
10225
10226 procedure Gen_Define_Source_File is
10227 Define : constant String :=
10228 File_To_Define
10229 (Get_Name_String (File_Name (Current_Source_File)));
10230
10231 begin
10232 Write_Str ("#ifndef ");
10233 Write_Str (Define);
10234 Write_Eol;
10235 Write_Str ("#define ");
10236 Write_Str (Define);
10237 Write_Eol;
10238 end Gen_Define_Source_File;
10239
10240 --------------------------------
10241 -- Gen_End_Define_Source_File --
10242 --------------------------------
10243
10244 procedure Gen_End_Define_Source_File is
10245 Define : constant String :=
10246 File_To_Define
10247 (Get_Name_String (File_Name (Current_Source_File)));
10248
10249 begin
10250 Write_Str ("#endif /* ");
10251 Write_Str (Define);
10252 Write_Str (" */");
10253 Write_Eol;
10254 end Gen_End_Define_Source_File;
10255
10256 -- Local variables
10257
10258 Current_Unit : Unit_Number_Type;
10259
10260 -- Start of processing for Cprint_Library_Item
10261
10262 begin
10263 -- Ignore Standard and ASCII packages
10264
10265 if Sloc (U) <= Standard_Location then
10266 return;
10267 end if;
10268
10269 Current_Unit := Get_Cunit_Unit_Number (Parent (U));
10270 Current_Source_File := Source_Index (Current_Unit);
10271
10272 -- For library level subprogram bodies that act as their own spec
10273 -- generate their declaration in the .h file. Needed to avoid the
10274 -- C warning on missing prototype.
10275
10276 if Nkind (U) = N_Subprogram_Body and then Acts_As_Spec (U) then
10277 Open_Scope (With_Block => False);
10278 Gen_Define_Source_File;
10279 Cprint_Node (Specification (U));
10280 Write_Char (';');
10281 Write_Eol;
10282 Gen_End_Define_Source_File;
10283 Close_Scope;
10284 end if;
10285
10286 if Full_Code_Generation then
10287 In_Main_Unit := In_Extended_Main_Code_Unit (U);
10288
10289 if Current_Unit = Main_Unit then
10290 if not Debug_Flag_Dot_YY then
10291 Close_H_File;
10292 Create_C_File;
10293 Set_Output (Output_FD);
10294 end if;
10295
10296 Set_File_Name ("h");
10297 Write_Str ("#include """);
10298 Write_Str (Name_Buffer (1 .. Name_Len - 1));
10299 Write_Char ('"');
10300 Write_Eol;
10301 end if;
10302
10303 -- ??? Has_No_Elaboration_Code is supposed to be set by default
10304 -- on subprogram bodies, but this is apparently not the case,
10305 -- so force the flag here. Ditto for subprogram decls.
10306
10307 if In_Main_Unit
10308 and then Nkind_In (U, N_Subprogram_Body,
10309 N_Subprogram_Declaration)
10310 then
10311 Set_Has_No_Elaboration_Code (Parent (U), True);
10312 end if;
10313
10314 elsif Nkind_In (U, N_Subprogram_Body, N_Package_Body) then
10315 return;
10316 end if;
10317
10318 Write_Eol;
10319
10320 if Current_Unit /= Main_Unit then
10321 Gen_Define_Source_File;
10322 end if;
10323
10324 -- Open the new scope associated with this unit to be ready to
10325 -- process its declarations (see Open_Scope). No explicit block is
10326 -- associated with this scope because for library level declarations
10327 -- it must not be generated.
10328
10329 declare
10330 Scope_Id : Nat;
10331
10332 begin
10333 Open_Scope (With_Block => False);
10334 Scope_Id := Current_Scope_Id;
10335
10336 -- Output C text to file
10337
10338 Cprint_Node (U);
10339 Check_No_Delayed_Itype_Decls;
10340
10341 -- Close this scope and all its inner scopes
10342
10343 Close_Scope (Scope_Id);
10344 end;
10345
10346 -- Ensure of terminating EOL
10347
10348 Write_Eol;
10349
10350 if Current_Unit /= Main_Unit then
10351 Gen_End_Define_Source_File;
10352 end if;
10353 end Cprint_Library_Item;
10354
10355 --------------------
10356 -- File_To_Define --
10357 --------------------
10358
10359 function File_To_Define (File : String) return String is
10360 Result : String (File'Range);
10361 begin
10362 for J in File'Range loop
10363 case File (J) is
10364 when 'A' .. 'Z' | '0' .. '9' | '_' =>
10365 Result (J) := File (J);
10366 when 'a' .. 'z' =>
10367 Result (J) := Fold_Upper (File (J));
10368 when others =>
10369 Result (J) := '_';
10370 end case;
10371 end loop;
10372
10373 return Result;
10374 end File_To_Define;
10375
10376 procedure Walk_All_Units is
10377 new Sem.Walk_Library_Items (Action => Cprint_Library_Item);
10378
10379 -- Start of processing for Source_Dump
10380
10381 begin
10382 -- Bump line length limit to avoid too many line drift when using -g
10383 -- to correlate Ada and C code.
10384
10385 Sprint_Line_Limit := 120;
10386
10387 -- Initialize constants for Write_Uint
10388
10389 LNegInt := -(Uint_2 ** (ints - 1));
10390 LPosInt := abs (LNegInt + 1);
10391 LNegLong := -(Uint_2 ** (longs - 1));
10392 LPosLong := abs (LNegLong + 1);
10393 LNegLL := -(Uint_2 ** (lls - 1));
10394 LPosLL := abs (LNegLL + 1);
10395
10396 LPosU := (Uint_2 ** ints) - 1;
10397 LNegU := -LPosU;
10398 LPosUL := (Uint_2 ** longs) - 1;
10399 LNegUL := -LPosUL;
10400 LPosULL := (Uint_2 ** lls) - 1;
10401 LNegULL := -LPosULL;
10402
10403 -- Dump C file
10404
10405 Current_Source_File := Main_Source_File;
10406
10407 -- Include content of "standard.h" to file
10408
10409 declare
10410 Hi : Source_Ptr;
10411 Lo : Source_Ptr;
10412 Text : Source_Buffer_Ptr;
10413
10414 begin
10415 Name_Len := 10;
10416 Name_Buffer (1 .. Name_Len) := "standard.h";
10417 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
10418
10419 -- Enable Full_Code_Generation when standard.h is found
10420
10421 if Text /= null then
10422 Full_Code_Generation := True;
10423 else
10424 -- Otherwise defaults to standard.ads.h for generation of headers
10425
10426 Full_Code_Generation := False;
10427 Name_Len := 14;
10428 Name_Buffer (1 .. Name_Len) := "standard.ads.h";
10429 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
10430
10431 if Text = null then
10432 Write_Line
10433 ("fatal error, run-time library not installed correctly");
10434 Write_Line ("cannot locate file standard.ads.h");
10435 raise Unrecoverable_Error;
10436 end if;
10437 end if;
10438
10439 -- Further output will be done in the C file, unless -gnatd.Y is set
10440 -- in which case output goes to stdout, for debugging purposes.
10441
10442 if not Debug_Flag_Dot_YY then
10443 Create_H_File;
10444 Set_Output (Output_FD);
10445 end if;
10446
10447 if Debugger_Level > 0 then
10448 if Full_Code_Generation then
10449 Write_Str ("#line 1 ""standard.h""");
10450 else
10451 Write_Str ("#line 1 ""standard.ads.h""");
10452 end if;
10453
10454 Write_Eol;
10455 end if;
10456
10457 Lo := 0;
10458
10459 -- Remove header in generated code
10460
10461 if Text (0) = '/' and Text (1) = '*' then
10462 for J in 2 .. Hi loop
10463 if Text (J) = '/' and Text (J - 1) = '*' then
10464 Lo := J + 1;
10465
10466 while Text (Lo) = ASCII.LF or Text (Lo) = ASCII.CR loop
10467 Lo := Lo + 1;
10468 end loop;
10469
10470 exit;
10471 end if;
10472 end loop;
10473 end if;
10474
10475 for J in Lo .. Hi - 1 loop
10476 Write_Char (Text (J));
10477 end loop;
10478 end;
10479
10480 -- Dump all units to generate a self contained C file
10481
10482 Walk_All_Units;
10483
10484 -- Close the C file
10485
10486 if not Debug_Flag_Dot_YY then
10487 if Full_Code_Generation then
10488 Close_C_File;
10489 else
10490 Close_H_File;
10491 end if;
10492
10493 Set_Standard_Output;
10494
10495 -- Delete .c and .h files in case of errors generated during code
10496 -- generation, unless -gnatd.4 is set.
10497
10498 if Compilation_Errors and not Debug_Flag_Dot_4 then
10499 Delete_C_File;
10500 Delete_H_File;
10501 end if;
10502 end if;
10503 end Source_Dump;
10504
10505 -----------------------------
10506 -- Unimplemented_Attribute --
10507 -----------------------------
10508
10509 procedure Unimplemented_Attribute
10510 (N : Node_Id;
10511 Attr : Name_Id;
10512 Context : String := "")
10513 is
10514 Name : constant String := Get_Name_String (Attr);
10515
10516 begin
10517 Error_Msg_Name_1 := Attr;
10518
10519 if Context = "" then
10520 Error_Msg_N ("unsupported attribute%", N);
10521 else
10522 Error_Msg_Strlen := Context'Length;
10523 Error_Msg_String (1 .. Error_Msg_Strlen) := Context;
10524 Error_Msg_N ("unsupported attribute% in this context (~)", N);
10525 end if;
10526
10527 Write_Str ("/* unsupported attribute: " & Name & " */");
10528 end Unimplemented_Attribute;
10529
10530 -----------------------
10531 -- Write_Array_Bound --
10532 -----------------------
10533
10534 procedure Write_Array_Bound
10535 (Expr : Node_Id;
10536 Bound : Bound_Kind;
10537 Dimension : Pos)
10538 is
10539 procedure Write_Bound (Array_Node : Node_Id);
10540 -- Output the Bound of the given Dimension of Array_Node
10541
10542 -----------------
10543 -- Write_Bound --
10544 -----------------
10545
10546 procedure Write_Bound (Array_Node : Node_Id) is
10547 procedure Write_Fatptr_Bounds (Node : Node_Id);
10548 -- Output the Bound of the given Dimension of a fat pointer
10549
10550 procedure Write_Range_Bounds (Rng : Node_Id);
10551 -- Output the Bound of the given Dimension of a range expression
10552
10553 procedure Write_Type_Bounds (Typ : Entity_Id);
10554 -- Output the Bound of the given Dimension of an array type
10555
10556 -------------------------
10557 -- Write_Fatptr_Bounds --
10558 -------------------------
10559
10560 procedure Write_Fatptr_Bounds (Node : Node_Id) is
10561 Typ : Entity_Id := Etype (Array_Node);
10562 begin
10563 if Is_Access_Type (Typ) then
10564 Typ := Get_Full_View (Designated_Type (Typ));
10565 end if;
10566
10567 Cprint_Node (Node);
10568 Write_Char ('.');
10569
10570 if Bound = Low then
10571 Write_Fatptr_First (Typ, Dimension);
10572 else
10573 Write_Fatptr_Last (Typ, Dimension);
10574 end if;
10575 end Write_Fatptr_Bounds;
10576
10577 ------------------------
10578 -- Write_Range_Bounds --
10579 ------------------------
10580
10581 procedure Write_Range_Bounds (Rng : Node_Id) is
10582 pragma Assert (Nkind (Rng) = N_Range);
10583 begin
10584 if Bound = Low then
10585 Cprint_Node (Low_Bound (Rng));
10586 else
10587 Cprint_Node (High_Bound (Rng));
10588 end if;
10589 end Write_Range_Bounds;
10590
10591 -----------------------
10592 -- Write_Type_Bounds --
10593 -----------------------
10594
10595 procedure Write_Type_Bounds (Typ : Entity_Id) is
10596 Ind : Node_Id := First_Index (Typ);
10597
10598 begin
10599 for J in 2 .. Dimension loop
10600 Next_Index (Ind);
10601 end loop;
10602
10603 if Bound = Low then
10604 Cprint_Node (Type_Low_Bound (Etype (Ind)));
10605 else
10606 Cprint_Node (Type_High_Bound (Etype (Ind)));
10607 end if;
10608 end Write_Type_Bounds;
10609
10610 -- Local variables
10611
10612 Expr_Type : Entity_Id := Get_Full_View (Etype (Array_Node));
10613
10614 -- Start of processing for Write_Bound
10615
10616 begin
10617 if Is_Access_Type (Expr_Type) then
10618 Expr_Type := Get_Full_View (Designated_Type (Expr_Type));
10619 end if;
10620
10621 -- Annoying special case of string literal
10622
10623 if Ekind (Expr_Type) = E_String_Literal_Subtype then
10624 if Bound = Low then
10625 Write_Uint
10626 (Intval (String_Literal_Low_Bound (Expr_Type)));
10627 else
10628 Write_Uint
10629 (String_Literal_Length (Expr_Type) -
10630 Intval (String_Literal_Low_Bound (Expr_Type)) + 1);
10631 end if;
10632
10633 return;
10634 end if;
10635
10636 if Nkind (Array_Node) in N_Has_Entity
10637 and then Present (Entity (Array_Node))
10638 then
10639 declare
10640 E : constant Entity_Id := Entity (Array_Node);
10641 Typ : constant Entity_Id := Get_Full_View (Etype (E));
10642
10643 begin
10644 if Ekind (E) = E_Variable then
10645
10646 -- Retrieve the bounds from the fat pointer
10647
10648 if Is_Access_Type (Typ) then
10649
10650 -- Retrieve the bounds from the fat pointer
10651
10652 if not Is_Constrained (Designated_Type (Typ)) then
10653 Write_Fatptr_Bounds (Array_Node);
10654 else
10655 Write_Type_Bounds (Designated_Type (Typ));
10656 end if;
10657
10658 else
10659 Write_Type_Bounds (Typ);
10660 end if;
10661
10662 elsif Ekind (E) in Formal_Kind
10663 and then not Is_Constrained (Typ)
10664 then
10665 Write_Fatptr_Bounds (Array_Node);
10666
10667 else
10668 Write_Type_Bounds (Expr_Type);
10669 end if;
10670 end;
10671
10672 else
10673 case Nkind (Array_Node) is
10674 when N_Slice =>
10675 declare
10676 Rng : constant Node_Id := Discrete_Range (Array_Node);
10677
10678 begin
10679 if Nkind (Rng) = N_Range then
10680 Write_Range_Bounds (Rng);
10681 else
10682 Write_Type_Bounds (Etype (Rng));
10683 end if;
10684 end;
10685
10686 when N_Null =>
10687
10688 -- The bounds of null are 0 when initializing fat pointers
10689
10690 Write_Char ('0');
10691
10692 when N_Selected_Component |
10693 N_Qualified_Expression =>
10694 Write_Type_Bounds (Expr_Type);
10695
10696 when others =>
10697
10698 -- Get index subtype bounds
10699
10700 Write_Type_Bounds (Expr_Type);
10701 end case;
10702 end if;
10703 end Write_Bound;
10704
10705 -- Local variables
10706
10707 Expr_Type : constant Entity_Id := Get_Full_View (Etype (Expr));
10708 Array_Node : Node_Id := Expr;
10709 Array_Type : Entity_Id;
10710
10711 -- Start of processing for Write_Array_Bound
10712
10713 begin
10714 if Is_Access_Type (Expr_Type) then
10715 Array_Type := Get_Full_View (Designated_Type (Expr_Type));
10716 else
10717 Array_Type := Expr_Type;
10718 end if;
10719
10720 pragma Assert (Is_Array_Type (Array_Type));
10721
10722 if not Is_Constrained (Array_Type) then
10723 case Nkind (Array_Node) is
10724 when N_Attribute_Reference =>
10725 declare
10726 Attr_Name : constant Name_Id := Attribute_Name (Expr);
10727 Attr_Id : constant Attribute_Id :=
10728 Get_Attribute_Id (Attr_Name);
10729 Attr_Prefix : constant Node_Id := Prefix (Expr);
10730 Prefix_Type : constant Entity_Id :=
10731 Get_Full_View (Etype (Attr_Prefix));
10732 begin
10733 pragma Assert
10734 (Attr_Id = Attribute_Access
10735 or else Attr_Id = Attribute_Unchecked_Access
10736 or else Attr_Id = Attribute_Unrestricted_Access);
10737 pragma Assert (Is_Array_Type (Prefix_Type));
10738
10739 Array_Node := Attr_Prefix;
10740 end;
10741
10742 when N_Type_Conversion =>
10743 Array_Node := Expression (Array_Node);
10744
10745 when N_Null |
10746 N_Identifier =>
10747 null;
10748
10749 when N_Allocator =>
10750 Array_Node := Expression (Array_Node);
10751
10752 if Nkind (Array_Node) = N_Qualified_Expression then
10753 Array_Node := Expression (Array_Node);
10754 end if;
10755
10756 -- Play it safe and generate an error for other cases we haven't
10757 -- tested.
10758 -- ??? in particular we need to handle N_Allocator, see c34007d
10759
10760 when others =>
10761 declare
10762 S : constant String := Node_Kind'Image (Nkind (Array_Node));
10763 begin
10764 Error_Msg_Strlen := S'Length;
10765 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
10766 Error_Msg_N
10767 ("unsupported access to unconstrained array (~)",
10768 Array_Node);
10769 end;
10770 end case;
10771 end if;
10772
10773 Write_Bound (Array_Node);
10774 end Write_Array_Bound;
10775
10776 -----------------------
10777 -- Write_C_Char_Code --
10778 -----------------------
10779
10780 Hex : constant array (Char_Code range 0 .. 15) of Character :=
10781 "0123456789abcdef";
10782
10783 procedure Write_C_Char_Code (CC : Char_Code) is
10784 C : Character;
10785 begin
10786 -- For now, output wide characters simply as ?
10787
10788 if CC > 255 then
10789 Write_Char ('?');
10790 return;
10791 end if;
10792
10793 C := Character'Val (CC);
10794
10795 -- Remaining characters in range 0 .. 255, output with most appropriate
10796 -- C (escape) sequence.
10797
10798 case C is
10799 when ASCII.BS =>
10800 Write_Str ("\b");
10801
10802 when ASCII.FF =>
10803 Write_Str ("\f");
10804
10805 when ASCII.LF =>
10806 Write_Str ("\n");
10807
10808 when ASCII.CR =>
10809 Write_Str ("\r");
10810
10811 when ASCII.HT =>
10812 Write_Str ("\t");
10813
10814 when ASCII.VT =>
10815 Write_Str ("\v");
10816
10817 when ' ' .. '~' =>
10818 if C = '\' or C = '"' or C = ''' then
10819 Write_Char ('\');
10820 end if;
10821
10822 Write_Char (C);
10823
10824 when others =>
10825 Write_Str ("\x");
10826 Write_Char (Hex (CC / 16));
10827 Write_Char (Hex (CC mod 16));
10828 end case;
10829 end Write_C_Char_Code;
10830
10831 --------------
10832 -- Write_Id --
10833 --------------
10834
10835 procedure Write_Id (N : Node_Id) is
10836 function Is_C_Keyword (Name : Name_Id) return Boolean;
10837 -- Return True if Name is a C keyword
10838
10839 function Is_Qualified (Name : Name_Id) return Boolean;
10840 -- Return True if Name is already fully qualified
10841
10842 ------------------
10843 -- Is_C_Keyword --
10844 ------------------
10845
10846 function Is_C_Keyword (Name : Name_Id) return Boolean is
10847 begin
10848 Get_Name_String (Name);
10849
10850 for J in 1 .. Name_Len loop
10851 Name_Buffer (J) := Fold_Lower (Name_Buffer (J));
10852 end loop;
10853
10854 declare
10855 Str_Name : String renames Name_Buffer (1 .. Name_Len);
10856 begin
10857 -- No need to check C keywords which are also Ada reserved words
10858 -- since (if present) they were rejected by the Ada front end.
10859 -- Those keywords are: case do else for goto if return while.
10860
10861 return Str_Name = "auto"
10862 or else Str_Name = "break"
10863 or else Str_Name = "char"
10864 or else Str_Name = "const"
10865 or else Str_Name = "continue"
10866 or else Str_Name = "default"
10867 or else Str_Name = "double"
10868 or else Str_Name = "enum"
10869 or else Str_Name = "extern"
10870 or else Str_Name = "float"
10871 or else Str_Name = "int"
10872 or else Str_Name = "long"
10873 or else Str_Name = "register"
10874 or else Str_Name = "short"
10875 or else Str_Name = "signed"
10876 or else Str_Name = "sizeof"
10877 or else Str_Name = "static"
10878 or else Str_Name = "struct"
10879 or else Str_Name = "switch"
10880 or else Str_Name = "typedef"
10881 or else Str_Name = "union"
10882 or else Str_Name = "unsigned"
10883 or else Str_Name = "void"
10884 or else Str_Name = "volatile";
10885 end;
10886 end Is_C_Keyword;
10887
10888 ------------------
10889 -- Is_Qualified --
10890 ------------------
10891
10892 function Is_Qualified (Name : Name_Id) return Boolean is
10893 begin
10894 Get_Name_String (Name);
10895
10896 -- Names starting with an upper-case letter are not qualified
10897
10898 if Name_Buffer (1) in 'A' .. 'Z' then
10899 return False;
10900
10901 else
10902 -- Names containing __ are qualified, others aren't
10903
10904 for J in 2 .. Name_Len loop
10905 if Name_Buffer (J) = '_' and then Name_Buffer (J - 1) = '_' then
10906 return True;
10907 end if;
10908 end loop;
10909
10910 return False;
10911 end if;
10912 end Is_Qualified;
10913
10914 -- Start of processing for Write_Id
10915
10916 begin
10917 -- Case of a defining identifier
10918
10919 if Nkind (N) = N_Defining_Identifier then
10920
10921 -- Itypes defined in package specs are propagated to the units
10922 -- depending on them through with clauses and do not always have
10923 -- a fully expanded name. This looks like a bug in the front end,
10924 -- which we workaround here for now???
10925
10926 if Is_Itype (N) then
10927
10928 -- Minimize cases where we add a prefix explicitly, to avoid
10929 -- generating pkg__pkg__Txxs instead of pkg__Txxs when the
10930 -- name has already been expanded.
10931
10932 if not Is_Qualified (Chars (N)) then
10933 Write_Name (Chars (Enclosing_Package_Or_Subprogram (N)));
10934 Write_Str ("__");
10935 end if;
10936
10937 Write_Name (Chars (N));
10938
10939 -- If defining identifier has an interface name (and no address
10940 -- clause), then we output the interface name.
10941
10942 elsif (Is_Imported (N) or else Is_Exported (N))
10943 and then Present (Interface_Name (N))
10944 and then No (Address_Clause (N))
10945 then
10946 String_To_Name_Buffer (Strval (Interface_Name (N)));
10947 Write_Str (Name_Buffer (1 .. Name_Len));
10948
10949 -- Handle renamings of enumeration literals
10950
10951 elsif Ekind (N) = E_Enumeration_Literal then
10952 Write_Name (Chars (Ultimate_Alias (N)));
10953
10954 -- Change names that match C keywords except when the reference
10955 -- an entity defined in Standard (i.e. Float or Unsigned) since
10956 -- they correspond exactly with the C types with such name.
10957
10958 elsif Scope (N) /= Standard_Standard
10959 and then Is_C_Keyword (Chars (N))
10960 then
10961 Write_Name (Chars (N));
10962 Write_Str ("_");
10963
10964 -- If no interface name (or inactive because there was an address
10965 -- clause), then just output the Chars name.
10966
10967 else
10968 Write_Name (Chars (N));
10969 end if;
10970
10971 -- Case of selector of an expanded name where the expanded name has
10972 -- an associated entity, output this entity. Check that the entity
10973 -- or associated node is of the right kind, see above.
10974
10975 elsif Nkind (Parent (N)) = N_Expanded_Name
10976 and then Selector_Name (Parent (N)) = N
10977 and then Present (Entity_Or_Associated_Node (Parent (N)))
10978 and then Nkind (Entity (Parent (N))) in N_Entity
10979 then
10980 Write_Id (Entity (Parent (N)));
10981
10982 -- For enumeration literal, print representation value
10983
10984 elsif Nkind (N) in N_Has_Entity
10985 and then Present (Entity (N))
10986 and then Ekind (Entity (N)) = E_Enumeration_Literal
10987 then
10988 Write_Uint (Enumeration_Rep (Entity (N)), Column_Check => False);
10989
10990 -- For any other node with an associated entity, output entity name
10991
10992 elsif Nkind (N) in N_Has_Entity
10993 and then Present (Entity_Or_Associated_Node (N))
10994 and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
10995 then
10996 if In_Search_Type_Ref
10997 and then Nkind (N) = N_Identifier
10998 and then Present (Associated_Node (N))
10999 then
11000 Check_Definition (Entity (N));
11001 end if;
11002
11003 if Is_Private_Type (Entity (N)) then
11004 Write_Id (Get_Full_View (Entity (N)));
11005 else
11006 Write_Id (Entity (N));
11007 end if;
11008
11009 -- All other cases, we just print the Chars field
11010 -- ??? Might be missing some useful cases here
11011
11012 else
11013 Write_Name (Chars (N));
11014 end if;
11015 end Write_Id;
11016
11017 ------------------
11018 -- Write_Indent --
11019 ------------------
11020
11021 procedure Write_Indent is
11022 begin
11023 if Column > 1 then
11024 Write_Eol;
11025 end if;
11026
11027 for J in 1 .. Indent loop
11028 Write_Char (' ');
11029 end loop;
11030 end Write_Indent;
11031
11032 ----------------------
11033 -- Write_Indent_Str --
11034 ----------------------
11035
11036 procedure Write_Indent_Str (S : String) is
11037 begin
11038 Write_Indent;
11039 Write_Str (S);
11040 end Write_Indent_Str;
11041
11042 ------------------------
11043 -- Write_Integer_Type --
11044 ------------------------
11045
11046 procedure Write_Integer_Type (Siz : Int; Signed : Boolean) is
11047 begin
11048 if Signed then
11049 Write_Str_Col_Check ("integer_");
11050 else
11051 Write_Str_Col_Check ("unsigned_");
11052 end if;
11053
11054 if Siz <= 8 then
11055 Write_Int (8);
11056 elsif Siz <= 16 then
11057 Write_Int (16);
11058 elsif Siz <= 32 then
11059 Write_Int (32);
11060 else
11061 Write_Int (64);
11062 end if;
11063 end Write_Integer_Type;
11064
11065 --------------------------
11066 -- Write_Name_Col_Check --
11067 --------------------------
11068
11069 procedure Write_Name_Col_Check (N : Name_Id) is
11070 begin
11071 Get_Name_String (N);
11072 Write_Str_Col_Check (Name_Buffer (1 .. Name_Len));
11073 end Write_Name_Col_Check;
11074
11075 -----------------------
11076 -- Write_Param_Specs --
11077 -----------------------
11078
11079 procedure Write_Param_Specs (N : Node_Id) is
11080 Formal : Node_Id;
11081
11082 begin
11083 Write_Char ('(');
11084
11085 -- Loop through formals (including any Extra_Formals)
11086
11087 if Nkind (N) in N_Entity and then Is_Itype (N) then
11088 Formal := First_Formal_With_Extras (N);
11089 else
11090 Formal := First_Formal_With_Extras (Unique_Defining_Entity (N));
11091 end if;
11092
11093 if No (Formal) then
11094 Write_Str ("void");
11095 else
11096 loop
11097 -- Output next formal. If parent is an N_Parameter_Specification
11098 -- node, we just print that node, and that takes care of dealing
11099 -- with * for IN OUT and several other issues of complex
11100 -- parameters.
11101
11102 if Nkind (Parent (Formal)) = N_Parameter_Specification then
11103 Cprint_Node (Parent (Formal));
11104
11105 -- Otherwise we have a normal IN parameter (typically an extra
11106 -- formal case), and we print the type and the parameter name in C
11107 -- style.
11108
11109 else
11110 Check_Definition (Etype (Formal), Error_Node => Formal);
11111 Cprint_Type_Name (Etype (Formal));
11112 Write_Char (' ');
11113 Write_Name_Col_Check (Chars (Formal));
11114 end if;
11115
11116 -- Move to next formal
11117
11118 Next_Formal_With_Extras (Formal);
11119
11120 exit when No (Formal);
11121
11122 Write_Str (", ");
11123 end loop;
11124 end if;
11125
11126 Write_Char (')');
11127 end Write_Param_Specs;
11128
11129 ------------------------
11130 -- Write_Source_Lines --
11131 ------------------------
11132
11133 procedure Write_Source_Lines (N : Node_Id) is
11134 begin
11135 if not Check_Sloc (Sloc (N)) then
11136 return;
11137 end if;
11138
11139 Write_Source_Lines (First_Line (N), Last_Line (N));
11140 end Write_Source_Lines;
11141
11142 procedure Write_Source_Lines (S : Source_Ptr) is
11143 L : constant Physical_Line_Number := Get_Physical_Line_Number (S);
11144 begin
11145 if not Check_Sloc (S) then
11146 return;
11147 end if;
11148
11149 Write_Source_Lines (L, L);
11150 end Write_Source_Lines;
11151
11152 procedure Write_Source_Lines
11153 (From : Source_Ptr;
11154 To : Physical_Line_Number) is
11155 begin
11156 if not Check_Sloc (From) then
11157 return;
11158 end if;
11159
11160 Write_Source_Lines (Get_Physical_Line_Number (From), To);
11161 end Write_Source_Lines;
11162
11163 procedure Write_Source_Lines (From, To : Physical_Line_Number) is
11164 Src : constant Source_Buffer_Ptr := Source_Text (Current_Source_File);
11165
11166 Write_Blank_Line : Boolean;
11167 -- If this is True, then a blank line is printed before outputting a
11168 -- source line, and the flag is reset.
11169
11170 function Is_Comment_Line (L : Physical_Line_Number) return Boolean;
11171 -- Returns true if line L is a comment line or blank line
11172
11173 procedure Write_Line_Directive (L : Physical_Line_Number);
11174 -- Write line directive for line L, no effect if L is a comment line
11175
11176 procedure Write_Source_Line (L : Physical_Line_Number);
11177 -- Write source line L as C comment, no effect if L is a comment line.
11178 -- Outputs initial blank line if Write_Blank_Line flag is set and then
11179 -- resets the flag.
11180
11181 ---------------------
11182 -- Is_Comment_Line --
11183 ---------------------
11184
11185 function Is_Comment_Line (L : Physical_Line_Number) return Boolean is
11186 Scn : Source_Ptr;
11187
11188 begin
11189 Scn := Line_Start (L, Current_Source_File);
11190 while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
11191 Scn := Scn + 1;
11192 end loop;
11193
11194 return Src (Scn) in Line_Terminator
11195 or else Src (Scn .. Scn + 1) = "--";
11196 end Is_Comment_Line;
11197
11198 --------------------------
11199 -- Write_Line_Directive --
11200 --------------------------
11201
11202 procedure Write_Line_Directive (L : Physical_Line_Number) is
11203 begin
11204 -- No #line directives for comments or if no -g set
11205
11206 if Debugger_Level = 0 or else Is_Comment_Line (L) then
11207 return;
11208 end if;
11209
11210 if Column /= 1 then
11211 Write_Eol;
11212 end if;
11213
11214 Write_Str ("#line ");
11215 Write_Int (Int (L));
11216 Write_Str (" """);
11217 Write_Str (Get_Name_String (File_Name (Current_Source_File)));
11218 Write_Char ('"');
11219 Write_Eol;
11220 end Write_Line_Directive;
11221
11222 -----------------------
11223 -- Write_Source_Line --
11224 -----------------------
11225
11226 procedure Write_Source_Line (L : Physical_Line_Number) is
11227 Scn : Source_Ptr;
11228
11229 begin
11230 if Is_Comment_Line (L) then
11231 return;
11232 end if;
11233
11234 if Write_Blank_Line then
11235 Write_Eol;
11236 Write_Blank_Line := False;
11237 end if;
11238
11239 Write_Eol;
11240 Write_Str ("/* ");
11241 Write_Int (Int (L));
11242 Write_Str (": ");
11243
11244 Scn := Line_Start (L, Current_Source_File);
11245 while Src (Scn) not in Line_Terminator loop
11246 Write_Char (Src (Scn));
11247 Scn := Scn + 1;
11248 end loop;
11249
11250 Write_Str (" */");
11251 end Write_Source_Line;
11252
11253 -- Local Variables
11254
11255 From_Line : Physical_Line_Number := From;
11256 To_Line : Physical_Line_Number := To;
11257 -- Effective from and to lines as adjusted below
11258
11259 -- Start of processing for Write_Source_Lines
11260
11261 begin
11262 -- Deal with no line number values
11263
11264 if From_Line = No_Physical_Line_Number then
11265 if To_Line = No_Physical_Line_Number then
11266 return;
11267 else
11268 From_Line := To_Line;
11269 end if;
11270 end if;
11271
11272 if To_Line = No_Physical_Line_Number then
11273 To_Line := From_Line;
11274 end if;
11275
11276 -- If some lines already dealt with, adjust From_Line
11277
11278 if Last_Line_Printed >= From_Line then
11279 From_Line := Last_Line_Printed + 1;
11280 end if;
11281
11282 -- Return if all lines already printed. Adjust #line directive before
11283 -- to ensure that we resync the #line info.
11284
11285 if From_Line > To_Line then
11286 Write_Line_Directive (To_Line);
11287 return;
11288 end if;
11289
11290 -- If we are in Dump_Source_Text mode, and there are unprinted source
11291 -- lines before the first line for the current construct, print these
11292 -- source lines, but without line directives.
11293
11294 if Dump_Source_Text and then Last_Line_Printed < From_Line - 1 then
11295 Write_Blank_Line := True;
11296
11297 loop
11298 Last_Line_Printed := Last_Line_Printed + 1;
11299 exit when Last_Line_Printed = From_Line - 1;
11300 Write_Source_Line (Last_Line_Printed);
11301 end loop;
11302 end if;
11303
11304 -- If we are in Dump_Source_Text mode, then print the source lines for
11305 -- the current construct, preceded by a blank line.
11306
11307 if Dump_Source_Text then
11308 Write_Blank_Line := True;
11309
11310 for J in From_Line .. To_Line loop
11311 Write_Source_Line (J);
11312 end loop;
11313 end if;
11314
11315 -- Write line directive for the last line, no need to output multiple
11316 -- line directives.
11317
11318 Write_Line_Directive (To_Line);
11319
11320 -- Note all lines up to To processed and we are done
11321
11322 Last_Line_Printed := To_Line;
11323 return;
11324 end Write_Source_Lines;
11325
11326 -------------------------
11327 -- Write_Str_Col_Check --
11328 -------------------------
11329
11330 procedure Write_Str_Col_Check (S : String) is
11331 begin
11332 if Int (S'Last) + Column > Sprint_Line_Limit then
11333 Write_Indent_Str (" ");
11334
11335 if S (S'First) = ' ' then
11336 Write_Str (S (S'First + 1 .. S'Last));
11337 else
11338 Write_Str (S);
11339 end if;
11340
11341 else
11342 Write_Str (S);
11343 end if;
11344 end Write_Str_Col_Check;
11345
11346 ----------------
11347 -- Write_Uint --
11348 ----------------
11349
11350 -- Note: we go out of our way to be compatible with ancient versions of C
11351 -- here, since we anticipate the output being compiled on such compilers.
11352
11353 procedure Write_Uint
11354 (U : Uint;
11355 Column_Check : Boolean := True;
11356 Modular : Boolean := False)
11357 is
11358 DDH : constant Nat := UI_Decimal_Digits_Hi (U);
11359
11360 procedure Check_Column (Val : Nat);
11361 pragma Inline (Check_Column);
11362 -- Call Col_Check if Column_Check is True, otherwise do nothing
11363
11364 ------------------
11365 -- Check_Column --
11366 ------------------
11367
11368 procedure Check_Column (Val : Nat) is
11369 begin
11370 if Column_Check then
11371 Col_Check (Val);
11372 end if;
11373 end Check_Column;
11374
11375 -- Start of processing for Write_Uint
11376
11377 begin
11378 -- Output largest negative int value as (-X-1) where X is largest
11379 -- positive int value, to avoid generating out of range int value.
11380
11381 if U = LNegInt then
11382 Check_Column (DDH + 4);
11383 Write_Char ('(');
11384 UI_Write (U + 1, Decimal);
11385 Write_Str ("-1)");
11386
11387 -- Most common case of in int range other than largest neg number
11388
11389 elsif LNegInt < U and then U <= LPosInt then
11390 Check_Column (DDH);
11391 UI_Write (U, Decimal);
11392
11393 if Modular then
11394 Write_Char ('U');
11395 end if;
11396
11397 -- Output largest negative long value as (-XL-1) where X is largest
11398 -- positive long value, to avoid generating out of range long value.
11399
11400 elsif U = LNegLong then
11401 Check_Column (DDH + 5);
11402 Write_Char ('(');
11403 UI_Write (U + 1, Decimal);
11404 Write_Str ("L-1)");
11405
11406 -- If in range of unsigned but not int, output with suffix U
11407
11408 elsif LNegU <= U and then U <= LPosU then
11409 Check_Column (DDH + 1);
11410 UI_Write (U, Decimal);
11411 Write_Char ('U');
11412
11413 -- If in range of long then output with suffix L
11414
11415 elsif LNegLong < U and then U <= LPosLong then
11416 Check_Column (DDH + 1);
11417 UI_Write (U, Decimal);
11418 Write_Char ('L');
11419
11420 if Modular then
11421 Write_Char ('U');
11422 end if;
11423
11424 -- Remaining processing depends on whether we are allowing long long,
11425 -- which is controlled by restriction No_Long_Long_Integers.
11426
11427 else
11428 -- Long_Long_Integer not allowed
11429
11430 if Restriction_Active (No_Long_Long_Integers) then
11431
11432 -- We must be in range of long unsigned, output with suffix LU
11433
11434 if LNegUL <= U and then U <= LPosUL then
11435 Check_Column (DDH + 2);
11436 UI_Write (U, Decimal);
11437 Write_Str ("LU");
11438
11439 -- Anything else should be impossible!
11440
11441 else
11442 raise Program_Error;
11443 end if;
11444
11445 -- Long_Long_Integer is allowed
11446
11447 else
11448 -- If in range of long long, output with suffix LL. Note that we
11449 -- do not bother with largest negative number case here. We assume
11450 -- that if long long is allowed, the compiler is more modern.
11451
11452 if LNegLL <= U and then U <= LPosLL then
11453 Check_Column (DDH + 2);
11454 UI_Write (U, Decimal);
11455 Write_Str ("LL");
11456
11457 if Modular then
11458 Write_Char ('U');
11459 end if;
11460
11461 -- If in range of long long unsigned, output with suffix LLU
11462
11463 elsif LNegULL <= U and then U <= LPosULL then
11464 Check_Column (DDH + 3);
11465 UI_Write (U, Decimal);
11466 Write_Str ("LLU");
11467
11468 -- Anything else is capped to LPosULL. This can happen when
11469 -- outputing an unconstrained array indexed by Long_Long_Integer,
11470 -- see e.g. Ada.Streams.Stream_Element_Array
11471
11472 else
11473 Check_Column (DDH + 2);
11474 UI_Write (LPosULL, Decimal);
11475 Write_Str ("LLU");
11476 end if;
11477 end if;
11478 end if;
11479 end Write_Uint;
11480
11481 --------------------------------------
11482 -- Write_Unconstrained_Array_Prefix --
11483 --------------------------------------
11484
11485 procedure Write_Unconstrained_Array_Prefix (N : Node_Id) is
11486 begin
11487 if Is_Unidimensional_Array_Type (Etype (N)) then
11488 Write_Str ("((");
11489 Cprint_Node (Component_Type (Etype (N)));
11490 Write_Str ("*)");
11491
11492 Write_Char ('(');
11493
11494 if Nkind (N) = N_Explicit_Dereference then
11495 Cprint_Node (Prefix (N));
11496 else
11497 Cprint_Node (N);
11498 end if;
11499
11500 Write_Fatptr_Dereference;
11501 Write_Str ("))");
11502
11503 elsif Nkind (N) in N_Has_Entity
11504 and then Present (Actual_Subtype (Entity (N)))
11505 then
11506 Write_Str ("(*(");
11507 Write_Id (Actual_Subtype (Entity (N)));
11508 Write_Str ("*) ");
11509 Cprint_Node (N);
11510 Write_Fatptr_Dereference;
11511 Write_Str (")");
11512
11513 elsif Is_Array_Formal (N)
11514 and then Nkind (N) = N_Explicit_Dereference
11515 and then Has_Back_End_Itype (Entity (Prefix (N)))
11516 then
11517 Write_Str ("(*(");
11518 Write_Back_End_Itype_Id (Entity (Prefix (N)));
11519 Write_Str ("*) ");
11520 Write_Id (Entity (Prefix (N)));
11521 Write_Fatptr_Dereference;
11522 Write_Str (")");
11523
11524 else
11525 declare
11526 S : constant String := Node_Kind'Image (Nkind (N));
11527 begin
11528 Error_Msg_Strlen := S'Length;
11529 Error_Msg_String (1 .. Error_Msg_Strlen) := S;
11530 Error_Msg_N ("unsupported unconstrained array access (~)", N);
11531 end;
11532 end if;
11533 end Write_Unconstrained_Array_Prefix;
11534
11535 ---------------------------
11536 -- Write_Ureal_Col_Check --
11537 ---------------------------
11538
11539 procedure Write_Ureal_Col_Check (U : Ureal) is
11540 procedure Write (Real : Ureal);
11541 -- Writes value of Real to standard output. As a result of evaluation of
11542 -- static expressions, it is possible to generate constants (e.g. 1/13)
11543 -- which have no such representation.
11544
11545 -----------
11546 -- Write --
11547 -----------
11548
11549 procedure Write (Real : Ureal) is
11550 T : Uint;
11551
11552 begin
11553 -- If value is negative, we precede the constant by a minus sign
11554
11555 if UR_Is_Negative (Real) then
11556 Write_Char ('-');
11557 end if;
11558
11559 -- Zero is zero
11560
11561 if UR_Is_Zero (Real) then
11562 Write_Str ("0.0");
11563
11564 -- For constants with a denominator of zero, the value is simply the
11565 -- numerator value, since we are dividing by base**0, which is 1.
11566
11567 elsif Denominator (Real) = 0 then
11568 UI_Write (Numerator (Real), Decimal);
11569 Write_Str (".0");
11570
11571 -- Small powers of 2 get written in decimal fixed-point format
11572
11573 elsif Rbase (Real) = 2
11574 and then Denominator (Real) <= 3
11575 and then Denominator (Real) >= -16
11576 then
11577 if Denominator (Real) = 1 then
11578 T := Numerator (Real) * (10 / 2);
11579 UI_Write (T / 10, Decimal);
11580 Write_Char ('.');
11581 UI_Write (T mod 10, Decimal);
11582
11583 elsif Denominator (Real) = 2 then
11584 T := Numerator (Real) * (100 / 4);
11585 UI_Write (T / 100, Decimal);
11586 Write_Char ('.');
11587 UI_Write (T mod 100 / 10, Decimal);
11588
11589 if T mod 10 /= 0 then
11590 UI_Write (T mod 10, Decimal);
11591 end if;
11592
11593 elsif Denominator (Real) = 3 then
11594 T := Numerator (Real) * (1000 / 8);
11595 UI_Write (T / 1000, Decimal);
11596 Write_Char ('.');
11597 UI_Write (T mod 1000 / 100, Decimal);
11598
11599 if T mod 100 /= 0 then
11600 UI_Write (T mod 100 / 10, Decimal);
11601
11602 if T mod 10 /= 0 then
11603 UI_Write (T mod 10, Decimal);
11604 end if;
11605 end if;
11606
11607 else
11608 UI_Write
11609 (Numerator (Real) * (Uint_2 ** (-Denominator (Real))),
11610 Decimal);
11611 Write_Str (".0");
11612 end if;
11613
11614 -- If the base is non-zero, we normalize the real number and
11615 -- use recursion to process the resulting number.
11616
11617 elsif Rbase (Real) /= 0 then
11618
11619 -- Note that we do not propagate the negative sign since
11620 -- the minus character was alredy sent to the output
11621
11622 Write
11623 (UR_From_Components
11624 (Num => Norm_Num (Real),
11625 Den => Norm_Den (Real)));
11626
11627 -- Rationals where numerator is divisible by denominator can be
11628 -- output as literals after we do the division. This includes the
11629 -- common case where the denominator is 1.
11630
11631 elsif Numerator (Real) mod Denominator (Real) = 0 then
11632 UI_Write (Numerator (Real) / Denominator (Real), Decimal);
11633 Write_Str (".0");
11634
11635 -- Other non-based (rational) constants are written in num/den style
11636
11637 else
11638 UI_Write (Numerator (Real), Decimal);
11639 Write_Str (".0/");
11640 UI_Write (Denominator (Real), Decimal);
11641 Write_Str (".0");
11642 end if;
11643 end Write;
11644
11645 -- Local variables
11646
11647 D : constant Uint := Denominator (U);
11648 N : constant Uint := Numerator (U);
11649
11650 begin
11651 Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
11652 Write (U);
11653 end Write_Ureal_Col_Check;
11654
11655 end Cprint;