1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Csets
; use Csets
;
30 with Einfo
; use Einfo
;
31 with Err_Vars
; use Err_Vars
;
32 with Namet
; use Namet
;
33 with Sinfo
; use Sinfo
;
34 with Sinput
; use Sinput
;
35 with Stand
; use Stand
;
36 with Stylesw
; use Stylesw
;
38 package body Styleg
.C
is
40 -----------------------
41 -- Body_With_No_Spec --
42 -----------------------
44 -- If the check specs mode (-gnatys) is set, then all subprograms must
45 -- have specs unless they are parameterless procedures that are not child
46 -- units at the library level (i.e. they are possible main programs).
48 procedure Body_With_No_Spec
(N
: Node_Id
) is
50 if Style_Check_Specs
then
51 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
53 Spec
: constant Node_Id
:= Specification
(N
);
54 Defnm
: constant Node_Id
:= Defining_Unit_Name
(Spec
);
57 if Nkind
(Spec
) = N_Procedure_Specification
58 and then Nkind
(Defnm
) = N_Defining_Identifier
59 and then No
(First_Formal
(Defnm
))
66 Error_Msg_N
("(style): subprogram body has no previous spec", N
);
68 end Body_With_No_Spec
;
70 ----------------------
71 -- Check_Identifier --
72 ----------------------
74 -- In check references mode (-gnatyr), identifier uses must be cased
75 -- the same way as the corresponding identifier declaration.
77 procedure Check_Identifier
78 (Ref
: Node_Or_Entity_Id
;
79 Def
: Node_Or_Entity_Id
)
81 Sref
: Source_Ptr
:= Sloc
(Ref
);
82 Sdef
: Source_Ptr
:= Sloc
(Def
);
83 Tref
: Source_Buffer_Ptr
;
84 Tdef
: Source_Buffer_Ptr
;
89 -- If reference does not come from source, nothing to check
91 if not Comes_From_Source
(Ref
) then
94 -- If previous error on either node/entity, ignore
96 elsif Error_Posted
(Ref
) or else Error_Posted
(Def
) then
99 -- Case of definition comes from source
101 elsif Comes_From_Source
(Def
) then
103 -- Check same casing if we are checking references
105 if Style_Check_References
then
106 Tref
:= Source_Text
(Get_Source_File_Index
(Sref
));
107 Tdef
:= Source_Text
(Get_Source_File_Index
(Sdef
));
109 -- Ignore operator name case completely. This also catches the
110 -- case of where one is an operator and the other is not. This
111 -- is a phenomenon from rewriting of operators as functions,
112 -- and is to be ignored.
114 if Tref
(Sref
) = '"' or else Tdef
(Sdef
) = '"' then
118 while Tref
(Sref
) = Tdef
(Sdef
) loop
120 -- If end of identifier, all done
122 if not Identifier_Char
(Tref
(Sref
)) then
125 -- Otherwise loop continues
133 -- Fall through loop when mismatch between identifiers
134 -- If either identifier is not terminated, error.
136 if Identifier_Char
(Tref
(Sref
))
138 Identifier_Char
(Tdef
(Sdef
))
140 Error_Msg_Node_1
:= Def
;
141 Error_Msg_Sloc
:= Sloc
(Def
);
143 ("(style) bad casing of & declared#", Sref
);
146 -- Else end of identifiers, and they match
154 -- Case of definition in package Standard
156 elsif Sdef
= Standard_Location
then
158 -- Check case of identifiers in Standard
160 if Style_Check_Standard
then
161 Tref
:= Source_Text
(Get_Source_File_Index
(Sref
));
165 if Tref
(Sref
) = '"' then
168 -- Otherwise determine required casing of Standard entity
171 -- ASCII entities are in all upper case
173 if Entity
(Ref
) = Standard_ASCII
then
174 Cas
:= All_Upper_Case
;
176 -- Special names in ASCII are also all upper case
178 elsif Entity
(Ref
) in SE
(S_LC_A
) .. SE
(S_LC_Z
)
180 Entity
(Ref
) in SE
(S_NUL
) .. SE
(S_US
)
182 Entity
(Ref
) = SE
(S_DEL
)
184 Cas
:= All_Upper_Case
;
186 -- All other entities are in mixed case
192 Nlen
:= Length_Of_Name
(Chars
(Ref
));
194 -- Now check if we have the right casing
197 (Tref
(Sref
.. Sref
+ Source_Ptr
(Nlen
) - 1)) = Cas
201 Name_Len
:= Integer (Nlen
);
202 Name_Buffer
(1 .. Name_Len
) :=
203 String (Tref
(Sref
.. Sref
+ Source_Ptr
(Nlen
) - 1));
205 Error_Msg_Name_1
:= Name_Enter
;
207 ("(style) bad casing of { declared in Standard", Ref
);
212 end Check_Identifier
;
214 -----------------------------------
215 -- Subprogram_Not_In_Alpha_Order --
216 -----------------------------------
218 procedure Subprogram_Not_In_Alpha_Order
(Name
: Node_Id
) is
220 if Style_Check_Order_Subprograms
then
222 ("(style) subprogram body& not in alphabetical order", Name
);
224 end Subprogram_Not_In_Alpha_Order
;