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