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