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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sinput.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
--                               S I N P U T                                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
pragma Style_Checks (All_Checks);
33
--  Subprograms not all in alpha order
34
 
35
with Atree;    use Atree;
36
with Debug;    use Debug;
37
with Opt;      use Opt;
38
with Output;   use Output;
39
with Scans;    use Scans;
40
with Tree_IO;  use Tree_IO;
41
with Widechar; use Widechar;
42
 
43
with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
44
 
45
with System;         use System;
46
with System.Memory;
47
with System.WCh_Con; use System.WCh_Con;
48
 
49
with Unchecked_Conversion;
50
with Unchecked_Deallocation;
51
 
52
package body Sinput is
53
 
54
   use ASCII;
55
   --  Make control characters visible
56
 
57
   First_Time_Around : Boolean := True;
58
   --  This needs a comment ???
59
 
60
   --  Routines to support conversion between types Lines_Table_Ptr,
61
   --  Logical_Lines_Table_Ptr and System.Address.
62
 
63
   pragma Warnings (Off);
64
   --  These unchecked conversions are aliasing safe, since they are never
65
   --  used to construct improperly aliased pointer values.
66
 
67
   function To_Address is
68
     new Unchecked_Conversion (Lines_Table_Ptr, Address);
69
 
70
   function To_Address is
71
     new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
72
 
73
   function To_Pointer is
74
     new Unchecked_Conversion (Address, Lines_Table_Ptr);
75
 
76
   function To_Pointer is
77
     new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
78
 
79
   pragma Warnings (On);
80
 
81
   ---------------------------
82
   -- Add_Line_Tables_Entry --
83
   ---------------------------
84
 
85
   procedure Add_Line_Tables_Entry
86
     (S : in out Source_File_Record;
87
      P : Source_Ptr)
88
   is
89
      LL : Physical_Line_Number;
90
 
91
   begin
92
      --  Reallocate the lines tables if necessary
93
 
94
      --  Note: the reason we do not use the normal Table package
95
      --  mechanism is that we have several of these tables. We could
96
      --  use the new GNAT.Dynamic_Tables package and that would probably
97
      --  be a good idea ???
98
 
99
      if S.Last_Source_Line = S.Lines_Table_Max then
100
         Alloc_Line_Tables
101
           (S,
102
            Int (S.Last_Source_Line) *
103
              ((100 + Alloc.Lines_Increment) / 100));
104
 
105
         if Debug_Flag_D then
106
            Write_Str ("--> Reallocating lines table, size = ");
107
            Write_Int (Int (S.Lines_Table_Max));
108
            Write_Eol;
109
         end if;
110
      end if;
111
 
112
      S.Last_Source_Line := S.Last_Source_Line + 1;
113
      LL := S.Last_Source_Line;
114
 
115
      S.Lines_Table (LL) := P;
116
 
117
      --  Deal with setting new entry in logical lines table if one is
118
      --  present. Note that there is always space (because the call to
119
      --  Alloc_Line_Tables makes sure both tables are the same length),
120
 
121
      if S.Logical_Lines_Table /= null then
122
 
123
         --  We can always set the entry from the previous one, because
124
         --  the processing for a Source_Reference pragma ensures that
125
         --  at least one entry following the pragma is set up correctly.
126
 
127
         S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
128
      end if;
129
   end Add_Line_Tables_Entry;
130
 
131
   -----------------------
132
   -- Alloc_Line_Tables --
133
   -----------------------
134
 
135
   procedure Alloc_Line_Tables
136
     (S       : in out Source_File_Record;
137
      New_Max : Nat)
138
   is
139
      subtype size_t is Memory.size_t;
140
 
141
      New_Table : Lines_Table_Ptr;
142
 
143
      New_Logical_Table : Logical_Lines_Table_Ptr;
144
 
145
      New_Size : constant size_t :=
146
                   size_t (New_Max * Lines_Table_Type'Component_Size /
147
                                                             Storage_Unit);
148
 
149
   begin
150
      if S.Lines_Table = null then
151
         New_Table := To_Pointer (Memory.Alloc (New_Size));
152
 
153
      else
154
         New_Table :=
155
           To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
156
      end if;
157
 
158
      if New_Table = null then
159
         raise Storage_Error;
160
      else
161
         S.Lines_Table     := New_Table;
162
         S.Lines_Table_Max := Physical_Line_Number (New_Max);
163
      end if;
164
 
165
      if S.Num_SRef_Pragmas /= 0 then
166
         if S.Logical_Lines_Table = null then
167
            New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
168
         else
169
            New_Logical_Table := To_Pointer
170
              (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
171
         end if;
172
 
173
         if New_Logical_Table = null then
174
            raise Storage_Error;
175
         else
176
            S.Logical_Lines_Table := New_Logical_Table;
177
         end if;
178
      end if;
179
   end Alloc_Line_Tables;
180
 
181
   -----------------
182
   -- Backup_Line --
183
   -----------------
184
 
185
   procedure Backup_Line (P : in out Source_Ptr) is
186
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
187
      Src    : constant Source_Buffer_Ptr :=
188
                 Source_File.Table (Sindex).Source_Text;
189
      Sfirst : constant Source_Ptr :=
190
                 Source_File.Table (Sindex).Source_First;
191
 
192
   begin
193
      P := P - 1;
194
 
195
      if P = Sfirst then
196
         return;
197
      end if;
198
 
199
      if Src (P) = CR then
200
         if Src (P - 1) = LF then
201
            P := P - 1;
202
         end if;
203
 
204
      else -- Src (P) = LF
205
         if Src (P - 1) = CR then
206
            P := P - 1;
207
         end if;
208
      end if;
209
 
210
      --  Now find first character of the previous line
211
 
212
      while P > Sfirst
213
        and then Src (P - 1) /= LF
214
        and then Src (P - 1) /= CR
215
      loop
216
         P := P - 1;
217
      end loop;
218
   end Backup_Line;
219
 
220
   ---------------------------
221
   -- Build_Location_String --
222
   ---------------------------
223
 
224
   procedure Build_Location_String (Loc : Source_Ptr) is
225
      Ptr : Source_Ptr;
226
 
227
   begin
228
      --  Loop through instantiations
229
 
230
      Ptr := Loc;
231
      loop
232
         Get_Name_String_And_Append
233
           (Reference_Name (Get_Source_File_Index (Ptr)));
234
         Add_Char_To_Name_Buffer (':');
235
         Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr)));
236
 
237
         Ptr := Instantiation_Location (Ptr);
238
         exit when Ptr = No_Location;
239
         Add_Str_To_Name_Buffer (" instantiated at ");
240
      end loop;
241
 
242
      Name_Buffer (Name_Len + 1) := NUL;
243
      return;
244
   end Build_Location_String;
245
 
246
   function Build_Location_String (Loc : Source_Ptr) return String is
247
   begin
248
      Name_Len := 0;
249
      Build_Location_String (Loc);
250
      return Name_Buffer (1 .. Name_Len);
251
   end Build_Location_String;
252
 
253
   -------------------
254
   -- Check_For_BOM --
255
   -------------------
256
 
257
   procedure Check_For_BOM is
258
      BOM : BOM_Kind;
259
      Len : Natural;
260
      Tst : String (1 .. 5);
261
 
262
   begin
263
      for J in 1 .. 5 loop
264
         Tst (J) := Source (Scan_Ptr + Source_Ptr (J) - 1);
265
      end loop;
266
 
267
      Read_BOM (Tst, Len, BOM, False);
268
 
269
      case BOM is
270
         when UTF8_All =>
271
            Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
272
            Wide_Character_Encoding_Method := WCEM_UTF8;
273
            Upper_Half_Encoding := True;
274
 
275
         when UTF16_LE | UTF16_BE =>
276
            Set_Standard_Error;
277
            Write_Line ("UTF-16 encoding format not recognized");
278
            Set_Standard_Output;
279
            raise Unrecoverable_Error;
280
 
281
         when UTF32_LE | UTF32_BE =>
282
            Set_Standard_Error;
283
            Write_Line ("UTF-32 encoding format not recognized");
284
            Set_Standard_Output;
285
            raise Unrecoverable_Error;
286
 
287
         when Unknown =>
288
            null;
289
 
290
         when others =>
291
            raise Program_Error;
292
      end case;
293
   end Check_For_BOM;
294
 
295
   -----------------------
296
   -- Get_Column_Number --
297
   -----------------------
298
 
299
   function Get_Column_Number (P : Source_Ptr) return Column_Number is
300
      S      : Source_Ptr;
301
      C      : Column_Number;
302
      Sindex : Source_File_Index;
303
      Src    : Source_Buffer_Ptr;
304
 
305
   begin
306
      --  If the input source pointer is not a meaningful value then return
307
      --  at once with column number 1. This can happen for a file not found
308
      --  condition for a file loaded indirectly by RTE, and also perhaps on
309
      --  some unknown internal error conditions. In either case we certainly
310
      --  don't want to blow up.
311
 
312
      if P < 1 then
313
         return 1;
314
 
315
      else
316
         Sindex := Get_Source_File_Index (P);
317
         Src := Source_File.Table (Sindex).Source_Text;
318
         S := Line_Start (P);
319
         C := 1;
320
 
321
         while S < P loop
322
            if Src (S) = HT then
323
               C := (C - 1) / 8 * 8 + (8 + 1);
324
            else
325
               C := C + 1;
326
            end if;
327
 
328
            S := S + 1;
329
         end loop;
330
 
331
         return C;
332
      end if;
333
   end Get_Column_Number;
334
 
335
   -----------------------------
336
   -- Get_Logical_Line_Number --
337
   -----------------------------
338
 
339
   function Get_Logical_Line_Number
340
     (P : Source_Ptr) return Logical_Line_Number
341
   is
342
      SFR : Source_File_Record
343
              renames Source_File.Table (Get_Source_File_Index (P));
344
 
345
      L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
346
 
347
   begin
348
      if SFR.Num_SRef_Pragmas = 0 then
349
         return Logical_Line_Number (L);
350
      else
351
         return SFR.Logical_Lines_Table (L);
352
      end if;
353
   end Get_Logical_Line_Number;
354
 
355
   ---------------------------------
356
   -- Get_Logical_Line_Number_Img --
357
   ---------------------------------
358
 
359
   function Get_Logical_Line_Number_Img
360
     (P : Source_Ptr) return String
361
   is
362
   begin
363
      Name_Len := 0;
364
      Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
365
      return Name_Buffer (1 .. Name_Len);
366
   end Get_Logical_Line_Number_Img;
367
 
368
   ------------------------------
369
   -- Get_Physical_Line_Number --
370
   ------------------------------
371
 
372
   function Get_Physical_Line_Number
373
     (P : Source_Ptr) return Physical_Line_Number
374
   is
375
      Sfile : Source_File_Index;
376
      Table : Lines_Table_Ptr;
377
      Lo    : Physical_Line_Number;
378
      Hi    : Physical_Line_Number;
379
      Mid   : Physical_Line_Number;
380
      Loc   : Source_Ptr;
381
 
382
   begin
383
      --  If the input source pointer is not a meaningful value then return
384
      --  at once with line number 1. This can happen for a file not found
385
      --  condition for a file loaded indirectly by RTE, and also perhaps on
386
      --  some unknown internal error conditions. In either case we certainly
387
      --  don't want to blow up.
388
 
389
      if P < 1 then
390
         return 1;
391
 
392
      --  Otherwise we can do the binary search
393
 
394
      else
395
         Sfile := Get_Source_File_Index (P);
396
         Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
397
         Table := Source_File.Table (Sfile).Lines_Table;
398
         Lo    := 1;
399
         Hi    := Source_File.Table (Sfile).Last_Source_Line;
400
 
401
         loop
402
            Mid := (Lo + Hi) / 2;
403
 
404
            if Loc < Table (Mid) then
405
               Hi := Mid - 1;
406
 
407
            else -- Loc >= Table (Mid)
408
 
409
               if Mid = Hi or else
410
                  Loc < Table (Mid + 1)
411
               then
412
                  return Mid;
413
               else
414
                  Lo := Mid + 1;
415
               end if;
416
 
417
            end if;
418
 
419
         end loop;
420
      end if;
421
   end Get_Physical_Line_Number;
422
 
423
   ---------------------------
424
   -- Get_Source_File_Index --
425
   ---------------------------
426
 
427
   Source_Cache_First : Source_Ptr := 1;
428
   Source_Cache_Last  : Source_Ptr := 0;
429
   --  Records the First and Last subscript values for the most recently
430
   --  referenced entry in the source table, to optimize the common case of
431
   --  repeated references to the same entry. The initial values force an
432
   --  initial search to set the cache value.
433
 
434
   Source_Cache_Index : Source_File_Index := No_Source_File;
435
   --  Contains the index of the entry corresponding to Source_Cache
436
 
437
   function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
438
   begin
439
      if S in Source_Cache_First .. Source_Cache_Last then
440
         return Source_Cache_Index;
441
 
442
      else
443
         pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size)
444
                          /=
445
                        No_Source_File);
446
         for J in Source_File_Index_Table (Int (S) / Chunk_Size)
447
                                                    .. Source_File.Last
448
         loop
449
            if S in Source_File.Table (J).Source_First ..
450
                    Source_File.Table (J).Source_Last
451
            then
452
               Source_Cache_Index := J;
453
               Source_Cache_First :=
454
                 Source_File.Table (Source_Cache_Index).Source_First;
455
               Source_Cache_Last :=
456
                 Source_File.Table (Source_Cache_Index).Source_Last;
457
               return Source_Cache_Index;
458
            end if;
459
         end loop;
460
      end if;
461
 
462
      --  We must find a matching entry in the above loop!
463
 
464
      raise Program_Error;
465
   end Get_Source_File_Index;
466
 
467
   ----------------
468
   -- Initialize --
469
   ----------------
470
 
471
   procedure Initialize is
472
   begin
473
      Source_Cache_First := 1;
474
      Source_Cache_Last  := 0;
475
      Source_Cache_Index := No_Source_File;
476
      Source_gnat_adc    := No_Source_File;
477
      First_Time_Around  := True;
478
 
479
      Source_File.Init;
480
   end Initialize;
481
 
482
   -------------------------
483
   -- Instantiation_Depth --
484
   -------------------------
485
 
486
   function Instantiation_Depth (S : Source_Ptr) return Nat is
487
      Sind  : Source_File_Index;
488
      Sval  : Source_Ptr;
489
      Depth : Nat;
490
 
491
   begin
492
      Sval := S;
493
      Depth := 0;
494
 
495
      loop
496
         Sind := Get_Source_File_Index (Sval);
497
         Sval := Instantiation (Sind);
498
         exit when Sval = No_Location;
499
         Depth := Depth + 1;
500
      end loop;
501
 
502
      return Depth;
503
   end Instantiation_Depth;
504
 
505
   ----------------------------
506
   -- Instantiation_Location --
507
   ----------------------------
508
 
509
   function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
510
   begin
511
      return Instantiation (Get_Source_File_Index (S));
512
   end Instantiation_Location;
513
 
514
   ----------------------
515
   -- Last_Source_File --
516
   ----------------------
517
 
518
   function Last_Source_File return Source_File_Index is
519
   begin
520
      return Source_File.Last;
521
   end Last_Source_File;
522
 
523
   ----------------
524
   -- Line_Start --
525
   ----------------
526
 
527
   function Line_Start (P : Source_Ptr) return Source_Ptr is
528
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
529
      Src    : constant Source_Buffer_Ptr :=
530
                 Source_File.Table (Sindex).Source_Text;
531
      Sfirst : constant Source_Ptr :=
532
                 Source_File.Table (Sindex).Source_First;
533
      S      : Source_Ptr;
534
 
535
   begin
536
      S := P;
537
      while S > Sfirst
538
        and then Src (S - 1) /= CR
539
        and then Src (S - 1) /= LF
540
      loop
541
         S := S - 1;
542
      end loop;
543
 
544
      return S;
545
   end Line_Start;
546
 
547
   function Line_Start
548
     (L : Physical_Line_Number;
549
      S : Source_File_Index) return Source_Ptr
550
   is
551
   begin
552
      return Source_File.Table (S).Lines_Table (L);
553
   end Line_Start;
554
 
555
   ----------
556
   -- Lock --
557
   ----------
558
 
559
   procedure Lock is
560
   begin
561
      Source_File.Locked := True;
562
      Source_File.Release;
563
   end Lock;
564
 
565
   ----------------------
566
   -- Num_Source_Files --
567
   ----------------------
568
 
569
   function Num_Source_Files return Nat is
570
   begin
571
      return Int (Source_File.Last) - Int (Source_File.First) + 1;
572
   end Num_Source_Files;
573
 
574
   ----------------------
575
   -- Num_Source_Lines --
576
   ----------------------
577
 
578
   function Num_Source_Lines (S : Source_File_Index) return Nat is
579
   begin
580
      return Nat (Source_File.Table (S).Last_Source_Line);
581
   end Num_Source_Lines;
582
 
583
   -----------------------
584
   -- Original_Location --
585
   -----------------------
586
 
587
   function Original_Location (S : Source_Ptr) return Source_Ptr is
588
      Sindex : Source_File_Index;
589
      Tindex : Source_File_Index;
590
 
591
   begin
592
      if S <= No_Location then
593
         return S;
594
 
595
      else
596
         Sindex := Get_Source_File_Index (S);
597
 
598
         if Instantiation (Sindex) = No_Location then
599
            return S;
600
 
601
         else
602
            Tindex := Template (Sindex);
603
            while Instantiation (Tindex) /= No_Location loop
604
               Tindex := Template (Tindex);
605
            end loop;
606
 
607
            return S - Source_First (Sindex) + Source_First (Tindex);
608
         end if;
609
      end if;
610
   end Original_Location;
611
 
612
   -------------------------
613
   -- Physical_To_Logical --
614
   -------------------------
615
 
616
   function Physical_To_Logical
617
     (Line : Physical_Line_Number;
618
      S    : Source_File_Index) return Logical_Line_Number
619
   is
620
      SFR : Source_File_Record renames Source_File.Table (S);
621
 
622
   begin
623
      if SFR.Num_SRef_Pragmas = 0 then
624
         return Logical_Line_Number (Line);
625
      else
626
         return SFR.Logical_Lines_Table (Line);
627
      end if;
628
   end Physical_To_Logical;
629
 
630
   --------------------------------
631
   -- Register_Source_Ref_Pragma --
632
   --------------------------------
633
 
634
   procedure Register_Source_Ref_Pragma
635
     (File_Name          : File_Name_Type;
636
      Stripped_File_Name : File_Name_Type;
637
      Mapped_Line        : Nat;
638
      Line_After_Pragma  : Physical_Line_Number)
639
   is
640
      subtype size_t is Memory.size_t;
641
 
642
      SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
643
 
644
      ML : Logical_Line_Number;
645
 
646
   begin
647
      if File_Name /= No_File then
648
         SFR.Reference_Name := Stripped_File_Name;
649
         SFR.Full_Ref_Name  := File_Name;
650
 
651
         if not Debug_Generated_Code then
652
            SFR.Debug_Source_Name := Stripped_File_Name;
653
            SFR.Full_Debug_Name   := File_Name;
654
         end if;
655
 
656
         SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
657
      end if;
658
 
659
      if SFR.Num_SRef_Pragmas = 1 then
660
         SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
661
      end if;
662
 
663
      if SFR.Logical_Lines_Table = null then
664
         SFR.Logical_Lines_Table := To_Pointer
665
           (Memory.Alloc
666
             (size_t (SFR.Lines_Table_Max *
667
                        Logical_Lines_Table_Type'Component_Size /
668
                                                        Storage_Unit)));
669
      end if;
670
 
671
      SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
672
 
673
      ML := Logical_Line_Number (Mapped_Line);
674
      for J in Line_After_Pragma .. SFR.Last_Source_Line loop
675
         SFR.Logical_Lines_Table (J) := ML;
676
         ML := ML + 1;
677
      end loop;
678
   end Register_Source_Ref_Pragma;
679
 
680
   ---------------------------------
681
   -- Set_Source_File_Index_Table --
682
   ---------------------------------
683
 
684
   procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
685
      Ind : Int;
686
      SP  : Source_Ptr;
687
      SL  : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
688
 
689
   begin
690
      SP  := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
691
                                                    / Chunk_Size * Chunk_Size;
692
      Ind := Int (SP) / Chunk_Size;
693
 
694
      while SP <= SL loop
695
         Source_File_Index_Table (Ind) := Xnew;
696
         SP := SP + Chunk_Size;
697
         Ind := Ind + 1;
698
      end loop;
699
   end Set_Source_File_Index_Table;
700
 
701
   ---------------------------
702
   -- Skip_Line_Terminators --
703
   ---------------------------
704
 
705
   procedure Skip_Line_Terminators
706
     (P        : in out Source_Ptr;
707
      Physical : out Boolean)
708
   is
709
      Chr : constant Character := Source (P);
710
 
711
   begin
712
      if Chr = CR then
713
         if Source (P + 1) = LF then
714
            P := P + 2;
715
         else
716
            P := P + 1;
717
         end if;
718
 
719
      elsif Chr = LF then
720
         P := P + 1;
721
 
722
      elsif Chr = FF or else Chr = VT then
723
         P := P + 1;
724
         Physical := False;
725
         return;
726
 
727
         --  Otherwise we have a wide character
728
 
729
      else
730
         Skip_Wide (Source, P);
731
      end if;
732
 
733
      --  Fall through in the physical line terminator case. First deal with
734
      --  making a possible entry into the lines table if one is needed.
735
 
736
      --  Note: we are dealing with a real source file here, this cannot be
737
      --  the instantiation case, so we need not worry about Sloc adjustment.
738
 
739
      declare
740
         S : Source_File_Record
741
               renames Source_File.Table (Current_Source_File);
742
 
743
      begin
744
         Physical := True;
745
 
746
         --  Make entry in lines table if not already made (in some scan backup
747
         --  cases, we will be rescanning previously scanned source, so the
748
         --  entry may have already been made on the previous forward scan).
749
 
750
         if Source (P) /= EOF
751
           and then P > S.Lines_Table (S.Last_Source_Line)
752
         then
753
            Add_Line_Tables_Entry (S, P);
754
         end if;
755
      end;
756
   end Skip_Line_Terminators;
757
 
758
   ----------------
759
   -- Sloc_Range --
760
   ----------------
761
 
762
   procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
763
 
764
      function Process (N : Node_Id) return Traverse_Result;
765
      --  Process function for traversing the node tree
766
 
767
      procedure Traverse is new Traverse_Proc (Process);
768
 
769
      -------------
770
      -- Process --
771
      -------------
772
 
773
      function Process (N : Node_Id) return Traverse_Result is
774
      begin
775
         if Sloc (N) < Min then
776
            if Sloc (N) > No_Location then
777
               Min := Sloc (N);
778
            end if;
779
         elsif Sloc (N) > Max then
780
            if Sloc (N) > No_Location then
781
               Max := Sloc (N);
782
            end if;
783
         end if;
784
 
785
         return OK;
786
      end Process;
787
 
788
   --  Start of processing for Sloc_Range
789
 
790
   begin
791
      Min := Sloc (N);
792
      Max := Sloc (N);
793
      Traverse (N);
794
   end Sloc_Range;
795
 
796
   -------------------
797
   -- Source_Offset --
798
   -------------------
799
 
800
   function Source_Offset (S : Source_Ptr) return Nat is
801
      Sindex : constant Source_File_Index := Get_Source_File_Index (S);
802
      Sfirst : constant Source_Ptr :=
803
                 Source_File.Table (Sindex).Source_First;
804
   begin
805
      return Nat (S - Sfirst);
806
   end Source_Offset;
807
 
808
   ------------------------
809
   -- Top_Level_Location --
810
   ------------------------
811
 
812
   function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
813
      Oldloc : Source_Ptr;
814
      Newloc : Source_Ptr;
815
 
816
   begin
817
      Newloc := S;
818
      loop
819
         Oldloc := Newloc;
820
         Newloc := Instantiation_Location (Oldloc);
821
         exit when Newloc = No_Location;
822
      end loop;
823
 
824
      return Oldloc;
825
   end Top_Level_Location;
826
 
827
   ---------------
828
   -- Tree_Read --
829
   ---------------
830
 
831
   procedure Tree_Read is
832
   begin
833
      --  First we must free any old source buffer pointers
834
 
835
      if not First_Time_Around then
836
         for J in Source_File.First .. Source_File.Last loop
837
            declare
838
               S : Source_File_Record renames Source_File.Table (J);
839
 
840
               procedure Free_Ptr is new Unchecked_Deallocation
841
                 (Big_Source_Buffer, Source_Buffer_Ptr);
842
 
843
               pragma Warnings (Off);
844
               --  This unchecked conversion is aliasing safe, since it is not
845
               --  used to create improperly aliased pointer values.
846
 
847
               function To_Source_Buffer_Ptr is new
848
                 Unchecked_Conversion (Address, Source_Buffer_Ptr);
849
 
850
               pragma Warnings (On);
851
 
852
               Tmp1 : Source_Buffer_Ptr;
853
 
854
            begin
855
               if S.Instantiation /= No_Location then
856
                  null;
857
 
858
               else
859
                  --  Free the buffer, we use Free here, because we used malloc
860
                  --  or realloc directly to allocate the tables. That is
861
                  --  because we were playing the big array trick.
862
 
863
                  --  We have to recreate a proper pointer to the actual array
864
                  --  from the zero origin pointer stored in the source table.
865
 
866
                  Tmp1 :=
867
                    To_Source_Buffer_Ptr
868
                      (S.Source_Text (S.Source_First)'Address);
869
                  Free_Ptr (Tmp1);
870
 
871
                  if S.Lines_Table /= null then
872
                     Memory.Free (To_Address (S.Lines_Table));
873
                     S.Lines_Table := null;
874
                  end if;
875
 
876
                  if S.Logical_Lines_Table /= null then
877
                     Memory.Free (To_Address (S.Logical_Lines_Table));
878
                     S.Logical_Lines_Table := null;
879
                  end if;
880
               end if;
881
            end;
882
         end loop;
883
      end if;
884
 
885
      --  Reset source cache pointers to force new read
886
 
887
      Source_Cache_First := 1;
888
      Source_Cache_Last  := 0;
889
 
890
      --  Read in source file table
891
 
892
      Source_File.Tree_Read;
893
 
894
      --  The pointers we read in there for the source buffer and lines
895
      --  table pointers are junk. We now read in the actual data that
896
      --  is referenced by these two fields.
897
 
898
      for J in Source_File.First .. Source_File.Last loop
899
         declare
900
            S : Source_File_Record renames Source_File.Table (J);
901
 
902
         begin
903
            --  For the instantiation case, we do not read in any data. Instead
904
            --  we share the data for the generic template entry. Since the
905
            --  template always occurs first, we can safely refer to its data.
906
 
907
            if S.Instantiation /= No_Location then
908
               declare
909
                  ST : Source_File_Record renames
910
                         Source_File.Table (S.Template);
911
 
912
               begin
913
                  --  The lines tables are copied from the template entry
914
 
915
                  S.Lines_Table :=
916
                    Source_File.Table (S.Template).Lines_Table;
917
                  S.Logical_Lines_Table :=
918
                    Source_File.Table (S.Template).Logical_Lines_Table;
919
 
920
                  --  In the case of the source table pointer, we share the
921
                  --  same data as the generic template, but the virtual origin
922
                  --  is adjusted. For example, if the first subscript of the
923
                  --  template is 100, and that of the instantiation is 200,
924
                  --  then the instantiation pointer is obtained by subtracting
925
                  --  100 from the template pointer.
926
 
927
                  declare
928
                     pragma Suppress (All_Checks);
929
 
930
                     pragma Warnings (Off);
931
                     --  This unchecked conversion is aliasing safe since it
932
                     --  not used to create improperly aliased pointer values.
933
 
934
                     function To_Source_Buffer_Ptr is new
935
                       Unchecked_Conversion (Address, Source_Buffer_Ptr);
936
 
937
                     pragma Warnings (On);
938
 
939
                  begin
940
                     S.Source_Text :=
941
                       To_Source_Buffer_Ptr
942
                          (ST.Source_Text
943
                            (ST.Source_First - S.Source_First)'Address);
944
                  end;
945
               end;
946
 
947
            --  Normal case (non-instantiation)
948
 
949
            else
950
               First_Time_Around := False;
951
               S.Lines_Table := null;
952
               S.Logical_Lines_Table := null;
953
               Alloc_Line_Tables (S, Int (S.Last_Source_Line));
954
 
955
               for J in 1 .. S.Last_Source_Line loop
956
                  Tree_Read_Int (Int (S.Lines_Table (J)));
957
               end loop;
958
 
959
               if S.Num_SRef_Pragmas /= 0 then
960
                  for J in 1 .. S.Last_Source_Line loop
961
                     Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
962
                  end loop;
963
               end if;
964
 
965
               --  Allocate source buffer and read in the data and then set the
966
               --  virtual origin to point to the logical zero'th element. This
967
               --  address must be computed with subscript checks turned off.
968
 
969
               declare
970
                  subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
971
                  type Text_Buffer_Ptr is access B;
972
                  T : Text_Buffer_Ptr;
973
 
974
                  pragma Suppress (All_Checks);
975
 
976
                  pragma Warnings (Off);
977
                  --  This unchecked conversion is aliasing safe, since it is
978
                  --  never used to create improperly aliased pointer values.
979
 
980
                  function To_Source_Buffer_Ptr is new
981
                    Unchecked_Conversion (Address, Source_Buffer_Ptr);
982
 
983
                  pragma Warnings (On);
984
 
985
               begin
986
                  T := new B;
987
 
988
                  Tree_Read_Data (T (S.Source_First)'Address,
989
                     Int (S.Source_Last) - Int (S.Source_First) + 1);
990
 
991
                  S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
992
               end;
993
            end if;
994
         end;
995
 
996
         Set_Source_File_Index_Table (J);
997
      end loop;
998
   end Tree_Read;
999
 
1000
   ----------------
1001
   -- Tree_Write --
1002
   ----------------
1003
 
1004
   procedure Tree_Write is
1005
   begin
1006
      Source_File.Tree_Write;
1007
 
1008
      --  The pointers we wrote out there for the source buffer and lines
1009
      --  table pointers are junk, we now write out the actual data that
1010
      --  is referenced by these two fields.
1011
 
1012
      for J in Source_File.First .. Source_File.Last loop
1013
         declare
1014
            S : Source_File_Record renames Source_File.Table (J);
1015
 
1016
         begin
1017
            --  For instantiations, there is nothing to do, since the data is
1018
            --  shared with the generic template. When the tree is read, the
1019
            --  pointers must be set, but no extra data needs to be written.
1020
 
1021
            if S.Instantiation /= No_Location then
1022
               null;
1023
 
1024
            --  For the normal case, write out the data of the tables
1025
 
1026
            else
1027
               --  Lines table
1028
 
1029
               for J in 1 .. S.Last_Source_Line loop
1030
                  Tree_Write_Int (Int (S.Lines_Table (J)));
1031
               end loop;
1032
 
1033
               --  Logical lines table if present
1034
 
1035
               if S.Num_SRef_Pragmas /= 0 then
1036
                  for J in 1 .. S.Last_Source_Line loop
1037
                     Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
1038
                  end loop;
1039
               end if;
1040
 
1041
               --  Source buffer
1042
 
1043
               Tree_Write_Data
1044
                 (S.Source_Text (S.Source_First)'Address,
1045
                   Int (S.Source_Last) - Int (S.Source_First) + 1);
1046
            end if;
1047
         end;
1048
      end loop;
1049
   end Tree_Write;
1050
 
1051
   --------------------
1052
   -- Write_Location --
1053
   --------------------
1054
 
1055
   procedure Write_Location (P : Source_Ptr) is
1056
   begin
1057
      if P = No_Location then
1058
         Write_Str ("<no location>");
1059
 
1060
      elsif P <= Standard_Location then
1061
         Write_Str ("<standard location>");
1062
 
1063
      else
1064
         declare
1065
            SI : constant Source_File_Index := Get_Source_File_Index (P);
1066
 
1067
         begin
1068
            Write_Name (Debug_Source_Name (SI));
1069
            Write_Char (':');
1070
            Write_Int (Int (Get_Logical_Line_Number (P)));
1071
            Write_Char (':');
1072
            Write_Int (Int (Get_Column_Number (P)));
1073
 
1074
            if Instantiation (SI) /= No_Location then
1075
               Write_Str (" [");
1076
               Write_Location (Instantiation (SI));
1077
               Write_Char (']');
1078
            end if;
1079
         end;
1080
      end if;
1081
   end Write_Location;
1082
 
1083
   ----------------------
1084
   -- Write_Time_Stamp --
1085
   ----------------------
1086
 
1087
   procedure Write_Time_Stamp (S : Source_File_Index) is
1088
      T : constant Time_Stamp_Type := Time_Stamp (S);
1089
      P : Natural;
1090
 
1091
   begin
1092
      if T (1) = '9' then
1093
         Write_Str ("19");
1094
         P := 0;
1095
      else
1096
         Write_Char (T (1));
1097
         Write_Char (T (2));
1098
         P := 2;
1099
      end if;
1100
 
1101
      Write_Char (T (P + 1));
1102
      Write_Char (T (P + 2));
1103
      Write_Char ('-');
1104
 
1105
      Write_Char (T (P + 3));
1106
      Write_Char (T (P + 4));
1107
      Write_Char ('-');
1108
 
1109
      Write_Char (T (P + 5));
1110
      Write_Char (T (P + 6));
1111
      Write_Char (' ');
1112
 
1113
      Write_Char (T (P + 7));
1114
      Write_Char (T (P + 8));
1115
      Write_Char (':');
1116
 
1117
      Write_Char (T (P + 9));
1118
      Write_Char (T (P + 10));
1119
      Write_Char (':');
1120
 
1121
      Write_Char (T (P + 11));
1122
      Write_Char (T (P + 12));
1123
   end Write_Time_Stamp;
1124
 
1125
   ----------------------------------------------
1126
   -- Access Subprograms for Source File Table --
1127
   ----------------------------------------------
1128
 
1129
   function Debug_Source_Name (S : SFI) return File_Name_Type is
1130
   begin
1131
      return Source_File.Table (S).Debug_Source_Name;
1132
   end Debug_Source_Name;
1133
 
1134
   function File_Name (S : SFI) return File_Name_Type is
1135
   begin
1136
      return Source_File.Table (S).File_Name;
1137
   end File_Name;
1138
 
1139
   function File_Type (S : SFI) return Type_Of_File is
1140
   begin
1141
      return Source_File.Table (S).File_Type;
1142
   end File_Type;
1143
 
1144
   function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1145
   begin
1146
      return Source_File.Table (S).First_Mapped_Line;
1147
   end First_Mapped_Line;
1148
 
1149
   function Full_Debug_Name (S : SFI) return File_Name_Type is
1150
   begin
1151
      return Source_File.Table (S).Full_Debug_Name;
1152
   end Full_Debug_Name;
1153
 
1154
   function Full_File_Name (S : SFI) return File_Name_Type is
1155
   begin
1156
      return Source_File.Table (S).Full_File_Name;
1157
   end Full_File_Name;
1158
 
1159
   function Full_Ref_Name (S : SFI) return File_Name_Type is
1160
   begin
1161
      return Source_File.Table (S).Full_Ref_Name;
1162
   end Full_Ref_Name;
1163
 
1164
   function Identifier_Casing (S : SFI) return Casing_Type is
1165
   begin
1166
      return Source_File.Table (S).Identifier_Casing;
1167
   end Identifier_Casing;
1168
 
1169
   function Inlined_Body (S : SFI) return Boolean is
1170
   begin
1171
      return Source_File.Table (S).Inlined_Body;
1172
   end Inlined_Body;
1173
 
1174
   function Instantiation (S : SFI) return Source_Ptr is
1175
   begin
1176
      return Source_File.Table (S).Instantiation;
1177
   end Instantiation;
1178
 
1179
   function Keyword_Casing (S : SFI) return Casing_Type is
1180
   begin
1181
      return Source_File.Table (S).Keyword_Casing;
1182
   end Keyword_Casing;
1183
 
1184
   function Last_Source_Line (S : SFI) return Physical_Line_Number is
1185
   begin
1186
      return Source_File.Table (S).Last_Source_Line;
1187
   end Last_Source_Line;
1188
 
1189
   function License (S : SFI) return License_Type is
1190
   begin
1191
      return Source_File.Table (S).License;
1192
   end License;
1193
 
1194
   function Num_SRef_Pragmas (S : SFI) return Nat is
1195
   begin
1196
      return Source_File.Table (S).Num_SRef_Pragmas;
1197
   end Num_SRef_Pragmas;
1198
 
1199
   function Reference_Name (S : SFI) return File_Name_Type is
1200
   begin
1201
      return Source_File.Table (S).Reference_Name;
1202
   end Reference_Name;
1203
 
1204
   function Source_Checksum (S : SFI) return Word is
1205
   begin
1206
      return Source_File.Table (S).Source_Checksum;
1207
   end Source_Checksum;
1208
 
1209
   function Source_First (S : SFI) return Source_Ptr is
1210
   begin
1211
      if S = Internal_Source_File then
1212
         return Internal_Source'First;
1213
      else
1214
         return Source_File.Table (S).Source_First;
1215
      end if;
1216
   end Source_First;
1217
 
1218
   function Source_Last (S : SFI) return Source_Ptr is
1219
   begin
1220
      if S = Internal_Source_File then
1221
         return Internal_Source'Last;
1222
      else
1223
         return Source_File.Table (S).Source_Last;
1224
      end if;
1225
   end Source_Last;
1226
 
1227
   function Source_Text (S : SFI) return Source_Buffer_Ptr is
1228
   begin
1229
      if S = Internal_Source_File then
1230
         return Internal_Source_Ptr;
1231
      else
1232
         return Source_File.Table (S).Source_Text;
1233
      end if;
1234
   end Source_Text;
1235
 
1236
   function Template (S : SFI) return SFI is
1237
   begin
1238
      return Source_File.Table (S).Template;
1239
   end Template;
1240
 
1241
   function Time_Stamp (S : SFI) return Time_Stamp_Type is
1242
   begin
1243
      return Source_File.Table (S).Time_Stamp;
1244
   end Time_Stamp;
1245
 
1246
   function Unit (S : SFI) return Unit_Number_Type is
1247
   begin
1248
      return Source_File.Table (S).Unit;
1249
   end Unit;
1250
 
1251
   ------------------------------------------
1252
   -- Set Procedures for Source File Table --
1253
   ------------------------------------------
1254
 
1255
   procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1256
   begin
1257
      Source_File.Table (S).Identifier_Casing := C;
1258
   end Set_Identifier_Casing;
1259
 
1260
   procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1261
   begin
1262
      Source_File.Table (S).Keyword_Casing := C;
1263
   end Set_Keyword_Casing;
1264
 
1265
   procedure Set_License (S : SFI; L : License_Type) is
1266
   begin
1267
      Source_File.Table (S).License := L;
1268
   end Set_License;
1269
 
1270
   procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1271
   begin
1272
      Source_File.Table (S).Unit := U;
1273
   end Set_Unit;
1274
 
1275
   ----------------------
1276
   -- Trim_Lines_Table --
1277
   ----------------------
1278
 
1279
   procedure Trim_Lines_Table (S : Source_File_Index) is
1280
      Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1281
 
1282
   begin
1283
      --  Release allocated storage that is no longer needed
1284
 
1285
      Source_File.Table (S).Lines_Table := To_Pointer
1286
        (Memory.Realloc
1287
          (To_Address (Source_File.Table (S).Lines_Table),
1288
           Memory.size_t
1289
            (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1290
      Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1291
   end Trim_Lines_Table;
1292
 
1293
   ------------
1294
   -- Unlock --
1295
   ------------
1296
 
1297
   procedure Unlock is
1298
   begin
1299
      Source_File.Locked := False;
1300
      Source_File.Release;
1301
   end Unlock;
1302
 
1303
   --------
1304
   -- wl --
1305
   --------
1306
 
1307
   procedure wl (P : Source_Ptr) is
1308
   begin
1309
      Write_Location (P);
1310
      Write_Eol;
1311
   end wl;
1312
 
1313
end Sinput;

powered by: WebSVN 2.1.0

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