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-2019, 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        := False;
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_Parameters     := False;
45      Validity_Check_Returns        := False;
46      Validity_Check_Subscripts     := False;
47      Validity_Check_Tests          := False;
48   end Reset_Validity_Check_Options;
49
50   ---------------------------------
51   -- Save_Validity_Check_Options --
52   ---------------------------------
53
54   procedure Save_Validity_Check_Options
55     (Options : out Validity_Check_Options)
56   is
57      P : Natural := 0;
58
59      procedure Add (C : Character; S : Boolean);
60      --  Add given character C to string if switch S is true
61
62      procedure Add (C : Character; S : Boolean) is
63      begin
64         if S then
65            P := P + 1;
66            Options (P) := C;
67         end if;
68      end Add;
69
70   --  Start of processing for Save_Validity_Check_Options
71
72   begin
73      for K in Options'Range loop
74         Options (K) := ' ';
75      end loop;
76
77      Add ('e', Validity_Check_Components);
78      Add ('c', Validity_Check_Copies);
79      Add ('d', Validity_Check_Default);
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 ('p', Validity_Check_Parameters);
85      Add ('r', Validity_Check_Returns);
86      Add ('s', Validity_Check_Subscripts);
87      Add ('t', Validity_Check_Tests);
88   end Save_Validity_Check_Options;
89
90   ----------------------------------------
91   -- Set_Default_Validity_Check_Options --
92   ----------------------------------------
93
94   procedure Set_Default_Validity_Check_Options is
95   begin
96      Reset_Validity_Check_Options;
97      Set_Validity_Check_Options ("d");
98   end Set_Default_Validity_Check_Options;
99
100   --------------------------------
101   -- Set_Validity_Check_Options --
102   --------------------------------
103
104   --  Version used when no error checking is required
105
106   procedure Set_Validity_Check_Options (Options : String) is
107      OK : Boolean;
108      EC : Natural;
109      pragma Warnings (Off, OK);
110      pragma Warnings (Off, EC);
111   begin
112      Set_Validity_Check_Options (Options, OK, EC);
113   end Set_Validity_Check_Options;
114
115   --  Normal version with error checking
116
117   procedure Set_Validity_Check_Options
118     (Options  : String;
119      OK       : out Boolean;
120      Err_Col  : out Natural)
121   is
122      J : Natural;
123      C : Character;
124
125   begin
126      J := Options'First;
127      while J <= Options'Last loop
128         C := Options (J);
129         J := J + 1;
130
131         --  Turn on validity checking (gets turned off by Vn)
132
133         Validity_Checks_On := True;
134
135         case C is
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         end case;
241      end loop;
242
243      OK := True;
244      Err_Col := Options'Last + 1;
245   end Set_Validity_Check_Options;
246
247end Validsw;
248