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