1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Hostparm
; use Hostparm
;
30 package body Stylesw
is
32 -------------------------------
33 -- Reset_Style_Check_Options --
34 -------------------------------
36 procedure Reset_Style_Check_Options
is
38 Style_Check_Indentation
:= 0;
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_Order_Subprograms
:= False;
53 Style_Check_Pragma_Casing
:= False;
54 Style_Check_References
:= False;
55 Style_Check_Specs
:= False;
56 Style_Check_Standard
:= False;
57 Style_Check_Tokens
:= False;
58 Style_Check_Xtra_Parens
:= False;
59 end Reset_Style_Check_Options
;
61 ------------------------------
62 -- Save_Style_Check_Options --
63 ------------------------------
65 procedure Save_Style_Check_Options
(Options
: out Style_Check_Options
) is
68 procedure Add
(C
: Character; S
: Boolean);
69 -- Add given character C to string if switch S is true
71 procedure Add_Nat
(N
: Nat
);
72 -- Add given natural number to string
78 procedure Add
(C
: Character; S
: Boolean) is
90 procedure Add_Nat
(N
: Nat
) is
97 Options
(P
) := Character'Val (Character'Pos ('0') + N
mod 10);
100 -- Start of processing for Save_Style_Check_Options
103 for K
in Options
'Range loop
107 Add
(Character'Val (Style_Check_Indentation
+ Character'Pos ('0')),
108 Style_Check_Indentation
/= 0);
110 Add
('a', Style_Check_Attribute_Casing
);
111 Add
('b', Style_Check_Blanks_At_End
);
112 Add
('c', Style_Check_Comments
);
113 Add
('d', Style_Check_DOS_Line_Terminator
);
114 Add
('e', Style_Check_End_Labels
);
115 Add
('f', Style_Check_Form_Feeds
);
116 Add
('h', Style_Check_Horizontal_Tabs
);
117 Add
('i', Style_Check_If_Then_Layout
);
118 Add
('k', Style_Check_Keyword_Casing
);
119 Add
('l', Style_Check_Layout
);
120 Add
('n', Style_Check_Standard
);
121 Add
('o', Style_Check_Order_Subprograms
);
122 Add
('p', Style_Check_Pragma_Casing
);
123 Add
('r', Style_Check_References
);
124 Add
('s', Style_Check_Specs
);
125 Add
('t', Style_Check_Tokens
);
126 Add
('u', Style_Check_Blank_Lines
);
127 Add
('x', Style_Check_Xtra_Parens
);
129 if Style_Check_Max_Line_Length
then
132 Add_Nat
(Style_Max_Line_Length
);
135 if Style_Check_Max_Nesting_Level
then
138 Add_Nat
(Style_Max_Nesting_Level
);
141 pragma Assert
(P
<= Options
'Last);
143 while P
< Options
'Last loop
147 end Save_Style_Check_Options
;
149 -------------------------------------
150 -- Set_Default_Style_Check_Options --
151 -------------------------------------
153 procedure Set_Default_Style_Check_Options
is
155 Reset_Style_Check_Options
;
156 Set_Style_Check_Options
("3abcefhiklmnprst");
157 end Set_Default_Style_Check_Options
;
159 -----------------------------
160 -- Set_Style_Check_Options --
161 -----------------------------
163 -- Version used when no error checking is required
165 procedure Set_Style_Check_Options
(Options
: String) is
169 Set_Style_Check_Options
(Options
, OK
, EC
);
171 end Set_Style_Check_Options
;
173 -- Normal version with error checking
175 procedure Set_Style_Check_Options
178 Err_Col
: out Natural)
182 procedure Add_Img
(N
: Natural);
183 -- Concatenates image of N at end of Style_Msg_Buf
185 procedure Bad_Style_Switch
(Msg
: String);
186 -- Called if bad style switch found. Msg is mset in Style_Msg_Buf and
187 -- Style_Msg_Len. OK is set False.
193 procedure Add_Img
(N
: Natural) is
199 Style_Msg_Len
:= Style_Msg_Len
+ 1;
200 Style_Msg_Buf
(Style_Msg_Len
) :=
201 Character'Val (N
mod 10 + Character'Pos ('0'));
204 ----------------------
205 -- Bad_Style_Switch --
206 ----------------------
208 procedure Bad_Style_Switch
(Msg
: String) is
211 Style_Msg_Len
:= Msg
'Length;
212 Style_Msg_Buf
(1 .. Style_Msg_Len
) := Msg
;
213 end Bad_Style_Switch
;
215 -- Start of processing for Set_Style_Check_Options
218 Err_Col
:= Options
'First;
219 while Err_Col
<= Options
'Last loop
220 C
:= Options
(Err_Col
);
221 Err_Col
:= Err_Col
+ 1;
225 Style_Check_Indentation
:=
226 Character'Pos (C
) - Character'Pos ('0');
229 Style_Check_Attribute_Casing
:= True;
232 Style_Check_Blanks_At_End
:= True;
235 Style_Check_Comments
:= True;
238 Style_Check_DOS_Line_Terminator
:= True;
241 Style_Check_End_Labels
:= True;
244 Style_Check_Form_Feeds
:= True;
247 Style_Check_Horizontal_Tabs
:= True;
250 Style_Check_If_Then_Layout
:= True;
253 Style_Check_Keyword_Casing
:= True;
256 Style_Check_Layout
:= True;
259 Style_Max_Nesting_Level
:= 0;
261 if Err_Col
> Options
'Last
262 or else Options
(Err_Col
) not in '0' .. '9'
264 Bad_Style_Switch
("invalid nesting level");
269 Style_Max_Nesting_Level
:=
270 Style_Max_Nesting_Level
* 10 +
271 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
273 if Style_Max_Nesting_Level
> 999 then
275 ("max nesting level (999) exceeded in style check");
279 Err_Col
:= Err_Col
+ 1;
280 exit when Err_Col
> Options
'Last
281 or else Options
(Err_Col
) not in '0' .. '9';
284 Style_Check_Max_Nesting_Level
:= Style_Max_Nesting_Level
/= 0;
287 Style_Check_Max_Line_Length
:= True;
288 Style_Max_Line_Length
:= 79;
291 Style_Max_Line_Length
:= 0;
293 if Err_Col
> Options
'Last
294 or else Options
(Err_Col
) not in '0' .. '9'
297 ("invalid line length in style check");
302 Style_Max_Line_Length
:=
303 Style_Max_Line_Length
* 10 +
304 Character'Pos (Options
(Err_Col
)) - Character'Pos ('0');
306 if Style_Max_Line_Length
> Int
(Max_Line_Length
) then
308 Style_Msg_Buf
(1 .. 27) := "max line length allowed is ";
310 Add_Img
(Natural (Max_Line_Length
));
314 Err_Col
:= Err_Col
+ 1;
315 exit when Err_Col
> Options
'Last
316 or else Options
(Err_Col
) not in '0' .. '9';
319 Style_Check_Max_Line_Length
:= Style_Max_Line_Length
/= 0;
322 Style_Check_Standard
:= True;
325 Reset_Style_Check_Options
;
328 Style_Check_Order_Subprograms
:= True;
331 Style_Check_Pragma_Casing
:= True;
334 Style_Check_References
:= True;
337 Style_Check_Specs
:= True;
340 Style_Check_Tokens
:= True;
343 Style_Check_Blank_Lines
:= True;
346 Style_Check_Xtra_Parens
:= True;
352 Err_Col
:= Err_Col
- 1;
353 Style_Msg_Buf
(1 .. 21) := "invalid style switch:";
355 Style_Msg_Buf
(Style_Msg_Len
) := C
;
363 end Set_Style_Check_Options
;