aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/butil.adb
blob: 77ed12c8295e84f89cd07d0a87da273145261069 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                B U T I L                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2024, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;
with Opt;    use Opt;
with Output; use Output;

with GNAT; use GNAT;

with System.OS_Lib; use System.OS_Lib;

package body Butil is

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator);
   --  Parse the name of the next available unit accessible through iterator
   --  Iter and save it in the iterator.

   function Read_Forced_Elab_Order_File return String_Ptr;
   --  Read the contents of the forced-elaboration-order file supplied to the
   --  binder via switch -f and return them as a string. Return null if the
   --  file is not available.

   --------------
   -- Has_Next --
   --------------

   function Has_Next (Iter : Forced_Units_Iterator) return Boolean is
   begin
      return Present (Iter.Unit_Name);
   end Has_Next;

   ----------------------
   -- Is_Internal_Unit --
   ----------------------

   --  Note: the reason we do not use the Fname package for this function
   --  is that it would drag too much junk into the binder.

   function Is_Internal_Unit return Boolean is
   begin
      return Is_Predefined_Unit
        or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%"
                                          or else
                                        Name_Buffer (1 .. 5) = "gnat."));
   end Is_Internal_Unit;

   ------------------------
   -- Is_Predefined_Unit --
   ------------------------

   --  Note: the reason we do not use the Fname package for this function
   --  is that it would drag too much junk into the binder.

   function Is_Predefined_Unit return Boolean is
      L : Natural renames Name_Len;
      B : String  renames Name_Buffer;
   begin
      return    (L >  3 and then B (1 ..  4) = "ada.")
        or else (L >  6 and then B (1 ..  7) = "system.")
        or else (L > 10 and then B (1 .. 11) = "interfaces.")
        or else (L >  3 and then B (1 ..  4) = "ada%")
        or else (L >  8 and then B (1 ..  9) = "calendar%")
        or else (L >  9 and then B (1 .. 10) = "direct_io%")
        or else (L > 10 and then B (1 .. 11) = "interfaces%")
        or else (L > 13 and then B (1 .. 14) = "io_exceptions%")
        or else (L > 12 and then B (1 .. 13) = "machine_code%")
        or else (L > 13 and then B (1 .. 14) = "sequential_io%")
        or else (L >  6 and then B (1 ..  7) = "system%")
        or else (L >  7 and then B (1 ..  8) = "text_io%")
        or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%")
        or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%")
        or else (L >  4 and then B (1 ..  5) = "gnat%")
        or else (L >  4 and then B (1 ..  5) = "gnat.");
   end Is_Predefined_Unit;

   --------------------------
   -- Iterate_Forced_Units --
   --------------------------

   function Iterate_Forced_Units return Forced_Units_Iterator is
      Iter : Forced_Units_Iterator;

   begin
      Iter.Order := Read_Forced_Elab_Order_File;
      Parse_Next_Unit_Name (Iter);

      return Iter;
   end Iterate_Forced_Units;

   ----------
   -- Next --
   ----------

   procedure Next
     (Iter      : in out Forced_Units_Iterator;
      Unit_Name : out Unit_Name_Type;
      Unit_Line : out Logical_Line_Number)
   is
   begin
      if not Has_Next (Iter) then
         raise Iterator_Exhausted;
      end if;

      Unit_Line := Iter.Unit_Line;
      Unit_Name := Iter.Unit_Name;
      pragma Assert (Present (Unit_Name));

      Parse_Next_Unit_Name (Iter);
   end Next;

   --------------------------
   -- Parse_Next_Unit_Name --
   --------------------------

   procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is
      Body_Suffix : constant String   := " (body)";
      Body_Type   : constant String   := "%b";
      Body_Length : constant Positive := Body_Suffix'Length;
      Body_Offset : constant Natural  := Body_Length - 1;

      Comment_Header : constant String  := "--";
      Comment_Offset : constant Natural := Comment_Header'Length - 1;

      Spec_Suffix : constant String   := " (spec)";
      Spec_Type   : constant String   := "%s";
      Spec_Length : constant Positive := Spec_Suffix'Length;
      Spec_Offset : constant Natural  := Spec_Length - 1;

      Index : Positive            renames Iter.Order_Index;
      Line  : Logical_Line_Number renames Iter.Order_Line;
      Order : String_Ptr          renames Iter.Order;

      function At_Comment return Boolean;
      pragma Inline (At_Comment);
      --  Determine whether iterator Iter is positioned over the start of a
      --  comment.

      function At_Terminator return Boolean;
      pragma Inline (At_Terminator);
      --  Determine whether iterator Iter is positioned over a line terminator
      --  character.

      function At_Whitespace return Boolean;
      pragma Inline (At_Whitespace);
      --  Determine whether iterator Iter is positioned over a whitespace
      --  character.

      function Is_Terminator (C : Character) return Boolean;
      pragma Inline (Is_Terminator);
      --  Determine whether character C denotes a line terminator

      function Is_Whitespace (C : Character) return Boolean;
      pragma Inline (Is_Whitespace);
      --  Determine whether character C denotes a whitespace

      procedure Parse_Unit_Name;
      pragma Inline (Parse_Unit_Name);
      --  Find and parse the first available unit name

      procedure Skip_Comment;
      pragma Inline (Skip_Comment);
      --  Skip a comment by reaching a line terminator

      procedure Skip_Terminator;
      pragma Inline (Skip_Terminator);
      --  Skip a line terminator and deal with the logical line numbering

      procedure Skip_Whitespace;
      pragma Inline (Skip_Whitespace);
      --  Skip whitespace

      function Within_Order
        (Low_Offset  : Natural := 0;
         High_Offset : Natural := 0) return Boolean;
      pragma Inline (Within_Order);
      --  Determine whether index of iterator Iter is still within the range of
      --  the order string. Low_Offset may be used to inspect the area that is
      --  less than the index. High_Offset may be used to inspect the area that
      --  is greater than the index.

      ----------------
      -- At_Comment --
      ----------------

      function At_Comment return Boolean is
      begin
         --  The interator is over a comment when the index is positioned over
         --  the start of a comment header.
         --
         --    unit (spec)  --  comment
         --                 ^
         --                 Index

         return
           Within_Order (High_Offset => Comment_Offset)
             and then Order (Index .. Index + Comment_Offset) = Comment_Header;
      end At_Comment;

      -------------------
      -- At_Terminator --
      -------------------

      function At_Terminator return Boolean is
      begin
         return Within_Order and then Is_Terminator (Order (Index));
      end At_Terminator;

      -------------------
      -- At_Whitespace --
      -------------------

      function At_Whitespace return Boolean is
      begin
         return Within_Order and then Is_Whitespace (Order (Index));
      end At_Whitespace;

      -------------------
      -- Is_Terminator --
      -------------------

      function Is_Terminator (C : Character) return Boolean is
      begin
         --  Carriage return is treated intentionally as whitespace since it
         --  appears only on certain targets, while line feed is consistent on
         --  all of them.

         return C = ASCII.LF;
      end Is_Terminator;

      -------------------
      -- Is_Whitespace --
      -------------------

      function Is_Whitespace (C : Character) return Boolean is
      begin
         return
           C = ' '
             or else C = ASCII.CR   --  carriage return
             or else C = ASCII.FF   --  form feed
             or else C = ASCII.HT   --  horizontal tab
             or else C = ASCII.VT;  --  vertical tab
      end Is_Whitespace;

      ---------------------
      -- Parse_Unit_Name --
      ---------------------

      procedure Parse_Unit_Name is
         pragma Assert (not At_Comment);
         pragma Assert (not At_Terminator);
         pragma Assert (not At_Whitespace);
         pragma Assert (Within_Order);

         procedure Find_End_Index_Of_Unit_Name;
         pragma Inline (Find_End_Index_Of_Unit_Name);
         --  Position the index of iterator Iter at the last character of the
         --  first available unit name.

         ---------------------------------
         -- Find_End_Index_Of_Unit_Name --
         ---------------------------------

         procedure Find_End_Index_Of_Unit_Name is
         begin
            --  At this point the index points at the start of a unit name. The
            --  unit name may be legal, in which case it appears as:
            --
            --    unit (body)
            --
            --  However, it may also be illegal:
            --
            --    unit without suffix
            --    unit with multiple prefixes (spec)
            --
            --  In order to handle both forms, find the construct following the
            --  unit name. This is either a comment, a terminator, or the end
            --  of the order:
            --
            --    unit (body)    --  comment
            --    unit without suffix    <terminator>
            --    unit with multiple prefixes (spec)<end of order>
            --
            --  Once the construct is found, truncate the unit name by skipping
            --  all white space between the construct and the end of the unit
            --  name.

            --  Find the construct that follows the unit name

            while Within_Order loop
               if At_Comment then
                  exit;

               elsif At_Terminator then
                  exit;
               end if;

               Index := Index + 1;
            end loop;

            --  Position the index prior to the construct that follows the unit
            --  name.

            Index := Index - 1;

            --  Truncate towards the end of the unit name

            while Within_Order loop
               if At_Whitespace then
                  Index := Index - 1;
               else
                  exit;
               end if;
            end loop;
         end Find_End_Index_Of_Unit_Name;

         --  Local variables

         Start_Index : constant Positive := Index;

         End_Index : Positive;
         Is_Body   : Boolean := False;
         Is_Spec   : Boolean := False;

      --  Start of processing for Parse_Unit_Name

      begin
         Find_End_Index_Of_Unit_Name;
         End_Index := Index;

         pragma Assert (Start_Index <= End_Index);

         --  At this point the indices are positioned as follows:
         --
         --              End_Index
         --              Index
         --              v
         --    unit (spec)     --  comment
         --    ^
         --    Start_Index

         --  Rewind the index, skipping over the legal suffixes
         --
         --    Index     End_Index
         --        v     v
         --    unit (spec)     --  comment
         --    ^
         --    Start_Index

         if Within_Order (Low_Offset => Body_Offset)
           and then Order (Index - Body_Offset .. Index) = Body_Suffix
         then
            Is_Body := True;
            Index   := Index - Body_Length;

         elsif Within_Order (Low_Offset => Spec_Offset)
           and then Order (Index - Spec_Offset .. Index) = Spec_Suffix
         then
            Is_Spec := True;
            Index   := Index - Spec_Length;
         end if;

         --  Capture the line where the unit name is defined

         Iter.Unit_Line := Line;

         --  Transform the unit name to match the format recognized by the
         --  name table.

         if Is_Body then
            Iter.Unit_Name :=
              Name_Find (Order (Start_Index .. Index) & Body_Type);

         elsif Is_Spec then
            Iter.Unit_Name :=
              Name_Find (Order (Start_Index .. Index) & Spec_Type);

         --  Otherwise the unit name is illegal, so leave it as is

         else
            Iter.Unit_Name := Name_Find (Order (Start_Index .. Index));
         end if;

         --  Advance the index past the unit name
         --
         --      End_IndexIndex
         --              vv
         --    unit (spec)     --  comment
         --    ^
         --    Start_Index

         Index := End_Index + 1;
      end Parse_Unit_Name;

      ------------------
      -- Skip_Comment --
      ------------------

      procedure Skip_Comment is
      begin
         pragma Assert (At_Comment);

         while Within_Order loop
            if At_Terminator then
               exit;
            end if;

            Index := Index + 1;
         end loop;
      end Skip_Comment;

      ---------------------
      -- Skip_Terminator --
      ---------------------

      procedure Skip_Terminator is
      begin
         pragma Assert (At_Terminator);

         Index := Index + 1;
         Line  := Line  + 1;
      end Skip_Terminator;

      ---------------------
      -- Skip_Whitespace --
      ---------------------

      procedure Skip_Whitespace is
      begin
         while Within_Order loop
            if At_Whitespace then
               Index := Index + 1;
            else
               exit;
            end if;
         end loop;
      end Skip_Whitespace;

      ------------------
      -- Within_Order --
      ------------------

      function Within_Order
        (Low_Offset  : Natural := 0;
         High_Offset : Natural := 0) return Boolean
      is
      begin
         return
           Order /= null
             and then Index - Low_Offset  >= Order'First
             and then Index + High_Offset <= Order'Last;
      end Within_Order;

   --  Start of processing for Parse_Next_Unit_Name

   begin
      --  A line in the forced-elaboration-order file has the following
      --  grammar:
      --
      --    LINE ::=
      --      [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR
      --
      --    WHITESPACE ::=
      --      <any whitespace character>
      --    | <carriage return>
      --
      --    UNIT_NAME ::=
      --      UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX
      --
      --    UNIT_PREFIX ::=
      --      <any string>
      --
      --    UNIT_SUFFIX ::=
      --      (body)
      --    | (spec)
      --
      --    COMMENT ::=
      --      --  <any string>
      --
      --    TERMINATOR ::=
      --      <line feed>
      --      <end of file>
      --
      --  Items in <> brackets are semantic notions

      --  Assume that the order has no remaining units

      Iter.Unit_Line := No_Line_Number;
      Iter.Unit_Name := No_Unit_Name;

      --  Try to find the first available unit name from the current position
      --  of iteration.

      while Within_Order loop
         Skip_Whitespace;

         if At_Comment then
            Skip_Comment;

         elsif not Within_Order then
            exit;

         elsif At_Terminator then
            Skip_Terminator;

         else
            Parse_Unit_Name;
            exit;
         end if;
      end loop;
   end Parse_Next_Unit_Name;

   ---------------------------------
   -- Read_Forced_Elab_Order_File --
   ---------------------------------

   function Read_Forced_Elab_Order_File return String_Ptr is
      procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);

      Descr    : File_Descriptor;
      Len      : Natural;
      Len_Read : Natural;
      Result   : String_Ptr;
      Success  : Boolean;

   begin
      if Force_Elab_Order_File = null then
         return null;
      end if;

      --  Obtain and sanitize a descriptor to the elaboration-order file

      Descr := Open_Read (Force_Elab_Order_File.all, Binary);

      if Descr = Invalid_FD then
         return null;
      end if;

      --  Determine the size of the file, allocate a result large enough to
      --  house its contents, and read it.

      Len := Natural (File_Length (Descr));

      if Len = 0 then
         return null;
      end if;

      Result   := new String (1 .. Len);
      Len_Read := Read (Descr, Result (1)'Address, Len);

      --  The read failed to acquire the whole content of the file

      if Len_Read /= Len then
         Free (Result);
         return null;
      end if;

      Close (Descr, Success);

      --  The file failed to close

      if not Success then
         Free (Result);
         return null;
      end if;

      return Result;
   end Read_Forced_Elab_Order_File;

   ----------------
   -- Uname_Less --
   ----------------

   function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
   begin
      Get_Name_String (U1);

      declare
         U1_Name : constant String (1 .. Name_Len) :=
                     Name_Buffer (1 .. Name_Len);
         Min_Length : Natural;

      begin
         Get_Name_String (U2);

         if Name_Len < U1_Name'Last then
            Min_Length := Name_Len;
         else
            Min_Length := U1_Name'Last;
         end if;

         for J in 1 .. Min_Length loop
            if U1_Name (J) > Name_Buffer (J) then
               return False;
            elsif U1_Name (J) < Name_Buffer (J) then
               return True;
            end if;
         end loop;

         return U1_Name'Last < Name_Len;
      end;
   end Uname_Less;

   ---------------------
   -- Write_Unit_Name --
   ---------------------

   procedure Write_Unit_Name (U : Unit_Name_Type) is
   begin
      Get_Name_String (U);
      Write_Str (Name_Buffer (1 .. Name_Len - 2));

      if Name_Buffer (Name_Len) = 's' then
         Write_Str (" (spec)");
      else
         Write_Str (" (body)");
      end if;

      Name_Len := Name_Len + 5;
   end Write_Unit_Name;

end Butil;