1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------
1159 -- Set Procedures for Source File Table --
1160 ------------------------------------------
1162 procedure Set_Identifier_Casing
(S
: SFI
; C
: Casing_Type
) is
1164 Source_File
.Table
(S
).Identifier_Casing
:= C
;
1165 end Set_Identifier_Casing
;
1167 procedure Set_Keyword_Casing
(S
: SFI
; C
: Casing_Type
) is
1169 Source_File
.Table
(S
).Keyword_Casing
:= C
;
1170 end Set_Keyword_Casing
;
1172 procedure Set_License
(S
: SFI
; L
: License_Type
) is
1174 Source_File
.Table
(S
).License
:= L
;
1177 ----------------------
1178 -- Trim_Lines_Table --
1179 ----------------------
1181 procedure Trim_Lines_Table
(S
: Source_File_Index
) is
1182 Max
: constant Nat
:= Nat
(Source_File
.Table
(S
).Last_Source_Line
);
1185 -- Release allocated storage that is no longer needed
1187 Source_File
.Table
(S
).Lines_Table
:= To_Pointer
1189 (To_Address
(Source_File
.Table
(S
).Lines_Table
),
1191 (Max
* (Lines_Table_Type
'Component_Size / System
.Storage_Unit
))));
1192 Source_File
.Table
(S
).Lines_Table_Max
:= Physical_Line_Number
(Max
);
1193 end Trim_Lines_Table
;
1199 procedure wl
(P
: Source_Ptr
) is