Mercurial > octave-nkf

comparison libinterp/octave-value/ov-usr-fcn.cc @ 15195:2fc554ffbc28

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
split libinterp from src * libinterp: New directory. Move all files from src directory here except Makefile.am, main.cc, main-cli.cc, mkoctfile.in.cc, mkoctfilr.in.sh, octave-config.in.cc, octave-config.in.sh. * libinterp/Makefile.am: New file, extracted from src/Makefile.am. * src/Makefile.am: Delete everything except targets and definitions needed to build and link main and utility programs. * Makefile.am (SUBDIRS): Include libinterp in the list. * autogen.sh: Run config-module.sh in libinterp/dldfcn directory, not src/dldfcn directory. * configure.ac (AC_CONFIG_SRCDIR): Use libinterp/octave.cc, not src/octave.cc. (DL_LDFLAGS, LIBOCTINTERP): Use libinterp, not src. (AC_CONFIG_FILES): Include libinterp/Makefile in the list. * find-docstring-files.sh: Look in libinterp, not src. * gui/src/Makefile.am (liboctgui_la_CPPFLAGS): Find header files in libinterp, not src.
author John W. Eaton <jwe@octave.org>
date Sat, 18 Aug 2012 16:23:39 -0400
parents src/octave-value/ov-usr-fcn.cc@46b19589b593
children 44d6ffdf9479
comparison
equal deleted inserted replaced
15194:0f0b795044c3 15195:2fc554ffbc28
1 /*
2
3 Copyright (C) 1996-2012 John W. Eaton
4
5 This file is part of Octave.
6
7 Octave is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 3 of the License, or (at your
10 option) any later version.
11
12 Octave is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with Octave; see the file COPYING. If not, see
19 <http://www.gnu.org/licenses/>.
20
21 */
22
23 #ifdef HAVE_CONFIG_H
24 #include <config.h>
25 #endif
26
27 #include <sstream>
28
29 #include "str-vec.h"
30
31 #include <defaults.h>
32 #include "Cell.h"
33 #include "defun.h"
34 #include "error.h"
35 #include "gripes.h"
36 #include "input.h"
37 #include "oct-obj.h"
38 #include "ov-usr-fcn.h"
39 #include "ov.h"
40 #include "pager.h"
41 #include "pt-eval.h"
42 #include "pt-jump.h"
43 #include "pt-misc.h"
44 #include "pt-pr-code.h"
45 #include "pt-stmt.h"
46 #include "pt-walk.h"
47 #include "symtab.h"
48 #include "toplev.h"
49 #include "unwind-prot.h"
50 #include "utils.h"
51 #include "parse.h"
52 #include "profiler.h"
53 #include "variables.h"
54 #include "ov-fcn-handle.h"
55
56 // Whether to optimize subsasgn method calls.
57 static bool Voptimize_subsasgn_calls = true;
58
59 // User defined scripts.
60
61 DEFINE_OCTAVE_ALLOCATOR (octave_user_script);
62
63 DEFINE_OV_TYPEID_FUNCTIONS_AND_DATA (octave_user_script,
64 "user-defined script",
65 "user-defined script");
66
67 octave_user_script::octave_user_script (void)
68 : octave_user_code (), cmd_list (0), file_name (),
69 t_parsed (static_cast<time_t> (0)),
70 t_checked (static_cast<time_t> (0)),
71 call_depth (-1)
72 { }
73
74 octave_user_script::octave_user_script (const std::string& fnm,
75 const std::string& nm,
76 tree_statement_list *cmds,
77 const std::string& ds)
78 : octave_user_code (nm, ds), cmd_list (cmds), file_name (fnm),
79 t_parsed (static_cast<time_t> (0)),
80 t_checked (static_cast<time_t> (0)),
81 call_depth (-1)
82 {
83 if (cmd_list)
84 cmd_list->mark_as_script_body ();
85 }
86
87 octave_user_script::octave_user_script (const std::string& fnm,
88 const std::string& nm,
89 const std::string& ds)
90 : octave_user_code (nm, ds), cmd_list (0), file_name (fnm),
91 t_parsed (static_cast<time_t> (0)),
92 t_checked (static_cast<time_t> (0)),
93 call_depth (-1)
94 { }
95
96 octave_user_script::~octave_user_script (void)
97 {
98 delete cmd_list;
99 }
100
101 octave_value_list
102 octave_user_script::subsref (const std::string&,
103 const std::list<octave_value_list>&, int)
104 {
105 octave_value_list retval;
106
107 ::error ("invalid use of script %s in index expression", file_name.c_str ());
108
109 return retval;
110 }
111
112 octave_value_list
113 octave_user_script::do_multi_index_op (int nargout,
114 const octave_value_list& args)
115 {
116 octave_value_list retval;
117
118 unwind_protect frame;
119
120 if (! error_state)
121 {
122 if (args.length () == 0 && nargout == 0)
123 {
124 if (cmd_list)
125 {
126 frame.protect_var (call_depth);
127 call_depth++;
128
129 if (call_depth < Vmax_recursion_depth)
130 {
131 octave_call_stack::push (this);
132
133 frame.add_fcn (octave_call_stack::pop);
134
135 frame.protect_var (tree_evaluator::statement_context);
136 tree_evaluator::statement_context = tree_evaluator::script;
137
138 BEGIN_PROFILER_BLOCK (profiler_name ())
139 cmd_list->accept (*current_evaluator);
140 END_PROFILER_BLOCK
141
142 if (tree_return_command::returning)
143 tree_return_command::returning = 0;
144
145 if (tree_break_command::breaking)
146 tree_break_command::breaking--;
147
148 if (error_state)
149 octave_call_stack::backtrace_error_message ();
150 }
151 else
152 ::error ("max_recursion_depth exceeded");
153 }
154 }
155 else
156 error ("invalid call to script %s", file_name.c_str ());
157 }
158
159 return retval;
160 }
161
162 void
163 octave_user_script::accept (tree_walker& tw)
164 {
165 tw.visit_octave_user_script (*this);
166 }
167
168 // User defined functions.
169
170 DEFINE_OCTAVE_ALLOCATOR (octave_user_function);
171
172 DEFINE_OV_TYPEID_FUNCTIONS_AND_DATA (octave_user_function,
173 "user-defined function",
174 "user-defined function");
175
176 // Ugh. This really needs to be simplified (code/data?
177 // extrinsic/intrinsic state?).
178
179 octave_user_function::octave_user_function
180 (symbol_table::scope_id sid, tree_parameter_list *pl,
181 tree_parameter_list *rl, tree_statement_list *cl)
182 : octave_user_code (std::string (), std::string ()),
183 param_list (pl), ret_list (rl), cmd_list (cl),
184 lead_comm (), trail_comm (), file_name (),
185 location_line (0), location_column (0),
186 parent_name (), t_parsed (static_cast<time_t> (0)),
187 t_checked (static_cast<time_t> (0)),
188 system_fcn_file (false), call_depth (-1),
189 num_named_args (param_list ? param_list->length () : 0),
190 subfunction (false), inline_function (false),
191 anonymous_function (false), nested_function (false),
192 class_constructor (false), class_method (false),
193 parent_scope (-1), local_scope (sid),
194 curr_unwind_protect_frame (0)
195 {
196 if (cmd_list)
197 cmd_list->mark_as_function_body ();
198
199 if (local_scope >= 0)
200 symbol_table::set_curr_fcn (this, local_scope);
201 }
202
203 octave_user_function::~octave_user_function (void)
204 {
205 delete param_list;
206 delete ret_list;
207 delete cmd_list;
208 delete lead_comm;
209 delete trail_comm;
210
211 symbol_table::erase_scope (local_scope);
212 }
213
214 octave_user_function *
215 octave_user_function::define_ret_list (tree_parameter_list *t)
216 {
217 ret_list = t;
218
219 return this;
220 }
221
222 void
223 octave_user_function::stash_fcn_file_name (const std::string& nm)
224 {
225 file_name = nm;
226 }
227
228 std::string
229 octave_user_function::profiler_name (void) const
230 {
231 std::ostringstream result;
232
233 if (is_inline_function ())
234 result << "inline@" << fcn_file_name ()
235 << ":" << location_line << ":" << location_column;
236 else if (is_anonymous_function ())
237 result << "anonymous@" << fcn_file_name ()
238 << ":" << location_line << ":" << location_column;
239 else if (is_subfunction ())
240 result << parent_fcn_name () << ">" << name ();
241 else
242 result << name ();
243
244 return result.str ();
245 }
246
247 void
248 octave_user_function::mark_as_system_fcn_file (void)
249 {
250 if (! file_name.empty ())
251 {
252 // We really should stash the whole path to the file we found,
253 // when we looked it up, to avoid possible race conditions...
254 // FIXME
255 //
256 // We probably also don't need to get the library directory
257 // every time, but since this function is only called when the
258 // function file is parsed, it probably doesn't matter that
259 // much.
260
261 std::string ff_name = fcn_file_in_path (file_name);
262
263 if (Vfcn_file_dir == ff_name.substr (0, Vfcn_file_dir.length ()))
264 system_fcn_file = true;
265 }
266 else
267 system_fcn_file = false;
268 }
269
270 bool
271 octave_user_function::takes_varargs (void) const
272 {
273 return (param_list && param_list->takes_varargs ());
274 }
275
276 bool
277 octave_user_function::takes_var_return (void) const
278 {
279 return (ret_list && ret_list->takes_varargs ());
280 }
281
282 void
283 octave_user_function::lock_subfunctions (void)
284 {
285 symbol_table::lock_subfunctions (local_scope);
286 }
287
288 void
289 octave_user_function::unlock_subfunctions (void)
290 {
291 symbol_table::unlock_subfunctions (local_scope);
292 }
293
294 octave_value_list
295 octave_user_function::all_va_args (const octave_value_list& args)
296 {
297 octave_value_list retval;
298
299 octave_idx_type n = args.length () - num_named_args;
300
301 if (n > 0)
302 retval = args.slice (num_named_args, n);
303
304 return retval;
305 }
306
307 octave_value_list
308 octave_user_function::subsref (const std::string& type,
309 const std::list<octave_value_list>& idx,
310 int nargout)
311 {
312 return octave_user_function::subsref (type, idx, nargout, 0);
313 }
314
315 octave_value_list
316 octave_user_function::subsref (const std::string& type,
317 const std::list<octave_value_list>& idx,
318 int nargout, const std::list<octave_lvalue>* lvalue_list)
319 {
320 octave_value_list retval;
321
322 switch (type[0])
323 {
324 case '(':
325 {
326 int tmp_nargout = (type.length () > 1 && nargout == 0) ? 1 : nargout;
327
328 retval = do_multi_index_op (tmp_nargout, idx.front (),
329 idx.size () == 1 ? lvalue_list : 0);
330 }
331 break;
332
333 case '{':
334 case '.':
335 {
336 std::string nm = type_name ();
337 error ("%s cannot be indexed with %c", nm.c_str (), type[0]);
338 }
339 break;
340
341 default:
342 panic_impossible ();
343 }
344
345 // FIXME -- perhaps there should be an
346 // octave_value_list::next_subsref member function? See also
347 // octave_builtin::subsref.
348
349 if (idx.size () > 1)
350 retval = retval(0).next_subsref (nargout, type, idx);
351
352 return retval;
353 }
354
355 octave_value_list
356 octave_user_function::do_multi_index_op (int nargout,
357 const octave_value_list& args)
358 {
359 return do_multi_index_op (nargout, args, 0);
360 }
361
362 octave_value_list
363 octave_user_function::do_multi_index_op (int nargout,
364 const octave_value_list& args,
365 const std::list<octave_lvalue>* lvalue_list)
366 {
367 octave_value_list retval;
368
369 if (error_state)
370 return retval;
371
372 if (! cmd_list)
373 return retval;
374
375 int nargin = args.length ();
376
377 unwind_protect frame;
378
379 frame.protect_var (call_depth);
380 call_depth++;
381
382 if (call_depth >= Vmax_recursion_depth)
383 {
384 ::error ("max_recursion_depth exceeded");
385 return retval;
386 }
387
388 // Save old and set current symbol table context, for
389 // eval_undefined_error().
390
391 int context = active_context ();
392
393 octave_call_stack::push (this, local_scope, context);
394 frame.add_fcn (octave_call_stack::pop);
395
396 if (call_depth > 0 && ! is_anonymous_function ())
397 {
398 symbol_table::push_context ();
399
400 frame.add_fcn (symbol_table::pop_context);
401 }
402
403 string_vector arg_names = args.name_tags ();
404
405 if (param_list && ! param_list->varargs_only ())
406 {
407 param_list->define_from_arg_vector (args);
408 if (error_state)
409 return retval;
410 }
411
412 // Force parameter list to be undefined when this function exits.
413 // Doing so decrements the reference counts on the values of local
414 // variables that are also named function parameters.
415
416 if (param_list)
417 frame.add_method (param_list, &tree_parameter_list::undefine);
418
419 // Force return list to be undefined when this function exits.
420 // Doing so decrements the reference counts on the values of local
421 // variables that are also named values returned by this function.
422
423 if (ret_list)
424 frame.add_method (ret_list, &tree_parameter_list::undefine);
425
426 if (call_depth == 0)
427 {
428 // Force symbols to be undefined again when this function
429 // exits.
430 //
431 // This cleanup function is added to the unwind_protect stack
432 // after the calls to clear the parameter lists so that local
433 // variables will be cleared before the parameter lists are
434 // cleared. That way, any function parameters that have been
435 // declared global will be unmarked as global before they are
436 // undefined by the clear_param_list cleanup function.
437
438 frame.add_fcn (symbol_table::clear_variables);
439 }
440
441 bind_automatic_vars (arg_names, nargin, nargout, all_va_args (args),
442 lvalue_list);
443
444 bool echo_commands = (Vecho_executing_commands & ECHO_FUNCTIONS);
445
446 if (echo_commands)
447 print_code_function_header ();
448
449 // Set pointer to the current unwind_protect frame to allow
450 // certain builtins register simple cleanup in a very optimized manner.
451 // This is *not* intended as a general-purpose on-cleanup mechanism,
452 frame.protect_var (curr_unwind_protect_frame);
453 curr_unwind_protect_frame = &frame;
454
455 // Evaluate the commands that make up the function.
456
457 frame.protect_var (tree_evaluator::statement_context);
458 tree_evaluator::statement_context = tree_evaluator::function;
459
460 bool special_expr = (is_inline_function () || is_anonymous_function ());
461
462 BEGIN_PROFILER_BLOCK (profiler_name ())
463
464 if (special_expr)
465 {
466 assert (cmd_list->length () == 1);
467
468 tree_statement *stmt = 0;
469
470 if ((stmt = cmd_list->front ())
471 && stmt->is_expression ())
472 {
473 tree_expression *expr = stmt->expression ();
474
475 retval = expr->rvalue (nargout);
476 }
477 }
478 else
479 cmd_list->accept (*current_evaluator);
480
481 END_PROFILER_BLOCK
482
483 if (echo_commands)
484 print_code_function_trailer ();
485
486 if (tree_return_command::returning)
487 tree_return_command::returning = 0;
488
489 if (tree_break_command::breaking)
490 tree_break_command::breaking--;
491
492 if (error_state)
493 {
494 octave_call_stack::backtrace_error_message ();
495 return retval;
496 }
497
498 // Copy return values out.
499
500 if (ret_list && ! special_expr)
501 {
502 ret_list->initialize_undefined_elements (my_name, nargout, Matrix ());
503
504 Cell varargout;
505
506 if (ret_list->takes_varargs ())
507 {
508 octave_value varargout_varval = symbol_table::varval ("varargout");
509
510 if (varargout_varval.is_defined ())
511 {
512 varargout = varargout_varval.cell_value ();
513
514 if (error_state)
515 error ("expecting varargout to be a cell array object");
516 }
517 }
518
519 if (! error_state)
520 retval = ret_list->convert_to_const_vector (nargout, varargout);
521 }
522
523 return retval;
524 }
525
526 void
527 octave_user_function::accept (tree_walker& tw)
528 {
529 tw.visit_octave_user_function (*this);
530 }
531
532 bool
533 octave_user_function::subsasgn_optimization_ok (void)
534 {
535 bool retval = false;
536 if (Voptimize_subsasgn_calls
537 && param_list->length () > 0 && ! param_list->varargs_only ()
538 && ret_list->length () == 1 && ! ret_list->takes_varargs ())
539 {
540 tree_identifier *par1 = param_list->front ()->ident ();
541 tree_identifier *ret1 = ret_list->front ()->ident ();
542 retval = par1->name () == ret1->name ();
543 }
544
545 return retval;
546 }
547
548 #if 0
549 void
550 octave_user_function::print_symtab_info (std::ostream& os) const
551 {
552 symbol_table::print_info (os, local_scope);
553 }
554 #endif
555
556 void
557 octave_user_function::print_code_function_header (void)
558 {
559 tree_print_code tpc (octave_stdout, VPS4);
560
561 tpc.visit_octave_user_function_header (*this);
562 }
563
564 void
565 octave_user_function::print_code_function_trailer (void)
566 {
567 tree_print_code tpc (octave_stdout, VPS4);
568
569 tpc.visit_octave_user_function_trailer (*this);
570 }
571
572 void
573 octave_user_function::bind_automatic_vars
574 (const string_vector& arg_names, int nargin, int nargout,
575 const octave_value_list& va_args, const std::list<octave_lvalue> *lvalue_list)
576 {
577 if (! arg_names.empty ())
578 {
579 // It is better to save this in the hidden variable .argn. and
580 // then use that in the inputname function instead of using argn,
581 // which might be redefined in a function. Keep the old argn name
582 // for backward compatibility of functions that use it directly.
583
584 symbol_table::varref ("argn") = arg_names;
585 symbol_table::varref (".argn.") = Cell (arg_names);
586
587 symbol_table::mark_hidden (".argn.");
588
589 symbol_table::mark_automatic ("argn");
590 symbol_table::mark_automatic (".argn.");
591 }
592
593 symbol_table::varref (".nargin.") = nargin;
594 symbol_table::varref (".nargout.") = nargout;
595
596 symbol_table::mark_hidden (".nargin.");
597 symbol_table::mark_hidden (".nargout.");
598
599 symbol_table::mark_automatic (".nargin.");
600 symbol_table::mark_automatic (".nargout.");
601
602 if (takes_varargs ())
603 symbol_table::varref ("varargin") = va_args.cell_value ();
604
605 // Force .ignored. variable to be undefined by default.
606 symbol_table::varref (".ignored.") = octave_value ();
607
608 if (lvalue_list)
609 {
610 octave_idx_type nbh = 0;
611 for (std::list<octave_lvalue>::const_iterator p = lvalue_list->begin ();
612 p != lvalue_list->end (); p++)
613 nbh += p->is_black_hole ();
614
615 if (nbh > 0)
616 {
617 // Only assign the hidden variable if black holes actually present.
618 Matrix bh (1, nbh);
619 octave_idx_type k = 0, l = 0;
620 for (std::list<octave_lvalue>::const_iterator p = lvalue_list->begin ();
621 p != lvalue_list->end (); p++)
622 {
623 if (p->is_black_hole ())
624 bh(l++) = k+1;
625 k += p->numel ();
626 }
627
628 symbol_table::varref (".ignored.") = bh;
629 }
630 }
631
632 symbol_table::mark_hidden (".ignored.");
633 symbol_table::mark_automatic (".ignored.");
634 }
635
636 DEFUN (nargin, args, ,
637 "-*- texinfo -*-\n\
638 @deftypefn {Built-in Function} {} nargin ()\n\
639 @deftypefnx {Built-in Function} {} nargin (@var{fcn})\n\
640 Within a function, return the number of arguments passed to the function.\n\
641 At the top level, return the number of command line arguments passed to\n\
642 Octave.\n\
643 \n\
644 If called with the optional argument @var{fcn}, a function name or handle,\n\
645 return the declared number of arguments that the function can accept.\n\
646 If the last argument is @var{varargin} the returned value is negative.\n\
647 This feature does not work on builtin functions.\n\
648 @seealso{nargout, varargin, isargout, varargout, nthargout}\n\
649 @end deftypefn")
650 {
651 octave_value retval;
652
653 int nargin = args.length ();
654
655 if (nargin == 1)
656 {
657 octave_value func = args(0);
658
659 if (func.is_string ())
660 {
661 std::string name = func.string_value ();
662 func = symbol_table::find_function (name);
663 if (func.is_undefined ())
664 error ("nargout: invalid function name: %s", name.c_str ());
665 }
666
667 octave_function *fcn_val = func.function_value ();
668 if (fcn_val)
669 {
670 octave_user_function *fcn = fcn_val->user_function_value (true);
671
672 if (fcn)
673 {
674 tree_parameter_list *param_list = fcn->parameter_list ();
675
676 retval = param_list ? param_list->length () : 0;
677 if (fcn->takes_varargs ())
678 retval = -1 - retval;
679 }
680 else
681 {
682 // Matlab gives up for histc, so maybe it's ok we give up somtimes too.
683 error ("nargin: nargin information not available for builtin functions");
684 }
685 }
686 else
687 error ("nargin: FCN must be a string or function handle");
688 }
689 else if (nargin == 0)
690 {
691 retval = symbol_table::varval (".nargin.");
692
693 if (retval.is_undefined ())
694 retval = 0;
695 }
696 else
697 print_usage ();
698
699 return retval;
700 }
701
702 DEFUN (nargout, args, ,
703 "-*- texinfo -*-\n\
704 @deftypefn {Built-in Function} {} nargout ()\n\
705 @deftypefnx {Built-in Function} {} nargout (@var{fcn})\n\
706 Within a function, return the number of values the caller expects to\n\
707 receive. If called with the optional argument @var{fcn}, a function\n\
708 name or handle, return the number of declared output values that the\n\
709 function can produce. If the final output argument is @var{varargout}\n\
710 the returned value is negative.\n\
711 \n\
712 For example,\n\
713 \n\
714 @example\n\
715 f ()\n\
716 @end example\n\
717 \n\
718 @noindent\n\
719 will cause @code{nargout} to return 0 inside the function @code{f} and\n\
720 \n\
721 @example\n\
722 [s, t] = f ()\n\
723 @end example\n\
724 \n\
725 @noindent\n\
726 will cause @code{nargout} to return 2 inside the function\n\
727 @code{f}.\n\
728 \n\
729 In the second usage,\n\
730 \n\
731 @example\n\
732 nargout (@@histc) \% or nargout ('histc')\n\
733 @end example\n\
734 \n\
735 @noindent\n\
736 will return 2, because @code{histc} has two outputs, whereas\n\
737 \n\
738 @example\n\
739 nargout (@@deal)\n\
740 @end example\n\
741 \n\
742 @noindent\n\
743 will return -1, because @code{deal} has a variable number of outputs.\n\
744 \n\
745 At the top level, @code{nargout} with no argument is undefined.\n\
746 @code{nargout} does not work on builtin functions.\n\
747 @code{nargout} returns -1 for all anonymous functions.\n\
748 @seealso{nargin, varargin, isargout, varargout, nthargout}\n\
749 @end deftypefn")
750 {
751 octave_value retval;
752
753 int nargin = args.length ();
754
755 if (nargin == 1)
756 {
757 octave_value func = args(0);
758
759 if (func.is_string ())
760 {
761 std::string name = func.string_value ();
762 func = symbol_table::find_function (name);
763 if (func.is_undefined ())
764 error ("nargout: invalid function name: %s", name.c_str ());
765 }
766
767 if (func.is_inline_function ())
768 {
769 retval = 1;
770 return retval;
771 }
772
773 if (func.is_function_handle ())
774 {
775 octave_fcn_handle *fh = func.fcn_handle_value ();
776 std::string fh_nm = fh->fcn_name ();
777
778 if (fh_nm == octave_fcn_handle::anonymous)
779 {
780 retval = -1;
781 return retval;
782 }
783 }
784
785 octave_function *fcn_val = func.function_value ();
786 if (fcn_val)
787 {
788 octave_user_function *fcn = fcn_val->user_function_value (true);
789
790 if (fcn)
791 {
792 tree_parameter_list *ret_list = fcn->return_list ();
793
794 retval = ret_list ? ret_list->length () : 0;
795
796 if (fcn->takes_var_return ())
797 retval = -1 - retval;
798 }
799 else
800 {
801 // JWE said this information is not available (currently, 2011-03-10)
802 // without making intrusive changes to Octave.
803 // Matlab gives up for histc, so maybe it's ok we give up somtimes too.
804 error ("nargout: nargout information not available for builtin functions.");
805 }
806 }
807 else
808 error ("nargout: FCN must be a string or function handle");
809 }
810 else if (nargin == 0)
811 {
812 if (! symbol_table::at_top_level ())
813 {
814 retval = symbol_table::varval (".nargout.");
815
816 if (retval.is_undefined ())
817 retval = 0;
818 }
819 else
820 error ("nargout: invalid call at top level");
821 }
822 else
823 print_usage ();
824
825 return retval;
826 }
827
828 DEFUN (optimize_subsasgn_calls, args, nargout,
829 "-*- texinfo -*-\n\
830 @deftypefn {Built-in Function} {@var{val} =} optimize_subsasgn_calls ()\n\
831 @deftypefnx {Built-in Function} {@var{old_val} =} optimize_subsasgn_calls (@var{new_val})\n\
832 @deftypefnx {Built-in Function} {} optimize_subsasgn_calls (@var{new_val}, \"local\")\n\
833 Query or set the internal flag for subsasgn method call optimizations.\n\
834 If true, Octave will attempt to eliminate the redundant copying when calling\n\
835 subsasgn method of a user-defined class.\n\
836 \n\
837 When called from inside a function with the \"local\" option, the variable is\n\
838 changed locally for the function and any subroutines it calls. The original\n\
839 variable value is restored when exiting the function.\n\
840 @end deftypefn")
841 {
842 return SET_INTERNAL_VARIABLE (optimize_subsasgn_calls);
843 }
844
845 static bool val_in_table (const Matrix& table, double val)
846 {
847 if (table.is_empty ())
848 return false;
849
850 octave_idx_type i = table.lookup (val, ASCENDING);
851 return (i > 0 && table(i-1) == val);
852 }
853
854 static bool isargout1 (int nargout, const Matrix& ignored, double k)
855 {
856 if (k != xround (k) || k <= 0)
857 {
858 error ("isargout: K must be a positive integer");
859 return false;
860 }
861 else
862 return (k == 1 || k <= nargout) && ! val_in_table (ignored, k);
863 }
864
865 DEFUN (isargout, args, ,
866 "-*- texinfo -*-\n\
867 @deftypefn {Built-in Function} {} isargout (@var{k})\n\
868 Within a function, return a logical value indicating whether the argument\n\
869 @var{k} will be assigned on output to a variable. If the result is false,\n\
870 the argument has been ignored during the function call through the use of\n\
871 the tilde (~) special output argument. Functions can use @code{isargout} to\n\
872 avoid performing unnecessary calculations for outputs which are unwanted.\n\
873 \n\
874 If @var{k} is outside the range @code{1:max (nargout)}, the function returns\n\
875 false. @var{k} can also be an array, in which case the function works\n\
876 element-by-element and a logical array is returned. At the top level,\n\
877 @code{isargout} returns an error.\n\
878 @seealso{nargout, nargin, varargin, varargout, nthargout}\n\
879 @end deftypefn")
880 {
881 octave_value retval;
882
883 int nargin = args.length ();
884
885 if (nargin == 1)
886 {
887 if (! symbol_table::at_top_level ())
888 {
889 int nargout1 = symbol_table::varval (".nargout.").int_value ();
890 if (error_state)
891 {
892 error ("isargout: internal error");
893 return retval;
894 }
895
896 Matrix ignored;
897 octave_value tmp = symbol_table::varval (".ignored.");
898 if (tmp.is_defined ())
899 ignored = tmp.matrix_value ();
900
901 if (args(0).is_scalar_type ())
902 {
903 double k = args(0).double_value ();
904 if (! error_state)
905 retval = isargout1 (nargout1, ignored, k);
906 }
907 else if (args(0).is_numeric_type ())
908 {
909 const NDArray ka = args(0).array_value ();
910 if (! error_state)
911 {
912 boolNDArray r (ka.dims ());
913 for (octave_idx_type i = 0; i < ka.numel () && ! error_state; i++)
914 r(i) = isargout1 (nargout1, ignored, ka(i));
915
916 retval = r;
917 }
918 }
919 else
920 gripe_wrong_type_arg ("isargout", args(0));
921 }
922 else
923 error ("isargout: invalid call at top level");
924 }
925 else
926 print_usage ();
927
928 return retval;
929 }
930
931 /*
932 %!function [x, y] = try_isargout ()
933 %! if (isargout (1))
934 %! if (isargout (2))
935 %! x = 1; y = 2;
936 %! else
937 %! x = -1;
938 %! endif
939 %! else
940 %! if (isargout (2))
941 %! y = -2;
942 %! else
943 %! error ("no outputs requested");
944 %! endif
945 %! endif
946 %!endfunction
947 %!
948 %!test
949 %! [x, y] = try_isargout ();
950 %! assert ([x, y], [1, 2]);
951 %!
952 %!test
953 %! [x, ~] = try_isargout ();
954 %! assert (x, -1);
955 %!
956 %!test
957 %! [~, y] = try_isargout ();
958 %! assert (y, -2);
959 %!
960 %!error [~, ~] = try_isargout ();
961 %!
962 %% Check to see that isargout isn't sticky:
963 %!test
964 %! [x, y] = try_isargout ();
965 %! assert ([x, y], [1, 2]);
966 */