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-2018, 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            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               if Ignore_Unrecognized_VWY_Switches then
233                  Write_Line ("unrecognized switch -gnatV" & C & " ignored");
234               else
235                  OK      := False;
236                  Err_Col := J - 1;
237                  return;
238               end if;
239         end case;
240      end loop;
241
242      OK := True;
243      Err_Col := Options'Last + 1;
244   end Set_Validity_Check_Options;
245
246end Validsw;
247