1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 -- Get_Column_Number --
307 -----------------------
309 function Get_Column_Number
(P
: Source_Ptr
) return Column_Number
is
312 Sindex
: Source_File_Index
;
313 Src
: Source_Buffer_Ptr
;
316 -- If the input source pointer is not a meaningful value then return
317 -- at once with column 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.
326 Sindex
:= Get_Source_File_Index
(P
);
327 Src
:= Source_File
.Table
(Sindex
).Source_Text
;
333 C
:= (C
- 1) / 8 * 8 + (8 + 1);
343 end Get_Column_Number
;
345 -----------------------------
346 -- Get_Logical_Line_Number --
347 -----------------------------
349 function Get_Logical_Line_Number
350 (P
: Source_Ptr
) return Logical_Line_Number
352 SFR
: Source_File_Record
353 renames Source_File
.Table
(Get_Source_File_Index
(P
));
355 L
: constant Physical_Line_Number
:= Get_Physical_Line_Number
(P
);
358 if SFR
.Num_SRef_Pragmas
= 0 then
359 return Logical_Line_Number
(L
);
361 return SFR
.Logical_Lines_Table
(L
);
363 end Get_Logical_Line_Number
;
365 ---------------------------------
366 -- Get_Logical_Line_Number_Img --
367 ---------------------------------
369 function Get_Logical_Line_Number_Img
370 (P
: Source_Ptr
) return String
374 Add_Nat_To_Name_Buffer
(Nat
(Get_Logical_Line_Number
(P
)));
375 return Name_Buffer
(1 .. Name_Len
);
376 end Get_Logical_Line_Number_Img
;
378 ------------------------------
379 -- Get_Physical_Line_Number --
380 ------------------------------
382 function Get_Physical_Line_Number
383 (P
: Source_Ptr
) return Physical_Line_Number
385 Sfile
: Source_File_Index
;
386 Table
: Lines_Table_Ptr
;
387 Lo
: Physical_Line_Number
;
388 Hi
: Physical_Line_Number
;
389 Mid
: Physical_Line_Number
;
393 -- If the input source pointer is not a meaningful value then return
394 -- at once with line number 1. This can happen for a file not found
395 -- condition for a file loaded indirectly by RTE, and also perhaps on
396 -- some unknown internal error conditions. In either case we certainly
397 -- don't want to blow up.
402 -- Otherwise we can do the binary search
405 Sfile
:= Get_Source_File_Index
(P
);
406 Loc
:= P
+ Source_File
.Table
(Sfile
).Sloc_Adjust
;
407 Table
:= Source_File
.Table
(Sfile
).Lines_Table
;
409 Hi
:= Source_File
.Table
(Sfile
).Last_Source_Line
;
412 Mid
:= (Lo
+ Hi
) / 2;
414 if Loc
< Table
(Mid
) then
417 else -- Loc >= Table (Mid)
420 Loc
< Table
(Mid
+ 1)
431 end Get_Physical_Line_Number
;
433 ---------------------------
434 -- Get_Source_File_Index --
435 ---------------------------
437 function Get_Source_File_Index
(S
: Source_Ptr
) return Source_File_Index
is
439 return Source_File_Index_Table
(Int
(S
) / Source_Align
);
440 end Get_Source_File_Index
;
446 procedure Initialize
is
448 Source_gnat_adc
:= No_Source_File
;
449 First_Time_Around
:= True;
454 Instances
.Append
(No_Location
);
455 pragma Assert
(Instances
.Last
= No_Instance_Id
);
462 function Instantiation
(S
: SFI
) return Source_Ptr
is
463 SIE
: Source_File_Record
renames Source_File
.Table
(S
);
465 if SIE
.Inlined_Body
then
466 return SIE
.Inlined_Call
;
468 return Instances
.Table
(SIE
.Instance
);
472 -------------------------
473 -- Instantiation_Depth --
474 -------------------------
476 function Instantiation_Depth
(S
: Source_Ptr
) return Nat
is
477 Sind
: Source_File_Index
;
486 Sind
:= Get_Source_File_Index
(Sval
);
487 Sval
:= Instantiation
(Sind
);
488 exit when Sval
= No_Location
;
493 end Instantiation_Depth
;
495 ----------------------------
496 -- Instantiation_Location --
497 ----------------------------
499 function Instantiation_Location
(S
: Source_Ptr
) return Source_Ptr
is
501 return Instantiation
(Get_Source_File_Index
(S
));
502 end Instantiation_Location
;
504 --------------------------
505 -- Iterate_On_Instances --
506 --------------------------
508 procedure Iterate_On_Instances
is
510 for J
in 1 .. Instances
.Last
loop
511 Process
(J
, Instances
.Table
(J
));
513 end Iterate_On_Instances
;
515 ----------------------
516 -- Last_Source_File --
517 ----------------------
519 function Last_Source_File
return Source_File_Index
is
521 return Source_File
.Last
;
522 end Last_Source_File
;
528 function Line_Start
(P
: Source_Ptr
) return Source_Ptr
is
529 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
530 Src
: constant Source_Buffer_Ptr
:=
531 Source_File
.Table
(Sindex
).Source_Text
;
532 Sfirst
: constant Source_Ptr
:=
533 Source_File
.Table
(Sindex
).Source_First
;
539 and then Src
(S
- 1) /= CR
540 and then Src
(S
- 1) /= LF
549 (L
: Physical_Line_Number
;
550 S
: Source_File_Index
) return Source_Ptr
553 return Source_File
.Table
(S
).Lines_Table
(L
);
562 Source_File
.Locked
:= True;
566 ----------------------
567 -- Num_Source_Files --
568 ----------------------
570 function Num_Source_Files
return Nat
is
572 return Int
(Source_File
.Last
) - Int
(Source_File
.First
) + 1;
573 end Num_Source_Files
;
575 ----------------------
576 -- Num_Source_Lines --
577 ----------------------
579 function Num_Source_Lines
(S
: Source_File_Index
) return Nat
is
581 return Nat
(Source_File
.Table
(S
).Last_Source_Line
);
582 end Num_Source_Lines
;
584 -----------------------
585 -- Original_Location --
586 -----------------------
588 function Original_Location
(S
: Source_Ptr
) return Source_Ptr
is
589 Sindex
: Source_File_Index
;
590 Tindex
: Source_File_Index
;
593 if S
<= No_Location
then
597 Sindex
:= Get_Source_File_Index
(S
);
599 if Instantiation
(Sindex
) = No_Location
then
603 Tindex
:= Template
(Sindex
);
604 while Instantiation
(Tindex
) /= No_Location
loop
605 Tindex
:= Template
(Tindex
);
608 return S
- Source_First
(Sindex
) + Source_First
(Tindex
);
611 end Original_Location
;
613 -------------------------
614 -- Physical_To_Logical --
615 -------------------------
617 function Physical_To_Logical
618 (Line
: Physical_Line_Number
;
619 S
: Source_File_Index
) return Logical_Line_Number
621 SFR
: Source_File_Record
renames Source_File
.Table
(S
);
624 if SFR
.Num_SRef_Pragmas
= 0 then
625 return Logical_Line_Number
(Line
);
627 return SFR
.Logical_Lines_Table
(Line
);
629 end Physical_To_Logical
;
631 --------------------------------
632 -- Register_Source_Ref_Pragma --
633 --------------------------------
635 procedure Register_Source_Ref_Pragma
636 (File_Name
: File_Name_Type
;
637 Stripped_File_Name
: File_Name_Type
;
639 Line_After_Pragma
: Physical_Line_Number
)
641 subtype size_t
is Memory
.size_t
;
643 SFR
: Source_File_Record
renames Source_File
.Table
(Current_Source_File
);
645 ML
: Logical_Line_Number
;
648 if File_Name
/= No_File
then
649 SFR
.Reference_Name
:= Stripped_File_Name
;
650 SFR
.Full_Ref_Name
:= File_Name
;
652 if not Debug_Generated_Code
then
653 SFR
.Debug_Source_Name
:= Stripped_File_Name
;
654 SFR
.Full_Debug_Name
:= File_Name
;
657 SFR
.Num_SRef_Pragmas
:= SFR
.Num_SRef_Pragmas
+ 1;
660 if SFR
.Num_SRef_Pragmas
= 1 then
661 SFR
.First_Mapped_Line
:= Logical_Line_Number
(Mapped_Line
);
664 if SFR
.Logical_Lines_Table
= null then
665 SFR
.Logical_Lines_Table
:= To_Pointer
667 (size_t
(SFR
.Lines_Table_Max
*
668 Logical_Lines_Table_Type
'Component_Size /
672 SFR
.Logical_Lines_Table
(Line_After_Pragma
- 1) := No_Line_Number
;
674 ML
:= Logical_Line_Number
(Mapped_Line
);
675 for J
in Line_After_Pragma
.. SFR
.Last_Source_Line
loop
676 SFR
.Logical_Lines_Table
(J
) := ML
;
679 end Register_Source_Ref_Pragma
;
681 ---------------------------------
682 -- Set_Source_File_Index_Table --
683 ---------------------------------
685 procedure Set_Source_File_Index_Table
(Xnew
: Source_File_Index
) is
688 SL
: constant Source_Ptr
:= Source_File
.Table
(Xnew
).Source_Last
;
690 SP
:= Source_File
.Table
(Xnew
).Source_First
;
691 pragma Assert
(SP
mod Source_Align
= 0);
692 Ind
:= Int
(SP
) / Source_Align
;
694 Source_File_Index_Table
(Ind
) := Xnew
;
695 SP
:= SP
+ Source_Align
;
698 end Set_Source_File_Index_Table
;
700 ---------------------------
701 -- Skip_Line_Terminators --
702 ---------------------------
704 procedure Skip_Line_Terminators
705 (P
: in out Source_Ptr
;
706 Physical
: out Boolean)
708 Chr
: constant Character := Source
(P
);
712 if Source
(P
+ 1) = LF
then
721 elsif Chr
= FF
or else Chr
= VT
then
726 -- Otherwise we have a wide character
729 Skip_Wide
(Source
, P
);
732 -- Fall through in the physical line terminator case. First deal with
733 -- making a possible entry into the lines table if one is needed.
735 -- Note: we are dealing with a real source file here, this cannot be
736 -- the instantiation case, so we need not worry about Sloc adjustment.
739 S
: Source_File_Record
740 renames Source_File
.Table
(Current_Source_File
);
745 -- Make entry in lines table if not already made (in some scan backup
746 -- cases, we will be rescanning previously scanned source, so the
747 -- entry may have already been made on the previous forward scan).
750 and then P
> S
.Lines_Table
(S
.Last_Source_Line
)
752 Add_Line_Tables_Entry
(S
, P
);
755 end Skip_Line_Terminators
;
761 procedure Sloc_Range
(N
: Node_Id
; Min
, Max
: out Source_Ptr
) is
763 function Process
(N
: Node_Id
) return Traverse_Result
;
764 -- Process function for traversing the node tree
766 procedure Traverse
is new Traverse_Proc
(Process
);
772 function Process
(N
: Node_Id
) return Traverse_Result
is
774 if Sloc
(N
) < Min
then
775 if Sloc
(N
) > No_Location
then
778 elsif Sloc
(N
) > Max
then
779 if Sloc
(N
) > No_Location
then
787 -- Start of processing for Sloc_Range
799 function Source_Offset
(S
: Source_Ptr
) return Nat
is
800 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(S
);
801 Sfirst
: constant Source_Ptr
:=
802 Source_File
.Table
(Sindex
).Source_First
;
804 return Nat
(S
- Sfirst
);
807 ------------------------
808 -- Top_Level_Location --
809 ------------------------
811 function Top_Level_Location
(S
: Source_Ptr
) return Source_Ptr
is
819 Newloc
:= Instantiation_Location
(Oldloc
);
820 exit when Newloc
= No_Location
;
824 end Top_Level_Location
;
830 procedure Tree_Read
is
832 -- First we must free any old source buffer pointers
834 if not First_Time_Around
then
835 for J
in Source_File
.First
.. Source_File
.Last
loop
837 S
: Source_File_Record
renames Source_File
.Table
(J
);
839 procedure Free_Ptr
is new Unchecked_Deallocation
840 (Big_Source_Buffer
, Source_Buffer_Ptr
);
842 pragma Warnings
(Off
);
843 -- This unchecked conversion is aliasing safe, since it is not
844 -- used to create improperly aliased pointer values.
846 function To_Source_Buffer_Ptr
is new
847 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
849 pragma Warnings
(On
);
851 Tmp1
: Source_Buffer_Ptr
;
854 if S
.Instance
/= No_Instance_Id
then
858 -- Free the buffer, we use Free here, because we used malloc
859 -- or realloc directly to allocate the tables. That is
860 -- because we were playing the big array trick.
862 -- We have to recreate a proper pointer to the actual array
863 -- from the zero origin pointer stored in the source table.
867 (S
.Source_Text
(S
.Source_First
)'Address);
870 if S
.Lines_Table
/= null then
871 Memory
.Free
(To_Address
(S
.Lines_Table
));
872 S
.Lines_Table
:= null;
875 if S
.Logical_Lines_Table
/= null then
876 Memory
.Free
(To_Address
(S
.Logical_Lines_Table
));
877 S
.Logical_Lines_Table
:= null;
884 -- Read in source file table and instance table
886 Source_File
.Tree_Read
;
889 -- The pointers we read in there for the source buffer and lines table
890 -- pointers are junk. We now read in the actual data that is referenced
891 -- by these two fields.
893 for J
in Source_File
.First
.. Source_File
.Last
loop
895 S
: Source_File_Record
renames Source_File
.Table
(J
);
898 -- For the instantiation case, we do not read in any data. Instead
899 -- we share the data for the generic template entry. Since the
900 -- template always occurs first, we can safely refer to its data.
902 if S
.Instance
/= No_Instance_Id
then
904 ST
: Source_File_Record
renames
905 Source_File
.Table
(S
.Template
);
908 -- The lines tables are copied from the template entry
911 Source_File
.Table
(S
.Template
).Lines_Table
;
912 S
.Logical_Lines_Table
:=
913 Source_File
.Table
(S
.Template
).Logical_Lines_Table
;
915 -- In the case of the source table pointer, we share the
916 -- same data as the generic template, but the virtual origin
917 -- is adjusted. For example, if the first subscript of the
918 -- template is 100, and that of the instantiation is 200,
919 -- then the instantiation pointer is obtained by subtracting
920 -- 100 from the template pointer.
923 pragma Suppress
(All_Checks
);
925 pragma Warnings
(Off
);
926 -- This unchecked conversion is aliasing safe since it
927 -- not used to create improperly aliased pointer values.
929 function To_Source_Buffer_Ptr
is new
930 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
932 pragma Warnings
(On
);
938 (ST
.Source_First
- S
.Source_First
)'Address);
942 -- Normal case (non-instantiation)
945 First_Time_Around
:= False;
946 S
.Lines_Table
:= null;
947 S
.Logical_Lines_Table
:= null;
948 Alloc_Line_Tables
(S
, Int
(S
.Last_Source_Line
));
950 for J
in 1 .. S
.Last_Source_Line
loop
951 Tree_Read_Int
(Int
(S
.Lines_Table
(J
)));
954 if S
.Num_SRef_Pragmas
/= 0 then
955 for J
in 1 .. S
.Last_Source_Line
loop
956 Tree_Read_Int
(Int
(S
.Logical_Lines_Table
(J
)));
960 -- Allocate source buffer and read in the data and then set the
961 -- virtual origin to point to the logical zero'th element. This
962 -- address must be computed with subscript checks turned off.
965 subtype B
is Text_Buffer
(S
.Source_First
.. S
.Source_Last
);
966 type Text_Buffer_Ptr
is access B
;
969 pragma Suppress
(All_Checks
);
971 pragma Warnings
(Off
);
972 -- This unchecked conversion is aliasing safe, since it is
973 -- never used to create improperly aliased pointer values.
975 function To_Source_Buffer_Ptr
is new
976 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
978 pragma Warnings
(On
);
983 Tree_Read_Data
(T
(S
.Source_First
)'Address,
984 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
986 S
.Source_Text
:= To_Source_Buffer_Ptr
(T
(0)'Address);
991 Set_Source_File_Index_Table
(J
);
999 procedure Tree_Write
is
1001 Source_File
.Tree_Write
;
1002 Instances
.Tree_Write
;
1004 -- The pointers we wrote out there for the source buffer and lines
1005 -- table pointers are junk, we now write out the actual data that
1006 -- is referenced by these two fields.
1008 for J
in Source_File
.First
.. Source_File
.Last
loop
1010 S
: Source_File_Record
renames Source_File
.Table
(J
);
1013 -- For instantiations, there is nothing to do, since the data is
1014 -- shared with the generic template. When the tree is read, the
1015 -- pointers must be set, but no extra data needs to be written.
1017 if S
.Instance
/= No_Instance_Id
then
1020 -- For the normal case, write out the data of the tables
1025 for J
in 1 .. S
.Last_Source_Line
loop
1026 Tree_Write_Int
(Int
(S
.Lines_Table
(J
)));
1029 -- Logical lines table if present
1031 if S
.Num_SRef_Pragmas
/= 0 then
1032 for J
in 1 .. S
.Last_Source_Line
loop
1033 Tree_Write_Int
(Int
(S
.Logical_Lines_Table
(J
)));
1040 (S
.Source_Text
(S
.Source_First
)'Address,
1041 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
1047 --------------------
1048 -- Write_Location --
1049 --------------------
1051 procedure Write_Location
(P
: Source_Ptr
) is
1053 if P
= No_Location
then
1054 Write_Str
("<no location>");
1056 elsif P
<= Standard_Location
then
1057 Write_Str
("<standard location>");
1061 SI
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
1064 Write_Name
(Debug_Source_Name
(SI
));
1066 Write_Int
(Int
(Get_Logical_Line_Number
(P
)));
1068 Write_Int
(Int
(Get_Column_Number
(P
)));
1070 if Instantiation
(SI
) /= No_Location
then
1072 Write_Location
(Instantiation
(SI
));
1079 ----------------------
1080 -- Write_Time_Stamp --
1081 ----------------------
1083 procedure Write_Time_Stamp
(S
: Source_File_Index
) is
1084 T
: constant Time_Stamp_Type
:= Time_Stamp
(S
);
1097 Write_Char
(T
(P
+ 1));
1098 Write_Char
(T
(P
+ 2));
1101 Write_Char
(T
(P
+ 3));
1102 Write_Char
(T
(P
+ 4));
1105 Write_Char
(T
(P
+ 5));
1106 Write_Char
(T
(P
+ 6));
1109 Write_Char
(T
(P
+ 7));
1110 Write_Char
(T
(P
+ 8));
1113 Write_Char
(T
(P
+ 9));
1114 Write_Char
(T
(P
+ 10));
1117 Write_Char
(T
(P
+ 11));
1118 Write_Char
(T
(P
+ 12));
1119 end Write_Time_Stamp
;
1121 ----------------------------------------------
1122 -- Access Subprograms for Source File Table --
1123 ----------------------------------------------
1125 function Debug_Source_Name
(S
: SFI
) return File_Name_Type
is
1127 return Source_File
.Table
(S
).Debug_Source_Name
;
1128 end Debug_Source_Name
;
1130 function Instance
(S
: SFI
) return Instance_Id
is
1132 return Source_File
.Table
(S
).Instance
;
1135 function File_Name
(S
: SFI
) return File_Name_Type
is
1137 return Source_File
.Table
(S
).File_Name
;
1140 function File_Type
(S
: SFI
) return Type_Of_File
is
1142 return Source_File
.Table
(S
).File_Type
;
1145 function First_Mapped_Line
(S
: SFI
) return Logical_Line_Number
is
1147 return Source_File
.Table
(S
).First_Mapped_Line
;
1148 end First_Mapped_Line
;
1150 function Full_Debug_Name
(S
: SFI
) return File_Name_Type
is
1152 return Source_File
.Table
(S
).Full_Debug_Name
;
1153 end Full_Debug_Name
;
1155 function Full_File_Name
(S
: SFI
) return File_Name_Type
is
1157 return Source_File
.Table
(S
).Full_File_Name
;
1160 function Full_Ref_Name
(S
: SFI
) return File_Name_Type
is
1162 return Source_File
.Table
(S
).Full_Ref_Name
;
1165 function Identifier_Casing
(S
: SFI
) return Casing_Type
is
1167 return Source_File
.Table
(S
).Identifier_Casing
;
1168 end Identifier_Casing
;
1170 function Inlined_Body
(S
: SFI
) return Boolean is
1172 return Source_File
.Table
(S
).Inlined_Body
;
1175 function Inlined_Call
(S
: SFI
) return Source_Ptr
is
1177 return Source_File
.Table
(S
).Inlined_Call
;
1180 function Keyword_Casing
(S
: SFI
) return Casing_Type
is
1182 return Source_File
.Table
(S
).Keyword_Casing
;
1185 function Last_Source_Line
(S
: SFI
) return Physical_Line_Number
is
1187 return Source_File
.Table
(S
).Last_Source_Line
;
1188 end Last_Source_Line
;
1190 function License
(S
: SFI
) return License_Type
is
1192 return Source_File
.Table
(S
).License
;
1195 function Num_SRef_Pragmas
(S
: SFI
) return Nat
is
1197 return Source_File
.Table
(S
).Num_SRef_Pragmas
;
1198 end Num_SRef_Pragmas
;
1200 function Reference_Name
(S
: SFI
) return File_Name_Type
is
1202 return Source_File
.Table
(S
).Reference_Name
;
1205 function Source_Checksum
(S
: SFI
) return Word
is
1207 return Source_File
.Table
(S
).Source_Checksum
;
1208 end Source_Checksum
;
1210 function Source_First
(S
: SFI
) return Source_Ptr
is
1212 if S
= Internal_Source_File
then
1213 return Internal_Source
'First;
1215 return Source_File
.Table
(S
).Source_First
;
1219 function Source_Last
(S
: SFI
) return Source_Ptr
is
1221 if S
= Internal_Source_File
then
1222 return Internal_Source
'Last;
1224 return Source_File
.Table
(S
).Source_Last
;
1228 function Source_Text
(S
: SFI
) return Source_Buffer_Ptr
is
1230 if S
= Internal_Source_File
then
1231 return Internal_Source_Ptr
;
1233 return Source_File
.Table
(S
).Source_Text
;
1237 function Template
(S
: SFI
) return SFI
is
1239 return Source_File
.Table
(S
).Template
;
1242 function Time_Stamp
(S
: SFI
) return Time_Stamp_Type
is
1244 return Source_File
.Table
(S
).Time_Stamp
;
1247 function Unit
(S
: SFI
) return Unit_Number_Type
is
1249 return Source_File
.Table
(S
).Unit
;
1252 ------------------------------------------
1253 -- Set Procedures for Source File Table --
1254 ------------------------------------------
1256 procedure Set_Identifier_Casing
(S
: SFI
; C
: Casing_Type
) is
1258 Source_File
.Table
(S
).Identifier_Casing
:= C
;
1259 end Set_Identifier_Casing
;
1261 procedure Set_Keyword_Casing
(S
: SFI
; C
: Casing_Type
) is
1263 Source_File
.Table
(S
).Keyword_Casing
:= C
;
1264 end Set_Keyword_Casing
;
1266 procedure Set_License
(S
: SFI
; L
: License_Type
) is
1268 Source_File
.Table
(S
).License
:= L
;
1271 procedure Set_Unit
(S
: SFI
; U
: Unit_Number_Type
) is
1273 Source_File
.Table
(S
).Unit
:= U
;
1276 ----------------------
1277 -- Trim_Lines_Table --
1278 ----------------------
1280 procedure Trim_Lines_Table
(S
: Source_File_Index
) is
1281 Max
: constant Nat
:= Nat
(Source_File
.Table
(S
).Last_Source_Line
);
1284 -- Release allocated storage that is no longer needed
1286 Source_File
.Table
(S
).Lines_Table
:= To_Pointer
1288 (To_Address
(Source_File
.Table
(S
).Lines_Table
),
1290 (Max
* (Lines_Table_Type
'Component_Size / System
.Storage_Unit
))));
1291 Source_File
.Table
(S
).Lines_Table_Max
:= Physical_Line_Number
(Max
);
1292 end Trim_Lines_Table
;
1300 Source_File
.Locked
:= False;
1301 Source_File
.Release
;
1308 procedure wl
(P
: Source_Ptr
) is