1 /*
2 * gretl -- Gnu Regression, Econometrics and Time-series Library
3 * Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
4 *
5 * This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19 #define FULL_XML_HEADERS
20
21 #include "libgretl.h"
22 #include "gretl_xml.h"
23 #include "gretl_func.h"
24 #include "usermat.h"
25 #include "gretl_string_table.h"
26 #include "matrix_extra.h"
27 #include "libset.h"
28 #include "monte_carlo.h"
29 #include "gretl_typemap.h"
30 #include "uservar.h"
31 #include "uservar_priv.h"
32 #include "gretl_cmatrix.h"
33
34 #ifdef WIN32
35 # include "gretl_win32.h"
36 #endif
37
38 #define UVDEBUG 0
39 #define HDEBUG 0
40
41 #if HDEBUG && defined(_OPENMP)
42 # include <omp.h>
43 #endif
44
45 #define LEVEL_AUTO -1
46 #define LEV_PRIVATE -1
47
48 static user_var **uvars;
49 static int n_vars;
50 static int n_alloc;
51 static int scalar_imin;
52
53 /* callback for the benefit of the edit scalars window
54 in the gretl GUI */
55
56 static void (*scalar_edit_callback)(void);
57
58 /* callback for adding or deleting icons representing
59 things in the GUI session window */
60
61 static USER_VAR_FUNC user_var_callback;
62
63 #define UV_CHUNK 32
64
65 #define var_is_private(u) ((u->flags & UV_PRIVATE) || *u->name == '$' || *u->name == '_')
66 #define var_is_shell(u) (u->flags & UV_SHELL)
67
na_ptr(void)68 static double *na_ptr (void)
69 {
70 double *px = malloc(sizeof *px);
71
72 if (px != NULL) {
73 *px = NADBL;
74 }
75
76 return px;
77 }
78
user_var_new(const char * name,int type,void * value,int * err)79 static user_var *user_var_new (const char *name, int type,
80 void *value, int *err)
81 {
82 user_var *u;
83
84 if (type == GRETL_TYPE_NONE) {
85 *err = E_DATA;
86 fputs("user_var_new: type = GRETL_TYPE_NONE\n", stderr);
87 return NULL;
88 }
89
90 u = malloc(sizeof *u);
91
92 if (u == NULL) {
93 *err = E_ALLOC;
94 } else {
95 u->type = type;
96 u->level = gretl_function_depth();
97 u->flags = (u->level == 0)? UV_MAIN : 0;
98 *u->name = '\0';
99 strncat(u->name, name, VNAMELEN - 1);
100 u->ptr = NULL;
101
102 if (type == GRETL_TYPE_MATRIX) {
103 gretl_matrix *m = value;
104
105 if (m == NULL) {
106 u->ptr = gretl_null_matrix_new();
107 } else if (get_user_var_by_data(m) != NULL) {
108 /* this check should be redundant? */
109 u->ptr = gretl_matrix_copy(m);
110 } else {
111 u->ptr = value;
112 }
113 } else if (type == GRETL_TYPE_BUNDLE) {
114 if (value == NULL) {
115 u->ptr = gretl_bundle_new();
116 } else {
117 u->ptr = value;
118 }
119 } else if (type == GRETL_TYPE_STRING) {
120 if (value == NULL) {
121 u->ptr = gretl_strdup("");
122 } else {
123 u->ptr = value;
124 }
125 } else if (type == GRETL_TYPE_LIST) {
126 if (value == NULL) {
127 u->ptr = gretl_null_list();
128 } else {
129 u->ptr = value;
130 }
131 } else if (type == GRETL_TYPE_DOUBLE) {
132 if (value == NULL) {
133 u->ptr = na_ptr();
134 } else {
135 u->ptr = value;
136 }
137 } else if (gretl_array_type(type) || type == GRETL_TYPE_ANY) {
138 if (value == NULL) {
139 u->ptr = gretl_array_new(type, 0, err);
140 } else {
141 u->ptr = value;
142 }
143 u->type = GRETL_TYPE_ARRAY;
144 } else {
145 fprintf(stderr, "user_var_new error, type=%d (%s)\n", type,
146 gretl_type_get_name(type));
147 *err = E_DATA;
148 }
149 }
150
151 if (u->ptr == NULL) {
152 if (!*err) {
153 *err = E_ALLOC;
154 }
155 free(u);
156 u = NULL;
157 }
158
159 return u;
160 }
161
uvar_free_value(user_var * u)162 static void uvar_free_value (user_var *u)
163 {
164 if (u->ptr == NULL) {
165 return;
166 } else if (u->type == GRETL_TYPE_MATRIX) {
167 gretl_matrix_free(u->ptr);
168 } else if (u->type == GRETL_TYPE_BUNDLE) {
169 gretl_bundle_destroy(u->ptr);
170 } else if (u->type == GRETL_TYPE_STRING) {
171 bufgets_finalize(u->ptr);
172 free(u->ptr);
173 } else if (u->type == GRETL_TYPE_ARRAY) {
174 gretl_array_destroy(u->ptr);
175 } else {
176 /* scalar, list */
177 free(u->ptr);
178 }
179 }
180
181 static GHashTable *uvh0; /* for use at "main" exec level */
182 static GHashTable *uvh1; /* for use within functions */
183 static GHashTable *uvars_hash; /* pointer to one or other of the above */
184 static int previous_d = -1; /* record of previous "function depth" */
185
set_previous_depth(int d)186 void set_previous_depth (int d)
187 {
188 previous_d = d;
189 }
190
get_previous_depth(void)191 static int get_previous_depth (void)
192 {
193 return previous_d;
194 }
195
switch_uservar_hash(int level)196 void switch_uservar_hash (int level)
197 {
198 #if HDEBUG && defined(_OPENMP)
199 fprintf(stderr, "switch_uservar_hash: level %d, nthreads %d\n",
200 level, omp_get_num_threads());
201 #endif
202
203 if (level == 0) {
204 uvars_hash = uvh0;
205 if (uvh1 != NULL) {
206 g_hash_table_remove_all(uvh1);
207 }
208 } else {
209 uvars_hash = uvh1;
210 }
211 }
212
uvar_hash_destroy(void)213 static void uvar_hash_destroy (void)
214 {
215 #if HDEBUG
216 fprintf(stderr, "uvar_hash_destroy (uvh0=%p, uvh1=%p)\n",
217 (void *) uvh0, (void *) uvh1);
218 #endif
219
220 if (uvh0 != NULL) {
221 #if HDEBUG
222 fprintf(stderr, " destroying uvh0\n");
223 #endif
224 g_hash_table_destroy(uvh0);
225 uvh0 = NULL;
226 }
227
228 if (uvh1 != NULL) {
229 #if HDEBUG
230 fprintf(stderr, " destroying uvh1\n");
231 #endif
232 g_hash_table_destroy(uvh1);
233 uvh1 = NULL;
234 }
235
236 /* also NULL the convenience pointer */
237 uvars_hash = NULL;
238
239 set_previous_depth(-1);
240 }
241
user_var_destroy(user_var * u)242 static void user_var_destroy (user_var *u)
243 {
244 #if HDEBUG
245 fprintf(stderr, "user_var_destroy: '%s' (level %d)\n", u->name, u->level);
246 #endif
247
248 if (uvars_hash != NULL) {
249 # if HDEBUG
250 if (g_hash_table_remove(uvars_hash, u->name)) {
251 fprintf(stderr, "removed '%s' from hash table at %p\n",
252 u->name, (void *) uvars_hash);
253 }
254 # else
255 g_hash_table_remove(uvars_hash, u->name);
256 # endif
257 }
258
259 if (!var_is_shell(u)) {
260 uvar_free_value(u);
261 }
262
263 free(u);
264 }
265
resize_uvar_stack(int n)266 static int resize_uvar_stack (int n)
267 {
268 int err = 0;
269
270 if (n > n_alloc) {
271 int n_new = n_alloc + UV_CHUNK;
272 user_var **tmp;
273
274 tmp = realloc(uvars, n_new * sizeof *tmp);
275 if (tmp == NULL) {
276 err = E_ALLOC;
277 } else {
278 uvars = tmp;
279 n_alloc = n_new;
280 }
281 }
282
283 return err;
284 }
285
set_nvars(int n,const char * caller)286 static void set_nvars (int n, const char *caller)
287 {
288 #if UVDEBUG
289 fprintf(stderr, "%s: setting n_vars = %d (was %d)\n",
290 caller, n, n_vars);
291 #endif
292 n_vars = n;
293 }
294
bname_is_temp(const char * name)295 static int bname_is_temp (const char *name)
296 {
297 return !strncmp(name, "btmp___", 7) && isdigit(name[7]);
298 }
299
real_user_var_add(const char * name,GretlType type,void * value,gretlopt opt)300 static int real_user_var_add (const char *name,
301 GretlType type,
302 void *value,
303 gretlopt opt)
304 {
305 user_var *u;
306 int err = 0;
307
308 u = user_var_new(name, type, value, &err);
309
310 if (u == NULL) {
311 fprintf(stderr, "real_user_var_add: name='%s', value=%p, u=%p\n",
312 name, value, (void *) u);
313 return err ? err : E_DATA;
314 }
315
316 /* We use OPT_P for a private variable, OPT_A
317 when adding as a function argument, OPT_S
318 when adding as a "shell" variable, OPT_C
319 when we're auto-casting a 1 x 1 matrix result
320 to a scalar.
321 */
322
323 #if UVDEBUG
324 fprintf(stderr, "real_user_var_add: '%s', level %d, err = %d\n",
325 name, u->level, err);
326 #endif
327
328 if (!err) {
329 err = resize_uvar_stack(n_vars + 1);
330 if (!err) {
331 if (opt & OPT_P) {
332 u->flags = UV_PRIVATE;
333 } else if (opt & OPT_S) {
334 u->flags = UV_SHELL;
335 }
336 if (opt & OPT_A) {
337 u->flags &= ~UV_MAIN;
338 u->level += 1;
339 }
340 if (opt & OPT_C) {
341 u->flags |= UV_NODECL;
342 }
343 uvars[n_vars] = u;
344 set_nvars(n_vars + 1, "user_var_add");
345 }
346 }
347
348 if (!err && user_var_callback != NULL && u->level == 0 &&
349 !(opt & (OPT_P | OPT_S)) && *name != '$' &&
350 (type == GRETL_TYPE_MATRIX || type == GRETL_TYPE_BUNDLE) &&
351 !(type == GRETL_TYPE_BUNDLE && bname_is_temp(name))) {
352 return (*user_var_callback)(name, type, UVAR_ADD);
353 }
354
355 return err;
356 }
357
358 /**
359 * user_var_add:
360 * @name: name to give the variable.
361 * @type: the type of the variable.
362 * @value: pointer to value for variable.
363 *
364 * Adds a new user-variable with the given characteristics.
365 * Note that the user-variable takes ownership of the
366 * supplied @value; this should be copied first if need be.
367 *
368 * Returns: 0 on success, non-zero code on error.
369 */
370
user_var_add(const char * name,GretlType type,void * value)371 int user_var_add (const char *name, GretlType type, void *value)
372 {
373 return real_user_var_add(name, type, value, OPT_NONE);
374 }
375
private_matrix_add(gretl_matrix * M,const char * name)376 int private_matrix_add (gretl_matrix *M, const char *name)
377 {
378 return real_user_var_add(name, GRETL_TYPE_MATRIX, M, OPT_P);
379 }
380
private_scalar_add(double val,const char * name)381 int private_scalar_add (double val, const char *name)
382 {
383 double *px = malloc(sizeof *px);
384 int err;
385
386 if (px == NULL) {
387 err = E_ALLOC;
388 } else {
389 *px = val;
390 err = real_user_var_add(name, GRETL_TYPE_DOUBLE,
391 px, OPT_P);
392 }
393
394 return err;
395 }
396
397 /**
398 * user_var_delete_by_name:
399 * @name: name of the variable to delete.
400 * @prn: pointer to gretl printer, or NULL.
401 *
402 * Deletes the specified user-variable.
403 *
404 * Returns: 0 on success, non-zero code on error.
405 */
406
user_var_delete_by_name(const char * name,PRN * prn)407 int user_var_delete_by_name (const char *name, PRN *prn)
408 {
409 GretlType type = 0;
410 int level = gretl_function_depth();
411 user_var *targ = NULL;
412 int i, j, k = 0;
413 int err = 0;
414
415 for (i=0; i<n_vars; i++) {
416 if (uvars[i]->level == level && !strcmp(uvars[i]->name, name)) {
417 targ = uvars[i];
418 k = i;
419 break;
420 }
421 }
422
423 if (targ == NULL) {
424 return E_UNKVAR;
425 }
426
427 if (level > 0 && (targ->flags & UV_MAIN)) {
428 gretl_errmsg_sprintf("%s: cannot be deleted here", targ->name);
429 return E_DATA;
430 }
431
432 if (user_var_callback != NULL && level == 0 &&
433 !var_is_private(targ) &&
434 (targ->type == GRETL_TYPE_MATRIX ||
435 targ->type == GRETL_TYPE_BUNDLE)) {
436 /* run this deletion through the GUI program to ensure
437 that things stay in sync
438 */
439 return (*user_var_callback)(name, targ->type,
440 UVAR_DELETE);
441 }
442
443 type = targ->type;
444 user_var_destroy(targ);
445 for (j=k; j<n_vars-1; j++) {
446 uvars[j] = uvars[j+1];
447 }
448 resize_uvar_stack(n_vars - 1);
449 set_nvars(n_vars - 1, "user_var_delete_by_name");
450
451 if (prn != NULL && gretl_messages_on()) {
452 pprintf(prn, _("Deleted %s"), name);
453 pputc(prn, '\n');
454 }
455 if (level == 0 && type == GRETL_TYPE_DOUBLE &&
456 scalar_edit_callback != NULL) {
457 scalar_edit_callback();
458 }
459
460 return err;
461 }
462
user_var_delete(user_var * uvar)463 int user_var_delete (user_var *uvar)
464 {
465 int i, j, err = E_UNKVAR;
466
467 for (i=0; i<n_vars; i++) {
468 if (uvar == uvars[i]) {
469 user_var_destroy(uvars[i]);
470 for (j=i; j<n_vars-1; j++) {
471 uvars[j] = uvars[j+1];
472 }
473 set_nvars(n_vars - 1, "user_var_delete");
474 err = 0;
475 break;
476 }
477 }
478
479 return err;
480 }
481
482 #if HDEBUG > 1
483
uvar_index(user_var * u)484 static int uvar_index (user_var *u)
485 {
486 int i;
487
488 for (i=0; i<n_vars; i++) {
489 if (u == uvars[i]) {
490 return i;
491 }
492 }
493
494 return -1;
495 }
496
497 #endif
498
499 /* Try to guess whether the currently-called function is big enough
500 (number of lines of code) to make it worthwhile to construct a hash
501 table for uservars at its level of execution, namely @uvh1, given
502 that we'll have to empty the table on exit from the function.
503
504 The number-of-lines threshold here is obviously kinda arbitrary;
505 some systematic experimentation might be useful.
506 */
507
use_uvh1(void)508 static inline int use_uvh1 (void)
509 {
510 return current_function_size() > 40;
511 }
512
get_user_var_of_type_by_name(const char * name,GretlType type)513 user_var *get_user_var_of_type_by_name (const char *name,
514 GretlType type)
515 {
516 int prev_d = get_previous_depth();
517 int d = gretl_function_depth();
518 int i, imin = 0;
519 user_var *u = NULL;
520
521 if (name == NULL || *name == '\0') {
522 return NULL;
523 }
524
525 if (type == GRETL_TYPE_DOUBLE) {
526 /* support "auxiliary scalars" mechanism */
527 imin = scalar_imin;
528 }
529
530 #if HDEBUG > 1
531 int hfound = 0;
532
533 fprintf(stderr, "get user var: '%s', %s (n_vars=%d, level=%d, "
534 "previous=%d, imin=%d)\n", name, gretl_type_get_name(type),
535 n_vars, d, prev_d, imin);
536 # if HDEBUG > 2
537 fputs("uvars list:\n", stderr);
538 for (i=0; i<n_vars; i++) {
539 fprintf(stderr, " %d: '%s', %s, level %d, ptr %p\n", i,
540 uvars[i]->name, gretl_type_get_name(uvars[i]->type),
541 uvars[i]->level, uvars[i]->ptr);
542 }
543 # endif
544 #endif
545
546 if (d != prev_d) {
547 if (d == 0) {
548 /* we're now at "main" level */
549 if (uvh0 == NULL) {
550 uvh0 = g_hash_table_new(g_str_hash, g_str_equal);
551 #if HDEBUG
552 fprintf(stderr, "uvh0: d=0, allocated at %p\n", uvh0);
553 #endif
554 }
555 if (uvh1 != NULL) {
556 #if HDEBUG
557 fprintf(stderr, "d=0, prev=%d: clear uvh1 at %p\n",
558 prev_d, uvh1);
559 #endif
560 g_hash_table_remove_all(uvh1);
561 }
562 uvars_hash = uvh0;
563 } else if (!use_uvh1()) {
564 /* exec'ing a function, hash table not wanted */
565 if (prev_d > 0 && uvh1 != NULL) {
566 g_hash_table_remove_all(uvh1);
567 }
568 uvars_hash = NULL;
569 } else {
570 /* exec'ing a function, hash table wanted */
571 if (uvh1 == NULL) {
572 uvh1 = g_hash_table_new(g_str_hash, g_str_equal);
573 #if HDEBUG
574 fprintf(stderr, "uvh1: d=%d, prev=%d, allocated at %p\n",
575 d, prev_d, uvh1);
576 #endif
577 } else if (prev_d > 0 && uvh1 != NULL) {
578 #if HDEBUG
579 fprintf(stderr, "d=%d, prev=%d: clear uvh1 at %p\n",
580 d, prev_d, uvh1);
581 #endif
582 g_hash_table_remove_all(uvh1);
583 }
584 uvars_hash = uvh1;
585 }
586 set_previous_depth(d);
587 }
588
589 if (uvars_hash != NULL) {
590 /* first resort: try a hash look-up */
591 u = g_hash_table_lookup(uvars_hash, name);
592 /* but verify type, if specified */
593 if (u != NULL && type != GRETL_TYPE_ANY && u->type != type) {
594 u = NULL;
595 }
596 #if HDEBUG > 1
597 if (u != NULL) hfound = 1;
598 #endif
599 }
600
601 if (u == NULL) {
602 /* "On demand" hashing: if we're successful in looking
603 up a variable in the traditional manner, then
604 insert it into the uservars hash table.
605 */
606 for (i=imin; i<n_vars; i++) {
607 if (uvars[i]->level == d &&
608 (type == GRETL_TYPE_ANY || uvars[i]->type == type) &&
609 !strcmp(uvars[i]->name, name)) {
610 u = uvars[i];
611 if (uvars_hash != NULL) {
612 g_hash_table_insert(uvars_hash, u->name, u);
613 }
614 break;
615 }
616 }
617 }
618
619 #if HDEBUG > 1
620 if (hfound)
621 fprintf(stderr, "found at pos %d via hash (%s)\n\n", uvar_index(u),
622 uvars_hash == uvh1 ? "uvh1" : "uvh0");
623 else if (u != NULL)
624 fprintf(stderr, "found at pos %d via regular search\n\n", uvar_index(u));
625 else
626 fprintf(stderr, "not found\n\n");
627 #endif
628
629 return u;
630 }
631
get_user_var_by_name(const char * name)632 user_var *get_user_var_by_name (const char *name)
633 {
634 return get_user_var_of_type_by_name(name, GRETL_TYPE_ANY);
635 }
636
user_var_get_type_by_name(const char * name)637 GretlType user_var_get_type_by_name (const char *name)
638 {
639 user_var *u;
640
641 u = get_user_var_of_type_by_name(name, GRETL_TYPE_ANY);
642
643 return u == NULL ? GRETL_TYPE_NONE : u->type;
644 }
645
user_var_get_value_and_type(const char * name,GretlType * type)646 void *user_var_get_value_and_type (const char *name,
647 GretlType *type)
648 {
649 void *ret = NULL;
650 user_var *u;
651
652 u = get_user_var_of_type_by_name(name, GRETL_TYPE_ANY);
653
654 if (u != NULL) {
655 ret = u->ptr;
656 *type = u->type;
657 } else {
658 *type = GRETL_TYPE_NONE;
659 }
660
661 return ret;
662 }
663
uservar_name_complete(const char * s)664 const char *uservar_name_complete (const char *s)
665 {
666 const char *ret = NULL;
667
668 if (uvars_hash != NULL) {
669 GList *hk = g_hash_table_get_keys(uvars_hash);
670 int n = strlen(s);
671
672 while (hk != NULL) {
673 if (!strncmp((const char *) hk->data, s, n)) {
674 ret = (const char *) hk->data;
675 break;
676 }
677 hk = hk->next;
678 }
679 g_list_free(hk);
680 }
681
682 return ret;
683 }
684
gretl_is_user_var(const char * name)685 int gretl_is_user_var (const char *name)
686 {
687 return get_user_var_by_name(name) != NULL;
688 }
689
get_user_var_by_data(const void * data)690 user_var *get_user_var_by_data (const void *data)
691 {
692 int i, d = gretl_function_depth();
693
694 if (data == NULL) {
695 return NULL;
696 }
697
698 for (i=0; i<n_vars; i++) {
699 if (uvars[i] != NULL && uvars[i]->level == d &&
700 uvars[i]->ptr == data) {
701 return uvars[i];
702 }
703 }
704
705 return NULL;
706 }
707
user_var_get_name(user_var * uvar)708 const char *user_var_get_name (user_var *uvar)
709 {
710 return uvar == NULL ? NULL : uvar->name;
711 }
712
user_var_get_name_by_data(const void * data)713 const char *user_var_get_name_by_data (const void *data)
714 {
715 user_var *u = get_user_var_by_data(data);
716
717 return u == NULL ? NULL : u->name;
718 }
719
user_var_get_level(user_var * uvar)720 int user_var_get_level (user_var *uvar)
721 {
722 return (uvar == NULL)? -1 : uvar->level;
723 }
724
user_var_get_flags(user_var * uvar)725 int user_var_get_flags (user_var *uvar)
726 {
727 return (uvar == NULL)? 0 : (int) uvar->flags;
728 }
729
user_var_set_flag(user_var * uvar,UVFlags flag)730 int user_var_set_flag (user_var *uvar, UVFlags flag)
731 {
732 if (uvar != NULL) {
733 uvar->flags |= flag;
734 return 0;
735 } else {
736 return E_INVARG;
737 }
738 }
739
user_var_unset_flag(user_var * uvar,UVFlags flag)740 int user_var_unset_flag (user_var *uvar, UVFlags flag)
741 {
742 if (uvar != NULL) {
743 uvar->flags &= ~flag;
744 return 0;
745 } else {
746 return E_INVARG;
747 }
748 }
749
user_var_privatize_by_name(const char * name)750 void user_var_privatize_by_name (const char *name)
751 {
752 user_var *u = get_user_var_by_name(name);
753
754 if (u != NULL) {
755 u->flags |= UV_PRIVATE;
756 }
757 }
758
user_var_get_value(user_var * uvar)759 void *user_var_get_value (user_var *uvar)
760 {
761 return (uvar == NULL)? NULL : uvar->ptr;
762 }
763
user_var_get_type(user_var * uvar)764 GretlType user_var_get_type (user_var *uvar)
765 {
766 return (uvar == NULL)? 0 : uvar->type;
767 }
768
user_var_get_value_by_name(const char * name)769 void *user_var_get_value_by_name (const char *name)
770 {
771 user_var *u = get_user_var_by_name(name);
772
773 return (u == NULL)? NULL : u->ptr;
774 }
775
776 /* special for scalars since user_var_get_value returns
777 a pointer */
778
user_var_get_scalar_value(user_var * uvar)779 double user_var_get_scalar_value (user_var *uvar)
780 {
781 if (uvar != NULL && uvar->type == GRETL_TYPE_DOUBLE) {
782 return *(double *) uvar->ptr;
783 } else {
784 return NADBL;
785 }
786 }
787
user_var_set_scalar_value(user_var * uvar,double x)788 int user_var_set_scalar_value (user_var *uvar, double x)
789 {
790 if (uvar != NULL && uvar->type == GRETL_TYPE_DOUBLE) {
791 *(double *) uvar->ptr = x;
792 return 0;
793 } else {
794 return E_DATA;
795 }
796 }
797
user_var_adjust_level(user_var * uvar,int adj)798 int user_var_adjust_level (user_var *uvar, int adj)
799 {
800 if (uvar == NULL) {
801 return E_UNKVAR;
802 } else {
803 uvar->level += adj;
804 return 0;
805 }
806 }
807
808 /* Note: the following should be called only from internal
809 contexts in which we know that the attempted renaming
810 is not broken (e.g. trying to assign to @uvar a name
811 that is already taken by some other object).
812 */
813
user_var_set_name(user_var * uvar,const char * name)814 int user_var_set_name (user_var *uvar, const char *name)
815 {
816 int err = 0;
817
818 if (uvar == NULL) {
819 err = E_DATA;
820 } else {
821 *uvar->name = '\0';
822 strncat(uvar->name, name, VNAMELEN - 1);
823 }
824
825 return err;
826 }
827
array_ref_type(GretlType type)828 static int array_ref_type (GretlType type)
829 {
830 return type == GRETL_TYPE_STRINGS_REF ||
831 type == GRETL_TYPE_MATRICES_REF ||
832 type == GRETL_TYPE_BUNDLES_REF ||
833 type == GRETL_TYPE_LISTS_REF;
834 }
835
836 /**
837 * user_var_localize:
838 * @origname: name of variable at caller level.
839 * @localname: name to be used within function.
840 *
841 * On entry to a function, renames the named variable (provided
842 * as an argument) and sets its level so that is is accessible
843 * within the function.
844 *
845 * Returns: 0 on success, non-zero on error.
846 */
847
user_var_localize(const char * origname,const char * localname,GretlType type)848 int user_var_localize (const char *origname,
849 const char *localname,
850 GretlType type)
851 {
852 user_var *u;
853 int err = 0;
854
855 if (array_ref_type(type)) {
856 type = GRETL_TYPE_ARRAY;
857 } else {
858 type = gretl_type_get_plain_type(type);
859 }
860
861 if (type == GRETL_TYPE_SCALAR_REF) {
862 type = GRETL_TYPE_DOUBLE;
863 } else if (type == GRETL_TYPE_MATRIX_REF) {
864 type = GRETL_TYPE_MATRIX;
865 } else if (type == GRETL_TYPE_BUNDLE_REF) {
866 type = GRETL_TYPE_BUNDLE;
867 } else if (array_ref_type(type)) {
868 type = GRETL_TYPE_ARRAY;
869 }
870
871 u = get_user_var_of_type_by_name(origname, type);
872
873 if (u == NULL) {
874 err = E_DATA;
875 } else {
876 user_var_set_name(u, localname);
877 u->level += 1;
878 }
879
880 return err;
881 }
882
user_var_count_for_type(GretlType type)883 static int user_var_count_for_type (GretlType type)
884 {
885 int i, n = 0;
886
887 for (i=0; i<n_vars; i++) {
888 if (uvars[i]->type == type) {
889 n++;
890 }
891 }
892
893 return n;
894 }
895
n_user_matrices(void)896 int n_user_matrices (void)
897 {
898 return user_var_count_for_type(GRETL_TYPE_MATRIX);
899 }
900
n_user_scalars(void)901 int n_user_scalars (void)
902 {
903 return user_var_count_for_type(GRETL_TYPE_DOUBLE);
904 }
905
n_user_lists(void)906 int n_user_lists (void)
907 {
908 return user_var_count_for_type(GRETL_TYPE_LIST);
909 }
910
n_user_bundles(void)911 int n_user_bundles (void)
912 {
913 return user_var_count_for_type(GRETL_TYPE_BUNDLE);
914 }
915
916 /**
917 * user_var_replace_value:
918 * @uvar: user variable.
919 * @value: the new value to place as the value or @uvar.
920 * @type: the type of the replacement value.
921 *
922 * Replaces the value of @uvar; the existing value is
923 * freed first.
924 *
925 * Returns: 0 on success, non-zero on error.
926 */
927
user_var_replace_value(user_var * uvar,void * value,GretlType type)928 int user_var_replace_value (user_var *uvar, void *value,
929 GretlType type)
930 {
931 int err = 0;
932
933 if (uvar == NULL) {
934 err = E_UNKVAR;
935 } else if (value != uvar->ptr && (uvar->flags & UV_NOREPL)) {
936 gretl_errmsg_sprintf("The variable %s is read-only", uvar->name);
937 err = E_DATA;
938 } else if (type != uvar->type) {
939 err = E_TYPES; /* assume the worst */
940 if (uvar->type == GRETL_TYPE_ARRAY && uvar->ptr != NULL) {
941 /* but we might be OK */
942 if (type == gretl_array_get_type(uvar->ptr)) {
943 err = 0;
944 }
945 }
946 if (err) {
947 fputs("*** user_var_replace_value: type mismatch ***\n", stderr);
948 fprintf(stderr, " (expected %s but got %s)\n",
949 gretl_type_get_name(uvar->type), gretl_type_get_name(type));
950 }
951 }
952
953 if (!err && value != uvar->ptr) {
954 if (uvar->ptr != NULL) {
955 uvar_free_value(uvar);
956 }
957 uvar->ptr = value;
958 }
959
960 return err;
961 }
962
user_string_resize(const char * name,size_t len,int * err)963 char *user_string_resize (const char *name, size_t len, int *err)
964 {
965 user_var *u;
966
967 u = get_user_var_of_type_by_name(name, GRETL_TYPE_STRING);
968
969 if (u == NULL) {
970 *err = E_INVARG;
971 return NULL;
972 } else {
973 char *orig = u->ptr;
974
975 if (orig == NULL || len > strlen(orig) + 1) {
976 char *tmp = realloc(u->ptr, len);
977
978 if (tmp == NULL) {
979 *err = E_ALLOC;
980 } else {
981 u->ptr = tmp;
982 }
983 }
984 }
985
986 return (char *) u->ptr;
987 }
988
user_string_reset(const char * name,const char * repl,int * err)989 char *user_string_reset (const char *name, const char *repl, int *err)
990 {
991 user_var *u;
992
993 u = get_user_var_of_type_by_name(name, GRETL_TYPE_STRING);
994
995 if (u == NULL) {
996 *err = E_INVARG;
997 return NULL;
998 } else {
999 free(u->ptr);
1000 if (repl == NULL) {
1001 u->ptr = gretl_strdup("");
1002 } else {
1003 u->ptr = gretl_strdup(repl);
1004 }
1005 return (char *) u->ptr;
1006 }
1007 }
1008
check_array_type_compat(GretlType type,user_var * u)1009 static int check_array_type_compat (GretlType type,
1010 user_var *u)
1011 {
1012 int err = 0;
1013
1014 if (u->type != GRETL_TYPE_ARRAY) {
1015 err = E_TYPES;
1016 } else {
1017 /* we also need a more specific check here */
1018 if (type != gretl_array_get_type(u->ptr)) {
1019 err = E_TYPES;
1020 }
1021 }
1022
1023 return err;
1024 }
1025
user_var_add_or_replace(const char * name,GretlType type,void * value)1026 int user_var_add_or_replace (const char *name,
1027 GretlType type,
1028 void *value)
1029 {
1030 user_var *u = get_user_var_by_name(name);
1031 int err = 0;
1032
1033 if (u != NULL) {
1034 if (gretl_array_type(type)) {
1035 err = check_array_type_compat(type, u);
1036 } else if (u->type != type) {
1037 err = E_TYPES;
1038 }
1039 if (!err) {
1040 err = user_var_replace_value(u, value, type);
1041 }
1042 } else {
1043 err = real_user_var_add(name, type, value, OPT_NONE);
1044 }
1045
1046 return err;
1047 }
1048
user_var_steal_value(user_var * uvar)1049 void *user_var_steal_value (user_var *uvar)
1050 {
1051 void *ret = NULL;
1052
1053 if (uvar != NULL) {
1054 ret = uvar->ptr;
1055 uvar->ptr = NULL;
1056 }
1057
1058 return ret;
1059 }
1060
1061 /* FIXME: are both the above and the below necessary? */
1062
user_var_unstack_value(user_var * uvar)1063 void *user_var_unstack_value (user_var *uvar)
1064 {
1065 void *ret = NULL;
1066 int i, j;
1067
1068 for (i=0; i<n_vars; i++) {
1069 if (uvar == uvars[i]) {
1070 ret = uvar->ptr;
1071 uvars[i]->ptr = NULL;
1072 user_var_destroy(uvars[i]);
1073 for (j=i; j<n_vars-1; j++) {
1074 uvars[j] = uvars[j+1];
1075 }
1076 set_nvars(n_vars - 1, "user_var_unstack_value");
1077 break;
1078 }
1079 }
1080
1081 return ret;
1082 }
1083
user_matrix_replace_matrix_by_name(const char * name,gretl_matrix * m)1084 int user_matrix_replace_matrix_by_name (const char *name,
1085 gretl_matrix *m)
1086 {
1087 user_var *u = get_user_var_by_name(name);
1088
1089 if (u != NULL) {
1090 return user_var_replace_value(u, m, GRETL_TYPE_MATRIX);
1091 } else {
1092 return E_DATA;
1093 }
1094 }
1095
user_var_names_for_type(GretlType type)1096 GList *user_var_names_for_type (GretlType type)
1097 {
1098 GList *list = NULL;
1099 int i;
1100
1101 for (i=0; i<n_vars; i++) {
1102 if (uvars[i]->type == type) {
1103 list = g_list_append(list, (gpointer) uvars[i]->name);
1104 }
1105 }
1106
1107 return list;
1108 }
1109
user_var_list_for_type(GretlType type)1110 GList *user_var_list_for_type (GretlType type)
1111 {
1112 GList *list = NULL;
1113 int i;
1114
1115 for (i=0; i<n_vars; i++) {
1116 if (uvars[i]->type == type) {
1117 list = g_list_append(list, (gpointer) uvars[i]);
1118 }
1119 }
1120
1121 return list;
1122 }
1123
1124 /**
1125 * set_user_var_callback:
1126 * @callback: function function to put in place.
1127 *
1128 * Sets the callback function to be invoked when a user-defined
1129 * matrix is added to or removed from the stack of saved objects.
1130 * Intended for synchronizing the GUI program with the saved object
1131 * state.
1132 */
1133
set_user_var_callback(USER_VAR_FUNC callback)1134 void set_user_var_callback (USER_VAR_FUNC callback)
1135 {
1136 user_var_callback = callback;
1137 }
1138
set_scalar_edit_callback(void (* callback))1139 void set_scalar_edit_callback (void (*callback))
1140 {
1141 scalar_edit_callback = callback;
1142 }
1143
1144 /* used in response to bare declaration of a user variable
1145 in geneval.c */
1146
create_user_var(const char * name,GretlType type)1147 int create_user_var (const char *name, GretlType type)
1148 {
1149 return real_user_var_add(name, type, NULL, OPT_NONE);
1150 }
1151
1152 /**
1153 * arg_add_as_shell:
1154 * @name: the name to be given to the "shell" variable.
1155 * @type: the type of the variable.
1156 * @value: the value pointer
1157 *
1158 * The value in question is added to the stack of named
1159 * variables under the name @name with the shell flag
1160 * set. This is used (a) when an anonymous matrix is given as
1161 * a %const argument to a user-defined function and (b) when
1162 * an anonymous bundle is given as the argument corresponding
1163 * to a bundle-pointer parameter. The @value becomes
1164 * accessible by @name within the function, but is protected
1165 * from destruction on exit from the function.
1166 *
1167 * Returns: 0 on success, non-zero on error.
1168 */
1169
arg_add_as_shell(const char * name,GretlType type,void * value)1170 int arg_add_as_shell (const char *name, GretlType type,
1171 void *value)
1172 {
1173 return real_user_var_add(name, type, value, OPT_S | OPT_A);
1174 }
1175
1176 /**
1177 * copy_matrix_as:
1178 * @m: the original matrix.
1179 * @newname: the name to be given to the copy.
1180 * @fnarg: 0 for regular use.
1181 *
1182 * A copy of matrix @m is added to the stack of saved matrices
1183 * under the name @newname.
1184 *
1185 * The @fnarg argument should be non-zero only if this function
1186 * is used to handle the case where a matrix is given as the argument
1187 * to a user-defined function.
1188 *
1189 * Returns: 0 on success, non-zero on error.
1190 */
1191
copy_matrix_as(const gretl_matrix * m,const char * newname,int fnarg)1192 int copy_matrix_as (const gretl_matrix *m, const char *newname,
1193 int fnarg)
1194 {
1195 gretl_matrix *m2 = gretl_matrix_copy(m);
1196 int err = 0;
1197
1198 if (m2 == NULL) {
1199 err = E_ALLOC;
1200 } else {
1201 gretlopt opt = fnarg ? OPT_A : OPT_NONE;
1202
1203 err = real_user_var_add(newname, GRETL_TYPE_MATRIX, m2, opt);
1204 }
1205
1206 return err;
1207 }
1208
copy_as_arg(const char * param_name,GretlType type,void * value)1209 int copy_as_arg (const char *param_name, GretlType type, void *value)
1210 {
1211 void *copyval = NULL;
1212 GretlType cpytype = type;
1213 int err = 0;
1214
1215 if (type == GRETL_TYPE_MATRIX) {
1216 gretl_matrix *mcpy = gretl_matrix_copy((gretl_matrix *) value);
1217
1218 if (mcpy == NULL) {
1219 err = E_ALLOC;
1220 } else {
1221 copyval = mcpy;
1222 }
1223 } else if (type == GRETL_TYPE_LIST) {
1224 int *lcpy = gretl_list_copy((int *) value);
1225
1226 if (lcpy == NULL) {
1227 err = E_ALLOC;
1228 } else {
1229 copyval = lcpy;
1230 }
1231 } else if (type == GRETL_TYPE_STRING) {
1232 char *scpy = gretl_strdup((char *) value);
1233
1234 if (scpy == NULL) {
1235 err = E_ALLOC;
1236 } else {
1237 copyval = scpy;
1238 }
1239 } else if (type == GRETL_TYPE_DOUBLE) {
1240 double *px = malloc(sizeof *px);
1241
1242 if (px == NULL) {
1243 err = E_ALLOC;
1244 } else {
1245 *px = *(double *) value;
1246 copyval = px;
1247 }
1248 } else if (type == GRETL_TYPE_BUNDLE) {
1249 gretl_bundle *bcpy = gretl_bundle_copy(value, &err);
1250
1251 if (!err) {
1252 copyval = bcpy;
1253 }
1254 } else if (gretl_array_type(type)) {
1255 gretl_array *acpy = gretl_array_copy(value, &err);
1256
1257 if (!err) {
1258 copyval = acpy;
1259 cpytype = gretl_array_get_type(acpy);
1260 }
1261 }
1262
1263 if (!err) {
1264 err = real_user_var_add(param_name, cpytype, copyval, OPT_A);
1265 }
1266
1267 return err;
1268 }
1269
copy_list_as_arg(const char * param_name,int * list,int * err)1270 int *copy_list_as_arg (const char *param_name, int *list,
1271 int *err)
1272 {
1273 int *ret = NULL;
1274
1275 *err = copy_as_arg(param_name, GRETL_TYPE_LIST, list);
1276 if (!*err) {
1277 ret = uvars[n_vars-1]->ptr;
1278 }
1279
1280 return ret;
1281 }
1282
destroy_user_vars(void)1283 void destroy_user_vars (void)
1284 {
1285 int i, j;
1286
1287 #if HDEBUG
1288 fprintf(stderr, "destroy_user_vars, uvars_hash = %p (uvh0 %p, uvh1 %p)\n",
1289 (void *) uvars_hash, (void *) uvh0, (void *) uvh1);
1290 #endif
1291
1292 for (i=0; i<n_vars; i++) {
1293 if (uvars[i] == NULL) {
1294 break;
1295 }
1296 user_var_destroy(uvars[i]);
1297 for (j=i; j<n_vars-1; j++) {
1298 uvars[j] = uvars[j+1];
1299 }
1300 uvars[n_vars-1] = NULL;
1301 i--;
1302 }
1303
1304 if (uvh0 != NULL || uvh1 != NULL) {
1305 uvar_hash_destroy();
1306 }
1307
1308 set_nvars(0, "destroy_user_vars");
1309
1310 free(uvars);
1311 uvars = NULL;
1312 n_alloc = 0;
1313 }
1314
uvar_levels_match(user_var * u,int level)1315 static int uvar_levels_match (user_var *u, int level)
1316 {
1317 int ret = 0;
1318
1319 if (u->level == level) {
1320 ret = 1;
1321 } else if (level == LEV_PRIVATE && var_is_private(u)) {
1322 ret = 1;
1323 }
1324
1325 return ret;
1326 }
1327
real_destroy_user_vars_at_level(int level,int type,int imin)1328 static int real_destroy_user_vars_at_level (int level, int type,
1329 int imin)
1330 {
1331 int i, j, nv = imin;
1332 int err = 0;
1333
1334 #if HDEBUG
1335 fprintf(stderr, "real_destroy_user_vars_at_level: level %d, "
1336 "type %d (%s), imin=%d\n", level, type,
1337 gretl_type_get_name(type), imin);
1338 #endif
1339
1340 for (i=imin; i<n_vars; i++) {
1341 if (uvars[i] == NULL) {
1342 break;
1343 }
1344 if (type > 0 && uvars[i]->type != type) {
1345 /* preserve this variable */
1346 nv++;
1347 continue;
1348 }
1349 if (uvar_levels_match(uvars[i], level)) {
1350 user_var_destroy(uvars[i]);
1351 /* shuffle the remainder down one place */
1352 for (j=i; j<n_vars-1; j++) {
1353 uvars[j] = uvars[j+1];
1354 }
1355 uvars[n_vars-1] = NULL;
1356 i--;
1357 } else {
1358 /* preserving */
1359 nv++;
1360 }
1361 }
1362
1363 set_nvars(nv, "real_destroy_user_vars_at_level");
1364
1365 return err;
1366 }
1367
destroy_user_vars_via_callback(int type)1368 static int destroy_user_vars_via_callback (int type)
1369 {
1370 user_var **delvars = NULL;
1371 int i, j, n = 0;
1372 int err = 0;
1373
1374 for (i=0; i<n_vars; i++) {
1375 if (uvars[i]->level == 0 && uvars[i]->type == type) {
1376 n++;
1377 }
1378 }
1379
1380 if (n == 0) {
1381 return 0;
1382 }
1383
1384 delvars = malloc(n * sizeof *delvars);
1385 if (delvars == NULL) {
1386 return E_ALLOC;
1387 }
1388
1389 j = 0;
1390 for (i=0; i<n_vars; i++) {
1391 if (uvars[i]->level == 0 && uvars[i]->type == type) {
1392 delvars[j++] = uvars[i];
1393 }
1394 }
1395
1396 for (j=0; j<n && !err; j++) {
1397 err = (*user_var_callback)(delvars[j]->name,
1398 delvars[j]->type,
1399 UVAR_DELETE);
1400 }
1401
1402 free(delvars);
1403
1404 return err;
1405 }
1406
1407 /**
1408 * destroy_user_vars_at_level:
1409 * @level: stack level of function execution.
1410 *
1411 * Destroys and removes from the stack of user matrices all
1412 * matrices that were created at the given @level. This is
1413 * part of the cleanup that is performed when a user-defined
1414 * function terminates.
1415 *
1416 * Returns: 0 on success, non-zero on error.
1417 */
1418
destroy_user_vars_at_level(int level)1419 int destroy_user_vars_at_level (int level)
1420 {
1421 return real_destroy_user_vars_at_level(level, 0, 0);
1422 }
1423
destroy_private_uvars(void)1424 int destroy_private_uvars (void)
1425 {
1426 return real_destroy_user_vars_at_level(LEV_PRIVATE, 0, 0);
1427 }
1428
destroy_private_matrices(void)1429 int destroy_private_matrices (void)
1430 {
1431 return real_destroy_user_vars_at_level(LEV_PRIVATE,
1432 GRETL_TYPE_MATRIX,
1433 0);
1434 }
1435
delete_user_vars_of_type(GretlType type,PRN * prn)1436 int delete_user_vars_of_type (GretlType type, PRN *prn)
1437 {
1438 int err = 0;
1439
1440 if (type == GRETL_TYPE_MATRIX ||
1441 type == GRETL_TYPE_BUNDLE ||
1442 type == GRETL_TYPE_ARRAY ||
1443 type == GRETL_TYPE_STRING ||
1444 type == GRETL_TYPE_DOUBLE ||
1445 type == GRETL_TYPE_LIST) {
1446 int level = gretl_function_depth();
1447
1448 if (level == 0 && user_var_callback != NULL &&
1449 (type == GRETL_TYPE_MATRIX || type == GRETL_TYPE_BUNDLE)) {
1450 err = destroy_user_vars_via_callback(type);
1451 } else {
1452 err = real_destroy_user_vars_at_level(level, type, 0);
1453 }
1454
1455 if (!err && gretl_messages_on()) {
1456 pprintf(prn, "Deleted all variables of type %s\n",
1457 gretl_type_get_name(type));
1458 }
1459 } else {
1460 err = E_TYPES;
1461 }
1462
1463 return err;
1464 }
1465
1466 /**
1467 * destroy_private_scalars:
1468 *
1469 * Gets rid of private or "internal" scalars whose
1470 * names begin with '$'.
1471 */
1472
destroy_private_scalars(void)1473 void destroy_private_scalars (void)
1474 {
1475 real_destroy_user_vars_at_level(LEV_PRIVATE,
1476 GRETL_TYPE_DOUBLE,
1477 0);
1478 }
1479
temp_name_for_bundle(void)1480 char *temp_name_for_bundle (void)
1481 {
1482 char tmpname[VNAMELEN];
1483 int i, nb = 0;
1484
1485 for (i=0; i<n_vars; i++) {
1486 if (uvars[i]->type == GRETL_TYPE_BUNDLE) {
1487 nb++;
1488 }
1489 }
1490
1491 sprintf(tmpname, "btmp___%d", nb);
1492 return gretl_strdup(tmpname);
1493 }
1494
xml_put_user_matrix(user_var * u,PRN * prn)1495 static void xml_put_user_matrix (user_var *u, PRN *prn)
1496 {
1497 if (u != NULL && u->ptr != NULL) {
1498 gretl_matrix_serialize(u->ptr, u->name, prn);
1499 }
1500 }
1501
write_scalar_value(double x,const char * fmt,PRN * prn)1502 static void write_scalar_value (double x, const char *fmt, PRN *prn)
1503 {
1504 if (na(x)) {
1505 #ifdef WIN32
1506 win32_pprint_nonfinite(prn, x, '\n');
1507 #else
1508 pprintf(prn, "%g\n", x);
1509 #endif
1510 } else {
1511 pprintf(prn, fmt, x);
1512 }
1513 }
1514
serialize_scalar_value(double x,PRN * prn)1515 static void serialize_scalar_value (double x, PRN *prn)
1516 {
1517 if (na(x)) {
1518 #ifdef WIN32
1519 win32_pprint_nonfinite(prn, x, 0);
1520 #else
1521 pprintf(prn, "%g", x);
1522 #endif
1523 } else {
1524 pprintf(prn, "%.16g", x);
1525 }
1526 }
1527
1528 /**
1529 * print_scalars:
1530 * @prn: pointer to gretl printing struct.
1531 *
1532 * Prints names and values of any saved scalars.
1533 */
1534
print_scalars(PRN * prn)1535 void print_scalars (PRN *prn)
1536 {
1537 double x;
1538 int level = gretl_function_depth();
1539 int len, ns = 0, maxlen = 0;
1540 int i;
1541
1542 for (i=0; i<n_vars; i++) {
1543 if (uvars[i]->type == GRETL_TYPE_DOUBLE &&
1544 uvars[i]->level == level) {
1545 len = strlen(uvars[i]->name);
1546 if (len > maxlen) {
1547 maxlen = len;
1548 }
1549 ns++;
1550 }
1551 }
1552
1553 if (ns == 0) {
1554 pprintf(prn, "%s\n", _("none"));
1555 return;
1556 }
1557
1558 pputc(prn, '\n');
1559
1560 for (i=0; i<n_vars; i++) {
1561 if (uvars[i]->type == GRETL_TYPE_DOUBLE &&
1562 uvars[i]->level == level) {
1563 x = *(double *) uvars[i]->ptr;
1564 pprintf(prn, " %*s = ", maxlen, uvars[i]->name);
1565 write_scalar_value(x, "%.16g\n", prn);
1566 }
1567 }
1568
1569 pputc(prn, '\n');
1570 }
1571
print_scalar_by_name(const char * name,PRN * prn)1572 void print_scalar_by_name (const char *name, PRN *prn)
1573 {
1574 user_var *u;
1575
1576 u = get_user_var_of_type_by_name(name, GRETL_TYPE_DOUBLE);
1577
1578 if (u != NULL) {
1579 double x = *(double *) u->ptr;
1580
1581 pprintf(prn, "\n%15s = ", u->name);
1582 write_scalar_value(x, "% #.8g\n", prn);
1583 }
1584 }
1585
1586 /* "auxiliary scalars": this apparatus is used when we want to do
1587 "private" NLS estimation (e.g. in ARMA initialization). It ensures
1588 that the scalar NLS parameters don't collide with the public scalar
1589 namespace. FIXME.
1590 */
1591
set_auxiliary_scalars(void)1592 void set_auxiliary_scalars (void)
1593 {
1594 scalar_imin = n_vars;
1595 }
1596
unset_auxiliary_scalars(void)1597 void unset_auxiliary_scalars (void)
1598 {
1599 real_destroy_user_vars_at_level(0, GRETL_TYPE_DOUBLE, scalar_imin);
1600 scalar_imin = 0;
1601 }
1602
real_scalar_add(const char * name,double val,gretlopt opt)1603 static int real_scalar_add (const char *name, double val,
1604 gretlopt opt)
1605 {
1606 user_var *u = get_user_var_by_name(name);
1607 int level = gretl_function_depth();
1608 int err = 0;
1609
1610 if (u != NULL) {
1611 if (u->type == GRETL_TYPE_DOUBLE) {
1612 *(double *) u->ptr = val;
1613 } else {
1614 err = E_TYPES;
1615 }
1616 return err;
1617 } else {
1618 double *px = malloc(sizeof *px);
1619
1620 if (px == NULL) {
1621 err = E_ALLOC;
1622 } else {
1623 *px = val;
1624 err = real_user_var_add(name, GRETL_TYPE_DOUBLE,
1625 px, opt);
1626 }
1627
1628 if (!err && level == 0 && scalar_edit_callback != NULL) {
1629 scalar_edit_callback();
1630 }
1631 }
1632
1633 return err;
1634 }
1635
gretl_scalar_add(const char * name,double val)1636 int gretl_scalar_add (const char *name, double val)
1637 {
1638 return real_scalar_add(name, val, OPT_NONE);
1639 }
1640
gretl_scalar_add_mutable(const char * name,double val)1641 int gretl_scalar_add_mutable (const char *name, double val)
1642 {
1643 return real_scalar_add(name, val, OPT_C);
1644 }
1645
gretl_scalar_convert_to_matrix(user_var * u)1646 int gretl_scalar_convert_to_matrix (user_var *u)
1647 {
1648 gretl_matrix *m = NULL;
1649
1650 if (u == NULL) {
1651 return E_UNKVAR;
1652 } else if (u->type != GRETL_TYPE_DOUBLE) {
1653 return E_TYPES;
1654 }
1655
1656 m = gretl_matrix_alloc(1, 1);
1657 if (m == NULL) {
1658 return E_ALLOC;
1659 }
1660
1661 m->val[0] = *(double *) u->ptr;
1662 free(u->ptr);
1663 u->ptr = m;
1664 u->type = GRETL_TYPE_MATRIX;
1665
1666 if (gretl_function_depth() == 0) {
1667 if (scalar_edit_callback != NULL) {
1668 (*scalar_edit_callback)();
1669 }
1670 if (user_var_callback != NULL) {
1671 (*user_var_callback)(u->name, GRETL_TYPE_MATRIX, UVAR_ADD);
1672 }
1673 }
1674
1675 return 0;
1676 }
1677
add_auxiliary_scalar(const char * name,double val)1678 int add_auxiliary_scalar (const char *name, double val)
1679 {
1680 double *px = malloc(sizeof *px);
1681 int err;
1682
1683 /* Note that unlike gretl_scalar_add() above, this function
1684 adds a new scalar variable unconditionally; it never
1685 modifies the value of an existing scalar of the same
1686 name.
1687 */
1688
1689 if (px == NULL) {
1690 err = E_ALLOC;
1691 } else {
1692 *px = val;
1693 err = real_user_var_add(name, GRETL_TYPE_DOUBLE,
1694 px, OPT_NONE);
1695 }
1696
1697 return err;
1698 }
1699
gretl_scalar_set_value(const char * name,double val)1700 int gretl_scalar_set_value (const char *name, double val)
1701 {
1702 user_var *u;
1703 int err = 0;
1704
1705 u = get_user_var_of_type_by_name(name, GRETL_TYPE_DOUBLE);
1706
1707 if (u == NULL) {
1708 gretl_errmsg_sprintf("%s: no such scalar", name);
1709 err = E_DATA;
1710 } else if (scalar_is_read_only_index(name)) {
1711 err = E_DATA;
1712 gretl_errmsg_sprintf(_("The variable %s is currently read-only"), name);
1713 } else {
1714 *(double *) u->ptr = val;
1715
1716 if (scalar_edit_callback != NULL) {
1717 scalar_edit_callback();
1718 }
1719 }
1720
1721 return err;
1722 }
1723
1724 /* get the value from a user variable of scalar type */
1725
gretl_scalar_get_value(const char * name,int * err)1726 double gretl_scalar_get_value (const char *name, int *err)
1727 {
1728 user_var *u;
1729 double ret = NADBL;
1730
1731 u = get_user_var_of_type_by_name(name, GRETL_TYPE_DOUBLE);
1732
1733 if (u != NULL) {
1734 ret = *(double *) u->ptr;
1735 } else {
1736 ret = get_const_by_name(name, err);
1737 }
1738
1739 return ret;
1740 }
1741
maybe_get_bundled_scalar(const char * name,int * err)1742 static double maybe_get_bundled_scalar (const char *name, int *err)
1743 {
1744 const char *p = strchr(name, '.');
1745 gretl_bundle *b = NULL;
1746 char bname[VNAMELEN];
1747 char key[VNAMELEN];
1748 double x = NADBL;
1749
1750 *bname = '\0';
1751 strncat(bname, name, p - name);
1752 b = get_bundle_by_name(bname);
1753
1754 if (b == NULL) {
1755 *err = E_INVARG;
1756 } else {
1757 *key = '\0';
1758 strncat(key, p + 1, VNAMELEN - 1);
1759 x = gretl_bundle_get_scalar(b, key, err);
1760 }
1761
1762 return x;
1763 }
1764
1765 /* more "permissive" than gretl_scalar_get_value(): allows
1766 for @name being the identifier for a 1 x 1 matrix, or
1767 bundle.member
1768 */
1769
get_scalar_value_by_name(const char * name,int * err)1770 double get_scalar_value_by_name (const char *name, int *err)
1771 {
1772 double ret = NADBL;
1773 user_var *u;
1774
1775 if (strchr(name, '.')) {
1776 ret = maybe_get_bundled_scalar(name, err);
1777 goto bailout;
1778 }
1779
1780 u = get_user_var_by_name(name);
1781
1782 if (u != NULL) {
1783 if (u->type == GRETL_TYPE_DOUBLE) {
1784 ret = *(double *) u->ptr;
1785 } else if (u->type == GRETL_TYPE_MATRIX) {
1786 gretl_matrix *m = u->ptr;
1787
1788 if (gretl_matrix_is_scalar(m)) {
1789 ret = m->val[0];
1790 } else {
1791 *err = E_TYPES;
1792 }
1793 } else {
1794 *err = E_TYPES;
1795 }
1796 } else {
1797 ret = get_const_by_name(name, err);
1798 }
1799
1800 bailout:
1801
1802 if (*err) {
1803 gretl_errmsg_sprintf(_("'%s': not a scalar"), name);
1804 }
1805
1806 return ret;
1807 }
1808
gretl_is_scalar(const char * name)1809 int gretl_is_scalar (const char *name)
1810 {
1811 int ret = 0;
1812
1813 if (get_user_var_of_type_by_name(name, GRETL_TYPE_DOUBLE) != NULL) {
1814 ret = 1;
1815 }
1816
1817 if (!ret) {
1818 ret = const_lookup(name);
1819 }
1820
1821 return ret;
1822 }
1823
1824 /**
1825 * get_string_by_name:
1826 * @name: the name of the string variable to access.
1827 *
1828 * Returns: the value of string variable @name, or %NULL
1829 * if there is no such variable. Note that this is the
1830 * actual string value, not a copy thereof, compare
1831 * copy_string_by_name().
1832 */
1833
get_string_by_name(const char * name)1834 char *get_string_by_name (const char *name)
1835 {
1836 user_var *u;
1837
1838 u = get_user_var_of_type_by_name(name, GRETL_TYPE_STRING);
1839
1840 if (u != NULL) {
1841 return (char *) u->ptr;
1842 } else {
1843 return get_built_in_string_by_name(name);
1844 }
1845 }
1846
1847 /**
1848 * copy_string_by_name:
1849 * @name: the name of the string variable to access.
1850 * @err: location to receive error code.
1851 *
1852 * Returns: a copy of the value of string variable @name,
1853 * or %NULL on failure.
1854 */
1855
copy_string_by_name(const char * name,int * err)1856 char *copy_string_by_name (const char *name, int *err)
1857 {
1858 user_var *u;
1859 const char *s;
1860 char *ret = NULL;
1861
1862 u = get_user_var_of_type_by_name(name, GRETL_TYPE_STRING);
1863
1864 if (u != NULL) {
1865 s = u->ptr;
1866 } else {
1867 s = get_built_in_string_by_name(name);
1868 }
1869
1870 if (s == NULL) {
1871 *err = E_DATA;
1872 } else {
1873 ret = gretl_strdup(s);
1874 if (ret == NULL) {
1875 *err = E_ALLOC;
1876 }
1877 }
1878
1879 return ret;
1880 }
1881
1882 /**
1883 * gretl_is_string:
1884 * @name: name to test.
1885 *
1886 * Returns: 1 if @name is the name of a currently defined
1887 * string variable, otherwise 0.
1888 */
1889
gretl_is_string(const char * name)1890 int gretl_is_string (const char *name)
1891 {
1892 if (*name == '@' && *(name + 1) != '@') {
1893 name++;
1894 }
1895
1896 if (get_user_var_of_type_by_name(name, GRETL_TYPE_STRING) != NULL) {
1897 return 1;
1898 } else if (get_built_in_string_by_name(name) != NULL) {
1899 return 1;
1900 } else {
1901 return 0;
1902 }
1903 }
1904
is_user_string(const char * name)1905 int is_user_string (const char *name)
1906 {
1907 if (*name == '@' && *(name + 1) != '@') {
1908 name++;
1909 }
1910
1911 if (get_user_var_of_type_by_name(name, GRETL_TYPE_STRING) != NULL) {
1912 return 1;
1913 } else {
1914 return 0;
1915 }
1916 }
1917
max_varno_in_saved_lists(void)1918 int max_varno_in_saved_lists (void)
1919 {
1920 int *list;
1921 int i, j, vmax = 0;
1922
1923 for (i=0; i<n_vars; i++) {
1924 if (uvars[i]->type == GRETL_TYPE_LIST) {
1925 list = uvars[i]->ptr;
1926 if (list != NULL) {
1927 for (j=1; j<=list[0]; j++) {
1928 if (list[j] > vmax) {
1929 vmax = list[j];
1930 }
1931 }
1932 }
1933 }
1934 }
1935
1936 return vmax;
1937 }
1938
var_is_deleted(const int * dlist,int dmin,int i)1939 static int var_is_deleted (const int *dlist, int dmin, int i)
1940 {
1941 int v = dmin + i - 1;
1942
1943 if (dlist != NULL) {
1944 return in_gretl_list(dlist, v);
1945 } else {
1946 return (v >= dmin);
1947 }
1948 }
1949
1950 /**
1951 * gretl_lists_revise:
1952 * @dlist: list of variables to be deleted (or NULL).
1953 * @dmin: lowest ID number of deleted var (referenced only
1954 * if @dlist is NULL).
1955 *
1956 * Goes through any saved lists, adjusting the ID numbers
1957 * they contain to reflect the deletion from the dataset of
1958 * certain variables: those referenced in @dlist, if given,
1959 * or if @dlist is NULL, those variables with IDs greater
1960 * than or equal to @dmin.
1961 *
1962 * Returns: 0 on success, non-zero code on failure.
1963 */
1964
gretl_lists_revise(const int * dlist,int dmin)1965 int gretl_lists_revise (const int *dlist, int dmin)
1966 {
1967 int *list, *maplist;
1968 int lmax = 0;
1969 int i, j, k;
1970
1971 if (dlist != NULL) {
1972 /* determine lowest deleted ID */
1973 dmin = dlist[1];
1974 for (i=2; i<=dlist[0]; i++) {
1975 if (dlist[i] > 0 && dlist[i] < dmin) {
1976 dmin = dlist[i];
1977 }
1978 }
1979 }
1980
1981 /* find highest ID ref'd in any saved list */
1982 for (j=0; j<n_vars; j++) {
1983 if (uvars[j]->type == GRETL_TYPE_LIST) {
1984 list = uvars[j]->ptr;
1985 if (list != NULL) {
1986 for (i=1; i<=list[0]; i++) {
1987 if (list[i] > lmax) {
1988 lmax = list[i];
1989 }
1990 }
1991 }
1992 }
1993 }
1994
1995 if (lmax < dmin) {
1996 /* nothing to be done */
1997 return 0;
1998 }
1999
2000 /* make mapping from old to new IDs */
2001
2002 maplist = gretl_list_new(lmax - dmin + 1);
2003 if (maplist == NULL) {
2004 return E_ALLOC;
2005 }
2006
2007 j = dmin;
2008
2009 for (i=1; i<=maplist[0]; i++) {
2010 if (var_is_deleted(dlist, dmin, i)) {
2011 maplist[i] = -1;
2012 } else {
2013 maplist[i] = j++;
2014 }
2015 }
2016
2017 /* use mapping to revise saved lists */
2018 for (j=0; j<n_vars; j++) {
2019 if (uvars[j]->type == GRETL_TYPE_LIST) {
2020 list = uvars[j]->ptr;
2021 if (list != NULL) {
2022 for (i=list[0]; i>0; i--) {
2023 k = list[i] - dmin + 1;
2024 if (k >= 1) {
2025 if (maplist[k] == -1) {
2026 gretl_list_delete_at_pos(list, i);
2027 } else {
2028 list[i] = maplist[k];
2029 }
2030 }
2031 }
2032 }
2033 }
2034 }
2035
2036 free(maplist);
2037
2038 return 0;
2039 }
2040
2041 /**
2042 * gretl_lists_cleanup:
2043 *
2044 * Frees all resources associated with the internal
2045 * apparatus for saving and retrieving named lists.
2046 */
2047
gretl_lists_cleanup(void)2048 void gretl_lists_cleanup (void)
2049 {
2050 real_destroy_user_vars_at_level(0,
2051 GRETL_TYPE_LIST,
2052 0);
2053 }
2054
2055 /* below: serialization of user vars to XML, plus de-serialization
2056 from XML -- for use in GUI session mechanism
2057 */
2058
write_user_scalars(PRN * prn)2059 static void write_user_scalars (PRN *prn)
2060 {
2061 double x;
2062 int i;
2063
2064 for (i=0; i<n_vars; i++) {
2065 if (uvars[i]->type == GRETL_TYPE_DOUBLE) {
2066 x = *(double *) uvars[i]->ptr;
2067 pprintf(prn, " <gretl-scalar name=\"%s\" value=\"", uvars[i]->name);
2068 serialize_scalar_value(x, prn);
2069 pputs(prn, "\"/>\n");
2070 }
2071 }
2072 }
2073
write_user_matrices(PRN * prn)2074 static void write_user_matrices (PRN *prn)
2075 {
2076 int i;
2077
2078 for (i=0; i<n_vars; i++) {
2079 if (uvars[i]->type == GRETL_TYPE_MATRIX) {
2080 xml_put_user_matrix(uvars[i], prn);
2081 }
2082 }
2083 }
2084
write_user_lists(PRN * prn)2085 static void write_user_lists (PRN *prn)
2086 {
2087 int i;
2088
2089 for (i=0; i<n_vars; i++) {
2090 if (uvars[i]->type == GRETL_TYPE_LIST) {
2091 gretl_list_serialize(uvars[i]->ptr,
2092 uvars[i]->name,
2093 prn);
2094 }
2095 }
2096 }
2097
write_user_bundles(PRN * prn)2098 static void write_user_bundles (PRN *prn)
2099 {
2100 int i;
2101
2102 for (i=0; i<n_vars; i++) {
2103 if (uvars[i]->type == GRETL_TYPE_BUNDLE) {
2104 gretl_bundle_serialize(uvars[i]->ptr,
2105 uvars[i]->name,
2106 prn);
2107 }
2108 }
2109 }
2110
read_user_scalars(xmlDocPtr doc,xmlNodePtr cur)2111 static int read_user_scalars (xmlDocPtr doc, xmlNodePtr cur)
2112 {
2113 char *name, *val;
2114 double x;
2115 int n, err = 0;
2116
2117 cur = cur->xmlChildrenNode;
2118
2119 gretl_push_c_numeric_locale();
2120
2121 while (cur != NULL && !err) {
2122 if (!xmlStrcmp(cur->name, (XUC) "gretl-scalar")) {
2123 name = (char *) xmlGetProp(cur, (XUC) "name");
2124 val = (char *) xmlGetProp(cur, (XUC) "value");
2125 if (name == NULL || val == NULL) {
2126 err = 1;
2127 } else {
2128 n = sscanf(val, "%lf", &x);
2129 if (n < 1) {
2130 #ifdef WIN32
2131 x = win32_sscan_nonfinite(val, &err);
2132 #else
2133 x = NADBL;
2134 #endif
2135 }
2136 err = gretl_scalar_add(name, x);
2137 }
2138 free(name);
2139 free(val);
2140 }
2141 cur = cur->next;
2142 }
2143
2144 gretl_pop_c_numeric_locale();
2145
2146 return err;
2147 }
2148
read_user_matrices(xmlDocPtr doc,xmlNodePtr cur)2149 static int read_user_matrices (xmlDocPtr doc, xmlNodePtr cur)
2150 {
2151 gretl_matrix *m;
2152 char *name;
2153 int err = 0;
2154
2155 cur = cur->xmlChildrenNode;
2156
2157 while (cur != NULL && !err) {
2158 if (!xmlStrcmp(cur->name, (XUC) "gretl-matrix")) {
2159 name = (char *) xmlGetProp(cur, (XUC) "name");
2160 if (name == NULL) {
2161 err = 1;
2162 } else {
2163 m = gretl_xml_get_matrix(cur, doc, &err);
2164 if (m != NULL) {
2165 err = user_var_add(name, GRETL_TYPE_MATRIX, m);
2166 }
2167 free(name);
2168 }
2169 }
2170 cur = cur->next;
2171 }
2172
2173 return err;
2174 }
2175
read_user_lists(xmlDocPtr doc,xmlNodePtr cur)2176 static int read_user_lists (xmlDocPtr doc, xmlNodePtr cur)
2177 {
2178 int *list;
2179 char *name;
2180 int err = 0;
2181
2182 cur = cur->xmlChildrenNode;
2183
2184 while (cur != NULL && !err) {
2185 if (!xmlStrcmp(cur->name, (XUC) "list")) {
2186 if (!gretl_xml_get_prop_as_string(cur, "name", &name)) {
2187 err = E_DATA;
2188 } else {
2189 list = gretl_xml_get_list(cur, doc, &err);
2190 if (!err) {
2191 err = user_var_add(name, GRETL_TYPE_LIST, list);
2192 }
2193 free(name);
2194 }
2195 }
2196 cur = cur->next;
2197 }
2198
2199 return err;
2200 }
2201
read_user_bundles(xmlDocPtr doc,xmlNodePtr cur)2202 static int read_user_bundles (xmlDocPtr doc, xmlNodePtr cur)
2203 {
2204 int err = 0;
2205
2206 gretl_push_c_numeric_locale();
2207
2208 cur = cur->xmlChildrenNode;
2209
2210 while (cur != NULL && !err) {
2211 if (!xmlStrcmp(cur->name, (XUC) "gretl-bundle")) {
2212 char *name = (char *) xmlGetProp(cur, (XUC) "name");
2213
2214 if (name == NULL) {
2215 err = 1;
2216 } else {
2217 char *creator = NULL;
2218 gretl_bundle *b;
2219
2220 b = gretl_bundle_deserialize(cur, doc, &err);
2221 if (!err) {
2222 creator = (char *) xmlGetProp(cur, (XUC) "creator");
2223 gretl_bundle_set_creator(b, creator);
2224 err = user_var_add(name, GRETL_TYPE_BUNDLE, b);
2225 }
2226 free(name);
2227 free(creator);
2228 }
2229 }
2230 cur = cur->next;
2231 }
2232
2233 gretl_pop_c_numeric_locale();
2234
2235 return err;
2236 }
2237
2238 typedef void (*xml_write_func) (PRN *);
2239 typedef int (*xml_read_func) (xmlDocPtr, xmlNodePtr);
2240
2241 struct uvar_file_ {
2242 GretlType type;
2243 const char *typestr;
2244 xml_write_func write_func;
2245 xml_read_func read_func;
2246 };
2247
2248 typedef struct uvar_file_ uvar_file;
2249
2250 static uvar_file uvar_files[] = {
2251 { GRETL_TYPE_DOUBLE, "scalars", write_user_scalars, read_user_scalars },
2252 { GRETL_TYPE_MATRIX, "matrices", write_user_matrices, read_user_matrices },
2253 { GRETL_TYPE_LIST, "lists", write_user_lists, read_user_lists },
2254 { GRETL_TYPE_BUNDLE, "bundles", write_user_bundles, read_user_bundles }
2255 };
2256
serialize_user_vars(const char * dirname)2257 int serialize_user_vars (const char *dirname)
2258 {
2259 GretlType type;
2260 const char *typestr;
2261 void (*write_func)();
2262 char path[MAXLEN];
2263 PRN *prn;
2264 int i, n, ni;
2265 int err = 0;
2266
2267 n = sizeof uvar_files / sizeof uvar_files[0];
2268
2269 gretl_push_c_numeric_locale();
2270
2271 for (i=0; i<n; i++) {
2272 type = uvar_files[i].type;
2273 ni = user_var_count_for_type(type);
2274 if (ni > 0) {
2275 int errp = 0;
2276
2277 typestr = uvar_files[i].typestr;
2278 sprintf(path, "%s%c%s.xml", dirname, SLASH, typestr);
2279 write_func = uvar_files[i].write_func;
2280 prn = gretl_print_new_with_filename(path, &errp);
2281 if (prn == NULL) {
2282 err++;
2283 continue;
2284 }
2285 gretl_xml_header(prn);
2286 pprintf(prn, "<gretl-%s count=\"%d\">\n", typestr, ni);
2287 (*write_func)(prn);
2288 pprintf(prn, "</gretl-%s>\n", typestr);
2289 gretl_print_destroy(prn);
2290 }
2291 }
2292
2293 gretl_pop_c_numeric_locale();
2294
2295 if (err > 0) {
2296 fprintf(stderr, "Failed writing %d user_var files\n", err);
2297 err = E_FOPEN;
2298 }
2299
2300 return err;
2301 }
2302
2303 #define UDEBUG 0
2304
deserialize_user_vars(const char * dirname)2305 int deserialize_user_vars (const char *dirname)
2306 {
2307 xmlDocPtr doc = NULL;
2308 xmlNodePtr cur = NULL;
2309 const char *typestr;
2310 int (*read_func)();
2311 char root_name[16];
2312 char path[MAXLEN];
2313 FILE *fp;
2314 int i, n;
2315 int n_failed = 0;
2316 int err = 0;
2317
2318 n = sizeof uvar_files / sizeof uvar_files[0];
2319
2320 #if UDEBUG
2321 fprintf(stderr, "deserialize_user_vars:\n");
2322 #endif
2323
2324 for (i=0; i<n; i++) {
2325 int err_i = 0;
2326
2327 typestr = uvar_files[i].typestr;
2328 sprintf(path, "%s%c%s.xml", dirname, SLASH, typestr);
2329
2330 #if UDEBUG
2331 fprintf(stderr, " checking for '%s.xml'\n", typestr);
2332 #endif
2333 fp = gretl_fopen(path, "r");
2334 if (fp == NULL) {
2335 /* OK, no user-vars of this type */
2336 #if UDEBUG
2337 fprintf(stderr, " not found\n");
2338 #endif
2339 continue;
2340 }
2341 fclose(fp);
2342 sprintf(root_name, "gretl-%s", typestr);
2343 err_i = gretl_xml_open_doc_root(path, root_name, &doc, &cur);
2344 if (!err_i) {
2345 read_func = uvar_files[i].read_func;
2346 #if UDEBUG
2347 fprintf(stderr, " found, reading...\n");
2348 #endif
2349 err_i = read_func(doc, cur);
2350 #if UDEBUG
2351 fprintf(stderr, " done.\n");
2352 #endif
2353 }
2354 if (doc != NULL) {
2355 xmlFreeDoc(doc);
2356 doc = NULL;
2357 }
2358 if (err_i) {
2359 n_failed++;
2360 if (!err) {
2361 err = err_i;
2362 }
2363 }
2364 }
2365
2366 if (n_failed > 0) {
2367 fprintf(stderr, "Failed reading %d user_var files\n", n_failed);
2368 }
2369
2370 return err;
2371 }
2372
print_user_var_by_name(const char * name,const DATASET * dset,gretlopt opt,PRN * prn)2373 int print_user_var_by_name (const char *name,
2374 const DATASET *dset,
2375 gretlopt opt,
2376 PRN *prn)
2377 {
2378 user_var *u = get_user_var_by_name(name);
2379 int err = 0;
2380
2381 if (u == NULL || u->ptr == NULL) {
2382 return E_DATA;
2383 }
2384
2385 if (u->type == GRETL_TYPE_DOUBLE) {
2386 print_scalar_by_name(name, prn);
2387 } else if (u->type == GRETL_TYPE_MATRIX) {
2388 gretl_matrix *tmp = u->ptr;
2389 if (tmp->is_complex || opt & OPT_C) {
2390 err = gretl_cmatrix_print(u->ptr, name, prn);
2391 } else {
2392 gretl_matrix_print_to_prn(u->ptr, name, prn);
2393 }
2394 } else if (u->type == GRETL_TYPE_BUNDLE) {
2395 if (opt & OPT_T) {
2396 gretl_bundle_print_tree(u->ptr, prn);
2397 } else {
2398 gretl_bundle_print(u->ptr, prn);
2399 }
2400 } else if (u->type == GRETL_TYPE_ARRAY) {
2401 gretl_array_print(u->ptr, prn);
2402 } else if (u->type == GRETL_TYPE_LIST) {
2403 gretl_list_print(u->ptr, dset, prn);
2404 } else if (u->type == GRETL_TYPE_STRING) {
2405 pputs(prn, (char *) u->ptr);
2406 pputc(prn, '\n');
2407 }
2408
2409 return err;
2410 }
2411
uvar_type_match(user_var * u,GretlType t)2412 static int uvar_type_match (user_var *u, GretlType t)
2413 {
2414 if (u->type == t) {
2415 return 1;
2416 } else if (u->type == GRETL_TYPE_ARRAY &&
2417 gretl_array_type(t)) {
2418 return t == gretl_array_get_type(u->ptr);
2419 } else {
2420 return 0;
2421 }
2422 }
2423
list_user_vars_of_type(const DATASET * dset,PRN * prn)2424 int list_user_vars_of_type (const DATASET *dset,
2425 PRN *prn)
2426 {
2427 const char *typename;
2428 GretlType t;
2429
2430 typename = get_optval_string(VARLIST, OPT_T);
2431 if (typename == NULL) {
2432 return E_INVARG;
2433 }
2434
2435 if (!strcmp(typename, "accessor")) {
2436 list_ok_dollar_vars((DATASET *) dset, prn);
2437 return 0;
2438 }
2439
2440 t = gretl_type_from_string(typename);
2441 if (t == GRETL_TYPE_NONE) {
2442 return E_INVARG;
2443 }
2444
2445 if (t == GRETL_TYPE_SERIES) {
2446 list_series(dset, OPT_NONE, prn);
2447 } else if (t == GRETL_TYPE_DOUBLE) {
2448 print_scalars(prn);
2449 } else if (t == GRETL_TYPE_LIST ||
2450 t == GRETL_TYPE_MATRIX ||
2451 t == GRETL_TYPE_BUNDLE ||
2452 t == GRETL_TYPE_ARRAY ||
2453 t == GRETL_TYPE_STRING ||
2454 gretl_array_type(t)) {
2455 int i, n = 0;
2456
2457 pprintf(prn, _("variables of type %s:"), typename);
2458 for (i=0; i<n_vars; i++) {
2459 if (uvar_type_match(uvars[i], t)) {
2460 if (n == 0) {
2461 pputc(prn, '\n');
2462 }
2463 if (uvars[i]->name[0] == '\0') {
2464 pputs(prn, _(" (unnamed)\n"));
2465 } else if (t == GRETL_TYPE_ARRAY) {
2466 GretlType at = gretl_array_get_type(uvars[i]->ptr);
2467
2468 pprintf(prn, " %s (%s)\n", uvars[i]->name,
2469 gretl_type_get_name(at));
2470 } else {
2471 pprintf(prn, " %s\n", uvars[i]->name);
2472 }
2473 n++;
2474 }
2475 }
2476 if (n == 0) {
2477 pprintf(prn, " %s\n", _("none"));
2478 }
2479 pputc(prn, '\n');
2480 } else {
2481 return E_INVARG;
2482 }
2483
2484 return 0;
2485 }
2486
leads_midas_list(int ID,const DATASET * dset,char * listname)2487 int leads_midas_list (int ID, const DATASET *dset,
2488 char *listname)
2489 {
2490 int level = gretl_function_depth();
2491 int *list;
2492 int i, ret = 0;
2493
2494 for (i=0; i<n_vars && !ret; i++) {
2495 if (uvars[i]->type == GRETL_TYPE_LIST &&
2496 uvars[i]->level == level) {
2497 list = uvars[i]->ptr;
2498 if (list[0] > 2 && list[1] == ID) {
2499 ret = gretl_is_midas_list(list, dset);
2500 if (ret && listname != NULL) {
2501 strcpy(listname, uvars[i]->name);
2502 }
2503 }
2504 }
2505 }
2506
2507 return ret;
2508 }
2509
in_midas_list(int ID,const DATASET * dset,char * listname)2510 int in_midas_list (int ID, const DATASET *dset,
2511 char *listname)
2512 {
2513 int level = gretl_function_depth();
2514 int *list;
2515 int i, ret = 0;
2516
2517 for (i=0; i<n_vars && !ret; i++) {
2518 if (uvars[i]->type == GRETL_TYPE_LIST &&
2519 uvars[i]->level == level) {
2520 list = uvars[i]->ptr;
2521 if (list[0] > 2 && in_gretl_list(list, ID)) {
2522 ret = gretl_is_midas_list(list, dset);
2523 if (ret && listname != NULL) {
2524 strcpy(listname, uvars[i]->name);
2525 }
2526 }
2527 }
2528 }
2529
2530 return ret;
2531 }
2532
get_listname_by_consecutive_content(int l0,int l1)2533 const char *get_listname_by_consecutive_content (int l0, int l1)
2534 {
2535 int level = gretl_function_depth();
2536 const char *ret = NULL;
2537 int i, j, *list;
2538
2539 for (i=0; i<n_vars; i++) {
2540 if (uvars[i]->type == GRETL_TYPE_LIST &&
2541 uvars[i]->level == level) {
2542 list = uvars[i]->ptr;
2543 if (list[0] == l0 && list[1] == l1) {
2544 int found = 1;
2545
2546 for (j=2; j<=l0; j++) {
2547 if (list[j] != list[j-1] + 1) {
2548 found = 0;
2549 break;
2550 }
2551 }
2552 if (found) {
2553 return uvars[i]->name;
2554 }
2555 }
2556 }
2557 }
2558
2559 return ret;
2560 }
2561
2562 /* Dropping terms from the list @targ inside a function:
2563 this is tricky with regard to the auto-generated
2564 "time" variable, which may be a member of a list that
2565 was passed as an argument yet not "visible" by name
2566 within the function. Here we attempt to fix this by
2567 transcribing the ID number for "time" from the caller's
2568 namespace into the @drop list -- if the latter is
2569 trying to drop this variable.
2570 */
2571
check_auto_time_var(const int * targ,int * drop,const DATASET * dset)2572 static void check_auto_time_var (const int *targ, int *drop,
2573 const DATASET *dset)
2574 {
2575 int i, vi, tnum = 0;
2576
2577 for (i=1; i<=targ[0]; i++) {
2578 vi = targ[i];
2579 if (!strcmp(dset->varname[vi], "time")) {
2580 tnum = vi;
2581 break;
2582 }
2583 }
2584
2585 if (tnum > 0) {
2586 for (i=drop[0]; i>0; i--) {
2587 vi = drop[i];
2588 if (!strcmp(dset->varname[vi], "time")) {
2589 drop[i] = tnum;
2590 }
2591 }
2592 }
2593 }
2594
2595 /* functions called from geneval.c when "editing" a named list */
2596
user_list_append(user_var * uvar,const int * add)2597 int user_list_append (user_var *uvar, const int *add)
2598 {
2599 int err = 0;
2600
2601 if (uvar == NULL || user_var_get_type(uvar) != GRETL_TYPE_LIST) {
2602 err = E_DATA;
2603 } else {
2604 const int *list = user_var_get_value(uvar);
2605 int *tmp = gretl_list_copy(list);
2606
2607 if (tmp == NULL) {
2608 err = E_ALLOC;
2609 } else {
2610 err = gretl_list_add_list(&tmp, add);
2611 if (!err) {
2612 user_var_replace_value(uvar, tmp, GRETL_TYPE_LIST);
2613 }
2614 }
2615 }
2616
2617 return err;
2618 }
2619
user_list_subtract(user_var * uvar,int * sub,const DATASET * dset)2620 int user_list_subtract (user_var *uvar, int *sub,
2621 const DATASET *dset)
2622 {
2623 int err = 0;
2624
2625 if (uvar == NULL || user_var_get_type(uvar) != GRETL_TYPE_LIST) {
2626 err = E_DATA;
2627 } else {
2628 const int *list = user_var_get_value(uvar);
2629 int *tmp;
2630
2631 if (gretl_function_depth() > 0) {
2632 check_auto_time_var(list, sub, dset);
2633 }
2634 tmp = gretl_list_drop(list, sub, &err);
2635 if (!err) {
2636 user_var_replace_value(uvar, tmp, GRETL_TYPE_LIST);
2637 }
2638 }
2639
2640 return err;
2641 }
2642
user_list_replace(user_var * uvar,const int * src)2643 int user_list_replace (user_var *uvar, const int *src)
2644 {
2645 int err = 0;
2646
2647 if (uvar == NULL || user_var_get_type(uvar) != GRETL_TYPE_LIST) {
2648 err = E_DATA;
2649 } else {
2650 int *tmp = gretl_list_copy(src);
2651
2652 if (tmp == NULL) {
2653 err = E_ALLOC;
2654 } else {
2655 user_var_replace_value(uvar, tmp, GRETL_TYPE_LIST);
2656 }
2657 }
2658
2659 return err;
2660 }
2661
2662 /**
2663 * remember_list:
2664 * @list: array of integers, the first element being a count
2665 * of the following elements.
2666 * @name: name to be given to the list.
2667 * @prn: printing struct.
2668 *
2669 * Adds a copy of @list to the stack of saved lists and associates
2670 * it with @name, unless there is already a list with the given
2671 * name in which case the original list is replaced. A status
2672 * message is printed to @prn.
2673 *
2674 * Returns: 0 on success, non-zero code on error.
2675 */
2676
remember_list(const int * list,const char * name,PRN * prn)2677 int remember_list (const int *list, const char *name, PRN *prn)
2678 {
2679 int *lcpy = gretl_list_copy(list);
2680 int err = 0;
2681
2682 if (lcpy == NULL) {
2683 err = (list == NULL)? E_DATA : E_ALLOC;
2684 } else {
2685 user_var *orig;
2686
2687 orig = get_user_var_of_type_by_name(name, GRETL_TYPE_LIST);
2688
2689 if (orig != NULL) {
2690 /* replace existing list of same name */
2691 user_var_replace_value(orig, lcpy, GRETL_TYPE_LIST);
2692 if (prn != NULL && gretl_messages_on()) {
2693 pprintf(prn, _("Replaced list '%s'\n"), name);
2694 }
2695 } else {
2696 err = user_var_add(name, GRETL_TYPE_LIST, lcpy);
2697 if (!err && prn != NULL && gretl_messages_on()) {
2698 pprintf(prn, _("Added list '%s'\n"), name);
2699 }
2700 }
2701 }
2702
2703 return err;
2704 }
2705
2706 /**
2707 * get_list_by_name:
2708 * @name: the name of the list to be found.
2709 *
2710 * Looks up @name in the stack of saved variables, at the current level
2711 * of function execution, and retrieves the associated list.
2712 *
2713 * Returns: the list, or NULL if the lookup fails.
2714 */
2715
get_list_by_name(const char * name)2716 int *get_list_by_name (const char *name)
2717 {
2718 user_var *u;
2719 int *ret = NULL;
2720
2721 u = get_user_var_of_type_by_name(name, GRETL_TYPE_LIST);
2722
2723 if (u != NULL) {
2724 ret = user_var_get_value(u);
2725 }
2726
2727 return ret;
2728 }
2729
2730 /**
2731 * gretl_is_list:
2732 * @name: the name to test.
2733 *
2734 * Returns: 1 if @name is the name of a saved list, 0
2735 * otherwise.
2736 */
2737
gretl_is_list(const char * name)2738 int gretl_is_list (const char *name)
2739 {
2740 return get_user_var_of_type_by_name(name, GRETL_TYPE_LIST) != NULL;
2741 }
2742