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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-util.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
--                              P R J . U T I L                             --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2001-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 Ada.Unchecked_Deallocation;
27
 
28
with GNAT.Case_Util; use GNAT.Case_Util;
29
with GNAT.Regexp;    use GNAT.Regexp;
30
 
31
with Osint;    use Osint;
32
with Output;   use Output;
33
with Opt;
34
with Prj.Com;
35
with Snames;   use Snames;
36
with Table;
37
with Targparm; use Targparm;
38
 
39
with GNAT.HTable;
40
 
41
package body Prj.Util is
42
 
43
   package Source_Info_Table is new Table.Table
44
     (Table_Component_Type => Source_Info_Iterator,
45
      Table_Index_Type     => Natural,
46
      Table_Low_Bound      => 1,
47
      Table_Initial        => 10,
48
      Table_Increment      => 100,
49
      Table_Name           => "Makeutl.Source_Info_Table");
50
 
51
   package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
52
     (Header_Num => Prj.Header_Num,
53
      Element    => Natural,
54
      No_Element => 0,
55
      Key        => Name_Id,
56
      Hash       => Prj.Hash,
57
      Equal      => "=");
58
 
59
   procedure Free is new Ada.Unchecked_Deallocation
60
     (Text_File_Data, Text_File);
61
 
62
   -----------
63
   -- Close --
64
   -----------
65
 
66
   procedure Close (File : in out Text_File) is
67
      Len : Integer;
68
      Status : Boolean;
69
 
70
   begin
71
      if File = null then
72
         Prj.Com.Fail ("Close attempted on an invalid Text_File");
73
      end if;
74
 
75
      if File.Out_File then
76
         if File.Buffer_Len > 0 then
77
            Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
78
 
79
            if Len /= File.Buffer_Len then
80
               Prj.Com.Fail ("Unable to write to an out Text_File");
81
            end if;
82
         end if;
83
 
84
         Close (File.FD, Status);
85
 
86
         if not Status then
87
            Prj.Com.Fail ("Unable to close an out Text_File");
88
         end if;
89
 
90
      else
91
 
92
         --  Close in file, no need to test status, since this is a file that
93
         --  we read, and the file was read successfully before we closed it.
94
 
95
         Close (File.FD);
96
      end if;
97
 
98
      Free (File);
99
   end Close;
100
 
101
   ------------
102
   -- Create --
103
   ------------
104
 
105
   procedure Create (File : out Text_File; Name : String) is
106
      FD        : File_Descriptor;
107
      File_Name : String (1 .. Name'Length + 1);
108
 
109
   begin
110
      File_Name (1 .. Name'Length) := Name;
111
      File_Name (File_Name'Last) := ASCII.NUL;
112
      FD := Create_File (Name => File_Name'Address,
113
                         Fmode => GNAT.OS_Lib.Text);
114
 
115
      if FD = Invalid_FD then
116
         File := null;
117
 
118
      else
119
         File := new Text_File_Data;
120
         File.FD := FD;
121
         File.Out_File := True;
122
         File.End_Of_File_Reached := True;
123
      end if;
124
   end Create;
125
 
126
   ---------------
127
   -- Duplicate --
128
   ---------------
129
 
130
   procedure Duplicate
131
     (This   : in out Name_List_Index;
132
      Shared : Shared_Project_Tree_Data_Access)
133
   is
134
      Old_Current : Name_List_Index;
135
      New_Current : Name_List_Index;
136
 
137
   begin
138
      if This /= No_Name_List then
139
         Old_Current := This;
140
         Name_List_Table.Increment_Last (Shared.Name_Lists);
141
         New_Current := Name_List_Table.Last (Shared.Name_Lists);
142
         This := New_Current;
143
         Shared.Name_Lists.Table (New_Current) :=
144
           (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
145
 
146
         loop
147
            Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
148
            exit when Old_Current = No_Name_List;
149
            Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
150
            Name_List_Table.Increment_Last (Shared.Name_Lists);
151
            New_Current := New_Current + 1;
152
            Shared.Name_Lists.Table (New_Current) :=
153
              (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
154
         end loop;
155
      end if;
156
   end Duplicate;
157
 
158
   -----------------
159
   -- End_Of_File --
160
   -----------------
161
 
162
   function End_Of_File (File : Text_File) return Boolean is
163
   begin
164
      if File = null then
165
         Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
166
      end if;
167
 
168
      return File.End_Of_File_Reached;
169
   end End_Of_File;
170
 
171
   -------------------
172
   -- Executable_Of --
173
   -------------------
174
 
175
   function Executable_Of
176
     (Project  : Project_Id;
177
      Shared   : Shared_Project_Tree_Data_Access;
178
      Main     : File_Name_Type;
179
      Index    : Int;
180
      Ada_Main : Boolean := True;
181
      Language : String := "";
182
      Include_Suffix : Boolean := True) return File_Name_Type
183
   is
184
      pragma Assert (Project /= No_Project);
185
 
186
      The_Packages : constant Package_Id := Project.Decl.Packages;
187
 
188
      Builder_Package : constant Prj.Package_Id :=
189
                          Prj.Util.Value_Of
190
                            (Name        => Name_Builder,
191
                             In_Packages => The_Packages,
192
                             Shared      => Shared);
193
 
194
      Executable : Variable_Value :=
195
                     Prj.Util.Value_Of
196
                       (Name                    => Name_Id (Main),
197
                        Index                   => Index,
198
                        Attribute_Or_Array_Name => Name_Executable,
199
                        In_Package              => Builder_Package,
200
                        Shared                  => Shared);
201
 
202
      Lang   : Language_Ptr;
203
 
204
      Spec_Suffix : Name_Id := No_Name;
205
      Body_Suffix : Name_Id := No_Name;
206
 
207
      Spec_Suffix_Length : Natural := 0;
208
      Body_Suffix_Length : Natural := 0;
209
 
210
      procedure Get_Suffixes
211
        (B_Suffix : File_Name_Type;
212
         S_Suffix : File_Name_Type);
213
      --  Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
214
 
215
      function Add_Suffix (File : File_Name_Type) return File_Name_Type;
216
      --  Return the name of the executable, based on File, and adding the
217
      --  executable suffix if needed
218
 
219
      ------------------
220
      -- Get_Suffixes --
221
      ------------------
222
 
223
      procedure Get_Suffixes
224
        (B_Suffix : File_Name_Type;
225
         S_Suffix : File_Name_Type)
226
      is
227
      begin
228
         if B_Suffix /= No_File then
229
            Body_Suffix := Name_Id (B_Suffix);
230
            Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
231
         end if;
232
 
233
         if S_Suffix /= No_File then
234
            Spec_Suffix := Name_Id (S_Suffix);
235
            Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
236
         end if;
237
      end Get_Suffixes;
238
 
239
      ----------------
240
      -- Add_Suffix --
241
      ----------------
242
 
243
      function Add_Suffix (File : File_Name_Type) return File_Name_Type is
244
         Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
245
         Result     : File_Name_Type;
246
         Suffix_From_Project : Variable_Value;
247
      begin
248
         if Include_Suffix then
249
            if Project.Config.Executable_Suffix /= No_Name then
250
               Executable_Extension_On_Target :=
251
                 Project.Config.Executable_Suffix;
252
            end if;
253
 
254
            Result :=  Executable_Name (File);
255
            Executable_Extension_On_Target := Saved_EEOT;
256
            return Result;
257
 
258
         elsif Builder_Package /= No_Package then
259
 
260
            --  If the suffix is specified in the project itself, as opposed to
261
            --  the config file, it needs to be taken into account. However,
262
            --  when the project was processed, in both cases the suffix was
263
            --  stored in Project.Config, so get it from the project again.
264
 
265
            Suffix_From_Project :=
266
              Prj.Util.Value_Of
267
                (Variable_Name => Name_Executable_Suffix,
268
                 In_Variables  =>
269
                   Shared.Packages.Table (Builder_Package).Decl.Attributes,
270
                 Shared        => Shared);
271
 
272
            if Suffix_From_Project /= Nil_Variable_Value
273
              and then Suffix_From_Project.Value /= No_Name
274
            then
275
               Executable_Extension_On_Target := Suffix_From_Project.Value;
276
               Result :=  Executable_Name (File);
277
               Executable_Extension_On_Target := Saved_EEOT;
278
               return Result;
279
            end if;
280
         end if;
281
 
282
         return File;
283
      end Add_Suffix;
284
 
285
   --  Start of processing for Executable_Of
286
 
287
   begin
288
      if Ada_Main then
289
         Lang := Get_Language_From_Name (Project, "ada");
290
      elsif Language /= "" then
291
         Lang := Get_Language_From_Name (Project, Language);
292
      end if;
293
 
294
      if Lang /= null then
295
         Get_Suffixes
296
           (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
297
            S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
298
      end if;
299
 
300
      if Builder_Package /= No_Package then
301
         if Executable = Nil_Variable_Value and then Ada_Main then
302
            Get_Name_String (Main);
303
 
304
            --  Try as index the name minus the implementation suffix or minus
305
            --  the specification suffix.
306
 
307
            declare
308
               Name : constant String (1 .. Name_Len) :=
309
                        Name_Buffer (1 .. Name_Len);
310
               Last : Positive := Name_Len;
311
 
312
               Truncated : Boolean := False;
313
 
314
            begin
315
               if Body_Suffix /= No_Name
316
                 and then Last > Natural (Length_Of_Name (Body_Suffix))
317
                 and then Name (Last - Body_Suffix_Length + 1 .. Last) =
318
                            Get_Name_String (Body_Suffix)
319
               then
320
                  Truncated := True;
321
                  Last := Last - Body_Suffix_Length;
322
               end if;
323
 
324
               if Spec_Suffix /= No_Name
325
                 and then not Truncated
326
                 and then Last > Spec_Suffix_Length
327
                 and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
328
                            Get_Name_String (Spec_Suffix)
329
               then
330
                  Truncated := True;
331
                  Last := Last - Spec_Suffix_Length;
332
               end if;
333
 
334
               if Truncated then
335
                  Name_Len := Last;
336
                  Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
337
                  Executable :=
338
                    Prj.Util.Value_Of
339
                      (Name                    => Name_Find,
340
                       Index                   => 0,
341
                       Attribute_Or_Array_Name => Name_Executable,
342
                       In_Package              => Builder_Package,
343
                       Shared                  => Shared);
344
               end if;
345
            end;
346
         end if;
347
 
348
         --  If we have found an Executable attribute, return its value,
349
         --  possibly suffixed by the executable suffix.
350
 
351
         if Executable /= Nil_Variable_Value
352
           and then Executable.Value /= No_Name
353
           and then Length_Of_Name (Executable.Value) /= 0
354
         then
355
            return Add_Suffix (File_Name_Type (Executable.Value));
356
         end if;
357
      end if;
358
 
359
      Get_Name_String (Main);
360
 
361
      --  If there is a body suffix or a spec suffix, remove this suffix,
362
      --  otherwise remove any suffix ('.' followed by other characters), if
363
      --  there is one.
364
 
365
      if Body_Suffix /= No_Name
366
         and then Name_Len > Body_Suffix_Length
367
         and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
368
                    Get_Name_String (Body_Suffix)
369
      then
370
         --  Found the body termination, remove it
371
 
372
         Name_Len := Name_Len - Body_Suffix_Length;
373
 
374
      elsif Spec_Suffix /= No_Name
375
            and then Name_Len > Spec_Suffix_Length
376
            and then
377
              Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
378
                Get_Name_String (Spec_Suffix)
379
      then
380
         --  Found the spec termination, remove it
381
 
382
         Name_Len := Name_Len - Spec_Suffix_Length;
383
 
384
      else
385
         --  Remove any suffix, if there is one
386
 
387
         Get_Name_String (Strip_Suffix (Main));
388
      end if;
389
 
390
      return Add_Suffix (Name_Find);
391
   end Executable_Of;
392
 
393
   --------------
394
   -- Get_Line --
395
   --------------
396
 
397
   procedure Get_Line
398
     (File : Text_File;
399
      Line : out String;
400
      Last : out Natural)
401
   is
402
      C : Character;
403
 
404
      procedure Advance;
405
 
406
      -------------
407
      -- Advance --
408
      -------------
409
 
410
      procedure Advance is
411
      begin
412
         if File.Cursor = File.Buffer_Len then
413
            File.Buffer_Len :=
414
              Read
415
               (FD => File.FD,
416
                A  => File.Buffer'Address,
417
                N  => File.Buffer'Length);
418
 
419
            if File.Buffer_Len = 0 then
420
               File.End_Of_File_Reached := True;
421
               return;
422
            else
423
               File.Cursor := 1;
424
            end if;
425
 
426
         else
427
            File.Cursor := File.Cursor + 1;
428
         end if;
429
      end Advance;
430
 
431
   --  Start of processing for Get_Line
432
 
433
   begin
434
      if File = null then
435
         Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
436
 
437
      elsif File.Out_File then
438
         Prj.Com.Fail ("Get_Line attempted on an out file");
439
      end if;
440
 
441
      Last := Line'First - 1;
442
 
443
      if not File.End_Of_File_Reached then
444
         loop
445
            C := File.Buffer (File.Cursor);
446
            exit when C = ASCII.CR or else C = ASCII.LF;
447
            Last := Last + 1;
448
            Line (Last) := C;
449
            Advance;
450
 
451
            if File.End_Of_File_Reached then
452
               return;
453
            end if;
454
 
455
            exit when Last = Line'Last;
456
         end loop;
457
 
458
         if C = ASCII.CR or else C = ASCII.LF then
459
            Advance;
460
 
461
            if File.End_Of_File_Reached then
462
               return;
463
            end if;
464
         end if;
465
 
466
         if C = ASCII.CR
467
           and then File.Buffer (File.Cursor) = ASCII.LF
468
         then
469
            Advance;
470
         end if;
471
      end if;
472
   end Get_Line;
473
 
474
   ----------------
475
   -- Initialize --
476
   ----------------
477
 
478
   procedure Initialize
479
     (Iter        : out Source_Info_Iterator;
480
      For_Project : Name_Id)
481
   is
482
      Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
483
   begin
484
      if Ind = 0 then
485
         Iter := (No_Source_Info, 0);
486
      else
487
         Iter := Source_Info_Table.Table (Ind);
488
      end if;
489
   end Initialize;
490
 
491
   --------------
492
   -- Is_Valid --
493
   --------------
494
 
495
   function Is_Valid (File : Text_File) return Boolean is
496
   begin
497
      return File /= null;
498
   end Is_Valid;
499
 
500
   ----------
501
   -- Next --
502
   ----------
503
 
504
   procedure Next (Iter : in out Source_Info_Iterator) is
505
   begin
506
      if Iter.Next = 0 then
507
         Iter.Info := No_Source_Info;
508
 
509
      else
510
         Iter := Source_Info_Table.Table (Iter.Next);
511
      end if;
512
   end Next;
513
 
514
   ----------
515
   -- Open --
516
   ----------
517
 
518
   procedure Open (File : out Text_File; Name : String) is
519
      FD        : File_Descriptor;
520
      File_Name : String (1 .. Name'Length + 1);
521
 
522
   begin
523
      File_Name (1 .. Name'Length) := Name;
524
      File_Name (File_Name'Last) := ASCII.NUL;
525
      FD := Open_Read (Name => File_Name'Address,
526
                       Fmode => GNAT.OS_Lib.Text);
527
 
528
      if FD = Invalid_FD then
529
         File := null;
530
 
531
      else
532
         File := new Text_File_Data;
533
         File.FD := FD;
534
         File.Buffer_Len :=
535
           Read (FD => FD,
536
                 A  => File.Buffer'Address,
537
                 N  => File.Buffer'Length);
538
 
539
         if File.Buffer_Len = 0 then
540
            File.End_Of_File_Reached := True;
541
         else
542
            File.Cursor := 1;
543
         end if;
544
      end if;
545
   end Open;
546
 
547
   ---------
548
   -- Put --
549
   ---------
550
 
551
   procedure Put
552
     (Into_List  : in out Name_List_Index;
553
      From_List  : String_List_Id;
554
      In_Tree    : Project_Tree_Ref;
555
      Lower_Case : Boolean := False)
556
   is
557
      Shared  : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
558
 
559
      Current_Name : Name_List_Index;
560
      List         : String_List_Id;
561
      Element      : String_Element;
562
      Last         : Name_List_Index :=
563
                       Name_List_Table.Last (Shared.Name_Lists);
564
      Value        : Name_Id;
565
 
566
   begin
567
      Current_Name := Into_List;
568
      while Current_Name /= No_Name_List
569
        and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
570
      loop
571
         Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
572
      end loop;
573
 
574
      List := From_List;
575
      while List /= Nil_String loop
576
         Element := Shared.String_Elements.Table (List);
577
         Value := Element.Value;
578
 
579
         if Lower_Case then
580
            Get_Name_String (Value);
581
            To_Lower (Name_Buffer (1 .. Name_Len));
582
            Value := Name_Find;
583
         end if;
584
 
585
         Name_List_Table.Append
586
           (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
587
 
588
         Last := Last + 1;
589
 
590
         if Current_Name = No_Name_List then
591
            Into_List := Last;
592
         else
593
            Shared.Name_Lists.Table (Current_Name).Next := Last;
594
         end if;
595
 
596
         Current_Name := Last;
597
 
598
         List := Element.Next;
599
      end loop;
600
   end Put;
601
 
602
   procedure Put (File : Text_File; S : String) is
603
      Len : Integer;
604
   begin
605
      if File = null then
606
         Prj.Com.Fail ("Attempted to write on an invalid Text_File");
607
 
608
      elsif not File.Out_File then
609
         Prj.Com.Fail ("Attempted to write an in Text_File");
610
      end if;
611
 
612
      if File.Buffer_Len + S'Length > File.Buffer'Last then
613
         --  Write buffer
614
         Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
615
 
616
         if Len /= File.Buffer_Len then
617
            Prj.Com.Fail ("Failed to write to an out Text_File");
618
         end if;
619
 
620
         File.Buffer_Len := 0;
621
      end if;
622
 
623
      File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
624
      File.Buffer_Len := File.Buffer_Len + S'Length;
625
   end Put;
626
 
627
   --------------
628
   -- Put_Line --
629
   --------------
630
 
631
   procedure Put_Line (File : Text_File; Line : String) is
632
      L : String (1 .. Line'Length + 1);
633
   begin
634
      L (1 .. Line'Length) := Line;
635
      L (L'Last) := ASCII.LF;
636
      Put (File, L);
637
   end Put_Line;
638
 
639
   ---------------------------
640
   -- Read_Source_Info_File --
641
   ---------------------------
642
 
643
   procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
644
      File : Text_File;
645
      Info : Source_Info_Iterator;
646
      Proj : Name_Id;
647
 
648
      procedure Report_Error;
649
 
650
      ------------------
651
      -- Report_Error --
652
      ------------------
653
 
654
      procedure Report_Error is
655
      begin
656
         Write_Line ("errors in source info file """ &
657
                     Tree.Source_Info_File_Name.all & '"');
658
         Tree.Source_Info_File_Exists := False;
659
      end Report_Error;
660
 
661
   begin
662
      Source_Info_Project_HTable.Reset;
663
      Source_Info_Table.Init;
664
 
665
      if Tree.Source_Info_File_Name = null then
666
         Tree.Source_Info_File_Exists := False;
667
         return;
668
      end if;
669
 
670
      Open (File, Tree.Source_Info_File_Name.all);
671
 
672
      if not Is_Valid (File) then
673
         if Opt.Verbose_Mode then
674
            Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
675
                        " does not exist");
676
         end if;
677
 
678
         Tree.Source_Info_File_Exists := False;
679
         return;
680
      end if;
681
 
682
      Tree.Source_Info_File_Exists := True;
683
 
684
      if Opt.Verbose_Mode then
685
         Write_Line ("Reading source info file " &
686
                     Tree.Source_Info_File_Name.all);
687
      end if;
688
 
689
      Source_Loop :
690
      while not End_Of_File (File) loop
691
         Info := (new Source_Info_Data, 0);
692
         Source_Info_Table.Increment_Last;
693
 
694
         --  project name
695
         Get_Line (File, Name_Buffer, Name_Len);
696
         Proj := Name_Find;
697
         Info.Info.Project := Proj;
698
         Info.Next := Source_Info_Project_HTable.Get (Proj);
699
         Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
700
 
701
         if End_Of_File (File) then
702
            Report_Error;
703
            exit Source_Loop;
704
         end if;
705
 
706
         --  language name
707
         Get_Line (File, Name_Buffer, Name_Len);
708
         Info.Info.Language := Name_Find;
709
 
710
         if End_Of_File (File) then
711
            Report_Error;
712
            exit Source_Loop;
713
         end if;
714
 
715
         --  kind
716
         Get_Line (File, Name_Buffer, Name_Len);
717
         Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
718
 
719
         if End_Of_File (File) then
720
            Report_Error;
721
            exit Source_Loop;
722
         end if;
723
 
724
         --  display path name
725
         Get_Line (File, Name_Buffer, Name_Len);
726
         Info.Info.Display_Path_Name := Name_Find;
727
         Info.Info.Path_Name := Info.Info.Display_Path_Name;
728
 
729
         if End_Of_File (File) then
730
            Report_Error;
731
            exit Source_Loop;
732
         end if;
733
 
734
         --  optional fields
735
         Option_Loop :
736
         loop
737
            Get_Line (File, Name_Buffer, Name_Len);
738
            exit Option_Loop when Name_Len = 0;
739
 
740
            if Name_Len <= 2 then
741
               Report_Error;
742
               exit Source_Loop;
743
 
744
            else
745
               if Name_Buffer (1 .. 2) = "P=" then
746
                  Name_Buffer (1 .. Name_Len - 2) :=
747
                    Name_Buffer (3 .. Name_Len);
748
                  Name_Len := Name_Len - 2;
749
                  Info.Info.Path_Name := Name_Find;
750
 
751
               elsif Name_Buffer (1 .. 2) = "U=" then
752
                  Name_Buffer (1 .. Name_Len - 2) :=
753
                    Name_Buffer (3 .. Name_Len);
754
                  Name_Len := Name_Len - 2;
755
                  Info.Info.Unit_Name := Name_Find;
756
 
757
               elsif Name_Buffer (1 .. 2) = "I=" then
758
                  Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
759
 
760
               elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
761
                  Info.Info.Naming_Exception := Yes;
762
 
763
               elsif Name_Buffer (1 .. Name_Len) = "N=I" then
764
                  Info.Info.Naming_Exception := Inherited;
765
 
766
               else
767
                  Report_Error;
768
                  exit Source_Loop;
769
               end if;
770
            end if;
771
         end loop Option_Loop;
772
 
773
         Source_Info_Table.Table (Source_Info_Table.Last) := Info;
774
      end loop Source_Loop;
775
 
776
      Close (File);
777
 
778
   exception
779
      when others =>
780
         Close (File);
781
         Report_Error;
782
   end Read_Source_Info_File;
783
 
784
   --------------------
785
   -- Source_Info_Of --
786
   --------------------
787
 
788
   function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
789
   begin
790
      return Iter.Info;
791
   end Source_Info_Of;
792
 
793
   --------------
794
   -- Value_Of --
795
   --------------
796
 
797
   function Value_Of
798
     (Variable : Variable_Value;
799
      Default  : String) return String
800
   is
801
   begin
802
      if Variable.Kind /= Single
803
        or else Variable.Default
804
        or else Variable.Value = No_Name
805
      then
806
         return Default;
807
      else
808
         return Get_Name_String (Variable.Value);
809
      end if;
810
   end Value_Of;
811
 
812
   function Value_Of
813
     (Index    : Name_Id;
814
      In_Array : Array_Element_Id;
815
      Shared   : Shared_Project_Tree_Data_Access) return Name_Id
816
   is
817
 
818
      Current    : Array_Element_Id;
819
      Element    : Array_Element;
820
      Real_Index : Name_Id := Index;
821
 
822
   begin
823
      Current := In_Array;
824
 
825
      if Current = No_Array_Element then
826
         return No_Name;
827
      end if;
828
 
829
      Element := Shared.Array_Elements.Table (Current);
830
 
831
      if not Element.Index_Case_Sensitive then
832
         Get_Name_String (Index);
833
         To_Lower (Name_Buffer (1 .. Name_Len));
834
         Real_Index := Name_Find;
835
      end if;
836
 
837
      while Current /= No_Array_Element loop
838
         Element := Shared.Array_Elements.Table (Current);
839
 
840
         if Real_Index = Element.Index then
841
            exit when Element.Value.Kind /= Single;
842
            exit when Element.Value.Value = Empty_String;
843
            return Element.Value.Value;
844
         else
845
            Current := Element.Next;
846
         end if;
847
      end loop;
848
 
849
      return No_Name;
850
   end Value_Of;
851
 
852
   function Value_Of
853
     (Index                  : Name_Id;
854
      Src_Index              : Int := 0;
855
      In_Array               : Array_Element_Id;
856
      Shared                 : Shared_Project_Tree_Data_Access;
857
      Force_Lower_Case_Index : Boolean := False;
858
      Allow_Wildcards        : Boolean := False) return Variable_Value
859
   is
860
      Current      : Array_Element_Id;
861
      Element      : Array_Element;
862
      Real_Index_1 : Name_Id;
863
      Real_Index_2 : Name_Id;
864
 
865
   begin
866
      Current := In_Array;
867
 
868
      if Current = No_Array_Element then
869
         return Nil_Variable_Value;
870
      end if;
871
 
872
      Element := Shared.Array_Elements.Table (Current);
873
 
874
      Real_Index_1 := Index;
875
 
876
      if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
877
         if Index /= All_Other_Names then
878
            Get_Name_String (Index);
879
            To_Lower (Name_Buffer (1 .. Name_Len));
880
            Real_Index_1 := Name_Find;
881
         end if;
882
      end if;
883
 
884
      while Current /= No_Array_Element loop
885
         Element := Shared.Array_Elements.Table (Current);
886
         Real_Index_2 := Element.Index;
887
 
888
         if not Element.Index_Case_Sensitive
889
           or else Force_Lower_Case_Index
890
         then
891
            if Element.Index /= All_Other_Names then
892
               Get_Name_String (Element.Index);
893
               To_Lower (Name_Buffer (1 .. Name_Len));
894
               Real_Index_2 := Name_Find;
895
            end if;
896
         end if;
897
 
898
         if Src_Index = Element.Src_Index and then
899
           (Real_Index_1 = Real_Index_2 or else
900
              (Real_Index_2 /= All_Other_Names and then
901
               Allow_Wildcards and then
902
                 Match (Get_Name_String (Real_Index_1),
903
                        Compile (Get_Name_String (Real_Index_2),
904
                                 Glob => True))))
905
         then
906
            return Element.Value;
907
         else
908
            Current := Element.Next;
909
         end if;
910
      end loop;
911
 
912
      return Nil_Variable_Value;
913
   end Value_Of;
914
 
915
   function Value_Of
916
     (Name                    : Name_Id;
917
      Index                   : Int := 0;
918
      Attribute_Or_Array_Name : Name_Id;
919
      In_Package              : Package_Id;
920
      Shared                  : Shared_Project_Tree_Data_Access;
921
      Force_Lower_Case_Index  : Boolean := False;
922
      Allow_Wildcards         : Boolean := False) return Variable_Value
923
   is
924
      The_Array     : Array_Element_Id;
925
      The_Attribute : Variable_Value := Nil_Variable_Value;
926
 
927
   begin
928
      if In_Package /= No_Package then
929
 
930
         --  First, look if there is an array element that fits
931
 
932
         The_Array :=
933
           Value_Of
934
             (Name      => Attribute_Or_Array_Name,
935
              In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
936
              Shared    => Shared);
937
         The_Attribute :=
938
           Value_Of
939
             (Index                  => Name,
940
              Src_Index              => Index,
941
              In_Array               => The_Array,
942
              Shared                 => Shared,
943
              Force_Lower_Case_Index => Force_Lower_Case_Index,
944
              Allow_Wildcards        => Allow_Wildcards);
945
 
946
         --  If there is no array element, look for a variable
947
 
948
         if The_Attribute = Nil_Variable_Value then
949
            The_Attribute :=
950
              Value_Of
951
                (Variable_Name => Attribute_Or_Array_Name,
952
                 In_Variables  => Shared.Packages.Table
953
                   (In_Package).Decl.Attributes,
954
                 Shared        => Shared);
955
         end if;
956
      end if;
957
 
958
      return The_Attribute;
959
   end Value_Of;
960
 
961
   function Value_Of
962
     (Index     : Name_Id;
963
      In_Array  : Name_Id;
964
      In_Arrays : Array_Id;
965
      Shared    : Shared_Project_Tree_Data_Access) return Name_Id
966
   is
967
      Current   : Array_Id;
968
      The_Array : Array_Data;
969
 
970
   begin
971
      Current := In_Arrays;
972
      while Current /= No_Array loop
973
         The_Array := Shared.Arrays.Table (Current);
974
         if The_Array.Name = In_Array then
975
            return Value_Of
976
              (Index, In_Array => The_Array.Value, Shared => Shared);
977
         else
978
            Current := The_Array.Next;
979
         end if;
980
      end loop;
981
 
982
      return No_Name;
983
   end Value_Of;
984
 
985
   function Value_Of
986
     (Name      : Name_Id;
987
      In_Arrays : Array_Id;
988
      Shared    : Shared_Project_Tree_Data_Access) return Array_Element_Id
989
   is
990
      Current   : Array_Id;
991
      The_Array : Array_Data;
992
 
993
   begin
994
      Current := In_Arrays;
995
      while Current /= No_Array loop
996
         The_Array := Shared.Arrays.Table (Current);
997
 
998
         if The_Array.Name = Name then
999
            return The_Array.Value;
1000
         else
1001
            Current := The_Array.Next;
1002
         end if;
1003
      end loop;
1004
 
1005
      return No_Array_Element;
1006
   end Value_Of;
1007
 
1008
   function Value_Of
1009
     (Name        : Name_Id;
1010
      In_Packages : Package_Id;
1011
      Shared      : Shared_Project_Tree_Data_Access) return Package_Id
1012
   is
1013
      Current     : Package_Id;
1014
      The_Package : Package_Element;
1015
 
1016
   begin
1017
      Current := In_Packages;
1018
      while Current /= No_Package loop
1019
         The_Package := Shared.Packages.Table (Current);
1020
         exit when The_Package.Name /= No_Name
1021
           and then The_Package.Name = Name;
1022
         Current := The_Package.Next;
1023
      end loop;
1024
 
1025
      return Current;
1026
   end Value_Of;
1027
 
1028
   function Value_Of
1029
     (Variable_Name : Name_Id;
1030
      In_Variables  : Variable_Id;
1031
      Shared        : Shared_Project_Tree_Data_Access) return Variable_Value
1032
   is
1033
      Current      : Variable_Id;
1034
      The_Variable : Variable;
1035
 
1036
   begin
1037
      Current := In_Variables;
1038
      while Current /= No_Variable loop
1039
         The_Variable := Shared.Variable_Elements.Table (Current);
1040
 
1041
         if Variable_Name = The_Variable.Name then
1042
            return The_Variable.Value;
1043
         else
1044
            Current := The_Variable.Next;
1045
         end if;
1046
      end loop;
1047
 
1048
      return Nil_Variable_Value;
1049
   end Value_Of;
1050
 
1051
   ----------------------------
1052
   -- Write_Source_Info_File --
1053
   ----------------------------
1054
 
1055
   procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1056
      Iter   : Source_Iterator := For_Each_Source (Tree);
1057
      Source : Prj.Source_Id;
1058
      File   : Text_File;
1059
 
1060
   begin
1061
      if Opt.Verbose_Mode then
1062
         Write_Line ("Writing new source info file " &
1063
                     Tree.Source_Info_File_Name.all);
1064
      end if;
1065
 
1066
      Create (File, Tree.Source_Info_File_Name.all);
1067
 
1068
      if not Is_Valid (File) then
1069
         Write_Line ("warning: unable to create source info file """ &
1070
                     Tree.Source_Info_File_Name.all & '"');
1071
         return;
1072
      end if;
1073
 
1074
      loop
1075
         Source := Element (Iter);
1076
         exit when Source = No_Source;
1077
 
1078
         if not Source.Locally_Removed and then
1079
           Source.Replaced_By = No_Source
1080
         then
1081
            --  Project name
1082
 
1083
            Put_Line (File, Get_Name_String (Source.Project.Name));
1084
 
1085
            --  Language name
1086
 
1087
            Put_Line (File, Get_Name_String (Source.Language.Name));
1088
 
1089
            --  Kind
1090
 
1091
            Put_Line (File, Source.Kind'Img);
1092
 
1093
            --  Display path name
1094
 
1095
            Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1096
 
1097
            --  Optional lines:
1098
 
1099
            --  Path name (P=)
1100
 
1101
            if Source.Path.Name /= Source.Path.Display_Name then
1102
               Put (File, "P=");
1103
               Put_Line (File, Get_Name_String (Source.Path.Name));
1104
            end if;
1105
 
1106
            --  Unit name (U=)
1107
 
1108
            if Source.Unit /= No_Unit_Index then
1109
               Put (File, "U=");
1110
               Put_Line (File, Get_Name_String (Source.Unit.Name));
1111
            end if;
1112
 
1113
            --  Multi-source index (I=)
1114
 
1115
            if Source.Index /= 0 then
1116
               Put (File, "I=");
1117
               Put_Line (File, Source.Index'Img);
1118
            end if;
1119
 
1120
            --  Naming exception ("N=T");
1121
 
1122
            if Source.Naming_Exception = Yes then
1123
               Put_Line (File, "N=Y");
1124
 
1125
            elsif Source.Naming_Exception = Inherited then
1126
               Put_Line (File, "N=I");
1127
            end if;
1128
 
1129
            --  Empty line to indicate end of info on this source
1130
 
1131
            Put_Line (File, "");
1132
         end if;
1133
 
1134
         Next (Iter);
1135
      end loop;
1136
 
1137
      Close (File);
1138
   end Write_Source_Info_File;
1139
 
1140
   ---------------
1141
   -- Write_Str --
1142
   ---------------
1143
 
1144
   procedure Write_Str
1145
     (S          : String;
1146
      Max_Length : Positive;
1147
      Separator  : Character)
1148
   is
1149
      First : Positive := S'First;
1150
      Last  : Natural  := S'Last;
1151
 
1152
   begin
1153
      --  Nothing to do for empty strings
1154
 
1155
      if S'Length > 0 then
1156
 
1157
         --  Start on a new line if current line is already longer than
1158
         --  Max_Length.
1159
 
1160
         if Positive (Column) >= Max_Length then
1161
            Write_Eol;
1162
         end if;
1163
 
1164
         --  If length of remainder is longer than Max_Length, we need to
1165
         --  cut the remainder in several lines.
1166
 
1167
         while Positive (Column) + S'Last - First > Max_Length loop
1168
 
1169
            --  Try the maximum length possible
1170
 
1171
            Last := First + Max_Length - Positive (Column);
1172
 
1173
            --  Look for last Separator in the line
1174
 
1175
            while Last >= First and then S (Last) /= Separator loop
1176
               Last := Last - 1;
1177
            end loop;
1178
 
1179
            --  If we do not find a separator, we output the maximum length
1180
            --  possible.
1181
 
1182
            if Last < First then
1183
               Last := First + Max_Length - Positive (Column);
1184
            end if;
1185
 
1186
            Write_Line (S (First .. Last));
1187
 
1188
            --  Set the beginning of the new remainder
1189
 
1190
            First := Last + 1;
1191
         end loop;
1192
 
1193
         --  What is left goes to the buffer, without EOL
1194
 
1195
         Write_Str (S (First .. S'Last));
1196
      end if;
1197
   end Write_Str;
1198
end Prj.Util;

powered by: WebSVN 2.1.0

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