1/* Lots of little arg checks. Global for convenience. 2 */ 3 4check_any = [(const true), _ "any"]; 5check_bool = [is_bool, _ "boolean"]; 6check_real = [is_real, _ "real"]; 7check_ureal = [is_ureal, _ "unsigned real"]; 8check_preal = [is_preal, _ "positive real"]; 9check_list = [is_list, _ "list"]; 10check_real_list = [is_real_list, _ "list of real"]; 11check_string = [is_string, _ "string"]; 12check_string_list = [is_string_list, _ "list of string"]; 13check_int = [is_int, _ "integer"]; 14check_uint = [is_uint, _ "unsigned integer"]; 15check_pint = [is_pint, _ "positive integer"]; 16check_matrix = [is_matrix, _ "rectangular array of real"]; 17check_matrix_display = [Matrix_display.is_display, _ "0|1|2|3"]; 18check_image = [is_image, _ "image"]; 19check_xy_list = [is_xy_list, _ "list of form [[1, 2], [3, 4], [5, 6], ...]"]; 20check_instance name = [is_instanceof name, name]; 21check_Image = check_instance "Image"; 22check_Matrix = [is_Matrix, _ "Matrix"]; 23check_colour_space = [is_colour_space, 24 join_sep "|" Image_type.colour_spaces.names]; 25check_rectangular = [is_rectangular, _ "rectangular [[*]]"]; 26check_Guide = [is_Guide, _ "HGuide|VGuide"]; 27check_Colour = check_instance (_ "Colour"); 28check_Mark = check_instance (_ "Mark"); 29 30/* Check a set of args to a class. Two members to look at: _check_args and 31 * _check_all. 32 * 33 * - each line in _check_args is [arg, "arg name", [test_fn, "arg type"]] 34 * same number of lines as there are args 35 * 36 * stuff like "arg 2 must be real" 37 * 38 * - each line in _check_all is [test, "description"] 39 * any number of lines 40 * 41 * stuff like "to must be greater than from" 42 * 43 * generate an error dialog with a helpful message on failure. 44 * 45 * Have as a separate function to try to keep the size of _Object down. 46 */ 47check_args x 48 = error message, badargs != [] || badalls != [] 49 = x 50{ 51 argcheck = x._check_args; 52 allcheck = x._check_all; 53 54 // indent string 55 indent = " "; 56 57 // test for a condition in a check line fails 58 test_fail x = ! x?0; 59 60 // set of failed argcheck indexes 61 badargs = map (extract 1) 62 (filter test_fail (zip2 (map testarg argcheck) [0..])) 63 { 64 testarg x = x?2?0 x?0; 65 } 66 67 // set of failed allcheck indexes 68 badalls = map (extract 1) 69 (filter test_fail (zip2 (map hd allcheck) [0..])); 70 71 // the error message 72 message = _ "bad properties for " ++ "\"" ++ x.name ++ "\"\n" ++ 73 argmsg ++ allmsg ++ "\n" ++ 74 _ "where" ++ "\n" ++ arg_types ++ extra; 75 76 // make the failed argcheck messages ... eg. ""value" should be 77 // real, you passed <function>" etc. 78 argmsg = concat (map fmt badargs) 79 { 80 fmt n = indent ++ "\"" ++ argcheck?n?1 ++ "\"" ++ 81 _ " should be of type " ++ argcheck?n?2?1 ++ ", " ++ 82 _ "you passed" ++ ":\n" ++ 83 indent ++ indent ++ print argcheck?n?0 ++ "\n"; 84 } 85 86 // make the failed allcheck messages ... eg "condition failed: 87 // x < y" ... don't make a message if any typechecks have 88 // failed, as we'll probably error horribly 89 allmsg 90 = [], badargs != [] 91 = concat (map fmt badalls) ++ 92 _ "you passed" ++ "\n" ++ 93 concat (map fmt_arg argcheck) 94 { 95 fmt n = _ "condition failed" ++ ": " ++ allcheck?n?1 ++ "\n"; 96 fmt_arg l = indent ++ l?1 ++ " = " ++ print l?0 ++ "\n"; 97 } 98 99 // make arg type notes 100 arg_types = join_sep "\n" (map fmt argcheck) 101 { 102 fmt l = indent ++ l?1 ++ " is of type " ++ l?2?1; 103 } 104 105 // extra bit at the bottom, if we have any conditions 106 extra 107 = [], allcheck == [] 108 = "\n" ++ _ "and" ++ "\n" ++ all_desc; 109 110 // make a list of all the allcheck descriptions, with a few 111 // spaces in front 112 all_desc_list = map (join indent @ extract 1) allcheck; 113 114 // join em up to make a set of condition notes 115 all_desc = join_sep "\n" all_desc_list; 116} 117 118/* Operator overloading stuff. 119 */ 120 121Operator_type = class { 122 ARITHMETIC = 1; // eg. add 123 RELATIONAL = 2; // eg. less 124 COMPOUND = 3; // eg. max/mean/etc. 125 COMPOUND_REWRAP = 4; // eg. transpose 126} 127 128Operator op_name fn type symmetric = class { 129} 130 131/* Form the converse of an Operator. 132 */ 133oo_converse op 134 = Operator (converse_name op.op_name) 135 (converse op.fn) op.type op.symmetric 136{ 137 converse_name x 138 = init x, last x == last "'" 139 = x ++ "'"; 140} 141 142/* Given an operator name, look up the definition. 143 */ 144oo_binary_lookup op_name 145 = matches?0, matches != [] 146 = error (_ "unknown binary operator" ++ ": " ++ print op_name) 147{ 148 operator_table = [ 149 Operator "add" add 150 Operator_type.ARITHMETIC true, 151 Operator "subtract" subtract 152 Operator_type.ARITHMETIC false, 153 Operator "remainder" remainder 154 Operator_type.ARITHMETIC false, 155 Operator "power" power 156 Operator_type.ARITHMETIC false, 157 Operator "subscript" subscript 158 Operator_type.ARITHMETIC false, 159 Operator "left_shift" left_shift 160 Operator_type.ARITHMETIC false, 161 Operator "right_shift" right_shift 162 Operator_type.ARITHMETIC false, 163 Operator "divide" divide 164 Operator_type.ARITHMETIC false, 165 Operator "join" join 166 Operator_type.ARITHMETIC false, 167 Operator "multiply" multiply 168 Operator_type.ARITHMETIC true, 169 Operator "logical_and" logical_and 170 Operator_type.ARITHMETIC true, 171 Operator "logical_or" logical_or 172 Operator_type.ARITHMETIC true, 173 Operator "bitwise_and" bitwise_and 174 Operator_type.ARITHMETIC true, 175 Operator "bitwise_or" bitwise_or 176 Operator_type.ARITHMETIC true, 177 Operator "eor" eor 178 Operator_type.ARITHMETIC true, 179 Operator "comma" comma 180 Operator_type.ARITHMETIC false, 181 Operator "if_then_else" if_then_else 182 Operator_type.ARITHMETIC false, 183 Operator "equal" equal 184 Operator_type.RELATIONAL true, 185 Operator "not_equal" not_equal 186 Operator_type.RELATIONAL true, 187 Operator "less" less 188 Operator_type.RELATIONAL false, 189 Operator "less_equal" less_equal 190 Operator_type.RELATIONAL false 191 ]; 192 193 matches = filter test_name operator_table; 194 test_name x = x.op_name == op_name; 195} 196 197/* Given an operator name, look up a function that implements that 198 * operator. 199 */ 200oo_unary_lookup op_name 201 = matches?0, matches != [] 202 = error (_ "unknown unary operator" ++ ": " ++ print op_name) 203{ 204 operator_table = [ 205 /* Operators. 206 */ 207 Operator "cast_signed_char" cast_signed_char 208 Operator_type.ARITHMETIC false, 209 Operator "cast_unsigned_char" cast_unsigned_char 210 Operator_type.ARITHMETIC false, 211 Operator "cast_signed_short" cast_signed_short 212 Operator_type.ARITHMETIC false, 213 Operator "cast_unsigned_short" cast_unsigned_short 214 Operator_type.ARITHMETIC false, 215 Operator "cast_signed_int" cast_signed_int 216 Operator_type.ARITHMETIC false, 217 Operator "cast_unsigned_int" cast_unsigned_int 218 Operator_type.ARITHMETIC false, 219 Operator "cast_float" cast_float 220 Operator_type.ARITHMETIC false, 221 Operator "cast_double" cast_double 222 Operator_type.ARITHMETIC false, 223 Operator "cast_complex" cast_complex 224 Operator_type.ARITHMETIC false, 225 Operator "cast_double_complex" cast_double_complex 226 Operator_type.ARITHMETIC false, 227 Operator "unary_minus" unary_minus 228 Operator_type.ARITHMETIC false, 229 Operator "negate" negate 230 Operator_type.RELATIONAL false, 231 Operator "complement" complement 232 Operator_type.ARITHMETIC false, 233 Operator "unary_plus" unary_plus 234 Operator_type.ARITHMETIC false, 235 236 /* Built in projections. 237 */ 238 Operator "re" re Operator_type.ARITHMETIC false, 239 Operator "im" im Operator_type.ARITHMETIC false, 240 Operator "hd" hd Operator_type.ARITHMETIC false, 241 Operator "tl" tl Operator_type.ARITHMETIC false, 242 243 /* Maths builtins. 244 */ 245 Operator "sin" sin Operator_type.ARITHMETIC false, 246 Operator "cos" cos Operator_type.ARITHMETIC false, 247 Operator "tan" tan Operator_type.ARITHMETIC false, 248 Operator "asin" asin Operator_type.ARITHMETIC false, 249 Operator "acos" acos Operator_type.ARITHMETIC false, 250 Operator "atan" atan Operator_type.ARITHMETIC false, 251 Operator "log" log Operator_type.ARITHMETIC false, 252 Operator "log10" log10 Operator_type.ARITHMETIC false, 253 Operator "exp" exp Operator_type.ARITHMETIC false, 254 Operator "exp10" exp10 Operator_type.ARITHMETIC false, 255 Operator "ceil" ceil Operator_type.ARITHMETIC false, 256 Operator "floor" floor Operator_type.ARITHMETIC false 257 ]; 258 259 matches = filter test_name operator_table; 260 test_name x = x.op_name == op_name; 261} 262 263/* Find the matching methods in a method table. 264 */ 265oo_method_lookup table = map (extract 0) (filter (extract 1) table); 266 267/* A binary op: a is a class, b may be a class ... eg. "add" a b 268 269 two obvious ways to find a method: 270 271 - a.oo_binary_search "add" (+) b 272 - b.oo_binary_search "add'" (converse (+)) a, is_class b 273 274 if these fail but op is a symmetric operator (eg. a + b == b + a), we can 275 also try reversing the args 276 277 - a.oo_binary_search "add'" (converse (+)) b 278 - b.oo_binary_search "add" (+) a, is_class b 279 280 if those fail as well, but this is ==, do pointer equals as a fallback 281 282 */ 283oo_binary_function op a b 284 = matches1?0, 285 matches1 != [] 286 = matches2?0, 287 is_class b && matches2 != [] 288 = matches3?0, 289 op.symmetric && matches3 != [] 290 = matches4?0, 291 op.symmetric && is_class b && matches4 != [] 292 = pointer_equal a b, 293 op.op_name == "equal" || op.op_name == "equal'" 294 = not_pointer_equal a b, 295 op.op_name == "not_equal" || op.op_name == "not_equal'" 296 = error (_ "No method found for binary operator." ++ "\n" ++ 297 _ "left" ++ " = " ++ print a ++ "\n" ++ 298 _ "operator" ++ " = " ++ op.op_name ++ "\n" ++ 299 _ "right" ++ " = " ++ print b) 300{ 301 matches1 = oo_method_lookup (a.oo_binary_table op b); 302 matches2 = oo_method_lookup (b.oo_binary_table (oo_converse op) a); 303 matches3 = oo_method_lookup (a.oo_binary_table (oo_converse op) b); 304 matches4 = oo_method_lookup (b.oo_binary_table op a); 305} 306 307/* A binary op: a is not a class, b is a class ... eg. "subtract" a b 308 309 only one way to find a method: 310 311 - b.oo_binary_search "subtract'" (converse (-)) a 312 313 if this fails but op is a symmetric operator (eg. a + b == b + a), we can 314 try reversing the args 315 316 - b.oo_binary_search "add" (+) a, is_class b 317 318 if that fails as well, but this is ==, do pointer equals as a fallback 319 320 */ 321oo_binary'_function op a b 322 = matches1?0, matches1 != [] 323 = matches2?0, op.symmetric && matches2 != [] 324 = pointer_equal a b, 325 op.op_name == "equal" || op.op_name == "equal'" 326 = not_pointer_equal a b, 327 op.op_name == "not_equal" || op.op_name == "not_equal'" 328 = error (_ "No method found for binary operator." ++ "\n" ++ 329 _ "left" ++ " = " ++ print a ++ "\n" ++ 330 _ "operator" ++ " = " ++ op.op_name ++ "\n" ++ 331 _ "right" ++ " = " ++ print b) 332{ 333 matches1 = oo_method_lookup (b.oo_binary_table (oo_converse op) a); 334 matches2 = oo_method_lookup (b.oo_binary_table op a); 335} 336 337oo_unary_function op x 338 = matches?0, matches != [] 339 = error (_ "No method found for unary operator." ++ "\n" ++ 340 _ "operator" ++ " = " ++ op.op_name ++ "\n" ++ 341 _ "argument" ++ " = " ++ print x) 342{ 343 matches = oo_method_lookup (x.oo_unary_table op); 344} 345 346/* Base class for nip's built-in classes ... base check function, base 347 * operator overload functions. 348 */ 349_Object = class { 350 check = check_args this; 351 352 // these should always be defined 353 _check_args = []; 354 _check_all = []; 355 356 /* Operator overloading stuff. 357 */ 358 oo_binary op x = oo_binary_function (oo_binary_lookup op) this x; 359 oo_binary' op x = oo_binary'_function (oo_binary_lookup op) x this; 360 oo_unary op = oo_unary_function (oo_unary_lookup op) this; 361 362 oo_binary_table op x = []; 363 oo_unary_table op = []; 364} 365