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