OSDN Git Service

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