?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-06-23 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc.git] / gcc / ada / sinput-l.adb
blobc084555cd93caa6273be91c48ac1fcf8748643ec
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S I N P U T . L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Alloc;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Fname; use Fname;
32 with Lib; use Lib;
33 with Opt; use Opt;
34 with Osint; use Osint;
35 with Output; use Output;
36 with Prep; use Prep;
37 with Prepcomp; use Prepcomp;
38 with Scans; use Scans;
39 with Scn; use Scn;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Util; use Sem_Util;
42 with Sinfo; use Sinfo;
43 with Snames; use Snames;
44 with System; use System;
45
46 with System.OS_Lib; use System.OS_Lib;
47
48 with Unchecked_Conversion;
49
50 package body Sinput.L is
51
52 Prep_Buffer : Text_Buffer_Ptr := null;
53 -- A buffer to temporarily stored the result of preprocessing a source.
54 -- It is only allocated if there is at least one source to preprocess.
55
56 Prep_Buffer_Last : Text_Ptr := 0;
57 -- Index of the last significant character in Prep_Buffer
58
59 Initial_Size_Of_Prep_Buffer : constant := 10_000;
60 -- Size of Prep_Buffer when it is first allocated
61
62 -- When a file is to be preprocessed and the options to list symbols
63 -- has been selected (switch -s), Prep.List_Symbols is called with a
64 -- "foreword", a single line indicating what source the symbols apply to.
65 -- The following two constant String are the start and the end of this
66 -- foreword.
67
68 Foreword_Start : constant String :=
69 "Preprocessing Symbols for source """;
70
71 Foreword_End : constant String := """";
72
73 -----------------
74 -- Subprograms --
75 -----------------
76
77 procedure Put_Char_In_Prep_Buffer (C : Character);
78 -- Add one character in Prep_Buffer, extending Prep_Buffer if need be.
79 -- Used to initialize the preprocessor.
80
81 procedure New_EOL_In_Prep_Buffer;
82 -- Add an LF to Prep_Buffer (used to initialize the preprocessor)
83
84 function Load_File
85 (N : File_Name_Type;
86 T : Osint.File_Type) return Source_File_Index;
87 -- Load a source file, a configuration pragmas file or a definition file
88 -- Coding also allows preprocessing file, but not a library file ???
89
90 -------------------------------
91 -- Adjust_Instantiation_Sloc --
92 -------------------------------
93
94 procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
95 Loc : constant Source_Ptr := Sloc (N);
96
97 begin
98 -- We only do the adjustment if the value is between the appropriate low
99 -- and high values. It is not clear that this should ever not be the
100 -- case, but in practice there seem to be some nodes that get copied
101 -- twice, and this is a defence against that happening.
102
103 if A.Lo <= Loc and then Loc <= A.Hi then
104 Set_Sloc (N, Loc + A.Adjust);
105 end if;
106 end Adjust_Instantiation_Sloc;
107
108 --------------------------------
109 -- Complete_Source_File_Entry --
110 --------------------------------
111
112 procedure Complete_Source_File_Entry is
113 CSF : constant Source_File_Index := Current_Source_File;
114 begin
115 Trim_Lines_Table (CSF);
116 Source_File.Table (CSF).Source_Checksum := Checksum;
117 end Complete_Source_File_Entry;
118
119 ---------------------------------
120 -- Create_Instantiation_Source --
121 ---------------------------------
122
123 procedure Create_Instantiation_Source
124 (Inst_Node : Entity_Id;
125 Template_Id : Entity_Id;
126 Inlined_Body : Boolean;
127 A : out Sloc_Adjustment)
128 is
129 Dnod : constant Node_Id := Declaration_Node (Template_Id);
130 Xold : Source_File_Index;
131 Xnew : Source_File_Index;
132
133 begin
134 Xold := Get_Source_File_Index (Sloc (Template_Id));
135 A.Lo := Source_File.Table (Xold).Source_First;
136 A.Hi := Source_File.Table (Xold).Source_Last;
137
138 Source_File.Append (Source_File.Table (Xold));
139 Xnew := Source_File.Last;
140
141 declare
142 Sold : Source_File_Record renames Source_File.Table (Xold);
143 Snew : Source_File_Record renames Source_File.Table (Xnew);
144
145 Inst_Spec : Node_Id;
146
147 begin
148 Snew.Inlined_Body := Inlined_Body;
149 Snew.Template := Xold;
150
151 -- For a genuine generic instantiation, assign new instance id.
152 -- For inlined bodies, we retain that of the template, but we
153 -- save the call location.
154
155 if Inlined_Body then
156 Snew.Inlined_Call := Sloc (Inst_Node);
157
158 else
159 -- If the spec has been instantiated already, and we are now
160 -- creating the instance source for the corresponding body now,
161 -- retrieve the instance id that was assigned to the spec, which
162 -- corresponds to the same instantiation sloc.
163
164 Inst_Spec := Instance_Spec (Inst_Node);
165 if Present (Inst_Spec) then
166 declare
167 Inst_Spec_Ent : Entity_Id;
168 -- Instance spec entity
169
170 Inst_Spec_Sloc : Source_Ptr;
171 -- Virtual sloc of the spec instance source
172
173 Inst_Spec_Inst_Id : Instance_Id;
174 -- Instance id assigned to the instance spec
175
176 begin
177 Inst_Spec_Ent := Defining_Entity (Inst_Spec);
178
179 -- For a subprogram instantiation, we want the subprogram
180 -- instance, not the wrapper package.
181
182 if Present (Related_Instance (Inst_Spec_Ent)) then
183 Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent);
184 end if;
185
186 -- The specification of the instance entity has a virtual
187 -- sloc within the instance sloc range.
188
189 -- ??? But the Unit_Declaration_Node has the sloc of the
190 -- instantiation, which is somewhat of an oddity.
191
192 Inst_Spec_Sloc :=
193 Sloc
194 (Specification (Unit_Declaration_Node (Inst_Spec_Ent)));
195 Inst_Spec_Inst_Id :=
196 Source_File.Table
197 (Get_Source_File_Index (Inst_Spec_Sloc)).Instance;
198
199 pragma Assert
200 (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id));
201 Snew.Instance := Inst_Spec_Inst_Id;
202 end;
203
204 else
205 Instances.Append (Sloc (Inst_Node));
206 Snew.Instance := Instances.Last;
207 end if;
208 end if;
209
210 -- Now we need to compute the new values of Source_First and
211 -- Source_Last and adjust the source file pointer to have the
212 -- correct virtual origin for the new range of values.
213
214 -- Source_First must be greater than the last Source_Last value
215 -- and also must be a multiple of Source_Align
216
217 Snew.Source_First :=
218 ((Source_File.Table (Xnew - 1).Source_Last + Source_Align) /
219 Source_Align) * Source_Align;
220 A.Adjust := Snew.Source_First - A.Lo;
221 Snew.Source_Last := A.Hi + A.Adjust;
222
223 Set_Source_File_Index_Table (Xnew);
224
225 Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust;
226
227 if Debug_Flag_L then
228 Write_Eol;
229 Write_Str ("*** Create instantiation source for ");
230
231 if Nkind (Dnod) in N_Proper_Body
232 and then Was_Originally_Stub (Dnod)
233 then
234 Write_Str ("subunit ");
235
236 elsif Ekind (Template_Id) = E_Generic_Package then
237 if Nkind (Dnod) = N_Package_Body then
238 Write_Str ("body of package ");
239 else
240 Write_Str ("spec of package ");
241 end if;
242
243 elsif Ekind (Template_Id) = E_Function then
244 Write_Str ("body of function ");
245
246 elsif Ekind (Template_Id) = E_Procedure then
247 Write_Str ("body of procedure ");
248
249 elsif Ekind (Template_Id) = E_Generic_Function then
250 Write_Str ("spec of function ");
251
252 elsif Ekind (Template_Id) = E_Generic_Procedure then
253 Write_Str ("spec of procedure ");
254
255 elsif Ekind (Template_Id) = E_Package_Body then
256 Write_Str ("body of package ");
257
258 else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
259
260 if Nkind (Dnod) = N_Procedure_Specification then
261 Write_Str ("body of procedure ");
262 else
263 Write_Str ("body of function ");
264 end if;
265 end if;
266
267 Write_Name (Chars (Template_Id));
268 Write_Eol;
269
270 Write_Str (" new source index = ");
271 Write_Int (Int (Xnew));
272 Write_Eol;
273
274 Write_Str (" copying from file name = ");
275 Write_Name (File_Name (Xold));
276 Write_Eol;
277
278 Write_Str (" old source index = ");
279 Write_Int (Int (Xold));
280 Write_Eol;
281
282 Write_Str (" old lo = ");
283 Write_Int (Int (A.Lo));
284 Write_Eol;
285
286 Write_Str (" old hi = ");
287 Write_Int (Int (A.Hi));
288 Write_Eol;
289
290 Write_Str (" new lo = ");
291 Write_Int (Int (Snew.Source_First));
292 Write_Eol;
293
294 Write_Str (" new hi = ");
295 Write_Int (Int (Snew.Source_Last));
296 Write_Eol;
297
298 Write_Str (" adjustment factor = ");
299 Write_Int (Int (A.Adjust));
300 Write_Eol;
301
302 Write_Str (" instantiation location: ");
303 Write_Location (Sloc (Inst_Node));
304 Write_Eol;
305 end if;
306
307 -- For a given character in the source, a higher subscript will be
308 -- used to access the instantiation, which means that the virtual
309 -- origin must have a corresponding lower value. We compute this new
310 -- origin by taking the address of the appropriate adjusted element
311 -- in the old array. Since this adjusted element will be at a
312 -- negative subscript, we must suppress checks.
313
314 declare
315 pragma Suppress (All_Checks);
316
317 pragma Warnings (Off);
318 -- This unchecked conversion is aliasing safe, since it is never
319 -- used to create improperly aliased pointer values.
320
321 function To_Source_Buffer_Ptr is new
322 Unchecked_Conversion (Address, Source_Buffer_Ptr);
323
324 pragma Warnings (On);
325
326 begin
327 Snew.Source_Text :=
328 To_Source_Buffer_Ptr
329 (Sold.Source_Text (-A.Adjust)'Address);
330 end;
331 end;
332 end Create_Instantiation_Source;
333
334 ----------------------
335 -- Load_Config_File --
336 ----------------------
337
338 function Load_Config_File
339 (N : File_Name_Type) return Source_File_Index
340 is
341 begin
342 return Load_File (N, Osint.Config);
343 end Load_Config_File;
344
345 --------------------------
346 -- Load_Definition_File --
347 --------------------------
348
349 function Load_Definition_File
350 (N : File_Name_Type) return Source_File_Index
351 is
352 begin
353 return Load_File (N, Osint.Definition);
354 end Load_Definition_File;
355
356 ---------------
357 -- Load_File --
358 ---------------
359
360 function Load_File
361 (N : File_Name_Type;
362 T : Osint.File_Type) return Source_File_Index
363 is
364 Src : Source_Buffer_Ptr;
365 X : Source_File_Index;
366 Lo : Source_Ptr;
367 Hi : Source_Ptr;
368
369 Preprocessing_Needed : Boolean := False;
370
371 begin
372 -- If already there, don't need to reload file. An exception occurs
373 -- in multiple unit per file mode. It would be nice in this case to
374 -- share the same source file for each unit, but this leads to many
375 -- difficulties with assumptions (e.g. in the body of lib), that a
376 -- unit can be found by locating its source file index. Since we do
377 -- not expect much use of this mode, it's no big deal to waste a bit
378 -- of space and time by reading and storing the source multiple times.
379
380 if Multiple_Unit_Index = 0 then
381 for J in 1 .. Source_File.Last loop
382 if Source_File.Table (J).File_Name = N then
383 return J;
384 end if;
385 end loop;
386 end if;
387
388 -- Here we must build a new entry in the file table
389
390 -- But first, we must check if a source needs to be preprocessed,
391 -- because we may have to load and parse a definition file, and we want
392 -- to do that before we load the source, so that the buffer of the
393 -- source will be the last created, and we will be able to replace it
394 -- and modify Hi without stepping on another buffer.
395
396 if T = Osint.Source and then not Is_Internal_File_Name (N) then
397 Prepare_To_Preprocess
398 (Source => N, Preprocessing_Needed => Preprocessing_Needed);
399 end if;
400
401 Source_File.Increment_Last;
402 X := Source_File.Last;
403
404 -- Compute starting index, respecting alignment requirement
405
406 if X = Source_File.First then
407 Lo := First_Source_Ptr;
408 else
409 Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) /
410 Source_Align) * Source_Align;
411 end if;
412
413 Osint.Read_Source_File (N, Lo, Hi, Src, T);
414
415 if Src = null then
416 Source_File.Decrement_Last;
417 return No_Source_File;
418
419 else
420 if Debug_Flag_L then
421 Write_Eol;
422 Write_Str ("*** Build source file table entry, Index = ");
423 Write_Int (Int (X));
424 Write_Str (", file name = ");
425 Write_Name (N);
426 Write_Eol;
427 Write_Str (" lo = ");
428 Write_Int (Int (Lo));
429 Write_Eol;
430 Write_Str (" hi = ");
431 Write_Int (Int (Hi));
432 Write_Eol;
433
434 Write_Str (" first 10 chars -->");
435
436 declare
437 procedure Wchar (C : Character);
438 -- Writes character or ? for control character
439
440 -----------
441 -- Wchar --
442 -----------
443
444 procedure Wchar (C : Character) is
445 begin
446 if C < ' '
447 or else C in ASCII.DEL .. Character'Val (16#9F#)
448 then
449 Write_Char ('?');
450 else
451 Write_Char (C);
452 end if;
453 end Wchar;
454
455 begin
456 for J in Lo .. Lo + 9 loop
457 Wchar (Src (J));
458 end loop;
459
460 Write_Str ("<--");
461 Write_Eol;
462
463 Write_Str (" last 10 chars -->");
464
465 for J in Hi - 10 .. Hi - 1 loop
466 Wchar (Src (J));
467 end loop;
468
469 Write_Str ("<--");
470 Write_Eol;
471
472 if Src (Hi) /= EOF then
473 Write_Str (" error: no EOF at end");
474 Write_Eol;
475 end if;
476 end;
477 end if;
478
479 declare
480 S : Source_File_Record renames Source_File.Table (X);
481 File_Type : Type_Of_File;
482
483 begin
484 case T is
485 when Osint.Source =>
486 File_Type := Sinput.Src;
487
488 when Osint.Library =>
489 raise Program_Error;
490
491 when Osint.Config =>
492 File_Type := Sinput.Config;
493
494 when Osint.Definition =>
495 File_Type := Def;
496
497 when Osint.Preprocessing_Data =>
498 File_Type := Preproc;
499 end case;
500
501 S := (Debug_Source_Name => N,
502 File_Name => N,
503 File_Type => File_Type,
504 First_Mapped_Line => No_Line_Number,
505 Full_Debug_Name => Osint.Full_Source_Name,
506 Full_File_Name => Osint.Full_Source_Name,
507 Full_Ref_Name => Osint.Full_Source_Name,
508 Instance => No_Instance_Id,
509 Identifier_Casing => Unknown,
510 Inlined_Call => No_Location,
511 Inlined_Body => False,
512 Keyword_Casing => Unknown,
513 Last_Source_Line => 1,
514 License => Unknown,
515 Lines_Table => null,
516 Lines_Table_Max => 1,
517 Logical_Lines_Table => null,
518 Num_SRef_Pragmas => 0,
519 Reference_Name => N,
520 Sloc_Adjust => 0,
521 Source_Checksum => 0,
522 Source_First => Lo,
523 Source_Last => Hi,
524 Source_Text => Src,
525 Template => No_Source_File,
526 Unit => No_Unit,
527 Time_Stamp => Osint.Current_Source_File_Stamp);
528
529 Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
530 S.Lines_Table (1) := Lo;
531 end;
532
533 -- Preprocess the source if it needs to be preprocessed
534
535 if Preprocessing_Needed then
536
537 -- Temporarily set the Source_File_Index_Table entries for the
538 -- source, to avoid crash when reporting an error.
539
540 Set_Source_File_Index_Table (X);
541
542 if Opt.List_Preprocessing_Symbols then
543 Get_Name_String (N);
544
545 declare
546 Foreword : String (1 .. Foreword_Start'Length +
547 Name_Len + Foreword_End'Length);
548
549 begin
550 Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
551 Foreword (Foreword_Start'Length + 1 ..
552 Foreword_Start'Length + Name_Len) :=
553 Name_Buffer (1 .. Name_Len);
554 Foreword (Foreword'Last - Foreword_End'Length + 1 ..
555 Foreword'Last) := Foreword_End;
556 Prep.List_Symbols (Foreword);
557 end;
558 end if;
559
560 declare
561 T : constant Nat := Total_Errors_Detected;
562 -- Used to check if there were errors during preprocessing
563
564 Save_Style_Check : Boolean;
565 -- Saved state of the Style_Check flag (which needs to be
566 -- temporarily set to False during preprocessing, see below).
567
568 Modified : Boolean;
569
570 begin
571 -- If this is the first time we preprocess a source, allocate
572 -- the preprocessing buffer.
573
574 if Prep_Buffer = null then
575 Prep_Buffer :=
576 new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
577 end if;
578
579 -- Make sure the preprocessing buffer is empty
580
581 Prep_Buffer_Last := 0;
582
583 -- Initialize the preprocessor hooks
584
585 Prep.Setup_Hooks
586 (Error_Msg => Errout.Error_Msg'Access,
587 Scan => Scn.Scanner.Scan'Access,
588 Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
589 Put_Char => Put_Char_In_Prep_Buffer'Access,
590 New_EOL => New_EOL_In_Prep_Buffer'Access);
591
592 -- Initialize scanner and set its behavior for preprocessing,
593 -- then preprocess. Also disable style checks, since some of
594 -- them are done in the scanner (specifically, those dealing
595 -- with line length and line termination), and cannot be done
596 -- during preprocessing (because the source file index table
597 -- has not been set yet).
598
599 Scn.Scanner.Initialize_Scanner (X);
600
601 Scn.Scanner.Set_Special_Character ('#');
602 Scn.Scanner.Set_Special_Character ('$');
603 Scn.Scanner.Set_End_Of_Line_As_Token (True);
604 Save_Style_Check := Opt.Style_Check;
605 Opt.Style_Check := False;
606
607 -- The actual preprocessing step
608
609 Preprocess (Modified);
610
611 -- Reset the scanner to its standard behavior, and restore the
612 -- Style_Checks flag.
613
614 Scn.Scanner.Reset_Special_Characters;
615 Scn.Scanner.Set_End_Of_Line_As_Token (False);
616 Opt.Style_Check := Save_Style_Check;
617
618 -- If there were errors during preprocessing, record an error
619 -- at the start of the file, and do not change the source
620 -- buffer.
621
622 if T /= Total_Errors_Detected then
623 Errout.Error_Msg
624 ("file could not be successfully preprocessed", Lo);
625 return No_Source_File;
626
627 else
628 -- Output the result of the preprocessing, if requested and
629 -- the source has been modified by the preprocessing. Only
630 -- do that for the main unit (spec, body and subunits).
631
632 if Generate_Processed_File
633 and then Modified
634 and then
635 ((Compiler_State = Parsing
636 and then Parsing_Main_Extended_Source)
637 or else
638 (Compiler_State = Analyzing
639 and then Analysing_Subunit_Of_Main))
640 then
641 declare
642 FD : File_Descriptor;
643 NB : Integer;
644 Status : Boolean;
645
646 begin
647 Get_Name_String (N);
648 Add_Str_To_Name_Buffer (Prep_Suffix);
649
650 Delete_File (Name_Buffer (1 .. Name_Len), Status);
651
652 FD :=
653 Create_New_File (Name_Buffer (1 .. Name_Len), Text);
654
655 Status := FD /= Invalid_FD;
656
657 if Status then
658 NB :=
659 Write
660 (FD,
661 Prep_Buffer (1)'Address,
662 Integer (Prep_Buffer_Last));
663 Status := NB = Integer (Prep_Buffer_Last);
664 end if;
665
666 if Status then
667 Close (FD, Status);
668 end if;
669
670 if not Status then
671 Errout.Error_Msg
672 ("??could not write processed file """ &
673 Name_Buffer (1 .. Name_Len) & '"',
674 Lo);
675 end if;
676 end;
677 end if;
678
679 -- Set the new value of Hi
680
681 Hi := Lo + Source_Ptr (Prep_Buffer_Last);
682
683 -- Create the new source buffer
684
685 declare
686 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
687 -- Physical buffer allocated
688
689 type Actual_Source_Ptr is access Actual_Source_Buffer;
690 -- Pointer type for the physical buffer allocated
691
692 Actual_Ptr : constant Actual_Source_Ptr :=
693 new Actual_Source_Buffer;
694 -- Actual physical buffer
695
696 begin
697 Actual_Ptr (Lo .. Hi - 1) :=
698 Prep_Buffer (1 .. Prep_Buffer_Last);
699 Actual_Ptr (Hi) := EOF;
700
701 -- Now we need to work out the proper virtual origin
702 -- pointer to return. This is Actual_Ptr (0)'Address, but
703 -- we have to be careful to suppress checks to compute
704 -- this address.
705
706 declare
707 pragma Suppress (All_Checks);
708
709 pragma Warnings (Off);
710 -- This unchecked conversion is aliasing safe, since
711 -- it is never used to create improperly aliased
712 -- pointer values.
713
714 function To_Source_Buffer_Ptr is new
715 Unchecked_Conversion (Address, Source_Buffer_Ptr);
716
717 pragma Warnings (On);
718
719 begin
720 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
721
722 -- Record in the table the new source buffer and the
723 -- new value of Hi.
724
725 Source_File.Table (X).Source_Text := Src;
726 Source_File.Table (X).Source_Last := Hi;
727
728 -- Reset Last_Line to 1, because the lines do not
729 -- have necessarily the same starts and lengths.
730
731 Source_File.Table (X).Last_Source_Line := 1;
732 end;
733 end;
734 end if;
735 end;
736 end if;
737
738 Set_Source_File_Index_Table (X);
739 return X;
740 end if;
741 end Load_File;
742
743 ----------------------------------
744 -- Load_Preprocessing_Data_File --
745 ----------------------------------
746
747 function Load_Preprocessing_Data_File
748 (N : File_Name_Type) return Source_File_Index
749 is
750 begin
751 return Load_File (N, Osint.Preprocessing_Data);
752 end Load_Preprocessing_Data_File;
753
754 ----------------------
755 -- Load_Source_File --
756 ----------------------
757
758 function Load_Source_File
759 (N : File_Name_Type) return Source_File_Index
760 is
761 begin
762 return Load_File (N, Osint.Source);
763 end Load_Source_File;
764
765 ----------------------------
766 -- New_EOL_In_Prep_Buffer --
767 ----------------------------
768
769 procedure New_EOL_In_Prep_Buffer is
770 begin
771 Put_Char_In_Prep_Buffer (ASCII.LF);
772 end New_EOL_In_Prep_Buffer;
773
774 -----------------------------
775 -- Put_Char_In_Prep_Buffer --
776 -----------------------------
777
778 procedure Put_Char_In_Prep_Buffer (C : Character) is
779 begin
780 -- If preprocessing buffer is not large enough, double it
781
782 if Prep_Buffer_Last = Prep_Buffer'Last then
783 declare
784 New_Prep_Buffer : constant Text_Buffer_Ptr :=
785 new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
786
787 begin
788 New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
789 Free (Prep_Buffer);
790 Prep_Buffer := New_Prep_Buffer;
791 end;
792 end if;
793
794 Prep_Buffer_Last := Prep_Buffer_Last + 1;
795 Prep_Buffer (Prep_Buffer_Last) := C;
796 end Put_Char_In_Prep_Buffer;
797
798 -------------------------
799 -- Source_File_Is_Body --
800 -------------------------
801
802 function Source_File_Is_Body (X : Source_File_Index) return Boolean is
803 Pcount : Natural;
804
805 begin
806 Initialize_Scanner (No_Unit, X);
807
808 -- Loop to look for subprogram or package body
809
810 loop
811 case Token is
812
813 -- PRAGMA, WITH, USE (which can appear before a body)
814
815 when Tok_Pragma | Tok_With | Tok_Use =>
816
817 -- We just want to skip any of these, do it by skipping to a
818 -- semicolon, but check for EOF, in case we have bad syntax.
819
820 loop
821 if Token = Tok_Semicolon then
822 Scan;
823 exit;
824 elsif Token = Tok_EOF then
825 return False;
826 else
827 Scan;
828 end if;
829 end loop;
830
831 -- PACKAGE
832
833 when Tok_Package =>
834 Scan; -- Past PACKAGE
835
836 -- We have a body if and only if BODY follows
837
838 return Token = Tok_Body;
839
840 -- FUNCTION or PROCEDURE
841
842 when Tok_Procedure | Tok_Function =>
843 Pcount := 0;
844
845 -- Loop through tokens following PROCEDURE or FUNCTION
846
847 loop
848 Scan;
849
850 case Token is
851
852 -- For parens, count paren level (note that paren level
853 -- can get greater than 1 if we have default parameters).
854
855 when Tok_Left_Paren =>
856 Pcount := Pcount + 1;
857
858 when Tok_Right_Paren =>
859 Pcount := Pcount - 1;
860
861 -- EOF means something weird, probably no body
862
863 when Tok_EOF =>
864 return False;
865
866 -- BEGIN or IS or END definitely means body is present
867
868 when Tok_Begin | Tok_Is | Tok_End =>
869 return True;
870
871 -- Semicolon means no body present if at outside any
872 -- parens. If within parens, ignore, since it could be
873 -- a parameter separator.
874
875 when Tok_Semicolon =>
876 if Pcount = 0 then
877 return False;
878 end if;
879
880 -- Skip anything else
881
882 when others =>
883 null;
884 end case;
885 end loop;
886
887 -- Anything else in main scan means we don't have a body
888
889 when others =>
890 return False;
891 end case;
892 end loop;
893 end Source_File_Is_Body;
894
895 ----------------------------
896 -- Source_File_Is_No_Body --
897 ----------------------------
898
899 function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
900 begin
901 Initialize_Scanner (No_Unit, X);
902
903 if Token /= Tok_Pragma then
904 return False;
905 end if;
906
907 Scan; -- past pragma
908
909 if Token /= Tok_Identifier
910 or else Chars (Token_Node) /= Name_No_Body
911 then
912 return False;
913 end if;
914
915 Scan; -- past No_Body
916
917 if Token /= Tok_Semicolon then
918 return False;
919 end if;
920
921 Scan; -- past semicolon
922
923 return Token = Tok_EOF;
924 end Source_File_Is_No_Body;
925
926 end Sinput.L;
Mirror of the offical gcc git repository hosted at gcc.gnu.org