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