c-family/
[official-gcc.git] / gcc / ada / lib-writ.adb
blob1c55a06aa3e940a2cafe20b584c0464a580e0cb9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I B . W R I T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with ALI; use ALI;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Fname; use Fname;
33 with Fname.UF; use Fname.UF;
34 with Lib.Util; use Lib.Util;
35 with Lib.Xref; use Lib.Xref;
36 use Lib.Xref.Alfa;
37 with Nlists; use Nlists;
38 with Gnatvsn; use Gnatvsn;
39 with Opt; use Opt;
40 with Osint; use Osint;
41 with Osint.C; use Osint.C;
42 with Par;
43 with Par_SCO; use Par_SCO;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Scn; use Scn;
47 with Sinfo; use Sinfo;
48 with Sinput; use Sinput;
49 with Snames; use Snames;
50 with Stringt; use Stringt;
51 with Tbuild; use Tbuild;
52 with Uname; use Uname;
54 with System.Case_Util; use System.Case_Util;
55 with System.WCh_Con; use System.WCh_Con;
57 package body Lib.Writ is
59 -----------------------
60 -- Local Subprograms --
61 -----------------------
63 procedure Write_Unit_Name (N : Node_Id);
64 -- Used to write out the unit name for R (pragma Restriction) lines
65 -- for uses of Restriction (No_Dependence => unit-name).
67 ----------------------------------
68 -- Add_Preprocessing_Dependency --
69 ----------------------------------
71 procedure Add_Preprocessing_Dependency (S : Source_File_Index) is
72 begin
73 Units.Increment_Last;
74 Units.Table (Units.Last) :=
75 (Unit_File_Name => File_Name (S),
76 Unit_Name => No_Unit_Name,
77 Expected_Unit => No_Unit_Name,
78 Source_Index => S,
79 Cunit => Empty,
80 Cunit_Entity => Empty,
81 Dependency_Num => 0,
82 Dynamic_Elab => False,
83 Fatal_Error => False,
84 Generate_Code => False,
85 Has_Allocator => False,
86 Has_RACW => False,
87 Is_Compiler_Unit => False,
88 Ident_String => Empty,
89 Loading => False,
90 Main_Priority => -1,
91 Main_CPU => -1,
92 Munit_Index => 0,
93 Serial_Number => 0,
94 Version => 0,
95 Error_Location => No_Location,
96 OA_Setting => 'O');
97 end Add_Preprocessing_Dependency;
99 ------------------------------
100 -- Ensure_System_Dependency --
101 ------------------------------
103 procedure Ensure_System_Dependency is
104 System_Uname : Unit_Name_Type;
105 -- Unit name for system spec if needed for dummy entry
107 System_Fname : File_Name_Type;
108 -- File name for system spec if needed for dummy entry
110 begin
111 -- Nothing to do if we already compiled System
113 for Unum in Units.First .. Last_Unit loop
114 if Units.Table (Unum).Source_Index = System_Source_File_Index then
115 return;
116 end if;
117 end loop;
119 -- If no entry for system.ads in the units table, then add a entry
120 -- to the units table for system.ads, which will be referenced when
121 -- the ali file is generated. We need this because every unit depends
122 -- on system as a result of Targparm scanning the system.ads file to
123 -- determine the target dependent parameters for the compilation.
125 Name_Len := 6;
126 Name_Buffer (1 .. 6) := "system";
127 System_Uname := Name_To_Unit_Name (Name_Enter);
128 System_Fname := File_Name (System_Source_File_Index);
130 Units.Increment_Last;
131 Units.Table (Units.Last) := (
132 Unit_File_Name => System_Fname,
133 Unit_Name => System_Uname,
134 Expected_Unit => System_Uname,
135 Source_Index => System_Source_File_Index,
136 Cunit => Empty,
137 Cunit_Entity => Empty,
138 Dependency_Num => 0,
139 Dynamic_Elab => False,
140 Fatal_Error => False,
141 Generate_Code => False,
142 Has_Allocator => False,
143 Has_RACW => False,
144 Is_Compiler_Unit => False,
145 Ident_String => Empty,
146 Loading => False,
147 Main_Priority => -1,
148 Main_CPU => -1,
149 Munit_Index => 0,
150 Serial_Number => 0,
151 Version => 0,
152 Error_Location => No_Location,
153 OA_Setting => 'O');
155 -- Parse system.ads so that the checksum is set right
156 -- Style checks are not applied.
158 declare
159 Save_Mindex : constant Nat := Multiple_Unit_Index;
160 Save_Style : constant Boolean := Style_Check;
161 begin
162 Multiple_Unit_Index := 0;
163 Style_Check := False;
164 Initialize_Scanner (Units.Last, System_Source_File_Index);
165 Discard_List (Par (Configuration_Pragmas => False));
166 Style_Check := Save_Style;
167 Multiple_Unit_Index := Save_Mindex;
168 end;
169 end Ensure_System_Dependency;
171 ---------------
172 -- Write_ALI --
173 ---------------
175 procedure Write_ALI (Object : Boolean) is
177 ----------------
178 -- Local Data --
179 ----------------
181 Last_Unit : constant Unit_Number_Type := Units.Last;
182 -- Record unit number of last unit. We capture this in case we
183 -- have to add a dummy entry to the unit table for package System.
185 With_Flags : array (Units.First .. Last_Unit) of Boolean;
186 -- Array of flags to show which units are with'ed
188 Elab_Flags : array (Units.First .. Last_Unit) of Boolean;
189 -- Array of flags to show which units have pragma Elaborate set
191 Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean;
192 -- Array of flags to show which units have pragma Elaborate All set
194 Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
195 -- Array of flags to show which units have Elaborate_Desirable set
197 Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
198 -- Array of flags to show which units have Elaborate_All_Desirable set
200 type Yes_No is (Unknown, Yes, No);
201 Implicit_With : array (Units.First .. Last_Unit) of Yes_No;
202 -- Indicates if an implicit with has been given for the unit. Yes if
203 -- certainly present, no if certainly absent, unkonwn if not known.
205 Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));
206 -- Sorted table of source dependencies. One extra entry in case we
207 -- have to add a dummy entry for System.
209 Num_Sdep : Nat := 0;
210 -- Number of active entries in Sdep_Table
212 flag_compare_debug : Int;
213 pragma Import (C, flag_compare_debug);
214 -- Import from toplev.c
216 -----------------------
217 -- Local Subprograms --
218 -----------------------
220 procedure Collect_Withs (Cunit : Node_Id);
221 -- Collect with lines for entries in the context clause of the
222 -- given compilation unit, Cunit.
224 procedure Update_Tables_From_ALI_File;
225 -- Given an up to date ALI file (see Up_To_Date_ALI_file_Exists
226 -- function), update tables from the ALI information, including
227 -- specifically the Compilation_Switches table.
229 function Up_To_Date_ALI_File_Exists return Boolean;
230 -- If there exists an ALI file that is up to date, then this function
231 -- initializes the tables in the ALI spec to contain information on
232 -- this file (using Scan_ALI) and returns True. If no file exists,
233 -- or the file is not up to date, then False is returned.
235 procedure Write_Unit_Information (Unit_Num : Unit_Number_Type);
236 -- Write out the library information for one unit for which code is
237 -- generated (includes unit line and with lines).
239 procedure Write_With_Lines;
240 -- Write out with lines collected by calls to Collect_Withs
242 -------------------
243 -- Collect_Withs --
244 -------------------
246 procedure Collect_Withs (Cunit : Node_Id) is
247 Item : Node_Id;
248 Unum : Unit_Number_Type;
250 begin
251 Item := First (Context_Items (Cunit));
252 while Present (Item) loop
254 -- Process with clause
256 -- Ada 2005 (AI-50217): limited with_clauses do not create
257 -- dependencies, but must be recorded as components of the
258 -- partition, in case there is no regular with_clause for
259 -- the unit anywhere else.
261 if Nkind (Item) = N_With_Clause then
262 Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
263 With_Flags (Unum) := True;
265 if not Limited_Present (Item) then
266 if Elaborate_Present (Item) then
267 Elab_Flags (Unum) := True;
268 end if;
270 if Elaborate_All_Present (Item) then
271 Elab_All_Flags (Unum) := True;
272 end if;
274 if Elaborate_All_Desirable (Item) then
275 Elab_All_Des_Flags (Unum) := True;
276 end if;
278 if Elaborate_Desirable (Item) then
279 Elab_Des_Flags (Unum) := True;
280 end if;
282 else
283 Set_From_With_Type (Cunit_Entity (Unum));
284 end if;
286 if Implicit_With (Unum) /= Yes then
287 if Implicit_With_From_Instantiation (Item) then
288 Implicit_With (Unum) := Yes;
289 else
290 Implicit_With (Unum) := No;
291 end if;
292 end if;
293 end if;
295 Next (Item);
296 end loop;
297 end Collect_Withs;
299 --------------------------------
300 -- Up_To_Date_ALI_File_Exists --
301 --------------------------------
303 function Up_To_Date_ALI_File_Exists return Boolean is
304 Name : File_Name_Type;
305 Text : Text_Buffer_Ptr;
306 Id : Sdep_Id;
307 Sind : Source_File_Index;
309 begin
310 Opt.Check_Object_Consistency := True;
311 Read_Library_Info (Name, Text);
313 -- Return if we could not find an ALI file
315 if Text = null then
316 return False;
317 end if;
319 -- Return if ALI file has bad format
321 Initialize_ALI;
323 if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then
324 return False;
325 end if;
327 -- If we have an OK ALI file, check if it is up to date
328 -- Note that we assume that the ALI read has all the entries
329 -- we have in our table, plus some additional ones (that can
330 -- come from expansion).
332 Id := First_Sdep_Entry;
333 for J in 1 .. Num_Sdep loop
334 Sind := Units.Table (Sdep_Table (J)).Source_Index;
336 while Sdep.Table (Id).Sfile /= File_Name (Sind) loop
337 if Id = Sdep.Last then
338 return False;
339 else
340 Id := Id + 1;
341 end if;
342 end loop;
344 if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then
345 return False;
346 end if;
347 end loop;
349 return True;
350 end Up_To_Date_ALI_File_Exists;
352 ---------------------------------
353 -- Update_Tables_From_ALI_File --
354 ---------------------------------
356 procedure Update_Tables_From_ALI_File is
357 begin
358 -- Build Compilation_Switches table
360 Compilation_Switches.Init;
362 for J in First_Arg_Entry .. Args.Last loop
363 Compilation_Switches.Increment_Last;
364 Compilation_Switches.Table (Compilation_Switches.Last) :=
365 Args.Table (J);
366 end loop;
367 end Update_Tables_From_ALI_File;
369 ----------------------------
370 -- Write_Unit_Information --
371 ----------------------------
373 procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is
374 Unode : constant Node_Id := Cunit (Unit_Num);
375 Ukind : constant Node_Kind := Nkind (Unit (Unode));
376 Uent : constant Entity_Id := Cunit_Entity (Unit_Num);
377 Pnode : Node_Id;
379 begin
380 Write_Info_Initiate ('U');
381 Write_Info_Char (' ');
382 Write_Info_Name (Unit_Name (Unit_Num));
383 Write_Info_Tab (25);
384 Write_Info_Name (Unit_File_Name (Unit_Num));
386 Write_Info_Tab (49);
387 Write_Info_Str (Version_Get (Unit_Num));
389 -- Add BD parameter if Elaborate_Body pragma desirable
391 if Ekind (Uent) = E_Package
392 and then Elaborate_Body_Desirable (Uent)
393 then
394 Write_Info_Str (" BD");
395 end if;
397 -- Add BN parameter if body needed for SAL
399 if (Is_Subprogram (Uent)
400 or else Ekind (Uent) = E_Package
401 or else Is_Generic_Unit (Uent))
402 and then Body_Needed_For_SAL (Uent)
403 then
404 Write_Info_Str (" BN");
405 end if;
407 if Dynamic_Elab (Unit_Num) then
408 Write_Info_Str (" DE");
409 end if;
411 -- Set the Elaborate_Body indication if either an explicit pragma
412 -- was present, or if this is an instantiation.
414 if Has_Pragma_Elaborate_Body (Uent)
415 or else (Ukind = N_Package_Declaration
416 and then Is_Generic_Instance (Uent)
417 and then Present (Corresponding_Body (Unit (Unode))))
418 then
419 Write_Info_Str (" EB");
420 end if;
422 -- Now see if we should tell the binder that an elaboration entity
423 -- is present, which must be set to true during elaboration.
424 -- We generate the indication if the following condition is met:
426 -- If this is a spec ...
428 if (Is_Subprogram (Uent)
429 or else
430 Ekind (Uent) = E_Package
431 or else
432 Is_Generic_Unit (Uent))
434 -- and an elaboration entity was declared ...
436 and then Present (Elaboration_Entity (Uent))
438 -- and either the elaboration flag is required ...
440 and then
441 (Elaboration_Entity_Required (Uent)
443 -- or this unit has elaboration code ...
445 or else not Has_No_Elaboration_Code (Unode)
447 -- or this unit has a separate body and this
448 -- body has elaboration code.
450 or else
451 (Ekind (Uent) = E_Package
452 and then Present (Body_Entity (Uent))
453 and then
454 not Has_No_Elaboration_Code
455 (Parent
456 (Declaration_Node
457 (Body_Entity (Uent))))))
458 then
459 if Convention (Uent) = Convention_CIL then
461 -- Special case for generic CIL packages which never have
462 -- elaboration code
464 Write_Info_Str (" NE");
466 else
467 Write_Info_Str (" EE");
468 end if;
469 end if;
471 if Has_No_Elaboration_Code (Unode) then
472 Write_Info_Str (" NE");
473 end if;
475 Write_Info_Str (" O");
476 Write_Info_Char (OA_Setting (Unit_Num));
478 if Ekind_In (Uent, E_Package, E_Package_Body)
479 and then Present (Finalizer (Uent))
480 then
481 Write_Info_Str (" PF");
482 end if;
484 if Is_Preelaborated (Uent) then
485 Write_Info_Str (" PR");
486 end if;
488 if Is_Pure (Uent) then
489 Write_Info_Str (" PU");
490 end if;
492 if Has_RACW (Unit_Num) then
493 Write_Info_Str (" RA");
494 end if;
496 if Is_Remote_Call_Interface (Uent) then
497 Write_Info_Str (" RC");
498 end if;
500 if Is_Remote_Types (Uent) then
501 Write_Info_Str (" RT");
502 end if;
504 if Is_Shared_Passive (Uent) then
505 Write_Info_Str (" SP");
506 end if;
508 if Ukind = N_Subprogram_Declaration
509 or else Ukind = N_Subprogram_Body
510 then
511 Write_Info_Str (" SU");
513 elsif Ukind = N_Package_Declaration
514 or else
515 Ukind = N_Package_Body
516 then
517 -- If this is a wrapper package for a subprogram instantiation,
518 -- the user view is the subprogram. Note that in this case the
519 -- ali file contains both the spec and body of the instance.
521 if Is_Wrapper_Package (Uent) then
522 Write_Info_Str (" SU");
523 else
524 Write_Info_Str (" PK");
525 end if;
527 elsif Ukind = N_Generic_Package_Declaration then
528 Write_Info_Str (" PK");
530 end if;
532 if Ukind in N_Generic_Declaration
533 or else
534 (Present (Library_Unit (Unode))
535 and then
536 Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration)
537 then
538 Write_Info_Str (" GE");
539 end if;
541 if not Is_Internal_File_Name (Unit_File_Name (Unit_Num), True) then
542 case Identifier_Casing (Source_Index (Unit_Num)) is
543 when All_Lower_Case => Write_Info_Str (" IL");
544 when All_Upper_Case => Write_Info_Str (" IU");
545 when others => null;
546 end case;
548 case Keyword_Casing (Source_Index (Unit_Num)) is
549 when Mixed_Case => Write_Info_Str (" KM");
550 when All_Upper_Case => Write_Info_Str (" KU");
551 when others => null;
552 end case;
553 end if;
555 if Initialize_Scalars or else Invalid_Value_Used then
556 Write_Info_Str (" IS");
557 end if;
559 Write_Info_EOL;
561 -- Generate with lines, first those that are directly with'ed
563 for J in With_Flags'Range loop
564 With_Flags (J) := False;
565 Elab_Flags (J) := False;
566 Elab_All_Flags (J) := False;
567 Elab_Des_Flags (J) := False;
568 Elab_All_Des_Flags (J) := False;
569 Implicit_With (J) := Unknown;
570 end loop;
572 Collect_Withs (Unode);
574 -- For a body, we must also check for any subunits which belong to
575 -- it and which have context clauses of their own, since these
576 -- with'ed units are part of its own elaboration dependencies.
578 if Nkind (Unit (Unode)) in N_Unit_Body then
579 for S in Units.First .. Last_Unit loop
581 -- We are only interested in subunits.
582 -- For preproc. data and def. files, Cunit is Empty, so
583 -- we need to test that first.
585 if Cunit (S) /= Empty
586 and then Nkind (Unit (Cunit (S))) = N_Subunit
587 then
588 Pnode := Library_Unit (Cunit (S));
590 -- In gnatc mode, the errors in the subunits will not
591 -- have been recorded, but the analysis of the subunit
592 -- may have failed. There is no information to add to
593 -- ALI file in this case.
595 if No (Pnode) then
596 exit;
597 end if;
599 -- Find ultimate parent of the subunit
601 while Nkind (Unit (Pnode)) = N_Subunit loop
602 Pnode := Library_Unit (Pnode);
603 end loop;
605 -- See if it belongs to current unit, and if so, include
606 -- its with_clauses.
608 if Pnode = Unode then
609 Collect_Withs (Cunit (S));
610 end if;
611 end if;
612 end loop;
613 end if;
615 Write_With_Lines;
617 -- Output linker option lines
619 for J in 1 .. Linker_Option_Lines.Last loop
620 declare
621 S : Linker_Option_Entry renames Linker_Option_Lines.Table (J);
622 begin
623 if S.Unit = Unit_Num then
624 Write_Info_Initiate ('L');
625 Write_Info_Char (' ');
626 Write_Info_Slit (S.Option);
627 Write_Info_EOL;
628 end if;
629 end;
630 end loop;
632 -- Output notes
634 for J in 1 .. Notes.Last loop
635 declare
636 N : constant Node_Id := Notes.Table (J).Pragma_Node;
637 L : constant Source_Ptr := Sloc (N);
638 U : constant Unit_Number_Type := Notes.Table (J).Unit;
639 C : Character;
641 begin
642 if U = Unit_Num then
643 Write_Info_Initiate ('N');
644 Write_Info_Char (' ');
646 case Chars (Pragma_Identifier (N)) is
647 when Name_Annotate =>
648 C := 'A';
649 when Name_Comment =>
650 C := 'C';
651 when Name_Ident =>
652 C := 'I';
653 when Name_Title =>
654 C := 'T';
655 when Name_Subtitle =>
656 C := 'S';
657 when others =>
658 raise Program_Error;
659 end case;
661 Write_Info_Char (C);
662 Write_Info_Int (Int (Get_Logical_Line_Number (L)));
663 Write_Info_Char (':');
664 Write_Info_Int (Int (Get_Column_Number (L)));
666 declare
667 A : Node_Id;
669 begin
670 A := First (Pragma_Argument_Associations (N));
671 while Present (A) loop
672 Write_Info_Char (' ');
674 if Chars (A) /= No_Name then
675 Write_Info_Name (Chars (A));
676 Write_Info_Char (':');
677 end if;
679 declare
680 Expr : constant Node_Id := Expression (A);
682 begin
683 if Nkind (Expr) = N_Identifier then
684 Write_Info_Name (Chars (Expr));
686 elsif Nkind (Expr) = N_Integer_Literal
687 and then Is_Static_Expression (Expr)
688 then
689 Write_Info_Uint (Intval (Expr));
691 elsif Nkind (Expr) = N_String_Literal
692 and then Is_Static_Expression (Expr)
693 then
694 Write_Info_Slit (Strval (Expr));
696 else
697 Write_Info_Str ("<expr>");
698 end if;
699 end;
701 Next (A);
702 end loop;
703 end;
705 Write_Info_EOL;
706 end if;
707 end;
708 end loop;
709 end Write_Unit_Information;
711 ----------------------
712 -- Write_With_Lines --
713 ----------------------
715 procedure Write_With_Lines is
716 With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1));
717 Num_Withs : Int := 0;
718 Unum : Unit_Number_Type;
719 Cunit : Node_Id;
720 Uname : Unit_Name_Type;
721 Fname : File_Name_Type;
722 Pname : constant Unit_Name_Type :=
723 Get_Parent_Spec_Name (Unit_Name (Main_Unit));
724 Body_Fname : File_Name_Type;
725 Body_Index : Nat;
727 procedure Write_With_File_Names
728 (Nam : in out File_Name_Type;
729 Idx : Nat);
730 -- Write source file name Nam and ALI file name for unit index Idx.
731 -- Possibly change Nam to lowercase (generating a new file name).
733 --------------------------
734 -- Write_With_File_Name --
735 --------------------------
737 procedure Write_With_File_Names
738 (Nam : in out File_Name_Type;
739 Idx : Nat)
741 begin
742 if not File_Names_Case_Sensitive then
743 Get_Name_String (Nam);
744 To_Lower (Name_Buffer (1 .. Name_Len));
745 Nam := Name_Find;
746 end if;
748 Write_Info_Name (Nam);
749 Write_Info_Tab (49);
750 Write_Info_Name (Lib_File_Name (Nam, Idx));
751 end Write_With_File_Names;
753 -- Start of processing for Write_With_Lines
755 begin
756 -- Loop to build the with table. A with on the main unit itself
757 -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if
758 -- the main unit is a subprogram with no spec, and a subunit of
759 -- it unnecessarily withs the parent.
761 for J in Units.First + 1 .. Last_Unit loop
763 -- Add element to with table if it is with'ed or if it is the
764 -- parent spec of the main unit (case of main unit is a child
765 -- unit). The latter with is not needed for semantic purposes,
766 -- but is required by the binder for elaboration purposes.
767 -- For preproc. data and def. files, there is no Unit_Name,
768 -- check for that first.
770 if Unit_Name (J) /= No_Unit_Name
771 and then (With_Flags (J) or else Unit_Name (J) = Pname)
772 then
773 Num_Withs := Num_Withs + 1;
774 With_Table (Num_Withs) := J;
775 end if;
776 end loop;
778 -- Sort and output the table
780 Sort (With_Table (1 .. Num_Withs));
782 for J in 1 .. Num_Withs loop
783 Unum := With_Table (J);
784 Cunit := Units.Table (Unum).Cunit;
785 Uname := Units.Table (Unum).Unit_Name;
786 Fname := Units.Table (Unum).Unit_File_Name;
788 if Implicit_With (Unum) = Yes then
789 Write_Info_Initiate ('Z');
791 elsif Ekind (Cunit_Entity (Unum)) = E_Package
792 and then From_With_Type (Cunit_Entity (Unum))
793 then
794 Write_Info_Initiate ('Y');
796 else
797 Write_Info_Initiate ('W');
798 end if;
800 Write_Info_Char (' ');
801 Write_Info_Name (Uname);
803 -- Now we need to figure out the names of the files that contain
804 -- the with'ed unit. These will usually be the files for the body,
805 -- except in the case of a package that has no body. Note that we
806 -- have a specific exemption here for predefined library generics
807 -- (see comments for Generic_May_Lack_ALI). We do not generate
808 -- dependency upon the ALI file for such units. Older compilers
809 -- used to not support generating code (and ALI) for generics, and
810 -- we want to avoid having different processing (namely, different
811 -- lists of files to be compiled) for different stages of the
812 -- bootstrap.
814 if not ((Nkind (Unit (Cunit)) in N_Generic_Declaration
815 or else
816 Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration)
817 and then Generic_May_Lack_ALI (Fname))
819 -- In Alfa mode, always generate the dependencies on ALI
820 -- files, which are required to compute frame conditions
821 -- of subprograms.
823 or else Alfa_Mode
824 then
825 Write_Info_Tab (25);
827 if Is_Spec_Name (Uname) then
828 Body_Fname :=
829 Get_File_Name
830 (Get_Body_Name (Uname),
831 Subunit => False, May_Fail => True);
833 Body_Index :=
834 Get_Unit_Index
835 (Get_Body_Name (Uname));
837 if Body_Fname = No_File then
838 Body_Fname := Get_File_Name (Uname, Subunit => False);
839 Body_Index := Get_Unit_Index (Uname);
840 end if;
842 else
843 Body_Fname := Get_File_Name (Uname, Subunit => False);
844 Body_Index := Get_Unit_Index (Uname);
845 end if;
847 -- A package is considered to have a body if it requires
848 -- a body or if a body is present in Ada 83 mode.
850 if Body_Required (Cunit)
851 or else (Ada_Version = Ada_83
852 and then Full_Source_Name (Body_Fname) /= No_File)
853 then
854 Write_With_File_Names (Body_Fname, Body_Index);
855 else
856 Write_With_File_Names (Fname, Munit_Index (Unum));
857 end if;
859 if Ekind (Cunit_Entity (Unum)) = E_Package
860 and then From_With_Type (Cunit_Entity (Unum))
861 then
862 null;
863 else
864 if Elab_Flags (Unum) then
865 Write_Info_Str (" E");
866 end if;
868 if Elab_All_Flags (Unum) then
869 Write_Info_Str (" EA");
870 end if;
872 if Elab_Des_Flags (Unum) then
873 Write_Info_Str (" ED");
874 end if;
876 if Elab_All_Des_Flags (Unum) then
877 Write_Info_Str (" AD");
878 end if;
879 end if;
880 end if;
882 Write_Info_EOL;
883 end loop;
884 end Write_With_Lines;
886 -- Start of processing for Write_ALI
888 begin
889 -- We never write an ALI file if the original operating mode was
890 -- syntax-only (-gnats switch used in compiler invocation line)
892 if Original_Operating_Mode = Check_Syntax
893 or flag_compare_debug /= 0
894 then
895 return;
896 end if;
898 -- Generation of ALI files may be disabled, e.g. for formal verification
899 -- back-end.
901 if Disable_ALI_File then
902 return;
903 end if;
905 -- Build sorted source dependency table. We do this right away, because
906 -- it is referenced by Up_To_Date_ALI_File_Exists.
908 for Unum in Units.First .. Last_Unit loop
909 if Cunit_Entity (Unum) = Empty
910 or else not From_With_Type (Cunit_Entity (Unum))
911 then
912 Num_Sdep := Num_Sdep + 1;
913 Sdep_Table (Num_Sdep) := Unum;
914 end if;
915 end loop;
917 -- Sort the table so that the D lines are in order
919 Lib.Sort (Sdep_Table (1 .. Num_Sdep));
921 -- If we are not generating code, and there is an up to date ALI file
922 -- file accessible, read it, and acquire the compilation arguments from
923 -- this file.
925 if Operating_Mode /= Generate_Code then
926 if Up_To_Date_ALI_File_Exists then
927 Update_Tables_From_ALI_File;
928 return;
929 end if;
930 end if;
932 -- Otherwise acquire compilation arguments and prepare to write
933 -- out a new ali file.
935 Create_Output_Library_Info;
937 -- Output version line
939 Write_Info_Initiate ('V');
940 Write_Info_Str (" """);
941 Write_Info_Str (Verbose_Library_Version);
942 Write_Info_Char ('"');
944 Write_Info_EOL;
946 -- Output main program line if this is acceptable main program
948 Output_Main_Program_Line : declare
949 U : Node_Id := Unit (Units.Table (Main_Unit).Cunit);
950 S : Node_Id;
952 procedure M_Parameters;
953 -- Output parameters for main program line
955 ------------------
956 -- M_Parameters --
957 ------------------
959 procedure M_Parameters is
960 begin
961 if Main_Priority (Main_Unit) /= Default_Main_Priority then
962 Write_Info_Char (' ');
963 Write_Info_Nat (Main_Priority (Main_Unit));
964 end if;
966 if Opt.Time_Slice_Set then
967 Write_Info_Str (" T=");
968 Write_Info_Nat (Opt.Time_Slice_Value);
969 end if;
971 if Has_Allocator (Main_Unit) then
972 Write_Info_Str (" AB");
973 end if;
975 if Main_CPU (Main_Unit) /= Default_Main_CPU then
976 Write_Info_Str (" C=");
977 Write_Info_Nat (Main_CPU (Main_Unit));
978 end if;
980 Write_Info_Str (" W=");
981 Write_Info_Char
982 (WC_Encoding_Letters (Wide_Character_Encoding_Method));
984 Write_Info_EOL;
985 end M_Parameters;
987 -- Start of processing for Output_Main_Program_Line
989 begin
990 if Nkind (U) = N_Subprogram_Body
991 or else
992 (Nkind (U) = N_Package_Body
993 and then
994 Nkind (Original_Node (U)) in N_Subprogram_Instantiation)
995 then
996 -- If the unit is a subprogram instance, the entity for the
997 -- subprogram is the alias of the visible entity, which is the
998 -- related instance of the wrapper package. We retrieve the
999 -- subprogram declaration of the desired entity.
1001 if Nkind (U) = N_Package_Body then
1002 U := Parent (Parent (
1003 Alias (Related_Instance (Defining_Unit_Name
1004 (Specification (Unit (Library_Unit (Parent (U)))))))));
1005 end if;
1007 S := Specification (U);
1009 -- A generic subprogram is never a main program
1011 if Nkind (U) = N_Subprogram_Body
1012 and then Present (Corresponding_Spec (U))
1013 and then
1014 Ekind_In (Corresponding_Spec (U),
1015 E_Generic_Procedure, E_Generic_Function)
1016 then
1017 null;
1019 elsif No (Parameter_Specifications (S)) then
1020 if Nkind (S) = N_Procedure_Specification then
1021 Write_Info_Initiate ('M');
1022 Write_Info_Str (" P");
1023 M_Parameters;
1025 else
1026 declare
1027 Nam : Node_Id := Defining_Unit_Name (S);
1029 begin
1030 -- If it is a child unit, get its simple name
1032 if Nkind (Nam) = N_Defining_Program_Unit_Name then
1033 Nam := Defining_Identifier (Nam);
1034 end if;
1036 if Is_Integer_Type (Etype (Nam)) then
1037 Write_Info_Initiate ('M');
1038 Write_Info_Str (" F");
1039 M_Parameters;
1040 end if;
1041 end;
1042 end if;
1043 end if;
1044 end if;
1045 end Output_Main_Program_Line;
1047 -- Write command argument ('A') lines
1049 for A in 1 .. Compilation_Switches.Last loop
1050 Write_Info_Initiate ('A');
1051 Write_Info_Char (' ');
1052 Write_Info_Str (Compilation_Switches.Table (A).all);
1053 Write_Info_Terminate;
1054 end loop;
1056 -- Output parameters ('P') line
1058 Write_Info_Initiate ('P');
1060 if Compilation_Errors then
1061 Write_Info_Str (" CE");
1062 end if;
1064 if Opt.Detect_Blocking then
1065 Write_Info_Str (" DB");
1066 end if;
1068 if Opt.Float_Format /= ' ' then
1069 Write_Info_Str (" F");
1071 if Opt.Float_Format = 'I' then
1072 Write_Info_Char ('I');
1074 elsif Opt.Float_Format_Long = 'D' then
1075 Write_Info_Char ('D');
1077 else
1078 Write_Info_Char ('G');
1079 end if;
1080 end if;
1082 if Tasking_Used
1083 and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit))
1084 then
1085 if Locking_Policy /= ' ' then
1086 Write_Info_Str (" L");
1087 Write_Info_Char (Locking_Policy);
1088 end if;
1090 if Queuing_Policy /= ' ' then
1091 Write_Info_Str (" Q");
1092 Write_Info_Char (Queuing_Policy);
1093 end if;
1095 if Task_Dispatching_Policy /= ' ' then
1096 Write_Info_Str (" T");
1097 Write_Info_Char (Task_Dispatching_Policy);
1098 Write_Info_Char (' ');
1099 end if;
1100 end if;
1102 if not Object then
1103 Write_Info_Str (" NO");
1104 end if;
1106 if No_Run_Time_Mode then
1107 Write_Info_Str (" NR");
1108 end if;
1110 if Normalize_Scalars then
1111 Write_Info_Str (" NS");
1112 end if;
1114 if Sec_Stack_Used then
1115 Write_Info_Str (" SS");
1116 end if;
1118 if Unreserve_All_Interrupts then
1119 Write_Info_Str (" UA");
1120 end if;
1122 if Exception_Mechanism = Back_End_Exceptions then
1123 Write_Info_Str (" ZX");
1124 end if;
1126 Write_Info_EOL;
1128 -- Before outputting the restrictions line, update the setting of
1129 -- the No_Elaboration_Code flag. Violations of this restriction
1130 -- cannot be detected until after the backend has been called since
1131 -- it is the backend that sets this flag. We have to check all units
1132 -- for which we have generated code
1134 for Unit in Units.First .. Last_Unit loop
1135 if Units.Table (Unit).Generate_Code
1136 or else Unit = Main_Unit
1137 then
1138 if not Has_No_Elaboration_Code (Cunit (Unit)) then
1139 Main_Restrictions.Violated (No_Elaboration_Code) := True;
1140 end if;
1141 end if;
1142 end loop;
1144 -- Positional case (only if debug flag -gnatd.R is set)
1146 if Debug_Flag_Dot_RR then
1148 -- Output first restrictions line
1150 Write_Info_Initiate ('R');
1151 Write_Info_Char (' ');
1153 -- First the information for the boolean restrictions
1155 for R in All_Boolean_Restrictions loop
1156 if Main_Restrictions.Set (R)
1157 and then not Restriction_Warnings (R)
1158 then
1159 Write_Info_Char ('r');
1160 elsif Main_Restrictions.Violated (R) then
1161 Write_Info_Char ('v');
1162 else
1163 Write_Info_Char ('n');
1164 end if;
1165 end loop;
1167 -- And now the information for the parameter restrictions
1169 for RP in All_Parameter_Restrictions loop
1170 if Main_Restrictions.Set (RP)
1171 and then not Restriction_Warnings (RP)
1172 then
1173 Write_Info_Char ('r');
1174 Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
1175 else
1176 Write_Info_Char ('n');
1177 end if;
1179 if not Main_Restrictions.Violated (RP)
1180 or else RP not in Checked_Parameter_Restrictions
1181 then
1182 Write_Info_Char ('n');
1183 else
1184 Write_Info_Char ('v');
1185 Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
1187 if Main_Restrictions.Unknown (RP) then
1188 Write_Info_Char ('+');
1189 end if;
1190 end if;
1191 end loop;
1193 Write_Info_EOL;
1195 -- Named case (if debug flag -gnatd.R is not set)
1197 else
1198 declare
1199 C : Character;
1201 begin
1202 -- Write RN header line with preceding blank line
1204 Write_Info_EOL;
1205 Write_Info_Initiate ('R');
1206 Write_Info_Char ('N');
1207 Write_Info_EOL;
1209 -- First the lines for the boolean restrictions
1211 for R in All_Boolean_Restrictions loop
1212 if Main_Restrictions.Set (R)
1213 and then not Restriction_Warnings (R)
1214 then
1215 C := 'R';
1216 elsif Main_Restrictions.Violated (R) then
1217 C := 'V';
1218 else
1219 goto Continue;
1220 end if;
1222 Write_Info_Initiate ('R');
1223 Write_Info_Char (C);
1224 Write_Info_Char (' ');
1225 Write_Info_Str (All_Boolean_Restrictions'Image (R));
1226 Write_Info_EOL;
1228 <<Continue>>
1229 null;
1230 end loop;
1231 end;
1233 -- And now the lines for the parameter restrictions
1235 for RP in All_Parameter_Restrictions loop
1236 if Main_Restrictions.Set (RP)
1237 and then not Restriction_Warnings (RP)
1238 then
1239 Write_Info_Initiate ('R');
1240 Write_Info_Str ("R ");
1241 Write_Info_Str (All_Parameter_Restrictions'Image (RP));
1242 Write_Info_Char ('=');
1243 Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
1244 Write_Info_EOL;
1245 end if;
1247 if not Main_Restrictions.Violated (RP)
1248 or else RP not in Checked_Parameter_Restrictions
1249 then
1250 null;
1251 else
1252 Write_Info_Initiate ('R');
1253 Write_Info_Str ("V ");
1254 Write_Info_Str (All_Parameter_Restrictions'Image (RP));
1255 Write_Info_Char ('=');
1256 Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
1258 if Main_Restrictions.Unknown (RP) then
1259 Write_Info_Char ('+');
1260 end if;
1262 Write_Info_EOL;
1263 end if;
1264 end loop;
1265 end if;
1267 -- Output R lines for No_Dependence entries
1269 for J in No_Dependences.First .. No_Dependences.Last loop
1270 if In_Extended_Main_Source_Unit (No_Dependences.Table (J).Unit)
1271 and then not No_Dependences.Table (J).Warn
1272 then
1273 Write_Info_Initiate ('R');
1274 Write_Info_Char (' ');
1275 Write_Unit_Name (No_Dependences.Table (J).Unit);
1276 Write_Info_EOL;
1277 end if;
1278 end loop;
1280 -- Output interrupt state lines
1282 for J in Interrupt_States.First .. Interrupt_States.Last loop
1283 Write_Info_Initiate ('I');
1284 Write_Info_Char (' ');
1285 Write_Info_Nat (Interrupt_States.Table (J).Interrupt_Number);
1286 Write_Info_Char (' ');
1287 Write_Info_Char (Interrupt_States.Table (J).Interrupt_State);
1288 Write_Info_Char (' ');
1289 Write_Info_Nat
1290 (Nat (Get_Logical_Line_Number
1291 (Interrupt_States.Table (J).Pragma_Loc)));
1292 Write_Info_EOL;
1293 end loop;
1295 -- Output priority specific dispatching lines
1297 for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop
1298 Write_Info_Initiate ('S');
1299 Write_Info_Char (' ');
1300 Write_Info_Char (Specific_Dispatching.Table (J).Dispatching_Policy);
1301 Write_Info_Char (' ');
1302 Write_Info_Nat (Specific_Dispatching.Table (J).First_Priority);
1303 Write_Info_Char (' ');
1304 Write_Info_Nat (Specific_Dispatching.Table (J).Last_Priority);
1305 Write_Info_Char (' ');
1306 Write_Info_Nat
1307 (Nat (Get_Logical_Line_Number
1308 (Specific_Dispatching.Table (J).Pragma_Loc)));
1309 Write_Info_EOL;
1310 end loop;
1312 -- Loop through file table to output information for all units for which
1313 -- we have generated code, as marked by the Generate_Code flag.
1315 for Unit in Units.First .. Last_Unit loop
1316 if Units.Table (Unit).Generate_Code
1317 or else Unit = Main_Unit
1318 then
1319 Write_Info_EOL; -- blank line
1320 Write_Unit_Information (Unit);
1321 end if;
1322 end loop;
1324 Write_Info_EOL; -- blank line
1326 -- Output external version reference lines
1328 for J in 1 .. Version_Ref.Last loop
1329 Write_Info_Initiate ('E');
1330 Write_Info_Char (' ');
1332 for K in 1 .. String_Length (Version_Ref.Table (J)) loop
1333 Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K));
1334 end loop;
1336 Write_Info_EOL;
1337 end loop;
1339 -- Prepare to output the source dependency lines
1341 declare
1342 Unum : Unit_Number_Type;
1343 -- Number of unit being output
1345 Sind : Source_File_Index;
1346 -- Index of corresponding source file
1348 Fname : File_Name_Type;
1350 begin
1351 for J in 1 .. Num_Sdep loop
1352 Unum := Sdep_Table (J);
1353 Units.Table (Unum).Dependency_Num := J;
1354 Sind := Units.Table (Unum).Source_Index;
1356 Write_Info_Initiate ('D');
1357 Write_Info_Char (' ');
1359 -- Normal case of a unit entry with a source index
1361 if Sind /= No_Source_File then
1362 Fname := File_Name (Sind);
1364 -- Ensure that on platforms where the file names are not
1365 -- case sensitive, the recorded file name is in lower case.
1367 if not File_Names_Case_Sensitive then
1368 Get_Name_String (Fname);
1369 To_Lower (Name_Buffer (1 .. Name_Len));
1370 Fname := Name_Find;
1371 end if;
1373 Write_Info_Name (Fname);
1374 Write_Info_Tab (25);
1375 Write_Info_Str (String (Time_Stamp (Sind)));
1376 Write_Info_Char (' ');
1377 Write_Info_Str (Get_Hex_String (Source_Checksum (Sind)));
1379 -- If subunit, add unit name, omitting the %b at the end
1381 if Present (Cunit (Unum))
1382 and then Nkind (Unit (Cunit (Unum))) = N_Subunit
1383 then
1384 Get_Decoded_Name_String (Unit_Name (Unum));
1385 Write_Info_Char (' ');
1386 Write_Info_Str (Name_Buffer (1 .. Name_Len - 2));
1387 end if;
1389 -- If Source_Reference pragma used output information
1391 if Num_SRef_Pragmas (Sind) > 0 then
1392 Write_Info_Char (' ');
1394 if Num_SRef_Pragmas (Sind) = 1 then
1395 Write_Info_Nat (Int (First_Mapped_Line (Sind)));
1396 else
1397 Write_Info_Nat (0);
1398 end if;
1400 Write_Info_Char (':');
1401 Write_Info_Name (Reference_Name (Sind));
1402 end if;
1404 -- Case where there is no source index (happens for missing
1405 -- files). In this case we write a dummy time stamp.
1407 else
1408 Write_Info_Name (Unit_File_Name (Unum));
1409 Write_Info_Tab (25);
1410 Write_Info_Str (String (Dummy_Time_Stamp));
1411 Write_Info_Char (' ');
1412 Write_Info_Str (Get_Hex_String (0));
1413 end if;
1415 Write_Info_EOL;
1416 end loop;
1417 end;
1419 -- Output cross-references
1421 if Opt.Xref_Active then
1422 Output_References;
1423 end if;
1425 -- Output SCO information if present
1427 if Generate_SCO then
1428 SCO_Output;
1429 end if;
1431 -- Output Alfa information if needed
1433 if Opt.Xref_Active and then Alfa_Mode then
1434 Collect_Alfa (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep);
1435 Output_Alfa;
1436 end if;
1438 -- Output final blank line and we are done. This final blank line is
1439 -- probably junk, but we don't feel like making an incompatible change!
1441 Write_Info_Terminate;
1442 Close_Output_Library_Info;
1443 end Write_ALI;
1445 ---------------------
1446 -- Write_Unit_Name --
1447 ---------------------
1449 procedure Write_Unit_Name (N : Node_Id) is
1450 begin
1451 if Nkind (N) = N_Identifier then
1452 Write_Info_Name (Chars (N));
1454 else
1455 pragma Assert (Nkind (N) = N_Selected_Component);
1456 Write_Unit_Name (Prefix (N));
1457 Write_Info_Char ('.');
1458 Write_Unit_Name (Selector_Name (N));
1459 end if;
1460 end Write_Unit_Name;
1462 end Lib.Writ;