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