1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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
("3aAbcdefhiklmnprsStux");
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 procedure Add_Img
(N
: Natural);
199 -- Concatenates image of N at end of Style_Msg_Buf
201 procedure Bad_Style_Switch
(Msg
: String);
202 -- Called if bad style switch found. Msg is mset in Style_Msg_Buf and
203 -- Style_Msg_Len. OK is set False.
209 procedure Add_Img
(N
: Natural) is
215 Style_Msg_Len
:= Style_Msg_Len
+ 1;
216 Style_Msg_Buf
(Style_Msg_Len
) :=
217 Character'Val (N
mod 10 + Character'Pos ('0'));
220 ----------------------
221 -- Bad_Style_Switch --
222 ----------------------
224 procedure Bad_Style_Switch
(Msg
: String) is
227 Style_Msg_Len
:= Msg
'Length;
228 Style_Msg_Buf
(1 .. Style_Msg_Len
) := Msg
;
229 end Bad_Style_Switch
;
231 -- Start of processing for Set_Style_Check_Options
234 Err_Col
:= Options
'First;
235 while Err_Col
<= Options
'Last loop
236 C
:= Options
(Err_Col
);
237 Err_Col
:= Err_Col
+ 1;
241 Style_Check_Indentation
:=
242 Character'Pos (C
) - Character'Pos ('0');
245 Style_Check_Attribute_Casing
:= True;
248 Style_Check_Array_Attribute_Index
:= True;
251 Style_Check_Blanks_At_End
:= True;
254 Style_Check_Comments
:= True;
257 Style_Check_DOS_Line_Terminator
:= True;
260 Style_Check_End_Labels
:= True;
263 Style_Check_Form_Feeds
:= True;
266 Set_GNAT_Style_Check_Options
;
269 Style_Check_Horizontal_Tabs
:= True;
272 Style_Check_If_Then_Layout
:= True;
275 Style_Check_Mode_In
:= True;
278 Style_Check_Keyword_Casing
:= True;
281 Style_Check_Layout
:= True;
284 Style_Max_Nesting_Level
:= 0;
286 if Err_Col
> Options
'Last
287 or else Options
(Err_Col
) not in '0' .. '9'
289 Bad_Style_Switch
("invalid nesting level");
294 Style_Max_Nesting_Level
:=
295 Style_Max_Nesting_Level
* 10 +
296 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
298 if Style_Max_Nesting_Level
> 999 then
300 ("max nesting level (999) exceeded in style check");
304 Err_Col
:= Err_Col
+ 1;
305 exit when Err_Col
> Options
'Last
306 or else Options
(Err_Col
) not in '0' .. '9';
309 Style_Check_Max_Nesting_Level
:= Style_Max_Nesting_Level
/= 0;
312 Style_Check_Max_Line_Length
:= True;
313 Style_Max_Line_Length
:= 79;
316 Style_Max_Line_Length
:= 0;
318 if Err_Col
> Options
'Last
319 or else Options
(Err_Col
) not in '0' .. '9'
322 ("invalid line length in style check");
327 Style_Max_Line_Length
:=
328 Style_Max_Line_Length
* 10 +
329 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
331 if Style_Max_Line_Length
> Int
(Max_Line_Length
) then
333 Style_Msg_Buf
(1 .. 27) := "max line length allowed is ";
335 Add_Img
(Natural (Max_Line_Length
));
339 Err_Col
:= Err_Col
+ 1;
340 exit when Err_Col
> Options
'Last
341 or else Options
(Err_Col
) not in '0' .. '9';
344 Style_Check_Max_Line_Length
:= Style_Max_Line_Length
/= 0;
347 Style_Check_Standard
:= True;
350 Reset_Style_Check_Options
;
353 Style_Check_Order_Subprograms
:= True;
356 Style_Check_Pragma_Casing
:= True;
359 Style_Check_References
:= True;
362 Style_Check_Specs
:= True;
365 Style_Check_Separate_Stmt_Lines
:= True;
368 Style_Check_Tokens
:= True;
371 Style_Check_Blank_Lines
:= True;
374 Style_Check_Xtra_Parens
:= True;
380 Err_Col
:= Err_Col
- 1;
381 Style_Msg_Buf
(1 .. 22) := "invalid style switch: ";
383 Style_Msg_Buf
(Style_Msg_Len
) := C
;
391 end Set_Style_Check_Options
;