← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/rules-not_elaboration_calls.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-08-24 08:44:11 UTC
  • Revision ID: james.westby@ubuntu.com-20060824084411-1r15uio1h75lqgpx
Tags: upstream-1.4r20
Import upstream version 1.4r20

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/rules-not_elaboration_calls.adb
 
1
----------------------------------------------------------------------
 
2
--  Rules.Not_Elaboration_Calls - Package body                      --
 
3
--                                                                  --
 
4
--  This software  is (c) The European Organisation  for the Safety --
 
5
--  of Air  Navigation (EUROCONTROL) and Adalog  2004-2005. The Ada --
 
6
--  Controller  is  free software;  you can redistribute  it and/or --
 
7
--  modify  it under  terms of  the GNU  General Public  License as --
 
8
--  published by the Free Software Foundation; either version 2, or --
 
9
--  (at your  option) any later version.  This  unit is distributed --
 
10
--  in the hope  that it will be useful,  but WITHOUT ANY WARRANTY; --
 
11
--  without even the implied warranty of MERCHANTABILITY or FITNESS --
 
12
--  FOR A  PARTICULAR PURPOSE.  See the GNU  General Public License --
 
13
--  for more details.   You should have received a  copy of the GNU --
 
14
--  General Public License distributed  with this program; see file --
 
15
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
 
16
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
 
17
--                                                                  --
 
18
--  As  a special  exception, if  other files  instantiate generics --
 
19
--  from the units  of this program, or if you  link this unit with --
 
20
--  other files  to produce  an executable, this  unit does  not by --
 
21
--  itself cause the resulting executable  to be covered by the GNU --
 
22
--  General  Public  License.   This  exception  does  not  however --
 
23
--  invalidate any  other reasons why the executable  file might be --
 
24
--  covered by the GNU Public License.                              --
 
25
--                                                                  --
 
26
--  This  software is  distributed  in  the hope  that  it will  be --
 
27
--  useful,  but WITHOUT  ANY  WARRANTY; without  even the  implied --
 
28
--  warranty  of  MERCHANTABILITY   or  FITNESS  FOR  A  PARTICULAR --
 
29
--  PURPOSE.                                                        --
 
30
----------------------------------------------------------------------
 
31
 
 
32
-- Ada
 
33
with
 
34
  Ada.Strings.Wide_Unbounded;
 
35
 
 
36
-- Adalog
 
37
with
 
38
  Thick_Queries,
 
39
  Utilities;
 
40
 
 
41
-- Asis
 
42
with
 
43
  Asis.Elements;
 
44
 
 
45
-- Adactl
 
46
with
 
47
  Framework.Language,
 
48
  Framework.Reports,
 
49
  Framework.Rules_Manager,
 
50
  Framework.Scope_Manager;
 
51
 
 
52
package body Rules.Not_Elaboration_Calls is
 
53
   use Framework, Utilities;
 
54
 
 
55
   Rule_Used : Boolean := False;
 
56
   Save_Used : Boolean;
 
57
 
 
58
   Subprograms : Context_Store;
 
59
 
 
60
   ----------
 
61
   -- Help --
 
62
   ----------
 
63
 
 
64
   procedure Help is
 
65
   begin
 
66
      User_Message ("Rule: " & Rule_Id);
 
67
      User_Message ("Parameter(s): <subprogram name>");
 
68
      User_Message ("Control subprogram calls that happen elsewhere than as part");
 
69
      User_Message ("of the elaboration of a library package.");
 
70
   end Help;
 
71
 
 
72
   -------------
 
73
   -- Add_Use --
 
74
   -------------
 
75
 
 
76
   procedure Add_Use (Label         : in Wide_String;
 
77
                      Rule_Use_Type : in Rule_Types) is
 
78
      use Ada.Strings.Wide_Unbounded, Framework.Language;
 
79
   begin
 
80
      if not Parameter_Exists then
 
81
         Parameter_Error ("At least one parameter required for rule " & Rule_Id);
 
82
      end if;
 
83
 
 
84
      while Parameter_Exists loop
 
85
         declare
 
86
            Entity : constant Entity_Specification := Get_Entity_Parameter;
 
87
         begin
 
88
            Associate (Subprograms, Entity, Simple_Context'(Rule_Use_Type,
 
89
                                                            To_Unbounded_Wide_String (Label)));
 
90
         exception
 
91
            when Already_In_Store =>
 
92
               Parameter_Error ("Subprogram already given for rule " & Rule_Id
 
93
                                  & ": " & Image (Entity));
 
94
         end;
 
95
      end loop;
 
96
 
 
97
      Rule_Used  := True;
 
98
 
 
99
   end Add_Use;
 
100
 
 
101
   -------------
 
102
   -- Command --
 
103
   -------------
 
104
 
 
105
   procedure Command (Action : Framework.Rules_Manager.Rule_Action) is
 
106
      use Framework.Rules_Manager;
 
107
   begin
 
108
      case Action is
 
109
         when Clear =>
 
110
            Rule_Used := False;
 
111
            Clear (Subprograms);
 
112
         when Suspend =>
 
113
            Save_Used := Rule_Used;
 
114
            Rule_Used := False;
 
115
         when Resume =>
 
116
            Rule_Used := Save_Used;
 
117
      end case;
 
118
   end Command;
 
119
 
 
120
   -------------
 
121
   -- Prepare --
 
122
   -------------
 
123
 
 
124
   procedure Prepare is
 
125
   begin
 
126
      Balance (Subprograms);
 
127
   end Prepare;
 
128
 
 
129
   ------------------
 
130
   -- Process_Call --
 
131
   ------------------
 
132
 
 
133
   procedure Process_Call (Call : in Asis.Element) is
 
134
      use Ada.Strings.Wide_Unbounded, Thick_Queries;
 
135
      use Asis, Asis.Elements;
 
136
      Called_Subprogram  : Asis.Expression;
 
137
   begin
 
138
      if not Rule_Used then
 
139
         return;
 
140
      end if;
 
141
      Rules_Manager.Enter (Rule_Id);
 
142
 
 
143
      Called_Subprogram := Called_Simple_Name (Call);
 
144
      declare
 
145
         use Framework.Reports, Framework.Scope_Manager;
 
146
         Current_Context : Rule_Context'Class := Matching_Context (Subprograms,
 
147
                                                                   Called_Subprogram);
 
148
         Scopes          : constant Asis.Element_List := Active_Scopes;
 
149
      begin
 
150
         if Current_Context = No_Matching_Context then
 
151
            return;
 
152
         end if;
 
153
 
 
154
         -- The enclosing scopes must not contain any procedure, function or entry
 
155
         for I in Scopes'Range loop
 
156
            case Declaration_Kind (Scopes (I)) is
 
157
               when A_Procedure_Body_Declaration
 
158
                 | A_Function_Body_Declaration
 
159
                 | A_Task_Body_Declaration
 
160
                 | A_Protected_Body_Declaration
 
161
                 | An_Entry_Body_Declaration
 
162
                 =>
 
163
                  Report (Rule_Id,
 
164
                          To_Wide_String (Simple_Context (Current_Context).Rule_Label),
 
165
                          Simple_Context (Current_Context).Rule_Type,
 
166
                          Get_Location (Call),
 
167
                          "call of """ & To_Title (Last_Matching_Name (Subprograms)) & '"');
 
168
               when others =>
 
169
                  -- This covers :
 
170
                  --   all specifications (no call can happen there)
 
171
                  --   things that are not declarations, i.e. statements and exception
 
172
                  --   handlers
 
173
                  null;
 
174
            end case;
 
175
         end loop;
 
176
      end;
 
177
   end Process_Call;
 
178
 
 
179
begin
 
180
   Framework.Rules_Manager.Register (Rule_Id,
 
181
                                     Help    => Help'Access,
 
182
                                     Add_Use => Add_Use'Access,
 
183
                                     Command => Command'Access,
 
184
                                     Prepare => Prepare'Access);
 
185
end Rules.Not_Elaboration_Calls;