← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/adacontrol/jaunty

« back to all changes in this revision

Viewing changes to src/framework-language.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-10-12 19:17:22 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061012191722-fo5bcn4k5r0iubgd
Tags: 1.5r24-1

* New upstream release.
* debian/control (Depends): add gnat-4.1.
  (Enhances): add gnat-gps.
* debian/adacontrol.gpr: build pfni.
* debian/rules: install the new gnat-gps plug-in, and pfni.
* debian/pfni.1: new.
* patches/gps-integration.patch: new.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/framework-language.adb
29
29
--  PURPOSE.                                                        --
30
30
----------------------------------------------------------------------
31
31
 
 
32
----------------------------------------------------------------------
 
33
--  !!!  WARNING !!!                                                --
 
34
--                                                                  --
 
35
--  This  package  must  be the  target  of  a  pragma Elaborate    --
 
36
--  for all rules that instantiate one of its generics.             --
 
37
--                                                                  --
 
38
--  Therefore, this package must  not contain a statement part, nor --
 
39
--  call  any   function  (or instantiate any generic) as  part     --
 
40
--  of  the  elaboration of its declarations.                       --
 
41
--                                                                  --
 
42
--  The package cannot be  made preelaborable due to dependencies   --
 
43
--  to non-preelaborable units.                                     --
 
44
--                                                                  --
 
45
-- (and  if you  don't understand  what this  stuff is  about, just --
 
46
--  stick to the rule!)                                             --
 
47
----------------------------------------------------------------------
 
48
 
32
49
-- Ada
33
50
with
 
51
  Ada.Characters.Handling,
 
52
  Ada.Exceptions,
34
53
  Ada.IO_Exceptions,
35
54
  Ada.Strings.Wide_Fixed;
36
55
 
43
62
  Adactl_Options,
44
63
  Framework.Language.Commands,
45
64
  Framework.Language.Scanner,
46
 
  Framework.Rules_Manager,
47
 
  Ruler;
 
65
  Framework.Reports,
 
66
  Framework.Rules_Manager;
48
67
package body Framework.Language is
49
68
   use Framework.Language.Scanner, Utilities;
50
69
 
83
102
   -- Get_Rule_Name --
84
103
   -------------------
85
104
 
86
 
   function Get_Rule_Name return Wide_String is
 
105
   function Get_Rule_Name (Allow_All : Boolean := False) return Wide_String is
87
106
   begin
88
107
      if Current_Token.Kind /= Name then
89
108
         Syntax_Error ("Rule identifier expected", Current_Token.Position);
93
112
         use Framework.Rules_Manager;
94
113
         Result : constant Wide_String := To_Upper (Current_Token.Text (1..Current_Token.Length));
95
114
      begin
96
 
         if Is_Rule_Name (Result) then
 
115
         if (Allow_All and Result = "ALL")
 
116
           or else Is_Rule_Name (Result)
 
117
         then
97
118
            Next_Token;
98
119
            if Current_Token.Kind = Left_Parenthesis then
99
120
               Next_Token;
125
146
   -------------
126
147
 
127
148
   procedure Compile is
128
 
      use Rules_Manager, Framework.Language.Commands, Ada.IO_Exceptions;
 
149
      use Rules_Manager, Framework.Language.Commands, Framework.Reports, Ada.IO_Exceptions, Ada.Characters.Handling;
 
150
 
 
151
      procedure Process_Error (Occur : Ada.Exceptions.Exception_Occurrence) is
 
152
         use Ada.Exceptions;
 
153
      begin
 
154
         User_Message ("Error in rule: " & To_Wide_String (Exception_Message (Occur)));
 
155
         Rule_Error_Occurred := True;
 
156
         -- Ignore till next semi-colon (or Eof)
 
157
         loop
 
158
            case Current_Token.Kind is
 
159
               when Semi_Colon =>
 
160
                  Close_Command;
 
161
                  exit;
 
162
               when Eof =>
 
163
                  exit;
 
164
               when others =>
 
165
                  begin
 
166
                     Next_Token (No_Delay => True);
 
167
                  exception
 
168
                     when User_Error =>
 
169
                        -- Encountered bad characters => Ignore
 
170
                        null;
 
171
                  end;
 
172
            end case;
 
173
         end loop;
 
174
      end Process_Error;
129
175
   begin
130
176
      -- Set up initial token
131
 
      Next_Token;
132
 
 
133
 
      while Current_Token.Kind /= EoF loop
134
 
         Last_Was_Go := False;
135
 
 
136
 
         if Current_Token.Kind /= Name then
137
 
            Syntax_Error ("Command or label expected", Current_Token.Position);
138
 
         end if;
139
 
 
140
 
         case Current_Token.Key is
141
 
            when Key_Check =>
142
 
               Next_Token;
143
 
               Add_Use ("", Check, Get_Rule_Name);
144
 
               Close_Command;
145
 
 
146
 
            when Key_Clear =>
147
 
               Next_Token;
148
 
               if Current_Token.Kind /= Name then
149
 
                  Syntax_Error ("""all"", ""counts"", or Rule name expected", Current_Token.Position);
150
 
               end if;
151
 
 
152
 
               if Current_Token.Key = Key_All then
153
 
                  Next_Token;
154
 
                  Close_Command;
155
 
 
156
 
                  Command_All (Clear);
157
 
               else
158
 
                  loop
159
 
                     Command (Current_Token.Text (1 .. Current_Token.Length), Clear);
160
 
                     Next_Token;
161
 
                     exit when Current_Token.Kind /= Comma;
162
 
                     Next_Token;
163
 
                     if Current_Token.Kind /= Name then
164
 
                        Syntax_Error ("Rule name expected", Current_Token.Position);
165
 
                     end if;
166
 
                  end loop;
167
 
                  Close_Command;
168
 
               end if;
169
 
 
170
 
            when Key_Count =>
171
 
               Next_Token;
172
 
               Add_Use ("", Count, Get_Rule_Name);
173
 
               Close_Command;
174
 
 
175
 
            when Key_Go =>
176
 
               Next_Token;
177
 
               Close_Command;
178
 
 
179
 
               Last_Was_Go := True;
180
 
               Go_Command;
181
 
 
182
 
            when Key_Help =>
183
 
               Next_Token;
184
 
               if Current_Token.Kind = Semi_Colon then
185
 
                  Close_Command;
186
 
 
187
 
                  User_Message ("Commands:");
188
 
                  Help_Command;
189
 
                  User_Message ("Rules:");
190
 
                  Help_Names;
191
 
 
192
 
               elsif Current_Token.Kind = Name and then Current_Token.Key = Key_All then
193
 
                  Next_Token;
194
 
                  Close_Command;
195
 
 
196
 
                  Help_All;
197
 
 
198
 
               else
199
 
                  -- The simpler solution is to provide help messages as rule names are parsed,
200
 
                  -- but this gives unpleasant behaviour in interactive mode when there is a
201
 
                  -- syntax error. Therefore, we first accumulate names, then give all helps.
202
 
                  declare
203
 
                     Rule_Names : array (1 .. Number_Of_Rules) of Unbounded_Wide_String;
204
 
                     Inx        : Natural := 0;
205
 
                  begin
 
177
      begin
 
178
         Next_Token (No_Delay => True);
 
179
         -- No_Delay is true to get the error here if there is a parse error in the first token
 
180
      exception
 
181
         when Occur : others =>
 
182
            Process_Error (Occur);
 
183
      end;
 
184
 
 
185
      while Current_Token.Kind /= Eof loop
 
186
         begin
 
187
            Last_Was_Go := False;
 
188
 
 
189
            if Current_Token.Kind /= Name then
 
190
               Syntax_Error ("Command or label expected", Current_Token.Position);
 
191
            end if;
 
192
 
 
193
            case Current_Token.Key is
 
194
               when Key_Check =>
 
195
                  Next_Token;
 
196
                  Add_Use ("", Check, Get_Rule_Name);
 
197
                  Close_Command;
 
198
 
 
199
               when Key_Clear =>
 
200
                  Next_Token;
 
201
                  if Current_Token.Kind /= Name then
 
202
                     Syntax_Error ("""all"" or Rule name expected", Current_Token.Position);
 
203
                  end if;
 
204
 
 
205
                  if Current_Token.Key = Key_All then
 
206
                     Next_Token;
 
207
                     Close_Command;
 
208
 
 
209
                     Command_All (Clear);
 
210
 
 
211
                  else
206
212
                     loop
 
213
                        Command (Current_Token.Text (1 .. Current_Token.Length), Clear);
 
214
                        Next_Token;
 
215
                        exit when Current_Token.Kind /= Comma;
 
216
                        Next_Token;
207
217
                        if Current_Token.Kind /= Name then
208
218
                           Syntax_Error ("Rule name expected", Current_Token.Position);
209
219
                        end if;
210
 
                        if Inx = Rule_Names'Last then
211
 
                           -- This can happen only if the user specified the same rule
212
 
                           -- several times, and listed more names than there are rules.
213
 
                           -- Extremely unlikely in practice, but not a reason for not being careful...
214
 
                           Syntax_Error ("Too many rule names in ""Help"" command", Current_Token.Position);
215
 
                        end if;
216
 
                        Inx := Inx + 1;
217
 
                        Rule_Names (Inx) := To_Unbounded_Wide_String (Current_Token.Text
218
 
                                                                      (1 .. Current_Token.Length));
219
 
                        Next_Token;
220
 
                        exit when Current_Token.Kind /= Comma;
221
 
                        Next_Token;
222
 
                     end loop;
223
 
                     Close_Command;
224
 
 
225
 
                     for I in 1 .. Inx loop
226
 
                        Help (To_Wide_String (Rule_Names (I)));
227
 
                     end loop;
228
 
                  end;
229
 
               end if;
230
 
 
231
 
            when Key_Inhibit =>
232
 
               Next_Token;
233
 
               Ruler.Inhibit (Get_Rule_Name);
234
 
               Close_Command;
235
 
 
236
 
            when Key_Message =>
237
 
               Next_Token (Force_String => True);
238
 
               if Current_Token.Kind /= Name then
239
 
                  Syntax_Error ("Message expected", Current_Token.Position);
240
 
               end if;
241
 
               declare
242
 
                  Mess : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
243
 
               begin
244
 
                  Next_Token;
245
 
                  Close_Command;
246
 
 
247
 
                  User_Message (Mess);
248
 
               end;
249
 
 
250
 
            when Key_Quit =>
251
 
               Next_Token;
252
 
               Close_Command;
253
 
               exit;
254
 
 
255
 
            when Key_Search =>
256
 
               Next_Token;
257
 
               Add_Use ("", Search, Get_Rule_Name);
258
 
               Close_Command;
259
 
 
260
 
            when Key_Set =>
261
 
               Next_Token;
262
 
               declare
263
 
                  Option : constant Wide_String := To_Upper (Current_Token.Text (1 .. Current_Token.Length));
264
 
                  State  : Boolean;
265
 
                  use Adactl_Options;
266
 
               begin
267
 
                  if Option = "OUTPUT" then
268
 
                     Next_Token (Force_String => True);
269
 
                     if Current_Token.Kind /= Name then
270
 
                        Syntax_Error ("File name expected", Current_Token.Position);
271
 
                     end if;
 
220
                     end loop;
 
221
                     Close_Command;
 
222
                  end if;
 
223
 
 
224
               when Key_Count =>
 
225
                  Next_Token;
 
226
                  Add_Use ("", Count, Get_Rule_Name);
 
227
                  Close_Command;
 
228
 
 
229
               when Key_Go =>
 
230
                  Next_Token;
 
231
                  Close_Command;
 
232
 
 
233
                  Last_Was_Go := True;
 
234
                  Go_Command;
 
235
 
 
236
               when Key_Help =>
 
237
                  Next_Token;
 
238
                  if Current_Token.Kind = Semi_Colon then
 
239
                     Close_Command;
 
240
 
 
241
                     User_Message ("Commands:");
 
242
                     Help_Command;
 
243
                     User_Message ("Rules:");
 
244
                     Help_Names;
 
245
 
 
246
                  elsif Current_Token.Kind = Name and then Current_Token.Key = Key_All then
 
247
                     Next_Token;
 
248
                     Close_Command;
 
249
 
 
250
                     Help_All;
 
251
 
 
252
                  else
 
253
                     -- The simpler solution is to provide help messages as rule names are parsed,
 
254
                     -- but this gives unpleasant behaviour in interactive mode when there is a
 
255
                     -- syntax error. Therefore, we first accumulate names, then give all helps.
272
256
                     declare
273
 
                        Output : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
257
                        Rule_Names : array (Rules_Count range 1 .. Number_Of_Rules) of Unbounded_Wide_String;
 
258
                        Inx        : Rules_Count := 0;
274
259
                     begin
275
 
                        Next_Token;
 
260
                        loop
 
261
                           if Current_Token.Kind /= Name then
 
262
                              Syntax_Error ("Rule name expected", Current_Token.Position);
 
263
                           end if;
 
264
                           if Inx = Rule_Names'Last then
 
265
                              -- This can happen only if the user specified the same rule
 
266
                              -- several times, and listed more names than there are rules.
 
267
                              -- Extremely unlikely in practice, but not a reason for not being careful...
 
268
                              Syntax_Error ("Too many rule names in ""Help"" command", Current_Token.Position);
 
269
                           end if;
 
270
                           Inx := Inx + 1;
 
271
                           Rule_Names (Inx) := To_Unbounded_Wide_String (Current_Token.Text
 
272
                                                                         (1 .. Current_Token.Length));
 
273
                           Next_Token;
 
274
                           exit when Current_Token.Kind /= Comma;
 
275
                           Next_Token;
 
276
                        end loop;
 
277
 
 
278
                        for I in Rules_Count range 1 .. Inx loop
 
279
                           Help (To_Wide_String (Rule_Names (I)));
 
280
                        end loop;
 
281
 
 
282
                        -- Note: Close command *after* providing help, since in case of errors
 
283
                        -- we assume that the command is not yet closed (see handler)
276
284
                        Close_Command;
277
 
 
278
 
                        Set_Output_Command (Output);
279
285
                     end;
280
 
 
281
 
                  else
282
 
                     Next_Token;
283
 
                     if Is_String (Current_Token, "ON") then
284
 
                        State := True;
285
 
                     elsif Is_String (Current_Token, "OFF") then
286
 
                        State := False;
287
 
                     else
288
 
                        Syntax_Error ("""on"" or ""off"" expected", Current_Token.Position);
289
 
                     end if;
290
 
 
291
 
                     if Option = "VERBOSE" then
292
 
                        Verbose_Option := State;
293
 
                     elsif Option = "DEBUG" then
294
 
                        Debug_Option := State;
295
 
                     elsif Option = "IGNORE" then
296
 
                        Ignore_Option := True;
297
 
                     else
298
 
                        Syntax_Error ("Unrecognised parameter: """ & Option &'"', Current_Token.Position);
299
 
                     end if;
300
 
                     Next_Token;
301
 
                     Close_Command;
302
 
                  end if;
303
 
               end;
304
 
 
305
 
            when Key_Source =>
306
 
               Next_Token (Force_String => True);
307
 
               if Current_Token.Kind /= Name then
308
 
                  Syntax_Error ("Expect file name after ""Source""", Current_Token.Position);
309
 
               end if;
310
 
 
311
 
               declare
312
 
                  Source     : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
313
 
                  Source_Pos : constant Location    := Current_Token.Position;
314
 
               begin
315
 
                  Next_Token;
316
 
                  Close_Command;
317
 
 
318
 
                  Source_Command (Source);
319
 
               exception
320
 
                  when Name_Error =>
321
 
                     Syntax_Error ("Sourced file " & Source & " not found", Source_Pos);
322
 
               end;
323
 
 
324
 
            when Not_A_Key
325
 
              | Profile_Keys -- Profile keys and "not" allowed as labels
326
 
              | Key_Not
327
 
              =>
328
 
               -- Must be a label
329
 
               declare
330
 
                  Label : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
331
 
               begin
332
 
                  Next_Token;
333
 
                  if Current_Token.Kind /= Colon then
334
 
                     Syntax_Error ("Unknown command " & Label, Current_Token.Position);
335
 
                  end if;
336
 
                  Next_Token;
337
 
                  if Current_Token.Kind /= Name then
338
 
                     Syntax_Error ("Unexpected element after label", Current_Token.Position);
339
 
                  end if;
340
 
 
341
 
                  case Current_Token.Key is
342
 
                     when Key_Check =>
343
 
                        Next_Token;
344
 
                        Add_Use (Label, Check, Get_Rule_Name);
345
 
                     when Key_Search =>
346
 
                        Next_Token;
347
 
                        Add_Use (Label, Search, Get_Rule_Name);
348
 
                      when Key_Count =>
349
 
                        Next_Token;
350
 
                        Add_Use (Label, Count, Get_Rule_Name);
351
 
                    when others =>
352
 
                        Syntax_Error ("Only ""Check"", ""Search"", or ""Count"" allowed after label",
353
 
                                      Current_Token.Position);
354
 
                  end case;
355
 
               end;
356
 
               Close_Command;
357
 
         end case;
358
 
 
 
286
                  end if;
 
287
 
 
288
               when Key_Inhibit =>
 
289
                  Next_Token;
 
290
 
 
291
                  Inhibit_Command (Get_Rule_Name (Allow_All => True));
 
292
                  Close_Command;
 
293
 
 
294
               when Key_Message =>
 
295
                  Next_Token (Force_String => True);
 
296
                  if Current_Token.Kind /= Name then
 
297
                     Syntax_Error ("Message expected", Current_Token.Position);
 
298
                  end if;
 
299
                  declare
 
300
                     Mess : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
301
                  begin
 
302
                     Next_Token;
 
303
                     Close_Command;
 
304
 
 
305
                     User_Message (Mess);
 
306
                  end;
 
307
 
 
308
               when Key_Quit =>
 
309
                  Next_Token;
 
310
                  Close_Command;
 
311
                  exit;
 
312
 
 
313
               when Key_Search =>
 
314
                  Next_Token;
 
315
                  Add_Use ("", Search, Get_Rule_Name);
 
316
                  Close_Command;
 
317
 
 
318
               when Key_Set =>
 
319
                  Next_Token;
 
320
                  declare
 
321
                     Option : constant Wide_String := To_Upper (Current_Token.Text (1 .. Current_Token.Length));
 
322
                     State  : Boolean;
 
323
                     use Adactl_Options;
 
324
                  begin
 
325
                     if Option = "FORMAT" then
 
326
                        Next_Token;
 
327
                        if Current_Token.Kind /= Name then
 
328
                           Syntax_Error ("Format name expected", Current_Token.Position);
 
329
                        end if;
 
330
                        declare
 
331
                           Format : constant Wide_String := To_Upper (Current_Token.Text (1 .. Current_Token.Length));
 
332
                        begin
 
333
                           Next_Token;
 
334
                           Close_Command;
 
335
 
 
336
                           Set_Format_Command (Format);
 
337
                        end;
 
338
 
 
339
                     elsif Option = "OUTPUT" then
 
340
                        Next_Token (Force_String => True);
 
341
                        if Current_Token.Kind /= Name then
 
342
                           Syntax_Error ("File name expected", Current_Token.Position);
 
343
                        end if;
 
344
                        declare
 
345
                           Output : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
346
                        begin
 
347
                           Next_Token;
 
348
                           Close_Command;
 
349
 
 
350
                           Set_Output_Command (Output);
 
351
                        end;
 
352
 
 
353
                     elsif Option = "STATISTICS" then
 
354
                        Next_Token;
 
355
                        if Current_Token.Kind /= Integer_Value
 
356
                          or else Current_Token.Value not in 0 .. Stats_Levels'Pos (Stats_Levels'Last)
 
357
                        then
 
358
                           Syntax_Error ("Statistics level expected (0 .."
 
359
                                           & Integer'Wide_Image (Stats_Levels'Pos (Stats_Levels'Last))
 
360
                                           & ')',
 
361
                                        Current_Token.Position);
 
362
                        end if;
 
363
                        Stats_Level := Stats_Levels'Val (Current_Token.Value);
 
364
                        Next_Token;
 
365
                        Close_Command;
 
366
 
 
367
                     elsif Option = "TRACE" then
 
368
                        Next_Token (Force_String => True);
 
369
                        if Current_Token.Kind /= Name then
 
370
                           Syntax_Error ("File name expected", Current_Token.Position);
 
371
                        end if;
 
372
                        declare
 
373
                           Trace : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
374
                        begin
 
375
                           Next_Token;
 
376
                           Close_Command;
 
377
 
 
378
                           Set_Trace_Command (Trace);
 
379
                        end;
 
380
 
 
381
                     else
 
382
                        Next_Token;
 
383
                        if Is_String (Current_Token, "ON") then
 
384
                           State := True;
 
385
                        elsif Is_String (Current_Token, "OFF") then
 
386
                           State := False;
 
387
                        else
 
388
                           Syntax_Error ("""on"" or ""off"" expected", Current_Token.Position);
 
389
                        end if;
 
390
 
 
391
                        if Option = "VERBOSE" then
 
392
                           Verbose_Option := State;
 
393
                        elsif Option = "DEBUG" then
 
394
                           Debug_Option := State;
 
395
                        elsif Option = "IGNORE" then
 
396
                           Ignore_Option := True;
 
397
                        elsif Option = "WARNING" then
 
398
                           Skip_Warning_Option := not State;
 
399
                        else
 
400
                           Syntax_Error ("Unrecognised parameter: """ & Option &'"', Current_Token.Position);
 
401
                        end if;
 
402
                        Next_Token;
 
403
                        Close_Command;
 
404
                     end if;
 
405
                  end;
 
406
 
 
407
               when Key_Source =>
 
408
                  Next_Token (Force_String => True);
 
409
                  if Current_Token.Kind /= Name then
 
410
                     Syntax_Error ("Expect file name after ""Source""", Current_Token.Position);
 
411
                  end if;
 
412
 
 
413
                  declare
 
414
                     Source     : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
415
                     Source_Pos : constant Location    := Current_Token.Position;
 
416
                  begin
 
417
                     Next_Token;
 
418
                     Source_Command (Source);
 
419
                     Close_Command;
 
420
 
 
421
                  exception
 
422
                     when Name_Error =>
 
423
                        Syntax_Error ("Sourced file " & Source & " not found", Source_Pos);
 
424
                  end;
 
425
 
 
426
               when Not_A_Key
 
427
                 | Profile_Keys -- Profile keys and "not" allowed as labels
 
428
                 | Key_Not
 
429
                 =>
 
430
                  -- Must be a label
 
431
                  declare
 
432
                     Label : constant Wide_String := Current_Token.Text (1 .. Current_Token.Length);
 
433
                  begin
 
434
                     Next_Token;
 
435
                     if Current_Token.Kind /= Colon then
 
436
                        Syntax_Error ("Unknown command " & Label, Current_Token.Position);
 
437
                     end if;
 
438
                     Next_Token;
 
439
                     if Current_Token.Kind /= Name then
 
440
                        Syntax_Error ("Unexpected element after label", Current_Token.Position);
 
441
                     end if;
 
442
 
 
443
                     case Current_Token.Key is
 
444
                        when Key_Check =>
 
445
                           Next_Token;
 
446
                           Add_Use (Label, Check, Get_Rule_Name);
 
447
                        when Key_Search =>
 
448
                           Next_Token;
 
449
                           Add_Use (Label, Search, Get_Rule_Name);
 
450
                        when Key_Count =>
 
451
                           Next_Token;
 
452
                           Add_Use (Label, Count, Get_Rule_Name);
 
453
                        when others =>
 
454
                           Syntax_Error ("Only ""Check"", ""Search"", or ""Count"" allowed after label",
 
455
                                         Current_Token.Position);
 
456
                     end case;
 
457
                  end;
 
458
                  Close_Command;
 
459
            end case;
 
460
         exception
 
461
            when Occur : Utilities.User_Error =>
 
462
               Process_Error (Occur);
 
463
         end;
359
464
      end loop;
360
465
   end Compile;
361
466
 
367
472
   -- Execute --
368
473
   -------------
369
474
 
370
 
   procedure Execute (Commands : Wide_String) is
 
475
   procedure Execute (Command_String : Wide_String) is
371
476
   begin
372
477
      Set_Prompt ("");
373
 
      Start_Scan (From_String => True, Source => Commands);
 
478
      Start_Scan (From_String => True, Source => Command_String);
374
479
      Compile;
375
480
   end Execute;
376
481
 
 
482
   ---------------------
 
483
   -- Source_Location --
 
484
   ---------------------
 
485
 
 
486
   function Source_Location return Location is
 
487
   begin
 
488
      return Current_Token.Position;
 
489
   end Source_Location;
 
490
 
377
491
   ----------------------
378
492
   -- Parameter_Exists --
379
493
   ----------------------
383
497
      return In_Parameters;
384
498
   end Parameter_Exists;
385
499
 
 
500
   --------------------------
 
501
   -- Is_Integer_Parameter --
 
502
   --------------------------
 
503
 
 
504
   function Is_Integer_Parameter return Boolean is
 
505
   begin
 
506
      if not In_Parameters then
 
507
         Failure ("Is_Integer_Parameter called when not in parameters");
 
508
      end if;
 
509
 
 
510
      return Current_Token.Kind = Integer_Value;
 
511
   end Is_Integer_Parameter;
 
512
 
 
513
   ------------------------
 
514
   -- Is_Float_Parameter --
 
515
   ------------------------
 
516
 
 
517
   function Is_Float_Parameter return Boolean is
 
518
   begin
 
519
      if not In_Parameters then
 
520
         Failure ("Is_Float_Parameter called when not in parameters");
 
521
      end if;
 
522
 
 
523
      return Current_Token.Kind = Float_Value;
 
524
   end Is_Float_Parameter;
 
525
 
386
526
   ---------------------------
387
527
   -- Get_Integer_Parameter --
388
528
   ---------------------------
393
533
         Failure ("Get_Integer_Parameter called when not in parameters");
394
534
      end if;
395
535
 
396
 
      if Current_Token.Kind = Integer_Value then
397
 
         declare
398
 
            Result : constant Integer := Current_Token.Value;
399
 
         begin
400
 
            Next_Token;
401
 
            Next_Parameter;
402
 
            return Result;
403
 
         end;
404
 
      elsif Current_Token.Kind = Name then
405
 
         Syntax_Error ("Integer parameter expected", Current_Token.Position);
406
 
      else
407
 
         Syntax_Error ("Parameter expected", Current_Token.Position);
408
 
      end if;
 
536
      case Current_Token.Kind is
 
537
         when Integer_Value =>
 
538
            declare
 
539
               Result : constant Integer := Current_Token.Value;
 
540
            begin
 
541
               Next_Token;
 
542
               Next_Parameter;
 
543
               return Result;
 
544
            end;
 
545
         when Bad_Integer =>
 
546
            Syntax_Error ("Bad integer value (too many digits?)", Current_Token.Position);
 
547
         when Name | Bad_Float =>
 
548
            Syntax_Error ("Integer parameter expected", Current_Token.Position);
 
549
         when others =>
 
550
           Syntax_Error ("Parameter expected", Current_Token.Position);
 
551
      end case;
409
552
   end Get_Integer_Parameter;
410
553
 
 
554
   -------------------------
 
555
   -- Get_Float_Parameter --
 
556
   -------------------------
 
557
 
 
558
   function Get_Float_Parameter return Float is
 
559
   begin
 
560
      if not In_Parameters then
 
561
         Failure ("Get_Float_Parameter called when not in parameters");
 
562
      end if;
 
563
 
 
564
      case Current_Token.Kind is
 
565
         when Float_Value =>
 
566
            declare
 
567
               Result : constant Float := Current_Token.Fvalue;
 
568
            begin
 
569
               Next_Token;
 
570
               Next_Parameter;
 
571
               return Result;
 
572
            end;
 
573
         when Bad_Integer | Bad_Float =>
 
574
            Syntax_Error ("Bad real value (too many digits?)", Current_Token.Position);
 
575
         when Name =>
 
576
            Syntax_Error ("Float parameter expected", Current_Token.Position);
 
577
         when others =>
 
578
            Syntax_Error ("Parameter expected", Current_Token.Position);
 
579
      end case;
 
580
   end Get_Float_Parameter;
 
581
 
411
582
   --------------------------
412
583
   -- Get_String_Parameter --
413
584
   --------------------------
470
641
 
471
642
      function Profile_List return Wide_String is
472
643
         With_Access : Boolean := False;
 
644
 
 
645
         function Formated_Name (Name : Wide_String) return Wide_String is
 
646
         begin
 
647
            if Qualified then
 
648
               if With_Access then
 
649
                  return '*' & Name;
 
650
               else
 
651
                  return Name;
 
652
               end if;
 
653
            else
 
654
               if With_Access then
 
655
                  return '*' & "STANDARD." & Name;
 
656
               else
 
657
                  return "STANDARD." & Name;
 
658
               end if;
 
659
            end if;
 
660
         end Formated_Name;
473
661
      begin
474
662
         if Current_Token.Kind = Name and then Current_Token.Key = Key_Access then
475
663
            With_Access := True;
479
667
         -- If not qualified, assume the identifier is declared in Standard
480
668
         Qualified := False;
481
669
         declare
482
 
            function Formated_Name (Name : Wide_String) return Wide_String is
483
 
            begin
484
 
               if Qualified then
485
 
                  if With_Access then
486
 
                     return '*' & Name;
487
 
                  else
488
 
                     return Name;
489
 
                  end if;
490
 
               else
491
 
                  if With_Access then
492
 
                     return '*' & "STANDARD." & Name;
493
 
                  else
494
 
                     return "STANDARD." & Name;
495
 
                  end if;
496
 
               end if;
497
 
            end Formated_Name;
498
 
 
499
670
            Name1 : constant Wide_String := Formated_Name (Full_Name);
500
671
         begin
501
672
            if Current_Token.Kind = Semi_Colon then
515
686
            declare
516
687
               Result_Type : constant Wide_String := Full_Name;
517
688
            begin
518
 
               -- If not qualified, assume the identifier is declared in Standard
519
 
               if not Qualified then
 
689
               if Qualified then
 
690
                  return ':' & Result_Type;
 
691
               else
 
692
                  -- If not qualified, assume the identifier is declared in Standard
520
693
                  return ':' & "STANDARD." & Result_Type;
521
 
               else
522
 
                  return ':' & Result_Type;
523
694
               end if;
524
695
            end;
525
696
         end if;
533
704
               declare
534
705
                  Result_Type : constant Wide_String := Full_Name;
535
706
               begin
536
 
                  -- If not qualified, assume the identifier is declared in Standard
537
 
                  if not Qualified then
 
707
                  if Qualified then
 
708
                     return List1 & ':' & Result_Type;
 
709
                  else
 
710
                     -- If not qualified, assume the identifier is declared in Standard
538
711
                     return List1 & ':' & "STANDARD." & Result_Type;
539
 
                  else
540
 
                     return List1 & ':' & Result_Type;
541
712
                  end if;
542
713
               end;
543
714
            else
605
776
         end if;
606
777
      end Full_Name;
607
778
 
608
 
      use Ada.Strings.Wide_Unbounded;
609
779
   begin  -- Get_Entity_Parameter
610
780
      if not In_Parameters then
611
781
         Failure ("Get_Entity_Parameter called when not in parameters");
679
849
      return Default;
680
850
   end Get_Modifier;
681
851
 
682
 
   ------------------------
683
 
   -- Get_Flag_Parameter --
684
 
   ------------------------
 
852
   -----------------------------
 
853
   -- Get_Enumerated_Modifier --
 
854
   -----------------------------
685
855
 
686
 
   function Get_Flag_Parameter return Flags is
 
856
   function Get_Enumerated_Modifier
 
857
     (Default : in Index       := Index'First;
 
858
      Prefix  : in Wide_String := "")
 
859
     return Index
 
860
   is
687
861
   begin
688
 
      if not In_Parameters then
689
 
         Failure ("Get_Flag_Parameter called when not in parameters");
690
 
      end if;
691
 
 
692
862
      if Current_Token.Kind = Name then
693
 
         declare
694
 
            To_Compare : constant Wide_String := To_Upper (Prefix &
695
 
                                                           Current_Token.Text (1 .. Current_Token.Length));
696
 
         begin
697
 
            for Key in Flags loop
698
 
               if To_Compare = Flags'Wide_Image (Key) then
699
 
                  if Allow_Any and then Key = Flags'First then
700
 
                     -- Oops, the user specified the special value
701
 
                     Syntax_Error ("Not a valid parameter: " & Current_Token.Text (1 .. Current_Token.Length),
702
 
                                   Current_Token.Position);
 
863
         for Idx in Index loop
 
864
            if
 
865
              To_Upper (Prefix & Current_Token.Text (1..Current_Token.Length)) =
 
866
              To_Upper (Index'Wide_Image (Idx))
 
867
            then
 
868
               Next_Token;
 
869
               return Idx;
 
870
            end if;
 
871
         end loop;
 
872
      end if;
 
873
      return Default;
 
874
   end Get_Enumerated_Modifier;
 
875
 
 
876
 
 
877
   --------------------
 
878
   -- Flag_Utilities --
 
879
   --------------------
 
880
 
 
881
   package body Flag_Utilities is
 
882
 
 
883
      ------------------------
 
884
      -- Get_Flag_Parameter --
 
885
      ------------------------
 
886
 
 
887
      function Get_Flag_Parameter (Allow_Any : Boolean) return Flags is
 
888
      begin
 
889
         if not In_Parameters then
 
890
            Failure ("Get_Flag_Parameter called when not in parameters");
 
891
         end if;
 
892
 
 
893
         if Current_Token.Kind = Name then
 
894
            declare
 
895
               To_Compare : constant Wide_String := To_Upper (Prefix &
 
896
                                                              Current_Token.Text (1 .. Current_Token.Length));
 
897
            begin
 
898
               for Key in Flags loop
 
899
                  if To_Compare = Flags'Wide_Image (Key) then
 
900
                     if Allow_Any and then Key = Flags'First then
 
901
                        -- Oops, the user specified the special value
 
902
                        Syntax_Error ("Not a valid parameter: " & Current_Token.Text (1 .. Current_Token.Length),
 
903
                                      Current_Token.Position);
 
904
                     end if;
 
905
 
 
906
                     Next_Token;
 
907
                     Next_Parameter;
 
908
                     return Key;
703
909
                  end if;
704
 
 
705
 
                  Next_Token;
706
 
                  Next_Parameter;
707
 
                  return Key;
708
 
               end if;
709
 
            end loop;
710
 
         end;
711
 
      end if;
712
 
 
713
 
      -- Here: not a Name, or unrecognized keyword
714
 
      if Allow_Any then
715
 
         -- Keep the current token
716
 
         return Flags'First;
717
 
      end if;
718
 
 
719
 
      Syntax_Error ("Keyword expected, use option -h <rule name> for a list of allowable keywords",
720
 
                    Current_Token.Position);
721
 
   end Get_Flag_Parameter;
 
910
               end loop;
 
911
            end;
 
912
         end if;
 
913
 
 
914
         -- Here: not a Name, or unrecognized keyword
 
915
         if Allow_Any then
 
916
            -- Keep the current token
 
917
            return Flags'First;
 
918
         end if;
 
919
 
 
920
         if Current_Token.Kind = Name then
 
921
            Syntax_Error ("Unknown keyword """
 
922
                            & Current_Token.Text (1 .. Current_Token.Length)
 
923
                            & """, use option -h <rule name> for a list of allowable keywords",
 
924
                          Current_Token.Position);
 
925
         else
 
926
            Syntax_Error ("Keyword expected, use option -h <rule name> for a list of allowable keywords",
 
927
                          Current_Token.Position);
 
928
         end if;
 
929
      end Get_Flag_Parameter;
 
930
 
 
931
      -----------
 
932
      -- Image --
 
933
      -----------
 
934
 
 
935
      function Image (Item : Flags) return Wide_String is
 
936
         Img : constant Wide_String := To_Lower (Flags'Wide_Image (Item));
 
937
      begin
 
938
            -- Remove prefix
 
939
            return Img (Prefix'Length+1 .. Img'Last);
 
940
      end Image;
 
941
 
 
942
      -------------------
 
943
      -- Help_On_Flags --
 
944
      -------------------
 
945
 
 
946
      procedure Help_On_Flags (Header      : Wide_String := "";
 
947
                               Footer      : Wide_String := "";
 
948
                               Extra_Value : Wide_String := "")
 
949
      is
 
950
         -- Pretty print of values of flags.
 
951
         -- Values are arranged in columns.
 
952
         -- The number of columns is computed assuming that each column is True_Width wide,
 
953
         -- except for the first one that can contain Extra_Value if provided.
 
954
         -- then the actual width is adjusted to what is actually needed, to make it prettier
 
955
         -- looking. More sophisticated optimization would be overkill.
 
956
         Display_Width : constant := 79;
 
957
         True_Width    : constant Natural := Flags'Width - Prefix'Length;
 
958
         Buffer        : Wide_String (1..Display_Width);
 
959
         Index         : Natural;
 
960
         Nb_Col        : constant Natural := 1 + (Display_Width - Header'Length
 
961
                                                  - Natural'Max (True_Width, Extra_Value'Length) - 3 -- Width of 1st col
 
962
                                                 ) / (True_Width + 3); -- 3 => " | "
 
963
         Col_Widthes   : array (1 .. Nb_Col) of Natural := (1 => Extra_Value'Length, others => 0);
 
964
         Current_Col   : Natural;
 
965
         First_Flag    : Flags;
 
966
      begin
 
967
         Current_Col := 1;
 
968
         for I in Flags loop
 
969
            declare
 
970
               Img : constant Wide_String := Image (I);
 
971
            begin
 
972
               if Img'Length > Col_Widthes (Current_Col) then
 
973
                  Col_Widthes (Current_Col) := Img'Length;
 
974
               end if;
 
975
               if Current_Col = Nb_Col then
 
976
                  Current_Col := 1;
 
977
               else
 
978
                  Current_Col := Current_Col + 1;
 
979
               end if;
 
980
            end;
 
981
         end loop;
 
982
 
 
983
         Buffer := (others => ' ');
 
984
         Buffer (1 .. Header'Length) := Header;
 
985
         Index := Header'Length;
 
986
 
 
987
         Current_Col := 1;
 
988
         if Extra_Value = "" then
 
989
            First_Flag  := Flags'First;
 
990
         else
 
991
            Index := Index + 1;  -- Add space
 
992
            Buffer (Index + 1 .. Index + Extra_Value'Length) := Extra_Value;
 
993
            Index := Index + Col_Widthes (Current_Col) + 1;
 
994
 
 
995
            Buffer (Index + 1) := '|';
 
996
            Index := Index + 1;
 
997
 
 
998
            if Nb_Col = 1 then
 
999
               User_Message (Buffer (1 .. Index));
 
1000
               Current_Col := 1;
 
1001
               Buffer := (others => ' ');
 
1002
               Index := Header'Length;
 
1003
            else
 
1004
               Current_Col := 2;
 
1005
            end if;
 
1006
 
 
1007
            -- Gnat warns about Constraint_Error being raised by the following statement
 
1008
            -- when instantiated with a Flag type that has only one value.
 
1009
            -- But in this case, Extra_Value must be "", so it is OK.
 
1010
            pragma Warnings (Off);
 
1011
            First_Flag := Flags'Succ (Flags'First);
 
1012
            pragma Warnings (On);
 
1013
         end if;
 
1014
 
 
1015
         for I in Flags range First_Flag .. Flags'Last loop
 
1016
            declare
 
1017
               Img : constant Wide_String := Image (I);
 
1018
            begin
 
1019
               Index := Index + 1;  -- Add space
 
1020
 
 
1021
               Buffer (Index + 1 .. Index + Img'Length) := Img;
 
1022
               if I = Flags'Last then
 
1023
                  Index := Index + Img'Length;
 
1024
                  User_Message (Buffer (1 .. Index));
 
1025
                  exit;
 
1026
               else
 
1027
                  Index := Index + Col_Widthes (Current_Col) + 1;
 
1028
               end if;
 
1029
 
 
1030
               Buffer (Index + 1) := '|';
 
1031
               Index := Index + 1;
 
1032
 
 
1033
               if Current_Col = Nb_Col then
 
1034
                  User_Message (Buffer (1 .. Index));
 
1035
                  Current_Col := 1;
 
1036
                  Buffer := (others => ' ');
 
1037
                  Index := Header'Length;
 
1038
               else
 
1039
                  Current_Col := Current_Col + 1;
 
1040
               end if;
 
1041
            end;
 
1042
         end loop;
 
1043
 
 
1044
         if Footer /= "" then
 
1045
            User_Message ((1..Header'Length + 1 => ' ') & Footer);
 
1046
         end if;
 
1047
      end Help_On_Flags;
 
1048
   end Flag_Utilities;
722
1049
 
723
1050
   ------------------
724
1051
   -- Adjust_Image --
777
1104
      Syntax_Error (Message, Current_Token.Position);
778
1105
   end Parameter_Error;
779
1106
 
 
1107
   procedure Parameter_Error (Message : Wide_String; Position : Location) renames Syntax_Error;
 
1108
 
780
1109
   ----------------------
781
1110
   -- Go_Command_Found --
782
1111
   ----------------------
792
1121
 
793
1122
   function Had_Failure return Boolean is
794
1123
   begin
795
 
      return Failure_Occured;
 
1124
      return Failure_Occurred;
796
1125
   end Had_Failure;
797
1126
 
 
1127
   ----------------
 
1128
   -- Had_Errors --
 
1129
   ----------------
 
1130
 
 
1131
   function Had_Errors return Boolean is
 
1132
   begin
 
1133
      return Rule_Error_Occurred;
 
1134
   end Had_Errors;
 
1135
 
798
1136
end Framework.Language;