1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Hostparm
; use Hostparm
;
29 package body Stylesw
is
31 -------------------------------
32 -- Reset_Style_Check_Options --
33 -------------------------------
35 procedure Reset_Style_Check_Options
is
37 Style_Check_Indentation
:= 0;
38 Style_Check_Array_Attribute_Index
:= False;
39 Style_Check_Attribute_Casing
:= False;
40 Style_Check_Blanks_At_End
:= False;
41 Style_Check_Blank_Lines
:= False;
42 Style_Check_Comments
:= False;
43 Style_Check_DOS_Line_Terminator
:= False;
44 Style_Check_End_Labels
:= False;
45 Style_Check_Form_Feeds
:= False;
46 Style_Check_Horizontal_Tabs
:= False;
47 Style_Check_If_Then_Layout
:= False;
48 Style_Check_Keyword_Casing
:= False;
49 Style_Check_Layout
:= False;
50 Style_Check_Max_Line_Length
:= False;
51 Style_Check_Max_Nesting_Level
:= False;
52 Style_Check_Mode_In
:= False;
53 Style_Check_Order_Subprograms
:= False;
54 Style_Check_Pragma_Casing
:= False;
55 Style_Check_References
:= False;
56 Style_Check_Separate_Stmt_Lines
:= False;
57 Style_Check_Specs
:= False;
58 Style_Check_Standard
:= False;
59 Style_Check_Tokens
:= False;
60 Style_Check_Xtra_Parens
:= False;
61 end Reset_Style_Check_Options
;
63 ------------------------------
64 -- Save_Style_Check_Options --
65 ------------------------------
67 procedure Save_Style_Check_Options
(Options
: out Style_Check_Options
) is
70 procedure Add
(C
: Character; S
: Boolean);
71 -- Add given character C to string if switch S is true
73 procedure Add_Nat
(N
: Nat
);
74 -- Add given natural number to string
80 procedure Add
(C
: Character; S
: Boolean) is
92 procedure Add_Nat
(N
: Nat
) is
99 Options
(P
) := Character'Val (Character'Pos ('0') + N
mod 10);
102 -- Start of processing for Save_Style_Check_Options
105 for K
in Options
'Range loop
109 Add
(Character'Val (Style_Check_Indentation
+ Character'Pos ('0')),
110 Style_Check_Indentation
/= 0);
112 Add
('a', Style_Check_Attribute_Casing
);
113 Add
('A', Style_Check_Array_Attribute_Index
);
114 Add
('b', Style_Check_Blanks_At_End
);
115 Add
('c', Style_Check_Comments
);
116 Add
('d', Style_Check_DOS_Line_Terminator
);
117 Add
('e', Style_Check_End_Labels
);
118 Add
('f', Style_Check_Form_Feeds
);
119 Add
('h', Style_Check_Horizontal_Tabs
);
120 Add
('i', Style_Check_If_Then_Layout
);
121 Add
('I', Style_Check_Mode_In
);
122 Add
('k', Style_Check_Keyword_Casing
);
123 Add
('l', Style_Check_Layout
);
124 Add
('n', Style_Check_Standard
);
125 Add
('o', Style_Check_Order_Subprograms
);
126 Add
('p', Style_Check_Pragma_Casing
);
127 Add
('r', Style_Check_References
);
128 Add
('s', Style_Check_Specs
);
129 Add
('S', Style_Check_Separate_Stmt_Lines
);
130 Add
('t', Style_Check_Tokens
);
131 Add
('u', Style_Check_Blank_Lines
);
132 Add
('x', Style_Check_Xtra_Parens
);
134 if Style_Check_Max_Line_Length
then
137 Add_Nat
(Style_Max_Line_Length
);
140 if Style_Check_Max_Nesting_Level
then
143 Add_Nat
(Style_Max_Nesting_Level
);
146 pragma Assert
(P
<= Options
'Last);
148 while P
< Options
'Last loop
152 end Save_Style_Check_Options
;
154 -------------------------------------
155 -- Set_Default_Style_Check_Options --
156 -------------------------------------
158 procedure Set_Default_Style_Check_Options
is
160 Reset_Style_Check_Options
;
161 Set_Style_Check_Options
("3aAbcefhiklmnprst");
162 end Set_Default_Style_Check_Options
;
164 ----------------------------------
165 -- Set_GNAT_Style_Check_Options --
166 ----------------------------------
168 procedure Set_GNAT_Style_Check_Options
is
170 Reset_Style_Check_Options
;
171 Set_Style_Check_Options
("3aAbcdefhiIklmnprsStux");
172 end Set_GNAT_Style_Check_Options
;
174 -----------------------------
175 -- Set_Style_Check_Options --
176 -----------------------------
178 -- Version used when no error checking is required
180 procedure Set_Style_Check_Options
(Options
: String) is
183 pragma Warnings
(Off
, EC
);
185 Set_Style_Check_Options
(Options
, OK
, EC
);
187 end Set_Style_Check_Options
;
189 -- Normal version with error checking
191 procedure Set_Style_Check_Options
194 Err_Col
: out Natural)
198 On
: Boolean := True;
199 -- Set to False if minus encountered
200 -- Set to True if plus encountered
202 Last_Option
: Character := ' ';
203 -- Set to last character encountered
205 procedure Add_Img
(N
: Natural);
206 -- Concatenates image of N at end of Style_Msg_Buf
208 procedure Bad_Style_Switch
(Msg
: String);
209 -- Called if bad style switch found. Msg is set in Style_Msg_Buf and
210 -- Style_Msg_Len. OK is set False.
216 procedure Add_Img
(N
: Natural) is
222 Style_Msg_Len
:= Style_Msg_Len
+ 1;
223 Style_Msg_Buf
(Style_Msg_Len
) :=
224 Character'Val (N
mod 10 + Character'Pos ('0'));
227 ----------------------
228 -- Bad_Style_Switch --
229 ----------------------
231 procedure Bad_Style_Switch
(Msg
: String) is
234 Style_Msg_Len
:= Msg
'Length;
235 Style_Msg_Buf
(1 .. Style_Msg_Len
) := Msg
;
236 end Bad_Style_Switch
;
238 -- Start of processing for Set_Style_Check_Options
241 Err_Col
:= Options
'First;
242 while Err_Col
<= Options
'Last loop
243 C
:= Options
(Err_Col
);
245 Err_Col
:= Err_Col
+ 1;
247 -- Turning switches on
259 Style_Check_Indentation
:=
260 Character'Pos (C
) - Character'Pos ('0');
263 Style_Check_Attribute_Casing
:= True;
266 Style_Check_Array_Attribute_Index
:= True;
269 Style_Check_Blanks_At_End
:= True;
272 Style_Check_Comments
:= True;
275 Style_Check_DOS_Line_Terminator
:= True;
278 Style_Check_End_Labels
:= True;
281 Style_Check_Form_Feeds
:= True;
284 Set_GNAT_Style_Check_Options
;
287 Style_Check_Horizontal_Tabs
:= True;
290 Style_Check_If_Then_Layout
:= True;
293 Style_Check_Mode_In
:= True;
296 Style_Check_Keyword_Casing
:= True;
299 Style_Check_Layout
:= True;
302 Style_Max_Nesting_Level
:= 0;
304 if Err_Col
> Options
'Last
305 or else Options
(Err_Col
) not in '0' .. '9'
307 Bad_Style_Switch
("invalid nesting level");
312 Style_Max_Nesting_Level
:=
313 Style_Max_Nesting_Level
* 10 +
314 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
316 if Style_Max_Nesting_Level
> 999 then
318 ("max nesting level (999) exceeded in style check");
322 Err_Col
:= Err_Col
+ 1;
323 exit when Err_Col
> Options
'Last
324 or else Options
(Err_Col
) not in '0' .. '9';
327 Style_Check_Max_Nesting_Level
:= Style_Max_Nesting_Level
/= 0;
330 Style_Check_Max_Line_Length
:= True;
331 Style_Max_Line_Length
:= 79;
334 Style_Max_Line_Length
:= 0;
336 if Err_Col
> Options
'Last
337 or else Options
(Err_Col
) not in '0' .. '9'
340 ("invalid line length in style check");
345 Style_Max_Line_Length
:=
346 Style_Max_Line_Length
* 10 +
347 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
349 if Style_Max_Line_Length
> Int
(Max_Line_Length
) then
351 Style_Msg_Buf
(1 .. 27) := "max line length allowed is ";
353 Add_Img
(Natural (Max_Line_Length
));
357 Err_Col
:= Err_Col
+ 1;
358 exit when Err_Col
> Options
'Last
359 or else Options
(Err_Col
) not in '0' .. '9';
362 Style_Check_Max_Line_Length
:= Style_Max_Line_Length
/= 0;
365 Style_Check_Standard
:= True;
368 Reset_Style_Check_Options
;
371 Style_Check_Order_Subprograms
:= True;
374 Style_Check_Pragma_Casing
:= True;
377 Style_Check_References
:= True;
380 Style_Check_Specs
:= True;
383 Style_Check_Separate_Stmt_Lines
:= True;
386 Style_Check_Tokens
:= True;
389 Style_Check_Blank_Lines
:= True;
392 Style_Check_Xtra_Parens
:= True;
395 Set_Default_Style_Check_Options
;
401 Err_Col
:= Err_Col
- 1;
402 Bad_Style_Switch
("invalid style switch: " & C
);
406 -- Turning switches off
418 Style_Check_Indentation
:= 0;
421 Style_Check_Attribute_Casing
:= False;
424 Style_Check_Array_Attribute_Index
:= False;
427 Style_Check_Blanks_At_End
:= False;
430 Style_Check_Comments
:= False;
433 Style_Check_DOS_Line_Terminator
:= False;
436 Style_Check_End_Labels
:= False;
439 Style_Check_Form_Feeds
:= False;
442 Reset_Style_Check_Options
;
445 Style_Check_Horizontal_Tabs
:= False;
448 Style_Check_If_Then_Layout
:= False;
451 Style_Check_Mode_In
:= False;
454 Style_Check_Keyword_Casing
:= False;
457 Style_Check_Layout
:= False;
460 Style_Max_Nesting_Level
:= 0;
463 Style_Check_Max_Line_Length
:= False;
466 Style_Max_Line_Length
:= 0;
467 Style_Check_Max_Line_Length
:= False;
470 Style_Check_Standard
:= False;
473 Style_Check_Order_Subprograms
:= False;
476 Style_Check_Pragma_Casing
:= False;
479 Style_Check_References
:= False;
482 Style_Check_Specs
:= False;
485 Style_Check_Separate_Stmt_Lines
:= False;
488 Style_Check_Tokens
:= False;
491 Style_Check_Blank_Lines
:= False;
494 Style_Check_Xtra_Parens
:= False;
500 Err_Col
:= Err_Col
- 1;
501 Bad_Style_Switch
("invalid style switch: " & C
);
507 -- Turn on style checking if other than N at end of string
509 Style_Check
:= (Last_Option
/= 'N');
511 end Set_Style_Check_Options
;