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