1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              V A L I D S W                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2001-2012, Free Software Foundation, Inc.         --
10--                                                                          --
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.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Opt; use Opt;
27
28package body Validsw is
29
30   ----------------------------------
31   -- Reset_Validity_Check_Options --
32   ----------------------------------
33
34   procedure Reset_Validity_Check_Options is
35   begin
36      Validity_Check_Components     := False;
37      Validity_Check_Copies         := False;
38      Validity_Check_Default        := True;
39      Validity_Check_Floating_Point := False;
40      Validity_Check_In_Out_Params  := False;
41      Validity_Check_In_Params      := False;
42      Validity_Check_Operands       := False;
43      Validity_Check_Returns        := False;
44      Validity_Check_Subscripts     := False;
45      Validity_Check_Tests          := False;
46   end Reset_Validity_Check_Options;
47
48   ---------------------------------
49   -- Save_Validity_Check_Options --
50   ---------------------------------
51
52   procedure Save_Validity_Check_Options
53     (Options : out Validity_Check_Options)
54   is
55      P : Natural := 0;
56
57      procedure Add (C : Character; S : Boolean);
58      --  Add given character C to string if switch S is true
59
60      procedure Add (C : Character; S : Boolean) is
61      begin
62         if S then
63            P := P + 1;
64            Options (P) := C;
65         end if;
66      end Add;
67
68   --  Start of processing for Save_Validity_Check_Options
69
70   begin
71      for K in Options'Range loop
72         Options (K) := ' ';
73      end loop;
74
75      Add ('n', not Validity_Check_Default);
76
77      Add ('c', Validity_Check_Copies);
78      Add ('e', Validity_Check_Components);
79      Add ('f', Validity_Check_Floating_Point);
80      Add ('i', Validity_Check_In_Params);
81      Add ('m', Validity_Check_In_Out_Params);
82      Add ('o', Validity_Check_Operands);
83      Add ('r', Validity_Check_Returns);
84      Add ('s', Validity_Check_Subscripts);
85      Add ('t', Validity_Check_Tests);
86   end Save_Validity_Check_Options;
87
88   ----------------------------------------
89   -- Set_Default_Validity_Check_Options --
90   ----------------------------------------
91
92   procedure Set_Default_Validity_Check_Options is
93   begin
94      Reset_Validity_Check_Options;
95      Set_Validity_Check_Options ("d");
96   end Set_Default_Validity_Check_Options;
97
98   --------------------------------
99   -- Set_Validity_Check_Options --
100   --------------------------------
101
102   --  Version used when no error checking is required
103
104   procedure Set_Validity_Check_Options (Options : String) is
105      OK : Boolean;
106      EC : Natural;
107      pragma Warnings (Off, OK);
108      pragma Warnings (Off, EC);
109   begin
110      Set_Validity_Check_Options (Options, OK, EC);
111   end Set_Validity_Check_Options;
112
113   --  Normal version with error checking
114
115   procedure Set_Validity_Check_Options
116     (Options  : String;
117      OK       : out Boolean;
118      Err_Col  : out Natural)
119   is
120      J : Natural;
121      C : Character;
122
123   begin
124      J := Options'First;
125      while J <= Options'Last loop
126         C := Options (J);
127         J := J + 1;
128
129         --  Turn on validity checking (gets turned off by Vn)
130
131         Validity_Checks_On := True;
132
133         case C is
134
135            when 'c' =>
136               Validity_Check_Copies         := True;
137
138            when 'd' =>
139               Validity_Check_Default        := True;
140
141            when 'e' =>
142               Validity_Check_Components     := True;
143
144            when 'f' =>
145               Validity_Check_Floating_Point := True;
146
147            when 'i' =>
148               Validity_Check_In_Params      := True;
149
150            when 'm' =>
151               Validity_Check_In_Out_Params  := True;
152
153            when 'o' =>
154               Validity_Check_Operands       := True;
155
156            when 'p' =>
157               Validity_Check_Parameters     := True;
158
159            when 'r' =>
160               Validity_Check_Returns        := True;
161
162            when 's' =>
163               Validity_Check_Subscripts     := True;
164
165            when 't' =>
166               Validity_Check_Tests          := True;
167
168            when 'C' =>
169               Validity_Check_Copies         := False;
170
171            when 'D' =>
172               Validity_Check_Default        := False;
173
174            when 'E' =>
175               Validity_Check_Components     := False;
176
177            when 'F' =>
178               Validity_Check_Floating_Point := False;
179
180            when 'I' =>
181               Validity_Check_In_Params      := False;
182
183            when 'M' =>
184               Validity_Check_In_Out_Params  := False;
185
186            when 'O' =>
187               Validity_Check_Operands       := False;
188
189            when 'P' =>
190               Validity_Check_Parameters     := False;
191
192            when 'R' =>
193               Validity_Check_Returns        := False;
194
195            when 'S' =>
196               Validity_Check_Subscripts     := False;
197
198            when 'T' =>
199               Validity_Check_Tests          := False;
200
201            when 'a' =>
202               Validity_Check_Components     := True;
203               Validity_Check_Copies         := True;
204               Validity_Check_Default        := True;
205               Validity_Check_Floating_Point := True;
206               Validity_Check_In_Out_Params  := True;
207               Validity_Check_In_Params      := True;
208               Validity_Check_Operands       := True;
209               Validity_Check_Parameters     := True;
210               Validity_Check_Returns        := True;
211               Validity_Check_Subscripts     := True;
212               Validity_Check_Tests          := True;
213
214            when 'n' =>
215               Validity_Check_Components     := False;
216               Validity_Check_Copies         := False;
217               Validity_Check_Default        := False;
218               Validity_Check_Floating_Point := False;
219               Validity_Check_In_Out_Params  := False;
220               Validity_Check_In_Params      := False;
221               Validity_Check_Operands       := False;
222               Validity_Check_Parameters     := False;
223               Validity_Check_Returns        := False;
224               Validity_Check_Subscripts     := False;
225               Validity_Check_Tests          := False;
226               Validity_Checks_On            := False;
227
228            when ' ' =>
229               null;
230
231            when others =>
232               OK      := False;
233               Err_Col := J - 1;
234               return;
235         end case;
236      end loop;
237
238      OK := True;
239      Err_Col := Options'Last + 1;
240   end Set_Validity_Check_Options;
241
242end Validsw;
243