?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* arm.md (reload_mulsi3, reload_mulsi_compare0, reload_muladdsi)
[official-gcc.git] / gcc / ada / sinput.adb
blob0f78501e6497a109409acf4d92e574c358946817
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S I N P U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
29 -- --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
32 -- --
33 ------------------------------------------------------------------------------
34
35 pragma Style_Checks (All_Checks);
36 -- Subprograms not all in alpha order
37
38 with Debug; use Debug;
39 with Namet; use Namet;
40 with Opt; use Opt;
41 with Output; use Output;
42 with Tree_IO; use Tree_IO;
43 with System; use System;
44
45 with System.Memory;
46
47 with Unchecked_Conversion;
48 with Unchecked_Deallocation;
49
50 package body Sinput is
51
52 use ASCII;
53 -- Make control characters visible
54
55 First_Time_Around : Boolean := True;
56
57 -- Routines to support conversion between types Lines_Table_Ptr,
58 -- Logical_Lines_Table_Ptr and System.Address.
59
60 function To_Address is
61 new Unchecked_Conversion (Lines_Table_Ptr, Address);
62
63 function To_Address is
64 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
65
66 function To_Pointer is
67 new Unchecked_Conversion (Address, Lines_Table_Ptr);
68
69 function To_Pointer is
70 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
71
72 ---------------------------
73 -- Add_Line_Tables_Entry --
74 ---------------------------
75
76 procedure Add_Line_Tables_Entry
77 (S : in out Source_File_Record;
78 P : Source_Ptr)
79 is
80 LL : Physical_Line_Number;
81
82 begin
83 -- Reallocate the lines tables if necessary.
84
85 -- Note: the reason we do not use the normal Table package
86 -- mechanism is that we have several of these tables. We could
87 -- use the new GNAT.Dynamic_Tables package and that would probably
88 -- be a good idea ???
89
90 if S.Last_Source_Line = S.Lines_Table_Max then
91 Alloc_Line_Tables
92 (S,
93 Int (S.Last_Source_Line) *
94 ((100 + Alloc.Lines_Increment) / 100));
95
96 if Debug_Flag_D then
97 Write_Str ("--> Reallocating lines table, size = ");
98 Write_Int (Int (S.Lines_Table_Max));
99 Write_Eol;
100 end if;
101 end if;
102
103 S.Last_Source_Line := S.Last_Source_Line + 1;
104 LL := S.Last_Source_Line;
105
106 S.Lines_Table (LL) := P;
107
108 -- Deal with setting new entry in logical lines table if one is
109 -- present. Note that there is always space (because the call to
110 -- Alloc_Line_Tables makes sure both tables are the same length),
111
112 if S.Logical_Lines_Table /= null then
113
114 -- We can always set the entry from the previous one, because
115 -- the processing for a Source_Reference pragma ensures that
116 -- at least one entry following the pragma is set up correctly.
117
118 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
119 end if;
120 end Add_Line_Tables_Entry;
121
122 -----------------------
123 -- Alloc_Line_Tables --
124 -----------------------
125
126 procedure Alloc_Line_Tables
127 (S : in out Source_File_Record;
128 New_Max : Nat)
129 is
130 subtype size_t is Memory.size_t;
131
132 New_Table : Lines_Table_Ptr;
133
134 New_Logical_Table : Logical_Lines_Table_Ptr;
135
136 New_Size : constant size_t :=
137 size_t (New_Max * Lines_Table_Type'Component_Size /
138 Storage_Unit);
139
140 begin
141 if S.Lines_Table = null then
142 New_Table := To_Pointer (Memory.Alloc (New_Size));
143
144 else
145 New_Table :=
146 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
147 end if;
148
149 if New_Table = null then
150 raise Storage_Error;
151 else
152 S.Lines_Table := New_Table;
153 S.Lines_Table_Max := Physical_Line_Number (New_Max);
154 end if;
155
156 if S.Num_SRef_Pragmas /= 0 then
157 if S.Logical_Lines_Table = null then
158 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
159 else
160 New_Logical_Table := To_Pointer
161 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
162 end if;
163
164 if New_Logical_Table = null then
165 raise Storage_Error;
166 else
167 S.Logical_Lines_Table := New_Logical_Table;
168 end if;
169 end if;
170 end Alloc_Line_Tables;
171
172 -----------------
173 -- Backup_Line --
174 -----------------
175
176 procedure Backup_Line (P : in out Source_Ptr) is
177 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
178 Src : constant Source_Buffer_Ptr :=
179 Source_File.Table (Sindex).Source_Text;
180 Sfirst : constant Source_Ptr :=
181 Source_File.Table (Sindex).Source_First;
182
183 begin
184 P := P - 1;
185
186 if P = Sfirst then
187 return;
188 end if;
189
190 if Src (P) = CR then
191 if Src (P - 1) = LF then
192 P := P - 1;
193 end if;
194
195 else -- Src (P) = LF
196 if Src (P - 1) = CR then
197 P := P - 1;
198 end if;
199 end if;
200
201 -- Now find first character of the previous line
202
203 while P > Sfirst
204 and then Src (P - 1) /= LF
205 and then Src (P - 1) /= CR
206 loop
207 P := P - 1;
208 end loop;
209 end Backup_Line;
210
211 ---------------------------
212 -- Build_Location_String --
213 ---------------------------
214
215 procedure Build_Location_String (Loc : Source_Ptr) is
216 Ptr : Source_Ptr;
217
218 begin
219 Name_Len := 0;
220
221 -- Loop through instantiations
222
223 Ptr := Loc;
224 loop
225 Get_Name_String_And_Append
226 (Reference_Name (Get_Source_File_Index (Ptr)));
227 Add_Char_To_Name_Buffer (':');
228 Add_Nat_To_Name_Buffer
229 (Nat (Get_Logical_Line_Number (Ptr)));
230
231 Ptr := Instantiation_Location (Ptr);
232 exit when Ptr = No_Location;
233 Add_Str_To_Name_Buffer (" instantiated at ");
234 end loop;
235
236 Name_Buffer (Name_Len + 1) := NUL;
237 return;
238 end Build_Location_String;
239
240 -----------------------
241 -- Get_Column_Number --
242 -----------------------
243
244 function Get_Column_Number (P : Source_Ptr) return Column_Number is
245 S : Source_Ptr;
246 C : Column_Number;
247 Sindex : Source_File_Index;
248 Src : Source_Buffer_Ptr;
249
250 begin
251 -- If the input source pointer is not a meaningful value then return
252 -- at once with column number 1. This can happen for a file not found
253 -- condition for a file loaded indirectly by RTE, and also perhaps on
254 -- some unknown internal error conditions. In either case we certainly
255 -- don't want to blow up.
256
257 if P < 1 then
258 return 1;
259
260 else
261 Sindex := Get_Source_File_Index (P);
262 Src := Source_File.Table (Sindex).Source_Text;
263 S := Line_Start (P);
264 C := 1;
265
266 while S < P loop
267 if Src (S) = HT then
268 C := (C - 1) / 8 * 8 + (8 + 1);
269 else
270 C := C + 1;
271 end if;
272
273 S := S + 1;
274 end loop;
275
276 return C;
277 end if;
278 end Get_Column_Number;
279
280 -----------------------------
281 -- Get_Logical_Line_Number --
282 -----------------------------
283
284 function Get_Logical_Line_Number
285 (P : Source_Ptr)
286 return Logical_Line_Number
287 is
288 SFR : Source_File_Record
289 renames Source_File.Table (Get_Source_File_Index (P));
290
291 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
292
293 begin
294 if SFR.Num_SRef_Pragmas = 0 then
295 return Logical_Line_Number (L);
296 else
297 return SFR.Logical_Lines_Table (L);
298 end if;
299 end Get_Logical_Line_Number;
300
301 ------------------------------
302 -- Get_Physical_Line_Number --
303 ------------------------------
304
305 function Get_Physical_Line_Number
306 (P : Source_Ptr)
307 return Physical_Line_Number
308 is
309 Sfile : Source_File_Index;
310 Table : Lines_Table_Ptr;
311 Lo : Physical_Line_Number;
312 Hi : Physical_Line_Number;
313 Mid : Physical_Line_Number;
314 Loc : Source_Ptr;
315
316 begin
317 -- If the input source pointer is not a meaningful value then return
318 -- at once with line number 1. This can happen for a file not found
319 -- condition for a file loaded indirectly by RTE, and also perhaps on
320 -- some unknown internal error conditions. In either case we certainly
321 -- don't want to blow up.
322
323 if P < 1 then
324 return 1;
325
326 -- Otherwise we can do the binary search
327
328 else
329 Sfile := Get_Source_File_Index (P);
330 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
331 Table := Source_File.Table (Sfile).Lines_Table;
332 Lo := 1;
333 Hi := Source_File.Table (Sfile).Last_Source_Line;
334
335 loop
336 Mid := (Lo + Hi) / 2;
337
338 if Loc < Table (Mid) then
339 Hi := Mid - 1;
340
341 else -- Loc >= Table (Mid)
342
343 if Mid = Hi or else
344 Loc < Table (Mid + 1)
345 then
346 return Mid;
347 else
348 Lo := Mid + 1;
349 end if;
350
351 end if;
352
353 end loop;
354 end if;
355 end Get_Physical_Line_Number;
356
357 ---------------------------
358 -- Get_Source_File_Index --
359 ---------------------------
360
361 Source_Cache_First : Source_Ptr := 1;
362 Source_Cache_Last : Source_Ptr := 0;
363 -- Records the First and Last subscript values for the most recently
364 -- referenced entry in the source table, to optimize the common case
365 -- of repeated references to the same entry. The initial values force
366 -- an initial search to set the cache value.
367
368 Source_Cache_Index : Source_File_Index := No_Source_File;
369 -- Contains the index of the entry corresponding to Source_Cache
370
371 function Get_Source_File_Index
372 (S : Source_Ptr)
373 return Source_File_Index
374 is
375 begin
376 if S in Source_Cache_First .. Source_Cache_Last then
377 return Source_Cache_Index;
378
379 else
380 for J in 1 .. Source_File.Last loop
381 if S in Source_File.Table (J).Source_First ..
382 Source_File.Table (J).Source_Last
383 then
384 Source_Cache_Index := J;
385 Source_Cache_First :=
386 Source_File.Table (Source_Cache_Index).Source_First;
387 Source_Cache_Last :=
388 Source_File.Table (Source_Cache_Index).Source_Last;
389 return Source_Cache_Index;
390 end if;
391 end loop;
392 end if;
393
394 -- We must find a matching entry in the above loop!
395
396 raise Program_Error;
397 end Get_Source_File_Index;
398
399 ----------------
400 -- Initialize --
401 ----------------
402
403 procedure Initialize is
404 begin
405 Source_File.Init;
406 end Initialize;
407
408 -------------------------
409 -- Instantiation_Depth --
410 -------------------------
411
412 function Instantiation_Depth (S : Source_Ptr) return Nat is
413 Sind : Source_File_Index;
414 Sval : Source_Ptr;
415 Depth : Nat;
416
417 begin
418 Sval := S;
419 Depth := 0;
420
421 loop
422 Sind := Get_Source_File_Index (Sval);
423 Sval := Instantiation (Sind);
424 exit when Sval = No_Location;
425 Depth := Depth + 1;
426 end loop;
427
428 return Depth;
429 end Instantiation_Depth;
430
431 ----------------------------
432 -- Instantiation_Location --
433 ----------------------------
434
435 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
436 begin
437 return Instantiation (Get_Source_File_Index (S));
438 end Instantiation_Location;
439
440 ----------------------
441 -- Last_Source_File --
442 ----------------------
443
444 function Last_Source_File return Source_File_Index is
445 begin
446 return Source_File.Last;
447 end Last_Source_File;
448
449 ----------------
450 -- Line_Start --
451 ----------------
452
453 function Line_Start (P : Source_Ptr) return Source_Ptr is
454 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
455 Src : constant Source_Buffer_Ptr :=
456 Source_File.Table (Sindex).Source_Text;
457 Sfirst : constant Source_Ptr :=
458 Source_File.Table (Sindex).Source_First;
459 S : Source_Ptr;
460
461 begin
462 S := P;
463
464 while S > Sfirst
465 and then Src (S - 1) /= CR
466 and then Src (S - 1) /= LF
467 loop
468 S := S - 1;
469 end loop;
470
471 return S;
472 end Line_Start;
473
474 function Line_Start
475 (L : Physical_Line_Number;
476 S : Source_File_Index)
477 return Source_Ptr
478 is
479 begin
480 return Source_File.Table (S).Lines_Table (L);
481 end Line_Start;
482
483 ----------
484 -- Lock --
485 ----------
486
487 procedure Lock is
488 begin
489 Source_File.Locked := True;
490 Source_File.Release;
491 end Lock;
492
493 ----------------------
494 -- Num_Source_Files --
495 ----------------------
496
497 function Num_Source_Files return Nat is
498 begin
499 return Int (Source_File.Last) - Int (Source_File.First) + 1;
500 end Num_Source_Files;
501
502 ----------------------
503 -- Num_Source_Lines --
504 ----------------------
505
506 function Num_Source_Lines (S : Source_File_Index) return Nat is
507 begin
508 return Nat (Source_File.Table (S).Last_Source_Line);
509 end Num_Source_Lines;
510
511 -----------------------
512 -- Original_Location --
513 -----------------------
514
515 function Original_Location (S : Source_Ptr) return Source_Ptr is
516 Sindex : Source_File_Index;
517 Tindex : Source_File_Index;
518
519 begin
520 if S <= No_Location then
521 return S;
522
523 else
524 Sindex := Get_Source_File_Index (S);
525
526 if Instantiation (Sindex) = No_Location then
527 return S;
528
529 else
530 Tindex := Template (Sindex);
531 while Instantiation (Tindex) /= No_Location loop
532 Tindex := Template (Tindex);
533 end loop;
534
535 return S - Source_First (Sindex) + Source_First (Tindex);
536 end if;
537 end if;
538 end Original_Location;
539
540 -------------------------
541 -- Physical_To_Logical --
542 -------------------------
543
544 function Physical_To_Logical
545 (Line : Physical_Line_Number;
546 S : Source_File_Index)
547 return Logical_Line_Number
548 is
549 SFR : Source_File_Record renames Source_File.Table (S);
550
551 begin
552 if SFR.Num_SRef_Pragmas = 0 then
553 return Logical_Line_Number (Line);
554 else
555 return SFR.Logical_Lines_Table (Line);
556 end if;
557 end Physical_To_Logical;
558
559 --------------------------------
560 -- Register_Source_Ref_Pragma --
561 --------------------------------
562
563 procedure Register_Source_Ref_Pragma
564 (File_Name : Name_Id;
565 Stripped_File_Name : Name_Id;
566 Mapped_Line : Nat;
567 Line_After_Pragma : Physical_Line_Number)
568 is
569 subtype size_t is Memory.size_t;
570
571 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
572
573 ML : Logical_Line_Number;
574
575 begin
576 if File_Name /= No_Name then
577 SFR.Full_Ref_Name := File_Name;
578
579 if not Debug_Generated_Code then
580 SFR.Debug_Source_Name := File_Name;
581 end if;
582
583 SFR.Reference_Name := Stripped_File_Name;
584 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
585 end if;
586
587 if SFR.Num_SRef_Pragmas = 1 then
588 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
589 end if;
590
591 if SFR.Logical_Lines_Table = null then
592 SFR.Logical_Lines_Table := To_Pointer
593 (Memory.Alloc
594 (size_t (SFR.Lines_Table_Max *
595 Logical_Lines_Table_Type'Component_Size /
596 Storage_Unit)));
597 end if;
598
599 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
600
601 ML := Logical_Line_Number (Mapped_Line);
602 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
603 SFR.Logical_Lines_Table (J) := ML;
604 ML := ML + 1;
605 end loop;
606 end Register_Source_Ref_Pragma;
607
608 ---------------------------
609 -- Skip_Line_Terminators --
610 ---------------------------
611
612 -- There are two distinct concepts of line terminator in GNAT
613
614 -- A logical line terminator is what corresponds to the "end of a line"
615 -- as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
616 -- acts as an end of logical line in this sense, and it is essentially
617 -- irrelevant whether one or more appears in sequence (since if a
618 -- sequence of such characters is regarded as separate ends of line,
619 -- then the intervening logical lines are null in any case).
620
621 -- A physical line terminator is a sequence of format effectors that
622 -- is treated as ending a physical line. Physical lines have no Ada
623 -- semantic significance, but they are significant for error reporting
624 -- purposes, since errors are identified by line and column location.
625
626 -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
627 -- CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
628 -- and CR alone in System 7. We don't know of any system using LF/CR, but
629 -- it seems reasonable to include this case for consistency. In addition,
630 -- we recognize any of these sequences in any of the operating systems,
631 -- for better behavior in treating foreign files (e.g. a Unix file with
632 -- LF terminators transferred to a DOS system).
633
634 procedure Skip_Line_Terminators
635 (P : in out Source_Ptr;
636 Physical : out Boolean)
637 is
638 begin
639 pragma Assert (Source (P) in Line_Terminator);
640
641 if Source (P) = CR then
642 if Source (P + 1) = LF then
643 P := P + 2;
644 else
645 P := P + 1;
646 end if;
647
648 elsif Source (P) = LF then
649 if Source (P + 1) = CR then
650 P := P + 2;
651 else
652 P := P + 1;
653 end if;
654
655 else -- Source (P) = FF or else Source (P) = VT
656 P := P + 1;
657 Physical := False;
658 return;
659 end if;
660
661 -- Fall through in the physical line terminator case. First deal with
662 -- making a possible entry into the lines table if one is needed.
663
664 -- Note: we are dealing with a real source file here, this cannot be
665 -- the instantiation case, so we need not worry about Sloc adjustment.
666
667 declare
668 S : Source_File_Record
669 renames Source_File.Table (Current_Source_File);
670
671 begin
672 Physical := True;
673
674 -- Make entry in lines table if not already made (in some scan backup
675 -- cases, we will be rescanning previously scanned source, so the
676 -- entry may have already been made on the previous forward scan).
677
678 if Source (P) /= EOF
679 and then P > S.Lines_Table (S.Last_Source_Line)
680 then
681 Add_Line_Tables_Entry (S, P);
682 end if;
683 end;
684 end Skip_Line_Terminators;
685
686 -------------------
687 -- Source_Offset --
688 -------------------
689
690 function Source_Offset (S : Source_Ptr) return Nat is
691 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
692 Sfirst : constant Source_Ptr :=
693 Source_File.Table (Sindex).Source_First;
694
695 begin
696 return Nat (S - Sfirst);
697 end Source_Offset;
698
699 ------------------------
700 -- Top_Level_Location --
701 ------------------------
702
703 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
704 Oldloc : Source_Ptr;
705 Newloc : Source_Ptr;
706
707 begin
708 Newloc := S;
709 loop
710 Oldloc := Newloc;
711 Newloc := Instantiation_Location (Oldloc);
712 exit when Newloc = No_Location;
713 end loop;
714
715 return Oldloc;
716 end Top_Level_Location;
717
718 ---------------
719 -- Tree_Read --
720 ---------------
721
722 procedure Tree_Read is
723 begin
724 -- First we must free any old source buffer pointers
725
726 if not First_Time_Around then
727 for J in Source_File.First .. Source_File.Last loop
728 declare
729 S : Source_File_Record renames Source_File.Table (J);
730
731 procedure Free_Ptr is new Unchecked_Deallocation
732 (Big_Source_Buffer, Source_Buffer_Ptr);
733
734 function To_Source_Buffer_Ptr is new
735 Unchecked_Conversion (Address, Source_Buffer_Ptr);
736
737 Tmp1 : Source_Buffer_Ptr;
738
739 begin
740 if S.Instantiation /= No_Location then
741 null;
742
743 else
744 -- We have to recreate a proper pointer to the actual array
745 -- from the zero origin pointer stored in the source table.
746
747 Tmp1 :=
748 To_Source_Buffer_Ptr
749 (S.Source_Text (S.Source_First)'Address);
750 Free_Ptr (Tmp1);
751
752 -- Note: we are using free here, because we used malloc
753 -- or realloc directly to allocate the tables. That is
754 -- because we were playing the big array trick.
755
756 if S.Lines_Table /= null then
757 Memory.Free (To_Address (S.Lines_Table));
758 S.Lines_Table := null;
759 end if;
760
761 if S.Logical_Lines_Table /= null then
762 Memory.Free (To_Address (S.Logical_Lines_Table));
763 S.Logical_Lines_Table := null;
764 end if;
765 end if;
766 end;
767 end loop;
768 end if;
769
770 -- Reset source cache pointers to force new read
771
772 Source_Cache_First := 1;
773 Source_Cache_Last := 0;
774
775 -- Read in source file table
776
777 Source_File.Tree_Read;
778
779 -- The pointers we read in there for the source buffer and lines
780 -- table pointers are junk. We now read in the actual data that
781 -- is referenced by these two fields.
782
783 for J in Source_File.First .. Source_File.Last loop
784 declare
785 S : Source_File_Record renames Source_File.Table (J);
786
787 begin
788 -- For the instantiation case, we do not read in any data. Instead
789 -- we share the data for the generic template entry. Since the
790 -- template always occurs first, we can safetly refer to its data.
791
792 if S.Instantiation /= No_Location then
793 declare
794 ST : Source_File_Record renames
795 Source_File.Table (S.Template);
796
797 begin
798 -- The lines tables are copied from the template entry
799
800 S.Lines_Table :=
801 Source_File.Table (S.Template).Lines_Table;
802 S.Logical_Lines_Table :=
803 Source_File.Table (S.Template).Logical_Lines_Table;
804
805 -- In the case of the source table pointer, we share the
806 -- same data as the generic template, but the virtual origin
807 -- is adjusted. For example, if the first subscript of the
808 -- template is 100, and that of the instantiation is 200,
809 -- then the instantiation pointer is obtained by subtracting
810 -- 100 from the template pointer.
811
812 declare
813 pragma Suppress (All_Checks);
814
815 function To_Source_Buffer_Ptr is new
816 Unchecked_Conversion (Address, Source_Buffer_Ptr);
817
818 begin
819 S.Source_Text :=
820 To_Source_Buffer_Ptr
821 (ST.Source_Text
822 (ST.Source_First - S.Source_First)'Address);
823 end;
824 end;
825
826 -- Normal case (non-instantiation)
827
828 else
829 First_Time_Around := False;
830 S.Lines_Table := null;
831 S.Logical_Lines_Table := null;
832 Alloc_Line_Tables (S, Int (S.Last_Source_Line));
833
834 for J in 1 .. S.Last_Source_Line loop
835 Tree_Read_Int (Int (S.Lines_Table (J)));
836 end loop;
837
838 if S.Num_SRef_Pragmas /= 0 then
839 for J in 1 .. S.Last_Source_Line loop
840 Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
841 end loop;
842 end if;
843
844 -- Allocate source buffer and read in the data and then set the
845 -- virtual origin to point to the logical zero'th element. This
846 -- address must be computed with subscript checks turned off.
847
848 declare
849 subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
850 type Text_Buffer_Ptr is access B;
851 T : Text_Buffer_Ptr;
852
853 pragma Suppress (All_Checks);
854
855 function To_Source_Buffer_Ptr is new
856 Unchecked_Conversion (Address, Source_Buffer_Ptr);
857
858 begin
859 T := new B;
860
861 Tree_Read_Data (T (S.Source_First)'Address,
862 Int (S.Source_Last) - Int (S.Source_First) + 1);
863
864 S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
865 end;
866 end if;
867 end;
868 end loop;
869 end Tree_Read;
870
871 ----------------
872 -- Tree_Write --
873 ----------------
874
875 procedure Tree_Write is
876 begin
877 Source_File.Tree_Write;
878
879 -- The pointers we wrote out there for the source buffer and lines
880 -- table pointers are junk, we now write out the actual data that
881 -- is referenced by these two fields.
882
883 for J in Source_File.First .. Source_File.Last loop
884 declare
885 S : Source_File_Record renames Source_File.Table (J);
886
887 begin
888 -- For instantiations, there is nothing to do, since the data is
889 -- shared with the generic template. When the tree is read, the
890 -- pointers must be set, but no extra data needs to be written.
891
892 if S.Instantiation /= No_Location then
893 null;
894
895 -- For the normal case, write out the data of the tables
896
897 else
898 -- Lines table
899
900 for J in 1 .. S.Last_Source_Line loop
901 Tree_Write_Int (Int (S.Lines_Table (J)));
902 end loop;
903
904 -- Logical lines table if present
905
906 if S.Num_SRef_Pragmas /= 0 then
907 for J in 1 .. S.Last_Source_Line loop
908 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
909 end loop;
910 end if;
911
912 -- Source buffer
913
914 Tree_Write_Data
915 (S.Source_Text (S.Source_First)'Address,
916 Int (S.Source_Last) - Int (S.Source_First) + 1);
917 end if;
918 end;
919 end loop;
920 end Tree_Write;
921
922 --------------------
923 -- Write_Location --
924 --------------------
925
926 procedure Write_Location (P : Source_Ptr) is
927 begin
928 if P = No_Location then
929 Write_Str ("<no location>");
930
931 elsif P <= Standard_Location then
932 Write_Str ("<standard location>");
933
934 else
935 declare
936 SI : constant Source_File_Index := Get_Source_File_Index (P);
937
938 begin
939 Write_Name (Debug_Source_Name (SI));
940 Write_Char (':');
941 Write_Int (Int (Get_Logical_Line_Number (P)));
942 Write_Char (':');
943 Write_Int (Int (Get_Column_Number (P)));
944
945 if Instantiation (SI) /= No_Location then
946 Write_Str (" [");
947 Write_Location (Instantiation (SI));
948 Write_Char (']');
949 end if;
950 end;
951 end if;
952 end Write_Location;
953
954 ----------------------
955 -- Write_Time_Stamp --
956 ----------------------
957
958 procedure Write_Time_Stamp (S : Source_File_Index) is
959 T : constant Time_Stamp_Type := Time_Stamp (S);
960 P : Natural;
961
962 begin
963 if T (1) = '9' then
964 Write_Str ("19");
965 P := 0;
966 else
967 Write_Char (T (1));
968 Write_Char (T (2));
969 P := 2;
970 end if;
971
972 Write_Char (T (P + 1));
973 Write_Char (T (P + 2));
974 Write_Char ('-');
975
976 Write_Char (T (P + 3));
977 Write_Char (T (P + 4));
978 Write_Char ('-');
979
980 Write_Char (T (P + 5));
981 Write_Char (T (P + 6));
982 Write_Char (' ');
983
984 Write_Char (T (P + 7));
985 Write_Char (T (P + 8));
986 Write_Char (':');
987
988 Write_Char (T (P + 9));
989 Write_Char (T (P + 10));
990 Write_Char (':');
991
992 Write_Char (T (P + 11));
993 Write_Char (T (P + 12));
994 end Write_Time_Stamp;
995
996 ----------------------------------------------
997 -- Access Subprograms for Source File Table --
998 ----------------------------------------------
999
1000 function Debug_Source_Name (S : SFI) return File_Name_Type is
1001 begin
1002 return Source_File.Table (S).Debug_Source_Name;
1003 end Debug_Source_Name;
1004
1005 function File_Name (S : SFI) return File_Name_Type is
1006 begin
1007 return Source_File.Table (S).File_Name;
1008 end File_Name;
1009
1010 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1011 begin
1012 return Source_File.Table (S).First_Mapped_Line;
1013 end First_Mapped_Line;
1014
1015 function Full_File_Name (S : SFI) return File_Name_Type is
1016 begin
1017 return Source_File.Table (S).Full_File_Name;
1018 end Full_File_Name;
1019
1020 function Full_Ref_Name (S : SFI) return File_Name_Type is
1021 begin
1022 return Source_File.Table (S).Full_Ref_Name;
1023 end Full_Ref_Name;
1024
1025 function Identifier_Casing (S : SFI) return Casing_Type is
1026 begin
1027 return Source_File.Table (S).Identifier_Casing;
1028 end Identifier_Casing;
1029
1030 function Instantiation (S : SFI) return Source_Ptr is
1031 begin
1032 return Source_File.Table (S).Instantiation;
1033 end Instantiation;
1034
1035 function Keyword_Casing (S : SFI) return Casing_Type is
1036 begin
1037 return Source_File.Table (S).Keyword_Casing;
1038 end Keyword_Casing;
1039
1040 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1041 begin
1042 return Source_File.Table (S).Last_Source_Line;
1043 end Last_Source_Line;
1044
1045 function License (S : SFI) return License_Type is
1046 begin
1047 return Source_File.Table (S).License;
1048 end License;
1049
1050 function Num_SRef_Pragmas (S : SFI) return Nat is
1051 begin
1052 return Source_File.Table (S).Num_SRef_Pragmas;
1053 end Num_SRef_Pragmas;
1054
1055 function Reference_Name (S : SFI) return File_Name_Type is
1056 begin
1057 return Source_File.Table (S).Reference_Name;
1058 end Reference_Name;
1059
1060 function Source_Checksum (S : SFI) return Word is
1061 begin
1062 return Source_File.Table (S).Source_Checksum;
1063 end Source_Checksum;
1064
1065 function Source_First (S : SFI) return Source_Ptr is
1066 begin
1067 return Source_File.Table (S).Source_First;
1068 end Source_First;
1069
1070 function Source_Last (S : SFI) return Source_Ptr is
1071 begin
1072 return Source_File.Table (S).Source_Last;
1073 end Source_Last;
1074
1075 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1076 begin
1077 return Source_File.Table (S).Source_Text;
1078 end Source_Text;
1079
1080 function Template (S : SFI) return SFI is
1081 begin
1082 return Source_File.Table (S).Template;
1083 end Template;
1084
1085 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1086 begin
1087 return Source_File.Table (S).Time_Stamp;
1088 end Time_Stamp;
1089
1090 ------------------------------------------
1091 -- Set Procedures for Source File Table --
1092 ------------------------------------------
1093
1094 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1095 begin
1096 Source_File.Table (S).Identifier_Casing := C;
1097 end Set_Identifier_Casing;
1098
1099 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1100 begin
1101 Source_File.Table (S).Keyword_Casing := C;
1102 end Set_Keyword_Casing;
1103
1104 procedure Set_License (S : SFI; L : License_Type) is
1105 begin
1106 Source_File.Table (S).License := L;
1107 end Set_License;
1108
1109 ----------------------
1110 -- Trim_Lines_Table --
1111 ----------------------
1112
1113 procedure Trim_Lines_Table (S : Source_File_Index) is
1114 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1115
1116 begin
1117 -- Release allocated storage that is no longer needed
1118
1119 Source_File.Table (S).Lines_Table := To_Pointer
1120 (Memory.Realloc
1121 (To_Address (Source_File.Table (S).Lines_Table),
1122 Memory.size_t
1123 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1124 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1125 end Trim_Lines_Table;
1126
1127 --------
1128 -- wl --
1129 --------
1130
1131 procedure wl (P : Source_Ptr) is
1132 begin
1133 Write_Location (P);
1134 Write_Eol;
1135 end wl;
1136
1137 end Sinput;
Mirror of the offical gcc git repository hosted at gcc.gnu.org