OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [lib-writ.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.