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