?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / bindgen.adb
blob3272e0d1a8ce01125eb5cea32096aee9a792c6de
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- B I N D G E N --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.5.10.1 $
10 -- --
11 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 -- --
27 ------------------------------------------------------------------------------
28
29 with ALI; use ALI;
30 with Binde; use Binde;
31 with Butil; use Butil;
32 with Casing; use Casing;
33 with Fname; use Fname;
34 with GNAT.OS_Lib; use GNAT.OS_Lib;
35 with Gnatvsn; use Gnatvsn;
36 with Hostparm;
37 with Namet; use Namet;
38 with Opt; use Opt;
39 with Osint; use Osint;
40 with Output; use Output;
41 with Types; use Types;
42 with Sdefault; use Sdefault;
43 with System; use System;
44
45 with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
46
47 package body Bindgen is
48
49 Statement_Buffer : String (1 .. 1000);
50 -- Buffer used for constructing output statements
51
52 Last : Natural := 0;
53 -- Last location in Statement_Buffer currently set
54
55 With_DECGNAT : Boolean := False;
56 -- Flag which indicates whether the program uses the DECGNAT library
57 -- (presence of the unit System.Aux_DEC.DECLIB)
58
59 With_GNARL : Boolean := False;
60 -- Flag which indicates whether the program uses the GNARL library
61 -- (presence of the unit System.OS_Interface)
62
63 Num_Elab_Calls : Nat := 0;
64 -- Number of generated calls to elaboration routines
65
66 subtype chars_ptr is Address;
67
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
71
72 procedure WBI (Info : String) renames Osint.Write_Binder_Info;
73 -- Convenient shorthand used throughout
74
75 function ABE_Boolean_Required (U : Unit_Id) return Boolean;
76 -- Given a unit id value U, determines if the corresponding unit requires
77 -- an access-before-elaboration check variable, i.e. it is a non-predefined
78 -- body for which no pragma Elaborate, Elaborate_All or Elaborate_Body is
79 -- present, and thus could require ABE checks.
80
81 procedure Resolve_Binder_Options;
82 -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
83 -- since it tests for a package named "dec" which might cause a conflict
84 -- on non-VMS systems.
85
86 procedure Gen_Adainit_Ada;
87 -- Generates the Adainit procedure (Ada code case)
88
89 procedure Gen_Adainit_C;
90 -- Generates the Adainit procedure (C code case)
91
92 procedure Gen_Adafinal_Ada;
93 -- Generate the Adafinal procedure (Ada code case)
94
95 procedure Gen_Adafinal_C;
96 -- Generate the Adafinal procedure (C code case)
97
98 procedure Gen_Elab_Calls_Ada;
99 -- Generate sequence of elaboration calls (Ada code case)
100
101 procedure Gen_Elab_Calls_C;
102 -- Generate sequence of elaboration calls (C code case)
103
104 procedure Gen_Elab_Order_Ada;
105 -- Generate comments showing elaboration order chosen (Ada case)
106
107 procedure Gen_Elab_Order_C;
108 -- Generate comments showing elaboration order chosen (C case)
109
110 procedure Gen_Elab_Defs_C;
111 -- Generate sequence of definitions for elaboration routines (C code case)
112
113 procedure Gen_Exception_Table_Ada;
114 -- Generate binder exception table (Ada code case). This consists of
115 -- declarations followed by a begin followed by a call. If zero cost
116 -- exceptions are not active, then only the begin is generated.
117
118 procedure Gen_Exception_Table_C;
119 -- Generate binder exception table (C code case). This has no effect
120 -- if zero cost exceptions are not active, otherwise it generates a
121 -- set of declarations followed by a call.
122
123 procedure Gen_Main_Ada;
124 -- Generate procedure main (Ada code case)
125
126 procedure Gen_Main_C;
127 -- Generate main() procedure (C code case)
128
129 procedure Gen_Object_Files_Options;
130 -- Output comments containing a list of the full names of the object
131 -- files to be linked and the list of linker options supplied by
132 -- Linker_Options pragmas in the source. (C and Ada code case)
133
134 procedure Gen_Output_File_Ada (Filename : String);
135 -- Generate output file (Ada code case)
136
137 procedure Gen_Output_File_C (Filename : String);
138 -- Generate output file (C code case)
139
140 procedure Gen_Scalar_Values;
141 -- Generates scalar initialization values for -Snn. A single procedure
142 -- handles both the Ada and C cases, since there is much common code.
143
144 procedure Gen_Versions_Ada;
145 -- Output series of definitions for unit versions (Ada code case)
146
147 procedure Gen_Versions_C;
148 -- Output series of definitions for unit versions (C code case)
149
150 function Get_Ada_Main_Name return String;
151 -- This function is used in the Ada main output case to compute a usable
152 -- name for the generated main program. The normal main program name is
153 -- Ada_Main, but this won't work if the user has a unit with this name.
154 -- This function tries Ada_Main first, and if there is such a clash, then
155 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
156
157 function Get_Main_Name return String;
158 -- This function is used in the Ada main output case to compute the
159 -- correct external main program. It is "main" by default, except on
160 -- VxWorks where it is the name of the Ada main name without the "_ada".
161 -- the -Mname binder option overrides the default with name.
162
163 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
164 -- Compare linker options, when sorting, first according to
165 -- Is_Internal_File (internal files come later) and then by elaboration
166 -- order position (latest to earliest) except its not possible to
167 -- distinguish between a linker option in the spec and one in the body.
168
169 procedure Move_Linker_Option (From : Natural; To : Natural);
170 -- Move routine for sorting linker options
171
172 procedure Set_Char (C : Character);
173 -- Set given character in Statement_Buffer at the Last + 1 position
174 -- and increment Last by one to reflect the stored character.
175
176 procedure Set_Int (N : Int);
177 -- Set given value in decimal in Statement_Buffer with no spaces
178 -- starting at the Last + 1 position, and updating Last past the value.
179 -- A minus sign is output for a negative value.
180
181 procedure Set_Main_Program_Name;
182 -- Given the main program name in Name_Buffer (length in Name_Len)
183 -- generate the name of the routine to be used in the call. The name
184 -- is generated starting at Last + 1, and Last is updated past it.
185
186 procedure Set_Name_Buffer;
187 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
188
189 procedure Set_String (S : String);
190 -- Sets characters of given string in Statement_Buffer, starting at the
191 -- Last + 1 position, and updating last past the string value.
192
193 procedure Set_Unit_Name;
194 -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
195 -- starting at the Last + 1 position, and updating last past the value.
196 -- changing periods to double underscores, and updating Last appropriately.
197
198 procedure Set_Unit_Number (U : Unit_Id);
199 -- Sets unit number (first unit is 1, leading zeroes output to line
200 -- up all output unit numbers nicely as required by the value, and
201 -- by the total number of units.
202
203 procedure Tab_To (N : Natural);
204 -- If Last is greater than or equal to N, no effect, otherwise store
205 -- blanks in Statement_Buffer bumping Last, until Last = N.
206
207 function Value (chars : chars_ptr) return String;
208 -- Return C NUL-terminated string at chars as an Ada string
209
210 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
211 -- For C code case, write C & Common, for Ada case write Ada & Common
212 -- to current binder output file using Write_Binder_Info.
213
214 procedure Write_Statement_Buffer;
215 -- Write out contents of statement buffer up to Last, and reset Last to 0
216
217 procedure Write_Statement_Buffer (S : String);
218 -- First writes its argument (using Set_String (S)), then writes out the
219 -- contents of statement buffer up to Last, and reset Last to 0
220
221 --------------------------
222 -- ABE_Boolean_Required --
223 --------------------------
224
225 function ABE_Boolean_Required (U : Unit_Id) return Boolean is
226 Typ : constant Unit_Type := Units.Table (U).Utype;
227 Unit : Unit_Id;
228
229 begin
230 if Typ /= Is_Body then
231 return False;
232
233 else
234 Unit := U + 1;
235
236 return (not Units.Table (Unit).Pure)
237 and then
238 (not Units.Table (Unit).Preelab)
239 and then
240 (not Units.Table (Unit).Elaborate_Body)
241 and then
242 (not Units.Table (Unit).Predefined);
243 end if;
244 end ABE_Boolean_Required;
245
246 ----------------------
247 -- Gen_Adafinal_Ada --
248 ----------------------
249
250 procedure Gen_Adafinal_Ada is
251 begin
252 WBI ("");
253 WBI (" procedure " & Ada_Final_Name.all & " is");
254 WBI (" begin");
255
256 -- If compiling for the JVM, we directly call Adafinal because
257 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
258
259 if Hostparm.Java_VM then
260 WBI (" System.Standard_Library.Adafinal;");
261 else
262 WBI (" Do_Finalize;");
263 end if;
264
265 WBI (" end " & Ada_Final_Name.all & ";");
266 end Gen_Adafinal_Ada;
267
268 --------------------
269 -- Gen_Adafinal_C --
270 --------------------
271
272 procedure Gen_Adafinal_C is
273 begin
274 WBI ("void " & Ada_Final_Name.all & " () {");
275 WBI (" system__standard_library__adafinal ();");
276 WBI ("}");
277 WBI ("");
278 end Gen_Adafinal_C;
279
280 ---------------------
281 -- Gen_Adainit_Ada --
282 ---------------------
283
284 procedure Gen_Adainit_Ada is
285 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
286 begin
287 WBI (" procedure " & Ada_Init_Name.all & " is");
288
289 -- Generate externals for elaboration entities
290
291 for E in Elab_Order.First .. Elab_Order.Last loop
292 declare
293 Unum : constant Unit_Id := Elab_Order.Table (E);
294 U : Unit_Record renames Units.Table (Unum);
295
296 begin
297 if U.Set_Elab_Entity then
298 Set_String (" ");
299 Set_String ("E");
300 Set_Unit_Number (Unum);
301 Set_String (" : Boolean; pragma Import (Ada, ");
302 Set_String ("E");
303 Set_Unit_Number (Unum);
304 Set_String (", """);
305 Get_Name_String (U.Uname);
306
307 -- In the case of JGNAT we need to emit an Import name
308 -- that includes the class name (using '$' separators
309 -- in the case of a child unit name).
310
311 if Hostparm.Java_VM then
312 for J in 1 .. Name_Len - 2 loop
313 if Name_Buffer (J) /= '.' then
314 Set_Char (Name_Buffer (J));
315 else
316 Set_String ("$");
317 end if;
318 end loop;
319
320 Set_String (".");
321
322 -- If the unit name is very long, then split the
323 -- Import link name across lines using "&" (occurs
324 -- in some C2 tests).
325
326 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
327 Set_String (""" &");
328 Write_Statement_Buffer;
329 Set_String (" """);
330 end if;
331 end if;
332
333 Set_Unit_Name;
334 Set_String ("_E"");");
335 Write_Statement_Buffer;
336 end if;
337 end;
338 end loop;
339
340 Write_Statement_Buffer;
341
342 -- Normal case (not No_Run_Time mode). The global values are
343 -- assigned using the runtime routine Set_Globals (we have to use
344 -- the routine call, rather than define the globals in the binder
345 -- file to deal with cross-library calls in some systems.
346
347 if No_Run_Time_Specified then
348
349 -- Case of No_Run_Time mode. The only global variable that might
350 -- be needed (by the Ravenscar profile) is the priority of the
351 -- environment. Also no exception tables are needed.
352
353 if Main_Priority /= No_Main_Priority then
354 WBI (" Main_Priority : Integer;");
355 WBI (" pragma Import (C, Main_Priority," &
356 " ""__gl_main_priority"");");
357 WBI ("");
358 end if;
359
360 WBI (" begin");
361
362 if Main_Priority /= No_Main_Priority then
363 Set_String (" Main_Priority := ");
364 Set_Int (Main_Priority);
365 Set_Char (';');
366 Write_Statement_Buffer;
367
368 else
369 WBI (" null;");
370 end if;
371
372 else
373 WBI ("");
374 WBI (" procedure Set_Globals");
375 WBI (" (Main_Priority : Integer;");
376 WBI (" Time_Slice_Value : Integer;");
377 WBI (" WC_Encoding : Character;");
378 WBI (" Locking_Policy : Character;");
379 WBI (" Queuing_Policy : Character;");
380 WBI (" Task_Dispatching_Policy : Character;");
381 WBI (" Adafinal : System.Address;");
382 WBI (" Unreserve_All_Interrupts : Integer;");
383 WBI (" Exception_Tracebacks : Integer);");
384 WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
385 WBI ("");
386
387 -- Import entry point for elaboration time signal handler
388 -- installation, and indication of whether it's been called
389 -- previously
390 WBI ("");
391 WBI (" procedure Install_Handler;");
392 WBI (" pragma Import (C, Install_Handler, " &
393 """__gnat_install_handler"");");
394 WBI ("");
395 WBI (" Handler_Installed : Integer;");
396 WBI (" pragma Import (C, Handler_Installed, " &
397 """__gnat_handler_installed"");");
398
399 -- Generate exception table
400
401 Gen_Exception_Table_Ada;
402
403 -- Generate the call to Set_Globals
404
405 WBI (" Set_Globals");
406
407 Set_String (" (Main_Priority => ");
408 Set_Int (Main_Priority);
409 Set_Char (',');
410 Write_Statement_Buffer;
411
412 Set_String (" Time_Slice_Value => ");
413
414 if Task_Dispatching_Policy_Specified = 'F'
415 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
416 then
417 Set_Int (0);
418 else
419 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
420 end if;
421
422 Set_Char (',');
423 Write_Statement_Buffer;
424
425 Set_String (" WC_Encoding => '");
426 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
427 Set_String ("',");
428 Write_Statement_Buffer;
429
430 Set_String (" Locking_Policy => '");
431 Set_Char (Locking_Policy_Specified);
432 Set_String ("',");
433 Write_Statement_Buffer;
434
435 Set_String (" Queuing_Policy => '");
436 Set_Char (Queuing_Policy_Specified);
437 Set_String ("',");
438 Write_Statement_Buffer;
439
440 Set_String (" Task_Dispatching_Policy => '");
441 Set_Char (Task_Dispatching_Policy_Specified);
442 Set_String ("',");
443 Write_Statement_Buffer;
444
445 WBI (" Adafinal => System.Null_Address,");
446
447 Set_String (" Unreserve_All_Interrupts => ");
448
449 if Unreserve_All_Interrupts_Specified then
450 Set_String ("1");
451 else
452 Set_String ("0");
453 end if;
454
455 Set_String (",");
456 Write_Statement_Buffer;
457
458 Set_String (" Exception_Tracebacks => ");
459
460 if Exception_Tracebacks then
461 Set_String ("1");
462 else
463 Set_String ("0");
464 end if;
465
466 Set_String (");");
467 Write_Statement_Buffer;
468
469 -- Generate call to Install_Handler
470 WBI ("");
471 WBI (" if Handler_Installed = 0 then");
472 WBI (" Install_Handler;");
473 WBI (" end if;");
474 end if;
475
476 Gen_Elab_Calls_Ada;
477
478 WBI (" end " & Ada_Init_Name.all & ";");
479 end Gen_Adainit_Ada;
480
481 -------------------
482 -- Gen_Adainit_C --
483 --------------------
484
485 procedure Gen_Adainit_C is
486 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
487 begin
488 WBI ("void " & Ada_Init_Name.all & " ()");
489 WBI ("{");
490
491 -- Generate externals for elaboration entities
492
493 for E in Elab_Order.First .. Elab_Order.Last loop
494 declare
495 Unum : constant Unit_Id := Elab_Order.Table (E);
496 U : Unit_Record renames Units.Table (Unum);
497
498 begin
499 if U.Set_Elab_Entity then
500 Set_String (" extern char ");
501 Get_Name_String (U.Uname);
502 Set_Unit_Name;
503 Set_String ("_E;");
504 Write_Statement_Buffer;
505 end if;
506 end;
507 end loop;
508
509 Write_Statement_Buffer;
510
511 if No_Run_Time_Specified then
512
513 -- Case of No_Run_Time mode. Set __gl_main_priority if needed
514 -- for the Ravenscar profile.
515
516 if Main_Priority /= No_Main_Priority then
517 Set_String (" extern int __gl_main_priority = ");
518 Set_Int (Main_Priority);
519 Set_Char (';');
520 Write_Statement_Buffer;
521 end if;
522
523 else
524 -- Code for normal case (not in No_Run_Time mode)
525
526 Gen_Exception_Table_C;
527
528 -- Generate call to set the runtime global variables defined in
529 -- a-init.c. We define the varables in a-init.c, rather than in
530 -- the binder generated file itself to avoid undefined externals
531 -- when the runtime is linked as a shareable image library.
532
533 -- We call the routine from inside adainit() because this works for
534 -- both programs with and without binder generated "main" functions.
535
536 WBI (" __gnat_set_globals (");
537
538 Set_String (" ");
539 Set_Int (Main_Priority);
540 Set_Char (',');
541 Tab_To (15);
542 Set_String ("/* Main_Priority */");
543 Write_Statement_Buffer;
544
545 Set_String (" ");
546
547 if Task_Dispatching_Policy = 'F'
548 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
549 then
550 Set_Int (0);
551 else
552 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
553 end if;
554
555 Set_Char (',');
556 Tab_To (15);
557 Set_String ("/* Time_Slice_Value */");
558 Write_Statement_Buffer;
559
560 Set_String (" '");
561 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
562 Set_String ("',");
563 Tab_To (15);
564 Set_String ("/* WC_Encoding */");
565 Write_Statement_Buffer;
566
567 Set_String (" '");
568 Set_Char (Locking_Policy_Specified);
569 Set_String ("',");
570 Tab_To (15);
571 Set_String ("/* Locking_Policy */");
572 Write_Statement_Buffer;
573
574 Set_String (" '");
575 Set_Char (Queuing_Policy_Specified);
576 Set_String ("',");
577 Tab_To (15);
578 Set_String ("/* Queuing_Policy */");
579 Write_Statement_Buffer;
580
581 Set_String (" '");
582 Set_Char (Task_Dispatching_Policy_Specified);
583 Set_String ("',");
584 Tab_To (15);
585 Set_String ("/* Tasking_Dispatching_Policy */");
586 Write_Statement_Buffer;
587
588 Set_String (" ");
589 Set_String ("0,");
590 Tab_To (15);
591 Set_String ("/* Finalization routine address, not used anymore */");
592 Write_Statement_Buffer;
593
594 Set_String (" ");
595 Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
596 Set_String (",");
597 Tab_To (15);
598 Set_String ("/* Unreserve_All_Interrupts */");
599 Write_Statement_Buffer;
600
601 Set_String (" ");
602 Set_Int (Boolean'Pos (Exception_Tracebacks));
603 Set_String (");");
604 Tab_To (15);
605 Set_String ("/* Exception_Tracebacks */");
606 Write_Statement_Buffer;
607
608 -- Install elaboration time signal handler
609 WBI (" if (__gnat_handler_installed == 0)");
610 WBI (" {");
611 WBI (" __gnat_install_handler ();");
612 WBI (" }");
613 end if;
614
615 WBI ("");
616 Gen_Elab_Calls_C;
617 WBI ("}");
618 end Gen_Adainit_C;
619
620 ------------------------
621 -- Gen_Elab_Calls_Ada --
622 ------------------------
623
624 procedure Gen_Elab_Calls_Ada is
625 begin
626
627 for E in Elab_Order.First .. Elab_Order.Last loop
628 declare
629 Unum : constant Unit_Id := Elab_Order.Table (E);
630 U : Unit_Record renames Units.Table (Unum);
631
632 Unum_Spec : Unit_Id;
633 -- This is the unit number of the spec that corresponds to
634 -- this entry. It is the same as Unum except when the body
635 -- and spec are different and we are currently processing
636 -- the body, in which case it is the spec (Unum + 1).
637
638 procedure Set_Elab_Entity;
639 -- Set name of elaboration entity flag
640
641 procedure Set_Elab_Entity is
642 begin
643 Get_Decoded_Name_String_With_Brackets (U.Uname);
644 Name_Len := Name_Len - 2;
645 Set_Casing (U.Icasing);
646 Set_Name_Buffer;
647 end Set_Elab_Entity;
648
649 begin
650 if U.Utype = Is_Body then
651 Unum_Spec := Unum + 1;
652 else
653 Unum_Spec := Unum;
654 end if;
655
656 -- Case of no elaboration code
657
658 if U.No_Elab then
659
660 -- The only case in which we have to do something is if
661 -- this is a body, with a separate spec, where the separate
662 -- spec has an elaboration entity defined.
663
664 -- In that case, this is where we set the elaboration entity
665 -- to True, we do not need to test if this has already been
666 -- done, since it is quicker to set the flag than to test it.
667
668 if U.Utype = Is_Body
669 and then Units.Table (Unum_Spec).Set_Elab_Entity
670 then
671 Set_String (" E");
672 Set_Unit_Number (Unum_Spec);
673 Set_String (" := True;");
674 Write_Statement_Buffer;
675 end if;
676
677 -- Here if elaboration code is present. We generate:
678
679 -- if not uname_E then
680 -- uname'elab_[spec|body];
681 -- uname_E := True;
682 -- end if;
683
684 -- The uname_E assignment is skipped if this is a separate spec,
685 -- since the assignment will be done when we process the body.
686
687 else
688 Set_String (" if not E");
689 Set_Unit_Number (Unum_Spec);
690 Set_String (" then");
691 Write_Statement_Buffer;
692
693 Set_String (" ");
694 Get_Decoded_Name_String_With_Brackets (U.Uname);
695
696 if Name_Buffer (Name_Len) = 's' then
697 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec";
698 else
699 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
700 end if;
701
702 Name_Len := Name_Len + 8;
703 Set_Casing (U.Icasing);
704 Set_Name_Buffer;
705 Set_Char (';');
706 Write_Statement_Buffer;
707
708 if U.Utype /= Is_Spec then
709 Set_String (" E");
710 Set_Unit_Number (Unum_Spec);
711 Set_String (" := True;");
712 Write_Statement_Buffer;
713 end if;
714
715 WBI (" end if;");
716 end if;
717 end;
718 end loop;
719
720 end Gen_Elab_Calls_Ada;
721
722 ----------------------
723 -- Gen_Elab_Calls_C --
724 ----------------------
725
726 procedure Gen_Elab_Calls_C is
727 begin
728
729 for E in Elab_Order.First .. Elab_Order.Last loop
730 declare
731 Unum : constant Unit_Id := Elab_Order.Table (E);
732 U : Unit_Record renames Units.Table (Unum);
733
734 Unum_Spec : Unit_Id;
735 -- This is the unit number of the spec that corresponds to
736 -- this entry. It is the same as Unum except when the body
737 -- and spec are different and we are currently processing
738 -- the body, in which case it is the spec (Unum + 1).
739
740 begin
741 if U.Utype = Is_Body then
742 Unum_Spec := Unum + 1;
743 else
744 Unum_Spec := Unum;
745 end if;
746
747 -- Case of no elaboration code
748
749 if U.No_Elab then
750
751 -- The only case in which we have to do something is if
752 -- this is a body, with a separate spec, where the separate
753 -- spec has an elaboration entity defined.
754
755 -- In that case, this is where we set the elaboration entity
756 -- to True, we do not need to test if this has already been
757 -- done, since it is quicker to set the flag than to test it.
758
759 if U.Utype = Is_Body
760 and then Units.Table (Unum_Spec).Set_Elab_Entity
761 then
762 Set_String (" ");
763 Get_Name_String (U.Uname);
764 Set_Unit_Name;
765 Set_String ("_E = 1;");
766 Write_Statement_Buffer;
767 end if;
768
769 -- Here if elaboration code is present. We generate:
770
771 -- if (uname_E == 0) {
772 -- uname__elab[s|b] ();
773 -- uname_E++;
774 -- }
775
776 -- The uname_E assignment is skipped if this is a separate spec,
777 -- since the assignment will be done when we process the body.
778
779 else
780 Set_String (" if (");
781 Get_Name_String (U.Uname);
782 Set_Unit_Name;
783 Set_String ("_E == 0) {");
784 Write_Statement_Buffer;
785
786 Set_String (" ");
787 Set_Unit_Name;
788 Set_String ("___elab");
789 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
790 Set_String (" ();");
791 Write_Statement_Buffer;
792
793 if U.Utype /= Is_Spec then
794 Set_String (" ");
795 Set_Unit_Name;
796 Set_String ("_E++;");
797 Write_Statement_Buffer;
798 end if;
799
800 WBI (" }");
801 end if;
802 end;
803 end loop;
804
805 end Gen_Elab_Calls_C;
806
807 ----------------------
808 -- Gen_Elab_Defs_C --
809 ----------------------
810
811 procedure Gen_Elab_Defs_C is
812 begin
813 for E in Elab_Order.First .. Elab_Order.Last loop
814
815 -- Generate declaration of elaboration procedure if elaboration
816 -- needed. Note that passive units are always excluded.
817
818 if not Units.Table (Elab_Order.Table (E)).No_Elab then
819 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
820 Set_String ("extern void ");
821 Set_Unit_Name;
822 Set_String ("___elab");
823 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
824 Set_String (" PARAMS ((void));");
825 Write_Statement_Buffer;
826 end if;
827
828 end loop;
829
830 WBI ("");
831 end Gen_Elab_Defs_C;
832
833 ------------------------
834 -- Gen_Elab_Order_Ada --
835 ------------------------
836
837 procedure Gen_Elab_Order_Ada is
838 begin
839 WBI ("");
840 WBI (" -- BEGIN ELABORATION ORDER");
841
842 for J in Elab_Order.First .. Elab_Order.Last loop
843 Set_String (" -- ");
844 Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
845 Set_Name_Buffer;
846 Write_Statement_Buffer;
847 end loop;
848
849 WBI (" -- END ELABORATION ORDER");
850 end Gen_Elab_Order_Ada;
851
852 ----------------------
853 -- Gen_Elab_Order_C --
854 ----------------------
855
856 procedure Gen_Elab_Order_C is
857 begin
858 WBI ("");
859 WBI ("/* BEGIN ELABORATION ORDER");
860
861 for J in Elab_Order.First .. Elab_Order.Last loop
862 Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
863 Set_Name_Buffer;
864 Write_Statement_Buffer;
865 end loop;
866
867 WBI (" END ELABORATION ORDER */");
868 end Gen_Elab_Order_C;
869
870 -----------------------------
871 -- Gen_Exception_Table_Ada --
872 -----------------------------
873
874 procedure Gen_Exception_Table_Ada is
875 Num : Nat;
876 Last : ALI_Id := No_ALI_Id;
877
878 begin
879 if not Zero_Cost_Exceptions_Specified then
880 WBI (" begin");
881 return;
882 end if;
883
884 -- The code we generate looks like
885
886 -- procedure SDP_Table_Build
887 -- (SDP_Addresses : System.Address;
888 -- SDP_Count : Natural;
889 -- Elab_Addresses : System.Address;
890 -- Elab_Addr_Count : Natural);
891 -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
892 --
893 -- ST : aliased constant array (1 .. nnn) of System.Address := (
894 -- unit_name_1'UET_Address,
895 -- unit_name_2'UET_Address,
896 -- ...
897 -- unit_name_3'UET_Address,
898 --
899 -- EA : aliased constant array (1 .. eee) of System.Address := (
900 -- adainit'Code_Address,
901 -- adafinal'Code_Address,
902 -- unit_name'elab[spec|body]'Code_Address,
903 -- unit_name'elab[spec|body]'Code_Address,
904 -- unit_name'elab[spec|body]'Code_Address,
905 -- unit_name'elab[spec|body]'Code_Address);
906 --
907 -- begin
908 -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
909
910 Num := 0;
911 for A in ALIs.First .. ALIs.Last loop
912 if ALIs.Table (A).Unit_Exception_Table then
913 Num := Num + 1;
914 Last := A;
915 end if;
916 end loop;
917
918 if Num = 0 then
919
920 -- Happens with "gnatmake -a -f -gnatL ..."
921
922 WBI (" ");
923 WBI (" begin");
924 return;
925 end if;
926
927 WBI (" procedure SDP_Table_Build");
928 WBI (" (SDP_Addresses : System.Address;");
929 WBI (" SDP_Count : Natural;");
930 WBI (" Elab_Addresses : System.Address;");
931 WBI (" Elab_Addr_Count : Natural);");
932 WBI (" " &
933 "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
934
935 WBI (" ");
936 Set_String (" ST : aliased constant array (1 .. ");
937 Set_Int (Num);
938 Set_String (") of System.Address := (");
939
940 if Num = 1 then
941 Set_String ("1 => A1);");
942 Write_Statement_Buffer;
943
944 else
945 Write_Statement_Buffer;
946
947 for A in ALIs.First .. ALIs.Last loop
948 if ALIs.Table (A).Unit_Exception_Table then
949 Get_Decoded_Name_String_With_Brackets
950 (Units.Table (ALIs.Table (A).First_Unit).Uname);
951 Set_Casing (Mixed_Case);
952 Set_String (" ");
953 Set_String (Name_Buffer (1 .. Name_Len - 2));
954 Set_String ("'UET_Address");
955
956 if A = Last then
957 Set_String (");");
958 else
959 Set_Char (',');
960 end if;
961
962 Write_Statement_Buffer;
963 end if;
964 end loop;
965 end if;
966
967 WBI (" ");
968 Set_String (" EA : aliased constant array (1 .. ");
969 Set_Int (Num_Elab_Calls + 2);
970 Set_String (") of System.Address := (");
971 Write_Statement_Buffer;
972 WBI (" " & Ada_Init_Name.all & "'Code_Address,");
973
974 -- If compiling for the JVM, we directly reference Adafinal because
975 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
976
977 if Hostparm.Java_VM then
978 Set_String (" System.Standard_Library.Adafinal'Code_Address");
979 else
980 Set_String (" Do_Finalize'Code_Address");
981 end if;
982
983 for E in Elab_Order.First .. Elab_Order.Last loop
984 Get_Decoded_Name_String_With_Brackets
985 (Units.Table (Elab_Order.Table (E)).Uname);
986
987 if Units.Table (Elab_Order.Table (E)).No_Elab then
988 null;
989
990 else
991 Set_Char (',');
992 Write_Statement_Buffer;
993 Set_String (" ");
994
995 if Name_Buffer (Name_Len) = 's' then
996 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
997 "'elab_spec'code_address";
998 else
999 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1000 "'elab_body'code_address";
1001 end if;
1002
1003 Name_Len := Name_Len + 21;
1004 Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
1005 Set_Name_Buffer;
1006 end if;
1007 end loop;
1008
1009 Set_String (");");
1010 Write_Statement_Buffer;
1011
1012 WBI (" ");
1013 WBI (" begin");
1014
1015 Set_String (" SDP_Table_Build (ST'Address, ");
1016 Set_Int (Num);
1017 Set_String (", EA'Address, ");
1018 Set_Int (Num_Elab_Calls + 2);
1019 Set_String (");");
1020 Write_Statement_Buffer;
1021 end Gen_Exception_Table_Ada;
1022
1023 ---------------------------
1024 -- Gen_Exception_Table_C --
1025 ---------------------------
1026
1027 procedure Gen_Exception_Table_C is
1028 Num : Nat;
1029 Num2 : Nat;
1030
1031 begin
1032 if not Zero_Cost_Exceptions_Specified then
1033 return;
1034 end if;
1035
1036 -- The code we generate looks like
1037
1038 -- extern void *__gnat_unitname1__SDP;
1039 -- extern void *__gnat_unitname2__SDP;
1040 -- ...
1041 --
1042 -- void **st[nnn] = {
1043 -- &__gnat_unitname1__SDP,
1044 -- &__gnat_unitname2__SDP,
1045 -- ...
1046 -- &__gnat_unitnamen__SDP};
1047 --
1048 -- extern void unitname1__elabb ();
1049 -- extern void unitname2__elabb ();
1050 -- ...
1051 --
1052 -- void (*ea[eee]) () = {
1053 -- adainit,
1054 -- adafinal,
1055 -- unitname1___elab[b,s],
1056 -- unitname2___elab[b,s],
1057 -- ...
1058 -- unitnamen___elab[b,s]};
1059 --
1060 -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
1061
1062 Num := 0;
1063 for A in ALIs.First .. ALIs.Last loop
1064 if ALIs.Table (A).Unit_Exception_Table then
1065 Num := Num + 1;
1066
1067 Set_String (" extern void *__gnat_");
1068 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1069 Set_Unit_Name;
1070 Set_String ("__SDP");
1071 Set_Char (';');
1072 Write_Statement_Buffer;
1073 end if;
1074 end loop;
1075
1076 if Num = 0 then
1077
1078 -- Happens with "gnatmake -a -f -gnatL ..."
1079
1080 return;
1081 end if;
1082
1083 WBI (" ");
1084
1085 Set_String (" void **st[");
1086 Set_Int (Num);
1087 Set_String ("] = {");
1088 Write_Statement_Buffer;
1089
1090 Num2 := 0;
1091 for A in ALIs.First .. ALIs.Last loop
1092 if ALIs.Table (A).Unit_Exception_Table then
1093 Num2 := Num2 + 1;
1094
1095 Set_String (" &__gnat_");
1096 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1097 Set_Unit_Name;
1098 Set_String ("__SDP");
1099
1100 if Num = Num2 then
1101 Set_String ("};");
1102 else
1103 Set_Char (',');
1104 end if;
1105
1106 Write_Statement_Buffer;
1107 end if;
1108 end loop;
1109
1110 WBI ("");
1111 for E in Elab_Order.First .. Elab_Order.Last loop
1112 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1113
1114 if Units.Table (Elab_Order.Table (E)).No_Elab then
1115 null;
1116
1117 else
1118 Set_String (" extern void ");
1119 Set_Unit_Name;
1120 Set_String ("___elab");
1121 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1122 Set_String (" ();");
1123 Write_Statement_Buffer;
1124 end if;
1125 end loop;
1126
1127 WBI ("");
1128 Set_String (" void (*ea[");
1129 Set_Int (Num_Elab_Calls + 2);
1130 Set_String ("]) () = {");
1131 Write_Statement_Buffer;
1132
1133 WBI (" " & Ada_Init_Name.all & ",");
1134 Set_String (" system__standard_library__adafinal");
1135
1136 for E in Elab_Order.First .. Elab_Order.Last loop
1137 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1138
1139 if Units.Table (Elab_Order.Table (E)).No_Elab then
1140 null;
1141
1142 else
1143 Set_Char (',');
1144 Write_Statement_Buffer;
1145 Set_String (" ");
1146 Set_Unit_Name;
1147 Set_String ("___elab");
1148 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1149 end if;
1150 end loop;
1151
1152 Set_String ("};");
1153 Write_Statement_Buffer;
1154
1155 WBI (" ");
1156
1157 Set_String (" __gnat_SDP_Table_Build (&st, ");
1158 Set_Int (Num);
1159 Set_String (", ea, ");
1160 Set_Int (Num_Elab_Calls + 2);
1161 Set_String (");");
1162 Write_Statement_Buffer;
1163 end Gen_Exception_Table_C;
1164
1165 ------------------
1166 -- Gen_Main_Ada --
1167 ------------------
1168
1169 procedure Gen_Main_Ada is
1170 Target : constant String_Ptr := Target_Name;
1171 VxWorks_Target : constant Boolean :=
1172 Target (Target'Last - 7 .. Target'Last) = "vxworks/";
1173
1174 begin
1175 WBI ("");
1176 Set_String (" function ");
1177 Set_String (Get_Main_Name);
1178
1179 if VxWorks_Target then
1180 Set_String (" return Integer is");
1181 Write_Statement_Buffer;
1182
1183 else
1184 Write_Statement_Buffer;
1185 WBI (" (argc : Integer;");
1186 WBI (" argv : System.Address;");
1187 WBI (" envp : System.Address)");
1188 WBI (" return Integer");
1189 WBI (" is");
1190 end if;
1191
1192 -- Initialize and Finalize are not used in No_Run_Time mode
1193
1194 if not No_Run_Time_Specified then
1195 WBI (" procedure initialize;");
1196 WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
1197 WBI ("");
1198 WBI (" procedure finalize;");
1199 WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
1200 WBI ("");
1201 end if;
1202
1203 -- Deal with declarations for main program case
1204
1205 if not No_Main_Subprogram then
1206
1207 -- To call the main program, we declare it using a pragma Import
1208 -- Ada with the right link name.
1209
1210 -- It might seem more obvious to "with" the main program, and call
1211 -- it in the normal Ada manner. We do not do this for three reasons:
1212
1213 -- 1. It is more efficient not to recompile the main program
1214 -- 2. We are not entitled to assume the source is accessible
1215 -- 3. We don't know what options to use to compile it
1216
1217 -- It is really reason 3 that is most critical (indeed we used
1218 -- to generate the "with", but several regression tests failed).
1219
1220 WBI ("");
1221
1222 if ALIs.Table (ALIs.First).Main_Program = Func then
1223 WBI (" Result : Integer;");
1224 WBI ("");
1225 WBI (" function Ada_Main_Program return Integer;");
1226
1227 else
1228 WBI (" procedure Ada_Main_Program;");
1229 end if;
1230
1231 Set_String (" pragma Import (Ada, Ada_Main_Program, """);
1232 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1233 Set_Main_Program_Name;
1234 Set_String (""");");
1235
1236 Write_Statement_Buffer;
1237 WBI ("");
1238 end if;
1239
1240 WBI (" begin");
1241
1242 -- On VxWorks, there are no command line arguments
1243
1244 if VxWorks_Target then
1245 WBI (" gnat_argc := 0;");
1246 WBI (" gnat_argv := System.Null_Address;");
1247 WBI (" gnat_envp := System.Null_Address;");
1248
1249 -- Normal case of command line arguments present
1250
1251 else
1252 WBI (" gnat_argc := argc;");
1253 WBI (" gnat_argv := argv;");
1254 WBI (" gnat_envp := envp;");
1255 WBI ("");
1256 end if;
1257
1258 if not No_Run_Time_Specified then
1259 WBI (" Initialize;");
1260 end if;
1261
1262 WBI (" " & Ada_Init_Name.all & ";");
1263
1264 if not No_Main_Subprogram then
1265 WBI (" Break_Start;");
1266
1267 if ALIs.Table (ALIs.First).Main_Program = Proc then
1268 WBI (" Ada_Main_Program;");
1269 else
1270 WBI (" Result := Ada_Main_Program;");
1271 end if;
1272 end if;
1273
1274 -- Adafinal is only called if we have a run time
1275
1276 if not No_Run_Time_Specified then
1277
1278 -- If compiling for the JVM, we directly call Adafinal because
1279 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1280
1281 if Hostparm.Java_VM then
1282 WBI (" System.Standard_Library.Adafinal;");
1283 else
1284 WBI (" Do_Finalize;");
1285 end if;
1286 end if;
1287
1288 -- Finalize is only called if we have a run time
1289
1290 if not No_Run_Time_Specified then
1291 WBI (" Finalize;");
1292 end if;
1293
1294 -- Return result
1295
1296 if No_Main_Subprogram
1297 or else ALIs.Table (ALIs.First).Main_Program = Proc
1298 then
1299 WBI (" return (gnat_exit_status);");
1300 else
1301 WBI (" return (Result);");
1302 end if;
1303
1304 WBI (" end;");
1305 end Gen_Main_Ada;
1306
1307 ----------------
1308 -- Gen_Main_C --
1309 ----------------
1310
1311 procedure Gen_Main_C is
1312 Target : constant String_Ptr := Target_Name;
1313 VxWorks_Target : constant Boolean :=
1314 Target (Target'Last - 7 .. Target'Last) = "vxworks/";
1315
1316 begin
1317 Set_String ("int ");
1318 Set_String (Get_Main_Name);
1319
1320 -- On VxWorks, there are no command line arguments
1321
1322 if VxWorks_Target then
1323 Set_String (" ()");
1324
1325 -- Normal case with command line arguments present
1326
1327 else
1328 Set_String (" (argc, argv, envp)");
1329 end if;
1330
1331 Write_Statement_Buffer;
1332
1333 -- VxWorks doesn't have the notion of argc/argv
1334
1335 if VxWorks_Target then
1336 WBI ("{");
1337 WBI (" int result;");
1338 WBI (" gnat_argc = 0;");
1339 WBI (" gnat_argv = 0;");
1340 WBI (" gnat_envp = 0;");
1341
1342 -- Normal case of arguments present
1343
1344 else
1345 WBI (" int argc;");
1346 WBI (" char **argv;");
1347 WBI (" char **envp;");
1348 WBI ("{");
1349
1350 if ALIs.Table (ALIs.First).Main_Program = Func then
1351 WBI (" int result;");
1352 end if;
1353
1354 WBI (" gnat_argc = argc;");
1355 WBI (" gnat_argv = argv;");
1356 WBI (" gnat_envp = envp;");
1357 WBI (" ");
1358 end if;
1359
1360 -- The __gnat_initialize routine is used only if we have a run-time
1361
1362 if not No_Run_Time_Specified then
1363 WBI
1364 (" __gnat_initialize ();");
1365 end if;
1366
1367 WBI (" " & Ada_Init_Name.all & " ();");
1368
1369 if not No_Main_Subprogram then
1370
1371 WBI (" __gnat_break_start ();");
1372 WBI (" ");
1373
1374 -- Output main program name
1375
1376 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1377
1378 -- Main program is procedure case
1379
1380 if ALIs.Table (ALIs.First).Main_Program = Proc then
1381 Set_String (" ");
1382 Set_Main_Program_Name;
1383 Set_String (" ();");
1384 Write_Statement_Buffer;
1385
1386 -- Main program is function case
1387
1388 else -- ALIs.Table (ALIs_First).Main_Program = Func
1389 Set_String (" result = ");
1390 Set_Main_Program_Name;
1391 Set_String (" ();");
1392 Write_Statement_Buffer;
1393 end if;
1394
1395 end if;
1396
1397 -- Adafinal is called only when we have a run-time
1398
1399 if not No_Run_Time_Specified then
1400 WBI (" ");
1401 WBI (" system__standard_library__adafinal ();");
1402 end if;
1403
1404 -- The finalize routine is used only if we have a run-time
1405
1406 if not No_Run_Time_Specified then
1407 WBI (" __gnat_finalize ();");
1408 end if;
1409
1410 if ALIs.Table (ALIs.First).Main_Program = Func then
1411
1412 if Hostparm.OpenVMS then
1413
1414 -- VMS must use the Posix exit routine in order to get an
1415 -- Unix compatible exit status.
1416
1417 WBI (" __posix_exit (result);");
1418
1419 else
1420 WBI (" exit (result);");
1421 end if;
1422
1423 else
1424
1425 if Hostparm.OpenVMS then
1426 -- VMS must use the Posix exit routine in order to get an
1427 -- Unix compatible exit status.
1428 WBI (" __posix_exit (gnat_exit_status);");
1429 else
1430 WBI (" exit (gnat_exit_status);");
1431 end if;
1432 end if;
1433
1434 WBI ("}");
1435 end Gen_Main_C;
1436
1437 ------------------------------
1438 -- Gen_Object_Files_Options --
1439 ------------------------------
1440
1441 procedure Gen_Object_Files_Options is
1442 Lgnat : Integer;
1443
1444 procedure Write_Linker_Option;
1445 -- Write binder info linker option.
1446
1447 -------------------------
1448 -- Write_Linker_Option --
1449 -------------------------
1450
1451 procedure Write_Linker_Option is
1452 Start : Natural;
1453 Stop : Natural;
1454
1455 begin
1456 -- Loop through string, breaking at null's
1457
1458 Start := 1;
1459 while Start < Name_Len loop
1460
1461 -- Find null ending this section
1462
1463 Stop := Start + 1;
1464 while Name_Buffer (Stop) /= ASCII.NUL
1465 and then Stop <= Name_Len loop
1466 Stop := Stop + 1;
1467 end loop;
1468
1469 -- Process section if non-null
1470
1471 if Stop > Start then
1472 if Output_Linker_Option_List then
1473 Write_Str (Name_Buffer (Start .. Stop - 1));
1474 Write_Eol;
1475 end if;
1476 Write_Info_Ada_C
1477 (" -- ", "", Name_Buffer (Start .. Stop - 1));
1478 end if;
1479
1480 Start := Stop + 1;
1481 end loop;
1482 end Write_Linker_Option;
1483
1484 -- Start of processing for Gen_Object_Files_Options
1485
1486 begin
1487 WBI ("");
1488 Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list");
1489
1490 for E in Elab_Order.First .. Elab_Order.Last loop
1491
1492 -- If not spec that has an associated body, then generate a
1493 -- comment giving the name of the corresponding object file.
1494
1495 if Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec then
1496 Get_Name_String
1497 (ALIs.Table
1498 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
1499
1500 -- If the presence of an object file is necessary or if it
1501 -- exists, then use it.
1502
1503 if not Hostparm.Exclude_Missing_Objects
1504 or else
1505 GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
1506 then
1507 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
1508 if Output_Object_List then
1509 Write_Str (Name_Buffer (1 .. Name_Len));
1510 Write_Eol;
1511 end if;
1512
1513 -- Don't link with the shared library on VMS if an internal
1514 -- filename object is seen. Multiply defined symbols will
1515 -- result.
1516
1517 if Hostparm.OpenVMS
1518 and then Is_Internal_File_Name
1519 (ALIs.Table
1520 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
1521 then
1522 Opt.Shared_Libgnat := False;
1523 end if;
1524
1525 end if;
1526 end if;
1527 end loop;
1528
1529 -- Add a "-Ldir" for each directory in the object path. We skip this
1530 -- in No_Run_Time mode, where we want more precise control of exactly
1531 -- what goes into the resulting object file
1532
1533 if not No_Run_Time_Specified then
1534 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
1535 declare
1536 Dir : String_Ptr := Dir_In_Obj_Search_Path (J);
1537
1538 begin
1539 Name_Len := 0;
1540 Add_Str_To_Name_Buffer ("-L");
1541 Add_Str_To_Name_Buffer (Dir.all);
1542 Write_Linker_Option;
1543 end;
1544 end loop;
1545 end if;
1546
1547 -- Sort linker options
1548
1549 Sort (Linker_Options.Last, Move_Linker_Option'Access,
1550 Lt_Linker_Option'Access);
1551
1552 -- Write user linker options
1553
1554 Lgnat := Linker_Options.Last + 1;
1555
1556 for J in 1 .. Linker_Options.Last loop
1557 if not Linker_Options.Table (J).Internal_File then
1558 Get_Name_String (Linker_Options.Table (J).Name);
1559 Write_Linker_Option;
1560 else
1561 Lgnat := J;
1562 exit;
1563 end if;
1564 end loop;
1565
1566 if not (No_Run_Time_Specified or else Opt.No_Stdlib) then
1567
1568 Name_Len := 0;
1569
1570 if Opt.Shared_Libgnat then
1571 Add_Str_To_Name_Buffer ("-shared");
1572 else
1573 Add_Str_To_Name_Buffer ("-static");
1574 end if;
1575
1576 -- Write directly to avoid -K output.
1577
1578 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
1579
1580 if With_DECGNAT then
1581 Name_Len := 0;
1582 Add_Str_To_Name_Buffer ("-ldecgnat");
1583 Write_Linker_Option;
1584 end if;
1585
1586 if With_GNARL then
1587 Name_Len := 0;
1588 Add_Str_To_Name_Buffer ("-lgnarl");
1589 Write_Linker_Option;
1590 end if;
1591
1592 Name_Len := 0;
1593 Add_Str_To_Name_Buffer ("-lgnat");
1594 Write_Linker_Option;
1595
1596 end if;
1597
1598 -- Write internal linker options
1599
1600 for J in Lgnat .. Linker_Options.Last loop
1601 Get_Name_String (Linker_Options.Table (J).Name);
1602 Write_Linker_Option;
1603 end loop;
1604
1605 if Ada_Bind_File then
1606 WBI ("-- END Object file/option list ");
1607 else
1608 WBI (" END Object file/option list */");
1609 end if;
1610
1611 end Gen_Object_Files_Options;
1612
1613 ---------------------
1614 -- Gen_Output_File --
1615 ---------------------
1616
1617 procedure Gen_Output_File (Filename : String) is
1618
1619 -- Start of processing for Gen_Output_File
1620
1621 begin
1622 -- Override Ada_Bind_File and Bind_Main_Program for Java since
1623 -- JGNAT only supports Ada code, and the main program is already
1624 -- generated by the compiler.
1625
1626 if Hostparm.Java_VM then
1627 Ada_Bind_File := True;
1628 Bind_Main_Program := False;
1629 end if;
1630
1631 -- Override time slice value if -T switch is set
1632
1633 if Time_Slice_Set then
1634 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
1635 end if;
1636
1637 -- Count number of elaboration calls
1638
1639 for E in Elab_Order.First .. Elab_Order.Last loop
1640 if Units.Table (Elab_Order.Table (E)).No_Elab then
1641 null;
1642 else
1643 Num_Elab_Calls := Num_Elab_Calls + 1;
1644 end if;
1645 end loop;
1646
1647 -- Generate output file in appropriate language
1648
1649 if Ada_Bind_File then
1650 Gen_Output_File_Ada (Filename);
1651 else
1652 Gen_Output_File_C (Filename);
1653 end if;
1654
1655 end Gen_Output_File;
1656
1657 -------------------------
1658 -- Gen_Output_File_Ada --
1659 -------------------------
1660
1661 procedure Gen_Output_File_Ada (Filename : String) is
1662
1663 Bfiles : Name_Id;
1664 -- Name of generated bind file (spec)
1665
1666 Bfileb : Name_Id;
1667 -- Name of generated bind file (body)
1668
1669 Ada_Main : constant String := Get_Ada_Main_Name;
1670 -- Name to be used for generated Ada main program. See the body of
1671 -- function Get_Ada_Main_Name for details on the form of the name.
1672
1673 Target : constant String_Ptr := Target_Name;
1674 VxWorks_Target : constant Boolean :=
1675 Target (Target'Last - 7 .. Target'Last) = "vxworks/";
1676
1677 begin
1678 -- Create spec first
1679
1680 Create_Binder_Output (Filename, 's', Bfiles);
1681
1682 if No_Run_Time_Specified then
1683 WBI ("pragma No_Run_Time;");
1684 end if;
1685
1686 -- Generate with of System so we can reference System.Address, note
1687 -- that such a reference is safe even in No_Run_Time mode, since we
1688 -- do not need any run-time code for such a reference, and we output
1689 -- a pragma No_Run_Time for this compilation above.
1690
1691 WBI ("with System;");
1692
1693 -- Generate with of System.Initialize_Scalars if active
1694
1695 if Initialize_Scalars_Used then
1696 WBI ("with System.Scalar_Values;");
1697 end if;
1698
1699 Resolve_Binder_Options;
1700
1701 if not No_Run_Time_Specified then
1702
1703 -- Usually, adafinal is called using a pragma Import C. Since
1704 -- Import C doesn't have the same semantics for JGNAT, we use
1705 -- standard Ada.
1706
1707 if Hostparm.Java_VM then
1708 WBI ("with System.Standard_Library;");
1709 end if;
1710 end if;
1711
1712 WBI ("package " & Ada_Main & " is");
1713
1714 -- Main program case
1715
1716 if Bind_Main_Program then
1717
1718 -- Generate argc/argv stuff
1719
1720 WBI ("");
1721 WBI (" gnat_argc : Integer;");
1722 WBI (" gnat_argv : System.Address;");
1723 WBI (" gnat_envp : System.Address;");
1724
1725 -- If we have a run time present, these variables are in the
1726 -- runtime data area for easy access from the runtime
1727
1728 if not No_Run_Time_Specified then
1729 WBI ("");
1730 WBI (" pragma Import (C, gnat_argc);");
1731 WBI (" pragma Import (C, gnat_argv);");
1732 WBI (" pragma Import (C, gnat_envp);");
1733 end if;
1734
1735 -- Define exit status. Again in normal mode, this is in the
1736 -- run-time library, and is initialized there, but in the no
1737 -- run time case, the variable is here and initialized here.
1738
1739 WBI ("");
1740
1741 if No_Run_Time_Specified then
1742 WBI (" gnat_exit_status : Integer := 0;");
1743 else
1744 WBI (" gnat_exit_status : Integer;");
1745 WBI (" pragma Import (C, gnat_exit_status);");
1746 end if;
1747 end if;
1748
1749 -- Generate the GNAT_Version and Ada_Main_Program_name info only for
1750 -- the main program. Otherwise, it can lead under some circumstances
1751 -- to a symbol duplication during the link (for instance when a
1752 -- C program uses 2 Ada libraries)
1753
1754 if Bind_Main_Program then
1755 WBI ("");
1756 WBI (" GNAT_Version : constant String :=");
1757 WBI (" ""GNAT Version: " &
1758 Gnat_Version_String & """;");
1759 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
1760
1761 WBI ("");
1762 Set_String (" Ada_Main_Program_Name : constant String := """);
1763 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1764 Set_Main_Program_Name;
1765 Set_String (""" & Ascii.NUL;");
1766 Write_Statement_Buffer;
1767
1768 WBI
1769 (" pragma Export (C, Ada_Main_Program_Name, " &
1770 """__gnat_ada_main_program_name"");");
1771 end if;
1772
1773 -- No need to generate a finalization routine if there is no
1774 -- runtime, since there is nothing to do in this case.
1775
1776 if not No_Run_Time_Specified then
1777 WBI ("");
1778 WBI (" procedure " & Ada_Final_Name.all & ";");
1779 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
1780 Ada_Final_Name.all & """);");
1781 end if;
1782
1783 WBI ("");
1784 WBI (" procedure " & Ada_Init_Name.all & ";");
1785 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
1786 Ada_Init_Name.all & """);");
1787
1788 if Bind_Main_Program then
1789
1790 -- If we have a run time, then Break_Start is defined there, but
1791 -- if there is no run-time, Break_Start is defined in this file.
1792
1793 WBI ("");
1794 WBI (" procedure Break_Start;");
1795
1796 if No_Run_Time_Specified then
1797 WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
1798 else
1799 WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
1800 end if;
1801
1802 WBI ("");
1803 WBI (" function " & Get_Main_Name);
1804
1805 -- Generate argument list (except on VxWorks, where none is present)
1806
1807 if not VxWorks_Target then
1808 WBI (" (argc : Integer;");
1809 WBI (" argv : System.Address;");
1810 WBI (" envp : System.Address)");
1811 end if;
1812
1813 WBI (" return Integer;");
1814 WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
1815 Get_Main_Name & """);");
1816 end if;
1817
1818 if Initialize_Scalars_Used then
1819 Gen_Scalar_Values;
1820 end if;
1821
1822 Gen_Versions_Ada;
1823 Gen_Elab_Order_Ada;
1824
1825 -- Spec is complete
1826
1827 WBI ("");
1828 WBI ("end " & Ada_Main & ";");
1829 Close_Binder_Output;
1830
1831 -- Prepare to write body
1832
1833 Create_Binder_Output (Filename, 'b', Bfileb);
1834
1835 -- Output Source_File_Name pragmas which look like
1836
1837 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
1838 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
1839
1840 -- where sss/bbb are the spec/body file names respectively
1841
1842 Get_Name_String (Bfiles);
1843 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
1844
1845 WBI ("pragma Source_File_Name (" &
1846 Ada_Main &
1847 ", Spec_File_Name => """ &
1848 Name_Buffer (1 .. Name_Len + 3));
1849
1850 Get_Name_String (Bfileb);
1851 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
1852
1853 WBI ("pragma Source_File_Name (" &
1854 Ada_Main &
1855 ", Body_File_Name => """ &
1856 Name_Buffer (1 .. Name_Len + 3));
1857
1858 WBI ("");
1859 WBI ("package body " & Ada_Main & " is");
1860
1861 -- Import the finalization procedure only if there is a runtime.
1862
1863 if not No_Run_Time_Specified then
1864
1865 -- In the Java case, pragma Import C cannot be used, so the
1866 -- standard Ada constructs will be used instead.
1867
1868 if not Hostparm.Java_VM then
1869 WBI ("");
1870 WBI (" procedure Do_Finalize;");
1871 WBI
1872 (" pragma Import (C, Do_Finalize, " &
1873 """system__standard_library__adafinal"");");
1874 WBI ("");
1875 end if;
1876 end if;
1877
1878 Gen_Adainit_Ada;
1879
1880 -- No need to generate a finalization routine if there is no
1881 -- runtime, since there is nothing to do in this case.
1882
1883 if not No_Run_Time_Specified then
1884 Gen_Adafinal_Ada;
1885 end if;
1886
1887 if Bind_Main_Program then
1888
1889 -- In No_Run_Time mode, generate dummy body for Break_Start
1890
1891 if No_Run_Time_Specified then
1892 WBI ("");
1893 WBI (" procedure Break_Start is");
1894 WBI (" begin");
1895 WBI (" null;");
1896 WBI (" end;");
1897 end if;
1898
1899 Gen_Main_Ada;
1900 end if;
1901
1902 -- Output object file list and the Ada body is complete
1903
1904 Gen_Object_Files_Options;
1905
1906 WBI ("");
1907 WBI ("end " & Ada_Main & ";");
1908
1909 Close_Binder_Output;
1910 end Gen_Output_File_Ada;
1911
1912 -----------------------
1913 -- Gen_Output_File_C --
1914 -----------------------
1915
1916 procedure Gen_Output_File_C (Filename : String) is
1917
1918 Bfile : Name_Id;
1919 -- Name of generated bind file
1920
1921 begin
1922 Create_Binder_Output (Filename, 'c', Bfile);
1923
1924 Resolve_Binder_Options;
1925
1926 WBI ("#ifdef __STDC__");
1927 WBI ("#define PARAMS(paramlist) paramlist");
1928 WBI ("#else");
1929 WBI ("#define PARAMS(paramlist) ()");
1930 WBI ("#endif");
1931 WBI ("");
1932
1933 WBI ("extern void __gnat_set_globals ");
1934 WBI (" PARAMS ((int, int, int, int, int, int, ");
1935 WBI (" void (*) PARAMS ((void)), int, int));");
1936 WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));");
1937 WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));");
1938
1939 WBI ("extern void system__standard_library__adafinal PARAMS ((void));");
1940
1941 if not No_Main_Subprogram then
1942 WBI ("extern int main PARAMS ((int, char **, char **));");
1943 if Hostparm.OpenVMS then
1944 WBI ("extern void __posix_exit PARAMS ((int));");
1945 else
1946 WBI ("extern void exit PARAMS ((int));");
1947 end if;
1948
1949 WBI ("extern void __gnat_break_start PARAMS ((void));");
1950 Set_String ("extern ");
1951
1952 if ALIs.Table (ALIs.First).Main_Program = Proc then
1953 Set_String ("void ");
1954 else
1955 Set_String ("int ");
1956 end if;
1957
1958 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1959 Set_Main_Program_Name;
1960 Set_String (" PARAMS ((void));");
1961 Write_Statement_Buffer;
1962 end if;
1963
1964 if not No_Run_Time_Specified then
1965 WBI ("extern void __gnat_initialize PARAMS ((void));");
1966 WBI ("extern void __gnat_finalize PARAMS ((void));");
1967 WBI ("extern void __gnat_install_handler PARAMS ((void));");
1968 end if;
1969
1970 WBI ("");
1971
1972 Gen_Elab_Defs_C;
1973
1974 -- Imported variable used to track elaboration/finalization phase.
1975 -- Used only when we have a runtime.
1976
1977 if not No_Run_Time_Specified then
1978 WBI ("extern int __gnat_handler_installed;");
1979 WBI ("");
1980 end if;
1981
1982 -- Write argv/argc stuff if main program case
1983
1984 if Bind_Main_Program then
1985
1986 -- In the normal case, these are in the runtime library
1987
1988 if not No_Run_Time_Specified then
1989 WBI ("extern int gnat_argc;");
1990 WBI ("extern char **gnat_argv;");
1991 WBI ("extern char **gnat_envp;");
1992 WBI ("extern int gnat_exit_status;");
1993
1994 -- In the No_Run_Time case, they are right in the binder file
1995 -- and we initialize gnat_exit_status in the declaration.
1996
1997 else
1998 WBI ("int gnat_argc;");
1999 WBI ("char **gnat_argv;");
2000 WBI ("char **gnat_envp;");
2001 WBI ("int gnat_exit_status = 0;");
2002 end if;
2003
2004 WBI ("");
2005 end if;
2006
2007 -- In no run-time mode, the __gnat_break_start routine (for the
2008 -- debugger to get initial control) is defined in this file.
2009
2010 if No_Run_Time_Specified then
2011 WBI ("");
2012 WBI ("void __gnat_break_start () {}");
2013 end if;
2014
2015 -- Generate the __gnat_version and __gnat_ada_main_program_name info
2016 -- only for the main program. Otherwise, it can lead under some
2017 -- circumstances to a symbol duplication during the link (for instance
2018 -- when a C program uses 2 Ada libraries)
2019
2020 if Bind_Main_Program then
2021 WBI ("");
2022 WBI ("char __gnat_version[] = ""GNAT Version: " &
2023 Gnat_Version_String & """;");
2024
2025 Set_String ("char __gnat_ada_main_program_name[] = """);
2026 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2027 Set_Main_Program_Name;
2028 Set_String (""";");
2029 Write_Statement_Buffer;
2030 end if;
2031
2032 -- Generate the adafinal routine. In no runtime mode, this is
2033 -- not needed, since there is no finalization to do.
2034
2035 if not No_Run_Time_Specified then
2036 Gen_Adafinal_C;
2037 end if;
2038
2039 Gen_Adainit_C;
2040
2041 -- Main is only present for Ada main case
2042
2043 if Bind_Main_Program then
2044 Gen_Main_C;
2045 end if;
2046
2047 -- Scalar values, versions and object files needed in both cases
2048
2049 if Initialize_Scalars_Used then
2050 Gen_Scalar_Values;
2051 end if;
2052
2053 Gen_Versions_C;
2054 Gen_Elab_Order_C;
2055 Gen_Object_Files_Options;
2056
2057 -- C binder output is complete
2058
2059 Close_Binder_Output;
2060 end Gen_Output_File_C;
2061
2062 -----------------------
2063 -- Gen_Scalar_Values --
2064 -----------------------
2065
2066 procedure Gen_Scalar_Values is
2067
2068 -- Strings to hold hex values of initialization constants. Note that
2069 -- we store these strings in big endian order, but they are actually
2070 -- used to initialize integer values, so the actual generated data
2071 -- will automaticaly have the right endianess.
2072
2073 IS_Is1 : String (1 .. 2);
2074 IS_Is2 : String (1 .. 4);
2075 IS_Is4 : String (1 .. 8);
2076 IS_Is8 : String (1 .. 16);
2077 IS_Iu1 : String (1 .. 2);
2078 IS_Iu2 : String (1 .. 4);
2079 IS_Iu4 : String (1 .. 8);
2080 IS_Iu8 : String (1 .. 16);
2081 IS_Isf : String (1 .. 8);
2082 IS_Ifl : String (1 .. 8);
2083 IS_Ilf : String (1 .. 16);
2084
2085 -- The string for Long_Long_Float is special. This is used only on the
2086 -- ia32 with 80-bit extended float (stored in 96 bits by gcc). The
2087 -- value here is represented little-endian, since that's the only way
2088 -- it is ever generated (this is not used on big-endian machines.
2089
2090 IS_Ill : String (1 .. 24);
2091
2092 begin
2093 -- -Sin (invalid values)
2094
2095 if Opt.Initialize_Scalars_Mode = 'I' then
2096 IS_Is1 := "80";
2097 IS_Is2 := "8000";
2098 IS_Is4 := "80000000";
2099 IS_Is8 := "8000000000000000";
2100 IS_Iu1 := "FF";
2101 IS_Iu2 := "FFFF";
2102 IS_Iu4 := "FFFFFFFF";
2103 IS_Iu8 := "FFFFFFFFFFFFFFFF";
2104 IS_Isf := IS_Iu4;
2105 IS_Ifl := IS_Iu4;
2106 IS_Ilf := IS_Iu8;
2107 IS_Ill := "00000000000000C0FFFF0000";
2108
2109 -- -Slo (low values)
2110
2111 elsif Opt.Initialize_Scalars_Mode = 'L' then
2112 IS_Is1 := "80";
2113 IS_Is2 := "8000";
2114 IS_Is4 := "80000000";
2115 IS_Is8 := "8000000000000000";
2116 IS_Iu1 := "00";
2117 IS_Iu2 := "0000";
2118 IS_Iu4 := "00000000";
2119 IS_Iu8 := "0000000000000000";
2120 IS_Isf := "FF800000";
2121 IS_Ifl := IS_Isf;
2122 IS_Ilf := "FFF0000000000000";
2123 IS_Ill := "0000000000000080FFFF0000";
2124
2125 -- -Shi (high values)
2126
2127 elsif Opt.Initialize_Scalars_Mode = 'H' then
2128 IS_Is1 := "7F";
2129 IS_Is2 := "7FFF";
2130 IS_Is4 := "7FFFFFFF";
2131 IS_Is8 := "7FFFFFFFFFFFFFFF";
2132 IS_Iu1 := "FF";
2133 IS_Iu2 := "FFFF";
2134 IS_Iu4 := "FFFFFFFF";
2135 IS_Iu8 := "FFFFFFFFFFFFFFFF";
2136 IS_Isf := "7F800000";
2137 IS_Ifl := IS_Isf;
2138 IS_Ilf := "7FF0000000000000";
2139 IS_Ill := "0000000000000080FF7F0000";
2140
2141 -- -Shh (hex byte)
2142
2143 else pragma Assert (Opt.Initialize_Scalars_Mode = 'X');
2144 IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val;
2145 IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val;
2146 IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val;
2147
2148 for J in 1 .. 4 loop
2149 IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
2150 end loop;
2151
2152 for J in 1 .. 8 loop
2153 IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
2154 end loop;
2155
2156 IS_Iu1 := IS_Is1;
2157 IS_Iu2 := IS_Is2;
2158 IS_Iu4 := IS_Is4;
2159 IS_Iu8 := IS_Is8;
2160
2161 IS_Isf := IS_Is4;
2162 IS_Ifl := IS_Is4;
2163 IS_Ilf := IS_Is8;
2164
2165 for J in 1 .. 12 loop
2166 IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
2167 end loop;
2168 end if;
2169
2170 -- Generate output, Ada case
2171
2172 if Ada_Bind_File then
2173 WBI ("");
2174
2175 Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#");
2176 Set_String (IS_Is1);
2177 Write_Statement_Buffer ("#;");
2178
2179 Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#");
2180 Set_String (IS_Is2);
2181 Write_Statement_Buffer ("#;");
2182
2183 Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#");
2184 Set_String (IS_Is4);
2185 Write_Statement_Buffer ("#;");
2186
2187 Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#");
2188 Set_String (IS_Is8);
2189 Write_Statement_Buffer ("#;");
2190
2191 Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#");
2192 Set_String (IS_Iu1);
2193 Write_Statement_Buffer ("#;");
2194
2195 Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#");
2196 Set_String (IS_Iu2);
2197 Write_Statement_Buffer ("#;");
2198
2199 Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#");
2200 Set_String (IS_Iu4);
2201 Write_Statement_Buffer ("#;");
2202
2203 Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#");
2204 Set_String (IS_Iu8);
2205 Write_Statement_Buffer ("#;");
2206
2207 Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#");
2208 Set_String (IS_Isf);
2209 Write_Statement_Buffer ("#;");
2210
2211 Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#");
2212 Set_String (IS_Ifl);
2213 Write_Statement_Buffer ("#;");
2214
2215 Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#");
2216 Set_String (IS_Ilf);
2217 Write_Statement_Buffer ("#;");
2218
2219 -- Special case of Long_Long_Float. This is a 10-byte value used
2220 -- only on the x86. We could omit it for other architectures, but
2221 -- we don't easily have that kind of target specialization in the
2222 -- binder, and it's only 10 bytes, and only if -Sxx is used. Note
2223 -- that for architectures where Long_Long_Float is the same as
2224 -- Long_Float, the expander uses the Long_Float constant for the
2225 -- initializations of Long_Long_Float values.
2226
2227 WBI (" IS_Ill : constant array (1 .. 12) of");
2228 WBI (" System.Scalar_Values.Byte1 := (");
2229 Set_String (" ");
2230
2231 for J in 1 .. 6 loop
2232 Set_String (" 16#");
2233 Set_Char (IS_Ill (2 * J - 1));
2234 Set_Char (IS_Ill (2 * J));
2235 Set_String ("#,");
2236 end loop;
2237
2238 Write_Statement_Buffer;
2239 Set_String (" ");
2240
2241 for J in 7 .. 12 loop
2242 Set_String (" 16#");
2243 Set_Char (IS_Ill (2 * J - 1));
2244 Set_Char (IS_Ill (2 * J));
2245
2246 if J = 12 then
2247 Set_String ("#);");
2248 else
2249 Set_String ("#,");
2250 end if;
2251 end loop;
2252
2253 Write_Statement_Buffer;
2254
2255 -- Output export statements to export to System.Scalar_Values
2256
2257 WBI ("");
2258
2259 WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");");
2260 WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");");
2261 WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");");
2262 WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");");
2263 WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");");
2264 WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");");
2265 WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");");
2266 WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");");
2267 WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");");
2268 WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");");
2269 WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");");
2270 WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");");
2271
2272 -- Generate output C case
2273
2274 else
2275 -- The lines we generate in this case are of the form
2276 -- typ __gnat_I?? = 0x??;
2277 -- where typ is appropriate to the length
2278
2279 WBI ("");
2280
2281 Set_String ("unsigned char __gnat_Is1 = 0x");
2282 Set_String (IS_Is1);
2283 Write_Statement_Buffer (";");
2284
2285 Set_String ("unsigned short __gnat_Is2 = 0x");
2286 Set_String (IS_Is2);
2287 Write_Statement_Buffer (";");
2288
2289 Set_String ("unsigned __gnat_Is4 = 0x");
2290 Set_String (IS_Is4);
2291 Write_Statement_Buffer (";");
2292
2293 Set_String ("long long unsigned __gnat_Is8 = 0x");
2294 Set_String (IS_Is8);
2295 Write_Statement_Buffer ("LL;");
2296
2297 Set_String ("unsigned char __gnat_Iu1 = 0x");
2298 Set_String (IS_Is1);
2299 Write_Statement_Buffer (";");
2300
2301 Set_String ("unsigned short __gnat_Iu2 = 0x");
2302 Set_String (IS_Is2);
2303 Write_Statement_Buffer (";");
2304
2305 Set_String ("unsigned __gnat_Iu4 = 0x");
2306 Set_String (IS_Is4);
2307 Write_Statement_Buffer (";");
2308
2309 Set_String ("long long unsigned __gnat_Iu8 = 0x");
2310 Set_String (IS_Is8);
2311 Write_Statement_Buffer ("LL;");
2312
2313 Set_String ("unsigned __gnat_Isf = 0x");
2314 Set_String (IS_Isf);
2315 Write_Statement_Buffer (";");
2316
2317 Set_String ("unsigned __gnat_Ifl = 0x");
2318 Set_String (IS_Ifl);
2319 Write_Statement_Buffer (";");
2320
2321 Set_String ("long long unsigned __gnat_Ilf = 0x");
2322 Set_String (IS_Ilf);
2323 Write_Statement_Buffer ("LL;");
2324
2325 -- For Long_Long_Float, we generate
2326 -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??,
2327 -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??);
2328
2329 Set_String ("unsigned char __gnat_Ill[12] = {");
2330
2331 for J in 1 .. 6 loop
2332 Set_String ("0x");
2333 Set_Char (IS_Ill (2 * J - 1));
2334 Set_Char (IS_Ill (2 * J));
2335 Set_String (", ");
2336 end loop;
2337
2338 Write_Statement_Buffer;
2339 Set_String (" ");
2340
2341 for J in 7 .. 12 loop
2342 Set_String ("0x");
2343 Set_Char (IS_Ill (2 * J - 1));
2344 Set_Char (IS_Ill (2 * J));
2345
2346 if J = 12 then
2347 Set_String ("};");
2348 else
2349 Set_String (", ");
2350 end if;
2351 end loop;
2352
2353 Write_Statement_Buffer;
2354 end if;
2355 end Gen_Scalar_Values;
2356
2357 ----------------------
2358 -- Gen_Versions_Ada --
2359 ----------------------
2360
2361 -- This routine generates two sets of lines. The first set has the form:
2362
2363 -- unnnnn : constant Integer := 16#hhhhhhhh#;
2364
2365 -- The second set has the form
2366
2367 -- pragma Export (C, unnnnn, unam);
2368
2369 -- for each unit, where unam is the unit name suffixed by either B or
2370 -- S for body or spec, with dots replaced by double underscores, and
2371 -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
2372
2373 procedure Gen_Versions_Ada is
2374 Ubuf : String (1 .. 6) := "u00000";
2375
2376 procedure Increment_Ubuf;
2377 -- Little procedure to increment the serial number
2378
2379 procedure Increment_Ubuf is
2380 begin
2381 for J in reverse Ubuf'Range loop
2382 Ubuf (J) := Character'Succ (Ubuf (J));
2383 exit when Ubuf (J) <= '9';
2384 Ubuf (J) := '0';
2385 end loop;
2386 end Increment_Ubuf;
2387
2388 -- Start of processing for Gen_Versions_Ada
2389
2390 begin
2391 if Bind_For_Library then
2392
2393 -- When building libraries, the version number of each unit can
2394 -- not be computed, since the binder does not know the full list
2395 -- of units. Therefore, the 'Version and 'Body_Version
2396 -- attributes can not supported in this case.
2397
2398 return;
2399 end if;
2400
2401 WBI ("");
2402
2403 WBI (" type Version_32 is mod 2 ** 32;");
2404 for U in Units.First .. Units.Last loop
2405 Increment_Ubuf;
2406 WBI (" " & Ubuf & " : constant Version_32 := 16#" &
2407 Units.Table (U).Version & "#;");
2408 end loop;
2409
2410 WBI ("");
2411 Ubuf := "u00000";
2412
2413 for U in Units.First .. Units.Last loop
2414 Increment_Ubuf;
2415 Set_String (" pragma Export (C, ");
2416 Set_String (Ubuf);
2417 Set_String (", """);
2418
2419 Get_Name_String (Units.Table (U).Uname);
2420
2421 for K in 1 .. Name_Len loop
2422 if Name_Buffer (K) = '.' then
2423 Set_Char ('_');
2424 Set_Char ('_');
2425
2426 elsif Name_Buffer (K) = '%' then
2427 exit;
2428
2429 else
2430 Set_Char (Name_Buffer (K));
2431 end if;
2432 end loop;
2433
2434 if Name_Buffer (Name_Len) = 's' then
2435 Set_Char ('S');
2436 else
2437 Set_Char ('B');
2438 end if;
2439
2440 Set_String (""");");
2441 Write_Statement_Buffer;
2442 end loop;
2443
2444 end Gen_Versions_Ada;
2445
2446 --------------------
2447 -- Gen_Versions_C --
2448 --------------------
2449
2450 -- This routine generates a line of the form:
2451
2452 -- unsigned unam = 0xhhhhhhhh;
2453
2454 -- for each unit, where unam is the unit name suffixed by either B or
2455 -- S for body or spec, with dots replaced by double underscores.
2456
2457 procedure Gen_Versions_C is
2458 begin
2459 if Bind_For_Library then
2460
2461 -- When building libraries, the version number of each unit can
2462 -- not be computed, since the binder does not know the full list
2463 -- of units. Therefore, the 'Version and 'Body_Version
2464 -- attributes can not supported.
2465
2466 return;
2467 end if;
2468
2469 for U in Units.First .. Units.Last loop
2470 Set_String ("unsigned ");
2471
2472 Get_Name_String (Units.Table (U).Uname);
2473
2474 for K in 1 .. Name_Len loop
2475 if Name_Buffer (K) = '.' then
2476 Set_String ("__");
2477
2478 elsif Name_Buffer (K) = '%' then
2479 exit;
2480
2481 else
2482 Set_Char (Name_Buffer (K));
2483 end if;
2484 end loop;
2485
2486 if Name_Buffer (Name_Len) = 's' then
2487 Set_Char ('S');
2488 else
2489 Set_Char ('B');
2490 end if;
2491
2492 Set_String (" = 0x");
2493 Set_String (Units.Table (U).Version);
2494 Set_Char (';');
2495 Write_Statement_Buffer;
2496 end loop;
2497
2498 end Gen_Versions_C;
2499
2500 -----------------------
2501 -- Get_Ada_Main_Name --
2502 -----------------------
2503
2504 function Get_Ada_Main_Name return String is
2505 Suffix : constant String := "_00";
2506 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
2507 Opt.Ada_Main_Name.all & Suffix;
2508 Nlen : Natural;
2509
2510 begin
2511 -- The main program generated by JGNAT expects a package called
2512 -- ada_<main procedure>.
2513
2514 if Hostparm.Java_VM then
2515 -- Get main program name
2516
2517 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2518
2519 -- Remove the %b
2520
2521 return "ada_" & Name_Buffer (1 .. Name_Len - 2);
2522 end if;
2523
2524 -- This loop tries the following possibilities in order
2525 -- <Ada_Main>
2526 -- <Ada_Main>_01
2527 -- <Ada_Main>_02
2528 -- ..
2529 -- <Ada_Main>_99
2530 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
2531 -- it is set to 'ada_main'.
2532
2533 for J in 0 .. 99 loop
2534 if J = 0 then
2535 Nlen := Name'Length - Suffix'Length;
2536 else
2537 Nlen := Name'Length;
2538 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
2539 Name (Name'Last - 1) :=
2540 Character'Val (J / 10 + Character'Pos ('0'));
2541 end if;
2542
2543 for K in ALIs.First .. ALIs.Last loop
2544 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
2545
2546 -- Get unit name, removing %b or %e at end
2547
2548 Get_Name_String (Units.Table (L).Uname);
2549 Name_Len := Name_Len - 2;
2550
2551 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
2552 goto Continue;
2553 end if;
2554 end loop;
2555 end loop;
2556
2557 return Name (1 .. Nlen);
2558
2559 <<Continue>>
2560 null;
2561 end loop;
2562
2563 -- If we fall through, just use a peculiar unlikely name
2564
2565 return ("Qwertyuiop");
2566 end Get_Ada_Main_Name;
2567
2568 -------------------
2569 -- Get_Main_Name --
2570 -------------------
2571
2572 function Get_Main_Name return String is
2573 Target : constant String_Ptr := Target_Name;
2574 VxWorks_Target : constant Boolean :=
2575 Target (Target'Last - 7 .. Target'Last) = "vxworks/";
2576
2577 begin
2578 -- Explicit name given with -M switch
2579
2580 if Bind_Alternate_Main_Name then
2581 return Alternate_Main_Name.all;
2582
2583 -- Case of main program name to be used directly
2584
2585 elsif VxWorks_Target then
2586
2587 -- Get main program name
2588
2589 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2590
2591 -- If this is a child name, return only the name of the child,
2592 -- since we can't have dots in a nested program name. Note that
2593 -- we do not include the %b at the end of the unit name.
2594
2595 for J in reverse 1 .. Name_Len - 3 loop
2596 if J = 1 or else Name_Buffer (J - 1) = '.' then
2597 return Name_Buffer (J .. Name_Len - 2);
2598 end if;
2599 end loop;
2600
2601 raise Program_Error; -- impossible exit
2602
2603 -- Case where "main" is to be used as default
2604
2605 else
2606 return "main";
2607 end if;
2608 end Get_Main_Name;
2609
2610 ----------------------
2611 -- Lt_Linker_Option --
2612 ----------------------
2613
2614 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
2615 begin
2616 if Linker_Options.Table (Op1).Internal_File
2617 /=
2618 Linker_Options.Table (Op2).Internal_File
2619 then
2620 return Linker_Options.Table (Op1).Internal_File
2621 <
2622 Linker_Options.Table (Op2).Internal_File;
2623 else
2624 if Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2625 /=
2626 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position
2627 then
2628 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2629 >
2630 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
2631
2632 else
2633 return Linker_Options.Table (Op1).Original_Pos
2634 <
2635 Linker_Options.Table (Op2).Original_Pos;
2636 end if;
2637 end if;
2638 end Lt_Linker_Option;
2639
2640 ------------------------
2641 -- Move_Linker_Option --
2642 ------------------------
2643
2644 procedure Move_Linker_Option (From : Natural; To : Natural) is
2645 begin
2646 Linker_Options.Table (To) := Linker_Options.Table (From);
2647 end Move_Linker_Option;
2648
2649 ----------------------------
2650 -- Resolve_Binder_Options --
2651 ----------------------------
2652
2653 procedure Resolve_Binder_Options is
2654 begin
2655 for E in Elab_Order.First .. Elab_Order.Last loop
2656 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
2657
2658 -- The procedure of looking for specific packages and setting
2659 -- flags is very wrong, but there isn't a good alternative at
2660 -- this time.
2661
2662 if Name_Buffer (1 .. 19) = "system.os_interface" then
2663 With_GNARL := True;
2664 end if;
2665
2666 if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then
2667 With_DECGNAT := True;
2668 end if;
2669 end loop;
2670 end Resolve_Binder_Options;
2671
2672 --------------
2673 -- Set_Char --
2674 --------------
2675
2676 procedure Set_Char (C : Character) is
2677 begin
2678 Last := Last + 1;
2679 Statement_Buffer (Last) := C;
2680 end Set_Char;
2681
2682 -------------
2683 -- Set_Int --
2684 -------------
2685
2686 procedure Set_Int (N : Int) is
2687 begin
2688 if N < 0 then
2689 Set_String ("-");
2690 Set_Int (-N);
2691
2692 else
2693 if N > 9 then
2694 Set_Int (N / 10);
2695 end if;
2696
2697 Last := Last + 1;
2698 Statement_Buffer (Last) :=
2699 Character'Val (N mod 10 + Character'Pos ('0'));
2700 end if;
2701 end Set_Int;
2702
2703 ---------------------------
2704 -- Set_Main_Program_Name --
2705 ---------------------------
2706
2707 procedure Set_Main_Program_Name is
2708 begin
2709 -- Note that name has %b on the end which we ignore
2710
2711 -- First we output the initial _ada_ since we know that the main
2712 -- program is a library level subprogram.
2713
2714 Set_String ("_ada_");
2715
2716 -- Copy name, changing dots to double underscores
2717
2718 for J in 1 .. Name_Len - 2 loop
2719 if Name_Buffer (J) = '.' then
2720 Set_String ("__");
2721 else
2722 Set_Char (Name_Buffer (J));
2723 end if;
2724 end loop;
2725 end Set_Main_Program_Name;
2726
2727 ---------------------
2728 -- Set_Name_Buffer --
2729 ---------------------
2730
2731 procedure Set_Name_Buffer is
2732 begin
2733 for J in 1 .. Name_Len loop
2734 Set_Char (Name_Buffer (J));
2735 end loop;
2736 end Set_Name_Buffer;
2737
2738 ----------------
2739 -- Set_String --
2740 ----------------
2741
2742 procedure Set_String (S : String) is
2743 begin
2744 Statement_Buffer (Last + 1 .. Last + S'Length) := S;
2745 Last := Last + S'Length;
2746 end Set_String;
2747
2748 -------------------
2749 -- Set_Unit_Name --
2750 -------------------
2751
2752 procedure Set_Unit_Name is
2753 begin
2754 for J in 1 .. Name_Len - 2 loop
2755 if Name_Buffer (J) /= '.' then
2756 Set_Char (Name_Buffer (J));
2757 else
2758 Set_String ("__");
2759 end if;
2760 end loop;
2761 end Set_Unit_Name;
2762
2763 ---------------------
2764 -- Set_Unit_Number --
2765 ---------------------
2766
2767 procedure Set_Unit_Number (U : Unit_Id) is
2768 Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First);
2769 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
2770
2771 begin
2772 if Num_Units >= 10 and then Unum < 10 then
2773 Set_Char ('0');
2774 end if;
2775
2776 if Num_Units >= 100 and then Unum < 100 then
2777 Set_Char ('0');
2778 end if;
2779
2780 Set_Int (Unum);
2781 end Set_Unit_Number;
2782
2783 ------------
2784 -- Tab_To --
2785 ------------
2786
2787 procedure Tab_To (N : Natural) is
2788 begin
2789 while Last < N loop
2790 Set_Char (' ');
2791 end loop;
2792 end Tab_To;
2793
2794 -----------
2795 -- Value --
2796 -----------
2797
2798 function Value (chars : chars_ptr) return String is
2799 function Strlen (chars : chars_ptr) return Natural;
2800 pragma Import (C, Strlen);
2801
2802 begin
2803 if chars = Null_Address then
2804 return "";
2805
2806 else
2807 declare
2808 subtype Result_Type is String (1 .. Strlen (chars));
2809
2810 Result : Result_Type;
2811 for Result'Address use chars;
2812
2813 begin
2814 return Result;
2815 end;
2816 end if;
2817 end Value;
2818
2819 ----------------------
2820 -- Write_Info_Ada_C --
2821 ----------------------
2822
2823 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
2824 begin
2825 if Ada_Bind_File then
2826 declare
2827 S : String (1 .. Ada'Length + Common'Length);
2828
2829 begin
2830 S (1 .. Ada'Length) := Ada;
2831 S (Ada'Length + 1 .. S'Length) := Common;
2832 WBI (S);
2833 end;
2834
2835 else
2836 declare
2837 S : String (1 .. C'Length + Common'Length);
2838
2839 begin
2840 S (1 .. C'Length) := C;
2841 S (C'Length + 1 .. S'Length) := Common;
2842 WBI (S);
2843 end;
2844 end if;
2845 end Write_Info_Ada_C;
2846
2847 ----------------------------
2848 -- Write_Statement_Buffer --
2849 ----------------------------
2850
2851 procedure Write_Statement_Buffer is
2852 begin
2853 WBI (Statement_Buffer (1 .. Last));
2854 Last := 0;
2855 end Write_Statement_Buffer;
2856
2857 procedure Write_Statement_Buffer (S : String) is
2858 begin
2859 Set_String (S);
2860 Write_Statement_Buffer;
2861 end Write_Statement_Buffer;
2862
2863 end Bindgen;
Mirror of the offical gcc git repository hosted at gcc.gnu.org