5164
|
1 /* |
|
2 |
|
3 Copyright (C) 2001 John W. Eaton and Paul Kienzle |
|
4 |
|
5 This program is free software; you can redistribute it and/or modify it |
|
6 under the terms of the GNU General Public License as published by the |
|
7 Free Software Foundation; either version 2, or (at your option) any |
|
8 later version. |
|
9 |
|
10 This program is distributed in the hope that it will be useful, but WITHOUT |
|
11 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
12 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
13 for more details. |
|
14 |
|
15 You should have received a copy of the GNU General Public License |
|
16 along with Octave; see the file COPYING. If not, write to the Free |
|
17 Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|
18 |
|
19 */ |
|
20 |
|
21 #ifdef HAVE_CONFIG_H |
|
22 #include <config.h> |
|
23 #endif |
|
24 |
|
25 #include <list> |
|
26 #include <map> |
|
27 #include <string> |
|
28 |
|
29 #include "defun-dld.h" |
|
30 #include "ov.h" |
|
31 #include "ov-fcn.h" |
|
32 #include "ov-typeinfo.h" |
|
33 #include "pager.h" |
|
34 #include "parse.h" |
|
35 #include "symtab.h" |
|
36 #include "variables.h" |
|
37 |
|
38 // XXX FIXME XXX should be using a map from type_id->name, rather |
|
39 // than type_name->name |
|
40 |
|
41 template class std::map<std::string,std::string>; |
|
42 |
|
43 typedef std::map<std::string,std::string> Table; |
|
44 |
|
45 class |
|
46 octave_dispatch : public octave_function |
|
47 { |
|
48 public: |
|
49 |
|
50 // XXX FIXME XXX need to handle doc strings of dispatched functions, for |
|
51 // example, by appending "for <f>(<type>,...) see <name>" for each |
|
52 // time dispatch(f,type,name) is called. |
|
53 octave_dispatch (const std::string &nm) |
|
54 : octave_function (nm, "Overloaded function"), tab (), base (nm), |
|
55 has_alias (false) |
|
56 { } |
|
57 |
|
58 // XXX FIXME XXX if we get deleted, we should restore the original |
|
59 // symbol_record from base before dying. |
|
60 ~octave_dispatch (void) { } |
|
61 |
|
62 bool is_builtin_function (void) const { return true; } |
|
63 |
|
64 octave_function *function_value (bool) { return this; } |
|
65 |
|
66 octave_value do_index_op (const octave_value_list&, int) |
|
67 { |
|
68 error ("dispatch: do_index_op"); |
|
69 return octave_value (); |
|
70 } |
|
71 |
|
72 octave_value subsref (const std::string&, |
|
73 const std::list<octave_value_list>&) |
|
74 { |
|
75 error ("dispatch: subsref (str, list)"); |
|
76 panic_impossible (); |
|
77 return octave_value (); |
|
78 } |
|
79 |
|
80 octave_value_list subsref (const std::string& type, |
|
81 const std::list<octave_value_list>& idx, |
|
82 int nargout); |
|
83 |
|
84 octave_value_list do_multi_index_op (int, const octave_value_list&); |
|
85 |
|
86 void add (const std::string t, const std::string n); |
|
87 |
|
88 void clear (const std::string t); |
|
89 |
|
90 void print (std::ostream& os, bool pr_as_read=false) const; |
|
91 |
|
92 private: |
|
93 |
|
94 Table tab; |
|
95 std::string base; |
|
96 bool has_alias; |
|
97 |
|
98 octave_dispatch (void) |
|
99 : octave_function (), tab (), base (), has_alias (false) { } |
|
100 |
|
101 DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA |
|
102 |
|
103 DECLARE_OCTAVE_ALLOCATOR |
|
104 }; |
|
105 |
|
106 DEFINE_OCTAVE_ALLOCATOR (octave_dispatch); |
|
107 |
|
108 DEFINE_OV_TYPEID_FUNCTIONS_AND_DATA (octave_dispatch, |
|
109 "overloaded function", "function"); |
|
110 |
|
111 void |
|
112 octave_dispatch::add (const std::string t, const std::string n) |
|
113 { |
|
114 if (tab.count (t) > 0 && tab[t] != n) |
|
115 warning ("replacing %s(%s,...)->%s with %s", |
|
116 base.c_str (), t.c_str (), tab[t].c_str (), n.c_str ()); |
|
117 |
|
118 tab[t] = n; |
|
119 |
|
120 if (t == "any") |
|
121 has_alias = true; |
|
122 } |
|
123 |
|
124 void |
|
125 octave_dispatch::clear (const std::string t) |
|
126 { |
|
127 tab.erase (t); |
|
128 |
|
129 if (t == "any") |
|
130 has_alias = false; |
|
131 } |
|
132 |
|
133 octave_value_list |
|
134 octave_dispatch::subsref (const std::string& type, |
|
135 const std::list<octave_value_list>& idx, |
|
136 int nargout) |
|
137 { |
|
138 octave_value_list retval; |
|
139 |
|
140 switch (type[0]) |
|
141 { |
|
142 case '(': |
|
143 retval = do_multi_index_op (nargout, idx.front ()); |
|
144 break; |
|
145 |
|
146 case '{': |
|
147 case '.': |
|
148 { |
|
149 const std::string nm = type_name (); |
|
150 error ("%s cannot be indexed with %c", nm.c_str (), type[0]); |
|
151 } |
|
152 break; |
|
153 |
|
154 default: |
|
155 panic_impossible (); |
|
156 } |
|
157 |
|
158 if (idx.size () > 1) |
|
159 retval = retval(0).next_subsref (type, idx); |
|
160 |
|
161 return retval; |
|
162 } |
|
163 |
|
164 static octave_function* |
|
165 builtin (const std::string& base) |
|
166 { |
|
167 octave_function *fcn = 0; |
|
168 |
|
169 // Check if we are overriding a builtin function. This is the |
|
170 // case if builtin is protected. |
|
171 symbol_record *builtin = fbi_sym_tab->lookup ("builtin:" + base, 0); |
|
172 |
|
173 if (! builtin) |
|
174 error ("builtin record has gone missing"); |
|
175 |
|
176 if (error_state) |
|
177 return fcn; |
|
178 |
|
179 if (builtin->is_read_only ()) |
|
180 { |
|
181 // builtin is read only, so checking for updates is pointless |
|
182 if (builtin->is_function ()) |
|
183 fcn = builtin->def().function_value (); |
|
184 else |
|
185 error ("builtin %s is not a function", base.c_str ()); |
|
186 } |
|
187 else |
|
188 { |
|
189 // Check that builtin is up to date. |
|
190 |
|
191 // Don't try to fight octave's function name handling |
|
192 // mechanism. Instead, move dispatch record out of the way, |
|
193 // and restore the builtin to its original name. |
|
194 symbol_record *dispatch = fbi_sym_tab->lookup (base, 0); |
|
195 if (! dispatch) |
|
196 error ("dispatch record has gone missing"); |
|
197 |
|
198 dispatch->unprotect (); |
|
199 |
|
200 fbi_sym_tab->rename (base, "dispatch:" + base); |
|
201 |
|
202 fbi_sym_tab->rename ("builtin:" + base, base); |
|
203 |
|
204 // check for updates to builtin function; ignore errors that |
|
205 // appear (they interfere with renaming), and remove the updated |
|
206 // name from the current symbol table. XXX FIXME XXX check that |
|
207 // updating a function updates it in all contexts --- it may be |
|
208 // that it is updated only in the current symbol table, and not |
|
209 // the caller. I believe this won't be a problem because the |
|
210 // caller will go through the same logic and end up with the |
|
211 // newer version. |
|
212 fcn = is_valid_function (base, "dispatch", 1); |
|
213 int cache_error = error_state; |
|
214 error_state = 0; |
|
215 curr_sym_tab->clear_function (base); |
|
216 |
|
217 // Move the builtin function out of the way and restore the |
|
218 // dispatch fuction. |
|
219 // XXX FIXME XXX what if builtin wants to protect itself? |
|
220 symbol_record *found=fbi_sym_tab->lookup (base, 0); |
|
221 bool readonly = found->is_read_only (); |
|
222 found->unprotect (); |
|
223 fbi_sym_tab->rename (base, "builtin:" + base); |
|
224 fbi_sym_tab->rename ("dispatch:" + base, base); |
|
225 if (readonly) |
|
226 found->protect (); |
|
227 dispatch->protect (); |
|
228 |
|
229 // remember if there were any errors. |
|
230 error_state = cache_error; |
|
231 } |
|
232 |
|
233 return fcn; |
|
234 } |
|
235 |
|
236 static bool |
|
237 any_arg_is_magic_colon (const octave_value_list& args) |
|
238 { |
|
239 int nargin = args.length (); |
|
240 |
|
241 for (int i = 0; i < nargin; i++) |
|
242 if (args(i).is_magic_colon ()) |
|
243 return true; |
|
244 |
|
245 return false; |
|
246 } |
|
247 |
|
248 |
|
249 octave_value_list |
|
250 octave_dispatch::do_multi_index_op (int nargout, const octave_value_list& args) |
|
251 { |
|
252 octave_value_list retval; |
|
253 |
|
254 if (error_state) return retval; |
|
255 |
|
256 if (any_arg_is_magic_colon (args)) |
|
257 { |
|
258 ::error ("invalid use of colon in function argument list"); |
|
259 return retval; |
|
260 } |
|
261 |
|
262 // If more than one argument, check if argument template matches any |
|
263 // overloaded functions. Also provide a catch-all '*' type to provide |
|
264 // single level pseudo rename and replace functionality. |
|
265 if (args.length () > 0 && tab.count (args(0).type_name ()) > 0) |
|
266 retval = feval (tab[args(0).type_name()], args, nargout); |
|
267 else if (has_alias) |
|
268 retval = feval (tab["any"], args, nargout); |
|
269 else |
|
270 { |
|
271 octave_function *fcn = builtin (base); |
|
272 if (! error_state && fcn) |
|
273 retval = fcn->do_multi_index_op (nargout, args); |
|
274 } |
|
275 |
|
276 return retval; |
|
277 } |
|
278 |
|
279 void |
|
280 octave_dispatch::print (std::ostream& os, bool) const |
|
281 { |
|
282 os << "Overloaded function " << base << std::endl; |
|
283 |
|
284 for (Table::const_iterator it = tab.begin (); it != tab.end (); it++) |
|
285 os << base << "(" << it->first << ",...)->" |
|
286 << it->second << "(" << it->first << ",...)" |
|
287 << std::endl; |
|
288 } |
|
289 |
|
290 DEFUN_DLD (builtin, args, nargout, |
|
291 "-*- texinfo -*-\n\ |
|
292 @deftypefn {Loadable Function} {[@dots{}]} builtin (@var{f}, @dots{})\n\ |
|
293 Call the base function @var{f} even if @var{f} is overloaded to\n\ |
|
294 some other function for the given type signature.\n\ |
|
295 @end deftypefn\n\ |
|
296 @seealso{dispatch}") |
|
297 { |
|
298 octave_value_list retval; |
|
299 |
|
300 int nargin = args.length (); |
|
301 |
|
302 if (nargin > 0) |
|
303 { |
|
304 const std::string name (args(0).string_value ()); |
|
305 |
|
306 if (error_state) |
|
307 return retval; |
|
308 |
|
309 symbol_record *sr = fbi_sym_tab->lookup (name, 0); |
5200
|
310 |
|
311 if (sr) |
5164
|
312 { |
5200
|
313 if (sr->def().type_id () == octave_dispatch::static_type_id ()) |
|
314 { |
|
315 octave_function *fcn = builtin (name); |
5164
|
316 |
5200
|
317 if (!error_state && fcn) |
|
318 retval = fcn->do_multi_index_op (nargout, |
|
319 args.splice (0, 1, retval)); |
|
320 } |
|
321 else |
|
322 retval = feval (name, args, nargout); |
5164
|
323 } |
|
324 else |
5200
|
325 error ("builtin: lookup for symbol `%s' failed", name.c_str ()); |
5164
|
326 } |
|
327 else |
|
328 print_usage ("builtin"); |
|
329 |
|
330 return retval; |
|
331 } |
|
332 |
|
333 DEFUN_DLD (dispatch_help, args, nargout, |
|
334 "-*- texinfo -*-\n\ |
|
335 @deftypefn {Loadable Function} {} dispatch_help (@var{name}, @dots{})\n\ |
|
336 Delayed loading of help messages for dispatched functions.\n\ |
|
337 @end deftypefn\n\ |
|
338 @seealso{builtin, dispatch}") |
|
339 { |
|
340 octave_value_list retval; |
|
341 |
|
342 int nargin = args.length (); |
|
343 |
|
344 for (int i = 0; i < nargin; i++) |
|
345 { |
|
346 if (args(i).is_string ()) |
|
347 { |
|
348 const std::string name (args(i).string_value ()); |
|
349 |
|
350 if (error_state) |
|
351 return retval; |
|
352 |
|
353 symbol_record *sr = fbi_sym_tab->lookup (name, false); |
|
354 |
|
355 if (sr) |
|
356 { |
|
357 std::string help = sr->help (); |
|
358 |
|
359 if (help[0] == '<' && help[1] == '>' |
|
360 && sr->def().type_id () == octave_dispatch::static_type_id ()) |
|
361 { |
|
362 builtin (name); |
|
363 |
|
364 symbol_record *builtin_record |
|
365 = fbi_sym_tab->lookup ("builtin:" + name, 0); |
|
366 |
|
367 help.replace (0, 2, builtin_record->help ()); |
|
368 |
|
369 sr->document (help); |
|
370 } |
|
371 } |
|
372 } |
|
373 } |
|
374 |
|
375 return feval ("builtin:help", args, nargout); |
|
376 } |
|
377 |
|
378 static void |
|
379 dispatch_record (const std::string &f, const std::string &n, |
|
380 const std::string &t) |
|
381 { |
|
382 // find the base function in the symbol table, loading it if it |
|
383 // is not already there; if it is already a dispatch, then bonus |
|
384 |
|
385 symbol_record *sr = fbi_sym_tab->lookup (f, true); |
|
386 |
|
387 if (sr->def().type_id () != octave_dispatch::static_type_id ()) |
|
388 { |
|
389 // Preserve mark_as_command status |
|
390 bool iscommand = sr->is_command (); |
|
391 |
|
392 // Not an overloaded name, so if only display or clear then we are done |
|
393 if (t.empty ()) |
|
394 return; |
|
395 |
|
396 // sr is the base symbol; rename it to keep it safe. When we need |
|
397 // it we will rename it back again. |
|
398 if (sr->is_read_only ()) |
|
399 { |
|
400 sr->unprotect (); |
|
401 fbi_sym_tab->rename (f, "builtin:" + f); |
|
402 sr = fbi_sym_tab->lookup (f, true); |
|
403 sr->protect (); |
|
404 } |
|
405 else |
|
406 fbi_sym_tab->rename (f, "builtin:" + f); |
|
407 |
|
408 std::string basedoc ("<>"); |
|
409 |
|
410 if (! sr->help().empty ()) |
|
411 basedoc = sr->help (); |
|
412 |
|
413 // Problem: when a function is first called a new record |
|
414 // is created for it in the current symbol table, so calling |
|
415 // dispatch on a function that has already been called, we |
|
416 // should also clear it from all existing symbol tables. |
|
417 // This is too much work, so we will only do it for the |
|
418 // top level symbol table. We can't use the clear_function() |
|
419 // method, because it won't clear builtin functions. Instead |
|
420 // we check if the symbol is a function and clear it then. This |
|
421 // won't properly clear shadowed functions, or functions in |
|
422 // other namespaces (such as the current, if called from a |
|
423 // function). |
|
424 symbol_record *local = top_level_sym_tab->lookup (f, false); |
|
425 if (local && local->is_function ()) |
|
426 local->clear (); |
|
427 |
|
428 // Build a new dispatch object based on the function definition |
|
429 octave_dispatch *dispatch = new octave_dispatch (f); |
|
430 |
|
431 // Create a symbol record for the dispatch object. |
|
432 sr = fbi_sym_tab->lookup (f, true); |
|
433 sr->unprotect (); |
|
434 sr->define (octave_value (dispatch), symbol_record::BUILTIN_FUNCTION); |
|
435 // std::cout << "iscommand('"<<f<<"')=" << iscommand << std::endl; |
|
436 if (iscommand) |
|
437 sr->mark_as_command(); |
5300
|
438 sr->document (basedoc + "\n\n@noindent\nOverloaded function:\n"); |
5164
|
439 sr->make_eternal (); // XXX FIXME XXX why?? |
|
440 sr->mark_as_static (); |
|
441 sr->protect (); |
|
442 } |
|
443 |
|
444 // clear/replace/extend the map with the new type-function pair |
|
445 const octave_dispatch& rep |
|
446 = reinterpret_cast<const octave_dispatch&> (sr->def().get_rep ()); |
|
447 |
|
448 if (t.empty ()) |
|
449 // XXX FIXME XXX should return the list if nargout > 1 |
|
450 rep.print (octave_stdout); |
|
451 else if (n.empty ()) |
|
452 { |
|
453 // XXX FIXME XXX should we eliminate the dispatch function if |
|
454 // there are no more elements? |
|
455 // XXX FIXME XXX should clear the " $t:\w+" from the help string. |
|
456 // XXX FIXME XXX -- seems bad to cast away const here... |
|
457 octave_dispatch& xrep = const_cast<octave_dispatch&> (rep); |
|
458 |
|
459 xrep.clear (t); |
|
460 } |
|
461 else |
|
462 { |
|
463 // XXX FIXME XXX -- seems bad to cast away const here... |
|
464 octave_dispatch& xrep = const_cast<octave_dispatch&> (rep); |
|
465 |
|
466 xrep.add (t, n); |
|
467 |
|
468 if (! sr->help().empty ()) |
5300
|
469 sr->document (sr->help() + "\n" + n + " (" + t + ", ...)\n"); |
5164
|
470 } |
|
471 } |
|
472 |
|
473 DEFUN_DLD (dispatch, args, , |
|
474 "-*- texinfo -*-\n\ |
|
475 @deftypefn {Loadable Function} {} dispatch (@var{f}, @var{r}, @var{type})\n\ |
|
476 \n\ |
|
477 Replace the function @var{f} with a dispatch so that function @var{r}\n\ |
|
478 is called when @var{f} is called with the first argument of the named\n\ |
|
479 @var{type}. If the type is @var{any} then call @var{r} if no other type\n\ |
|
480 matches. The original function @var{f} is accessible using\n\ |
|
481 @code{builtin (@var{f}, @dots{}).\n\ |
|
482 \n\ |
|
483 If @var{r} is omitted, clear dispatch function associated with @var{type}.\n\ |
|
484 \n\ |
|
485 If both @var{r} and @var{type} are omitted, list dispatch functions\n\ |
|
486 for @var{f}\n\ |
|
487 @end deftypefn\n\ |
|
488 @seealso{builtin}") |
|
489 { |
|
490 octave_value retval; |
|
491 int nargin = args.length (); |
|
492 |
|
493 if (nargin < 1 || nargin > 3) |
|
494 { |
|
495 print_usage ("dispatch"); |
|
496 return retval; |
|
497 } |
|
498 |
|
499 std::string f, t, n; |
|
500 if (nargin > 0) |
|
501 f = args(0).string_value (); |
|
502 |
|
503 if (nargin == 2) |
|
504 t = args(1).string_value (); |
|
505 else if (nargin > 2) |
|
506 { |
|
507 n = args(1).string_value (); |
|
508 t = args(2).string_value (); |
|
509 } |
|
510 |
|
511 if (error_state) |
|
512 return retval; |
|
513 |
|
514 static bool register_type = true; |
|
515 |
|
516 // register dispatch function type if you have not already done so |
|
517 if (register_type) |
|
518 { |
|
519 octave_dispatch::register_type (); |
|
520 register_type = false; |
|
521 fbi_sym_tab->lookup("dispatch")->mark_as_static (); |
|
522 dispatch_record ("help", "dispatch_help", "string"); |
5300
|
523 dispatch_record ("help", "dispatch_help", "sq_string"); |
5164
|
524 } |
|
525 |
|
526 dispatch_record (f, n, t); |
|
527 |
|
528 return retval; |
|
529 } |
|
530 |
|
531 /* |
|
532 |
|
533 %!test # builtin function replacement |
|
534 %! dispatch('sin','length','string') |
|
535 %! assert(sin('abc'),3) |
|
536 %! assert(sin(0),0,10*eps); |
|
537 %!test # 'any' function |
|
538 %! dispatch('sin','exp','any') |
|
539 %! assert(sin(0),1,eps); |
|
540 %! assert(sin('abc'),3); |
|
541 %!test # 'builtin' function |
|
542 %! assert(builtin('sin',0),0,eps); |
|
543 %! builtin('eval','x=1;'); |
|
544 %! assert(x,1); |
|
545 %!test # clear function mapping |
|
546 %! dispatch('sin','string') |
|
547 %! dispatch('sin','any') |
|
548 %! assert(sin(0),0,10*eps); |
|
549 %!test # oct-file replacement |
|
550 %! dispatch('fft','length','string') |
|
551 %! assert(fft([1,1]),[2,0]); |
|
552 %! assert(fft('abc'),3) |
|
553 %! dispatch('fft','string'); |
|
554 %!test # m-file replacement |
|
555 %! dispatch('hamming','length','string') |
|
556 %! assert(hamming(1),1) |
|
557 %! assert(hamming('abc'),3) |
|
558 %! dispatch('hamming','string') |
|
559 |
|
560 %!test # override preloaded builtin |
|
561 %! evalin('base','cos(1);'); |
|
562 %! dispatch('cos','length','string') |
|
563 %! evalin('base',"assert(cos('abc'),3)"); |
|
564 %! evalin('base',"assert(cos(0),1,eps)"); |
|
565 %! dispatch('cos','string') |
|
566 %!test # override pre-loaded oct-file |
|
567 %! evalin('base','qr(1);'); |
|
568 %! dispatch('qr','length','string') |
|
569 %! evalin('base',"assert(qr('abc'),3)"); |
|
570 %! evalin('base',"assert(qr(1),1)"); |
|
571 %! dispatch('qr','string'); |
|
572 %!test # override pre-loaded m-file |
|
573 %! evalin('base','hanning(1);'); |
|
574 %! dispatch('hanning','length','string') |
|
575 %! evalin('base','assert(hanning("abc"),3)'); |
|
576 %! evalin('base','assert(hanning(1),1)'); |
|
577 %! dispatch('hanning','string'); |
|
578 |
|
579 XXX FIXME XXX I would rather not create dispatch_x/dispatch_y |
|
580 in the current directory! I don't want them installed accidentally. |
|
581 |
|
582 %!test # replace base m-file |
|
583 %! system("echo 'function a=dispatch_x(a)'>dispatch_x.m"); |
|
584 %! dispatch('dispatch_x','length','string') |
|
585 %! assert(dispatch_x(3),3) |
|
586 %! assert(dispatch_x('a'),1) |
|
587 %! pause(1); |
|
588 %! system("echo 'function a=dispatch_x(a),++a;'>dispatch_x.m"); |
|
589 %! assert(dispatch_x(3),4) |
|
590 %! assert(dispatch_x('a'),1) |
|
591 %!test |
|
592 %! system("rm dispatch_x.m"); |
|
593 |
|
594 %!test # replace dispatch m-file |
|
595 %! system("echo 'function a=dispatch_y(a)'>dispatch_y.m"); |
|
596 %! dispatch('hello','dispatch_y','complex scalar') |
|
597 %! assert(hello(3i),3i) |
|
598 %! pause(1); |
|
599 %! system("echo 'function a=dispatch_y(a),++a;'>dispatch_y.m"); |
|
600 %! assert(hello(3i),1+3i) |
|
601 %!test |
|
602 %! system("rm dispatch_y.m"); |
|
603 |
|
604 XXX FIXME XXX add tests for preservation of mark_as_command status. |
|
605 |
|
606 */ |