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
20 /* driver module for 'genr' and related commands */
21
22 #include "genparse.h"
23 #include "libset.h"
24 #include "gretl_func.h"
25 #include "genr_optim.h"
26 #include "gretl_typemap.h"
27
28 #include <errno.h>
29
30 #if GENDEBUG
31 # define GDEBUG 1
32 #else
33 # define GDEBUG 0
34 #endif
35
36 #define setting_obsval(p) (p->flags & P_OBSVAL)
37
write_scalar_message(const parser * p,PRN * prn)38 static void write_scalar_message (const parser *p, PRN *prn)
39 {
40 double x = gretl_scalar_get_value(p->lh.name, NULL);
41
42 if (p->lh.t == NUM) {
43 pprintf(prn, _("Replaced scalar %s"), p->lh.name);
44 } else {
45 pprintf(prn, _("Generated scalar %s"), p->lh.name);
46 }
47
48 if (na(x)) {
49 pputs(prn, " = NA");
50 } else {
51 pprintf(prn, " = %g", x);
52 }
53 }
54
55 /* Note: p->lh.name may be empty but it's never NULL, while
56 the vname member of a NODE may be NULL.
57 */
58
gen_write_message(const parser * p,int oldv,PRN * prn)59 static void gen_write_message (const parser *p, int oldv, PRN *prn)
60 {
61 const char *name = p->lh.name;
62 int targ = p->targ;
63 int vnum = p->lh.vnum;
64 int t = p->lh.t;
65
66 if (p->lhres != NULL) {
67 /* compound LHS object */
68 NODE *lhs = p->lhres;
69 NODE *lh1 = lhs->L;
70
71 if (lh1->vname != NULL) {
72 /* not an "embedded" object */
73 name = lh1->vname;
74 t = targ = lh1->t;
75 if (t == SERIES) {
76 vnum = lh1->vnum;
77 targ = NUM;
78 }
79 } else {
80 return;
81 }
82 if (t != SERIES && t != LIST && t != MAT) {
83 /* we'll not print a message for modification
84 of container types (bundle, array)
85 */
86 return;
87 }
88 }
89
90 if (targ == NUM) {
91 if (setting_obsval(p)) {
92 /* setting specific observation in series */
93 pprintf(prn, _("Modified series %s (ID %d)"),
94 name, vnum);
95 } else {
96 write_scalar_message(p, prn);
97 }
98 } else if (targ == SERIES) {
99 if (vnum == 0 && (p->flags & P_STRVEC)) {
100 pprintf(prn, _("Generated series %s (ID %d)"), name, p->ret->vnum);
101 } else if (vnum < oldv) {
102 pprintf(prn, _("Replaced series %s (ID %d)"), name, vnum);
103 } else {
104 pprintf(prn, _("Generated series %s (ID %d)"), name, vnum);
105 }
106 } else if (targ == MAT) {
107 gretl_matrix *m = get_matrix_by_name(name);
108
109 if (p->lhres != NULL) {
110 pprintf(prn, _("Modified matrix %s"), name);
111 } else if (t == MAT) {
112 pprintf(prn, _("Replaced matrix %s"), name);
113 } else {
114 pprintf(prn, _("Generated matrix %s"), name);
115 }
116 if (gretl_matrix_is_scalar(m)) {
117 pprintf(prn, " = {%g}", m->val[0]);
118 }
119 } else if (targ == LIST) {
120 if (p->lhres != NULL) {
121 pprintf(prn, _("Modified list %s"), name);
122 } else if (t == LIST) {
123 pprintf(prn, _("Replaced list %s"), name);
124 } else {
125 pprintf(prn, _("Generated list %s"), name);
126 }
127 } else if (targ == STR) {
128 if (p->lhres != NULL) {
129 pprintf(prn, _("Modified string %s"), name);
130 } else if (t == STR) {
131 pprintf(prn, _("Replaced string %s"), name);
132 } else {
133 pprintf(prn, _("Generated string %s"), name);
134 }
135 } else {
136 return;
137 }
138
139 pputc(prn, '\n');
140 }
141
maybe_record_lag_info(parser * p)142 static int maybe_record_lag_info (parser *p)
143 {
144 const char *s = p->input;
145 int n = strlen(p->lh.name);
146 char vname[VNAMELEN];
147 char fmt[16];
148 int lag;
149
150 if (!strncmp(s, "genr ", 5)) {
151 s += 5;
152 } else if (!strncmp(s, "series ", 7)) {
153 s += 7;
154 }
155
156 s += strspn(s, " ");
157
158 if (!strncmp(s, p->lh.name, n)) {
159 s += n;
160 s += strspn(s, " ");
161 if (*s == '=') s++;
162 s += strspn(s, " ");
163 }
164
165 /* ensure we don't preserve stale metadata */
166 if (p->lh.vnum > 0) {
167 series_delete_metadata(p->dset, p->lh.vnum);
168 }
169
170 sprintf(fmt, "%%%d[^ ()](%%d)", VNAMELEN-1);
171
172 if (sscanf(s, fmt, vname, &lag) == 2) {
173 s = strchr(s, ')');
174 if (s != NULL && string_is_blank(s + 1)) {
175 int pv = series_index(p->dset, vname);
176
177 if (pv < p->dset->v && function_lookup(vname)) {
178 /* rule out the case of a series name shadowing
179 a built-in function
180 */
181 pv = -1;
182 }
183 if (pv > 0 && pv < p->dset->v) {
184 series_set_parent(p->dset, p->lh.vnum, p->dset->varname[pv]);
185 series_set_transform(p->dset, p->lh.vnum, LAGS);
186 series_set_lag(p->dset, p->lh.vnum, -lag);
187 }
188 }
189 }
190
191 return 0;
192 }
193
gen_write_label(parser * p,int oldv)194 static void gen_write_label (parser *p, int oldv)
195 {
196 const char *src = NULL;
197
198 if (p->targ != SERIES) {
199 /* this is relevant only for series */
200 return;
201 }
202
203 if (p->lh.expr != NULL) {
204 /* don't touch the label if we generated a single
205 observation in a series
206 */
207 return;
208 }
209
210 maybe_record_lag_info(p);
211
212 if (p->lh.vnum < oldv && p->targ == SERIES) {
213 series_set_mtime(p->dset, p->lh.vnum);
214 }
215
216 if (p->lh.label != NULL && (p->flags & P_UFRET)) {
217 src = p->lh.label;
218 } else if (p->rhs != NULL && strcmp(p->rhs, "NA")) {
219 src = p->rhs;
220 }
221
222 if (src != NULL && *src != '\0') {
223 if (strlen(src) > MAXLABEL - 1) {
224 /* truncate if necessary */
225 char tmp[MAXLABEL];
226
227 *tmp = '\0';
228 strncat(tmp, src, MAXLABEL - 4);
229 strcat(tmp, "...");
230 series_set_label(p->dset, p->lh.vnum, tmp);
231 } else {
232 series_set_label(p->dset, p->lh.vnum, src);
233 }
234 if (src == p->rhs) {
235 /* in case the label is a formula */
236 series_set_flag(p->dset, p->lh.vnum, VAR_GENERATED);
237 }
238 }
239 }
240
241 /**
242 * function_from_string:
243 * @s: the string to look up.
244 *
245 * Returns: 1 if there is a function corresponding
246 * to the name @s, or 0 if there is no such function.
247 */
248
function_from_string(const char * s)249 int function_from_string (const char *s)
250 {
251 char word[9];
252 const char *p;
253
254 *word = 0;
255
256 p = strchr(s, '(');
257 if (p != NULL && p - s <= 8) {
258 strncat(word, s, p - s);
259 } else {
260 strncat(word, s, 8);
261 }
262
263 if (function_lookup(word)) {
264 return 1;
265 }
266
267 /* user-defined functions */
268 if (get_user_function_by_name(s)) {
269 return 1;
270 }
271
272 return 0;
273 }
274
275 static const char *reswords[] = {
276 /* constants */
277 "const",
278 "NA",
279 "null",
280 "obs", /* not exactly a constant, but hey */
281 /* types */
282 "scalar",
283 "series",
284 "matrix",
285 "string",
286 "list",
287 "bundle",
288 "array",
289 "void",
290 /* control flow */
291 "for",
292 /* debugging instructions, etc. */
293 "continue",
294 "next",
295 "to"
296 };
297
298 /**
299 * gretl_reserved_word:
300 * @str: string to be tested.
301 *
302 * Returns: non-zero if @str is a reserved word that cannot
303 * figure as the name of a user-defined variable, otherwise 0.
304 */
305
gretl_reserved_word(const char * str)306 int gretl_reserved_word (const char *str)
307 {
308 static int n = sizeof reswords / sizeof reswords[0];
309 int i, ret = gretl_command_number(str);
310
311 /* the names of built-in functions are deliberately
312 not reserved */
313
314 for (i=0; i<n && !ret; i++) {
315 if (!strcmp(str, reswords[i])) {
316 ret = E_INVARG;
317 }
318 }
319
320 if (ret) {
321 gretl_errmsg_sprintf(_("'%s' is a reserved word"), str);
322 }
323
324 return ret;
325 }
326
327 /**
328 * extract_varname:
329 * @targ: target string into which to write name.
330 * @src: source string.
331 * @len: location to receive the length of the extracted portion.
332 *
333 * Writes up to #VNAMELEN - 1 characters from @s into @vname.
334 *
335 * Returns: 0 on success, non-zero if the number of valid varname
336 * characters in @s is greater than #VNAMELEN - 1.
337 */
338
extract_varname(char * targ,const char * src,int * len)339 int extract_varname (char *targ, const char *src, int *len)
340 {
341 int err = 0;
342
343 *targ = '\0';
344 *len = gretl_namechar_spn(src);
345
346 if (*len >= VNAMELEN) {
347 /* too long to be a valid variable name */
348 err = E_UNKVAR;
349 } else {
350 strncat(targ, src, *len);
351 }
352
353 return err;
354 }
355
try_for_listvar(const DATASET * dset,const char * s)356 static int try_for_listvar (const DATASET *dset, const char *s)
357 {
358 char vname[VNAMELEN];
359 char lname[VNAMELEN];
360 char fmt[16];
361
362 sprintf(fmt, "%%%d[^.].%%%ds", VNAMELEN-1, VNAMELEN-1);
363
364 if (sscanf(s, fmt, lname, vname) == 2) {
365 int *list = get_list_by_name(lname);
366
367 if (list != NULL) {
368 int i, vi;
369
370 for (i=1; i<=list[0]; i++) {
371 vi = list[i];
372 if (!strcmp(vname, dset->varname[vi])) {
373 return vi;
374 }
375 }
376 }
377 }
378
379 return dset->v;
380 }
381
382 #define GEN_LEVEL_DEBUG 0
383
384 /**
385 * series_index:
386 * @dset: data information struct.
387 * @varname: name of variable to test.
388 *
389 * Returns: the ID number of the variable whose name is given,
390 * or the next available ID number if there is no variable of
391 * that name.
392 */
393
series_index(const DATASET * dset,const char * varname)394 int series_index (const DATASET *dset, const char *varname)
395 {
396 const char *s = varname;
397 int fd = 0, ret = -1;
398
399 if (dset != NULL) {
400 int i;
401
402 ret = dset->v; /* initialize to "next" series ID */
403
404 if (s == NULL || *s == '\0' || isdigit(*s)) {
405 goto bailout;
406 }
407
408 if (strcmp(s, "const") == 0) {
409 ret = 0;
410 goto bailout;
411 }
412
413 if (strchr(s, '.') != NULL) {
414 ret = try_for_listvar(dset, s);
415 goto bailout;
416 }
417
418 fd = gretl_function_depth();
419
420 if (fd == 0) {
421 /* not inside a user function: easy */
422 for (i=1; i<dset->v; i++) {
423 if (strcmp(dset->varname[i], s) == 0) {
424 ret = i;
425 break;
426 }
427 }
428 } else {
429 /* The condition for recognizing a series by name, if we're
430 inside a user function: it must exist at the current level
431 of function execution, and its tenure at that level must
432 not just be the result of its being a member of a list
433 that was passed as an argument.
434 */
435 for (i=1; i<dset->v; i++) {
436 if (fd == series_get_stack_level(dset, i) &&
437 !series_is_listarg(dset, i, NULL) &&
438 strcmp(dset->varname[i], s) == 0) {
439 ret = i;
440 break;
441 }
442 }
443 }
444 }
445
446 bailout:
447
448 #if GEN_LEVEL_DEBUG
449 fprintf(stderr, "series_index for '%s', fd = %d: got %d (dset->v = %d)\n",
450 s, fd, ret, dset->v);
451 #endif
452
453 return ret;
454 }
455
456 /**
457 * series_greatest_index:
458 * @dset: data information struct.
459 * @varname: name of variable to test.
460 *
461 * Returns: the ID number of the variable whose name is given,
462 * or the next available ID number if there is no variable of
463 * that name. In contrast to series_index() this variant searches
464 * down from the greatest current series ID.
465 */
466
series_greatest_index(const DATASET * dset,const char * varname)467 int series_greatest_index (const DATASET *dset, const char *varname)
468 {
469 const char *s = varname;
470 int fd = 0, ret = -1;
471
472 if (dset != NULL) {
473 int i;
474
475 ret = dset->v;
476
477 if (s == NULL || *s == '\0' || isdigit(*s)) {
478 goto bailout;
479 }
480
481 if (strcmp(s, "const") == 0) {
482 ret = 0;
483 goto bailout;
484 }
485
486 if (strchr(s, '.') != NULL) {
487 ret = try_for_listvar(dset, s);
488 goto bailout;
489 }
490
491 fd = gretl_function_depth();
492
493 if (fd == 0) {
494 /* not inside a user function: easy */
495 for (i=dset->v-1; i>0; i--) {
496 if (strcmp(dset->varname[i], s) == 0) {
497 ret = i;
498 break;
499 }
500 }
501 } else {
502 /* The condition for recognizing a series by name, if we're
503 inside a user function: it must exist at the current level
504 of function execution, and its tenure at that level must
505 not just be the result of its being a member of a list
506 that was passed as an argument.
507 */
508 for (i=dset->v-1; i>0; i--) {
509 if (fd == series_get_stack_level(dset, i) &&
510 !series_is_listarg(dset, i, NULL) &&
511 strcmp(dset->varname[i], s) == 0) {
512 ret = i;
513 break;
514 }
515 }
516 }
517 }
518
519 if (ret <= 0 && strcmp(s, "const")) {
520 ret = dset->v;
521 }
522
523 bailout:
524
525 #if GEN_LEVEL_DEBUG
526 fprintf(stderr, "series_index for '%s', fd = %d: got %d (dset->v = %d)\n",
527 s, fd, ret, dset->v);
528 #endif
529
530 return ret;
531 }
532
current_series_index(const DATASET * dset,const char * vname)533 int current_series_index (const DATASET *dset, const char *vname)
534 {
535 int v = -1;
536
537 if (dset != NULL && dset->v > 0 &&
538 vname != NULL && *vname != '\0') {
539 v = series_index(dset, vname);
540 if (v >= dset->v) {
541 v = -1;
542 }
543 }
544
545 return v;
546 }
547
gretl_is_series(const char * name,const DATASET * dset)548 int gretl_is_series (const char *name, const DATASET *dset)
549 {
550 if (dset == NULL) {
551 return 0;
552 } else {
553 int v = series_index(dset, name);
554
555 return (v >= 0 && v < dset->v);
556 }
557 }
558
genr_special_word(const char * s)559 int genr_special_word (const char *s)
560 {
561 if (!strcmp(s, "dummy") ||
562 !strcmp(s, "timedum") ||
563 !strcmp(s, "unitdum") ||
564 !strcmp(s, "time") ||
565 !strcmp(s, "index") ||
566 !strcmp(s, "unit") ||
567 !strcmp(s, "weekday")) {
568 return 1;
569 } else {
570 return 0;
571 }
572 }
573
574 static GretlType genr_last_type;
575
genr_get_last_output_type(void)576 GretlType genr_get_last_output_type (void)
577 {
578 return genr_last_type;
579 }
580
gen_special(const char * s,const char * line,DATASET * dset,PRN * prn,parser * p)581 static int gen_special (const char *s, const char *line,
582 DATASET *dset, PRN *prn, parser *p)
583 {
584 const char *msg = NULL;
585 int orig_v = dset->v;
586 int write_label = 0;
587 int vnum = -1;
588 int err = 0;
589
590 if (dset == NULL || dset->n == 0) {
591 return E_NODATA;
592 }
593
594 if (!strcmp(s, "markers")) {
595 return generate_obs_markers(line, dset);
596 } else if (!strcmp(s, "dummy")) {
597 err = gen_seasonal_dummies(dset, 0);
598 if (!err) {
599 msg = N_("Periodic dummy variables generated.\n");
600 }
601 } else if (!strcmp(s, "timedum")) {
602 err = gen_panel_dummies(dset, OPT_T, prn);
603 if (!err) {
604 msg = N_("Panel dummy variables generated.\n");
605 }
606 } else if (!strcmp(s, "unitdum")) {
607 err = gen_panel_dummies(dset, OPT_NONE, prn);
608 if (!err) {
609 msg = N_("Panel dummy variables generated.\n");
610 }
611 } else if (!strcmp(s, "time")) {
612 err = gen_time(dset, 1, &vnum);
613 write_label = 1;
614 } else if (!strcmp(s, "index")) {
615 err = gen_time(dset, 0, &vnum);
616 write_label = 1;
617 } else if (!strcmp(s, "unit")) {
618 err = gen_unit(dset, &vnum);
619 write_label = 1;
620 } else if (!strcmp(s, "weekday")) {
621 err = gen_wkday(dset, &vnum);
622 write_label = 1;
623 }
624
625 if (msg != NULL && gretl_messages_on()) {
626 pputs(prn, _(msg));
627 }
628
629 if (!err && write_label) {
630 strcpy(p->lh.name, s);
631 p->lh.vnum = vnum;
632 p->dset = dset;
633 p->targ = SERIES;
634 p->flags = 0;
635 p->lhres = NULL;
636 p->err = 0;
637 p->prn = prn;
638 if (prn != NULL && gretl_messages_on()) {
639 gen_write_message(p, orig_v, prn);
640 }
641 }
642
643 if (dset->v > orig_v) {
644 set_dataset_is_changed(dset, 1);
645 genr_last_type = GRETL_TYPE_SERIES;
646 }
647
648 return err;
649 }
650
get_oldstyle_stack_args(const char * s,char ** arg,char ** opt1,char ** opt2)651 static int get_oldstyle_stack_args (const char *s, char **arg,
652 char **opt1, char **opt2)
653 {
654 const char *p1, *p2;
655 int len;
656
657 /* Let the marker for old-style uage be the presence of
658 one or more legacy option flags */
659
660 p1 = strstr(s, "--length=");
661 if (p1 != NULL) {
662 len = strcspn(p1 + 9, " \n");
663 *opt1 = gretl_strndup(p1 + 9, len);
664 }
665
666 p2 = strstr(s, "--offset=");
667 if (p2 != NULL) {
668 len = strcspn(p2 + 9, " \n");
669 *opt2 = gretl_strndup(p2 + 9, len);
670 }
671
672 if (p1 != NULL || p2 != NULL) {
673 len = strcspn(s, ")");
674 *arg = gretl_strndup(s, len);
675 return 1;
676 } else {
677 return 0;
678 }
679 }
680
stack_update_parser_input(parser * p)681 int stack_update_parser_input (parser *p)
682 {
683 char *arg = NULL, *opt1 = NULL, *opt2 = NULL;
684 char *s, *start;
685 gchar *tmp = NULL;
686 GString *gs;
687 int offset;
688
689 offset = p->point - p->input;
690 start = gretl_strndup(p->input, offset);
691 gs = g_string_new(start);
692 free(start);
693
694 s = strstr(p->input, "stack(") + 6;
695 get_oldstyle_stack_args(s, &arg, &opt1, &opt2);
696 if (arg != NULL) {
697 gs = g_string_append(gs, arg);
698 free(arg);
699 }
700 if (opt1 != NULL) {
701 gs = g_string_append_c(gs, ',');
702 gs = g_string_append(gs, opt1);
703 free(opt1);
704 }
705 if (opt2 != NULL) {
706 gs = g_string_append_c(gs, ',');
707 gs = g_string_append(gs, opt2);
708 free(opt2);
709 }
710 gs = g_string_append_c(gs, ')');
711 tmp = g_string_free(gs, FALSE);
712
713 p->input = tmp;
714 p->point = p->input + offset;
715 p->flags |= P_ALTINP;
716
717 return 0;
718 }
719
is_genr_special(const char * s,char * spec,const char ** rem)720 static int is_genr_special (const char *s, char *spec, const char **rem)
721 {
722 if (strncmp(s, "genr ", 5)) {
723 return 0;
724 }
725
726 s += 5;
727 while (*s == ' ') s++;
728
729 if (genr_special_word(s)) {
730 if (spec != NULL) {
731 strcpy(spec, s);
732 }
733 if (rem != NULL) {
734 *rem = s;
735 }
736 return 1;
737 }
738
739 if (!strncmp(s, "markers", 7) && strchr(s, '=')) {
740 if (spec != NULL) {
741 strcpy(spec, "markers");
742 }
743 if (rem != NULL) {
744 s = strchr(s, '=') + 1;
745 while (*s == ' ') s++;
746 *rem = s;
747 }
748 return 1;
749 }
750
751 return 0;
752 }
753
maybe_unassigned_fncall(const char * s)754 static int maybe_unassigned_fncall (const char *s)
755 {
756 return s[strlen(s)-1] == ')';
757 }
758
759 #define gen_silent(f) (f & (P_DISCARD | P_PRIV | P_DECL))
760
generate(const char * line,DATASET * dset,GretlType gtype,gretlopt opt,PRN * prn)761 int generate (const char *line, DATASET *dset,
762 GretlType gtype, gretlopt opt,
763 PRN *prn)
764 {
765 char vname[VNAMELEN] = {0};
766 const char *subline = NULL;
767 int oldv, flags = 0;
768 int targtype = UNK;
769 parser p;
770
771 if (line == NULL) {
772 return E_ARGS;
773 }
774
775 if (gtype == GRETL_TYPE_NONE) {
776 flags |= P_DISCARD;
777 } else if (gtype == GRETL_TYPE_DOUBLE) {
778 targtype = NUM;
779 } else if (gtype == GRETL_TYPE_SERIES) {
780 targtype = SERIES;
781 } else if (gtype == GRETL_TYPE_MATRIX) {
782 targtype = MAT;
783 } else if (gtype == GRETL_TYPE_STRING) {
784 targtype = STR;
785 } else if (gtype == GRETL_TYPE_BUNDLE) {
786 targtype = BUNDLE;
787 } else if (gtype == GRETL_TYPE_LIST) {
788 targtype = LIST;
789 } else if (gtype == GRETL_TYPE_BOOL) {
790 targtype = NUM;
791 flags |= P_ANON;
792 } else if (gretl_array_type(gtype)) {
793 targtype = gtype;
794 }
795
796 if (opt & OPT_P) {
797 /* internal use of generate() */
798 flags |= P_PRIV;
799 }
800
801 if (opt & OPT_Q) {
802 flags |= P_QUIET;
803 }
804
805 if (opt & OPT_C) {
806 flags |= P_CATCH;
807 }
808
809 if (opt & OPT_O) {
810 /* special for function call, no assignment */
811 if (maybe_unassigned_fncall(line)) {
812 targtype = EMPTY;
813 flags |= P_VOID;
814 } else {
815 return E_PARSE;
816 }
817 }
818
819 oldv = (dset != NULL)? dset->v : 0;
820
821 #if GDEBUG
822 fprintf(stderr, "\n*** generate: line = '%s'\n", line);
823 fprintf(stderr, " gtype=%s, targtype=%s\n", gretl_type_get_name(gtype),
824 getsymb(targtype));
825 #endif
826
827 if (is_genr_special(line, vname, &subline)) {
828 return gen_special(vname, subline, dset, prn, &p);
829 }
830
831 realgen(line, &p, dset, prn, flags, targtype);
832
833 if (!p.err && targtype != EMPTY) {
834 gen_save_or_print(&p, prn);
835 if (!p.err && !gen_silent(p.flags)) {
836 gen_write_label(&p, oldv);
837 if (gretl_messages_on() && prn != NULL && !(opt & OPT_Q)) {
838 gen_write_message(&p, oldv, prn);
839 }
840 }
841 }
842
843 genr_last_type = genr_get_output_type(&p);
844 if (genr_last_type == GRETL_TYPE_SERIES) {
845 set_dataset_is_changed(dset, 1);
846 }
847
848 if (p.err == 1) {
849 /* a fairly good guess? */
850 p.err = E_PARSE;
851 }
852
853 gen_cleanup(&p);
854
855 #if GDEBUG
856 fprintf(stderr, "generate: returning %d\n", p.err);
857 #endif
858
859 return p.err;
860 }
861
862 /* retrieve a scalar result directly */
863
generate_scalar_full(const char * s,DATASET * dset,PRN * prn,int * err)864 static double generate_scalar_full (const char *s, DATASET *dset,
865 PRN *prn, int *err)
866 {
867 parser p;
868 double x = NADBL;
869
870 *err = realgen(s, &p, dset, prn, P_PRIV | P_ANON, NUM);
871
872 if (!*err) {
873 if (p.ret->t == MAT) {
874 gretl_matrix *m = p.ret->v.m;
875
876 if (gretl_matrix_is_scalar(m)) {
877 x = p.ret->v.m->val[0];
878 } else if (!gretl_is_null_matrix(m)) {
879 fprintf(stderr, "generate_scalar: got %d x %d matrix\n",
880 m->rows, m->cols);
881 *err = E_TYPES;
882 }
883 } else if (p.ret->t == NUM) {
884 x = p.ret->v.xval;
885 } else {
886 *err = E_TYPES;
887 }
888 } else if (*err == 1) {
889 *err = E_PARSE;
890 }
891
892 gen_cleanup(&p);
893
894 return x;
895 }
896
generate_scalar(const char * s,DATASET * dset,int * err)897 double generate_scalar (const char *s, DATASET *dset, int *err)
898 {
899 return generate_scalar_full(s, dset, NULL, err);
900 }
901
902 /* retrieve a boolean result directly: called only from
903 flow_control.c
904 */
905
generate_boolean(const char * s,DATASET * dset,PRN * prn,int * err)906 double generate_boolean (const char *s, DATASET *dset, PRN *prn, int *err)
907 {
908 double x = generate_scalar_full(s, dset, prn, err);
909
910 return (*err || na(x)) ? NADBL : (double) (x != 0.0);
911 }
912
913 /* retrieve an integer result directly */
914
generate_int(const char * s,DATASET * dset,int * err)915 int generate_int (const char *s, DATASET *dset, int *err)
916 {
917 double x = generate_scalar_full(s, dset, NULL, err);
918 int ret = -1;
919
920 if (!*err) {
921 ret = gretl_int_from_double(x, err);
922 }
923
924 return ret;
925 }
926
927 /* Execute statement @s, bypassing the command tokenizer,
928 when we know that it contains a call to a function whose
929 return value (if any) we do not want to assign. Prime
930 example: the bundle-print function for a function package.
931 */
932
generate_void(const char * s,DATASET * dset,PRN * prn)933 int generate_void (const char *s, DATASET *dset, PRN *prn)
934 {
935 parser p;
936 int err;
937
938 err = realgen(s, &p, dset, prn, P_PRIV | P_VOID, EMPTY);
939
940 gen_cleanup(&p);
941
942 return err;
943 }
944
945 /* retrieve a series result directly */
946
generate_series(const char * s,DATASET * dset,PRN * prn,int * err)947 double *generate_series (const char *s, DATASET *dset, PRN *prn,
948 int *err)
949 {
950 parser p;
951 double *x = NULL;
952
953 *err = realgen(s, &p, dset, prn, P_PRIV | P_ANON, SERIES);
954
955 if (!*err) {
956 NODE *n = p.ret;
957
958 if (n->t == SERIES) {
959 if (n->flags & TMP_NODE) {
960 /* steal the generated series */
961 x = n->v.xvec;
962 n->v.xvec = NULL;
963 } else {
964 x = copyvec(n->v.xvec, p.dset->n);
965 }
966 } else {
967 *err = E_TYPES;
968 }
969 } else if (*err == 1) {
970 *err = E_PARSE;
971 }
972
973 gen_cleanup(&p);
974
975 return x;
976 }
977
978 /* retrieve a matrix result directly */
979
generate_matrix(const char * s,DATASET * dset,int * err)980 gretl_matrix *generate_matrix (const char *s, DATASET *dset,
981 int *err)
982 {
983 gretl_matrix *m = NULL;
984 parser p;
985
986 *err = realgen(s, &p, dset, NULL, P_PRIV | P_ANON, MAT);
987
988 if (!*err) {
989 NODE *n = p.ret;
990
991 if (n->t == MAT) {
992 if (n->flags & TMP_NODE) {
993 /* steal the generated matrix */
994 m = n->v.m;
995 n->v.m = NULL;
996 } else {
997 m = gretl_matrix_copy(n->v.m);
998 if (m == NULL) {
999 *err = E_ALLOC;
1000 }
1001 }
1002 } else if (n->t == NUM) {
1003 if (na(n->v.xval)) {
1004 *err = E_NAN;
1005 } else {
1006 m = gretl_matrix_alloc(1, 1);
1007 if (m == NULL) {
1008 *err = E_ALLOC;
1009 } else {
1010 m->val[0] = n->v.xval;
1011 }
1012 }
1013 } else {
1014 *err = E_TYPES;
1015 }
1016 } else if (*err == 1) {
1017 *err = E_PARSE;
1018 }
1019
1020 gen_cleanup(&p);
1021
1022 return m;
1023 }
1024
1025 /* retrieve a string result directly */
1026
generate_string(const char * s,DATASET * dset,int * err)1027 char *generate_string (const char *s, DATASET *dset, int *err)
1028 {
1029 parser p;
1030 char *ret = NULL;
1031
1032 *err = realgen(s, &p, dset, NULL, P_PRIV | P_ANON, STR);
1033
1034 if (!*err) {
1035 NODE *n = p.ret;
1036
1037 if (n->t == STR) {
1038 if (n->flags & TMP_NODE) {
1039 /* steal the generated string */
1040 ret = n->v.str;
1041 n->v.str = NULL;
1042 } else {
1043 ret = gretl_strdup(n->v.str);
1044 }
1045 } else {
1046 *err = E_TYPES;
1047 }
1048 } else if (*err == 1) {
1049 *err = E_PARSE;
1050 }
1051
1052 gen_cleanup(&p);
1053
1054 return ret;
1055 }
1056
1057 /* retrieve a list result directly */
1058
generate_list(const char * s,DATASET * dset,int * err)1059 int *generate_list (const char *s, DATASET *dset, int *err)
1060 {
1061 int *ret = NULL;
1062 parser p;
1063
1064 if (dset == NULL) {
1065 *err = E_NODATA;
1066 return NULL;
1067 }
1068
1069 *err = realgen(s, &p, dset, NULL, P_PRIV | P_ANON, LIST);
1070
1071 if (!*err) {
1072 ret = node_get_list(p.ret, &p);
1073 *err = p.err;
1074 }
1075
1076 gen_cleanup(&p);
1077
1078 return ret;
1079 }
1080
1081 /* create a parsed tree that can be evaluated later,
1082 probably multiple times */
1083
genr_compile(const char * s,DATASET * dset,GretlType gtype,gretlopt opt,PRN * prn,int * err)1084 parser *genr_compile (const char *s, DATASET *dset,
1085 GretlType gtype, gretlopt opt,
1086 PRN *prn, int *err)
1087 {
1088 parser *p;
1089 int flags = P_COMPILE;
1090 int targtype = UNK;
1091
1092 #if GDEBUG
1093 fprintf(stderr, "\n*** genr_compile: s = '%s'\n", s);
1094 #endif
1095
1096 if (is_genr_special(s, NULL, NULL)) {
1097 *err = E_EQN;
1098 return NULL;
1099 }
1100
1101 p = malloc(sizeof *p);
1102
1103 if (p == NULL) {
1104 *err = E_ALLOC;
1105 return NULL;
1106 }
1107
1108 if (gtype == GRETL_TYPE_NONE) {
1109 flags |= P_DISCARD;
1110 } else if (gtype == GRETL_TYPE_DOUBLE) {
1111 targtype = NUM;
1112 } else if (gtype == GRETL_TYPE_SERIES) {
1113 targtype = SERIES;
1114 } else if (gtype == GRETL_TYPE_MATRIX) {
1115 targtype = MAT;
1116 } else if (gtype == GRETL_TYPE_STRING) {
1117 targtype = STR;
1118 } else if (gtype == GRETL_TYPE_BUNDLE) {
1119 targtype = BUNDLE;
1120 } else if (gtype == GRETL_TYPE_LIST) {
1121 targtype = LIST;
1122 } else if (gtype == GRETL_TYPE_BOOL) {
1123 targtype = NUM;
1124 flags |= P_ANON;
1125 } else if (gretl_array_type(gtype)) {
1126 targtype = gtype;
1127 }
1128
1129 if (opt & OPT_P) {
1130 /* internal use of generate() */
1131 flags |= P_PRIV;
1132 }
1133
1134 if (opt & OPT_O) {
1135 /* special for function call, no assignment */
1136 targtype = EMPTY;
1137 flags |= P_VOID;
1138 }
1139
1140 if (opt & OPT_N) {
1141 /* "no exec": compile but don't run */
1142 flags |= P_NOEXEC;
1143 }
1144
1145 if (opt & OPT_A) {
1146 /* anonymous: no assignment to named variable */
1147 flags |= P_ANON;
1148 }
1149
1150 *err = realgen(s, p, dset, prn, flags, targtype);
1151
1152 if (*err == 0 && p != NULL &&
1153 !(opt & OPT_N) && p->targ != EMPTY) {
1154 gen_save_or_print(p, prn);
1155 if (p->err) {
1156 *err = p->err;
1157 }
1158 }
1159
1160 if (*err) {
1161 destroy_genr(p);
1162 p = NULL;
1163 }
1164
1165 #if GDEBUG
1166 fprintf(stderr, "genr_compile: err = %d\n", *err);
1167 #endif
1168
1169 return p;
1170 }
1171
1172 /* run a previously compiled generator */
1173
execute_genr(parser * p,DATASET * dset,PRN * prn)1174 int execute_genr (parser *p, DATASET *dset, PRN *prn)
1175 {
1176 #if GDEBUG
1177 fprintf(stderr, "\n*** execute_genr: p=%p, LHS='%s', Z=%p, prn=%p\n",
1178 (void *) p, p->lh.expr ? p->lh.expr : p->lh.name,
1179 (void *) dset->Z, (void *) prn);
1180 #endif
1181
1182 realgen(NULL, p, dset, prn, P_EXEC, UNK);
1183
1184 if (!p->err && p->targ != EMPTY) {
1185 gen_save_or_print(p, prn);
1186 }
1187
1188 if (p->err) {
1189 gen_cleanup(p);
1190 }
1191
1192 #if GDEBUG
1193 fprintf(stderr, "execute_genr: returning %d\n", p->err);
1194 #endif
1195
1196 return p->err;
1197 }
1198
evaluate_scalar_genr(parser * p,DATASET * dset,PRN * prn,int * err)1199 double evaluate_scalar_genr (parser *p, DATASET *dset,
1200 PRN *prn, int *err)
1201 {
1202 double x = NADBL;
1203
1204 *err = realgen(NULL, p, dset, NULL, P_EXEC | P_PRIV | P_ANON,
1205 NUM);
1206
1207 if (!*err) {
1208 if (p->ret->t == MAT) {
1209 gretl_matrix *m = p->ret->v.m;
1210
1211 if (gretl_matrix_is_scalar(m)) {
1212 x = p->ret->v.m->val[0];
1213 } else if (!gretl_is_null_matrix(m)) {
1214 fprintf(stderr, "evaluate_if_cond: got %d x %d matrix\n",
1215 m->rows, m->cols);
1216 *err = E_TYPES;
1217 }
1218 } else if (p->ret->t == NUM) {
1219 x = p->ret->v.xval;
1220 } else {
1221 *err = E_TYPES;
1222 }
1223 } else if (*err == 1) {
1224 *err = E_PARSE;
1225 }
1226
1227 gen_cleanup(p);
1228
1229 return x;
1230 }
1231
evaluate_if_cond(parser * p,DATASET * dset,PRN * prn,int * err)1232 double evaluate_if_cond (parser *p, DATASET *dset, PRN *prn, int *err)
1233 {
1234 double x = evaluate_scalar_genr(p, dset, prn, err);
1235
1236 return *err ? x : (double) (x != 0.0);
1237 }
1238
1239 /* destroy a previously compiled generator */
1240
destroy_genr(parser * p)1241 void destroy_genr (parser *p)
1242 {
1243 #if GDEBUG
1244 fprintf(stderr, "\n*** destroy_genr: p = %p\n", (void *) p);
1245 #endif
1246
1247 if (p != NULL) {
1248 p->flags = 0;
1249 gen_cleanup(p);
1250 free(p);
1251 }
1252 }
1253
genr_get_output_type(const parser * p)1254 GretlType genr_get_output_type (const parser *p)
1255 {
1256 int t = GRETL_TYPE_NONE;
1257
1258 if (!p->err) {
1259 if (p->targ == NUM) {
1260 t = GRETL_TYPE_DOUBLE;
1261 } else if (p->targ == SERIES) {
1262 t = GRETL_TYPE_SERIES;
1263 } else if (p->targ == MAT) {
1264 t = GRETL_TYPE_MATRIX;
1265 } else if (p->targ == LIST) {
1266 t = GRETL_TYPE_LIST;
1267 } else if (p->targ == BUNDLE) {
1268 t = GRETL_TYPE_BUNDLE;
1269 } else if (p->targ == ARRAY) {
1270 t = GRETL_TYPE_ARRAY;
1271 }
1272 }
1273
1274 return t;
1275 }
1276
genr_get_output_varnum(const parser * p)1277 int genr_get_output_varnum (const parser *p)
1278 {
1279 return p->lh.vnum;
1280 }
1281
genr_get_output_matrix(parser * p)1282 gretl_matrix *genr_get_output_matrix (parser *p)
1283 {
1284 gretl_matrix *m = p->lh.mret;
1285
1286 if (p->targ != MAT) {
1287 /* matrix under bundle or array?
1288 nullify pointer in case the type changes
1289 */
1290 p->lh.mret = NULL;
1291 }
1292
1293 return m;
1294 }
1295
genr_get_output_scalar(const parser * p)1296 double genr_get_output_scalar (const parser *p)
1297 {
1298 if (p->targ == NUM) {
1299 return gretl_scalar_get_value(p->lh.name, NULL);
1300 } else {
1301 return NADBL;
1302 }
1303 }
1304
genr_no_assign(const parser * p)1305 int genr_no_assign (const parser *p)
1306 {
1307 return (p->flags & (P_DISCARD | P_VOID));
1308 }
1309
genr_is_autoregressive(const parser * p)1310 int genr_is_autoregressive (const parser *p)
1311 {
1312 return (p->flags & P_AUTOREG);
1313 }
1314
genr_set_na_check(parser * p)1315 void genr_set_na_check (parser *p)
1316 {
1317 p->flags |= P_NATEST;
1318 }
1319
genr_unset_na_check(parser * p)1320 void genr_unset_na_check (parser *p)
1321 {
1322 p->flags &= ~P_NATEST;
1323 }
1324