Merged with mainline at revision 128810.
[official-gcc.git] / gcc / ada / sinput-l.adb
blob7064660c98ca4934fbeb16178ac69f2ee2169d16
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-2007, 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 ------------------------------------------------------------------------------
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 Opt; use Opt;
32 with Osint; use Osint;
33 with Output; use Output;
34 with Prep; use Prep;
35 with Prepcomp; use Prepcomp;
36 with Scans; use Scans;
37 with Scn; use Scn;
38 with Sinfo; use Sinfo;
39 with Snames; use Snames;
40 with System; use System;
42 with Unchecked_Conversion;
44 package body Sinput.L is
46 Prep_Buffer : Text_Buffer_Ptr := null;
47 -- A buffer to temporarily stored the result of preprocessing a source.
48 -- It is only allocated if there is at least one source to preprocess.
50 Prep_Buffer_Last : Text_Ptr := 0;
51 -- Index of the last significant character in Prep_Buffer
53 Initial_Size_Of_Prep_Buffer : constant := 10_000;
54 -- Size of Prep_Buffer when it is first allocated
56 -- When a file is to be preprocessed and the options to list symbols
57 -- has been selected (switch -s), Prep.List_Symbols is called with a
58 -- "foreword", a single line indicationg what source the symbols apply to.
59 -- The following two constant String are the start and the end of this
60 -- foreword.
62 Foreword_Start : constant String :=
63 "Preprocessing Symbols for source """;
65 Foreword_End : constant String := """";
67 -----------------
68 -- Subprograms --
69 -----------------
71 procedure Put_Char_In_Prep_Buffer (C : Character);
72 -- Add one character in Prep_Buffer, extending Prep_Buffer if need be.
73 -- Used to initialize the preprocessor.
75 procedure New_EOL_In_Prep_Buffer;
76 -- Add an LF to Prep_Buffer.
77 -- Used to initialize the preprocessor.
79 function Load_File
80 (N : File_Name_Type;
81 T : Osint.File_Type) return Source_File_Index;
82 -- Load a source file, a configuration pragmas file or a definition file
83 -- Coding also allows preprocessing file, but not a library file ???
85 -------------------------------
86 -- Adjust_Instantiation_Sloc --
87 -------------------------------
89 procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
90 Loc : constant Source_Ptr := Sloc (N);
92 begin
93 -- We only do the adjustment if the value is between the appropriate
94 -- low and high values. It is not clear that this should ever not be
95 -- the case, but in practice there seem to be some nodes that get
96 -- copied twice, and this is a defence against that happening.
98 if A.Lo <= Loc and then Loc <= A.Hi then
99 Set_Sloc (N, Loc + A.Adjust);
100 end if;
101 end Adjust_Instantiation_Sloc;
103 --------------------------------
104 -- Complete_Source_File_Entry --
105 --------------------------------
107 procedure Complete_Source_File_Entry is
108 CSF : constant Source_File_Index := Current_Source_File;
110 begin
111 Trim_Lines_Table (CSF);
112 Source_File.Table (CSF).Source_Checksum := Checksum;
113 end Complete_Source_File_Entry;
115 ---------------------------------
116 -- Create_Instantiation_Source --
117 ---------------------------------
119 procedure Create_Instantiation_Source
120 (Inst_Node : Entity_Id;
121 Template_Id : Entity_Id;
122 Inlined_Body : Boolean;
123 A : out Sloc_Adjustment)
125 Dnod : constant Node_Id := Declaration_Node (Template_Id);
126 Xold : Source_File_Index;
127 Xnew : Source_File_Index;
129 begin
130 Xold := Get_Source_File_Index (Sloc (Template_Id));
131 A.Lo := Source_File.Table (Xold).Source_First;
132 A.Hi := Source_File.Table (Xold).Source_Last;
134 Source_File.Append (Source_File.Table (Xold));
135 Xnew := Source_File.Last;
137 Source_File.Table (Xnew).Inlined_Body := Inlined_Body;
138 Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
139 Source_File.Table (Xnew).Template := Xold;
141 -- Now we need to compute the new values of Source_First, Source_Last
142 -- and adjust the source file pointer to have the correct virtual
143 -- origin for the new range of values.
145 Source_File.Table (Xnew).Source_First :=
146 Source_File.Table (Xnew - 1).Source_Last + 1;
147 A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
148 Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
150 Set_Source_File_Index_Table (Xnew);
152 Source_File.Table (Xnew).Sloc_Adjust :=
153 Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
155 if Debug_Flag_L then
156 Write_Eol;
157 Write_Str ("*** Create instantiation source for ");
159 if Nkind (Dnod) in N_Proper_Body
160 and then Was_Originally_Stub (Dnod)
161 then
162 Write_Str ("subunit ");
164 elsif Ekind (Template_Id) = E_Generic_Package then
165 if Nkind (Dnod) = N_Package_Body then
166 Write_Str ("body of package ");
167 else
168 Write_Str ("spec of package ");
169 end if;
171 elsif Ekind (Template_Id) = E_Function then
172 Write_Str ("body of function ");
174 elsif Ekind (Template_Id) = E_Procedure then
175 Write_Str ("body of procedure ");
177 elsif Ekind (Template_Id) = E_Generic_Function then
178 Write_Str ("spec of function ");
180 elsif Ekind (Template_Id) = E_Generic_Procedure then
181 Write_Str ("spec of procedure ");
183 elsif Ekind (Template_Id) = E_Package_Body then
184 Write_Str ("body of package ");
186 else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
188 if Nkind (Dnod) = N_Procedure_Specification then
189 Write_Str ("body of procedure ");
190 else
191 Write_Str ("body of function ");
192 end if;
193 end if;
195 Write_Name (Chars (Template_Id));
196 Write_Eol;
198 Write_Str (" new source index = ");
199 Write_Int (Int (Xnew));
200 Write_Eol;
202 Write_Str (" copying from file name = ");
203 Write_Name (File_Name (Xold));
204 Write_Eol;
206 Write_Str (" old source index = ");
207 Write_Int (Int (Xold));
208 Write_Eol;
210 Write_Str (" old lo = ");
211 Write_Int (Int (A.Lo));
212 Write_Eol;
214 Write_Str (" old hi = ");
215 Write_Int (Int (A.Hi));
216 Write_Eol;
218 Write_Str (" new lo = ");
219 Write_Int (Int (Source_File.Table (Xnew).Source_First));
220 Write_Eol;
222 Write_Str (" new hi = ");
223 Write_Int (Int (Source_File.Table (Xnew).Source_Last));
224 Write_Eol;
226 Write_Str (" adjustment factor = ");
227 Write_Int (Int (A.Adjust));
228 Write_Eol;
230 Write_Str (" instantiation location: ");
231 Write_Location (Sloc (Inst_Node));
232 Write_Eol;
233 end if;
235 -- For a given character in the source, a higher subscript will be
236 -- used to access the instantiation, which means that the virtual
237 -- origin must have a corresponding lower value. We compute this
238 -- new origin by taking the address of the appropriate adjusted
239 -- element in the old array. Since this adjusted element will be
240 -- at a negative subscript, we must suppress checks.
242 declare
243 pragma Suppress (All_Checks);
245 pragma Warnings (Off);
246 -- This unchecked conversion is aliasing safe, since it is never
247 -- used to create improperly aliased pointer values.
249 function To_Source_Buffer_Ptr is new
250 Unchecked_Conversion (Address, Source_Buffer_Ptr);
252 pragma Warnings (On);
254 begin
255 Source_File.Table (Xnew).Source_Text :=
256 To_Source_Buffer_Ptr
257 (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
258 end;
259 end Create_Instantiation_Source;
261 ----------------------
262 -- Load_Config_File --
263 ----------------------
265 function Load_Config_File
266 (N : File_Name_Type) return Source_File_Index
268 begin
269 return Load_File (N, Osint.Config);
270 end Load_Config_File;
272 --------------------------
273 -- Load_Definition_File --
274 --------------------------
276 function Load_Definition_File
277 (N : File_Name_Type) return Source_File_Index
279 begin
280 return Load_File (N, Osint.Definition);
281 end Load_Definition_File;
283 ---------------
284 -- Load_File --
285 ---------------
287 function Load_File
288 (N : File_Name_Type;
289 T : Osint.File_Type) return Source_File_Index
291 Src : Source_Buffer_Ptr;
292 X : Source_File_Index;
293 Lo : Source_Ptr;
294 Hi : Source_Ptr;
296 Preprocessing_Needed : Boolean := False;
298 begin
299 -- If already there, don't need to reload file. An exception occurs
300 -- in multiple unit per file mode. It would be nice in this case to
301 -- share the same source file for each unit, but this leads to many
302 -- difficulties with assumptions (e.g. in the body of lib), that a
303 -- unit can be found by locating its source file index. Since we do
304 -- not expect much use of this mode, it's no big deal to waste a bit
305 -- of space and time by reading and storing the source multiple times.
307 if Multiple_Unit_Index = 0 then
308 for J in 1 .. Source_File.Last loop
309 if Source_File.Table (J).File_Name = N then
310 return J;
311 end if;
312 end loop;
313 end if;
315 -- Here we must build a new entry in the file table
317 -- But first, we must check if a source needs to be preprocessed,
318 -- because we may have to load and parse a definition file, and we want
319 -- to do that before we load the source, so that the buffer of the
320 -- source will be the last created, and we will be able to replace it
321 -- and modify Hi without stepping on another buffer.
323 if T = Osint.Source then
324 Prepare_To_Preprocess
325 (Source => N, Preprocessing_Needed => Preprocessing_Needed);
326 end if;
328 Source_File.Increment_Last;
329 X := Source_File.Last;
331 if X = Source_File.First then
332 Lo := First_Source_Ptr;
333 else
334 Lo := Source_File.Table (X - 1).Source_Last + 1;
335 end if;
337 Osint.Read_Source_File (N, Lo, Hi, Src, T);
339 if Src = null then
340 Source_File.Decrement_Last;
341 return No_Source_File;
343 else
344 if Debug_Flag_L then
345 Write_Eol;
346 Write_Str ("*** Build source file table entry, Index = ");
347 Write_Int (Int (X));
348 Write_Str (", file name = ");
349 Write_Name (N);
350 Write_Eol;
351 Write_Str (" lo = ");
352 Write_Int (Int (Lo));
353 Write_Eol;
354 Write_Str (" hi = ");
355 Write_Int (Int (Hi));
356 Write_Eol;
358 Write_Str (" first 10 chars -->");
360 declare
361 procedure Wchar (C : Character);
362 -- Writes character or ? for control character
364 procedure Wchar (C : Character) is
365 begin
366 if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
367 Write_Char ('?');
368 else
369 Write_Char (C);
370 end if;
371 end Wchar;
373 begin
374 for J in Lo .. Lo + 9 loop
375 Wchar (Src (J));
376 end loop;
378 Write_Str ("<--");
379 Write_Eol;
381 Write_Str (" last 10 chars -->");
383 for J in Hi - 10 .. Hi - 1 loop
384 Wchar (Src (J));
385 end loop;
387 Write_Str ("<--");
388 Write_Eol;
390 if Src (Hi) /= EOF then
391 Write_Str (" error: no EOF at end");
392 Write_Eol;
393 end if;
394 end;
395 end if;
397 declare
398 S : Source_File_Record renames Source_File.Table (X);
399 File_Type : Type_Of_File;
401 begin
402 case T is
403 when Osint.Source =>
404 File_Type := Sinput.Src;
406 when Osint.Library =>
407 raise Program_Error;
409 when Osint.Config =>
410 File_Type := Sinput.Config;
412 when Osint.Definition =>
413 File_Type := Def;
415 when Osint.Preprocessing_Data =>
416 File_Type := Preproc;
417 end case;
419 S := (Debug_Source_Name => N,
420 File_Name => N,
421 File_Type => File_Type,
422 First_Mapped_Line => No_Line_Number,
423 Full_Debug_Name => Osint.Full_Source_Name,
424 Full_File_Name => Osint.Full_Source_Name,
425 Full_Ref_Name => Osint.Full_Source_Name,
426 Identifier_Casing => Unknown,
427 Inlined_Body => False,
428 Instantiation => No_Location,
429 Keyword_Casing => Unknown,
430 Last_Source_Line => 1,
431 License => Unknown,
432 Lines_Table => null,
433 Lines_Table_Max => 1,
434 Logical_Lines_Table => null,
435 Num_SRef_Pragmas => 0,
436 Reference_Name => N,
437 Sloc_Adjust => 0,
438 Source_Checksum => 0,
439 Source_First => Lo,
440 Source_Last => Hi,
441 Source_Text => Src,
442 Template => No_Source_File,
443 Unit => No_Unit,
444 Time_Stamp => Osint.Current_Source_File_Stamp);
446 Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
447 S.Lines_Table (1) := Lo;
448 end;
450 -- Preprocess the source if it needs to be preprocessed
452 if Preprocessing_Needed then
453 if Opt.List_Preprocessing_Symbols then
454 Get_Name_String (N);
456 declare
457 Foreword : String (1 .. Foreword_Start'Length +
458 Name_Len + Foreword_End'Length);
460 begin
461 Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
462 Foreword (Foreword_Start'Length + 1 ..
463 Foreword_Start'Length + Name_Len) :=
464 Name_Buffer (1 .. Name_Len);
465 Foreword (Foreword'Last - Foreword_End'Length + 1 ..
466 Foreword'Last) := Foreword_End;
467 Prep.List_Symbols (Foreword);
468 end;
469 end if;
471 declare
472 T : constant Nat := Total_Errors_Detected;
473 -- Used to check if there were errors during preprocessing
475 begin
476 -- If this is the first time we preprocess a source, allocate
477 -- the preprocessing buffer.
479 if Prep_Buffer = null then
480 Prep_Buffer :=
481 new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
482 end if;
484 -- Make sure the preprocessing buffer is empty
486 Prep_Buffer_Last := 0;
488 -- Initialize the preprocessor
490 Prep.Initialize
491 (Error_Msg => Errout.Error_Msg'Access,
492 Scan => Scn.Scanner.Scan'Access,
493 Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
494 Put_Char => Put_Char_In_Prep_Buffer'Access,
495 New_EOL => New_EOL_In_Prep_Buffer'Access);
497 -- Initialize the scanner and set its behavior for
498 -- preprocessing, then preprocess.
500 Scn.Scanner.Initialize_Scanner (X);
502 Scn.Scanner.Set_Special_Character ('#');
503 Scn.Scanner.Set_Special_Character ('$');
504 Scn.Scanner.Set_End_Of_Line_As_Token (True);
506 Preprocess;
508 -- Reset the scanner to its standard behavior
510 Scn.Scanner.Reset_Special_Characters;
511 Scn.Scanner.Set_End_Of_Line_As_Token (False);
513 -- If there were errors during preprocessing, record an
514 -- error at the start of the file, and do not change the
515 -- source buffer.
517 if T /= Total_Errors_Detected then
518 Errout.Error_Msg
519 ("file could not be successfully preprocessed", Lo);
520 return No_Source_File;
522 else
523 -- Set the new value of Hi
525 Hi := Lo + Source_Ptr (Prep_Buffer_Last);
527 -- Create the new source buffer
529 declare
530 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
531 -- Physical buffer allocated
533 type Actual_Source_Ptr is access Actual_Source_Buffer;
534 -- This is the pointer type for the physical buffer
535 -- allocated.
537 Actual_Ptr : constant Actual_Source_Ptr :=
538 new Actual_Source_Buffer;
539 -- And this is the actual physical buffer
541 begin
542 Actual_Ptr (Lo .. Hi - 1) :=
543 Prep_Buffer (1 .. Prep_Buffer_Last);
544 Actual_Ptr (Hi) := EOF;
546 -- Now we need to work out the proper virtual origin
547 -- pointer to return. This is exactly
548 -- Actual_Ptr (0)'Address, but we have to be careful to
549 -- suppress checks to compute this address.
551 declare
552 pragma Suppress (All_Checks);
554 pragma Warnings (Off);
555 -- This unchecked conversion is aliasing safe, since
556 -- it is never used to create improperly aliased
557 -- pointer values.
559 function To_Source_Buffer_Ptr is new
560 Unchecked_Conversion (Address, Source_Buffer_Ptr);
562 pragma Warnings (On);
564 begin
565 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
567 -- Record in the table the new source buffer and the
568 -- new value of Hi.
570 Source_File.Table (X).Source_Text := Src;
571 Source_File.Table (X).Source_Last := Hi;
573 -- Reset Last_Line to 1, because the lines do not
574 -- have neccessarily the same starts and lengths.
576 Source_File.Table (X).Last_Source_Line := 1;
577 end;
578 end;
579 end if;
580 end;
581 end if;
583 Set_Source_File_Index_Table (X);
584 return X;
585 end if;
586 end Load_File;
588 ----------------------------------
589 -- Load_Preprocessing_Data_File --
590 ----------------------------------
592 function Load_Preprocessing_Data_File
593 (N : File_Name_Type) return Source_File_Index
595 begin
596 return Load_File (N, Osint.Preprocessing_Data);
597 end Load_Preprocessing_Data_File;
599 ----------------------
600 -- Load_Source_File --
601 ----------------------
603 function Load_Source_File
604 (N : File_Name_Type) return Source_File_Index
606 begin
607 return Load_File (N, Osint.Source);
608 end Load_Source_File;
610 ----------------------------
611 -- New_EOL_In_Prep_Buffer --
612 ----------------------------
614 procedure New_EOL_In_Prep_Buffer is
615 begin
616 Put_Char_In_Prep_Buffer (ASCII.LF);
617 end New_EOL_In_Prep_Buffer;
619 -----------------------------
620 -- Put_Char_In_Prep_Buffer --
621 -----------------------------
623 procedure Put_Char_In_Prep_Buffer (C : Character) is
624 begin
625 -- If preprocessing buffer is not large enough, double it
627 if Prep_Buffer_Last = Prep_Buffer'Last then
628 declare
629 New_Prep_Buffer : constant Text_Buffer_Ptr :=
630 new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
632 begin
633 New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
634 Free (Prep_Buffer);
635 Prep_Buffer := New_Prep_Buffer;
636 end;
637 end if;
639 Prep_Buffer_Last := Prep_Buffer_Last + 1;
640 Prep_Buffer (Prep_Buffer_Last) := C;
641 end Put_Char_In_Prep_Buffer;
643 -----------------------------------
644 -- Source_File_Is_Pragma_No_Body --
645 -----------------------------------
647 function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
648 begin
649 Initialize_Scanner (No_Unit, X);
651 if Token /= Tok_Pragma then
652 return False;
653 end if;
655 Scan; -- past pragma
657 if Token /= Tok_Identifier
658 or else Chars (Token_Node) /= Name_No_Body
659 then
660 return False;
661 end if;
663 Scan; -- past No_Body
665 if Token /= Tok_Semicolon then
666 return False;
667 end if;
669 Scan; -- past semicolon
671 return Token = Tok_EOF;
672 end Source_File_Is_No_Body;
674 ----------------------------
675 -- Source_File_Is_Subunit --
676 ----------------------------
678 function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
679 begin
680 Initialize_Scanner (No_Unit, X);
682 -- We scan past junk to the first interesting compilation unit
683 -- token, to see if it is SEPARATE. We ignore WITH keywords during
684 -- this and also PRIVATE. The reason for ignoring PRIVATE is that
685 -- it handles some error situations, and also to handle PRIVATE WITH
686 -- in Ada 2005 mode.
688 while Token = Tok_With
689 or else Token = Tok_Private
690 or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
691 loop
692 Scan;
693 end loop;
695 return Token = Tok_Separate;
696 end Source_File_Is_Subunit;
698 end Sinput.L;