OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sinput.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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