File : sinput.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S I N P U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 pragma Style_Checks (All_Checks);
33 -- Subprograms not all in alpha order
34
35 with Atree; use Atree;
36 with Debug; use Debug;
37 with Opt; use Opt;
38 with Output; use Output;
39 with Scans; use Scans;
40 with Tree_IO; use Tree_IO;
41 with Widechar; use Widechar;
42
43 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
44
45 with System; use System;
46 with System.Memory;
47 with System.WCh_Con; use System.WCh_Con;
48
49 with Unchecked_Conversion;
50 with Unchecked_Deallocation;
51
52 package body Sinput is
53
54 use ASCII;
55 -- Make control characters visible
56
57 First_Time_Around : Boolean := True;
58 -- This needs a comment ???
59
60 -- Routines to support conversion between types Lines_Table_Ptr,
61 -- Logical_Lines_Table_Ptr and System.Address.
62
63 pragma Warnings (Off);
64 -- These unchecked conversions are aliasing safe, since they are never
65 -- used to construct improperly aliased pointer values.
66
67 function To_Address is
68 new Unchecked_Conversion (Lines_Table_Ptr, Address);
69
70 function To_Address is
71 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
72
73 function To_Pointer is
74 new Unchecked_Conversion (Address, Lines_Table_Ptr);
75
76 function To_Pointer is
77 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
78
79 pragma Warnings (On);
80
81 ---------------------------
82 -- Add_Line_Tables_Entry --
83 ---------------------------
84
85 procedure Add_Line_Tables_Entry
86 (S : in out Source_File_Record;
87 P : Source_Ptr)
88 is
89 LL : Physical_Line_Number;
90
91 begin
92 -- Reallocate the lines tables if necessary
93
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
97 -- be a good idea ???
98
99 if S.Last_Source_Line = S.Lines_Table_Max then
100 Alloc_Line_Tables
101 (S,
102 Int (S.Last_Source_Line) *
103 ((100 + Alloc.Lines_Increment) / 100));
104
105 if Debug_Flag_D then
106 Write_Str ("--> Reallocating lines table, size = ");
107 Write_Int (Int (S.Lines_Table_Max));
108 Write_Eol;
109 end if;
110 end if;
111
112 S.Last_Source_Line := S.Last_Source_Line + 1;
113 LL := S.Last_Source_Line;
114
115 S.Lines_Table (LL) := P;
116
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),
120
121 if S.Logical_Lines_Table /= null then
122
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.
126
127 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
128 end if;
129 end Add_Line_Tables_Entry;
130
131 -----------------------
132 -- Alloc_Line_Tables --
133 -----------------------
134
135 procedure Alloc_Line_Tables
136 (S : in out Source_File_Record;
137 New_Max : Nat)
138 is
139 subtype size_t is Memory.size_t;
140
141 New_Table : Lines_Table_Ptr;
142
143 New_Logical_Table : Logical_Lines_Table_Ptr;
144
145 New_Size : constant size_t :=
146 size_t (New_Max * Lines_Table_Type'Component_Size /
147 Storage_Unit);
148
149 begin
150 if S.Lines_Table = null then
151 New_Table := To_Pointer (Memory.Alloc (New_Size));
152
153 else
154 New_Table :=
155 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
156 end if;
157
158 if New_Table = null then
159 raise Storage_Error;
160 else
161 S.Lines_Table := New_Table;
162 S.Lines_Table_Max := Physical_Line_Number (New_Max);
163 end if;
164
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));
168 else
169 New_Logical_Table := To_Pointer
170 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
171 end if;
172
173 if New_Logical_Table = null then
174 raise Storage_Error;
175 else
176 S.Logical_Lines_Table := New_Logical_Table;
177 end if;
178 end if;
179 end Alloc_Line_Tables;
180
181 -----------------
182 -- Backup_Line --
183 -----------------
184
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;
191
192 begin
193 P := P - 1;
194
195 if P = Sfirst then
196 return;
197 end if;
198
199 if Src (P) = CR then
200 if Src (P - 1) = LF then
201 P := P - 1;
202 end if;
203
204 else -- Src (P) = LF
205 if Src (P - 1) = CR then
206 P := P - 1;
207 end if;
208 end if;
209
210 -- Now find first character of the previous line
211
212 while P > Sfirst
213 and then Src (P - 1) /= LF
214 and then Src (P - 1) /= CR
215 loop
216 P := P - 1;
217 end loop;
218 end Backup_Line;
219
220 ---------------------------
221 -- Build_Location_String --
222 ---------------------------
223
224 procedure Build_Location_String
225 (Buf : in out Bounded_String;
226 Loc : Source_Ptr)
227 is
228 Ptr : Source_Ptr := Loc;
229
230 begin
231 -- Loop through instantiations
232
233 loop
234 Append (Buf, Reference_Name (Get_Source_File_Index (Ptr)));
235 Append (Buf, ':');
236 Append (Buf, Nat (Get_Logical_Line_Number (Ptr)));
237
238 Ptr := Instantiation_Location (Ptr);
239 exit when Ptr = No_Location;
240 Append (Buf, " instantiated at ");
241 end loop;
242 end Build_Location_String;
243
244 function Build_Location_String (Loc : Source_Ptr) return String is
245 Buf : Bounded_String;
246 begin
247 Build_Location_String (Buf, Loc);
248 return +Buf;
249 end Build_Location_String;
250
251 -------------------
252 -- Check_For_BOM --
253 -------------------
254
255 procedure Check_For_BOM is
256 BOM : BOM_Kind;
257 Len : Natural;
258 Tst : String (1 .. 5);
259 C : Character;
260
261 begin
262 for J in 1 .. 5 loop
263 C := Source (Scan_Ptr + Source_Ptr (J) - 1);
264
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.
267
268 if C = EOF then
269 return;
270 end if;
271
272 Tst (J) := C;
273 end loop;
274
275 Read_BOM (Tst, Len, BOM, False);
276
277 case BOM is
278 when UTF8_All =>
279 Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
280 Wide_Character_Encoding_Method := WCEM_UTF8;
281 Upper_Half_Encoding := True;
282
283 when UTF16_LE | UTF16_BE =>
284 Set_Standard_Error;
285 Write_Line ("UTF-16 encoding format not recognized");
286 Set_Standard_Output;
287 raise Unrecoverable_Error;
288
289 when UTF32_LE | UTF32_BE =>
290 Set_Standard_Error;
291 Write_Line ("UTF-32 encoding format not recognized");
292 Set_Standard_Output;
293 raise Unrecoverable_Error;
294
295 when Unknown =>
296 null;
297
298 when others =>
299 raise Program_Error;
300 end case;
301 end Check_For_BOM;
302
303 ---------------------------------
304 -- Comes_From_Inherited_Pragma --
305 ---------------------------------
306
307 function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is
308 SIE : Source_File_Record renames
309 Source_File.Table (Get_Source_File_Index (S));
310 begin
311 return SIE.Inherited_Pragma;
312 end Comes_From_Inherited_Pragma;
313
314 -----------------------------
315 -- Comes_From_Inlined_Body --
316 -----------------------------
317
318 function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
319 SIE : Source_File_Record renames
320 Source_File.Table (Get_Source_File_Index (S));
321 begin
322 return SIE.Inlined_Body;
323 end Comes_From_Inlined_Body;
324
325 -----------------------
326 -- Get_Column_Number --
327 -----------------------
328
329 function Get_Column_Number (P : Source_Ptr) return Column_Number is
330 S : Source_Ptr;
331 C : Column_Number;
332 Sindex : Source_File_Index;
333 Src : Source_Buffer_Ptr;
334
335 begin
336 -- If the input source pointer is not a meaningful value then return
337 -- at once with column number 1. This can happen for a file not found
338 -- condition for a file loaded indirectly by RTE, and also perhaps on
339 -- some unknown internal error conditions. In either case we certainly
340 -- don't want to blow up.
341
342 if P < 1 then
343 return 1;
344
345 else
346 Sindex := Get_Source_File_Index (P);
347 Src := Source_File.Table (Sindex).Source_Text;
348 S := Line_Start (P);
349 C := 1;
350
351 while S < P loop
352 if Src (S) = HT then
353 C := (C - 1) / 8 * 8 + (8 + 1);
354 S := S + 1;
355
356 -- Deal with wide character case, but don't include brackets
357 -- notation in this circuit, since we know that this will
358 -- display unencoded (no one encodes brackets notation).
359
360 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
361 C := C + 1;
362 Skip_Wide (Src, S);
363
364 -- Normal (non-wide) character case or brackets sequence
365
366 else
367 C := C + 1;
368 S := S + 1;
369 end if;
370 end loop;
371
372 return C;
373 end if;
374 end Get_Column_Number;
375
376 -----------------------------
377 -- Get_Logical_Line_Number --
378 -----------------------------
379
380 function Get_Logical_Line_Number
381 (P : Source_Ptr) return Logical_Line_Number
382 is
383 SFR : Source_File_Record
384 renames Source_File.Table (Get_Source_File_Index (P));
385
386 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
387
388 begin
389 if SFR.Num_SRef_Pragmas = 0 then
390 return Logical_Line_Number (L);
391 else
392 return SFR.Logical_Lines_Table (L);
393 end if;
394 end Get_Logical_Line_Number;
395
396 ---------------------------------
397 -- Get_Logical_Line_Number_Img --
398 ---------------------------------
399
400 function Get_Logical_Line_Number_Img
401 (P : Source_Ptr) return String
402 is
403 begin
404 Name_Len := 0;
405 Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
406 return Name_Buffer (1 .. Name_Len);
407 end Get_Logical_Line_Number_Img;
408
409 ------------------------------
410 -- Get_Physical_Line_Number --
411 ------------------------------
412
413 function Get_Physical_Line_Number
414 (P : Source_Ptr) return Physical_Line_Number
415 is
416 Sfile : Source_File_Index;
417 Table : Lines_Table_Ptr;
418 Lo : Physical_Line_Number;
419 Hi : Physical_Line_Number;
420 Mid : Physical_Line_Number;
421 Loc : Source_Ptr;
422
423 begin
424 -- If the input source pointer is not a meaningful value then return
425 -- at once with line number 1. This can happen for a file not found
426 -- condition for a file loaded indirectly by RTE, and also perhaps on
427 -- some unknown internal error conditions. In either case we certainly
428 -- don't want to blow up.
429
430 if P < 1 then
431 return 1;
432
433 -- Otherwise we can do the binary search
434
435 else
436 Sfile := Get_Source_File_Index (P);
437 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
438 Table := Source_File.Table (Sfile).Lines_Table;
439 Lo := 1;
440 Hi := Source_File.Table (Sfile).Last_Source_Line;
441
442 loop
443 Mid := (Lo + Hi) / 2;
444
445 if Loc < Table (Mid) then
446 Hi := Mid - 1;
447
448 else -- Loc >= Table (Mid)
449
450 if Mid = Hi or else
451 Loc < Table (Mid + 1)
452 then
453 return Mid;
454 else
455 Lo := Mid + 1;
456 end if;
457
458 end if;
459
460 end loop;
461 end if;
462 end Get_Physical_Line_Number;
463
464 ---------------------------
465 -- Get_Source_File_Index --
466 ---------------------------
467
468 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
469 begin
470 return Source_File_Index_Table (Int (S) / Source_Align);
471 end Get_Source_File_Index;
472
473 ----------------
474 -- Initialize --
475 ----------------
476
477 procedure Initialize is
478 begin
479 Source_gnat_adc := No_Source_File;
480 First_Time_Around := True;
481
482 Source_File.Init;
483
484 Instances.Init;
485 Instances.Append (No_Location);
486 pragma Assert (Instances.Last = No_Instance_Id);
487 end Initialize;
488
489 -------------------
490 -- Instantiation --
491 -------------------
492
493 function Instantiation (S : SFI) return Source_Ptr is
494 SIE : Source_File_Record renames Source_File.Table (S);
495 begin
496 if SIE.Inlined_Body or SIE.Inherited_Pragma then
497 return SIE.Inlined_Call;
498 else
499 return Instances.Table (SIE.Instance);
500 end if;
501 end Instantiation;
502
503 -------------------------
504 -- Instantiation_Depth --
505 -------------------------
506
507 function Instantiation_Depth (S : Source_Ptr) return Nat is
508 Sind : Source_File_Index;
509 Sval : Source_Ptr;
510 Depth : Nat;
511
512 begin
513 Sval := S;
514 Depth := 0;
515
516 loop
517 Sind := Get_Source_File_Index (Sval);
518 Sval := Instantiation (Sind);
519 exit when Sval = No_Location;
520 Depth := Depth + 1;
521 end loop;
522
523 return Depth;
524 end Instantiation_Depth;
525
526 ----------------------------
527 -- Instantiation_Location --
528 ----------------------------
529
530 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
531 begin
532 return Instantiation (Get_Source_File_Index (S));
533 end Instantiation_Location;
534
535 --------------------------
536 -- Iterate_On_Instances --
537 --------------------------
538
539 procedure Iterate_On_Instances is
540 begin
541 for J in 1 .. Instances.Last loop
542 Process (J, Instances.Table (J));
543 end loop;
544 end Iterate_On_Instances;
545
546 ----------------------
547 -- Last_Source_File --
548 ----------------------
549
550 function Last_Source_File return Source_File_Index is
551 begin
552 return Source_File.Last;
553 end Last_Source_File;
554
555 ----------------
556 -- Line_Start --
557 ----------------
558
559 function Line_Start (P : Source_Ptr) return Source_Ptr is
560 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
561 Src : constant Source_Buffer_Ptr :=
562 Source_File.Table (Sindex).Source_Text;
563 Sfirst : constant Source_Ptr :=
564 Source_File.Table (Sindex).Source_First;
565 S : Source_Ptr;
566
567 begin
568 S := P;
569 while S > Sfirst
570 and then Src (S - 1) /= CR
571 and then Src (S - 1) /= LF
572 loop
573 S := S - 1;
574 end loop;
575
576 return S;
577 end Line_Start;
578
579 function Line_Start
580 (L : Physical_Line_Number;
581 S : Source_File_Index) return Source_Ptr
582 is
583 begin
584 return Source_File.Table (S).Lines_Table (L);
585 end Line_Start;
586
587 ----------
588 -- Lock --
589 ----------
590
591 procedure Lock is
592 begin
593 Source_File.Locked := True;
594 Source_File.Release;
595 end Lock;
596
597 ----------------------
598 -- Num_Source_Files --
599 ----------------------
600
601 function Num_Source_Files return Nat is
602 begin
603 return Int (Source_File.Last) - Int (Source_File.First) + 1;
604 end Num_Source_Files;
605
606 ----------------------
607 -- Num_Source_Lines --
608 ----------------------
609
610 function Num_Source_Lines (S : Source_File_Index) return Nat is
611 begin
612 return Nat (Source_File.Table (S).Last_Source_Line);
613 end Num_Source_Lines;
614
615 -----------------------
616 -- Original_Location --
617 -----------------------
618
619 function Original_Location (S : Source_Ptr) return Source_Ptr is
620 Sindex : Source_File_Index;
621 Tindex : Source_File_Index;
622
623 begin
624 if S <= No_Location then
625 return S;
626
627 else
628 Sindex := Get_Source_File_Index (S);
629
630 if Instantiation (Sindex) = No_Location then
631 return S;
632
633 else
634 Tindex := Template (Sindex);
635 while Instantiation (Tindex) /= No_Location loop
636 Tindex := Template (Tindex);
637 end loop;
638
639 return S - Source_First (Sindex) + Source_First (Tindex);
640 end if;
641 end if;
642 end Original_Location;
643
644 -------------------------
645 -- Physical_To_Logical --
646 -------------------------
647
648 function Physical_To_Logical
649 (Line : Physical_Line_Number;
650 S : Source_File_Index) return Logical_Line_Number
651 is
652 SFR : Source_File_Record renames Source_File.Table (S);
653
654 begin
655 if SFR.Num_SRef_Pragmas = 0 then
656 return Logical_Line_Number (Line);
657 else
658 return SFR.Logical_Lines_Table (Line);
659 end if;
660 end Physical_To_Logical;
661
662 --------------------------------
663 -- Register_Source_Ref_Pragma --
664 --------------------------------
665
666 procedure Register_Source_Ref_Pragma
667 (File_Name : File_Name_Type;
668 Stripped_File_Name : File_Name_Type;
669 Mapped_Line : Nat;
670 Line_After_Pragma : Physical_Line_Number)
671 is
672 subtype size_t is Memory.size_t;
673
674 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
675
676 ML : Logical_Line_Number;
677
678 begin
679 if File_Name /= No_File then
680 SFR.Reference_Name := Stripped_File_Name;
681 SFR.Full_Ref_Name := File_Name;
682
683 if not Debug_Generated_Code then
684 SFR.Debug_Source_Name := Stripped_File_Name;
685 SFR.Full_Debug_Name := File_Name;
686 end if;
687
688 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
689 end if;
690
691 if SFR.Num_SRef_Pragmas = 1 then
692 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
693 end if;
694
695 if SFR.Logical_Lines_Table = null then
696 SFR.Logical_Lines_Table := To_Pointer
697 (Memory.Alloc
698 (size_t (SFR.Lines_Table_Max *
699 Logical_Lines_Table_Type'Component_Size /
700 Storage_Unit)));
701 end if;
702
703 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
704
705 ML := Logical_Line_Number (Mapped_Line);
706 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
707 SFR.Logical_Lines_Table (J) := ML;
708 ML := ML + 1;
709 end loop;
710 end Register_Source_Ref_Pragma;
711
712 ---------------------------------
713 -- Set_Source_File_Index_Table --
714 ---------------------------------
715
716 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
717 Ind : Int;
718 SP : Source_Ptr;
719 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
720 begin
721 SP := Source_File.Table (Xnew).Source_First;
722 pragma Assert (SP mod Source_Align = 0);
723 Ind := Int (SP) / Source_Align;
724 while SP <= SL loop
725 Source_File_Index_Table (Ind) := Xnew;
726 SP := SP + Source_Align;
727 Ind := Ind + 1;
728 end loop;
729 end Set_Source_File_Index_Table;
730
731 ---------------------------
732 -- Skip_Line_Terminators --
733 ---------------------------
734
735 procedure Skip_Line_Terminators
736 (P : in out Source_Ptr;
737 Physical : out Boolean)
738 is
739 Chr : constant Character := Source (P);
740
741 begin
742 if Chr = CR then
743 if Source (P + 1) = LF then
744 P := P + 2;
745 else
746 P := P + 1;
747 end if;
748
749 elsif Chr = LF then
750 P := P + 1;
751
752 elsif Chr = FF or else Chr = VT then
753 P := P + 1;
754 Physical := False;
755 return;
756
757 -- Otherwise we have a wide character
758
759 else
760 Skip_Wide (Source, P);
761 end if;
762
763 -- Fall through in the physical line terminator case. First deal with
764 -- making a possible entry into the lines table if one is needed.
765
766 -- Note: we are dealing with a real source file here, this cannot be
767 -- the instantiation case, so we need not worry about Sloc adjustment.
768
769 declare
770 S : Source_File_Record
771 renames Source_File.Table (Current_Source_File);
772
773 begin
774 Physical := True;
775
776 -- Make entry in lines table if not already made (in some scan backup
777 -- cases, we will be rescanning previously scanned source, so the
778 -- entry may have already been made on the previous forward scan).
779
780 if Source (P) /= EOF
781 and then P > S.Lines_Table (S.Last_Source_Line)
782 then
783 Add_Line_Tables_Entry (S, P);
784 end if;
785 end;
786 end Skip_Line_Terminators;
787
788 ----------------
789 -- Sloc_Range --
790 ----------------
791
792 procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
793
794 function Process (N : Node_Id) return Traverse_Result;
795 -- Process function for traversing the node tree
796
797 procedure Traverse is new Traverse_Proc (Process);
798
799 -------------
800 -- Process --
801 -------------
802
803 function Process (N : Node_Id) return Traverse_Result is
804 Orig : constant Node_Id := Original_Node (N);
805
806 begin
807 if Sloc (Orig) < Min then
808 if Sloc (Orig) > No_Location then
809 Min := Sloc (Orig);
810 end if;
811
812 elsif Sloc (Orig) > Max then
813 if Sloc (Orig) > No_Location then
814 Max := Sloc (Orig);
815 end if;
816 end if;
817
818 return OK_Orig;
819 end Process;
820
821 -- Start of processing for Sloc_Range
822
823 begin
824 Min := Sloc (N);
825 Max := Sloc (N);
826 Traverse (N);
827 end Sloc_Range;
828
829 -------------------
830 -- Source_Offset --
831 -------------------
832
833 function Source_Offset (S : Source_Ptr) return Nat is
834 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
835 Sfirst : constant Source_Ptr :=
836 Source_File.Table (Sindex).Source_First;
837 begin
838 return Nat (S - Sfirst);
839 end Source_Offset;
840
841 ------------------------
842 -- Top_Level_Location --
843 ------------------------
844
845 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
846 Oldloc : Source_Ptr;
847 Newloc : Source_Ptr;
848
849 begin
850 Newloc := S;
851 loop
852 Oldloc := Newloc;
853 Newloc := Instantiation_Location (Oldloc);
854 exit when Newloc = No_Location;
855 end loop;
856
857 return Oldloc;
858 end Top_Level_Location;
859
860 ---------------
861 -- Tree_Read --
862 ---------------
863
864 procedure Tree_Read is
865 begin
866 -- First we must free any old source buffer pointers
867
868 if not First_Time_Around then
869 for J in Source_File.First .. Source_File.Last loop
870 declare
871 S : Source_File_Record renames Source_File.Table (J);
872
873 procedure Free_Ptr is new Unchecked_Deallocation
874 (Big_Source_Buffer, Source_Buffer_Ptr);
875
876 pragma Warnings (Off);
877 -- This unchecked conversion is aliasing safe, since it is not
878 -- used to create improperly aliased pointer values.
879
880 function To_Source_Buffer_Ptr is new
881 Unchecked_Conversion (Address, Source_Buffer_Ptr);
882
883 pragma Warnings (On);
884
885 Tmp1 : Source_Buffer_Ptr;
886
887 begin
888 if S.Instance /= No_Instance_Id then
889 null;
890
891 else
892 -- Free the buffer, we use Free here, because we used malloc
893 -- or realloc directly to allocate the tables. That is
894 -- because we were playing the big array trick.
895
896 -- We have to recreate a proper pointer to the actual array
897 -- from the zero origin pointer stored in the source table.
898
899 Tmp1 :=
900 To_Source_Buffer_Ptr
901 (S.Source_Text (S.Source_First)'Address);
902 Free_Ptr (Tmp1);
903
904 if S.Lines_Table /= null then
905 Memory.Free (To_Address (S.Lines_Table));
906 S.Lines_Table := null;
907 end if;
908
909 if S.Logical_Lines_Table /= null then
910 Memory.Free (To_Address (S.Logical_Lines_Table));
911 S.Logical_Lines_Table := null;
912 end if;
913 end if;
914 end;
915 end loop;
916 end if;
917
918 -- Read in source file table and instance table
919
920 Source_File.Tree_Read;
921 Instances.Tree_Read;
922
923 -- The pointers we read in there for the source buffer and lines table
924 -- pointers are junk. We now read in the actual data that is referenced
925 -- by these two fields.
926
927 for J in Source_File.First .. Source_File.Last loop
928 declare
929 S : Source_File_Record renames Source_File.Table (J);
930
931 begin
932 -- For the instantiation case, we do not read in any data. Instead
933 -- we share the data for the generic template entry. Since the
934 -- template always occurs first, we can safely refer to its data.
935
936 if S.Instance /= No_Instance_Id then
937 declare
938 ST : Source_File_Record renames
939 Source_File.Table (S.Template);
940
941 begin
942 -- The lines tables are copied from the template entry
943
944 S.Lines_Table :=
945 Source_File.Table (S.Template).Lines_Table;
946 S.Logical_Lines_Table :=
947 Source_File.Table (S.Template).Logical_Lines_Table;
948
949 -- In the case of the source table pointer, we share the
950 -- same data as the generic template, but the virtual origin
951 -- is adjusted. For example, if the first subscript of the
952 -- template is 100, and that of the instantiation is 200,
953 -- then the instantiation pointer is obtained by subtracting
954 -- 100 from the template pointer.
955
956 declare
957 pragma Suppress (All_Checks);
958
959 pragma Warnings (Off);
960 -- This unchecked conversion is aliasing safe since it
961 -- not used to create improperly aliased pointer values.
962
963 function To_Source_Buffer_Ptr is new
964 Unchecked_Conversion (Address, Source_Buffer_Ptr);
965
966 pragma Warnings (On);
967
968 begin
969 S.Source_Text :=
970 To_Source_Buffer_Ptr
971 (ST.Source_Text
972 (ST.Source_First - S.Source_First)'Address);
973 end;
974 end;
975
976 -- Normal case (non-instantiation)
977
978 else
979 First_Time_Around := False;
980 S.Lines_Table := null;
981 S.Logical_Lines_Table := null;
982 Alloc_Line_Tables (S, Int (S.Last_Source_Line));
983
984 for J in 1 .. S.Last_Source_Line loop
985 Tree_Read_Int (Int (S.Lines_Table (J)));
986 end loop;
987
988 if S.Num_SRef_Pragmas /= 0 then
989 for J in 1 .. S.Last_Source_Line loop
990 Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
991 end loop;
992 end if;
993
994 -- Allocate source buffer and read in the data and then set the
995 -- virtual origin to point to the logical zero'th element. This
996 -- address must be computed with subscript checks turned off.
997
998 declare
999 subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
1000 type Text_Buffer_Ptr is access B;
1001 T : Text_Buffer_Ptr;
1002
1003 pragma Suppress (All_Checks);
1004
1005 pragma Warnings (Off);
1006 -- This unchecked conversion is aliasing safe, since it is
1007 -- never used to create improperly aliased pointer values.
1008
1009 function To_Source_Buffer_Ptr is new
1010 Unchecked_Conversion (Address, Source_Buffer_Ptr);
1011
1012 pragma Warnings (On);
1013
1014 begin
1015 T := new B;
1016
1017 Tree_Read_Data (T (S.Source_First)'Address,
1018 Int (S.Source_Last) - Int (S.Source_First) + 1);
1019
1020 S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
1021 end;
1022 end if;
1023 end;
1024
1025 Set_Source_File_Index_Table (J);
1026 end loop;
1027 end Tree_Read;
1028
1029 ----------------
1030 -- Tree_Write --
1031 ----------------
1032
1033 procedure Tree_Write is
1034 begin
1035 Source_File.Tree_Write;
1036 Instances.Tree_Write;
1037
1038 -- The pointers we wrote out there for the source buffer and lines
1039 -- table pointers are junk, we now write out the actual data that
1040 -- is referenced by these two fields.
1041
1042 for J in Source_File.First .. Source_File.Last loop
1043 declare
1044 S : Source_File_Record renames Source_File.Table (J);
1045
1046 begin
1047 -- For instantiations, there is nothing to do, since the data is
1048 -- shared with the generic template. When the tree is read, the
1049 -- pointers must be set, but no extra data needs to be written.
1050
1051 if S.Instance /= No_Instance_Id then
1052 null;
1053
1054 -- For the normal case, write out the data of the tables
1055
1056 else
1057 -- Lines table
1058
1059 for J in 1 .. S.Last_Source_Line loop
1060 Tree_Write_Int (Int (S.Lines_Table (J)));
1061 end loop;
1062
1063 -- Logical lines table if present
1064
1065 if S.Num_SRef_Pragmas /= 0 then
1066 for J in 1 .. S.Last_Source_Line loop
1067 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
1068 end loop;
1069 end if;
1070
1071 -- Source buffer
1072
1073 Tree_Write_Data
1074 (S.Source_Text (S.Source_First)'Address,
1075 Int (S.Source_Last) - Int (S.Source_First) + 1);
1076 end if;
1077 end;
1078 end loop;
1079 end Tree_Write;
1080
1081 --------------------
1082 -- Write_Location --
1083 --------------------
1084
1085 procedure Write_Location (P : Source_Ptr) is
1086 begin
1087 if P = No_Location then
1088 Write_Str ("<no location>");
1089
1090 elsif P <= Standard_Location then
1091 Write_Str ("<standard location>");
1092
1093 else
1094 declare
1095 SI : constant Source_File_Index := Get_Source_File_Index (P);
1096
1097 begin
1098 Write_Name (Debug_Source_Name (SI));
1099 Write_Char (':');
1100 Write_Int (Int (Get_Logical_Line_Number (P)));
1101 Write_Char (':');
1102 Write_Int (Int (Get_Column_Number (P)));
1103
1104 if Instantiation (SI) /= No_Location then
1105 Write_Str (" [");
1106 Write_Location (Instantiation (SI));
1107 Write_Char (']');
1108 end if;
1109 end;
1110 end if;
1111 end Write_Location;
1112
1113 ----------------------
1114 -- Write_Time_Stamp --
1115 ----------------------
1116
1117 procedure Write_Time_Stamp (S : Source_File_Index) is
1118 T : constant Time_Stamp_Type := Time_Stamp (S);
1119 P : Natural;
1120
1121 begin
1122 if T (1) = '9' then
1123 Write_Str ("19");
1124 P := 0;
1125 else
1126 Write_Char (T (1));
1127 Write_Char (T (2));
1128 P := 2;
1129 end if;
1130
1131 Write_Char (T (P + 1));
1132 Write_Char (T (P + 2));
1133 Write_Char ('-');
1134
1135 Write_Char (T (P + 3));
1136 Write_Char (T (P + 4));
1137 Write_Char ('-');
1138
1139 Write_Char (T (P + 5));
1140 Write_Char (T (P + 6));
1141 Write_Char (' ');
1142
1143 Write_Char (T (P + 7));
1144 Write_Char (T (P + 8));
1145 Write_Char (':');
1146
1147 Write_Char (T (P + 9));
1148 Write_Char (T (P + 10));
1149 Write_Char (':');
1150
1151 Write_Char (T (P + 11));
1152 Write_Char (T (P + 12));
1153 end Write_Time_Stamp;
1154
1155 ----------------------------------------------
1156 -- Access Subprograms for Source File Table --
1157 ----------------------------------------------
1158
1159 function Debug_Source_Name (S : SFI) return File_Name_Type is
1160 begin
1161 return Source_File.Table (S).Debug_Source_Name;
1162 end Debug_Source_Name;
1163
1164 function Instance (S : SFI) return Instance_Id is
1165 begin
1166 return Source_File.Table (S).Instance;
1167 end Instance;
1168
1169 function File_Name (S : SFI) return File_Name_Type is
1170 begin
1171 return Source_File.Table (S).File_Name;
1172 end File_Name;
1173
1174 function File_Type (S : SFI) return Type_Of_File is
1175 begin
1176 return Source_File.Table (S).File_Type;
1177 end File_Type;
1178
1179 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1180 begin
1181 return Source_File.Table (S).First_Mapped_Line;
1182 end First_Mapped_Line;
1183
1184 function Full_Debug_Name (S : SFI) return File_Name_Type is
1185 begin
1186 return Source_File.Table (S).Full_Debug_Name;
1187 end Full_Debug_Name;
1188
1189 function Full_File_Name (S : SFI) return File_Name_Type is
1190 begin
1191 return Source_File.Table (S).Full_File_Name;
1192 end Full_File_Name;
1193
1194 function Full_Ref_Name (S : SFI) return File_Name_Type is
1195 begin
1196 return Source_File.Table (S).Full_Ref_Name;
1197 end Full_Ref_Name;
1198
1199 function Identifier_Casing (S : SFI) return Casing_Type is
1200 begin
1201 return Source_File.Table (S).Identifier_Casing;
1202 end Identifier_Casing;
1203
1204 function Inherited_Pragma (S : SFI) return Boolean is
1205 begin
1206 return Source_File.Table (S).Inherited_Pragma;
1207 end Inherited_Pragma;
1208
1209 function Inlined_Body (S : SFI) return Boolean is
1210 begin
1211 return Source_File.Table (S).Inlined_Body;
1212 end Inlined_Body;
1213
1214 function Inlined_Call (S : SFI) return Source_Ptr is
1215 begin
1216 return Source_File.Table (S).Inlined_Call;
1217 end Inlined_Call;
1218
1219 function Keyword_Casing (S : SFI) return Casing_Type is
1220 begin
1221 return Source_File.Table (S).Keyword_Casing;
1222 end Keyword_Casing;
1223
1224 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1225 begin
1226 return Source_File.Table (S).Last_Source_Line;
1227 end Last_Source_Line;
1228
1229 function License (S : SFI) return License_Type is
1230 begin
1231 return Source_File.Table (S).License;
1232 end License;
1233
1234 function Num_SRef_Pragmas (S : SFI) return Nat is
1235 begin
1236 return Source_File.Table (S).Num_SRef_Pragmas;
1237 end Num_SRef_Pragmas;
1238
1239 function Reference_Name (S : SFI) return File_Name_Type is
1240 begin
1241 return Source_File.Table (S).Reference_Name;
1242 end Reference_Name;
1243
1244 function Source_Checksum (S : SFI) return Word is
1245 begin
1246 return Source_File.Table (S).Source_Checksum;
1247 end Source_Checksum;
1248
1249 function Source_First (S : SFI) return Source_Ptr is
1250 begin
1251 if S = Internal_Source_File then
1252 return Internal_Source'First;
1253 else
1254 return Source_File.Table (S).Source_First;
1255 end if;
1256 end Source_First;
1257
1258 function Source_Last (S : SFI) return Source_Ptr is
1259 begin
1260 if S = Internal_Source_File then
1261 return Internal_Source'Last;
1262 else
1263 return Source_File.Table (S).Source_Last;
1264 end if;
1265 end Source_Last;
1266
1267 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1268 begin
1269 if S = Internal_Source_File then
1270 return Internal_Source_Ptr;
1271 else
1272 return Source_File.Table (S).Source_Text;
1273 end if;
1274 end Source_Text;
1275
1276 function Template (S : SFI) return SFI is
1277 begin
1278 return Source_File.Table (S).Template;
1279 end Template;
1280
1281 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1282 begin
1283 return Source_File.Table (S).Time_Stamp;
1284 end Time_Stamp;
1285
1286 function Unit (S : SFI) return Unit_Number_Type is
1287 begin
1288 return Source_File.Table (S).Unit;
1289 end Unit;
1290
1291 ------------------------------------------
1292 -- Set Procedures for Source File Table --
1293 ------------------------------------------
1294
1295 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1296 begin
1297 Source_File.Table (S).Identifier_Casing := C;
1298 end Set_Identifier_Casing;
1299
1300 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1301 begin
1302 Source_File.Table (S).Keyword_Casing := C;
1303 end Set_Keyword_Casing;
1304
1305 procedure Set_License (S : SFI; L : License_Type) is
1306 begin
1307 Source_File.Table (S).License := L;
1308 end Set_License;
1309
1310 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1311 begin
1312 Source_File.Table (S).Unit := U;
1313 end Set_Unit;
1314
1315 ----------------------
1316 -- Trim_Lines_Table --
1317 ----------------------
1318
1319 procedure Trim_Lines_Table (S : Source_File_Index) is
1320 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1321
1322 begin
1323 -- Release allocated storage that is no longer needed
1324
1325 Source_File.Table (S).Lines_Table := To_Pointer
1326 (Memory.Realloc
1327 (To_Address (Source_File.Table (S).Lines_Table),
1328 Memory.size_t
1329 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1330 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1331 end Trim_Lines_Table;
1332
1333 ------------
1334 -- Unlock --
1335 ------------
1336
1337 procedure Unlock is
1338 begin
1339 Source_File.Locked := False;
1340 Source_File.Release;
1341 end Unlock;
1342
1343 --------
1344 -- wl --
1345 --------
1346
1347 procedure wl (P : Source_Ptr) is
1348 begin
1349 Write_Location (P);
1350 Write_Eol;
1351 end wl;
1352
1353 end Sinput;