OSDN Git Service

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