1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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
;
39 with Output
; use Output
;
40 with Tree_IO
; use Tree_IO
;
41 with System
; use System
;
42 with Widechar
; use Widechar
;
46 with Unchecked_Conversion
;
47 with Unchecked_Deallocation
;
49 package body Sinput
is
52 -- Make control characters visible
54 First_Time_Around
: Boolean := True;
56 -- Routines to support conversion between types Lines_Table_Ptr,
57 -- Logical_Lines_Table_Ptr and System.Address.
59 pragma Warnings
(Off
);
60 -- These unchecked conversions are aliasing safe, since they are never
61 -- used to construct improperly aliased pointer values.
63 function To_Address
is
64 new Unchecked_Conversion
(Lines_Table_Ptr
, Address
);
66 function To_Address
is
67 new Unchecked_Conversion
(Logical_Lines_Table_Ptr
, Address
);
69 function To_Pointer
is
70 new Unchecked_Conversion
(Address
, Lines_Table_Ptr
);
72 function To_Pointer
is
73 new Unchecked_Conversion
(Address
, Logical_Lines_Table_Ptr
);
77 ---------------------------
78 -- Add_Line_Tables_Entry --
79 ---------------------------
81 procedure Add_Line_Tables_Entry
82 (S
: in out Source_File_Record
;
85 LL
: Physical_Line_Number
;
88 -- Reallocate the lines tables if necessary
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
95 if S
.Last_Source_Line
= S
.Lines_Table_Max
then
98 Int
(S
.Last_Source_Line
) *
99 ((100 + Alloc
.Lines_Increment
) / 100));
102 Write_Str
("--> Reallocating lines table, size = ");
103 Write_Int
(Int
(S
.Lines_Table_Max
));
108 S
.Last_Source_Line
:= S
.Last_Source_Line
+ 1;
109 LL
:= S
.Last_Source_Line
;
111 S
.Lines_Table
(LL
) := P
;
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),
117 if S
.Logical_Lines_Table
/= null then
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.
123 S
.Logical_Lines_Table
(LL
) := S
.Logical_Lines_Table
(LL
- 1) + 1;
125 end Add_Line_Tables_Entry
;
127 -----------------------
128 -- Alloc_Line_Tables --
129 -----------------------
131 procedure Alloc_Line_Tables
132 (S
: in out Source_File_Record
;
135 subtype size_t
is Memory
.size_t
;
137 New_Table
: Lines_Table_Ptr
;
139 New_Logical_Table
: Logical_Lines_Table_Ptr
;
141 New_Size
: constant size_t
:=
142 size_t
(New_Max
* Lines_Table_Type
'Component_Size /
146 if S
.Lines_Table
= null then
147 New_Table
:= To_Pointer
(Memory
.Alloc
(New_Size
));
151 To_Pointer
(Memory
.Realloc
(To_Address
(S
.Lines_Table
), New_Size
));
154 if New_Table
= null then
157 S
.Lines_Table
:= New_Table
;
158 S
.Lines_Table_Max
:= Physical_Line_Number
(New_Max
);
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
));
165 New_Logical_Table
:= To_Pointer
166 (Memory
.Realloc
(To_Address
(S
.Logical_Lines_Table
), New_Size
));
169 if New_Logical_Table
= null then
172 S
.Logical_Lines_Table
:= New_Logical_Table
;
175 end Alloc_Line_Tables
;
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
;
196 if Src
(P
- 1) = LF
then
201 if Src
(P
- 1) = CR
then
206 -- Now find first character of the previous line
209 and then Src
(P
- 1) /= LF
210 and then Src
(P
- 1) /= CR
216 ---------------------------
217 -- Build_Location_String --
218 ---------------------------
220 procedure Build_Location_String
(Loc
: Source_Ptr
) is
224 -- Loop through instantiations
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
)));
234 Ptr
:= Instantiation_Location
(Ptr
);
235 exit when Ptr
= No_Location
;
236 Add_Str_To_Name_Buffer
(" instantiated at ");
239 Name_Buffer
(Name_Len
+ 1) := NUL
;
241 end Build_Location_String
;
243 -----------------------
244 -- Get_Column_Number --
245 -----------------------
247 function Get_Column_Number
(P
: Source_Ptr
) return Column_Number
is
250 Sindex
: Source_File_Index
;
251 Src
: Source_Buffer_Ptr
;
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.
264 Sindex
:= Get_Source_File_Index
(P
);
265 Src
:= Source_File
.Table
(Sindex
).Source_Text
;
271 C
:= (C
- 1) / 8 * 8 + (8 + 1);
281 end Get_Column_Number
;
283 -----------------------------
284 -- Get_Logical_Line_Number --
285 -----------------------------
287 function Get_Logical_Line_Number
289 return Logical_Line_Number
291 SFR
: Source_File_Record
292 renames Source_File
.Table
(Get_Source_File_Index
(P
));
294 L
: constant Physical_Line_Number
:= Get_Physical_Line_Number
(P
);
297 if SFR
.Num_SRef_Pragmas
= 0 then
298 return Logical_Line_Number
(L
);
300 return SFR
.Logical_Lines_Table
(L
);
302 end Get_Logical_Line_Number
;
304 ------------------------------
305 -- Get_Physical_Line_Number --
306 ------------------------------
308 function Get_Physical_Line_Number
310 return Physical_Line_Number
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
;
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.
329 -- Otherwise we can do the binary search
332 Sfile
:= Get_Source_File_Index
(P
);
333 Loc
:= P
+ Source_File
.Table
(Sfile
).Sloc_Adjust
;
334 Table
:= Source_File
.Table
(Sfile
).Lines_Table
;
336 Hi
:= Source_File
.Table
(Sfile
).Last_Source_Line
;
339 Mid
:= (Lo
+ Hi
) / 2;
341 if Loc
< Table
(Mid
) then
344 else -- Loc >= Table (Mid)
347 Loc
< Table
(Mid
+ 1)
358 end Get_Physical_Line_Number
;
360 ---------------------------
361 -- Get_Source_File_Index --
362 ---------------------------
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.
371 Source_Cache_Index
: Source_File_Index
:= No_Source_File
;
372 -- Contains the index of the entry corresponding to Source_Cache
374 function Get_Source_File_Index
(S
: Source_Ptr
) return Source_File_Index
is
376 if S
in Source_Cache_First
.. Source_Cache_Last
then
377 return Source_Cache_Index
;
380 pragma Assert
(Source_File_Index_Table
(Int
(S
) / Chunk_Size
)
383 for J
in Source_File_Index_Table
(Int
(S
) / Chunk_Size
)
386 if S
in Source_File
.Table
(J
).Source_First
..
387 Source_File
.Table
(J
).Source_Last
389 Source_Cache_Index
:= J
;
390 Source_Cache_First
:=
391 Source_File
.Table
(Source_Cache_Index
).Source_First
;
393 Source_File
.Table
(Source_Cache_Index
).Source_Last
;
394 return Source_Cache_Index
;
399 -- We must find a matching entry in the above loop!
402 end Get_Source_File_Index
;
408 procedure Initialize
is
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;
419 -------------------------
420 -- Instantiation_Depth --
421 -------------------------
423 function Instantiation_Depth
(S
: Source_Ptr
) return Nat
is
424 Sind
: Source_File_Index
;
433 Sind
:= Get_Source_File_Index
(Sval
);
434 Sval
:= Instantiation
(Sind
);
435 exit when Sval
= No_Location
;
440 end Instantiation_Depth
;
442 ----------------------------
443 -- Instantiation_Location --
444 ----------------------------
446 function Instantiation_Location
(S
: Source_Ptr
) return Source_Ptr
is
448 return Instantiation
(Get_Source_File_Index
(S
));
449 end Instantiation_Location
;
451 ----------------------
452 -- Last_Source_File --
453 ----------------------
455 function Last_Source_File
return Source_File_Index
is
457 return Source_File
.Last
;
458 end Last_Source_File
;
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
;
476 and then Src
(S
- 1) /= CR
477 and then Src
(S
- 1) /= LF
486 (L
: Physical_Line_Number
;
487 S
: Source_File_Index
)
491 return Source_File
.Table
(S
).Lines_Table
(L
);
500 Source_File
.Locked
:= True;
504 ----------------------
505 -- Num_Source_Files --
506 ----------------------
508 function Num_Source_Files
return Nat
is
510 return Int
(Source_File
.Last
) - Int
(Source_File
.First
) + 1;
511 end Num_Source_Files
;
513 ----------------------
514 -- Num_Source_Lines --
515 ----------------------
517 function Num_Source_Lines
(S
: Source_File_Index
) return Nat
is
519 return Nat
(Source_File
.Table
(S
).Last_Source_Line
);
520 end Num_Source_Lines
;
522 -----------------------
523 -- Original_Location --
524 -----------------------
526 function Original_Location
(S
: Source_Ptr
) return Source_Ptr
is
527 Sindex
: Source_File_Index
;
528 Tindex
: Source_File_Index
;
531 if S
<= No_Location
then
535 Sindex
:= Get_Source_File_Index
(S
);
537 if Instantiation
(Sindex
) = No_Location
then
541 Tindex
:= Template
(Sindex
);
542 while Instantiation
(Tindex
) /= No_Location
loop
543 Tindex
:= Template
(Tindex
);
546 return S
- Source_First
(Sindex
) + Source_First
(Tindex
);
549 end Original_Location
;
551 -------------------------
552 -- Physical_To_Logical --
553 -------------------------
555 function Physical_To_Logical
556 (Line
: Physical_Line_Number
;
557 S
: Source_File_Index
)
558 return Logical_Line_Number
560 SFR
: Source_File_Record
renames Source_File
.Table
(S
);
563 if SFR
.Num_SRef_Pragmas
= 0 then
564 return Logical_Line_Number
(Line
);
566 return SFR
.Logical_Lines_Table
(Line
);
568 end Physical_To_Logical
;
570 --------------------------------
571 -- Register_Source_Ref_Pragma --
572 --------------------------------
574 procedure Register_Source_Ref_Pragma
575 (File_Name
: File_Name_Type
;
576 Stripped_File_Name
: File_Name_Type
;
578 Line_After_Pragma
: Physical_Line_Number
)
580 subtype size_t
is Memory
.size_t
;
582 SFR
: Source_File_Record
renames Source_File
.Table
(Current_Source_File
);
584 ML
: Logical_Line_Number
;
587 if File_Name
/= No_File
then
588 SFR
.Reference_Name
:= Stripped_File_Name
;
589 SFR
.Full_Ref_Name
:= File_Name
;
591 if not Debug_Generated_Code
then
592 SFR
.Debug_Source_Name
:= Stripped_File_Name
;
593 SFR
.Full_Debug_Name
:= File_Name
;
596 SFR
.Num_SRef_Pragmas
:= SFR
.Num_SRef_Pragmas
+ 1;
599 if SFR
.Num_SRef_Pragmas
= 1 then
600 SFR
.First_Mapped_Line
:= Logical_Line_Number
(Mapped_Line
);
603 if SFR
.Logical_Lines_Table
= null then
604 SFR
.Logical_Lines_Table
:= To_Pointer
606 (size_t
(SFR
.Lines_Table_Max
*
607 Logical_Lines_Table_Type
'Component_Size /
611 SFR
.Logical_Lines_Table
(Line_After_Pragma
- 1) := No_Line_Number
;
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
;
618 end Register_Source_Ref_Pragma
;
620 ---------------------------------
621 -- Set_Source_File_Index_Table --
622 ---------------------------------
624 procedure Set_Source_File_Index_Table
(Xnew
: Source_File_Index
) is
627 SL
: constant Source_Ptr
:= Source_File
.Table
(Xnew
).Source_Last
;
630 SP
:= (Source_File
.Table
(Xnew
).Source_First
+ Chunk_Size
- 1)
631 / Chunk_Size
* Chunk_Size
;
632 Ind
:= Int
(SP
) / Chunk_Size
;
635 Source_File_Index_Table
(Ind
) := Xnew
;
636 SP
:= SP
+ Chunk_Size
;
639 end Set_Source_File_Index_Table
;
641 ---------------------------
642 -- Skip_Line_Terminators --
643 ---------------------------
645 procedure Skip_Line_Terminators
646 (P
: in out Source_Ptr
;
647 Physical
: out Boolean)
649 Chr
: constant Character := Source
(P
);
653 if Source
(P
+ 1) = LF
then
660 if Source
(P
) = CR
then
666 elsif Chr
= FF
or else Chr
= VT
then
671 -- Otherwise we have a wide character
674 Skip_Wide
(Source
, P
);
677 -- Fall through in the physical line terminator case. First deal with
678 -- making a possible entry into the lines table if one is needed.
680 -- Note: we are dealing with a real source file here, this cannot be
681 -- the instantiation case, so we need not worry about Sloc adjustment.
684 S
: Source_File_Record
685 renames Source_File
.Table
(Current_Source_File
);
690 -- Make entry in lines table if not already made (in some scan backup
691 -- cases, we will be rescanning previously scanned source, so the
692 -- entry may have already been made on the previous forward scan).
695 and then P
> S
.Lines_Table
(S
.Last_Source_Line
)
697 Add_Line_Tables_Entry
(S
, P
);
700 end Skip_Line_Terminators
;
706 function Source_Offset
(S
: Source_Ptr
) return Nat
is
707 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(S
);
708 Sfirst
: constant Source_Ptr
:=
709 Source_File
.Table
(Sindex
).Source_First
;
712 return Nat
(S
- Sfirst
);
715 ------------------------
716 -- Top_Level_Location --
717 ------------------------
719 function Top_Level_Location
(S
: Source_Ptr
) return Source_Ptr
is
727 Newloc
:= Instantiation_Location
(Oldloc
);
728 exit when Newloc
= No_Location
;
732 end Top_Level_Location
;
738 procedure Tree_Read
is
740 -- First we must free any old source buffer pointers
742 if not First_Time_Around
then
743 for J
in Source_File
.First
.. Source_File
.Last
loop
745 S
: Source_File_Record
renames Source_File
.Table
(J
);
747 procedure Free_Ptr
is new Unchecked_Deallocation
748 (Big_Source_Buffer
, Source_Buffer_Ptr
);
750 pragma Warnings
(Off
);
751 -- This unchecked conversion is aliasing safe, since it is not
752 -- used to create improperly aliased pointer values.
754 function To_Source_Buffer_Ptr
is new
755 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
757 pragma Warnings
(On
);
759 Tmp1
: Source_Buffer_Ptr
;
762 if S
.Instantiation
/= No_Location
then
766 -- Free the buffer, we use Free here, because we used malloc
767 -- or realloc directly to allocate the tables. That is
768 -- because we were playing the big array trick. We need to
769 -- suppress the warning for freeing from an empty pool!
771 -- We have to recreate a proper pointer to the actual array
772 -- from the zero origin pointer stored in the source table.
776 (S
.Source_Text
(S
.Source_First
)'Address);
777 pragma Warnings
(Off
);
779 pragma Warnings
(On
);
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 safely 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
;
1211 Source_File
.Locked
:= False;
1212 Source_File
.Release
;
1219 procedure wl
(P
: Source_Ptr
) is