1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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
.Storage_Elements
;
47 with System
.WCh_Con
; use System
.WCh_Con
;
49 with Unchecked_Conversion
;
50 with Unchecked_Deallocation
;
52 package body Sinput
is
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 -- Source_File_Index_Table --
79 -----------------------------
81 -- The Get_Source_File_Index function is called very frequently. Earlier
82 -- versions cached a single entry, but then reverted to a serial search,
83 -- and this proved to be a significant source of inefficiency. We then
84 -- switched to using a table with a start point followed by a serial
85 -- search. Now we make sure source buffers are on a reasonable boundary
86 -- (see Types.Source_Align), and we can just use a direct look up in the
89 -- Note that this array is pretty large, but in most operating systems
90 -- it will not be allocated in physical memory unless it is actually used.
92 Source_File_Index_Table
:
93 array (Int
range 0 .. 1 + (Int
'Last / Source_Align
)) of Source_File_Index
;
95 ---------------------------
96 -- Add_Line_Tables_Entry --
97 ---------------------------
99 procedure Add_Line_Tables_Entry
100 (S
: in out Source_File_Record
;
103 LL
: Physical_Line_Number
;
106 -- Reallocate the lines tables if necessary
108 -- Note: the reason we do not use the normal Table package
109 -- mechanism is that we have several of these tables. We could
110 -- use the new GNAT.Dynamic_Tables package and that would probably
111 -- be a good idea ???
113 if S
.Last_Source_Line
= S
.Lines_Table_Max
then
116 Int
(S
.Last_Source_Line
) *
117 ((100 + Alloc
.Lines_Increment
) / 100));
120 Write_Str
("--> Reallocating lines table, size = ");
121 Write_Int
(Int
(S
.Lines_Table_Max
));
126 S
.Last_Source_Line
:= S
.Last_Source_Line
+ 1;
127 LL
:= S
.Last_Source_Line
;
129 S
.Lines_Table
(LL
) := P
;
131 -- Deal with setting new entry in logical lines table if one is
132 -- present. Note that there is always space (because the call to
133 -- Alloc_Line_Tables makes sure both tables are the same length),
135 if S
.Logical_Lines_Table
/= null then
137 -- We can always set the entry from the previous one, because
138 -- the processing for a Source_Reference pragma ensures that
139 -- at least one entry following the pragma is set up correctly.
141 S
.Logical_Lines_Table
(LL
) := S
.Logical_Lines_Table
(LL
- 1) + 1;
143 end Add_Line_Tables_Entry
;
145 -----------------------
146 -- Alloc_Line_Tables --
147 -----------------------
149 procedure Alloc_Line_Tables
150 (S
: in out Source_File_Record
;
153 subtype size_t
is Memory
.size_t
;
155 New_Table
: Lines_Table_Ptr
;
157 New_Logical_Table
: Logical_Lines_Table_Ptr
;
159 New_Size
: constant size_t
:=
160 size_t
(New_Max
* Lines_Table_Type
'Component_Size /
164 if S
.Lines_Table
= null then
165 New_Table
:= To_Pointer
(Memory
.Alloc
(New_Size
));
169 To_Pointer
(Memory
.Realloc
(To_Address
(S
.Lines_Table
), New_Size
));
172 if New_Table
= null then
175 S
.Lines_Table
:= New_Table
;
176 S
.Lines_Table_Max
:= Physical_Line_Number
(New_Max
);
179 if S
.Num_SRef_Pragmas
/= 0 then
180 if S
.Logical_Lines_Table
= null then
181 New_Logical_Table
:= To_Pointer
(Memory
.Alloc
(New_Size
));
183 New_Logical_Table
:= To_Pointer
184 (Memory
.Realloc
(To_Address
(S
.Logical_Lines_Table
), New_Size
));
187 if New_Logical_Table
= null then
190 S
.Logical_Lines_Table
:= New_Logical_Table
;
193 end Alloc_Line_Tables
;
199 procedure Backup_Line
(P
: in out Source_Ptr
) is
200 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
201 Src
: constant Source_Buffer_Ptr
:=
202 Source_File
.Table
(Sindex
).Source_Text
;
203 Sfirst
: constant Source_Ptr
:=
204 Source_File
.Table
(Sindex
).Source_First
;
214 if Src
(P
- 1) = LF
then
219 if Src
(P
- 1) = CR
then
224 -- Now find first character of the previous line
227 and then Src
(P
- 1) /= LF
228 and then Src
(P
- 1) /= CR
234 ---------------------------
235 -- Build_Location_String --
236 ---------------------------
238 procedure Build_Location_String
239 (Buf
: in out Bounded_String
;
242 Ptr
: Source_Ptr
:= Loc
;
245 -- Loop through instantiations
248 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Ptr
)));
250 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Ptr
)));
252 Ptr
:= Instantiation_Location
(Ptr
);
253 exit when Ptr
= No_Location
;
254 Append
(Buf
, " instantiated at ");
256 end Build_Location_String
;
258 function Build_Location_String
(Loc
: Source_Ptr
) return String is
259 Buf
: Bounded_String
;
261 Build_Location_String
(Buf
, Loc
);
263 end Build_Location_String
;
269 procedure Check_For_BOM
is
272 Tst
: String (1 .. 5);
277 C
:= Source
(Scan_Ptr
+ Source_Ptr
(J
) - 1);
279 -- Definitely no BOM if EOF character marks either end of file, or
280 -- an illegal non-BOM character if not at the end of file.
289 Read_BOM
(Tst
, Len
, BOM
, XML_Support
=> False);
293 Scan_Ptr
:= Scan_Ptr
+ Source_Ptr
(Len
);
294 First_Non_Blank_Location
:= Scan_Ptr
;
295 Current_Line_Start
:= Scan_Ptr
;
296 Wide_Character_Encoding_Method
:= WCEM_UTF8
;
297 Upper_Half_Encoding
:= True;
303 Write_Line
("UTF-16 encoding format not recognized");
305 raise Unrecoverable_Error
;
311 Write_Line
("UTF-32 encoding format not recognized");
313 raise Unrecoverable_Error
;
323 -----------------------------
324 -- Clear_Source_File_Table --
325 -----------------------------
327 procedure Free
is new Unchecked_Deallocation
328 (Lines_Table_Type
, Lines_Table_Ptr
);
330 procedure Free
is new Unchecked_Deallocation
331 (Logical_Lines_Table_Type
, Logical_Lines_Table_Ptr
);
333 procedure Clear_Source_File_Table
is
335 for X
in 1 .. Source_File
.Last
loop
337 S
: Source_File_Record
renames Source_File
.Table
(X
);
339 if S
.Instance
= No_Instance_Id
then
340 Free_Source_Buffer
(S
.Source_Text
);
342 Free_Dope
(S
.Source_Text
'Address);
343 S
.Source_Text
:= null;
346 Free
(S
.Lines_Table
);
347 Free
(S
.Logical_Lines_Table
);
353 end Clear_Source_File_Table
;
355 ---------------------------------
356 -- Comes_From_Inherited_Pragma --
357 ---------------------------------
359 function Comes_From_Inherited_Pragma
(S
: Source_Ptr
) return Boolean is
360 SIE
: Source_File_Record
renames
361 Source_File
.Table
(Get_Source_File_Index
(S
));
363 return SIE
.Inherited_Pragma
;
364 end Comes_From_Inherited_Pragma
;
366 -----------------------------
367 -- Comes_From_Inlined_Body --
368 -----------------------------
370 function Comes_From_Inlined_Body
(S
: Source_Ptr
) return Boolean is
371 SIE
: Source_File_Record
renames
372 Source_File
.Table
(Get_Source_File_Index
(S
));
374 return SIE
.Inlined_Body
;
375 end Comes_From_Inlined_Body
;
377 ------------------------
378 -- Free_Source_Buffer --
379 ------------------------
381 procedure Free_Source_Buffer
(Src
: in out Source_Buffer_Ptr
) is
382 -- Unchecked_Deallocation doesn't work for access-to-constant; we need
383 -- to first Unchecked_Convert to access-to-variable.
385 function To_Source_Buffer_Ptr_Var
is new
386 Unchecked_Conversion
(Source_Buffer_Ptr
, Source_Buffer_Ptr_Var
);
388 Temp
: Source_Buffer_Ptr_Var
:= To_Source_Buffer_Ptr_Var
(Src
);
390 procedure Free_Ptr
is new
391 Unchecked_Deallocation
(Source_Buffer
, Source_Buffer_Ptr_Var
);
395 end Free_Source_Buffer
;
397 -----------------------
398 -- Get_Column_Number --
399 -----------------------
401 function Get_Column_Number
(P
: Source_Ptr
) return Column_Number
is
404 Sindex
: Source_File_Index
;
405 Src
: Source_Buffer_Ptr
;
408 -- If the input source pointer is not a meaningful value then return
409 -- at once with column number 1. This can happen for a file not found
410 -- condition for a file loaded indirectly by RTE, and also perhaps on
411 -- some unknown internal error conditions. In either case we certainly
412 -- don't want to blow up.
418 Sindex
:= Get_Source_File_Index
(P
);
419 Src
:= Source_File
.Table
(Sindex
).Source_Text
;
425 C
:= (C
- 1) / 8 * 8 + (8 + 1);
428 -- Deal with wide character case, but don't include brackets
429 -- notation in this circuit, since we know that this will
430 -- display unencoded (no one encodes brackets notation).
432 elsif Src
(S
) /= '[' and then Is_Start_Of_Wide_Char
(Src
, S
) then
436 -- Normal (non-wide) character case or brackets sequence
446 end Get_Column_Number
;
448 -----------------------------
449 -- Get_Logical_Line_Number --
450 -----------------------------
452 function Get_Logical_Line_Number
453 (P
: Source_Ptr
) return Logical_Line_Number
455 SFR
: Source_File_Record
456 renames Source_File
.Table
(Get_Source_File_Index
(P
));
458 L
: constant Physical_Line_Number
:= Get_Physical_Line_Number
(P
);
461 if SFR
.Num_SRef_Pragmas
= 0 then
462 return Logical_Line_Number
(L
);
464 return SFR
.Logical_Lines_Table
(L
);
466 end Get_Logical_Line_Number
;
468 ---------------------------------
469 -- Get_Logical_Line_Number_Img --
470 ---------------------------------
472 function Get_Logical_Line_Number_Img
473 (P
: Source_Ptr
) return String
477 Add_Nat_To_Name_Buffer
(Nat
(Get_Logical_Line_Number
(P
)));
478 return Name_Buffer
(1 .. Name_Len
);
479 end Get_Logical_Line_Number_Img
;
481 ------------------------------
482 -- Get_Physical_Line_Number --
483 ------------------------------
485 function Get_Physical_Line_Number
486 (P
: Source_Ptr
) return Physical_Line_Number
488 Sfile
: Source_File_Index
;
489 Table
: Lines_Table_Ptr
;
490 Lo
: Physical_Line_Number
;
491 Hi
: Physical_Line_Number
;
492 Mid
: Physical_Line_Number
;
496 -- If the input source pointer is not a meaningful value then return
497 -- at once with line number 1. This can happen for a file not found
498 -- condition for a file loaded indirectly by RTE, and also perhaps on
499 -- some unknown internal error conditions. In either case we certainly
500 -- don't want to blow up.
505 -- Otherwise we can do the binary search
508 Sfile
:= Get_Source_File_Index
(P
);
509 Loc
:= P
+ Source_File
.Table
(Sfile
).Sloc_Adjust
;
510 Table
:= Source_File
.Table
(Sfile
).Lines_Table
;
512 Hi
:= Source_File
.Table
(Sfile
).Last_Source_Line
;
515 Mid
:= (Lo
+ Hi
) / 2;
517 if Loc
< Table
(Mid
) then
520 else -- Loc >= Table (Mid)
523 Loc
< Table
(Mid
+ 1)
534 end Get_Physical_Line_Number
;
536 ---------------------------
537 -- Get_Source_File_Index --
538 ---------------------------
540 function Get_Source_File_Index
(S
: Source_Ptr
) return Source_File_Index
is
541 Result
: Source_File_Index
;
543 procedure Assertions
;
544 -- Assert various properties of the result
546 procedure Assertions
is
548 -- ???The old version using zero-origin array indexing without array
549 -- bounds checks returned 1 (i.e. system.ads) for these special
550 -- locations, presumably by accident. We are mimicing that here.
552 Special
: constant Boolean :=
554 or else S
= Standard_Location
555 or else S
= Standard_ASCII_Location
556 or else S
= System_Location
;
558 pragma Assert
((S
> No_Location
) xor Special
);
559 pragma Assert
(Result
in Source_File
.First
.. Source_File
.Last
);
561 SFR
: Source_File_Record
renames Source_File
.Table
(Result
);
564 -- SFR.Source_Text = null if and only if this is the SFR for a debug
565 -- output file (*.dg), and that file is under construction. S can be
566 -- slightly past Source_Last in that case because we haven't updated
569 if Null_Source_Buffer_Ptr
(SFR
.Source_Text
) then
570 pragma Assert
(S
>= SFR
.Source_First
); null;
572 pragma Assert
(SFR
.Source_Text
'First = SFR
.Source_First
);
573 pragma Assert
(SFR
.Source_Text
'Last = SFR
.Source_Last
);
576 pragma Assert
(S
in SFR
.Source_First
.. SFR
.Source_Last
);
582 -- Start of processing for Get_Source_File_Index
585 if S
> No_Location
then
586 Result
:= Source_File_Index_Table
(Int
(S
) / Source_Align
);
591 pragma Debug
(Assertions
);
594 end Get_Source_File_Index
;
600 procedure Initialize
is
602 Source_gnat_adc
:= No_Source_File
;
605 Instances
.Append
(No_Location
);
606 pragma Assert
(Instances
.Last
= No_Instance_Id
);
613 function Instantiation
(S
: SFI
) return Source_Ptr
is
614 SIE
: Source_File_Record
renames Source_File
.Table
(S
);
616 if SIE
.Inlined_Body
or SIE
.Inherited_Pragma
then
617 return SIE
.Inlined_Call
;
619 return Instances
.Table
(SIE
.Instance
);
623 -------------------------
624 -- Instantiation_Depth --
625 -------------------------
627 function Instantiation_Depth
(S
: Source_Ptr
) return Nat
is
628 Sind
: Source_File_Index
;
637 Sind
:= Get_Source_File_Index
(Sval
);
638 Sval
:= Instantiation
(Sind
);
639 exit when Sval
= No_Location
;
644 end Instantiation_Depth
;
646 ----------------------------
647 -- Instantiation_Location --
648 ----------------------------
650 function Instantiation_Location
(S
: Source_Ptr
) return Source_Ptr
is
652 return Instantiation
(Get_Source_File_Index
(S
));
653 end Instantiation_Location
;
655 --------------------------
656 -- Iterate_On_Instances --
657 --------------------------
659 procedure Iterate_On_Instances
is
661 for J
in 1 .. Instances
.Last
loop
662 Process
(J
, Instances
.Table
(J
));
664 end Iterate_On_Instances
;
666 ----------------------
667 -- Last_Source_File --
668 ----------------------
670 function Last_Source_File
return Source_File_Index
is
672 return Source_File
.Last
;
673 end Last_Source_File
;
679 function Line_Start
(P
: Source_Ptr
) return Source_Ptr
is
680 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
681 Src
: constant Source_Buffer_Ptr
:=
682 Source_File
.Table
(Sindex
).Source_Text
;
683 Sfirst
: constant Source_Ptr
:=
684 Source_File
.Table
(Sindex
).Source_First
;
690 and then Src
(S
- 1) /= CR
691 and then Src
(S
- 1) /= LF
700 (L
: Physical_Line_Number
;
701 S
: Source_File_Index
) return Source_Ptr
704 return Source_File
.Table
(S
).Lines_Table
(L
);
714 Source_File
.Locked
:= True;
717 ----------------------
718 -- Num_Source_Files --
719 ----------------------
721 function Num_Source_Files
return Nat
is
723 return Int
(Source_File
.Last
) - Int
(Source_File
.First
) + 1;
724 end Num_Source_Files
;
726 ----------------------
727 -- Num_Source_Lines --
728 ----------------------
730 function Num_Source_Lines
(S
: Source_File_Index
) return Nat
is
732 return Nat
(Source_File
.Table
(S
).Last_Source_Line
);
733 end Num_Source_Lines
;
735 -----------------------
736 -- Original_Location --
737 -----------------------
739 function Original_Location
(S
: Source_Ptr
) return Source_Ptr
is
740 Sindex
: Source_File_Index
;
741 Tindex
: Source_File_Index
;
744 if S
<= No_Location
then
748 Sindex
:= Get_Source_File_Index
(S
);
750 if Instantiation
(Sindex
) = No_Location
then
754 Tindex
:= Template
(Sindex
);
755 while Instantiation
(Tindex
) /= No_Location
loop
756 Tindex
:= Template
(Tindex
);
759 return S
- Source_First
(Sindex
) + Source_First
(Tindex
);
762 end Original_Location
;
764 -------------------------
765 -- Physical_To_Logical --
766 -------------------------
768 function Physical_To_Logical
769 (Line
: Physical_Line_Number
;
770 S
: Source_File_Index
) return Logical_Line_Number
772 SFR
: Source_File_Record
renames Source_File
.Table
(S
);
775 if SFR
.Num_SRef_Pragmas
= 0 then
776 return Logical_Line_Number
(Line
);
778 return SFR
.Logical_Lines_Table
(Line
);
780 end Physical_To_Logical
;
782 --------------------------------
783 -- Register_Source_Ref_Pragma --
784 --------------------------------
786 procedure Register_Source_Ref_Pragma
787 (File_Name
: File_Name_Type
;
788 Stripped_File_Name
: File_Name_Type
;
790 Line_After_Pragma
: Physical_Line_Number
)
792 subtype size_t
is Memory
.size_t
;
794 SFR
: Source_File_Record
renames Source_File
.Table
(Current_Source_File
);
796 ML
: Logical_Line_Number
;
799 if File_Name
/= No_File
then
800 SFR
.Reference_Name
:= Stripped_File_Name
;
801 SFR
.Full_Ref_Name
:= File_Name
;
803 if not Debug_Generated_Code
then
804 SFR
.Debug_Source_Name
:= Stripped_File_Name
;
805 SFR
.Full_Debug_Name
:= File_Name
;
808 SFR
.Num_SRef_Pragmas
:= SFR
.Num_SRef_Pragmas
+ 1;
811 if SFR
.Num_SRef_Pragmas
= 1 then
812 SFR
.First_Mapped_Line
:= Logical_Line_Number
(Mapped_Line
);
815 if SFR
.Logical_Lines_Table
= null then
816 SFR
.Logical_Lines_Table
:= To_Pointer
818 (size_t
(SFR
.Lines_Table_Max
*
819 Logical_Lines_Table_Type
'Component_Size /
823 SFR
.Logical_Lines_Table
(Line_After_Pragma
- 1) := No_Line_Number
;
825 ML
:= Logical_Line_Number
(Mapped_Line
);
826 for J
in Line_After_Pragma
.. SFR
.Last_Source_Line
loop
827 SFR
.Logical_Lines_Table
(J
) := ML
;
830 end Register_Source_Ref_Pragma
;
832 ---------------------------------
833 -- Set_Source_File_Index_Table --
834 ---------------------------------
836 procedure Set_Source_File_Index_Table
(Xnew
: Source_File_Index
) is
839 SL
: constant Source_Ptr
:= Source_File
.Table
(Xnew
).Source_Last
;
841 SP
:= Source_File
.Table
(Xnew
).Source_First
;
842 pragma Assert
(SP
mod Source_Align
= 0);
843 Ind
:= Int
(SP
) / Source_Align
;
845 Source_File_Index_Table
(Ind
) := Xnew
;
846 SP
:= SP
+ Source_Align
;
849 end Set_Source_File_Index_Table
;
851 ---------------------------
852 -- Skip_Line_Terminators --
853 ---------------------------
855 procedure Skip_Line_Terminators
856 (P
: in out Source_Ptr
;
857 Physical
: out Boolean)
859 Chr
: constant Character := Source
(P
);
863 if Source
(P
+ 1) = LF
then
872 elsif Chr
= FF
or else Chr
= VT
then
877 -- Otherwise we have a wide character
880 Skip_Wide
(Source
, P
);
883 -- Fall through in the physical line terminator case. First deal with
884 -- making a possible entry into the lines table if one is needed.
886 -- Note: we are dealing with a real source file here, this cannot be
887 -- the instantiation case, so we need not worry about Sloc adjustment.
890 S
: Source_File_Record
891 renames Source_File
.Table
(Current_Source_File
);
896 -- Make entry in lines table if not already made (in some scan backup
897 -- cases, we will be rescanning previously scanned source, so the
898 -- entry may have already been made on the previous forward scan).
901 and then P
> S
.Lines_Table
(S
.Last_Source_Line
)
903 Add_Line_Tables_Entry
(S
, P
);
906 end Skip_Line_Terminators
;
913 (Src
: System
.Address
; New_Dope
: Dope_Ptr
)
915 -- A fat pointer is a pair consisting of data pointer and dope pointer,
916 -- in that order. So we want to overwrite the second word.
917 Dope
: System
.Address
;
918 pragma Import
(Ada
, Dope
);
919 use System
.Storage_Elements
;
920 for Dope
'Address use Src
+ System
.Address
'Size / 8;
922 Dope
:= New_Dope
.all'Address;
925 procedure Free_Dope
(Src
: System
.Address
) is
927 pragma Import
(Ada
, Dope
);
928 use System
.Storage_Elements
;
929 for Dope
'Address use Src
+ System
.Address
'Size / 8;
930 procedure Free
is new Unchecked_Deallocation
(Dope_Rec
, Dope_Ptr
);
939 procedure Sloc_Range
(N
: Node_Id
; Min
, Max
: out Source_Ptr
) is
941 function Process
(N
: Node_Id
) return Traverse_Result
;
942 -- Process function for traversing the node tree
944 procedure Traverse
is new Traverse_Proc
(Process
);
950 function Process
(N
: Node_Id
) return Traverse_Result
is
951 Orig
: constant Node_Id
:= Original_Node
(N
);
954 if Sloc
(Orig
) < Min
then
955 if Sloc
(Orig
) > No_Location
then
959 elsif Sloc
(Orig
) > Max
then
960 if Sloc
(Orig
) > No_Location
then
968 -- Start of processing for Sloc_Range
980 function Source_Offset
(S
: Source_Ptr
) return Nat
is
981 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(S
);
982 Sfirst
: constant Source_Ptr
:=
983 Source_File
.Table
(Sindex
).Source_First
;
985 return Nat
(S
- Sfirst
);
988 ------------------------
989 -- Top_Level_Location --
990 ------------------------
992 function Top_Level_Location
(S
: Source_Ptr
) return Source_Ptr
is
1000 Newloc
:= Instantiation_Location
(Oldloc
);
1001 exit when Newloc
= No_Location
;
1005 end Top_Level_Location
;
1011 procedure Tree_Read
is
1013 -- First we must free any old source buffer pointers
1015 for J
in Source_File
.First
.. Source_File
.Last
loop
1017 S
: Source_File_Record
renames Source_File
.Table
(J
);
1019 if S
.Instance
= No_Instance_Id
then
1020 Free_Source_Buffer
(S
.Source_Text
);
1022 if S
.Lines_Table
/= null then
1023 Memory
.Free
(To_Address
(S
.Lines_Table
));
1024 S
.Lines_Table
:= null;
1027 if S
.Logical_Lines_Table
/= null then
1028 Memory
.Free
(To_Address
(S
.Logical_Lines_Table
));
1029 S
.Logical_Lines_Table
:= null;
1033 Free_Dope
(S
.Source_Text
'Address);
1034 S
.Source_Text
:= null;
1039 -- Read in source file table and instance table
1041 Source_File
.Tree_Read
;
1042 Instances
.Tree_Read
;
1044 -- The pointers we read in there for the source buffer and lines table
1045 -- pointers are junk. We now read in the actual data that is referenced
1046 -- by these two fields.
1048 for J
in Source_File
.First
.. Source_File
.Last
loop
1050 S
: Source_File_Record
renames Source_File
.Table
(J
);
1052 -- Normal case (non-instantiation)
1054 if S
.Instance
= No_Instance_Id
then
1055 S
.Lines_Table
:= null;
1056 S
.Logical_Lines_Table
:= null;
1057 Alloc_Line_Tables
(S
, Int
(S
.Last_Source_Line
));
1059 for J
in 1 .. S
.Last_Source_Line
loop
1060 Tree_Read_Int
(Int
(S
.Lines_Table
(J
)));
1063 if S
.Num_SRef_Pragmas
/= 0 then
1064 for J
in 1 .. S
.Last_Source_Line
loop
1065 Tree_Read_Int
(Int
(S
.Logical_Lines_Table
(J
)));
1069 -- Allocate source buffer and read in the data
1072 T
: constant Source_Buffer_Ptr_Var
:=
1073 new Source_Buffer
(S
.Source_First
.. S
.Source_Last
);
1075 Tree_Read_Data
(T
(S
.Source_First
)'Address,
1076 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
1077 S
.Source_Text
:= T
.all'Access;
1080 -- For the instantiation case, we do not read in any data. Instead
1081 -- we share the data for the generic template entry. Since the
1082 -- template always occurs first, we can safely refer to its data.
1086 ST
: Source_File_Record
renames
1087 Source_File
.Table
(S
.Template
);
1090 -- The lines tables are copied from the template entry
1092 S
.Lines_Table
:= ST
.Lines_Table
;
1093 S
.Logical_Lines_Table
:= ST
.Logical_Lines_Table
;
1095 -- The Source_Text of the instance is the same data as that
1096 -- of the template, but with different bounds.
1099 Dope
: constant Dope_Ptr
:=
1100 new Dope_Rec
'(S.Source_First, S.Source_Last);
1102 S.Source_Text := ST.Source_Text;
1103 Set_Dope (S.Source_Text'Address, Dope);
1109 Set_Source_File_Index_Table (J);
1117 procedure Tree_Write is
1119 Source_File.Tree_Write;
1120 Instances.Tree_Write;
1122 -- The pointers we wrote out there for the source buffer and lines
1123 -- table pointers are junk, we now write out the actual data that
1124 -- is referenced by these two fields.
1126 for J in Source_File.First .. Source_File.Last loop
1128 S : Source_File_Record renames Source_File.Table (J);
1131 -- For instantiations, there is nothing to do, since the data is
1132 -- shared with the generic template. When the tree is read, the
1133 -- pointers must be set, but no extra data needs to be written.
1134 -- For the normal case, write out the data of the tables.
1136 if S.Instance = No_Instance_Id then
1139 for J in 1 .. S.Last_Source_Line loop
1140 Tree_Write_Int (Int (S.Lines_Table (J)));
1143 -- Logical lines table if present
1145 if S.Num_SRef_Pragmas /= 0 then
1146 for J in 1 .. S.Last_Source_Line loop
1147 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
1154 (S.Source_Text (S.Source_First)'Address,
1155 Int (S.Source_Last) - Int (S.Source_First) + 1);
1161 --------------------
1162 -- Write_Location --
1163 --------------------
1165 procedure Write_Location (P : Source_Ptr) is
1167 if P = No_Location then
1168 Write_Str ("<no location>");
1170 elsif P <= Standard_Location then
1171 Write_Str ("<standard location>");
1175 SI : constant Source_File_Index := Get_Source_File_Index (P);
1178 Write_Name (Debug_Source_Name (SI));
1180 Write_Int (Int (Get_Logical_Line_Number (P)));
1182 Write_Int (Int (Get_Column_Number (P)));
1184 if Instantiation (SI) /= No_Location then
1186 Write_Location (Instantiation (SI));
1193 ----------------------
1194 -- Write_Time_Stamp --
1195 ----------------------
1197 procedure Write_Time_Stamp (S : Source_File_Index) is
1198 T : constant Time_Stamp_Type := Time_Stamp (S);
1211 Write_Char (T (P + 1));
1212 Write_Char (T (P + 2));
1215 Write_Char (T (P + 3));
1216 Write_Char (T (P + 4));
1219 Write_Char (T (P + 5));
1220 Write_Char (T (P + 6));
1223 Write_Char (T (P + 7));
1224 Write_Char (T (P + 8));
1227 Write_Char (T (P + 9));
1228 Write_Char (T (P + 10));
1231 Write_Char (T (P + 11));
1232 Write_Char (T (P + 12));
1233 end Write_Time_Stamp;
1235 ----------------------------------------------
1236 -- Access Subprograms for Source File Table --
1237 ----------------------------------------------
1239 function Debug_Source_Name (S : SFI) return File_Name_Type is
1241 return Source_File.Table (S).Debug_Source_Name;
1242 end Debug_Source_Name;
1244 function Instance (S : SFI) return Instance_Id is
1246 return Source_File.Table (S).Instance;
1249 function File_Name (S : SFI) return File_Name_Type is
1251 return Source_File.Table (S).File_Name;
1254 function File_Type (S : SFI) return Type_Of_File is
1256 return Source_File.Table (S).File_Type;
1259 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1261 return Source_File.Table (S).First_Mapped_Line;
1262 end First_Mapped_Line;
1264 function Full_Debug_Name (S : SFI) return File_Name_Type is
1266 return Source_File.Table (S).Full_Debug_Name;
1267 end Full_Debug_Name;
1269 function Full_File_Name (S : SFI) return File_Name_Type is
1271 return Source_File.Table (S).Full_File_Name;
1274 function Full_Ref_Name (S : SFI) return File_Name_Type is
1276 return Source_File.Table (S).Full_Ref_Name;
1279 function Identifier_Casing (S : SFI) return Casing_Type is
1281 return Source_File.Table (S).Identifier_Casing;
1282 end Identifier_Casing;
1284 function Inherited_Pragma (S : SFI) return Boolean is
1286 return Source_File.Table (S).Inherited_Pragma;
1287 end Inherited_Pragma;
1289 function Inlined_Body (S : SFI) return Boolean is
1291 return Source_File.Table (S).Inlined_Body;
1294 function Inlined_Call (S : SFI) return Source_Ptr is
1296 return Source_File.Table (S).Inlined_Call;
1299 function Keyword_Casing (S : SFI) return Casing_Type is
1301 return Source_File.Table (S).Keyword_Casing;
1304 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1306 return Source_File.Table (S).Last_Source_Line;
1307 end Last_Source_Line;
1309 function License (S : SFI) return License_Type is
1311 return Source_File.Table (S).License;
1314 function Num_SRef_Pragmas (S : SFI) return Nat is
1316 return Source_File.Table (S).Num_SRef_Pragmas;
1317 end Num_SRef_Pragmas;
1319 function Reference_Name (S : SFI) return File_Name_Type is
1321 return Source_File.Table (S).Reference_Name;
1324 function Source_Checksum (S : SFI) return Word is
1326 return Source_File.Table (S).Source_Checksum;
1327 end Source_Checksum;
1329 function Source_First (S : SFI) return Source_Ptr is
1331 return Source_File.Table (S).Source_First;
1334 function Source_Last (S : SFI) return Source_Ptr is
1336 return Source_File.Table (S).Source_Last;
1339 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1341 return Source_File.Table (S).Source_Text;
1344 function Template (S : SFI) return SFI is
1346 return Source_File.Table (S).Template;
1349 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1351 return Source_File.Table (S).Time_Stamp;
1354 function Unit (S : SFI) return Unit_Number_Type is
1356 return Source_File.Table (S).Unit;
1359 ------------------------------------------
1360 -- Set Procedures for Source File Table --
1361 ------------------------------------------
1363 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1365 Source_File.Table (S).Identifier_Casing := C;
1366 end Set_Identifier_Casing;
1368 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1370 Source_File.Table (S).Keyword_Casing := C;
1371 end Set_Keyword_Casing;
1373 procedure Set_License (S : SFI; L : License_Type) is
1375 Source_File.Table (S).License := L;
1378 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1380 Source_File.Table (S).Unit := U;
1383 ----------------------
1384 -- Trim_Lines_Table --
1385 ----------------------
1387 procedure Trim_Lines_Table (S : Source_File_Index) is
1388 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1391 -- Release allocated storage that is no longer needed
1393 Source_File.Table (S).Lines_Table := To_Pointer
1395 (To_Address (Source_File.Table (S).Lines_Table),
1397 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1398 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1399 end Trim_Lines_Table;
1407 Source_File.Locked := False;
1408 Source_File.Release;
1415 procedure wl (P : Source_Ptr) is