1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 pragma Style_Checks (All_Checks);
35 -- Subprograms not all in alpha order
37 with Debug; use Debug;
38 with Namet; use Namet;
40 with Output; use Output;
41 with Tree_IO; use Tree_IO;
42 with System; use System;
43 with Widechar; use Widechar;
47 with Unchecked_Conversion;
48 with Unchecked_Deallocation;
50 package body Sinput is
53 -- Make control characters visible
55 First_Time_Around : Boolean := True;
57 -- Routines to support conversion between types Lines_Table_Ptr,
58 -- Logical_Lines_Table_Ptr and System.Address.
60 pragma Warnings (Off);
61 -- These unchecked conversions are aliasing safe, since they are never
62 -- used to construct improperly aliased pointer values.
64 function To_Address is
65 new Unchecked_Conversion (Lines_Table_Ptr, Address);
67 function To_Address is
68 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
70 function To_Pointer is
71 new Unchecked_Conversion (Address, Lines_Table_Ptr);
73 function To_Pointer is
74 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
78 ---------------------------
79 -- Add_Line_Tables_Entry --
80 ---------------------------
82 procedure Add_Line_Tables_Entry
83 (S : in out Source_File_Record;
86 LL : Physical_Line_Number;
89 -- Reallocate the lines tables if necessary
91 -- Note: the reason we do not use the normal Table package
92 -- mechanism is that we have several of these tables. We could
93 -- use the new GNAT.Dynamic_Tables package and that would probably
96 if S.Last_Source_Line = S.Lines_Table_Max then
99 Int (S.Last_Source_Line) *
100 ((100 + Alloc.Lines_Increment) / 100));
103 Write_Str ("--> Reallocating lines table, size = ");
104 Write_Int (Int (S.Lines_Table_Max));
109 S.Last_Source_Line := S.Last_Source_Line + 1;
110 LL := S.Last_Source_Line;
112 S.Lines_Table (LL) := P;
114 -- Deal with setting new entry in logical lines table if one is
115 -- present. Note that there is always space (because the call to
116 -- Alloc_Line_Tables makes sure both tables are the same length),
118 if S.Logical_Lines_Table /= null then
120 -- We can always set the entry from the previous one, because
121 -- the processing for a Source_Reference pragma ensures that
122 -- at least one entry following the pragma is set up correctly.
124 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
126 end Add_Line_Tables_Entry;
128 -----------------------
129 -- Alloc_Line_Tables --
130 -----------------------
132 procedure Alloc_Line_Tables
133 (S : in out Source_File_Record;
136 subtype size_t is Memory.size_t;
138 New_Table : Lines_Table_Ptr;
140 New_Logical_Table : Logical_Lines_Table_Ptr;
142 New_Size : constant size_t :=
143 size_t (New_Max * Lines_Table_Type'Component_Size /
147 if S.Lines_Table = null then
148 New_Table := To_Pointer (Memory.Alloc (New_Size));
152 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
155 if New_Table = null then
158 S.Lines_Table := New_Table;
159 S.Lines_Table_Max := Physical_Line_Number (New_Max);
162 if S.Num_SRef_Pragmas /= 0 then
163 if S.Logical_Lines_Table = null then
164 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
166 New_Logical_Table := To_Pointer
167 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
170 if New_Logical_Table = null then
173 S.Logical_Lines_Table := New_Logical_Table;
176 end Alloc_Line_Tables;
182 procedure Backup_Line (P : in out Source_Ptr) is
183 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
184 Src : constant Source_Buffer_Ptr :=
185 Source_File.Table (Sindex).Source_Text;
186 Sfirst : constant Source_Ptr :=
187 Source_File.Table (Sindex).Source_First;
197 if Src (P - 1) = LF then
202 if Src (P - 1) = CR then
207 -- Now find first character of the previous line
210 and then Src (P - 1) /= LF
211 and then Src (P - 1) /= CR
217 ---------------------------
218 -- Build_Location_String --
219 ---------------------------
221 procedure Build_Location_String (Loc : Source_Ptr) is
227 -- Loop through instantiations
231 Get_Name_String_And_Append
232 (Reference_Name (Get_Source_File_Index (Ptr)));
233 Add_Char_To_Name_Buffer (':');
234 Add_Nat_To_Name_Buffer
235 (Nat (Get_Logical_Line_Number (Ptr)));
237 Ptr := Instantiation_Location (Ptr);
238 exit when Ptr = No_Location;
239 Add_Str_To_Name_Buffer (" instantiated at ");
242 Name_Buffer (Name_Len + 1) := NUL;
244 end Build_Location_String;
246 -----------------------
247 -- Get_Column_Number --
248 -----------------------
250 function Get_Column_Number (P : Source_Ptr) return Column_Number is
253 Sindex : Source_File_Index;
254 Src : Source_Buffer_Ptr;
257 -- If the input source pointer is not a meaningful value then return
258 -- at once with column number 1. This can happen for a file not found
259 -- condition for a file loaded indirectly by RTE, and also perhaps on
260 -- some unknown internal error conditions. In either case we certainly
261 -- don't want to blow up.
267 Sindex := Get_Source_File_Index (P);
268 Src := Source_File.Table (Sindex).Source_Text;
274 C := (C - 1) / 8 * 8 + (8 + 1);
284 end Get_Column_Number;
286 -----------------------------
287 -- Get_Logical_Line_Number --
288 -----------------------------
290 function Get_Logical_Line_Number
292 return Logical_Line_Number
294 SFR : Source_File_Record
295 renames Source_File.Table (Get_Source_File_Index (P));
297 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
300 if SFR.Num_SRef_Pragmas = 0 then
301 return Logical_Line_Number (L);
303 return SFR.Logical_Lines_Table (L);
305 end Get_Logical_Line_Number;
307 ------------------------------
308 -- Get_Physical_Line_Number --
309 ------------------------------
311 function Get_Physical_Line_Number
313 return Physical_Line_Number
315 Sfile : Source_File_Index;
316 Table : Lines_Table_Ptr;
317 Lo : Physical_Line_Number;
318 Hi : Physical_Line_Number;
319 Mid : Physical_Line_Number;
323 -- If the input source pointer is not a meaningful value then return
324 -- at once with line number 1. This can happen for a file not found
325 -- condition for a file loaded indirectly by RTE, and also perhaps on
326 -- some unknown internal error conditions. In either case we certainly
327 -- don't want to blow up.
332 -- Otherwise we can do the binary search
335 Sfile := Get_Source_File_Index (P);
336 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
337 Table := Source_File.Table (Sfile).Lines_Table;
339 Hi := Source_File.Table (Sfile).Last_Source_Line;
342 Mid := (Lo + Hi) / 2;
344 if Loc < Table (Mid) then
347 else -- Loc >= Table (Mid)
350 Loc < Table (Mid + 1)
361 end Get_Physical_Line_Number;
363 ---------------------------
364 -- Get_Source_File_Index --
365 ---------------------------
367 Source_Cache_First : Source_Ptr := 1;
368 Source_Cache_Last : Source_Ptr := 0;
369 -- Records the First and Last subscript values for the most recently
370 -- referenced entry in the source table, to optimize the common case
371 -- of repeated references to the same entry. The initial values force
372 -- an initial search to set the cache value.
374 Source_Cache_Index : Source_File_Index := No_Source_File;
375 -- Contains the index of the entry corresponding to Source_Cache
377 function Get_Source_File_Index
379 return Source_File_Index
382 if S in Source_Cache_First .. Source_Cache_Last then
383 return Source_Cache_Index;
386 for J in Source_File_Index_Table (Int (S) / Chunk_Size)
389 if S in Source_File.Table (J).Source_First ..
390 Source_File.Table (J).Source_Last
392 Source_Cache_Index := J;
393 Source_Cache_First :=
394 Source_File.Table (Source_Cache_Index).Source_First;
396 Source_File.Table (Source_Cache_Index).Source_Last;
397 return Source_Cache_Index;
402 -- We must find a matching entry in the above loop!
405 end Get_Source_File_Index;
411 procedure Initialize is
413 Source_Cache_First := 1;
414 Source_Cache_Last := 0;
415 Source_Cache_Index := No_Source_File;
416 Source_gnat_adc := No_Source_File;
417 First_Time_Around := True;
422 -------------------------
423 -- Instantiation_Depth --
424 -------------------------
426 function Instantiation_Depth (S : Source_Ptr) return Nat is
427 Sind : Source_File_Index;
436 Sind := Get_Source_File_Index (Sval);
437 Sval := Instantiation (Sind);
438 exit when Sval = No_Location;
443 end Instantiation_Depth;
445 ----------------------------
446 -- Instantiation_Location --
447 ----------------------------
449 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
451 return Instantiation (Get_Source_File_Index (S));
452 end Instantiation_Location;
454 ----------------------
455 -- Last_Source_File --
456 ----------------------
458 function Last_Source_File return Source_File_Index is
460 return Source_File.Last;
461 end Last_Source_File;
467 function Line_Start (P : Source_Ptr) return Source_Ptr is
468 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
469 Src : constant Source_Buffer_Ptr :=
470 Source_File.Table (Sindex).Source_Text;
471 Sfirst : constant Source_Ptr :=
472 Source_File.Table (Sindex).Source_First;
479 and then Src (S - 1) /= CR
480 and then Src (S - 1) /= LF
489 (L : Physical_Line_Number;
490 S : Source_File_Index)
494 return Source_File.Table (S).Lines_Table (L);
503 Source_File.Locked := True;
507 ----------------------
508 -- Num_Source_Files --
509 ----------------------
511 function Num_Source_Files return Nat is
513 return Int (Source_File.Last) - Int (Source_File.First) + 1;
514 end Num_Source_Files;
516 ----------------------
517 -- Num_Source_Lines --
518 ----------------------
520 function Num_Source_Lines (S : Source_File_Index) return Nat is
522 return Nat (Source_File.Table (S).Last_Source_Line);
523 end Num_Source_Lines;
525 -----------------------
526 -- Original_Location --
527 -----------------------
529 function Original_Location (S : Source_Ptr) return Source_Ptr is
530 Sindex : Source_File_Index;
531 Tindex : Source_File_Index;
534 if S <= No_Location then
538 Sindex := Get_Source_File_Index (S);
540 if Instantiation (Sindex) = No_Location then
544 Tindex := Template (Sindex);
545 while Instantiation (Tindex) /= No_Location loop
546 Tindex := Template (Tindex);
549 return S - Source_First (Sindex) + Source_First (Tindex);
552 end Original_Location;
554 -------------------------
555 -- Physical_To_Logical --
556 -------------------------
558 function Physical_To_Logical
559 (Line : Physical_Line_Number;
560 S : Source_File_Index)
561 return Logical_Line_Number
563 SFR : Source_File_Record renames Source_File.Table (S);
566 if SFR.Num_SRef_Pragmas = 0 then
567 return Logical_Line_Number (Line);
569 return SFR.Logical_Lines_Table (Line);
571 end Physical_To_Logical;
573 --------------------------------
574 -- Register_Source_Ref_Pragma --
575 --------------------------------
577 procedure Register_Source_Ref_Pragma
578 (File_Name : Name_Id;
579 Stripped_File_Name : Name_Id;
581 Line_After_Pragma : Physical_Line_Number)
583 subtype size_t is Memory.size_t;
585 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
587 ML : Logical_Line_Number;
590 if File_Name /= No_Name then
591 SFR.Reference_Name := Stripped_File_Name;
592 SFR.Full_Ref_Name := File_Name;
594 if not Debug_Generated_Code then
595 SFR.Debug_Source_Name := Stripped_File_Name;
596 SFR.Full_Debug_Name := File_Name;
599 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
602 if SFR.Num_SRef_Pragmas = 1 then
603 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
606 if SFR.Logical_Lines_Table = null then
607 SFR.Logical_Lines_Table := To_Pointer
609 (size_t (SFR.Lines_Table_Max *
610 Logical_Lines_Table_Type'Component_Size /
614 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
616 ML := Logical_Line_Number (Mapped_Line);
617 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
618 SFR.Logical_Lines_Table (J) := ML;
621 end Register_Source_Ref_Pragma;
623 ---------------------------------
624 -- Set_Source_File_Index_Table --
625 ---------------------------------
627 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
630 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
633 SP := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
634 / Chunk_Size * Chunk_Size;
635 Ind := Int (SP) / Chunk_Size;
638 Source_File_Index_Table (Ind) := Xnew;
639 SP := SP + Chunk_Size;
642 end Set_Source_File_Index_Table;
644 ---------------------------
645 -- Skip_Line_Terminators --
646 ---------------------------
648 procedure Skip_Line_Terminators
649 (P : in out Source_Ptr;
650 Physical : out Boolean)
652 Chr : constant Character := Source (P);
656 if Source (P + 1) = LF then
663 if Source (P) = CR then
669 elsif Chr = FF or else Chr = VT then
674 -- Otherwise we have a wide character
677 Skip_Wide (Source, P);
680 -- Fall through in the physical line terminator case. First deal with
681 -- making a possible entry into the lines table if one is needed.
683 -- Note: we are dealing with a real source file here, this cannot be
684 -- the instantiation case, so we need not worry about Sloc adjustment.
687 S : Source_File_Record
688 renames Source_File.Table (Current_Source_File);
693 -- Make entry in lines table if not already made (in some scan backup
694 -- cases, we will be rescanning previously scanned source, so the
695 -- entry may have already been made on the previous forward scan).
698 and then P > S.Lines_Table (S.Last_Source_Line)
700 Add_Line_Tables_Entry (S, P);
703 end Skip_Line_Terminators;
709 function Source_Offset (S : Source_Ptr) return Nat is
710 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
711 Sfirst : constant Source_Ptr :=
712 Source_File.Table (Sindex).Source_First;
715 return Nat (S - Sfirst);
718 ------------------------
719 -- Top_Level_Location --
720 ------------------------
722 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
730 Newloc := Instantiation_Location (Oldloc);
731 exit when Newloc = No_Location;
735 end Top_Level_Location;
741 procedure Tree_Read is
743 -- First we must free any old source buffer pointers
745 if not First_Time_Around then
746 for J in Source_File.First .. Source_File.Last loop
748 S : Source_File_Record renames Source_File.Table (J);
750 procedure Free_Ptr is new Unchecked_Deallocation
751 (Big_Source_Buffer, Source_Buffer_Ptr);
753 pragma Warnings (Off);
754 -- This unchecked conversion is aliasing safe, since it is not
755 -- used to create improperly aliased pointer values.
757 function To_Source_Buffer_Ptr is new
758 Unchecked_Conversion (Address, Source_Buffer_Ptr);
760 pragma Warnings (On);
762 Tmp1 : Source_Buffer_Ptr;
765 if S.Instantiation /= No_Location then
769 -- We have to recreate a proper pointer to the actual array
770 -- from the zero origin pointer stored in the source table.
774 (S.Source_Text (S.Source_First)'Address);
777 -- Note: we are using free here, because we used malloc
778 -- or realloc directly to allocate the tables. That is
779 -- because we were playing the big array trick.
781 if S.Lines_Table /= null then
782 Memory.Free (To_Address (S.Lines_Table));
783 S.Lines_Table := null;
786 if S.Logical_Lines_Table /= null then
787 Memory.Free (To_Address (S.Logical_Lines_Table));
788 S.Logical_Lines_Table := null;
795 -- Reset source cache pointers to force new read
797 Source_Cache_First := 1;
798 Source_Cache_Last := 0;
800 -- Read in source file table
802 Source_File.Tree_Read;
804 -- The pointers we read in there for the source buffer and lines
805 -- table pointers are junk. We now read in the actual data that
806 -- is referenced by these two fields.
808 for J in Source_File.First .. Source_File.Last loop
810 S : Source_File_Record renames Source_File.Table (J);
813 -- For the instantiation case, we do not read in any data. Instead
814 -- we share the data for the generic template entry. Since the
815 -- template always occurs first, we can safetly refer to its data.
817 if S.Instantiation /= No_Location then
819 ST : Source_File_Record renames
820 Source_File.Table (S.Template);
823 -- The lines tables are copied from the template entry
826 Source_File.Table (S.Template).Lines_Table;
827 S.Logical_Lines_Table :=
828 Source_File.Table (S.Template).Logical_Lines_Table;
830 -- In the case of the source table pointer, we share the
831 -- same data as the generic template, but the virtual origin
832 -- is adjusted. For example, if the first subscript of the
833 -- template is 100, and that of the instantiation is 200,
834 -- then the instantiation pointer is obtained by subtracting
835 -- 100 from the template pointer.
838 pragma Suppress (All_Checks);
840 pragma Warnings (Off);
841 -- This unchecked conversion is aliasing safe since it
842 -- not used to create improperly aliased pointer values.
844 function To_Source_Buffer_Ptr is new
845 Unchecked_Conversion (Address, Source_Buffer_Ptr);
847 pragma Warnings (On);
853 (ST.Source_First - S.Source_First)'Address);
857 -- Normal case (non-instantiation)
860 First_Time_Around := False;
861 S.Lines_Table := null;
862 S.Logical_Lines_Table := null;
863 Alloc_Line_Tables (S, Int (S.Last_Source_Line));
865 for J in 1 .. S.Last_Source_Line loop
866 Tree_Read_Int (Int (S.Lines_Table (J)));
869 if S.Num_SRef_Pragmas /= 0 then
870 for J in 1 .. S.Last_Source_Line loop
871 Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
875 -- Allocate source buffer and read in the data and then set the
876 -- virtual origin to point to the logical zero'th element. This
877 -- address must be computed with subscript checks turned off.
880 subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
881 type Text_Buffer_Ptr is access B;
884 pragma Suppress (All_Checks);
886 pragma Warnings (Off);
887 -- This unchecked conversion is aliasing safe, since it is
888 -- never used to create improperly aliased pointer values.
890 function To_Source_Buffer_Ptr is new
891 Unchecked_Conversion (Address, Source_Buffer_Ptr);
893 pragma Warnings (On);
898 Tree_Read_Data (T (S.Source_First)'Address,
899 Int (S.Source_Last) - Int (S.Source_First) + 1);
901 S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
906 Set_Source_File_Index_Table (J);
914 procedure Tree_Write is
916 Source_File.Tree_Write;
918 -- The pointers we wrote out there for the source buffer and lines
919 -- table pointers are junk, we now write out the actual data that
920 -- is referenced by these two fields.
922 for J in Source_File.First .. Source_File.Last loop
924 S : Source_File_Record renames Source_File.Table (J);
927 -- For instantiations, there is nothing to do, since the data is
928 -- shared with the generic template. When the tree is read, the
929 -- pointers must be set, but no extra data needs to be written.
931 if S.Instantiation /= No_Location then
934 -- For the normal case, write out the data of the tables
939 for J in 1 .. S.Last_Source_Line loop
940 Tree_Write_Int (Int (S.Lines_Table (J)));
943 -- Logical lines table if present
945 if S.Num_SRef_Pragmas /= 0 then
946 for J in 1 .. S.Last_Source_Line loop
947 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
954 (S.Source_Text (S.Source_First)'Address,
955 Int (S.Source_Last) - Int (S.Source_First) + 1);
965 procedure Write_Location (P : Source_Ptr) is
967 if P = No_Location then
968 Write_Str ("<no location>");
970 elsif P <= Standard_Location then
971 Write_Str ("<standard location>");
975 SI : constant Source_File_Index := Get_Source_File_Index (P);
978 Write_Name (Debug_Source_Name (SI));
980 Write_Int (Int (Get_Logical_Line_Number (P)));
982 Write_Int (Int (Get_Column_Number (P)));
984 if Instantiation (SI) /= No_Location then
986 Write_Location (Instantiation (SI));
993 ----------------------
994 -- Write_Time_Stamp --
995 ----------------------
997 procedure Write_Time_Stamp (S : Source_File_Index) is
998 T : constant Time_Stamp_Type := Time_Stamp (S);
1011 Write_Char (T (P + 1));
1012 Write_Char (T (P + 2));
1015 Write_Char (T (P + 3));
1016 Write_Char (T (P + 4));
1019 Write_Char (T (P + 5));
1020 Write_Char (T (P + 6));
1023 Write_Char (T (P + 7));
1024 Write_Char (T (P + 8));
1027 Write_Char (T (P + 9));
1028 Write_Char (T (P + 10));
1031 Write_Char (T (P + 11));
1032 Write_Char (T (P + 12));
1033 end Write_Time_Stamp;
1035 ----------------------------------------------
1036 -- Access Subprograms for Source File Table --
1037 ----------------------------------------------
1039 function Debug_Source_Name (S : SFI) return File_Name_Type is
1041 return Source_File.Table (S).Debug_Source_Name;
1042 end Debug_Source_Name;
1044 function File_Name (S : SFI) return File_Name_Type is
1046 return Source_File.Table (S).File_Name;
1049 function File_Type (S : SFI) return Type_Of_File is
1051 return Source_File.Table (S).File_Type;
1054 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1056 return Source_File.Table (S).First_Mapped_Line;
1057 end First_Mapped_Line;
1059 function Full_Debug_Name (S : SFI) return File_Name_Type is
1061 return Source_File.Table (S).Full_Debug_Name;
1062 end Full_Debug_Name;
1064 function Full_File_Name (S : SFI) return File_Name_Type is
1066 return Source_File.Table (S).Full_File_Name;
1069 function Full_Ref_Name (S : SFI) return File_Name_Type is
1071 return Source_File.Table (S).Full_Ref_Name;
1074 function Identifier_Casing (S : SFI) return Casing_Type is
1076 return Source_File.Table (S).Identifier_Casing;
1077 end Identifier_Casing;
1079 function Inlined_Body (S : SFI) return Boolean is
1081 return Source_File.Table (S).Inlined_Body;
1084 function Instantiation (S : SFI) return Source_Ptr is
1086 return Source_File.Table (S).Instantiation;
1089 function Keyword_Casing (S : SFI) return Casing_Type is
1091 return Source_File.Table (S).Keyword_Casing;
1094 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1096 return Source_File.Table (S).Last_Source_Line;
1097 end Last_Source_Line;
1099 function License (S : SFI) return License_Type is
1101 return Source_File.Table (S).License;
1104 function Num_SRef_Pragmas (S : SFI) return Nat is
1106 return Source_File.Table (S).Num_SRef_Pragmas;
1107 end Num_SRef_Pragmas;
1109 function Reference_Name (S : SFI) return File_Name_Type is
1111 return Source_File.Table (S).Reference_Name;
1114 function Source_Checksum (S : SFI) return Word is
1116 return Source_File.Table (S).Source_Checksum;
1117 end Source_Checksum;
1119 function Source_First (S : SFI) return Source_Ptr is
1121 if S = Internal_Source_File then
1122 return Internal_Source'First;
1124 return Source_File.Table (S).Source_First;
1128 function Source_Last (S : SFI) return Source_Ptr is
1130 if S = Internal_Source_File then
1131 return Internal_Source'Last;
1133 return Source_File.Table (S).Source_Last;
1138 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1140 if S = Internal_Source_File then
1141 return Internal_Source_Ptr;
1143 return Source_File.Table (S).Source_Text;
1148 function Template (S : SFI) return SFI is
1150 return Source_File.Table (S).Template;
1153 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1155 return Source_File.Table (S).Time_Stamp;
1158 function Unit (S : SFI) return Unit_Number_Type is
1160 return Source_File.Table (S).Unit;
1163 ------------------------------------------
1164 -- Set Procedures for Source File Table --
1165 ------------------------------------------
1167 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1169 Source_File.Table (S).Identifier_Casing := C;
1170 end Set_Identifier_Casing;
1172 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1174 Source_File.Table (S).Keyword_Casing := C;
1175 end Set_Keyword_Casing;
1177 procedure Set_License (S : SFI; L : License_Type) is
1179 Source_File.Table (S).License := L;
1182 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1184 Source_File.Table (S).Unit := U;
1187 ----------------------
1188 -- Trim_Lines_Table --
1189 ----------------------
1191 procedure Trim_Lines_Table (S : Source_File_Index) is
1192 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1195 -- Release allocated storage that is no longer needed
1197 Source_File.Table (S).Lines_Table := To_Pointer
1199 (To_Address (Source_File.Table (S).Lines_Table),
1201 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1202 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1203 end Trim_Lines_Table;
1209 procedure wl (P : Source_Ptr) is