1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001 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
;
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 function To_Address
is
60 new Unchecked_Conversion
(Lines_Table_Ptr
, Address
);
62 function To_Address
is
63 new Unchecked_Conversion
(Logical_Lines_Table_Ptr
, Address
);
65 function To_Pointer
is
66 new Unchecked_Conversion
(Address
, Lines_Table_Ptr
);
68 function To_Pointer
is
69 new Unchecked_Conversion
(Address
, Logical_Lines_Table_Ptr
);
71 ---------------------------
72 -- Add_Line_Tables_Entry --
73 ---------------------------
75 procedure Add_Line_Tables_Entry
76 (S
: in out Source_File_Record
;
79 LL
: Physical_Line_Number
;
82 -- Reallocate the lines tables if necessary.
84 -- Note: the reason we do not use the normal Table package
85 -- mechanism is that we have several of these tables. We could
86 -- use the new GNAT.Dynamic_Tables package and that would probably
89 if S
.Last_Source_Line
= S
.Lines_Table_Max
then
92 Int
(S
.Last_Source_Line
) *
93 ((100 + Alloc
.Lines_Increment
) / 100));
96 Write_Str
("--> Reallocating lines table, size = ");
97 Write_Int
(Int
(S
.Lines_Table_Max
));
102 S
.Last_Source_Line
:= S
.Last_Source_Line
+ 1;
103 LL
:= S
.Last_Source_Line
;
105 S
.Lines_Table
(LL
) := P
;
107 -- Deal with setting new entry in logical lines table if one is
108 -- present. Note that there is always space (because the call to
109 -- Alloc_Line_Tables makes sure both tables are the same length),
111 if S
.Logical_Lines_Table
/= null then
113 -- We can always set the entry from the previous one, because
114 -- the processing for a Source_Reference pragma ensures that
115 -- at least one entry following the pragma is set up correctly.
117 S
.Logical_Lines_Table
(LL
) := S
.Logical_Lines_Table
(LL
- 1) + 1;
119 end Add_Line_Tables_Entry
;
121 -----------------------
122 -- Alloc_Line_Tables --
123 -----------------------
125 procedure Alloc_Line_Tables
126 (S
: in out Source_File_Record
;
129 subtype size_t
is Memory
.size_t
;
131 New_Table
: Lines_Table_Ptr
;
133 New_Logical_Table
: Logical_Lines_Table_Ptr
;
135 New_Size
: constant size_t
:=
136 size_t
(New_Max
* Lines_Table_Type
'Component_Size /
140 if S
.Lines_Table
= null then
141 New_Table
:= To_Pointer
(Memory
.Alloc
(New_Size
));
145 To_Pointer
(Memory
.Realloc
(To_Address
(S
.Lines_Table
), New_Size
));
148 if New_Table
= null then
151 S
.Lines_Table
:= New_Table
;
152 S
.Lines_Table_Max
:= Physical_Line_Number
(New_Max
);
155 if S
.Num_SRef_Pragmas
/= 0 then
156 if S
.Logical_Lines_Table
= null then
157 New_Logical_Table
:= To_Pointer
(Memory
.Alloc
(New_Size
));
159 New_Logical_Table
:= To_Pointer
160 (Memory
.Realloc
(To_Address
(S
.Logical_Lines_Table
), New_Size
));
163 if New_Logical_Table
= null then
166 S
.Logical_Lines_Table
:= New_Logical_Table
;
169 end Alloc_Line_Tables
;
175 procedure Backup_Line
(P
: in out Source_Ptr
) is
176 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
177 Src
: constant Source_Buffer_Ptr
:=
178 Source_File
.Table
(Sindex
).Source_Text
;
179 Sfirst
: constant Source_Ptr
:=
180 Source_File
.Table
(Sindex
).Source_First
;
190 if Src
(P
- 1) = LF
then
195 if Src
(P
- 1) = CR
then
200 -- Now find first character of the previous line
203 and then Src
(P
- 1) /= LF
204 and then Src
(P
- 1) /= CR
210 ---------------------------
211 -- Build_Location_String --
212 ---------------------------
214 procedure Build_Location_String
(Loc
: Source_Ptr
) is
220 -- Loop through instantiations
224 Get_Name_String_And_Append
225 (Reference_Name
(Get_Source_File_Index
(Ptr
)));
226 Add_Char_To_Name_Buffer
(':');
227 Add_Nat_To_Name_Buffer
228 (Nat
(Get_Logical_Line_Number
(Ptr
)));
230 Ptr
:= Instantiation_Location
(Ptr
);
231 exit when Ptr
= No_Location
;
232 Add_Str_To_Name_Buffer
(" instantiated at ");
235 Name_Buffer
(Name_Len
+ 1) := NUL
;
237 end Build_Location_String
;
239 -----------------------
240 -- Get_Column_Number --
241 -----------------------
243 function Get_Column_Number
(P
: Source_Ptr
) return Column_Number
is
246 Sindex
: Source_File_Index
;
247 Src
: Source_Buffer_Ptr
;
250 -- If the input source pointer is not a meaningful value then return
251 -- at once with column number 1. This can happen for a file not found
252 -- condition for a file loaded indirectly by RTE, and also perhaps on
253 -- some unknown internal error conditions. In either case we certainly
254 -- don't want to blow up.
260 Sindex
:= Get_Source_File_Index
(P
);
261 Src
:= Source_File
.Table
(Sindex
).Source_Text
;
267 C
:= (C
- 1) / 8 * 8 + (8 + 1);
277 end Get_Column_Number
;
279 -----------------------------
280 -- Get_Logical_Line_Number --
281 -----------------------------
283 function Get_Logical_Line_Number
285 return Logical_Line_Number
287 SFR
: Source_File_Record
288 renames Source_File
.Table
(Get_Source_File_Index
(P
));
290 L
: constant Physical_Line_Number
:= Get_Physical_Line_Number
(P
);
293 if SFR
.Num_SRef_Pragmas
= 0 then
294 return Logical_Line_Number
(L
);
296 return SFR
.Logical_Lines_Table
(L
);
298 end Get_Logical_Line_Number
;
300 ------------------------------
301 -- Get_Physical_Line_Number --
302 ------------------------------
304 function Get_Physical_Line_Number
306 return Physical_Line_Number
308 Sfile
: Source_File_Index
;
309 Table
: Lines_Table_Ptr
;
310 Lo
: Physical_Line_Number
;
311 Hi
: Physical_Line_Number
;
312 Mid
: Physical_Line_Number
;
316 -- If the input source pointer is not a meaningful value then return
317 -- at once with line number 1. This can happen for a file not found
318 -- condition for a file loaded indirectly by RTE, and also perhaps on
319 -- some unknown internal error conditions. In either case we certainly
320 -- don't want to blow up.
325 -- Otherwise we can do the binary search
328 Sfile
:= Get_Source_File_Index
(P
);
329 Loc
:= P
+ Source_File
.Table
(Sfile
).Sloc_Adjust
;
330 Table
:= Source_File
.Table
(Sfile
).Lines_Table
;
332 Hi
:= Source_File
.Table
(Sfile
).Last_Source_Line
;
335 Mid
:= (Lo
+ Hi
) / 2;
337 if Loc
< Table
(Mid
) then
340 else -- Loc >= Table (Mid)
343 Loc
< Table
(Mid
+ 1)
354 end Get_Physical_Line_Number
;
356 ---------------------------
357 -- Get_Source_File_Index --
358 ---------------------------
360 Source_Cache_First
: Source_Ptr
:= 1;
361 Source_Cache_Last
: Source_Ptr
:= 0;
362 -- Records the First and Last subscript values for the most recently
363 -- referenced entry in the source table, to optimize the common case
364 -- of repeated references to the same entry. The initial values force
365 -- an initial search to set the cache value.
367 Source_Cache_Index
: Source_File_Index
:= No_Source_File
;
368 -- Contains the index of the entry corresponding to Source_Cache
370 function Get_Source_File_Index
372 return Source_File_Index
375 if S
in Source_Cache_First
.. Source_Cache_Last
then
376 return Source_Cache_Index
;
379 for J
in 1 .. Source_File
.Last
loop
380 if S
in Source_File
.Table
(J
).Source_First
..
381 Source_File
.Table
(J
).Source_Last
383 Source_Cache_Index
:= J
;
384 Source_Cache_First
:=
385 Source_File
.Table
(Source_Cache_Index
).Source_First
;
387 Source_File
.Table
(Source_Cache_Index
).Source_Last
;
388 return Source_Cache_Index
;
393 -- We must find a matching entry in the above loop!
396 end Get_Source_File_Index
;
402 procedure Initialize
is
407 -------------------------
408 -- Instantiation_Depth --
409 -------------------------
411 function Instantiation_Depth
(S
: Source_Ptr
) return Nat
is
412 Sind
: Source_File_Index
;
421 Sind
:= Get_Source_File_Index
(Sval
);
422 Sval
:= Instantiation
(Sind
);
423 exit when Sval
= No_Location
;
428 end Instantiation_Depth
;
430 ----------------------------
431 -- Instantiation_Location --
432 ----------------------------
434 function Instantiation_Location
(S
: Source_Ptr
) return Source_Ptr
is
436 return Instantiation
(Get_Source_File_Index
(S
));
437 end Instantiation_Location
;
439 ----------------------
440 -- Last_Source_File --
441 ----------------------
443 function Last_Source_File
return Source_File_Index
is
445 return Source_File
.Last
;
446 end Last_Source_File
;
452 function Line_Start
(P
: Source_Ptr
) return Source_Ptr
is
453 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
454 Src
: constant Source_Buffer_Ptr
:=
455 Source_File
.Table
(Sindex
).Source_Text
;
456 Sfirst
: constant Source_Ptr
:=
457 Source_File
.Table
(Sindex
).Source_First
;
464 and then Src
(S
- 1) /= CR
465 and then Src
(S
- 1) /= LF
474 (L
: Physical_Line_Number
;
475 S
: Source_File_Index
)
479 return Source_File
.Table
(S
).Lines_Table
(L
);
488 Source_File
.Locked
:= True;
492 ----------------------
493 -- Num_Source_Files --
494 ----------------------
496 function Num_Source_Files
return Nat
is
498 return Int
(Source_File
.Last
) - Int
(Source_File
.First
) + 1;
499 end Num_Source_Files
;
501 ----------------------
502 -- Num_Source_Lines --
503 ----------------------
505 function Num_Source_Lines
(S
: Source_File_Index
) return Nat
is
507 return Nat
(Source_File
.Table
(S
).Last_Source_Line
);
508 end Num_Source_Lines
;
510 -----------------------
511 -- Original_Location --
512 -----------------------
514 function Original_Location
(S
: Source_Ptr
) return Source_Ptr
is
515 Sindex
: Source_File_Index
;
516 Tindex
: Source_File_Index
;
519 if S
<= No_Location
then
523 Sindex
:= Get_Source_File_Index
(S
);
525 if Instantiation
(Sindex
) = No_Location
then
529 Tindex
:= Template
(Sindex
);
530 while Instantiation
(Tindex
) /= No_Location
loop
531 Tindex
:= Template
(Tindex
);
534 return S
- Source_First
(Sindex
) + Source_First
(Tindex
);
537 end Original_Location
;
539 -------------------------
540 -- Physical_To_Logical --
541 -------------------------
543 function Physical_To_Logical
544 (Line
: Physical_Line_Number
;
545 S
: Source_File_Index
)
546 return Logical_Line_Number
548 SFR
: Source_File_Record
renames Source_File
.Table
(S
);
551 if SFR
.Num_SRef_Pragmas
= 0 then
552 return Logical_Line_Number
(Line
);
554 return SFR
.Logical_Lines_Table
(Line
);
556 end Physical_To_Logical
;
558 --------------------------------
559 -- Register_Source_Ref_Pragma --
560 --------------------------------
562 procedure Register_Source_Ref_Pragma
563 (File_Name
: Name_Id
;
564 Stripped_File_Name
: Name_Id
;
566 Line_After_Pragma
: Physical_Line_Number
)
568 subtype size_t
is Memory
.size_t
;
570 SFR
: Source_File_Record
renames Source_File
.Table
(Current_Source_File
);
572 ML
: Logical_Line_Number
;
575 if File_Name
/= No_Name
then
576 SFR
.Full_Ref_Name
:= File_Name
;
578 if not Debug_Generated_Code
then
579 SFR
.Debug_Source_Name
:= File_Name
;
582 SFR
.Reference_Name
:= Stripped_File_Name
;
583 SFR
.Num_SRef_Pragmas
:= SFR
.Num_SRef_Pragmas
+ 1;
586 if SFR
.Num_SRef_Pragmas
= 1 then
587 SFR
.First_Mapped_Line
:= Logical_Line_Number
(Mapped_Line
);
590 if SFR
.Logical_Lines_Table
= null then
591 SFR
.Logical_Lines_Table
:= To_Pointer
593 (size_t
(SFR
.Lines_Table_Max
*
594 Logical_Lines_Table_Type
'Component_Size /
598 SFR
.Logical_Lines_Table
(Line_After_Pragma
- 1) := No_Line_Number
;
600 ML
:= Logical_Line_Number
(Mapped_Line
);
601 for J
in Line_After_Pragma
.. SFR
.Last_Source_Line
loop
602 SFR
.Logical_Lines_Table
(J
) := ML
;
605 end Register_Source_Ref_Pragma
;
607 ---------------------------
608 -- Skip_Line_Terminators --
609 ---------------------------
611 -- There are two distinct concepts of line terminator in GNAT
613 -- A logical line terminator is what corresponds to the "end of a line"
614 -- as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
615 -- acts as an end of logical line in this sense, and it is essentially
616 -- irrelevant whether one or more appears in sequence (since if a
617 -- sequence of such characters is regarded as separate ends of line,
618 -- then the intervening logical lines are null in any case).
620 -- A physical line terminator is a sequence of format effectors that
621 -- is treated as ending a physical line. Physical lines have no Ada
622 -- semantic significance, but they are significant for error reporting
623 -- purposes, since errors are identified by line and column location.
625 -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
626 -- CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
627 -- and CR alone in System 7. We don't know of any system using LF/CR, but
628 -- it seems reasonable to include this case for consistency. In addition,
629 -- we recognize any of these sequences in any of the operating systems,
630 -- for better behavior in treating foreign files (e.g. a Unix file with
631 -- LF terminators transferred to a DOS system).
633 procedure Skip_Line_Terminators
634 (P
: in out Source_Ptr
;
635 Physical
: out Boolean)
638 pragma Assert
(Source
(P
) in Line_Terminator
);
640 if Source
(P
) = CR
then
641 if Source
(P
+ 1) = LF
then
647 elsif Source
(P
) = LF
then
648 if Source
(P
+ 1) = CR
then
654 else -- Source (P) = FF or else Source (P) = VT
660 -- Fall through in the physical line terminator case. First deal with
661 -- making a possible entry into the lines table if one is needed.
663 -- Note: we are dealing with a real source file here, this cannot be
664 -- the instantiation case, so we need not worry about Sloc adjustment.
667 S
: Source_File_Record
668 renames Source_File
.Table
(Current_Source_File
);
673 -- Make entry in lines table if not already made (in some scan backup
674 -- cases, we will be rescanning previously scanned source, so the
675 -- entry may have already been made on the previous forward scan).
678 and then P
> S
.Lines_Table
(S
.Last_Source_Line
)
680 Add_Line_Tables_Entry
(S
, P
);
683 end Skip_Line_Terminators
;
689 function Source_Offset
(S
: Source_Ptr
) return Nat
is
690 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(S
);
691 Sfirst
: constant Source_Ptr
:=
692 Source_File
.Table
(Sindex
).Source_First
;
695 return Nat
(S
- Sfirst
);
698 ------------------------
699 -- Top_Level_Location --
700 ------------------------
702 function Top_Level_Location
(S
: Source_Ptr
) return Source_Ptr
is
710 Newloc
:= Instantiation_Location
(Oldloc
);
711 exit when Newloc
= No_Location
;
715 end Top_Level_Location
;
721 procedure Tree_Read
is
723 -- First we must free any old source buffer pointers
725 if not First_Time_Around
then
726 for J
in Source_File
.First
.. Source_File
.Last
loop
728 S
: Source_File_Record
renames Source_File
.Table
(J
);
730 procedure Free_Ptr
is new Unchecked_Deallocation
731 (Big_Source_Buffer
, Source_Buffer_Ptr
);
733 function To_Source_Buffer_Ptr
is new
734 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
736 Tmp1
: Source_Buffer_Ptr
;
739 if S
.Instantiation
/= No_Location
then
743 -- We have to recreate a proper pointer to the actual array
744 -- from the zero origin pointer stored in the source table.
748 (S
.Source_Text
(S
.Source_First
)'Address);
751 -- Note: we are using free here, because we used malloc
752 -- or realloc directly to allocate the tables. That is
753 -- because we were playing the big array trick.
755 if S
.Lines_Table
/= null then
756 Memory
.Free
(To_Address
(S
.Lines_Table
));
757 S
.Lines_Table
:= null;
760 if S
.Logical_Lines_Table
/= null then
761 Memory
.Free
(To_Address
(S
.Logical_Lines_Table
));
762 S
.Logical_Lines_Table
:= null;
769 -- Reset source cache pointers to force new read
771 Source_Cache_First
:= 1;
772 Source_Cache_Last
:= 0;
774 -- Read in source file table
776 Source_File
.Tree_Read
;
778 -- The pointers we read in there for the source buffer and lines
779 -- table pointers are junk. We now read in the actual data that
780 -- is referenced by these two fields.
782 for J
in Source_File
.First
.. Source_File
.Last
loop
784 S
: Source_File_Record
renames Source_File
.Table
(J
);
787 -- For the instantiation case, we do not read in any data. Instead
788 -- we share the data for the generic template entry. Since the
789 -- template always occurs first, we can safetly refer to its data.
791 if S
.Instantiation
/= No_Location
then
793 ST
: Source_File_Record
renames
794 Source_File
.Table
(S
.Template
);
797 -- The lines tables are copied from the template entry
800 Source_File
.Table
(S
.Template
).Lines_Table
;
801 S
.Logical_Lines_Table
:=
802 Source_File
.Table
(S
.Template
).Logical_Lines_Table
;
804 -- In the case of the source table pointer, we share the
805 -- same data as the generic template, but the virtual origin
806 -- is adjusted. For example, if the first subscript of the
807 -- template is 100, and that of the instantiation is 200,
808 -- then the instantiation pointer is obtained by subtracting
809 -- 100 from the template pointer.
812 pragma Suppress
(All_Checks
);
814 function To_Source_Buffer_Ptr
is new
815 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
821 (ST
.Source_First
- S
.Source_First
)'Address);
825 -- Normal case (non-instantiation)
828 First_Time_Around
:= False;
829 S
.Lines_Table
:= null;
830 S
.Logical_Lines_Table
:= null;
831 Alloc_Line_Tables
(S
, Int
(S
.Last_Source_Line
));
833 for J
in 1 .. S
.Last_Source_Line
loop
834 Tree_Read_Int
(Int
(S
.Lines_Table
(J
)));
837 if S
.Num_SRef_Pragmas
/= 0 then
838 for J
in 1 .. S
.Last_Source_Line
loop
839 Tree_Read_Int
(Int
(S
.Logical_Lines_Table
(J
)));
843 -- Allocate source buffer and read in the data and then set the
844 -- virtual origin to point to the logical zero'th element. This
845 -- address must be computed with subscript checks turned off.
848 subtype B
is Text_Buffer
(S
.Source_First
.. S
.Source_Last
);
849 type Text_Buffer_Ptr
is access B
;
852 pragma Suppress
(All_Checks
);
854 function To_Source_Buffer_Ptr
is new
855 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
860 Tree_Read_Data
(T
(S
.Source_First
)'Address,
861 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
863 S
.Source_Text
:= To_Source_Buffer_Ptr
(T
(0)'Address);
874 procedure Tree_Write
is
876 Source_File
.Tree_Write
;
878 -- The pointers we wrote out there for the source buffer and lines
879 -- table pointers are junk, we now write out the actual data that
880 -- is referenced by these two fields.
882 for J
in Source_File
.First
.. Source_File
.Last
loop
884 S
: Source_File_Record
renames Source_File
.Table
(J
);
887 -- For instantiations, there is nothing to do, since the data is
888 -- shared with the generic template. When the tree is read, the
889 -- pointers must be set, but no extra data needs to be written.
891 if S
.Instantiation
/= No_Location
then
894 -- For the normal case, write out the data of the tables
899 for J
in 1 .. S
.Last_Source_Line
loop
900 Tree_Write_Int
(Int
(S
.Lines_Table
(J
)));
903 -- Logical lines table if present
905 if S
.Num_SRef_Pragmas
/= 0 then
906 for J
in 1 .. S
.Last_Source_Line
loop
907 Tree_Write_Int
(Int
(S
.Logical_Lines_Table
(J
)));
914 (S
.Source_Text
(S
.Source_First
)'Address,
915 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
925 procedure Write_Location
(P
: Source_Ptr
) is
927 if P
= No_Location
then
928 Write_Str
("<no location>");
930 elsif P
<= Standard_Location
then
931 Write_Str
("<standard location>");
935 SI
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
938 Write_Name
(Debug_Source_Name
(SI
));
940 Write_Int
(Int
(Get_Logical_Line_Number
(P
)));
942 Write_Int
(Int
(Get_Column_Number
(P
)));
944 if Instantiation
(SI
) /= No_Location
then
946 Write_Location
(Instantiation
(SI
));
953 ----------------------
954 -- Write_Time_Stamp --
955 ----------------------
957 procedure Write_Time_Stamp
(S
: Source_File_Index
) is
958 T
: constant Time_Stamp_Type
:= Time_Stamp
(S
);
971 Write_Char
(T
(P
+ 1));
972 Write_Char
(T
(P
+ 2));
975 Write_Char
(T
(P
+ 3));
976 Write_Char
(T
(P
+ 4));
979 Write_Char
(T
(P
+ 5));
980 Write_Char
(T
(P
+ 6));
983 Write_Char
(T
(P
+ 7));
984 Write_Char
(T
(P
+ 8));
987 Write_Char
(T
(P
+ 9));
988 Write_Char
(T
(P
+ 10));
991 Write_Char
(T
(P
+ 11));
992 Write_Char
(T
(P
+ 12));
993 end Write_Time_Stamp
;
995 ----------------------------------------------
996 -- Access Subprograms for Source File Table --
997 ----------------------------------------------
999 function Debug_Source_Name
(S
: SFI
) return File_Name_Type
is
1001 return Source_File
.Table
(S
).Debug_Source_Name
;
1002 end Debug_Source_Name
;
1004 function File_Name
(S
: SFI
) return File_Name_Type
is
1006 return Source_File
.Table
(S
).File_Name
;
1009 function First_Mapped_Line
(S
: SFI
) return Logical_Line_Number
is
1011 return Source_File
.Table
(S
).First_Mapped_Line
;
1012 end First_Mapped_Line
;
1014 function Full_File_Name
(S
: SFI
) return File_Name_Type
is
1016 return Source_File
.Table
(S
).Full_File_Name
;
1019 function Full_Ref_Name
(S
: SFI
) return File_Name_Type
is
1021 return Source_File
.Table
(S
).Full_Ref_Name
;
1024 function Identifier_Casing
(S
: SFI
) return Casing_Type
is
1026 return Source_File
.Table
(S
).Identifier_Casing
;
1027 end Identifier_Casing
;
1029 function Instantiation
(S
: SFI
) return Source_Ptr
is
1031 return Source_File
.Table
(S
).Instantiation
;
1034 function Keyword_Casing
(S
: SFI
) return Casing_Type
is
1036 return Source_File
.Table
(S
).Keyword_Casing
;
1039 function Last_Source_Line
(S
: SFI
) return Physical_Line_Number
is
1041 return Source_File
.Table
(S
).Last_Source_Line
;
1042 end Last_Source_Line
;
1044 function License
(S
: SFI
) return License_Type
is
1046 return Source_File
.Table
(S
).License
;
1049 function Num_SRef_Pragmas
(S
: SFI
) return Nat
is
1051 return Source_File
.Table
(S
).Num_SRef_Pragmas
;
1052 end Num_SRef_Pragmas
;
1054 function Reference_Name
(S
: SFI
) return File_Name_Type
is
1056 return Source_File
.Table
(S
).Reference_Name
;
1059 function Source_Checksum
(S
: SFI
) return Word
is
1061 return Source_File
.Table
(S
).Source_Checksum
;
1062 end Source_Checksum
;
1064 function Source_First
(S
: SFI
) return Source_Ptr
is
1066 return Source_File
.Table
(S
).Source_First
;
1069 function Source_Last
(S
: SFI
) return Source_Ptr
is
1071 return Source_File
.Table
(S
).Source_Last
;
1074 function Source_Text
(S
: SFI
) return Source_Buffer_Ptr
is
1076 return Source_File
.Table
(S
).Source_Text
;
1079 function Template
(S
: SFI
) return SFI
is
1081 return Source_File
.Table
(S
).Template
;
1084 function Time_Stamp
(S
: SFI
) return Time_Stamp_Type
is
1086 return Source_File
.Table
(S
).Time_Stamp
;
1089 ------------------------------------------
1090 -- Set Procedures for Source File Table --
1091 ------------------------------------------
1093 procedure Set_Identifier_Casing
(S
: SFI
; C
: Casing_Type
) is
1095 Source_File
.Table
(S
).Identifier_Casing
:= C
;
1096 end Set_Identifier_Casing
;
1098 procedure Set_Keyword_Casing
(S
: SFI
; C
: Casing_Type
) is
1100 Source_File
.Table
(S
).Keyword_Casing
:= C
;
1101 end Set_Keyword_Casing
;
1103 procedure Set_License
(S
: SFI
; L
: License_Type
) is
1105 Source_File
.Table
(S
).License
:= L
;
1108 ----------------------
1109 -- Trim_Lines_Table --
1110 ----------------------
1112 procedure Trim_Lines_Table
(S
: Source_File_Index
) is
1113 Max
: constant Nat
:= Nat
(Source_File
.Table
(S
).Last_Source_Line
);
1116 -- Release allocated storage that is no longer needed
1118 Source_File
.Table
(S
).Lines_Table
:= To_Pointer
1120 (To_Address
(Source_File
.Table
(S
).Lines_Table
),
1122 (Max
* (Lines_Table_Type
'Component_Size / System
.Storage_Unit
))));
1123 Source_File
.Table
(S
).Lines_Table_Max
:= Physical_Line_Number
(Max
);
1124 end Trim_Lines_Table
;
1130 procedure wl
(P
: Source_Ptr
) is