Mercurial > octave-nkf

comparison src/DLD-FUNCTIONS/dispatch.cc @ 5164:57077d0ddc8e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[project @ 2005-02-25 19:55:24 by jwe]
author jwe
date Fri, 25 Feb 2005 19:55:28 +0000
parents
children 240ed0328925
comparison
equal deleted inserted replaced
5163:9f3299378193 5164:57077d0ddc8e
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);
310 if (sr->def().type_id () == octave_dispatch::static_type_id ())
311 {
312 octave_function *fcn = builtin (name);
313
314 if (!error_state && fcn)
315 retval = fcn->do_multi_index_op (nargout,
316 args.splice (0, 1, retval));
317 }
318 else
319 retval = feval (name, args, nargout);
320 }
321 else
322 print_usage ("builtin");
323
324 return retval;
325 }
326
327 DEFUN_DLD (dispatch_help, args, nargout,
328 "-*- texinfo -*-\n\
329 @deftypefn {Loadable Function} {} dispatch_help (@var{name}, @dots{})\n\
330 Delayed loading of help messages for dispatched functions.\n\
331 @end deftypefn\n\
332 @seealso{builtin, dispatch}")
333 {
334 octave_value_list retval;
335
336 int nargin = args.length ();
337
338 for (int i = 0; i < nargin; i++)
339 {
340 if (args(i).is_string ())
341 {
342 const std::string name (args(i).string_value ());
343
344 if (error_state)
345 return retval;
346
347 symbol_record *sr = fbi_sym_tab->lookup (name, false);
348
349 if (sr)
350 {
351 std::string help = sr->help ();
352
353 if (help[0] == '<' && help[1] == '>'
354 && sr->def().type_id () == octave_dispatch::static_type_id ())
355 {
356 builtin (name);
357
358 symbol_record *builtin_record
359 = fbi_sym_tab->lookup ("builtin:" + name, 0);
360
361 help.replace (0, 2, builtin_record->help ());
362
363 sr->document (help);
364 }
365 }
366 }
367 }
368
369 return feval ("builtin:help", args, nargout);
370 }
371
372 static void
373 dispatch_record (const std::string &f, const std::string &n,
374 const std::string &t)
375 {
376 // find the base function in the symbol table, loading it if it
377 // is not already there; if it is already a dispatch, then bonus
378
379 symbol_record *sr = fbi_sym_tab->lookup (f, true);
380
381 if (sr->def().type_id () != octave_dispatch::static_type_id ())
382 {
383 // Preserve mark_as_command status
384 bool iscommand = sr->is_command ();
385
386 // Not an overloaded name, so if only display or clear then we are done
387 if (t.empty ())
388 return;
389
390 // sr is the base symbol; rename it to keep it safe. When we need
391 // it we will rename it back again.
392 if (sr->is_read_only ())
393 {
394 sr->unprotect ();
395 fbi_sym_tab->rename (f, "builtin:" + f);
396 sr = fbi_sym_tab->lookup (f, true);
397 sr->protect ();
398 }
399 else
400 fbi_sym_tab->rename (f, "builtin:" + f);
401
402 std::string basedoc ("<>");
403
404 if (! sr->help().empty ())
405 basedoc = sr->help ();
406
407 // Problem: when a function is first called a new record
408 // is created for it in the current symbol table, so calling
409 // dispatch on a function that has already been called, we
410 // should also clear it from all existing symbol tables.
411 // This is too much work, so we will only do it for the
412 // top level symbol table. We can't use the clear_function()
413 // method, because it won't clear builtin functions. Instead
414 // we check if the symbol is a function and clear it then. This
415 // won't properly clear shadowed functions, or functions in
416 // other namespaces (such as the current, if called from a
417 // function).
418 symbol_record *local = top_level_sym_tab->lookup (f, false);
419 if (local && local->is_function ())
420 local->clear ();
421
422 // Build a new dispatch object based on the function definition
423 octave_dispatch *dispatch = new octave_dispatch (f);
424
425 // Create a symbol record for the dispatch object.
426 sr = fbi_sym_tab->lookup (f, true);
427 sr->unprotect ();
428 sr->define (octave_value (dispatch), symbol_record::BUILTIN_FUNCTION);
429 // std::cout << "iscommand('"<<f<<"')=" << iscommand << std::endl;
430 if (iscommand)
431 sr->mark_as_command();
432 sr->document (basedoc + "\n\nOverloaded function\n");
433 sr->make_eternal (); // XXX FIXME XXX why??
434 sr->mark_as_static ();
435 sr->protect ();
436 }
437
438 // clear/replace/extend the map with the new type-function pair
439 const octave_dispatch& rep
440 = reinterpret_cast<const octave_dispatch&> (sr->def().get_rep ());
441
442 if (t.empty ())
443 // XXX FIXME XXX should return the list if nargout > 1
444 rep.print (octave_stdout);
445 else if (n.empty ())
446 {
447 // XXX FIXME XXX should we eliminate the dispatch function if
448 // there are no more elements?
449 // XXX FIXME XXX should clear the " $t:\w+" from the help string.
450 // XXX FIXME XXX -- seems bad to cast away const here...
451 octave_dispatch& xrep = const_cast<octave_dispatch&> (rep);
452
453 xrep.clear (t);
454 }
455 else
456 {
457 // XXX FIXME XXX -- seems bad to cast away const here...
458 octave_dispatch& xrep = const_cast<octave_dispatch&> (rep);
459
460 xrep.add (t, n);
461
462 if (! sr->help().empty ())
463 sr->document (sr->help() + "\n " + n + "(" + t + ",...)");
464 }
465 }
466
467 DEFUN_DLD (dispatch, args, ,
468 "-*- texinfo -*-\n\
469 @deftypefn {Loadable Function} {} dispatch (@var{f}, @var{r}, @var{type})\n\
470 \n\
471 Replace the function @var{f} with a dispatch so that function @var{r}\n\
472 is called when @var{f} is called with the first argument of the named\n\
473 @var{type}. If the type is @var{any} then call @var{r} if no other type\n\
474 matches. The original function @var{f} is accessible using\n\
475 @code{builtin (@var{f}, @dots{}).\n\
476 \n\
477 If @var{r} is omitted, clear dispatch function associated with @var{type}.\n\
478 \n\
479 If both @var{r} and @var{type} are omitted, list dispatch functions\n\
480 for @var{f}\n\
481 @end deftypefn\n\
482 @seealso{builtin}")
483 {
484 octave_value retval;
485 int nargin = args.length ();
486
487 if (nargin < 1 || nargin > 3)
488 {
489 print_usage ("dispatch");
490 return retval;
491 }
492
493 std::string f, t, n;
494 if (nargin > 0)
495 f = args(0).string_value ();
496
497 if (nargin == 2)
498 t = args(1).string_value ();
499 else if (nargin > 2)
500 {
501 n = args(1).string_value ();
502 t = args(2).string_value ();
503 }
504
505 if (error_state)
506 return retval;
507
508 static bool register_type = true;
509
510 // register dispatch function type if you have not already done so
511 if (register_type)
512 {
513 octave_dispatch::register_type ();
514 register_type = false;
515 fbi_sym_tab->lookup("dispatch")->mark_as_static ();
516 dispatch_record ("help", "dispatch_help", "string");
517 }
518
519 dispatch_record (f, n, t);
520
521 return retval;
522 }
523
524 /*
525
526 %!test # builtin function replacement
527 %! dispatch('sin','length','string')
528 %! assert(sin('abc'),3)
529 %! assert(sin(0),0,10*eps);
530 %!test # 'any' function
531 %! dispatch('sin','exp','any')
532 %! assert(sin(0),1,eps);
533 %! assert(sin('abc'),3);
534 %!test # 'builtin' function
535 %! assert(builtin('sin',0),0,eps);
536 %! builtin('eval','x=1;');
537 %! assert(x,1);
538 %!test # clear function mapping
539 %! dispatch('sin','string')
540 %! dispatch('sin','any')
541 %! assert(sin(0),0,10*eps);
542 %!test # oct-file replacement
543 %! dispatch('fft','length','string')
544 %! assert(fft([1,1]),[2,0]);
545 %! assert(fft('abc'),3)
546 %! dispatch('fft','string');
547 %!test # m-file replacement
548 %! dispatch('hamming','length','string')
549 %! assert(hamming(1),1)
550 %! assert(hamming('abc'),3)
551 %! dispatch('hamming','string')
552
553 %!test # override preloaded builtin
554 %! evalin('base','cos(1);');
555 %! dispatch('cos','length','string')
556 %! evalin('base',"assert(cos('abc'),3)");
557 %! evalin('base',"assert(cos(0),1,eps)");
558 %! dispatch('cos','string')
559 %!test # override pre-loaded oct-file
560 %! evalin('base','qr(1);');
561 %! dispatch('qr','length','string')
562 %! evalin('base',"assert(qr('abc'),3)");
563 %! evalin('base',"assert(qr(1),1)");
564 %! dispatch('qr','string');
565 %!test # override pre-loaded m-file
566 %! evalin('base','hanning(1);');
567 %! dispatch('hanning','length','string')
568 %! evalin('base','assert(hanning("abc"),3)');
569 %! evalin('base','assert(hanning(1),1)');
570 %! dispatch('hanning','string');
571
572 XXX FIXME XXX I would rather not create dispatch_x/dispatch_y
573 in the current directory! I don't want them installed accidentally.
574
575 %!test # replace base m-file
576 %! system("echo 'function a=dispatch_x(a)'>dispatch_x.m");
577 %! dispatch('dispatch_x','length','string')
578 %! assert(dispatch_x(3),3)
579 %! assert(dispatch_x('a'),1)
580 %! pause(1);
581 %! system("echo 'function a=dispatch_x(a),++a;'>dispatch_x.m");
582 %! assert(dispatch_x(3),4)
583 %! assert(dispatch_x('a'),1)
584 %!test
585 %! system("rm dispatch_x.m");
586
587 %!test # replace dispatch m-file
588 %! system("echo 'function a=dispatch_y(a)'>dispatch_y.m");
589 %! dispatch('hello','dispatch_y','complex scalar')
590 %! assert(hello(3i),3i)
591 %! pause(1);
592 %! system("echo 'function a=dispatch_y(a),++a;'>dispatch_y.m");
593 %! assert(hello(3i),1+3i)
594 %!test
595 %! system("rm dispatch_y.m");
596
597 XXX FIXME XXX add tests for preservation of mark_as_command status.
598
599 */