1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 pragma Style_Checks (All_Checks);
33 -- Subprograms not all in alpha order
35 with Atree; use Atree;
36 with Debug; use Debug;
38 with Output; use Output;
39 with Scans; use Scans;
40 with Tree_IO; use Tree_IO;
41 with Widechar; use Widechar;
43 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
45 with System; use System;
47 with System.WCh_Con; use System.WCh_Con;
49 with Unchecked_Conversion;
50 with Unchecked_Deallocation;
52 package body Sinput is
55 -- Make control characters visible
57 First_Time_Around : Boolean := True;
58 -- This needs a comment ???
60 -- Routines to support conversion between types Lines_Table_Ptr,
61 -- Logical_Lines_Table_Ptr and System.Address.
63 pragma Warnings (Off);
64 -- These unchecked conversions are aliasing safe, since they are never
65 -- used to construct improperly aliased pointer values.
67 function To_Address is
68 new Unchecked_Conversion (Lines_Table_Ptr, Address);
70 function To_Address is
71 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
73 function To_Pointer is
74 new Unchecked_Conversion (Address, Lines_Table_Ptr);
76 function To_Pointer is
77 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
81 ---------------------------
82 -- Add_Line_Tables_Entry --
83 ---------------------------
85 procedure Add_Line_Tables_Entry
86 (S : in out Source_File_Record;
89 LL : Physical_Line_Number;
92 -- Reallocate the lines tables if necessary
94 -- Note: the reason we do not use the normal Table package
95 -- mechanism is that we have several of these tables. We could
96 -- use the new GNAT.Dynamic_Tables package and that would probably
99 if S.Last_Source_Line = S.Lines_Table_Max then
102 Int (S.Last_Source_Line) *
103 ((100 + Alloc.Lines_Increment) / 100));
106 Write_Str ("--> Reallocating lines table, size = ");
107 Write_Int (Int (S.Lines_Table_Max));
112 S.Last_Source_Line := S.Last_Source_Line + 1;
113 LL := S.Last_Source_Line;
115 S.Lines_Table (LL) := P;
117 -- Deal with setting new entry in logical lines table if one is
118 -- present. Note that there is always space (because the call to
119 -- Alloc_Line_Tables makes sure both tables are the same length),
121 if S.Logical_Lines_Table /= null then
123 -- We can always set the entry from the previous one, because
124 -- the processing for a Source_Reference pragma ensures that
125 -- at least one entry following the pragma is set up correctly.
127 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
129 end Add_Line_Tables_Entry;
131 -----------------------
132 -- Alloc_Line_Tables --
133 -----------------------
135 procedure Alloc_Line_Tables
136 (S : in out Source_File_Record;
139 subtype size_t is Memory.size_t;
141 New_Table : Lines_Table_Ptr;
143 New_Logical_Table : Logical_Lines_Table_Ptr;
145 New_Size : constant size_t :=
146 size_t (New_Max * Lines_Table_Type'Component_Size /
150 if S.Lines_Table = null then
151 New_Table := To_Pointer (Memory.Alloc (New_Size));
155 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
158 if New_Table = null then
161 S.Lines_Table := New_Table;
162 S.Lines_Table_Max := Physical_Line_Number (New_Max);
165 if S.Num_SRef_Pragmas /= 0 then
166 if S.Logical_Lines_Table = null then
167 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
169 New_Logical_Table := To_Pointer
170 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
173 if New_Logical_Table = null then
176 S.Logical_Lines_Table := New_Logical_Table;
179 end Alloc_Line_Tables;
185 procedure Backup_Line (P : in out Source_Ptr) is
186 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
187 Src : constant Source_Buffer_Ptr :=
188 Source_File.Table (Sindex).Source_Text;
189 Sfirst : constant Source_Ptr :=
190 Source_File.Table (Sindex).Source_First;
200 if Src (P - 1) = LF then
205 if Src (P - 1) = CR then
210 -- Now find first character of the previous line
213 and then Src (P - 1) /= LF
214 and then Src (P - 1) /= CR
220 ---------------------------
221 -- Build_Location_String --
222 ---------------------------
224 procedure Build_Location_String (Loc : Source_Ptr) is
228 -- Loop through instantiations
232 Get_Name_String_And_Append
233 (Reference_Name (Get_Source_File_Index (Ptr)));
234 Add_Char_To_Name_Buffer (':');
235 Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr)));
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 function Build_Location_String (Loc : Source_Ptr) return String is
249 Build_Location_String (Loc);
250 return Name_Buffer (1 .. Name_Len);
251 end Build_Location_String;
257 procedure Check_For_BOM is
260 Tst : String (1 .. 5);
265 C := Source (Scan_Ptr + Source_Ptr (J) - 1);
267 -- Definitely no BOM if EOF character marks either end of file, or
268 -- an illegal non-BOM character if not at the end of file.
277 Read_BOM (Tst, Len, BOM, False);
281 Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
282 Wide_Character_Encoding_Method := WCEM_UTF8;
283 Upper_Half_Encoding := True;
285 when UTF16_LE | UTF16_BE =>
287 Write_Line ("UTF-16 encoding format not recognized");
289 raise Unrecoverable_Error;
291 when UTF32_LE | UTF32_BE =>
293 Write_Line ("UTF-32 encoding format not recognized");
295 raise Unrecoverable_Error;
305 -----------------------------
306 -- Comes_From_Inlined_Body --
307 -----------------------------
309 function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
310 SIE : Source_File_Record renames
311 Source_File.Table (Get_Source_File_Index (S));
313 return SIE.Inlined_Body;
314 end Comes_From_Inlined_Body;
316 -----------------------
317 -- Get_Column_Number --
318 -----------------------
320 function Get_Column_Number (P : Source_Ptr) return Column_Number is
323 Sindex : Source_File_Index;
324 Src : Source_Buffer_Ptr;
327 -- If the input source pointer is not a meaningful value then return
328 -- at once with column number 1. This can happen for a file not found
329 -- condition for a file loaded indirectly by RTE, and also perhaps on
330 -- some unknown internal error conditions. In either case we certainly
331 -- don't want to blow up.
337 Sindex := Get_Source_File_Index (P);
338 Src := Source_File.Table (Sindex).Source_Text;
344 C := (C - 1) / 8 * 8 + (8 + 1);
347 -- Deal with wide character case, but don't include brackets
348 -- notation in this circuit, since we know that this will
349 -- display unencoded (no one encodes brackets notation).
351 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
355 -- Normal (non-wide) character case or brackets sequence
365 end Get_Column_Number;
367 -----------------------------
368 -- Get_Logical_Line_Number --
369 -----------------------------
371 function Get_Logical_Line_Number
372 (P : Source_Ptr) return Logical_Line_Number
374 SFR : Source_File_Record
375 renames Source_File.Table (Get_Source_File_Index (P));
377 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
380 if SFR.Num_SRef_Pragmas = 0 then
381 return Logical_Line_Number (L);
383 return SFR.Logical_Lines_Table (L);
385 end Get_Logical_Line_Number;
387 ---------------------------------
388 -- Get_Logical_Line_Number_Img --
389 ---------------------------------
391 function Get_Logical_Line_Number_Img
392 (P : Source_Ptr) return String
396 Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
397 return Name_Buffer (1 .. Name_Len);
398 end Get_Logical_Line_Number_Img;
400 ------------------------------
401 -- Get_Physical_Line_Number --
402 ------------------------------
404 function Get_Physical_Line_Number
405 (P : Source_Ptr) return Physical_Line_Number
407 Sfile : Source_File_Index;
408 Table : Lines_Table_Ptr;
409 Lo : Physical_Line_Number;
410 Hi : Physical_Line_Number;
411 Mid : Physical_Line_Number;
415 -- If the input source pointer is not a meaningful value then return
416 -- at once with line number 1. This can happen for a file not found
417 -- condition for a file loaded indirectly by RTE, and also perhaps on
418 -- some unknown internal error conditions. In either case we certainly
419 -- don't want to blow up.
424 -- Otherwise we can do the binary search
427 Sfile := Get_Source_File_Index (P);
428 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
429 Table := Source_File.Table (Sfile).Lines_Table;
431 Hi := Source_File.Table (Sfile).Last_Source_Line;
434 Mid := (Lo + Hi) / 2;
436 if Loc < Table (Mid) then
439 else -- Loc >= Table (Mid)
442 Loc < Table (Mid + 1)
453 end Get_Physical_Line_Number;
455 ---------------------------
456 -- Get_Source_File_Index --
457 ---------------------------
459 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
461 return Source_File_Index_Table (Int (S) / Source_Align);
462 end Get_Source_File_Index;
468 procedure Initialize is
470 Source_gnat_adc := No_Source_File;
471 First_Time_Around := True;
476 Instances.Append (No_Location);
477 pragma Assert (Instances.Last = No_Instance_Id);
484 function Instantiation (S : SFI) return Source_Ptr is
485 SIE : Source_File_Record renames Source_File.Table (S);
487 if SIE.Inlined_Body then
488 return SIE.Inlined_Call;
490 return Instances.Table (SIE.Instance);
494 -------------------------
495 -- Instantiation_Depth --
496 -------------------------
498 function Instantiation_Depth (S : Source_Ptr) return Nat is
499 Sind : Source_File_Index;
508 Sind := Get_Source_File_Index (Sval);
509 Sval := Instantiation (Sind);
510 exit when Sval = No_Location;
515 end Instantiation_Depth;
517 ----------------------------
518 -- Instantiation_Location --
519 ----------------------------
521 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
523 return Instantiation (Get_Source_File_Index (S));
524 end Instantiation_Location;
526 --------------------------
527 -- Iterate_On_Instances --
528 --------------------------
530 procedure Iterate_On_Instances is
532 for J in 1 .. Instances.Last loop
533 Process (J, Instances.Table (J));
535 end Iterate_On_Instances;
537 ----------------------
538 -- Last_Source_File --
539 ----------------------
541 function Last_Source_File return Source_File_Index is
543 return Source_File.Last;
544 end Last_Source_File;
550 function Line_Start (P : Source_Ptr) return Source_Ptr is
551 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
552 Src : constant Source_Buffer_Ptr :=
553 Source_File.Table (Sindex).Source_Text;
554 Sfirst : constant Source_Ptr :=
555 Source_File.Table (Sindex).Source_First;
561 and then Src (S - 1) /= CR
562 and then Src (S - 1) /= LF
571 (L : Physical_Line_Number;
572 S : Source_File_Index) return Source_Ptr
575 return Source_File.Table (S).Lines_Table (L);
584 Source_File.Locked := True;
588 ----------------------
589 -- Num_Source_Files --
590 ----------------------
592 function Num_Source_Files return Nat is
594 return Int (Source_File.Last) - Int (Source_File.First) + 1;
595 end Num_Source_Files;
597 ----------------------
598 -- Num_Source_Lines --
599 ----------------------
601 function Num_Source_Lines (S : Source_File_Index) return Nat is
603 return Nat (Source_File.Table (S).Last_Source_Line);
604 end Num_Source_Lines;
606 -----------------------
607 -- Original_Location --
608 -----------------------
610 function Original_Location (S : Source_Ptr) return Source_Ptr is
611 Sindex : Source_File_Index;
612 Tindex : Source_File_Index;
615 if S <= No_Location then
619 Sindex := Get_Source_File_Index (S);
621 if Instantiation (Sindex) = No_Location then
625 Tindex := Template (Sindex);
626 while Instantiation (Tindex) /= No_Location loop
627 Tindex := Template (Tindex);
630 return S - Source_First (Sindex) + Source_First (Tindex);
633 end Original_Location;
635 -------------------------
636 -- Physical_To_Logical --
637 -------------------------
639 function Physical_To_Logical
640 (Line : Physical_Line_Number;
641 S : Source_File_Index) return Logical_Line_Number
643 SFR : Source_File_Record renames Source_File.Table (S);
646 if SFR.Num_SRef_Pragmas = 0 then
647 return Logical_Line_Number (Line);
649 return SFR.Logical_Lines_Table (Line);
651 end Physical_To_Logical;
653 --------------------------------
654 -- Register_Source_Ref_Pragma --
655 --------------------------------
657 procedure Register_Source_Ref_Pragma
658 (File_Name : File_Name_Type;
659 Stripped_File_Name : File_Name_Type;
661 Line_After_Pragma : Physical_Line_Number)
663 subtype size_t is Memory.size_t;
665 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
667 ML : Logical_Line_Number;
670 if File_Name /= No_File then
671 SFR.Reference_Name := Stripped_File_Name;
672 SFR.Full_Ref_Name := File_Name;
674 if not Debug_Generated_Code then
675 SFR.Debug_Source_Name := Stripped_File_Name;
676 SFR.Full_Debug_Name := File_Name;
679 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
682 if SFR.Num_SRef_Pragmas = 1 then
683 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
686 if SFR.Logical_Lines_Table = null then
687 SFR.Logical_Lines_Table := To_Pointer
689 (size_t (SFR.Lines_Table_Max *
690 Logical_Lines_Table_Type'Component_Size /
694 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
696 ML := Logical_Line_Number (Mapped_Line);
697 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
698 SFR.Logical_Lines_Table (J) := ML;
701 end Register_Source_Ref_Pragma;
703 ---------------------------------
704 -- Set_Source_File_Index_Table --
705 ---------------------------------
707 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
710 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
712 SP := Source_File.Table (Xnew).Source_First;
713 pragma Assert (SP mod Source_Align = 0);
714 Ind := Int (SP) / Source_Align;
716 Source_File_Index_Table (Ind) := Xnew;
717 SP := SP + Source_Align;
720 end Set_Source_File_Index_Table;
722 ---------------------------
723 -- Skip_Line_Terminators --
724 ---------------------------
726 procedure Skip_Line_Terminators
727 (P : in out Source_Ptr;
728 Physical : out Boolean)
730 Chr : constant Character := Source (P);
734 if Source (P + 1) = LF then
743 elsif Chr = FF or else Chr = VT then
748 -- Otherwise we have a wide character
751 Skip_Wide (Source, P);
754 -- Fall through in the physical line terminator case. First deal with
755 -- making a possible entry into the lines table if one is needed.
757 -- Note: we are dealing with a real source file here, this cannot be
758 -- the instantiation case, so we need not worry about Sloc adjustment.
761 S : Source_File_Record
762 renames Source_File.Table (Current_Source_File);
767 -- Make entry in lines table if not already made (in some scan backup
768 -- cases, we will be rescanning previously scanned source, so the
769 -- entry may have already been made on the previous forward scan).
772 and then P > S.Lines_Table (S.Last_Source_Line)
774 Add_Line_Tables_Entry (S, P);
777 end Skip_Line_Terminators;
783 procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
785 function Process (N : Node_Id) return Traverse_Result;
786 -- Process function for traversing the node tree
788 procedure Traverse is new Traverse_Proc (Process);
794 function Process (N : Node_Id) return Traverse_Result is
795 Orig : constant Node_Id := Original_Node (N);
798 if Sloc (Orig) < Min then
799 if Sloc (Orig) > No_Location then
803 elsif Sloc (Orig) > Max then
804 if Sloc (Orig) > No_Location then
812 -- Start of processing for Sloc_Range
824 function Source_Offset (S : Source_Ptr) return Nat is
825 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
826 Sfirst : constant Source_Ptr :=
827 Source_File.Table (Sindex).Source_First;
829 return Nat (S - Sfirst);
832 ------------------------
833 -- Top_Level_Location --
834 ------------------------
836 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
844 Newloc := Instantiation_Location (Oldloc);
845 exit when Newloc = No_Location;
849 end Top_Level_Location;
855 procedure Tree_Read is
857 -- First we must free any old source buffer pointers
859 if not First_Time_Around then
860 for J in Source_File.First .. Source_File.Last loop
862 S : Source_File_Record renames Source_File.Table (J);
864 procedure Free_Ptr is new Unchecked_Deallocation
865 (Big_Source_Buffer, Source_Buffer_Ptr);
867 pragma Warnings (Off);
868 -- This unchecked conversion is aliasing safe, since it is not
869 -- used to create improperly aliased pointer values.
871 function To_Source_Buffer_Ptr is new
872 Unchecked_Conversion (Address, Source_Buffer_Ptr);
874 pragma Warnings (On);
876 Tmp1 : Source_Buffer_Ptr;
879 if S.Instance /= No_Instance_Id then
883 -- Free the buffer, we use Free here, because we used malloc
884 -- or realloc directly to allocate the tables. That is
885 -- because we were playing the big array trick.
887 -- We have to recreate a proper pointer to the actual array
888 -- from the zero origin pointer stored in the source table.
892 (S.Source_Text (S.Source_First)'Address);
895 if S.Lines_Table /= null then
896 Memory.Free (To_Address (S.Lines_Table));
897 S.Lines_Table := null;
900 if S.Logical_Lines_Table /= null then
901 Memory.Free (To_Address (S.Logical_Lines_Table));
902 S.Logical_Lines_Table := null;
909 -- Read in source file table and instance table
911 Source_File.Tree_Read;
914 -- The pointers we read in there for the source buffer and lines table
915 -- pointers are junk. We now read in the actual data that is referenced
916 -- by these two fields.
918 for J in Source_File.First .. Source_File.Last loop
920 S : Source_File_Record renames Source_File.Table (J);
923 -- For the instantiation case, we do not read in any data. Instead
924 -- we share the data for the generic template entry. Since the
925 -- template always occurs first, we can safely refer to its data.
927 if S.Instance /= No_Instance_Id then
929 ST : Source_File_Record renames
930 Source_File.Table (S.Template);
933 -- The lines tables are copied from the template entry
936 Source_File.Table (S.Template).Lines_Table;
937 S.Logical_Lines_Table :=
938 Source_File.Table (S.Template).Logical_Lines_Table;
940 -- In the case of the source table pointer, we share the
941 -- same data as the generic template, but the virtual origin
942 -- is adjusted. For example, if the first subscript of the
943 -- template is 100, and that of the instantiation is 200,
944 -- then the instantiation pointer is obtained by subtracting
945 -- 100 from the template pointer.
948 pragma Suppress (All_Checks);
950 pragma Warnings (Off);
951 -- This unchecked conversion is aliasing safe since it
952 -- not used to create improperly aliased pointer values.
954 function To_Source_Buffer_Ptr is new
955 Unchecked_Conversion (Address, Source_Buffer_Ptr);
957 pragma Warnings (On);
963 (ST.Source_First - S.Source_First)'Address);
967 -- Normal case (non-instantiation)
970 First_Time_Around := False;
971 S.Lines_Table := null;
972 S.Logical_Lines_Table := null;
973 Alloc_Line_Tables (S, Int (S.Last_Source_Line));
975 for J in 1 .. S.Last_Source_Line loop
976 Tree_Read_Int (Int (S.Lines_Table (J)));
979 if S.Num_SRef_Pragmas /= 0 then
980 for J in 1 .. S.Last_Source_Line loop
981 Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
985 -- Allocate source buffer and read in the data and then set the
986 -- virtual origin to point to the logical zero'th element. This
987 -- address must be computed with subscript checks turned off.
990 subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
991 type Text_Buffer_Ptr is access B;
994 pragma Suppress (All_Checks);
996 pragma Warnings (Off);
997 -- This unchecked conversion is aliasing safe, since it is
998 -- never used to create improperly aliased pointer values.
1000 function To_Source_Buffer_Ptr is new
1001 Unchecked_Conversion (Address, Source_Buffer_Ptr);
1003 pragma Warnings (On);
1008 Tree_Read_Data (T (S.Source_First)'Address,
1009 Int (S.Source_Last) - Int (S.Source_First) + 1);
1011 S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
1016 Set_Source_File_Index_Table (J);
1024 procedure Tree_Write is
1026 Source_File.Tree_Write;
1027 Instances.Tree_Write;
1029 -- The pointers we wrote out there for the source buffer and lines
1030 -- table pointers are junk, we now write out the actual data that
1031 -- is referenced by these two fields.
1033 for J in Source_File.First .. Source_File.Last loop
1035 S : Source_File_Record renames Source_File.Table (J);
1038 -- For instantiations, there is nothing to do, since the data is
1039 -- shared with the generic template. When the tree is read, the
1040 -- pointers must be set, but no extra data needs to be written.
1042 if S.Instance /= No_Instance_Id then
1045 -- For the normal case, write out the data of the tables
1050 for J in 1 .. S.Last_Source_Line loop
1051 Tree_Write_Int (Int (S.Lines_Table (J)));
1054 -- Logical lines table if present
1056 if S.Num_SRef_Pragmas /= 0 then
1057 for J in 1 .. S.Last_Source_Line loop
1058 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
1065 (S.Source_Text (S.Source_First)'Address,
1066 Int (S.Source_Last) - Int (S.Source_First) + 1);
1072 --------------------
1073 -- Write_Location --
1074 --------------------
1076 procedure Write_Location (P : Source_Ptr) is
1078 if P = No_Location then
1079 Write_Str ("<no location>");
1081 elsif P <= Standard_Location then
1082 Write_Str ("<standard location>");
1086 SI : constant Source_File_Index := Get_Source_File_Index (P);
1089 Write_Name (Debug_Source_Name (SI));
1091 Write_Int (Int (Get_Logical_Line_Number (P)));
1093 Write_Int (Int (Get_Column_Number (P)));
1095 if Instantiation (SI) /= No_Location then
1097 Write_Location (Instantiation (SI));
1104 ----------------------
1105 -- Write_Time_Stamp --
1106 ----------------------
1108 procedure Write_Time_Stamp (S : Source_File_Index) is
1109 T : constant Time_Stamp_Type := Time_Stamp (S);
1122 Write_Char (T (P + 1));
1123 Write_Char (T (P + 2));
1126 Write_Char (T (P + 3));
1127 Write_Char (T (P + 4));
1130 Write_Char (T (P + 5));
1131 Write_Char (T (P + 6));
1134 Write_Char (T (P + 7));
1135 Write_Char (T (P + 8));
1138 Write_Char (T (P + 9));
1139 Write_Char (T (P + 10));
1142 Write_Char (T (P + 11));
1143 Write_Char (T (P + 12));
1144 end Write_Time_Stamp;
1146 ----------------------------------------------
1147 -- Access Subprograms for Source File Table --
1148 ----------------------------------------------
1150 function Debug_Source_Name (S : SFI) return File_Name_Type is
1152 return Source_File.Table (S).Debug_Source_Name;
1153 end Debug_Source_Name;
1155 function Instance (S : SFI) return Instance_Id is
1157 return Source_File.Table (S).Instance;
1160 function File_Name (S : SFI) return File_Name_Type is
1162 return Source_File.Table (S).File_Name;
1165 function File_Type (S : SFI) return Type_Of_File is
1167 return Source_File.Table (S).File_Type;
1170 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1172 return Source_File.Table (S).First_Mapped_Line;
1173 end First_Mapped_Line;
1175 function Full_Debug_Name (S : SFI) return File_Name_Type is
1177 return Source_File.Table (S).Full_Debug_Name;
1178 end Full_Debug_Name;
1180 function Full_File_Name (S : SFI) return File_Name_Type is
1182 return Source_File.Table (S).Full_File_Name;
1185 function Full_Ref_Name (S : SFI) return File_Name_Type is
1187 return Source_File.Table (S).Full_Ref_Name;
1190 function Identifier_Casing (S : SFI) return Casing_Type is
1192 return Source_File.Table (S).Identifier_Casing;
1193 end Identifier_Casing;
1195 function Inlined_Body (S : SFI) return Boolean is
1197 return Source_File.Table (S).Inlined_Body;
1200 function Inlined_Call (S : SFI) return Source_Ptr is
1202 return Source_File.Table (S).Inlined_Call;
1205 function Keyword_Casing (S : SFI) return Casing_Type is
1207 return Source_File.Table (S).Keyword_Casing;
1210 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1212 return Source_File.Table (S).Last_Source_Line;
1213 end Last_Source_Line;
1215 function License (S : SFI) return License_Type is
1217 return Source_File.Table (S).License;
1220 function Num_SRef_Pragmas (S : SFI) return Nat is
1222 return Source_File.Table (S).Num_SRef_Pragmas;
1223 end Num_SRef_Pragmas;
1225 function Reference_Name (S : SFI) return File_Name_Type is
1227 return Source_File.Table (S).Reference_Name;
1230 function Source_Checksum (S : SFI) return Word is
1232 return Source_File.Table (S).Source_Checksum;
1233 end Source_Checksum;
1235 function Source_First (S : SFI) return Source_Ptr is
1237 if S = Internal_Source_File then
1238 return Internal_Source'First;
1240 return Source_File.Table (S).Source_First;
1244 function Source_Last (S : SFI) return Source_Ptr is
1246 if S = Internal_Source_File then
1247 return Internal_Source'Last;
1249 return Source_File.Table (S).Source_Last;
1253 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1255 if S = Internal_Source_File then
1256 return Internal_Source_Ptr;
1258 return Source_File.Table (S).Source_Text;
1262 function Template (S : SFI) return SFI is
1264 return Source_File.Table (S).Template;
1267 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1269 return Source_File.Table (S).Time_Stamp;
1272 function Unit (S : SFI) return Unit_Number_Type is
1274 return Source_File.Table (S).Unit;
1277 ------------------------------------------
1278 -- Set Procedures for Source File Table --
1279 ------------------------------------------
1281 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1283 Source_File.Table (S).Identifier_Casing := C;
1284 end Set_Identifier_Casing;
1286 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1288 Source_File.Table (S).Keyword_Casing := C;
1289 end Set_Keyword_Casing;
1291 procedure Set_License (S : SFI; L : License_Type) is
1293 Source_File.Table (S).License := L;
1296 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1298 Source_File.Table (S).Unit := U;
1301 ----------------------
1302 -- Trim_Lines_Table --
1303 ----------------------
1305 procedure Trim_Lines_Table (S : Source_File_Index) is
1306 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1309 -- Release allocated storage that is no longer needed
1311 Source_File.Table (S).Lines_Table := To_Pointer
1313 (To_Address (Source_File.Table (S).Lines_Table),
1315 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1316 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1317 end Trim_Lines_Table;
1325 Source_File.Locked := False;
1326 Source_File.Release;
1333 procedure wl (P : Source_Ptr) is