1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                  S C N                                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2003 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,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, 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
27with Atree;    use Atree;
28with Csets;    use Csets;
29with Hostparm;
30with Namet;    use Namet;
31with Opt;      use Opt;
32with Scans;    use Scans;
33with Sinfo;    use Sinfo;
34with Sinput;   use Sinput;
35
36package body Scn is
37
38   use ASCII;
39
40   Used_As_Identifier : array (Token_Type) of Boolean;
41   --  Flags set True if a given keyword is used as an identifier (used to
42   --  make sure that we only post an error message for incorrect use of a
43   --  keyword as an identifier once for a given keyword).
44
45   procedure Check_End_Of_Line;
46   --  Called when end of line encountered. Checks that line is not
47   --  too long, and that other style checks for the end of line are met.
48
49   function Determine_License return License_Type;
50   --  Scan header of file and check that it has an appropriate GNAT-style
51   --  header with a proper license statement. Returns GPL, Unrestricted,
52   --  or Modified_GPL depending on header. If none of these, returns Unknown.
53
54   procedure Error_Long_Line;
55   --  Signal error of excessively long line
56
57   ---------------
58   -- Post_Scan --
59   ---------------
60
61   procedure Post_Scan is
62   begin
63      case Token is
64         when Tok_Char_Literal =>
65            Token_Node := New_Node (N_Character_Literal, Token_Ptr);
66            Set_Char_Literal_Value (Token_Node, Character_Code);
67            Set_Chars (Token_Node, Token_Name);
68
69         when Tok_Identifier =>
70            Token_Node := New_Node (N_Identifier, Token_Ptr);
71            Set_Chars (Token_Node, Token_Name);
72
73         when Tok_Real_Literal =>
74            Token_Node := New_Node (N_Real_Literal, Token_Ptr);
75            Set_Realval (Token_Node, Real_Literal_Value);
76
77         when Tok_Integer_Literal =>
78            Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
79            Set_Intval (Token_Node, Int_Literal_Value);
80
81         when Tok_String_Literal =>
82            Token_Node := New_Node (N_String_Literal, Token_Ptr);
83            Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
84            Set_Strval (Token_Node, String_Literal_Id);
85
86         when Tok_Operator_Symbol =>
87            Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
88            Set_Chars (Token_Node, Token_Name);
89            Set_Strval (Token_Node, String_Literal_Id);
90
91         when others =>
92            null;
93      end case;
94   end Post_Scan;
95
96   -----------------------
97   -- Check_End_Of_Line --
98   -----------------------
99
100   procedure Check_End_Of_Line is
101      Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
102
103   begin
104      if Len > Hostparm.Max_Line_Length then
105         Error_Long_Line;
106
107      elsif Style_Check then
108         Style.Check_Line_Terminator (Len);
109      end if;
110   end Check_End_Of_Line;
111
112   -----------------------
113   -- Determine_License --
114   -----------------------
115
116   function Determine_License return License_Type is
117      GPL_Found : Boolean := False;
118
119      function Contains (S : String) return Boolean;
120      --  See if current comment contains successive non-blank characters
121      --  matching the contents of S. If so leave Scan_Ptr unchanged and
122      --  return True, otherwise leave Scan_Ptr unchanged and return False.
123
124      procedure Skip_EOL;
125      --  Skip to line terminator character
126
127      --------------
128      -- Contains --
129      --------------
130
131      function Contains (S : String) return Boolean is
132         CP : Natural;
133         SP : Source_Ptr;
134         SS : Source_Ptr;
135
136      begin
137         SP := Scan_Ptr;
138         while Source (SP) /= CR and then Source (SP) /= LF loop
139            if Source (SP) = S (S'First) then
140               SS := SP;
141               CP := S'First;
142
143               loop
144                  SS := SS + 1;
145                  CP := CP + 1;
146
147                  if CP > S'Last then
148                     return True;
149                  end if;
150
151                  while Source (SS) = ' ' loop
152                     SS := SS + 1;
153                  end loop;
154
155                  exit when Source (SS) /= S (CP);
156               end loop;
157            end if;
158
159            SP := SP + 1;
160         end loop;
161
162         return False;
163      end Contains;
164
165      --------------
166      -- Skip_EOL --
167      --------------
168
169      procedure Skip_EOL is
170      begin
171         while Source (Scan_Ptr) /= CR
172           and then Source (Scan_Ptr) /= LF
173         loop
174            Scan_Ptr := Scan_Ptr + 1;
175         end loop;
176      end Skip_EOL;
177
178   --  Start of processing for Determine_License
179
180   begin
181      loop
182         if Source (Scan_Ptr) /= '-'
183           or else Source (Scan_Ptr + 1) /= '-'
184         then
185            if GPL_Found then
186               return GPL;
187            else
188               return Unknown;
189            end if;
190
191         elsif Contains ("Asaspecialexception") then
192            if GPL_Found then
193               return Modified_GPL;
194            end if;
195
196         elsif Contains ("GNUGeneralPublicLicense") then
197            GPL_Found := True;
198
199         elsif
200             Contains
201               ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
202           or else
203             Contains
204              ("ThisspecificationisderivedfromtheAdaReferenceManual")
205         then
206            return Unrestricted;
207         end if;
208
209         Skip_EOL;
210
211         Check_End_Of_Line;
212
213         declare
214            Physical : Boolean;
215
216         begin
217            Skip_Line_Terminators (Scan_Ptr, Physical);
218
219            --  If we are at start of physical line, update scan pointers
220            --  to reflect the start of the new line.
221
222            if Physical then
223               Current_Line_Start       := Scan_Ptr;
224               Start_Column             := Scanner.Set_Start_Column;
225               First_Non_Blank_Location := Scan_Ptr;
226            end if;
227         end;
228      end loop;
229   end Determine_License;
230
231   ----------------------------
232   -- Determine_Token_Casing --
233   ----------------------------
234
235   function Determine_Token_Casing return Casing_Type is
236   begin
237      return Scanner.Determine_Token_Casing;
238   end Determine_Token_Casing;
239
240   ---------------------
241   -- Error_Long_Line --
242   ---------------------
243
244   procedure Error_Long_Line is
245   begin
246      Error_Msg
247        ("this line is too long",
248         Current_Line_Start + Hostparm.Max_Line_Length);
249   end Error_Long_Line;
250
251   ------------------------
252   -- Initialize_Scanner --
253   ------------------------
254
255   procedure Initialize_Scanner
256     (Unit  : Unit_Number_Type;
257      Index : Source_File_Index)
258   is
259      GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
260
261   begin
262      Scanner.Initialize_Scanner (Unit, Index);
263
264      --  Set default for Comes_From_Source (except if we are going to process
265      --  an artificial string internally created within the compiler and
266      --  placed into internal source duffer). All nodes built now until we
267      --  reenter the analyzer will have Comes_From_Source set to True
268
269      if Index /= Internal_Source_File then
270         Set_Comes_From_Source_Default (True);
271      end if;
272
273      --  Check license if GNAT type header possibly present
274
275      if Source_Last (Index) - Scan_Ptr > 80
276        and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
277      then
278         Set_License (Current_Source_File, Determine_License);
279      end if;
280
281      --  Because of the License stuff above, Scng.Initialize_Scanner cannot
282      --  call Scan. Scan initial token (note this initializes Prev_Token,
283      --  Prev_Token_Ptr).
284
285      --  There are two reasons not to do the Scan step in case if we
286      --  initialize the scanner for the internal source buffer:
287
288      --  - The artificial string may not be created by the compiler in this
289      --    buffer when we call Initialize_Scanner
290
291      --  - For these artificial strings a special way of scanning is used, so
292      --    the standard step of the scanner may just break the algorithm of
293      --    processing these strings.
294
295      if Index /= Internal_Source_File then
296         Scan;
297      end if;
298
299      --  Clear flags for reserved words used as indentifiers
300
301      for J in Token_Type loop
302         Used_As_Identifier (J) := False;
303      end loop;
304   end Initialize_Scanner;
305
306   ------------------------------
307   -- Scan_Reserved_Identifier --
308   ------------------------------
309
310   procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
311      Token_Chars : constant String := Token_Type'Image (Token);
312
313   begin
314      --  We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
315      --  This code extracts the xxx and makes an identifier out of it.
316
317      Name_Len := 0;
318
319      for J in 5 .. Token_Chars'Length loop
320         Name_Len := Name_Len + 1;
321         Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J));
322      end loop;
323
324      Token_Name := Name_Find;
325
326      if not Used_As_Identifier (Token) or else Force_Msg then
327         Error_Msg_Name_1 := Token_Name;
328         Error_Msg_SC ("reserved word* cannot be used as identifier!");
329         Used_As_Identifier (Token) := True;
330      end if;
331
332      Token := Tok_Identifier;
333      Token_Node := New_Node (N_Identifier, Token_Ptr);
334      Set_Chars (Token_Node, Token_Name);
335   end Scan_Reserved_Identifier;
336
337end Scn;
338