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