Mercurial > hg > octave-nkf

comparison src/variables.cc @ 1:78fd87e624cb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[project @ 1993-08-08 01:13:40 by jwe] Initial revision
author jwe
date Sun, 08 Aug 1993 01:13:40 +0000
parents
children 174de3807b61
comparison
equal deleted inserted replaced
0:22412e3a4641 1:78fd87e624cb
1 // variables.cc -*- C++ -*-
2 /*
3
4 Copyright (C) 1992, 1993 John W. Eaton
5
6 This file is part of Octave.
7
8 Octave is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 Octave is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with Octave; see the file COPYING. If not, write to the Free
20 Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
21
22 */
23
24 #ifdef __GNUG__
25 #pragma implementation
26 #endif
27
28 #include <sys/types.h>
29 #ifdef HAVE_UNISTD_H
30 #include <unistd.h>
31 #endif
32 #include <ctype.h>
33 #include <iostream.h>
34
35 #include "statdefs.h"
36 #include "tree-const.h"
37 #include "variables.h"
38 #include "symtab.h"
39 #include "error.h"
40 #include "utils.h"
41 #include "tree.h"
42
43 // Symbol table for symbols at the top level.
44 symbol_table *top_level_sym_tab;
45
46 // Symbol table for the current scope.
47 symbol_table *curr_sym_tab;
48
49 // Symbol table for global symbols.
50 symbol_table *global_sym_tab;
51
52 /*
53 * Is there a corresponding M-file that is newer than the symbol
54 * definition?
55 */
56 int
57 symbol_out_of_date (symbol_record *sr)
58 {
59 int status = 0;
60 if (sr != (symbol_record *) NULL)
61 {
62 tree *ans = sr->def ();
63 if (ans != NULL_TREE)
64 {
65 char *mf = ans->m_file_name ();
66 if (mf != (char *) NULL)
67 {
68 time_t tp = ans->time_parsed ();
69 status = is_newer (mf, tp);
70 }
71 }
72 }
73 return status;
74 }
75
76 /*
77 * Force a symbol into the global symbol table.
78 */
79 symbol_record *
80 force_global (char *name)
81 {
82 symbol_record *retval = (symbol_record *) NULL;
83
84 if (valid_identifier (name))
85 {
86 symbol_record *sr;
87 sr = curr_sym_tab->lookup (name, 0, 0);
88 if (sr == (symbol_record *) NULL)
89 {
90 retval = global_sym_tab->lookup (name, 1, 0);
91 }
92 else if (sr->is_formal_parameter ())
93 {
94 error ("formal parameter `%s' can't be made global", name);
95 }
96 else
97 {
98 retval = global_sym_tab->lookup (name, 1, 0);
99 retval->alias (sr);
100 curr_sym_tab->clear (name);
101 }
102 }
103 else
104 warning ("`%s' is invalid as an identifier", name);
105
106 return retval;
107 }
108
109 int
110 bind_variable (char *varname, tree_constant *val)
111 {
112 // Look for the symbol in the current symbol table. If it's there,
113 // great. If not, don't insert it, but look for it in the global
114 // symbol table. If it's there, great. If not, insert it in the
115 // original current symbol table.
116
117 symbol_record *sr;
118 sr = curr_sym_tab->lookup (varname, 0, 0);
119 if (sr == (symbol_record *) NULL)
120 {
121 sr = global_sym_tab->lookup (varname, 0, 0);
122 if (sr == (symbol_record *) NULL)
123 {
124 sr = curr_sym_tab->lookup (varname, 1);
125 }
126 }
127
128 if (sr != (symbol_record *) NULL)
129 {
130 sr->define (val);
131 return 0;
132 }
133 else
134 return 1;
135 }
136
137 int
138 bind_protected_variable (char *varname, tree_constant *val)
139 {
140 // Look for the symbol in the current symbol table. If it's there,
141 // great. If not, don't insert it, but look for it in the global
142 // symbol table. If it's there, great. If not, insert it in the
143 // original current symbol table.
144
145 symbol_record *sr;
146 sr = curr_sym_tab->lookup (varname, 0, 0);
147 if (sr == (symbol_record *) NULL)
148 {
149 sr = global_sym_tab->lookup (varname, 0, 0);
150 if (sr == (symbol_record *) NULL)
151 {
152 sr = curr_sym_tab->lookup (varname, 1);
153 }
154 }
155
156 if (sr != (symbol_record *) NULL)
157 {
158 sr->unprotect ();
159 sr->define (val);
160 sr->protect ();
161 return 0;
162 }
163 else
164 return 1;
165 }
166
167 /*
168 * Look for name first in current then in global symbol tables. If
169 * name is found and it refers to a string, return a new string
170 * containing its value. Otherwise, return NULL.
171 */
172 char *
173 octave_string_variable (char *name)
174 {
175 char *retval = (char *) NULL;
176 symbol_record *sr;
177 sr = curr_sym_tab->lookup (name, 0, 0);
178 if (sr == (symbol_record *) NULL)
179 {
180 sr = global_sym_tab->lookup (name, 0, 0);
181 if (sr == (symbol_record *) NULL)
182 return retval;
183 }
184
185 tree *defn = sr->def ();
186 if (defn != NULL_TREE)
187 {
188 tree_constant val = defn->eval (0);
189 if (val.is_string_type ())
190 {
191 char *s = val.string_value ();
192 if (s != (char *) NULL)
193 retval = strsave (s);
194 }
195 }
196
197 return retval;
198 }
199
200 /*
201 * Look for name first in current then in global symbol tables. If
202 * name is found and it refers to a real scalar, place the value in d
203 * and return 0. Otherwise, return -1.
204 */
205 int
206 octave_real_scalar_variable (char *name, double& d)
207 {
208 int status = -1;
209 symbol_record *sr;
210 sr = curr_sym_tab->lookup (name, 0, 0);
211 if (sr == (symbol_record *) NULL)
212 {
213 sr = global_sym_tab->lookup (name, 0, 0);
214 if (sr == (symbol_record *) NULL)
215 return status;
216 }
217
218 tree *defn = sr->def ();
219 if (defn != NULL_TREE)
220 {
221 tree_constant val = defn->eval (0);
222 if (val.const_type () == tree_constant_rep::scalar_constant)
223 {
224 d = val.double_value ();
225 status = 0;
226 }
227 }
228
229 return status;
230 }
231
232 /*
233 * Extract a keyword and its value from a file. Input should look
234 * something like:
235 *
236 * #[ \t]*keyword[ \t]*:[ \t]*string-value\n
237 */
238 int
239 extract_keyword (istream& is, char *keyword, char *value)
240 {
241 char *ptr = value;
242
243 int status = 0;
244
245 char c;
246 while (is.get (c))
247 {
248 if (c == '#')
249 {
250 while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
251 ; // Skip whitespace and comment characters.
252
253 if (isalpha (c))
254 *ptr++ = c;
255
256 while (is.get (c) && isalpha (c))
257 *ptr++ = c;
258
259 if (strncmp (value, keyword, strlen (keyword)) == 0)
260 {
261 ptr = value;
262 while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
263 ; // Skip whitespace and the colon.
264
265 if (c != '\n')
266 {
267 *ptr++ = c;
268 while (is.get (c) && c != '\n')
269 *ptr++ = c;
270 }
271 *ptr = '\0';
272 status = 1;
273 break;
274 }
275 }
276 }
277 return status;
278 }
279
280 int
281 extract_keyword (istream& is, char *keyword, int& value)
282 {
283 char buf [128];
284 char *ptr = buf;
285
286 int status = 0;
287 value = 0;
288
289 char c;
290 while (is.get (c))
291 {
292 if (c == '#')
293 {
294 while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
295 ; // Skip whitespace and comment characters.
296
297 if (isalpha (c))
298 *ptr++ = c;
299
300 while (is.get (c) && isalpha (c))
301 *ptr++ = c;
302
303 if (strncmp (buf, keyword, strlen (keyword)) == 0)
304 {
305 ptr = buf;
306 while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
307 ; // Skip whitespace and the colon.
308
309 is.putback (c);
310 if (c != '\n')
311 is >> value;
312 if (is)
313 status = 1;
314 while (is.get (c) && c != '\n')
315 ; // Skip to beginning of next line;
316 break;
317 }
318 }
319 }
320 return status;
321 }
322
323 /*
324 * Skip trailing white space and
325 */
326 void
327 skip_comments (istream& is)
328 {
329 char c = '\0';
330 while (is.get (c))
331 {
332 if (c == ' ' || c == '\t' || c == '\n')
333 ; // Skip whitespace on way to beginning of next line.
334 else
335 break;
336 }
337
338 for (;;)
339 {
340 if (is && c == '#')
341 while (is.get (c) && c != '\n')
342 ; // Skip to beginning of next line, ignoring everything.
343 else
344 break;
345 }
346 }
347
348 /*
349 * Is `s' a valid identifier?
350 */
351 int
352 valid_identifier (char *s)
353 {
354 if (s == (char *) NULL || ! (isalnum (*s) || *s == '_'))
355 return 0;
356
357 while (*++s != '\0')
358 if (! (isalnum (*s) || *s == '_'))
359 return 0;
360
361 return 1;
362 }
363
364 /*
365 * See if the identifier is in scope.
366 */
367 int
368 identifier_exists (char *name)
369 {
370 int status = 0;
371
372 if (curr_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL
373 || global_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL)
374 status = 1;
375 else
376 {
377 char *path = m_file_in_path (name);
378 if (path != (char *) NULL)
379 {
380 delete [] path;
381 status = 2;
382 }
383 else
384 {
385 struct stat buf;
386 if (stat (name, &buf) == 0 && S_ISREG (buf.st_mode))
387 status = 2;
388 }
389
390 }
391 return status;
392 }
393
394 /*
395 * Is this tree_constant a valid function?
396 */
397 tree *
398 is_valid_function (tree_constant& arg, char *warn_for, int warn = 0)
399 {
400 tree *ans = NULL_TREE;
401
402 if (! arg.is_string_type ())
403 {
404 if (warn)
405 message (warn_for, "expecting function name as argument");
406 return ans;
407 }
408
409 char *fcn_name = arg.string_value ();
410 symbol_record *sr = global_sym_tab->lookup (fcn_name, 0, 0);
411
412 if (sr == (symbol_record *) NULL)
413 {
414 sr = global_sym_tab->lookup (fcn_name, 1, 0);
415 tree_identifier tmp (sr);
416 tmp.parse_m_file (0);
417 }
418 else if (symbol_out_of_date (sr))
419 {
420 tree_identifier tmp (sr);
421 tmp.parse_m_file (0);
422 }
423
424 ans = sr->def ();
425 if (ans == NULL_TREE || ! sr->is_function ())
426 {
427 if (warn)
428 message (warn_for, "the symbol `%s' is not valid as a function",
429 fcn_name);
430 ans = NULL_TREE;
431 }
432
433 return ans;
434 }
435
436 /*
437 * Does this function take the right number of arguments?
438 */
439 int
440 takes_correct_nargs (tree *fcn, int expected_nargin, char *warn_for,
441 int warn = 0)
442 {
443 int nargs = fcn->max_expected_args () - 1;
444 int e_nargs = expected_nargin - 1;
445 if (nargs != e_nargs)
446 {
447 if (warn)
448 message (warn_for, "expecting function to take %d argument%c",
449 e_nargs, s_plural (e_nargs));
450 return 0;
451 }
452 return 1;
453 }
454
455 char **
456 make_name_list (void)
457 {
458 int key_len = 0;
459 int glb_len = 0;
460 int top_len = 0;
461 int lcl_len = 0;
462 int mfl_len = 0;
463
464 char **key = (char **) NULL;
465 char **glb = (char **) NULL;
466 char **top = (char **) NULL;
467 char **lcl = (char **) NULL;
468 char **mfl = (char **) NULL;
469
470 key = names (keyword_help (), key_len);
471 glb = global_sym_tab->list (glb_len);
472 top = top_level_sym_tab->list (top_len);
473 if (top_level_sym_tab != curr_sym_tab)
474 lcl = curr_sym_tab->list (lcl_len);
475 mfl = get_m_file_names (mfl_len, 1);
476
477 int total_len = key_len + glb_len + top_len + lcl_len + mfl_len;
478
479 char **list = new char * [total_len+1];
480
481 int j = 0;
482 int i = 0;
483 for (i = 0; i < key_len; i++)
484 list[j++] = key[i];
485
486 for (i = 0; i < glb_len; i++)
487 list[j++] = glb[i];
488
489 for (i = 0; i < top_len; i++)
490 list[j++] = top[i];
491
492 for (i = 0; i < lcl_len; i++)
493 list[j++] = lcl[i];
494
495 for (i = 0; i < mfl_len; i++)
496 list[j++] = mfl[i];
497
498 list[j] = (char *) NULL;
499
500 delete [] key;
501 delete [] glb;
502 delete [] top;
503 delete [] lcl;
504 delete [] mfl;
505
506 return list;
507 }
508
509 /*
510 ;;; Local Variables: ***
511 ;;; mode: C++ ***
512 ;;; page-delimiter: "^/\\*" ***
513 ;;; End: ***
514 */