1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
225 (Buf
: in out Bounded_String
;
228 Ptr
: Source_Ptr
:= Loc
;
231 -- Loop through instantiations
234 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Ptr
)));
236 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Ptr
)));
238 Ptr
:= Instantiation_Location
(Ptr
);
239 exit when Ptr
= No_Location
;
240 Append
(Buf
, " instantiated at ");
242 end Build_Location_String
;
244 function Build_Location_String
(Loc
: Source_Ptr
) return String is
245 Buf
: Bounded_String
;
247 Build_Location_String
(Buf
, Loc
);
249 end Build_Location_String
;
255 procedure Check_For_BOM
is
258 Tst
: String (1 .. 5);
263 C
:= Source
(Scan_Ptr
+ Source_Ptr
(J
) - 1);
265 -- Definitely no BOM if EOF character marks either end of file, or
266 -- an illegal non-BOM character if not at the end of file.
275 Read_BOM
(Tst
, Len
, BOM
, False);
279 Scan_Ptr
:= Scan_Ptr
+ Source_Ptr
(Len
);
280 Wide_Character_Encoding_Method
:= WCEM_UTF8
;
281 Upper_Half_Encoding
:= True;
283 when UTF16_LE | UTF16_BE
=>
285 Write_Line
("UTF-16 encoding format not recognized");
287 raise Unrecoverable_Error
;
289 when UTF32_LE | UTF32_BE
=>
291 Write_Line
("UTF-32 encoding format not recognized");
293 raise Unrecoverable_Error
;
303 -----------------------------
304 -- Comes_From_Inlined_Body --
305 -----------------------------
307 function Comes_From_Inlined_Body
(S
: Source_Ptr
) return Boolean is
308 SIE
: Source_File_Record
renames
309 Source_File
.Table
(Get_Source_File_Index
(S
));
311 return SIE
.Inlined_Body
;
312 end Comes_From_Inlined_Body
;
314 -----------------------
315 -- Get_Column_Number --
316 -----------------------
318 function Get_Column_Number
(P
: Source_Ptr
) return Column_Number
is
321 Sindex
: Source_File_Index
;
322 Src
: Source_Buffer_Ptr
;
325 -- If the input source pointer is not a meaningful value then return
326 -- at once with column number 1. This can happen for a file not found
327 -- condition for a file loaded indirectly by RTE, and also perhaps on
328 -- some unknown internal error conditions. In either case we certainly
329 -- don't want to blow up.
335 Sindex
:= Get_Source_File_Index
(P
);
336 Src
:= Source_File
.Table
(Sindex
).Source_Text
;
342 C
:= (C
- 1) / 8 * 8 + (8 + 1);
345 -- Deal with wide character case, but don't include brackets
346 -- notation in this circuit, since we know that this will
347 -- display unencoded (no one encodes brackets notation).
349 elsif Src
(S
) /= '[' and then Is_Start_Of_Wide_Char
(Src
, S
) then
353 -- Normal (non-wide) character case or brackets sequence
363 end Get_Column_Number
;
365 -----------------------------
366 -- Get_Logical_Line_Number --
367 -----------------------------
369 function Get_Logical_Line_Number
370 (P
: Source_Ptr
) return Logical_Line_Number
372 SFR
: Source_File_Record
373 renames Source_File
.Table
(Get_Source_File_Index
(P
));
375 L
: constant Physical_Line_Number
:= Get_Physical_Line_Number
(P
);
378 if SFR
.Num_SRef_Pragmas
= 0 then
379 return Logical_Line_Number
(L
);
381 return SFR
.Logical_Lines_Table
(L
);
383 end Get_Logical_Line_Number
;
385 ---------------------------------
386 -- Get_Logical_Line_Number_Img --
387 ---------------------------------
389 function Get_Logical_Line_Number_Img
390 (P
: Source_Ptr
) return String
394 Add_Nat_To_Name_Buffer
(Nat
(Get_Logical_Line_Number
(P
)));
395 return Name_Buffer
(1 .. Name_Len
);
396 end Get_Logical_Line_Number_Img
;
398 ------------------------------
399 -- Get_Physical_Line_Number --
400 ------------------------------
402 function Get_Physical_Line_Number
403 (P
: Source_Ptr
) return Physical_Line_Number
405 Sfile
: Source_File_Index
;
406 Table
: Lines_Table_Ptr
;
407 Lo
: Physical_Line_Number
;
408 Hi
: Physical_Line_Number
;
409 Mid
: Physical_Line_Number
;
413 -- If the input source pointer is not a meaningful value then return
414 -- at once with line number 1. This can happen for a file not found
415 -- condition for a file loaded indirectly by RTE, and also perhaps on
416 -- some unknown internal error conditions. In either case we certainly
417 -- don't want to blow up.
422 -- Otherwise we can do the binary search
425 Sfile
:= Get_Source_File_Index
(P
);
426 Loc
:= P
+ Source_File
.Table
(Sfile
).Sloc_Adjust
;
427 Table
:= Source_File
.Table
(Sfile
).Lines_Table
;
429 Hi
:= Source_File
.Table
(Sfile
).Last_Source_Line
;
432 Mid
:= (Lo
+ Hi
) / 2;
434 if Loc
< Table
(Mid
) then
437 else -- Loc >= Table (Mid)
440 Loc
< Table
(Mid
+ 1)
451 end Get_Physical_Line_Number
;
453 ---------------------------
454 -- Get_Source_File_Index --
455 ---------------------------
457 function Get_Source_File_Index
(S
: Source_Ptr
) return Source_File_Index
is
459 return Source_File_Index_Table
(Int
(S
) / Source_Align
);
460 end Get_Source_File_Index
;
466 procedure Initialize
is
468 Source_gnat_adc
:= No_Source_File
;
469 First_Time_Around
:= True;
474 Instances
.Append
(No_Location
);
475 pragma Assert
(Instances
.Last
= No_Instance_Id
);
482 function Instantiation
(S
: SFI
) return Source_Ptr
is
483 SIE
: Source_File_Record
renames Source_File
.Table
(S
);
485 if SIE
.Inlined_Body
then
486 return SIE
.Inlined_Call
;
488 return Instances
.Table
(SIE
.Instance
);
492 -------------------------
493 -- Instantiation_Depth --
494 -------------------------
496 function Instantiation_Depth
(S
: Source_Ptr
) return Nat
is
497 Sind
: Source_File_Index
;
506 Sind
:= Get_Source_File_Index
(Sval
);
507 Sval
:= Instantiation
(Sind
);
508 exit when Sval
= No_Location
;
513 end Instantiation_Depth
;
515 ----------------------------
516 -- Instantiation_Location --
517 ----------------------------
519 function Instantiation_Location
(S
: Source_Ptr
) return Source_Ptr
is
521 return Instantiation
(Get_Source_File_Index
(S
));
522 end Instantiation_Location
;
524 --------------------------
525 -- Iterate_On_Instances --
526 --------------------------
528 procedure Iterate_On_Instances
is
530 for J
in 1 .. Instances
.Last
loop
531 Process
(J
, Instances
.Table
(J
));
533 end Iterate_On_Instances
;
535 ----------------------
536 -- Last_Source_File --
537 ----------------------
539 function Last_Source_File
return Source_File_Index
is
541 return Source_File
.Last
;
542 end Last_Source_File
;
548 function Line_Start
(P
: Source_Ptr
) return Source_Ptr
is
549 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
550 Src
: constant Source_Buffer_Ptr
:=
551 Source_File
.Table
(Sindex
).Source_Text
;
552 Sfirst
: constant Source_Ptr
:=
553 Source_File
.Table
(Sindex
).Source_First
;
559 and then Src
(S
- 1) /= CR
560 and then Src
(S
- 1) /= LF
569 (L
: Physical_Line_Number
;
570 S
: Source_File_Index
) return Source_Ptr
573 return Source_File
.Table
(S
).Lines_Table
(L
);
582 Source_File
.Locked
:= True;
586 ----------------------
587 -- Num_Source_Files --
588 ----------------------
590 function Num_Source_Files
return Nat
is
592 return Int
(Source_File
.Last
) - Int
(Source_File
.First
) + 1;
593 end Num_Source_Files
;
595 ----------------------
596 -- Num_Source_Lines --
597 ----------------------
599 function Num_Source_Lines
(S
: Source_File_Index
) return Nat
is
601 return Nat
(Source_File
.Table
(S
).Last_Source_Line
);
602 end Num_Source_Lines
;
604 -----------------------
605 -- Original_Location --
606 -----------------------
608 function Original_Location
(S
: Source_Ptr
) return Source_Ptr
is
609 Sindex
: Source_File_Index
;
610 Tindex
: Source_File_Index
;
613 if S
<= No_Location
then
617 Sindex
:= Get_Source_File_Index
(S
);
619 if Instantiation
(Sindex
) = No_Location
then
623 Tindex
:= Template
(Sindex
);
624 while Instantiation
(Tindex
) /= No_Location
loop
625 Tindex
:= Template
(Tindex
);
628 return S
- Source_First
(Sindex
) + Source_First
(Tindex
);
631 end Original_Location
;
633 -------------------------
634 -- Physical_To_Logical --
635 -------------------------
637 function Physical_To_Logical
638 (Line
: Physical_Line_Number
;
639 S
: Source_File_Index
) return Logical_Line_Number
641 SFR
: Source_File_Record
renames Source_File
.Table
(S
);
644 if SFR
.Num_SRef_Pragmas
= 0 then
645 return Logical_Line_Number
(Line
);
647 return SFR
.Logical_Lines_Table
(Line
);
649 end Physical_To_Logical
;
651 --------------------------------
652 -- Register_Source_Ref_Pragma --
653 --------------------------------
655 procedure Register_Source_Ref_Pragma
656 (File_Name
: File_Name_Type
;
657 Stripped_File_Name
: File_Name_Type
;
659 Line_After_Pragma
: Physical_Line_Number
)
661 subtype size_t
is Memory
.size_t
;
663 SFR
: Source_File_Record
renames Source_File
.Table
(Current_Source_File
);
665 ML
: Logical_Line_Number
;
668 if File_Name
/= No_File
then
669 SFR
.Reference_Name
:= Stripped_File_Name
;
670 SFR
.Full_Ref_Name
:= File_Name
;
672 if not Debug_Generated_Code
then
673 SFR
.Debug_Source_Name
:= Stripped_File_Name
;
674 SFR
.Full_Debug_Name
:= File_Name
;
677 SFR
.Num_SRef_Pragmas
:= SFR
.Num_SRef_Pragmas
+ 1;
680 if SFR
.Num_SRef_Pragmas
= 1 then
681 SFR
.First_Mapped_Line
:= Logical_Line_Number
(Mapped_Line
);
684 if SFR
.Logical_Lines_Table
= null then
685 SFR
.Logical_Lines_Table
:= To_Pointer
687 (size_t
(SFR
.Lines_Table_Max
*
688 Logical_Lines_Table_Type
'Component_Size /
692 SFR
.Logical_Lines_Table
(Line_After_Pragma
- 1) := No_Line_Number
;
694 ML
:= Logical_Line_Number
(Mapped_Line
);
695 for J
in Line_After_Pragma
.. SFR
.Last_Source_Line
loop
696 SFR
.Logical_Lines_Table
(J
) := ML
;
699 end Register_Source_Ref_Pragma
;
701 ---------------------------------
702 -- Set_Source_File_Index_Table --
703 ---------------------------------
705 procedure Set_Source_File_Index_Table
(Xnew
: Source_File_Index
) is
708 SL
: constant Source_Ptr
:= Source_File
.Table
(Xnew
).Source_Last
;
710 SP
:= Source_File
.Table
(Xnew
).Source_First
;
711 pragma Assert
(SP
mod Source_Align
= 0);
712 Ind
:= Int
(SP
) / Source_Align
;
714 Source_File_Index_Table
(Ind
) := Xnew
;
715 SP
:= SP
+ Source_Align
;
718 end Set_Source_File_Index_Table
;
720 ---------------------------
721 -- Skip_Line_Terminators --
722 ---------------------------
724 procedure Skip_Line_Terminators
725 (P
: in out Source_Ptr
;
726 Physical
: out Boolean)
728 Chr
: constant Character := Source
(P
);
732 if Source
(P
+ 1) = LF
then
741 elsif Chr
= FF
or else Chr
= VT
then
746 -- Otherwise we have a wide character
749 Skip_Wide
(Source
, P
);
752 -- Fall through in the physical line terminator case. First deal with
753 -- making a possible entry into the lines table if one is needed.
755 -- Note: we are dealing with a real source file here, this cannot be
756 -- the instantiation case, so we need not worry about Sloc adjustment.
759 S
: Source_File_Record
760 renames Source_File
.Table
(Current_Source_File
);
765 -- Make entry in lines table if not already made (in some scan backup
766 -- cases, we will be rescanning previously scanned source, so the
767 -- entry may have already been made on the previous forward scan).
770 and then P
> S
.Lines_Table
(S
.Last_Source_Line
)
772 Add_Line_Tables_Entry
(S
, P
);
775 end Skip_Line_Terminators
;
781 procedure Sloc_Range
(N
: Node_Id
; Min
, Max
: out Source_Ptr
) is
783 function Process
(N
: Node_Id
) return Traverse_Result
;
784 -- Process function for traversing the node tree
786 procedure Traverse
is new Traverse_Proc
(Process
);
792 function Process
(N
: Node_Id
) return Traverse_Result
is
793 Orig
: constant Node_Id
:= Original_Node
(N
);
796 if Sloc
(Orig
) < Min
then
797 if Sloc
(Orig
) > No_Location
then
801 elsif Sloc
(Orig
) > Max
then
802 if Sloc
(Orig
) > No_Location
then
810 -- Start of processing for Sloc_Range
822 function Source_Offset
(S
: Source_Ptr
) return Nat
is
823 Sindex
: constant Source_File_Index
:= Get_Source_File_Index
(S
);
824 Sfirst
: constant Source_Ptr
:=
825 Source_File
.Table
(Sindex
).Source_First
;
827 return Nat
(S
- Sfirst
);
830 ------------------------
831 -- Top_Level_Location --
832 ------------------------
834 function Top_Level_Location
(S
: Source_Ptr
) return Source_Ptr
is
842 Newloc
:= Instantiation_Location
(Oldloc
);
843 exit when Newloc
= No_Location
;
847 end Top_Level_Location
;
853 procedure Tree_Read
is
855 -- First we must free any old source buffer pointers
857 if not First_Time_Around
then
858 for J
in Source_File
.First
.. Source_File
.Last
loop
860 S
: Source_File_Record
renames Source_File
.Table
(J
);
862 procedure Free_Ptr
is new Unchecked_Deallocation
863 (Big_Source_Buffer
, Source_Buffer_Ptr
);
865 pragma Warnings
(Off
);
866 -- This unchecked conversion is aliasing safe, since it is not
867 -- used to create improperly aliased pointer values.
869 function To_Source_Buffer_Ptr
is new
870 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
872 pragma Warnings
(On
);
874 Tmp1
: Source_Buffer_Ptr
;
877 if S
.Instance
/= No_Instance_Id
then
881 -- Free the buffer, we use Free here, because we used malloc
882 -- or realloc directly to allocate the tables. That is
883 -- because we were playing the big array trick.
885 -- We have to recreate a proper pointer to the actual array
886 -- from the zero origin pointer stored in the source table.
890 (S
.Source_Text
(S
.Source_First
)'Address);
893 if S
.Lines_Table
/= null then
894 Memory
.Free
(To_Address
(S
.Lines_Table
));
895 S
.Lines_Table
:= null;
898 if S
.Logical_Lines_Table
/= null then
899 Memory
.Free
(To_Address
(S
.Logical_Lines_Table
));
900 S
.Logical_Lines_Table
:= null;
907 -- Read in source file table and instance table
909 Source_File
.Tree_Read
;
912 -- The pointers we read in there for the source buffer and lines table
913 -- pointers are junk. We now read in the actual data that is referenced
914 -- by these two fields.
916 for J
in Source_File
.First
.. Source_File
.Last
loop
918 S
: Source_File_Record
renames Source_File
.Table
(J
);
921 -- For the instantiation case, we do not read in any data. Instead
922 -- we share the data for the generic template entry. Since the
923 -- template always occurs first, we can safely refer to its data.
925 if S
.Instance
/= No_Instance_Id
then
927 ST
: Source_File_Record
renames
928 Source_File
.Table
(S
.Template
);
931 -- The lines tables are copied from the template entry
934 Source_File
.Table
(S
.Template
).Lines_Table
;
935 S
.Logical_Lines_Table
:=
936 Source_File
.Table
(S
.Template
).Logical_Lines_Table
;
938 -- In the case of the source table pointer, we share the
939 -- same data as the generic template, but the virtual origin
940 -- is adjusted. For example, if the first subscript of the
941 -- template is 100, and that of the instantiation is 200,
942 -- then the instantiation pointer is obtained by subtracting
943 -- 100 from the template pointer.
946 pragma Suppress
(All_Checks
);
948 pragma Warnings
(Off
);
949 -- This unchecked conversion is aliasing safe since it
950 -- not used to create improperly aliased pointer values.
952 function To_Source_Buffer_Ptr
is new
953 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
955 pragma Warnings
(On
);
961 (ST
.Source_First
- S
.Source_First
)'Address);
965 -- Normal case (non-instantiation)
968 First_Time_Around
:= False;
969 S
.Lines_Table
:= null;
970 S
.Logical_Lines_Table
:= null;
971 Alloc_Line_Tables
(S
, Int
(S
.Last_Source_Line
));
973 for J
in 1 .. S
.Last_Source_Line
loop
974 Tree_Read_Int
(Int
(S
.Lines_Table
(J
)));
977 if S
.Num_SRef_Pragmas
/= 0 then
978 for J
in 1 .. S
.Last_Source_Line
loop
979 Tree_Read_Int
(Int
(S
.Logical_Lines_Table
(J
)));
983 -- Allocate source buffer and read in the data and then set the
984 -- virtual origin to point to the logical zero'th element. This
985 -- address must be computed with subscript checks turned off.
988 subtype B
is Text_Buffer
(S
.Source_First
.. S
.Source_Last
);
989 type Text_Buffer_Ptr
is access B
;
992 pragma Suppress
(All_Checks
);
994 pragma Warnings
(Off
);
995 -- This unchecked conversion is aliasing safe, since it is
996 -- never used to create improperly aliased pointer values.
998 function To_Source_Buffer_Ptr
is new
999 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
1001 pragma Warnings
(On
);
1006 Tree_Read_Data
(T
(S
.Source_First
)'Address,
1007 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
1009 S
.Source_Text
:= To_Source_Buffer_Ptr
(T
(0)'Address);
1014 Set_Source_File_Index_Table
(J
);
1022 procedure Tree_Write
is
1024 Source_File
.Tree_Write
;
1025 Instances
.Tree_Write
;
1027 -- The pointers we wrote out there for the source buffer and lines
1028 -- table pointers are junk, we now write out the actual data that
1029 -- is referenced by these two fields.
1031 for J
in Source_File
.First
.. Source_File
.Last
loop
1033 S
: Source_File_Record
renames Source_File
.Table
(J
);
1036 -- For instantiations, there is nothing to do, since the data is
1037 -- shared with the generic template. When the tree is read, the
1038 -- pointers must be set, but no extra data needs to be written.
1040 if S
.Instance
/= No_Instance_Id
then
1043 -- For the normal case, write out the data of the tables
1048 for J
in 1 .. S
.Last_Source_Line
loop
1049 Tree_Write_Int
(Int
(S
.Lines_Table
(J
)));
1052 -- Logical lines table if present
1054 if S
.Num_SRef_Pragmas
/= 0 then
1055 for J
in 1 .. S
.Last_Source_Line
loop
1056 Tree_Write_Int
(Int
(S
.Logical_Lines_Table
(J
)));
1063 (S
.Source_Text
(S
.Source_First
)'Address,
1064 Int
(S
.Source_Last
) - Int
(S
.Source_First
) + 1);
1070 --------------------
1071 -- Write_Location --
1072 --------------------
1074 procedure Write_Location
(P
: Source_Ptr
) is
1076 if P
= No_Location
then
1077 Write_Str
("<no location>");
1079 elsif P
<= Standard_Location
then
1080 Write_Str
("<standard location>");
1084 SI
: constant Source_File_Index
:= Get_Source_File_Index
(P
);
1087 Write_Name
(Debug_Source_Name
(SI
));
1089 Write_Int
(Int
(Get_Logical_Line_Number
(P
)));
1091 Write_Int
(Int
(Get_Column_Number
(P
)));
1093 if Instantiation
(SI
) /= No_Location
then
1095 Write_Location
(Instantiation
(SI
));
1102 ----------------------
1103 -- Write_Time_Stamp --
1104 ----------------------
1106 procedure Write_Time_Stamp
(S
: Source_File_Index
) is
1107 T
: constant Time_Stamp_Type
:= Time_Stamp
(S
);
1120 Write_Char
(T
(P
+ 1));
1121 Write_Char
(T
(P
+ 2));
1124 Write_Char
(T
(P
+ 3));
1125 Write_Char
(T
(P
+ 4));
1128 Write_Char
(T
(P
+ 5));
1129 Write_Char
(T
(P
+ 6));
1132 Write_Char
(T
(P
+ 7));
1133 Write_Char
(T
(P
+ 8));
1136 Write_Char
(T
(P
+ 9));
1137 Write_Char
(T
(P
+ 10));
1140 Write_Char
(T
(P
+ 11));
1141 Write_Char
(T
(P
+ 12));
1142 end Write_Time_Stamp
;
1144 ----------------------------------------------
1145 -- Access Subprograms for Source File Table --
1146 ----------------------------------------------
1148 function Debug_Source_Name
(S
: SFI
) return File_Name_Type
is
1150 return Source_File
.Table
(S
).Debug_Source_Name
;
1151 end Debug_Source_Name
;
1153 function Instance
(S
: SFI
) return Instance_Id
is
1155 return Source_File
.Table
(S
).Instance
;
1158 function File_Name
(S
: SFI
) return File_Name_Type
is
1160 return Source_File
.Table
(S
).File_Name
;
1163 function File_Type
(S
: SFI
) return Type_Of_File
is
1165 return Source_File
.Table
(S
).File_Type
;
1168 function First_Mapped_Line
(S
: SFI
) return Logical_Line_Number
is
1170 return Source_File
.Table
(S
).First_Mapped_Line
;
1171 end First_Mapped_Line
;
1173 function Full_Debug_Name
(S
: SFI
) return File_Name_Type
is
1175 return Source_File
.Table
(S
).Full_Debug_Name
;
1176 end Full_Debug_Name
;
1178 function Full_File_Name
(S
: SFI
) return File_Name_Type
is
1180 return Source_File
.Table
(S
).Full_File_Name
;
1183 function Full_Ref_Name
(S
: SFI
) return File_Name_Type
is
1185 return Source_File
.Table
(S
).Full_Ref_Name
;
1188 function Identifier_Casing
(S
: SFI
) return Casing_Type
is
1190 return Source_File
.Table
(S
).Identifier_Casing
;
1191 end Identifier_Casing
;
1193 function Inlined_Body
(S
: SFI
) return Boolean is
1195 return Source_File
.Table
(S
).Inlined_Body
;
1198 function Inlined_Call
(S
: SFI
) return Source_Ptr
is
1200 return Source_File
.Table
(S
).Inlined_Call
;
1203 function Keyword_Casing
(S
: SFI
) return Casing_Type
is
1205 return Source_File
.Table
(S
).Keyword_Casing
;
1208 function Last_Source_Line
(S
: SFI
) return Physical_Line_Number
is
1210 return Source_File
.Table
(S
).Last_Source_Line
;
1211 end Last_Source_Line
;
1213 function License
(S
: SFI
) return License_Type
is
1215 return Source_File
.Table
(S
).License
;
1218 function Num_SRef_Pragmas
(S
: SFI
) return Nat
is
1220 return Source_File
.Table
(S
).Num_SRef_Pragmas
;
1221 end Num_SRef_Pragmas
;
1223 function Reference_Name
(S
: SFI
) return File_Name_Type
is
1225 return Source_File
.Table
(S
).Reference_Name
;
1228 function Source_Checksum
(S
: SFI
) return Word
is
1230 return Source_File
.Table
(S
).Source_Checksum
;
1231 end Source_Checksum
;
1233 function Source_First
(S
: SFI
) return Source_Ptr
is
1235 if S
= Internal_Source_File
then
1236 return Internal_Source
'First;
1238 return Source_File
.Table
(S
).Source_First
;
1242 function Source_Last
(S
: SFI
) return Source_Ptr
is
1244 if S
= Internal_Source_File
then
1245 return Internal_Source
'Last;
1247 return Source_File
.Table
(S
).Source_Last
;
1251 function Source_Text
(S
: SFI
) return Source_Buffer_Ptr
is
1253 if S
= Internal_Source_File
then
1254 return Internal_Source_Ptr
;
1256 return Source_File
.Table
(S
).Source_Text
;
1260 function Template
(S
: SFI
) return SFI
is
1262 return Source_File
.Table
(S
).Template
;
1265 function Time_Stamp
(S
: SFI
) return Time_Stamp_Type
is
1267 return Source_File
.Table
(S
).Time_Stamp
;
1270 function Unit
(S
: SFI
) return Unit_Number_Type
is
1272 return Source_File
.Table
(S
).Unit
;
1275 ------------------------------------------
1276 -- Set Procedures for Source File Table --
1277 ------------------------------------------
1279 procedure Set_Identifier_Casing
(S
: SFI
; C
: Casing_Type
) is
1281 Source_File
.Table
(S
).Identifier_Casing
:= C
;
1282 end Set_Identifier_Casing
;
1284 procedure Set_Keyword_Casing
(S
: SFI
; C
: Casing_Type
) is
1286 Source_File
.Table
(S
).Keyword_Casing
:= C
;
1287 end Set_Keyword_Casing
;
1289 procedure Set_License
(S
: SFI
; L
: License_Type
) is
1291 Source_File
.Table
(S
).License
:= L
;
1294 procedure Set_Unit
(S
: SFI
; U
: Unit_Number_Type
) is
1296 Source_File
.Table
(S
).Unit
:= U
;
1299 ----------------------
1300 -- Trim_Lines_Table --
1301 ----------------------
1303 procedure Trim_Lines_Table
(S
: Source_File_Index
) is
1304 Max
: constant Nat
:= Nat
(Source_File
.Table
(S
).Last_Source_Line
);
1307 -- Release allocated storage that is no longer needed
1309 Source_File
.Table
(S
).Lines_Table
:= To_Pointer
1311 (To_Address
(Source_File
.Table
(S
).Lines_Table
),
1313 (Max
* (Lines_Table_Type
'Component_Size / System
.Storage_Unit
))));
1314 Source_File
.Table
(S
).Lines_Table_Max
:= Physical_Line_Number
(Max
);
1315 end Trim_Lines_Table
;
1323 Source_File
.Locked
:= False;
1324 Source_File
.Release
;
1331 procedure wl
(P
: Source_Ptr
) is