Mercurial > octave-nkf
comparison src/ov-usr-fcn.cc @ 2974:ebbc34ff7f66
[project @ 1997-05-15 19:36:16 by jwe]
author | jwe |
---|---|
date | Thu, 15 May 1997 19:42:59 +0000 |
parents | |
children | 20f5cec4f11c |
comparison
equal
deleted
inserted
replaced
2973:ef3379196bcf | 2974:ebbc34ff7f66 |
---|---|
1 /* | |
2 | |
3 Copyright (C) 1996, 1997 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 2, or (at your option) any | |
10 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, write to the Free | |
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
20 | |
21 */ | |
22 | |
23 #if defined (__GNUG__) | |
24 #pragma implementation | |
25 #endif | |
26 | |
27 #ifdef HAVE_CONFIG_H | |
28 #include <config.h> | |
29 #endif | |
30 | |
31 #include "str-vec.h" | |
32 | |
33 #include <defaults.h> | |
34 #include "defun.h" | |
35 #include "error.h" | |
36 #include "help.h" | |
37 #include "input.h" | |
38 #include "oct-obj.h" | |
39 #include "ov-usr-fcn.h" | |
40 #include "ov.h" | |
41 #include "pager.h" | |
42 #include "pt-misc.h" | |
43 #include "pt-pr-code.h" | |
44 #include "pt-walk.h" | |
45 #include "symtab.h" | |
46 #include "toplev.h" | |
47 #include "unwind-prot.h" | |
48 #include "utils.h" | |
49 #include "variables.h" | |
50 | |
51 // If TRUE, variables returned from functions have default values even | |
52 // if they are not explicitly initialized. | |
53 static bool Vdefine_all_return_values; | |
54 | |
55 // If TRUE, the last computed value is returned from functions that | |
56 // don't actually define any return variables. | |
57 static bool Vreturn_last_computed_value; | |
58 | |
59 // Nonzero means we're breaking out of a loop or function body. | |
60 extern int breaking; | |
61 | |
62 // Nonzero means we're returning from a function. | |
63 extern int returning; | |
64 | |
65 // User defined functions. | |
66 | |
67 octave_allocator | |
68 octave_user_function::allocator (sizeof (octave_user_function)); | |
69 | |
70 int | |
71 octave_user_function::t_id (-1); | |
72 | |
73 const string | |
74 octave_user_function::t_name ("user-defined function"); | |
75 | |
76 // Ugh. This really needs to be simplified (code/data? | |
77 // extrinsic/intrinsic state?). | |
78 | |
79 octave_user_function::octave_user_function | |
80 (tree_parameter_list *pl, tree_parameter_list *rl, | |
81 tree_statement_list *cl, symbol_table *st) | |
82 : octave_function (string (), string ()), | |
83 param_list (pl), ret_list (rl), cmd_list (cl), | |
84 sym_tab (st), file_name (), fcn_name (), t_parsed (0), | |
85 system_fcn_file (false), call_depth (0), num_named_args (0), | |
86 args_passed (), num_args_passed (0), curr_va_arg_number (0), | |
87 vr_list (0), symtab_entry (0), argn_sr (0), nargin_sr (0), | |
88 nargout_sr (0) | |
89 { | |
90 install_automatic_vars (); | |
91 | |
92 if (param_list) | |
93 { | |
94 num_named_args = param_list->length (); | |
95 curr_va_arg_number = num_named_args; | |
96 } | |
97 } | |
98 | |
99 octave_user_function::~octave_user_function (void) | |
100 { | |
101 delete param_list; | |
102 delete ret_list; | |
103 delete sym_tab; | |
104 delete cmd_list; | |
105 delete vr_list; | |
106 } | |
107 | |
108 octave_user_function * | |
109 octave_user_function::define_ret_list (tree_parameter_list *t) | |
110 { | |
111 ret_list = t; | |
112 | |
113 if (ret_list && ret_list->takes_varargs ()) | |
114 vr_list = new tree_va_return_list; | |
115 | |
116 return this; | |
117 } | |
118 | |
119 void | |
120 octave_user_function::stash_fcn_file_name (void) | |
121 { | |
122 if (fcn_name.empty ()) | |
123 file_name = ""; | |
124 else | |
125 file_name = fcn_file_in_path (fcn_name); | |
126 } | |
127 | |
128 void | |
129 octave_user_function::mark_as_system_fcn_file (void) | |
130 { | |
131 if (! file_name.empty ()) | |
132 { | |
133 // We really should stash the whole path to the file we found, | |
134 // when we looked it up, to avoid possible race conditions... | |
135 // XXX FIXME XXX | |
136 // | |
137 // We probably also don't need to get the library directory | |
138 // every time, but since this function is only called when the | |
139 // function file is parsed, it probably doesn't matter that | |
140 // much. | |
141 | |
142 string ff_name = fcn_file_in_path (file_name); | |
143 | |
144 if (Vfcn_file_dir.compare (ff_name, 0, Vfcn_file_dir.length ()) == 0) | |
145 system_fcn_file = 1; | |
146 } | |
147 else | |
148 system_fcn_file = 0; | |
149 } | |
150 | |
151 bool | |
152 octave_user_function::takes_varargs (void) const | |
153 { | |
154 return (param_list && param_list->takes_varargs ()); | |
155 } | |
156 | |
157 octave_value | |
158 octave_user_function::octave_va_arg (void) | |
159 { | |
160 octave_value retval; | |
161 | |
162 if (curr_va_arg_number < num_args_passed) | |
163 retval = args_passed (curr_va_arg_number++); | |
164 else | |
165 ::error ("va_arg: error getting arg number %d -- only %d provided", | |
166 curr_va_arg_number + 1, num_args_passed); | |
167 | |
168 return retval; | |
169 } | |
170 | |
171 octave_value_list | |
172 octave_user_function::octave_all_va_args (void) | |
173 { | |
174 octave_value_list retval; | |
175 | |
176 retval.resize (num_args_passed - num_named_args); | |
177 | |
178 int k = 0; | |
179 for (int i = num_named_args; i < num_args_passed; i++) | |
180 retval(k++) = args_passed(i); | |
181 | |
182 return retval; | |
183 } | |
184 | |
185 bool | |
186 octave_user_function::takes_var_return (void) const | |
187 { | |
188 return (ret_list && ret_list->takes_varargs ()); | |
189 } | |
190 | |
191 void | |
192 octave_user_function::octave_vr_val (const octave_value& val) | |
193 { | |
194 assert (vr_list); | |
195 | |
196 vr_list->append (val); | |
197 } | |
198 | |
199 void | |
200 octave_user_function::stash_function_name (const string& s) | |
201 { | |
202 fcn_name = s; | |
203 } | |
204 | |
205 // For unwind protect. | |
206 | |
207 static void | |
208 pop_symbol_table_context (void *table) | |
209 { | |
210 symbol_table *tmp = static_cast<symbol_table *> (table); | |
211 tmp->pop_context (); | |
212 } | |
213 | |
214 static void | |
215 delete_vr_list (void *list) | |
216 { | |
217 tree_va_return_list *tmp = static_cast<tree_va_return_list *> (list); | |
218 tmp->clear (); | |
219 delete tmp; | |
220 } | |
221 | |
222 static void | |
223 clear_symbol_table (void *table) | |
224 { | |
225 symbol_table *tmp = static_cast<symbol_table *> (table); | |
226 tmp->clear (); | |
227 } | |
228 | |
229 static void | |
230 unprotect_function (void *sr_arg) | |
231 { | |
232 symbol_record *sr = static_cast<symbol_record *> (sr_arg); | |
233 sr->unprotect (); | |
234 } | |
235 | |
236 octave_value_list | |
237 octave_user_function::do_index_op (int nargout, const octave_value_list& args) | |
238 { | |
239 octave_value_list retval; | |
240 | |
241 if (error_state) | |
242 return retval; | |
243 | |
244 if (! cmd_list) | |
245 return retval; | |
246 | |
247 int nargin = args.length (); | |
248 | |
249 begin_unwind_frame ("func_eval"); | |
250 | |
251 unwind_protect_int (call_depth); | |
252 call_depth++; | |
253 | |
254 if (symtab_entry && ! symtab_entry->is_read_only ()) | |
255 { | |
256 symtab_entry->protect (); | |
257 add_unwind_protect (unprotect_function, symtab_entry); | |
258 } | |
259 | |
260 if (call_depth > 1) | |
261 { | |
262 sym_tab->push_context (); | |
263 add_unwind_protect (pop_symbol_table_context, sym_tab); | |
264 | |
265 if (vr_list) | |
266 { | |
267 // Push new vr_list. | |
268 | |
269 unwind_protect_ptr (vr_list); | |
270 vr_list = new tree_va_return_list; | |
271 | |
272 // Clear and delete the new one before restoring the old | |
273 // one. | |
274 | |
275 add_unwind_protect (delete_vr_list, vr_list); | |
276 } | |
277 } | |
278 | |
279 if (vr_list) | |
280 vr_list->clear (); | |
281 | |
282 // Force symbols to be undefined again when this function exits. | |
283 | |
284 add_unwind_protect (clear_symbol_table, sym_tab); | |
285 | |
286 // Save old and set current symbol table context, for | |
287 // eval_undefined_error(). | |
288 | |
289 unwind_protect_ptr (curr_sym_tab); | |
290 curr_sym_tab = sym_tab; | |
291 | |
292 unwind_protect_ptr (curr_function); | |
293 curr_function = this; | |
294 | |
295 // XXX FIXME XXX -- ??? | |
296 // unwind_protect_ptr (args_passed); | |
297 | |
298 args_passed = args; | |
299 | |
300 string_vector arg_names = args.name_tags (); | |
301 | |
302 unwind_protect_int (num_args_passed); | |
303 num_args_passed = nargin; | |
304 | |
305 unwind_protect_int (num_named_args); | |
306 unwind_protect_int (curr_va_arg_number); | |
307 | |
308 if (param_list && ! param_list->varargs_only ()) | |
309 { | |
310 param_list->define_from_arg_vector (args); | |
311 if (error_state) | |
312 goto abort; | |
313 } | |
314 | |
315 if (ret_list && Vdefine_all_return_values) | |
316 { | |
317 octave_value tmp = builtin_any_variable ("default_return_value"); | |
318 | |
319 if (tmp.is_defined ()) | |
320 ret_list->initialize_undefined_elements (tmp); | |
321 } | |
322 | |
323 // The following code is in a separate scope to avoid warnings from | |
324 // G++ about `goto abort' crossing the initialization of some | |
325 // variables. | |
326 | |
327 { | |
328 bind_automatic_vars (arg_names, nargin, nargout); | |
329 | |
330 bool echo_commands = (Vecho_executing_commands & ECHO_FUNCTIONS); | |
331 | |
332 if (echo_commands) | |
333 print_code_function_header (); | |
334 | |
335 // Evaluate the commands that make up the function. | |
336 | |
337 octave_value_list tmp = cmd_list->eval (); | |
338 | |
339 octave_value last_computed_value; | |
340 | |
341 if (! tmp.empty ()) | |
342 last_computed_value = tmp(0); | |
343 | |
344 if (echo_commands) | |
345 print_code_function_trailer (); | |
346 | |
347 if (returning) | |
348 returning = 0; | |
349 | |
350 if (breaking) | |
351 breaking--; | |
352 | |
353 if (error_state) | |
354 { | |
355 traceback_error (); | |
356 goto abort; | |
357 } | |
358 | |
359 // Copy return values out. | |
360 | |
361 if (ret_list) | |
362 retval = ret_list->convert_to_const_vector (vr_list); | |
363 else if (Vreturn_last_computed_value) | |
364 retval(0) = last_computed_value; | |
365 } | |
366 | |
367 abort: | |
368 run_unwind_frame ("func_eval"); | |
369 | |
370 return retval; | |
371 } | |
372 | |
373 void | |
374 octave_user_function::traceback_error (void) | |
375 { | |
376 if (error_state >= 0) | |
377 error_state = -1; | |
378 | |
379 if (fcn_name.empty ()) | |
380 { | |
381 if (file_name.empty ()) | |
382 ::error ("called from `?unknown?'"); | |
383 else | |
384 ::error ("called from file `%s'", file_name.c_str ()); | |
385 } | |
386 else | |
387 { | |
388 if (file_name.empty ()) | |
389 ::error ("called from `%s'", fcn_name.c_str ()); | |
390 else | |
391 ::error ("called from `%s' in file `%s'", | |
392 fcn_name.c_str (), file_name.c_str ()); | |
393 } | |
394 } | |
395 | |
396 void | |
397 octave_user_function::accept (tree_walker& tw) | |
398 { | |
399 tw.visit_octave_user_function (*this); | |
400 } | |
401 | |
402 void | |
403 octave_user_function::print_code_function_header (void) | |
404 { | |
405 tree_print_code tpc (octave_stdout, Vps4); | |
406 | |
407 tpc.visit_octave_user_function_header (*this); | |
408 } | |
409 | |
410 void | |
411 octave_user_function::print_code_function_trailer (void) | |
412 { | |
413 tree_print_code tpc (octave_stdout, Vps4); | |
414 | |
415 tpc.visit_octave_user_function_trailer (*this); | |
416 } | |
417 | |
418 void | |
419 octave_user_function::install_automatic_vars (void) | |
420 { | |
421 argn_sr = sym_tab->lookup ("argn", true); | |
422 nargin_sr = sym_tab->lookup ("nargin", true); | |
423 nargout_sr = sym_tab->lookup ("nargout", true); | |
424 } | |
425 | |
426 void | |
427 octave_user_function::bind_automatic_vars | |
428 (const string_vector& arg_names, int nargin, int nargout) | |
429 { | |
430 if (! arg_names.empty ()) | |
431 argn_sr->define (arg_names); | |
432 | |
433 nargin_sr->define (static_cast<double> (nargin)); | |
434 nargout_sr->define (static_cast<double> (nargout)); | |
435 } | |
436 | |
437 DEFUN (va_arg, args, , | |
438 "va_arg (): return next argument in a function that takes a\n\ | |
439 variable number of parameters") | |
440 { | |
441 octave_value_list retval; | |
442 | |
443 int nargin = args.length (); | |
444 | |
445 if (nargin == 0) | |
446 { | |
447 if (curr_function) | |
448 { | |
449 if (curr_function->takes_varargs ()) | |
450 retval = curr_function->octave_va_arg (); | |
451 else | |
452 { | |
453 ::error ("va_arg only valid within function taking variable"); | |
454 ::error ("number of arguments"); | |
455 } | |
456 } | |
457 else | |
458 ::error ("va_arg only valid within function body"); | |
459 } | |
460 else | |
461 print_usage ("va_arg"); | |
462 | |
463 return retval; | |
464 } | |
465 | |
466 DEFUN (va_start, args, , | |
467 "va_start (): reset the pointer to the list of optional arguments\n\ | |
468 to the beginning") | |
469 { | |
470 octave_value_list retval; | |
471 | |
472 int nargin = args.length (); | |
473 | |
474 if (nargin == 0) | |
475 { | |
476 if (curr_function) | |
477 { | |
478 if (curr_function->takes_varargs ()) | |
479 curr_function->octave_va_start (); | |
480 else | |
481 { | |
482 ::error ("va_start only valid within function taking variable"); | |
483 ::error ("number of arguments"); | |
484 } | |
485 } | |
486 else | |
487 ::error ("va_start only valid within function body"); | |
488 } | |
489 else | |
490 print_usage ("va_start"); | |
491 | |
492 return retval; | |
493 } | |
494 | |
495 DEFUN (vr_val, args, , | |
496 "vr_val (X): append X to the list of optional return values for a\n\ | |
497 function that allows a variable number of return values") | |
498 { | |
499 octave_value_list retval; | |
500 | |
501 int nargin = args.length (); | |
502 | |
503 if (nargin == 1) | |
504 { | |
505 if (curr_function) | |
506 { | |
507 if (curr_function->takes_var_return ()) | |
508 curr_function->octave_vr_val (args(0)); | |
509 else | |
510 { | |
511 ::error ("vr_val only valid within function declared to"); | |
512 ::error ("produce a variable number of values"); | |
513 } | |
514 } | |
515 else | |
516 ::error ("vr_val only valid within function body"); | |
517 } | |
518 else | |
519 print_usage ("vr_val"); | |
520 | |
521 return retval; | |
522 } | |
523 | |
524 static int | |
525 define_all_return_values (void) | |
526 { | |
527 Vdefine_all_return_values = check_preference ("define_all_return_values"); | |
528 | |
529 return 0; | |
530 } | |
531 | |
532 static int | |
533 return_last_computed_value (void) | |
534 { | |
535 Vreturn_last_computed_value | |
536 = check_preference ("return_last_computed_value"); | |
537 | |
538 return 0; | |
539 } | |
540 | |
541 void | |
542 symbols_of_ov_usr_fcn (void) | |
543 { | |
544 DEFVAR (default_return_value, Matrix (), 0, 0, | |
545 "the default for value for unitialized variables returned from\n\ | |
546 functions. Only used if the variable initialize_return_values is\n\ | |
547 set to \"true\"."); | |
548 | |
549 DEFVAR (define_all_return_values, 0.0, 0, define_all_return_values, | |
550 "control whether values returned from functions should have a\n\ | |
551 value even if one has not been explicitly assigned. See also\n\ | |
552 default_return_value"); | |
553 | |
554 DEFVAR (return_last_computed_value, 0.0, 0, return_last_computed_value, | |
555 "if a function does not return any values explicitly, return the\n\ | |
556 last computed value"); | |
557 } | |
558 | |
559 /* | |
560 ;;; Local Variables: *** | |
561 ;;; mode: C++ *** | |
562 ;;; End: *** | |
563 */ |