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 /* monte_carlo.c - loop procedures */
21
22 #include "libgretl.h"
23 #include "monte_carlo.h"
24 #include "libset.h"
25 #include "compat.h"
26 #include "cmd_private.h"
27 #include "var.h"
28 #include "objstack.h"
29 #include "gretl_func.h"
30 #include "uservar.h"
31 #include "uservar_priv.h"
32 #include "flow_control.h"
33 #include "system.h"
34 #include "genparse.h"
35 #include "gretl_string_table.h"
36 #include "genr_optim.h"
37
38 #include <time.h>
39 #include <unistd.h>
40
41 #define LOOP_DEBUG 0
42 #define SUBST_DEBUG 0
43
44 #if HAVE_GMP
45 # include <gmp.h>
46
47 typedef mpf_t bigval;
48 #endif
49
50 enum loop_types {
51 COUNT_LOOP,
52 WHILE_LOOP,
53 INDEX_LOOP,
54 DATED_LOOP,
55 FOR_LOOP,
56 EACH_LOOP
57 };
58
59 #define DEFAULT_NOBS 512
60
61 #define indexed_loop(l) (l->type == INDEX_LOOP || \
62 l->type == DATED_LOOP || \
63 l->type == EACH_LOOP)
64
65 #if HAVE_GMP
66
67 /* below: LOOP_PRINT, LOOP_MODEL and LOOP_STORE are
68 used only in "progressive" loops, which requires
69 GMP to preserve precision
70 */
71
72 typedef struct {
73 int lineno; /* location: line number in loop */
74 int n; /* number of repetitions */
75 int nvars; /* number of variables */
76 char **names; /* names of vars to print */
77 bigval *sum; /* running sum of values */
78 bigval *ssq; /* running sum of squares */
79 double *xbak; /* previous values */
80 int *diff; /* indicator for difference */
81 char *na; /* indicator for NAs in calculation */
82 } LOOP_PRINT;
83
84 typedef struct {
85 int lineno; /* location: line number in loop */
86 int n; /* number of repetitions */
87 int nc; /* number of coefficients */
88 MODEL *model0; /* copy of initial model */
89 bigval *bigarray; /* global pointer array */
90 bigval *sum_coeff; /* sums of coefficient estimates */
91 bigval *ssq_coeff; /* sums of squares of coeff estimates */
92 bigval *sum_sderr; /* sums of estimated std. errors */
93 bigval *ssq_sderr; /* sums of squares of estd std. errs */
94 double *cbak; /* previous values of coeffs */
95 double *sbak; /* previous values of std. errs */
96 int *cdiff; /* indicator for difference in coeff */
97 int *sdiff; /* indicator for difference in s.e. */
98 } LOOP_MODEL;
99
100 typedef struct {
101 int lineno; /* location: line number in loop */
102 int n; /* number of observations */
103 int nvars; /* number of variables to store */
104 char **names; /* names of vars to print */
105 char *fname; /* filename for output */
106 gretlopt opt; /* formatting option */
107 DATASET *dset; /* temporary data storage */
108 } LOOP_STORE;
109
110 #endif /* HAVE_GMP: progressive option supported */
111
112 typedef enum {
113 LOOP_PROGRESSIVE = 1 << 0,
114 LOOP_VERBOSE = 1 << 1,
115 LOOP_DELVAR = 1 << 2,
116 LOOP_ATTACHED = 1 << 3,
117 LOOP_RENAMING = 1 << 4,
118 LOOP_ERR_CAUGHT = 1 << 5,
119 LOOP_CONDITIONAL = 1 << 6
120 } LoopFlags;
121
122 struct controller_ {
123 double val; /* evaluated value */
124 char vname[VNAMELEN]; /* name of (scalar) variable, if used */
125 user_var *uv; /* pointer to scalar variable */
126 int vsign; /* 1 or -1, if vname is used */
127 char *expr; /* expression to pass to genr, if used */
128 GENERATOR *genr; /* compiled generator */
129 int subst; /* expression uses string substitution? */
130 };
131
132 typedef struct controller_ controller;
133
134 typedef enum {
135 LOOP_CMD_GENR = 1 << 0, /* compiled "genr" */
136 LOOP_CMD_LIT = 1 << 1, /* literal printing */
137 LOOP_CMD_NODOL = 1 << 2, /* no $-substitution this line */
138 LOOP_CMD_NOSUB = 1 << 3, /* no @-substitution this line */
139 LOOP_CMD_CATCH = 1 << 4, /* "catch" flag present */
140 LOOP_CMD_COND = 1 << 5, /* compiled conditional */
141 LOOP_CMD_PDONE = 1 << 6, /* progressive loop command started */
142 LOOP_CMD_NOEQ = 1 << 7 /* "genr" with no formula */
143 } LoopCmdFlags;
144
145 struct loop_command_ {
146 char *line;
147 int ci;
148 gretlopt opt;
149 LoopCmdFlags flags;
150 GENERATOR *genr;
151 };
152
153 typedef struct loop_command_ loop_command;
154
155 struct LOOPSET_ {
156 /* basic characteristics */
157 char type;
158 LoopFlags flags;
159 int level;
160 int err;
161
162 /* iterations */
163 int itermax;
164 int iter;
165 int index;
166
167 /* index/foreach control variables */
168 char idxname[VNAMELEN];
169 user_var *idxvar;
170 int idxval;
171 char eachname[VNAMELEN];
172 GretlType eachtype;
173
174 /* break signal */
175 char brk;
176
177 /* control structures */
178 controller init;
179 controller test;
180 controller delta;
181 controller final;
182
183 /* numbers of various subsidiary objects */
184 int n_cmds;
185 int n_models;
186 int n_children;
187
188 /* subsidiary objects */
189 loop_command *cmds; /* saved command info */
190 char **eachstrs; /* for use with "foreach" loop */
191 MODEL **models; /* regular model pointers */
192 int *model_lines;
193 LOOPSET *parent;
194 LOOPSET **children;
195 int parent_line;
196
197 #if HAVE_GMP
198 /* "progressive" objects and counts thereof */
199 LOOP_MODEL *lmodels;
200 LOOP_PRINT *prns;
201 LOOP_STORE store;
202 int n_loop_models;
203 int n_prints;
204 #endif
205 };
206
207 #define loop_is_progressive(l) (l->flags & LOOP_PROGRESSIVE)
208 #define loop_set_progressive(l) (l->flags |= LOOP_PROGRESSIVE)
209 #define loop_is_verbose(l) (l->flags & LOOP_VERBOSE)
210 #define loop_set_verbose(l) (l->flags |= LOOP_VERBOSE)
211 #define loop_is_attached(l) (l->flags & LOOP_ATTACHED)
212 #define loop_set_attached(l) (l->flags |= LOOP_ATTACHED)
213 #define loop_is_renaming(l) (l->flags & LOOP_RENAMING)
214 #define loop_set_renaming(l) (l->flags |= LOOP_RENAMING)
215 #define loop_err_caught(l) (l->flags |= LOOP_ERR_CAUGHT)
216 #define loop_has_cond(l) (l->flags & LOOP_CONDITIONAL)
217 #define loop_set_has_cond(l) (l->flags |= LOOP_CONDITIONAL)
218
219 #define model_print_deferred(o) (o & OPT_F)
220
221 static void controller_init (controller *clr);
222 static int gretl_loop_prepare (LOOPSET *loop);
223 static void controller_free (controller *clr);
224 static void destroy_loop_stack (LOOPSET *loop);
225
226 #if HAVE_GMP
227 static int extend_loop_dataset (LOOP_STORE *lstore);
228 static void loop_model_free (LOOP_MODEL *lmod);
229 static void loop_print_free (LOOP_PRINT *lprn);
230 static void loop_store_free (LOOP_STORE *lstore);
231 static void loop_store_init (LOOP_STORE *lstore);
232 #endif
233
234 static int
235 make_dollar_substitutions (char *str, int maxlen,
236 const LOOPSET *loop,
237 const DATASET *dset,
238 int *subst,
239 gretlopt opt);
240
241 #define LOOP_BLOCK 32
242
243 /* record of state, and communication of state with outside world */
244
245 static LOOPSET *currloop;
246
247 static int compile_level;
248 static int loop_execute;
249 static int loop_renaming;
250
gretl_compiling_loop(void)251 int gretl_compiling_loop (void)
252 {
253 return compile_level;
254 }
255
gretl_abort_compiling_loop(void)256 void gretl_abort_compiling_loop (void)
257 {
258 if (currloop != NULL) {
259 destroy_loop_stack(currloop);
260 }
261 }
262
gretl_execute_loop(void)263 int gretl_execute_loop (void)
264 {
265 return loop_execute;
266 }
267
get_loop_renaming(void)268 int get_loop_renaming (void)
269 {
270 return loop_renaming;
271 }
272
273 /* Test for a "while" or "for" expression: if it
274 involves string substitution we can't compile.
275 */
276
does_string_sub(const char * s,LOOPSET * loop,DATASET * dset)277 static int does_string_sub (const char *s,
278 LOOPSET *loop,
279 DATASET *dset)
280 {
281 int subst = 0;
282
283 if (strchr(s, '@')) {
284 subst = 1;
285 } else if (strchr(s, '$')) {
286 char test[64];
287
288 *test = '\0';
289 strncat(test, s, 63);
290 make_dollar_substitutions(test, 63, loop, dset,
291 &subst, OPT_T);
292 }
293
294 return subst;
295 }
296
297 /* For indexed loops: get a value from a loop "limit" element (lower
298 or upper). If we got the name of a scalar variable at setup time,
299 look up its current value (and modify the sign if wanted). Or if
300 we got a "genr" expression, evaluate it. Otherwise we should have
301 got a numerical constant at setup, in which case we just return
302 that value.
303 */
304
controller_get_val(controller * clr,LOOPSET * loop,DATASET * dset,int * err)305 static double controller_get_val (controller *clr,
306 LOOPSET *loop,
307 DATASET *dset,
308 int *err)
309 {
310 /* note: check for "compiled" variants first */
311 if (clr->uv != NULL) {
312 clr->val = uvar_get_scalar_value(clr->uv) * clr->vsign;
313 } else if (clr->genr != NULL) {
314 clr->val = evaluate_scalar_genr(clr->genr, dset, NULL, err);
315 } else if (clr->vname[0] != '\0') {
316 if (clr->vname[0] == '$') {
317 /* built-in scalar constant */
318 clr->val = get_const_by_name(clr->vname, err) * clr->vsign;
319 } else {
320 /* should be scalar uservar */
321 if (clr->uv == NULL) {
322 clr->uv = get_user_var_of_type_by_name(clr->vname, GRETL_TYPE_DOUBLE);
323 }
324 if (clr->uv == NULL) {
325 gretl_errmsg_sprintf(_("'%s': not a scalar"), clr->vname);
326 *err = E_TYPES;
327 } else {
328 clr->val = uvar_get_scalar_value(clr->uv) * clr->vsign;
329 }
330 }
331 } else if (clr->expr != NULL && clr->subst) {
332 int done = 0;
333
334 if (strchr(clr->expr, '@')) {
335 /* the expression needs string substitution? */
336 char expr[64];
337
338 *expr = '\0';
339 strncat(expr, clr->expr, 63);
340 *err = substitute_named_strings(expr, &clr->subst);
341 if (!*err && clr->subst) {
342 clr->val = generate_scalar(expr, dset, err);
343 done = 1;
344 }
345 }
346 if (!done && !*err && strchr(clr->expr, '$')) {
347 /* the expression needs dollar substitution? */
348 char expr[64];
349
350 *expr = '\0';
351 strncat(expr, clr->expr, 63);
352 *err = make_dollar_substitutions(expr, 63, loop, dset,
353 &clr->subst, OPT_T);
354 if (!*err && clr->subst) {
355 clr->val = generate_scalar(expr, dset, err);
356 done = 1;
357 }
358 }
359 if (!*err && !done) {
360 clr->subst = 0;
361 clr->val = generate_scalar(clr->expr, dset, err);
362 }
363 } else if (clr->expr != NULL) {
364 /* expression with no string substitution */
365 if (clr->genr == NULL) {
366 clr->genr = genr_compile(clr->expr, dset, GRETL_TYPE_DOUBLE,
367 OPT_P | OPT_N | OPT_A, NULL, err);
368 }
369 if (clr->genr != NULL) {
370 clr->val = evaluate_scalar_genr(clr->genr, dset, NULL, err);
371 } else {
372 /* fallback: or should we just flag an error? */
373 *err = 0;
374 clr->val = generate_scalar(clr->expr, dset, err);
375 }
376 }
377
378 if (*err && clr->expr != NULL) {
379 gchar *msg;
380
381 msg = g_strdup_printf("Bad loop-control expression '%s'", clr->expr);
382 gretl_errmsg_append(msg, *err);
383 g_free(msg);
384 }
385
386 #if LOOP_DEBUG > 1
387 fprintf(stderr, "controller_get_val: vname='%s', expr='%s', val=%g, err=%d\n",
388 clr->vname, clr->expr, clr->val, *err);
389 #endif
390
391 return clr->val;
392 }
393
394 /* apply initialization in case of for-loop */
395
396 static void
forloop_init(LOOPSET * loop,DATASET * dset,int * err)397 forloop_init (LOOPSET *loop, DATASET *dset, int *err)
398 {
399 const char *expr = loop->init.expr;
400
401 if (expr != NULL) {
402 *err = generate(expr, dset, GRETL_TYPE_ANY, OPT_Q, NULL);
403 if (*err) {
404 gretl_errmsg_sprintf("%s: '%s'", _("error evaluating loop condition"),
405 expr);
406 }
407 }
408 }
409
410 /* evaluate boolean condition in for-loop or while-loop */
411
412 static int
loop_testval(LOOPSET * loop,DATASET * dset,int * err)413 loop_testval (LOOPSET *loop, DATASET *dset, int *err)
414 {
415 const char *expr = loop->test.expr;
416 int ret = 1;
417
418 if (expr != NULL) {
419 double x = NADBL;
420
421 if (loop->test.subst < 0) {
422 /* not checked yet */
423 loop->test.subst = does_string_sub(expr, loop, dset);
424 }
425
426 if (!loop->test.subst && loop->test.genr == NULL) {
427 loop->test.genr = genr_compile(expr, dset,
428 GRETL_TYPE_BOOL,
429 OPT_P | OPT_N,
430 NULL, err);
431 }
432
433 if (loop->test.genr != NULL) {
434 x = evaluate_if_cond(loop->test.genr, dset, NULL, err);
435 } else if (!*err) {
436 x = generate_scalar(expr, dset, err);
437 }
438
439 if (!*err && na(x)) {
440 *err = E_DATA;
441 ret = 0;
442 } else {
443 ret = x;
444 }
445 if (*err) {
446 gretl_errmsg_sprintf("%s: '%s'", _("error evaluating loop condition"),
447 expr);
448 }
449 }
450
451 return ret;
452 }
453
454 /* evaluate third expression in for-loop, if any */
455
456 static void
loop_delta(LOOPSET * loop,DATASET * dset,int * err)457 loop_delta (LOOPSET *loop, DATASET *dset, int *err)
458 {
459 const char *expr = loop->delta.expr;
460
461 if (expr != NULL) {
462 if (loop->delta.subst < 0) {
463 /* not checked yet */
464 loop->delta.subst = does_string_sub(expr, loop, dset);
465 }
466
467 if (!loop->delta.subst && loop->delta.genr == NULL) {
468 loop->delta.genr = genr_compile(expr, dset,
469 GRETL_TYPE_ANY,
470 OPT_N,
471 NULL, err);
472 }
473
474 if (loop->delta.genr != NULL) {
475 *err = execute_genr(loop->delta.genr, dset, NULL);
476 } else if (!*err) {
477 *err = generate(expr, dset, GRETL_TYPE_ANY, OPT_Q, NULL);
478 }
479 if (*err) {
480 gretl_errmsg_sprintf("%s: '%s'", _("error evaluating loop condition"),
481 expr);
482 }
483 }
484 }
485
set_loop_opts(LOOPSET * loop,gretlopt opt)486 static void set_loop_opts (LOOPSET *loop, gretlopt opt)
487 {
488 if (opt & OPT_P) {
489 loop_set_progressive(loop);
490 }
491 if (opt & OPT_V) {
492 loop_set_verbose(loop);
493 }
494 }
495
496 #define plain_model_ci(c) (MODEL_COMMAND(c) && \
497 c != NLS && \
498 c != MLE && \
499 c != GMM)
500
501 /**
502 * ok_in_loop:
503 * @ci: command index.
504 *
505 * Returns: 1 if the given command is acceptable inside the loop construct,
506 * 0 otherwise.
507 */
508
ok_in_loop(int c)509 int ok_in_loop (int c)
510 {
511 /* here are the commands we _don't_ currently allow */
512
513 if (c == FUNC ||
514 c == INCLUDE ||
515 c == NULLDATA ||
516 c == RUN ||
517 c == SETMISS ||
518 c == QUIT) {
519 return 0;
520 }
521
522 #if 0
523 if (c == RENAME) return 0;
524 #endif
525
526 return 1;
527 }
528
loop_attach_child(LOOPSET * loop,LOOPSET * child)529 static int loop_attach_child (LOOPSET *loop, LOOPSET *child)
530 {
531 LOOPSET **children;
532 int nc = loop->n_children;
533
534 children = realloc(loop->children, (nc + 1) * sizeof *children);
535 if (children == NULL) {
536 return E_ALLOC;
537 }
538
539 loop->children = children;
540 loop->children[nc] = child;
541 child->parent = loop;
542 child->parent_line = loop->n_cmds;
543 child->level = loop->level + 1;
544
545 #if LOOP_DEBUG
546 fprintf(stderr, "child loop %p has parent %p\n",
547 (void *) child, (void *) child->parent);
548 #endif
549
550 loop->n_children += 1;
551
552 return 0;
553 }
554
gretl_loop_init(LOOPSET * loop)555 static void gretl_loop_init (LOOPSET *loop)
556 {
557 #if LOOP_DEBUG > 1
558 fprintf(stderr, "gretl_loop_init: initing loop at %p\n", (void *) loop);
559 #endif
560
561 loop->flags = 0;
562 loop->level = 0;
563
564 loop->itermax = 0;
565 loop->iter = 0;
566 loop->err = 0;
567 *loop->idxname = '\0';
568 loop->idxvar = NULL;
569 loop->idxval = 0;
570 loop->brk = 0;
571 *loop->eachname = '\0';
572 loop->eachtype = 0;
573 loop->eachstrs = NULL;
574
575 controller_init(&loop->init);
576 controller_init(&loop->test);
577 controller_init(&loop->delta);
578 controller_init(&loop->final);
579
580 loop->n_cmds = 0;
581 loop->cmds = NULL;
582 loop->n_models = 0;
583 loop->models = NULL;
584 loop->model_lines = NULL;
585
586 loop->parent = NULL;
587 loop->children = NULL;
588 loop->n_children = 0;
589 loop->parent_line = 0;
590
591 #if HAVE_GMP
592 /* "progressive" apparatus */
593 loop->n_loop_models = 0;
594 loop->lmodels = NULL;
595 loop->n_prints = 0;
596 loop->prns = NULL;
597 loop_store_init(&loop->store);
598 #endif
599 }
600
gretl_loop_new(LOOPSET * parent)601 static LOOPSET *gretl_loop_new (LOOPSET *parent)
602 {
603 LOOPSET *loop = malloc(sizeof *loop);
604
605 if (loop == NULL) {
606 return NULL;
607 }
608
609 gretl_loop_init(loop);
610
611 if (parent != NULL) {
612 int err = loop_attach_child(parent, loop);
613
614 if (err) {
615 free(loop);
616 loop = NULL;
617 }
618 }
619
620 return loop;
621 }
622
gretl_loop_destroy(LOOPSET * loop)623 void gretl_loop_destroy (LOOPSET *loop)
624 {
625 int i;
626
627 if (loop == NULL) {
628 return;
629 }
630
631 if (loop_is_attached(loop)) {
632 detach_loop_from_function(loop);
633 }
634
635 #if GLOBAL_TRACE || LOOP_DEBUG
636 fprintf(stderr, "destroying LOOPSET at %p\n", (void *) loop);
637 #endif
638
639 for (i=0; i<loop->n_children; i++) {
640 gretl_loop_destroy(loop->children[i]);
641 loop->children[i] = NULL;
642 }
643
644 controller_free(&loop->init);
645 controller_free(&loop->test);
646 controller_free(&loop->delta);
647 controller_free(&loop->final);
648
649 if (loop->cmds != NULL) {
650 for (i=0; i<loop->n_cmds; i++) {
651 free(loop->cmds[i].line);
652 if (loop->cmds[i].genr != NULL) {
653 destroy_genr(loop->cmds[i].genr);
654 }
655 }
656 free(loop->cmds);
657 }
658
659 free(loop->model_lines);
660 free(loop->models);
661
662 if (loop->eachstrs != NULL && loop->eachtype != GRETL_TYPE_STRINGS) {
663 strings_array_free(loop->eachstrs, loop->itermax);
664 }
665
666 #if HAVE_GMP
667 if (loop->lmodels != NULL) {
668 for (i=0; i<loop->n_loop_models; i++) {
669 loop_model_free(&loop->lmodels[i]);
670 }
671 free(loop->lmodels);
672 }
673 if (loop->prns != NULL) {
674 for (i=0; i<loop->n_prints; i++) {
675 loop_print_free(&loop->prns[i]);
676 }
677 free(loop->prns);
678 }
679 loop_store_free(&loop->store);
680 #endif
681
682 if (loop->children != NULL) {
683 free(loop->children);
684 }
685
686 if (loop->flags & LOOP_DELVAR) {
687 user_var_delete_by_name(loop->idxname, NULL);
688 }
689
690 free(loop);
691 }
692
destroy_loop_stack(LOOPSET * loop)693 static void destroy_loop_stack (LOOPSET *loop)
694 {
695 if (loop == NULL) {
696 return;
697 }
698
699 /* find the origin of the stack */
700 while (loop->parent != NULL) {
701 loop = loop->parent;
702 }
703
704 /* and destroy recursively */
705 gretl_loop_destroy(loop);
706
707 compile_level = 0;
708 loop_renaming = 0;
709 set_loop_off();
710 currloop = NULL;
711 }
712
parse_as_while_loop(LOOPSET * loop,const char * s)713 static int parse_as_while_loop (LOOPSET *loop, const char *s)
714 {
715 int err = 0;
716
717 #if LOOP_DEBUG > 1
718 fprintf(stderr, "parse_as_while_loop: cond = '%s'\n", s);
719 #endif
720
721 if (s == NULL || *s == '\0') {
722 err = E_PARSE;
723 } else {
724 loop->type = WHILE_LOOP;
725 loop->test.expr = gretl_strdup(s);
726 if (loop->test.expr == NULL) {
727 err = E_ALLOC;
728 }
729 }
730
731 return err;
732 }
733
check_index_in_parentage(LOOPSET * loop,const char * vname)734 static int check_index_in_parentage (LOOPSET *loop, const char *vname)
735 {
736 int thistype = loop->type;
737
738 while ((loop = loop->parent) != NULL) {
739 if ((loop->type != FOR_LOOP || loop->type != thistype) &&
740 strcmp(vname, loop->idxname) == 0) {
741 gretl_errmsg_sprintf(_("Using the same index variable (%s) for nested loops:\n"
742 "this is acceptable only with \"for\" loops."), vname);
743 return E_DATA;
744 }
745 }
746
747 return 0;
748 }
749
get_local_scalar_by_name(const char * s,int * err)750 static user_var *get_local_scalar_by_name (const char *s, int *err)
751 {
752 user_var *u = get_user_var_by_name(s);
753
754 if (u == NULL) {
755 /* no pre-existing var, OK */
756 return NULL;
757 } else if (u->type != GRETL_TYPE_DOUBLE) {
758 gretl_errmsg_set("loop index must be a scalar");
759 *err = E_TYPES;
760 return NULL;
761 } else {
762 return u;
763 }
764 }
765
766 /* The following is called only once, at the point of initial
767 "compilation" of a loop.
768 */
769
loop_attach_index_var(LOOPSET * loop,const char * vname,DATASET * dset)770 static int loop_attach_index_var (LOOPSET *loop,
771 const char *vname,
772 DATASET *dset)
773 {
774 int err = 0;
775
776 if (loop->parent != NULL) {
777 err = check_index_in_parentage(loop, vname);
778 if (err) {
779 return err;
780 }
781 }
782
783 loop->idxvar = get_local_scalar_by_name(vname, &err);
784
785 if (loop->idxvar != NULL) {
786 strcpy(loop->idxname, vname);
787 uvar_set_scalar_fast(loop->idxvar, loop->init.val);
788 } else if (!err) {
789 /* create index var from scratch */
790 char genline[64];
791
792 if (na(loop->init.val)) {
793 sprintf(genline, "%s=NA", vname);
794 } else {
795 gretl_push_c_numeric_locale();
796 sprintf(genline, "%s=%g", vname, loop->init.val);
797 gretl_pop_c_numeric_locale();
798 }
799
800 err = generate(genline, dset, GRETL_TYPE_DOUBLE, OPT_Q, NULL);
801
802 if (!err) {
803 /* automatic index variable */
804 strcpy(loop->idxname, vname);
805 loop->idxvar = get_user_var_by_name(vname);
806 loop->flags |= LOOP_DELVAR;
807 }
808 }
809
810 return err;
811 }
812
813 /* for a loop control expression such as "j=start..end", get the
814 initial or final value from the string @s (we also use this to get
815 the count for a simple count loop).
816 */
817
index_get_limit(LOOPSET * loop,controller * clr,const char * s,DATASET * dset)818 static int index_get_limit (LOOPSET *loop, controller *clr,
819 const char *s, DATASET *dset)
820 {
821 int v, err = 0;
822
823 if (integer_string(s)) {
824 /* plain numerical value */
825 clr->val = atoi(s);
826 } else {
827 if (*s == '-') {
828 /* negative of variable? */
829 clr->vsign = -1;
830 s++;
831 }
832 if (gretl_is_scalar(s)) {
833 *clr->vname = '\0';
834 strncat(clr->vname, s, VNAMELEN - 1);
835 clr->val = (int) gretl_scalar_get_value(s, NULL);
836 } else if ((v = current_series_index(dset, s)) >= 0) {
837 /* found a series by the name of @s */
838 gretl_errmsg_sprintf(_("'%s': not a scalar"), s);
839 } else if (loop->parent != NULL && strlen(s) == gretl_namechar_spn(s)) {
840 /* potentially valid varname, but unknown at present */
841 *clr->vname = '\0';
842 strncat(clr->vname, s, VNAMELEN - 1);
843 } else {
844 /* expression to be evaluated to scalar? */
845 clr->expr = gretl_strdup(s);
846 if (clr->expr == NULL) {
847 err = E_ALLOC;
848 }
849 }
850 }
851
852 return err;
853 }
854
855 #define maybe_date(s) (strchr(s, ':') || strchr(s, '/'))
856
parse_as_indexed_loop(LOOPSET * loop,DATASET * dset,const char * lvar,const char * start,const char * end)857 static int parse_as_indexed_loop (LOOPSET *loop,
858 DATASET *dset,
859 const char *lvar,
860 const char *start,
861 const char *end)
862 {
863 int err = 0;
864
865 /* starting and ending values: the order in which we try
866 for valid values is: dates, numeric constants,
867 named scalars, scalar expressions.
868 */
869
870 #if LOOP_DEBUG > 1
871 fprintf(stderr, "parse_as_indexed_loop: start='%s', end='%s'\n", start, end);
872 #endif
873
874 if (maybe_date(start)) {
875 loop->init.val = dateton(start, dset);
876 if (loop->init.val < 0) {
877 err = E_DATA;
878 } else {
879 loop->init.val += 1;
880 loop->final.val = dateton(end, dset);
881 if (loop->final.val < 0) {
882 err = E_DATA;
883 } else {
884 loop->final.val += 1;
885 loop->type = DATED_LOOP;
886 }
887 }
888 } else {
889 err = index_get_limit(loop, &loop->init, start, dset);
890 if (!err) {
891 err = index_get_limit(loop, &loop->final, end, dset);
892 }
893 if (!err) {
894 loop->type = INDEX_LOOP;
895 }
896 }
897
898 if (!err) {
899 err = loop_attach_index_var(loop, lvar, dset);
900 }
901
902 #if LOOP_DEBUG > 1
903 fprintf(stderr, "indexed_loop: init.val=%g, final.val=%g, err=%d\n",
904 loop->init.val, loop->final.val, err);
905 #endif
906
907 return err;
908 }
909
910 /* for example, "loop 100" or "loop K" */
911
parse_as_count_loop(LOOPSET * loop,DATASET * dset,const char * s)912 static int parse_as_count_loop (LOOPSET *loop,
913 DATASET *dset,
914 const char *s)
915 {
916 int err;
917
918 err = index_get_limit(loop, &loop->final, s, dset);
919
920 if (!err) {
921 loop->init.val = 1;
922 loop->type = COUNT_LOOP;
923 }
924
925 #if LOOP_DEBUG > 1
926 fprintf(stderr, "parse_as_count_loop: init.val=%g, final.val=%g\n",
927 loop->init.val, loop->final.val);
928 #endif
929
930 return err;
931 }
932
set_forloop_element(char * s,LOOPSET * loop,int i)933 static int set_forloop_element (char *s, LOOPSET *loop, int i)
934 {
935 controller *clr = (i == 0)? &loop->init :
936 (i == 1)? &loop->test : &loop->delta;
937 int len, err = 0;
938
939 #if LOOP_DEBUG > 1
940 fprintf(stderr, "set_forloop_element: i=%d: '%s'\n", i, s);
941 #endif
942
943 if (s == NULL || *s == '\0') {
944 /* an empty "for" field */
945 if (i == 1) {
946 /* test is implicitly always true */
947 clr->val = 1;
948 } else {
949 /* no-op */
950 clr->val = 0;
951 }
952 return 0;
953 }
954
955 clr->expr = gretl_strdup(s);
956 if (clr->expr == NULL) {
957 err = E_ALLOC;
958 }
959
960 if (!err && i == 0) {
961 /* initialization: look for varname for possible substitution */
962 err = extract_varname(clr->vname, s, &len);
963 }
964
965 #if LOOP_DEBUG > 1
966 fprintf(stderr, " expr='%s', vname='%s'\n", clr->expr, clr->vname);
967 #endif
968
969 return err;
970 }
971
allocate_each_strings(LOOPSET * loop,int n)972 static int allocate_each_strings (LOOPSET *loop, int n)
973 {
974 loop->eachstrs = strings_array_new(n);
975
976 return (loop->eachstrs == NULL)? E_ALLOC : 0;
977 }
978
list_vars_to_strings(LOOPSET * loop,const int * list,const DATASET * dset)979 static int list_vars_to_strings (LOOPSET *loop, const int *list,
980 const DATASET *dset)
981 {
982 int i, vi;
983 int err;
984
985 #if LOOP_DEBUG > 1
986 fprintf(stderr, "list_vars_to_strings: adding %d strings\n", list[0]);
987 #endif
988
989 err = allocate_each_strings(loop, list[0]);
990
991 for (i=0; i<list[0] && !err; i++) {
992 vi = list[i+1];
993 if (vi < 0 || vi >= dset->v) {
994 err = E_DATA;
995 } else {
996 loop->eachstrs[i] = gretl_strdup(dset->varname[vi]);
997 if (loop->eachstrs[i] == NULL) {
998 err = E_ALLOC;
999 }
1000 }
1001 }
1002
1003 return err;
1004 }
1005
get_eachvar_by_name(const char * s,GretlType * t)1006 static void *get_eachvar_by_name (const char *s, GretlType *t)
1007 {
1008 void *ptr = NULL;
1009
1010 if (*t == GRETL_TYPE_LIST) {
1011 ptr = get_list_by_name(s);
1012 } else if (*t == GRETL_TYPE_STRINGS) {
1013 ptr = get_strings_array_by_name(s);
1014 } else if (*t == GRETL_TYPE_BUNDLE) {
1015 ptr = get_bundle_by_name(s);
1016 } else {
1017 /* type not yet determined */
1018 if ((ptr = get_list_by_name(s)) != NULL) {
1019 *t = GRETL_TYPE_LIST;
1020 } else if ((ptr = get_strings_array_by_name(s)) != NULL) {
1021 *t = GRETL_TYPE_STRINGS;
1022 } else if ((ptr = get_bundle_by_name(s)) != NULL) {
1023 *t = GRETL_TYPE_BUNDLE;
1024 }
1025 }
1026
1027 return ptr;
1028 }
1029
1030 /* At loop runtime, check the named list and insert the names (or
1031 numbers) of the variables as "eachstrs"; flag an error if the list
1032 has disappeared. We also have to handle the case where the name
1033 of the loop-controlling list is subject to $-substitution.
1034 */
1035
loop_list_refresh(LOOPSET * loop,const DATASET * dset)1036 static int loop_list_refresh (LOOPSET *loop, const DATASET *dset)
1037 {
1038 void *eachvar = NULL;
1039 const char *strval = NULL;
1040 int err = 0;
1041
1042 if (strchr(loop->eachname, '$') != NULL) {
1043 /* $-string substitution required */
1044 char vname[VNAMELEN];
1045
1046 strcpy(vname, loop->eachname);
1047 err = make_dollar_substitutions(vname, VNAMELEN, loop,
1048 dset, NULL, OPT_T);
1049 if (!err) {
1050 eachvar = get_eachvar_by_name(vname, &loop->eachtype);
1051 }
1052 } else if (*loop->eachname == '@') {
1053 /* @-string substitution required */
1054 strval = get_string_by_name(loop->eachname + 1);
1055 if (strval != NULL && strlen(strval) < VNAMELEN) {
1056 eachvar = get_eachvar_by_name(strval, &loop->eachtype);
1057 }
1058 } else {
1059 /* no string substitution needed */
1060 eachvar = get_eachvar_by_name(loop->eachname, &loop->eachtype);
1061 }
1062
1063 /* note: if @eachvar is an array of strings then loop->eachstrs
1064 will be borrowed data and should not be freed!
1065 */
1066 if (loop->eachstrs != NULL) {
1067 if (loop->eachtype != GRETL_TYPE_STRINGS) {
1068 strings_array_free(loop->eachstrs, loop->itermax);
1069 }
1070 loop->eachstrs = NULL;
1071 }
1072
1073 loop->itermax = loop->final.val = 0;
1074
1075 if (loop->eachtype != GRETL_TYPE_NONE && eachvar == NULL) {
1076 /* foreach variable has disappeared? */
1077 err = E_DATA;
1078 } else if (loop->eachtype == GRETL_TYPE_LIST) {
1079 int *list = eachvar;
1080
1081 if (list[0] > 0) {
1082 err = list_vars_to_strings(loop, list, dset);
1083 if (!err) {
1084 loop->final.val = list[0];
1085 }
1086 }
1087 } else if (loop->eachtype == GRETL_TYPE_STRINGS) {
1088 gretl_array *a = eachvar;
1089 int n = gretl_array_get_length(a);
1090
1091 if (n > 0) {
1092 loop->eachstrs = gretl_array_get_strings(a, &n);
1093 loop->final.val = n;
1094 }
1095 } else if (loop->eachtype == GRETL_TYPE_BUNDLE) {
1096 gretl_bundle *b = eachvar;
1097 int n = gretl_bundle_get_n_keys(b);
1098
1099 if (n > 0) {
1100 loop->eachstrs = gretl_bundle_get_keys_raw(b, &n);
1101 loop->final.val = n;
1102 }
1103 } else if (!err) {
1104 /* FIXME do/should we ever come here? */
1105 if (strval != NULL) {
1106 /* maybe space separated strings? */
1107 int nf = 0;
1108
1109 loop->eachstrs = gretl_string_split_quoted(strval, &nf, NULL, &err);
1110 if (!err) {
1111 loop->final.val = nf;
1112 }
1113 } else {
1114 err = E_UNKVAR;
1115 }
1116 }
1117
1118 return err;
1119 }
1120
find_target_in_parentage(LOOPSET * loop,const char * s)1121 static GretlType find_target_in_parentage (LOOPSET *loop,
1122 const char *s)
1123 {
1124 char lfmt[16], afmt[18], vname[VNAMELEN];
1125 int i;
1126
1127 sprintf(lfmt, "list %%%d[^ =]", VNAMELEN-1);
1128 sprintf(afmt, "strings %%%d[^ =]", VNAMELEN-1);
1129
1130 while ((loop = loop->parent) != NULL) {
1131 for (i=0; i<loop->n_cmds; i++) {
1132 if (sscanf(loop->cmds[i].line, lfmt, vname)) {
1133 if (!strcmp(vname, s)) {
1134 return GRETL_TYPE_LIST;
1135 }
1136 } else if (sscanf(loop->cmds[i].line, afmt, vname)) {
1137 if (!strcmp(vname, s)) {
1138 return GRETL_TYPE_STRINGS;
1139 }
1140 }
1141 }
1142 }
1143
1144 return GRETL_TYPE_NONE;
1145 }
1146
1147 /* We're looking at a "foreach" loop with just one field after the
1148 index variable, so it's most likely a loop over a list or array.
1149
1150 We begin by looking for a currently existing named list, but if
1151 this fails we don't give up immediately. If we're working on an
1152 embedded loop, the list may be created within a parent loop whose
1153 commands have not yet been executed, so we search upward among the
1154 ancestors of this loop (if any) for a relevant list-creation
1155 command.
1156
1157 Even if we find an already-existing list, we do not yet fill out
1158 the variable-name (or variable-number) strings: these will be set
1159 when the loop is actually run, since the list may have changed in
1160 the meantime.
1161
1162 Besides the possibilities mentioned above, the single field
1163 may be an @-string that cashes out into one or more "words".
1164 */
1165
list_loop_setup(LOOPSET * loop,char * s,int * nf,int * idxmax)1166 static int list_loop_setup (LOOPSET *loop, char *s, int *nf,
1167 int *idxmax)
1168 {
1169 GretlType t = 0;
1170 gretl_array *a = NULL;
1171 gretl_bundle *b = NULL;
1172 int *list = NULL;
1173 int len = 0;
1174 int err = 0;
1175
1176 while (isspace(*s)) s++;
1177 tailstrip(s);
1178
1179 if (*s == '@') {
1180 /* tricksy: got a list-name that needs string subst? */
1181 *loop->eachname = '\0';
1182 strncat(loop->eachname, s, VNAMELEN - 1);
1183 *nf = 0;
1184 return 0;
1185 }
1186
1187 #if LOOP_DEBUG > 1
1188 fprintf(stderr, "list_loop_setup: s = '%s'\n", s);
1189 #endif
1190
1191 if ((list = get_list_by_name(s)) != NULL) {
1192 t = GRETL_TYPE_LIST;
1193 len = list[0];
1194 } else if ((a = get_array_by_name(s)) != NULL) {
1195 t = gretl_array_get_type(a);
1196 len = gretl_array_get_length(a);
1197 if (t != GRETL_TYPE_STRINGS) {
1198 *idxmax = len;
1199 return 0;
1200 }
1201 } else if ((b = get_bundle_by_name(s)) != NULL) {
1202 t = GRETL_TYPE_BUNDLE;
1203 len = gretl_bundle_get_n_keys(b);
1204 } else {
1205 t = find_target_in_parentage(loop, s);
1206 }
1207
1208 if (t == GRETL_TYPE_NONE) {
1209 err = E_UNKVAR;
1210 } else {
1211 loop->eachtype = t;
1212 *loop->eachname = '\0';
1213 strncat(loop->eachname, s, VNAMELEN - 1);
1214 *nf = len;
1215 }
1216
1217 return err;
1218 }
1219
1220 enum {
1221 DOTTED_LIST,
1222 WILDCARD_LIST
1223 };
1224
1225 static int
each_strings_from_list_of_vars(LOOPSET * loop,const DATASET * dset,char * s,int * pnf,int type)1226 each_strings_from_list_of_vars (LOOPSET *loop, const DATASET *dset,
1227 char *s, int *pnf, int type)
1228 {
1229 int *list = NULL;
1230 int err = 0;
1231
1232 if (type == WILDCARD_LIST) {
1233 s += strspn(s, " \t");
1234 list = varname_match_list(dset, s, &err);
1235 } else {
1236 char vn1[VNAMELEN], vn2[VNAMELEN];
1237 char fmt[16];
1238
1239 gretl_delchar(' ', s);
1240 sprintf(fmt, "%%%d[^.]..%%%ds", VNAMELEN-1, VNAMELEN-1);
1241
1242 if (sscanf(s, fmt, vn1, vn2) != 2) {
1243 err = E_PARSE;
1244 } else {
1245 int v1 = current_series_index(dset, vn1);
1246 int v2 = current_series_index(dset, vn2);
1247
1248 if (v1 < 0 || v2 < 0) {
1249 err = E_UNKVAR;
1250 } else if (v2 - v1 + 1 <= 0) {
1251 err = E_DATA;
1252 } else {
1253 list = gretl_consecutive_list_new(v1, v2);
1254 if (list == NULL) {
1255 err = E_ALLOC;
1256 }
1257 }
1258 }
1259 if (err) {
1260 *pnf = 0;
1261 }
1262 }
1263
1264 if (list != NULL) {
1265 int i, vi;
1266
1267 err = allocate_each_strings(loop, list[0]);
1268 if (!err) {
1269 for (i=1; i<=list[0] && !err; i++) {
1270 vi = list[i];
1271 loop->eachstrs[i-1] = gretl_strdup(dset->varname[vi]);
1272 if (loop->eachstrs[i-1] == NULL) {
1273 strings_array_free(loop->eachstrs, list[0]);
1274 loop->eachstrs = NULL;
1275 err = E_ALLOC;
1276 }
1277 }
1278 }
1279 if (!err) {
1280 *pnf = list[0];
1281 }
1282 free(list);
1283 }
1284
1285 return err;
1286 }
1287
1288 /* in context of "foreach" loop, split a string variable by
1289 both spaces and newlines */
1290
count_each_fields(const char * s)1291 static int count_each_fields (const char *s)
1292 {
1293 int nf = 0;
1294
1295 if (s != NULL && *s != '\0') {
1296 const char *p;
1297
1298 s += strspn(s, " ");
1299
1300 if (*s != '\0' && *s != '\n') {
1301 s++;
1302 nf++;
1303 }
1304
1305 while (*s) {
1306 p = strpbrk(s, " \n");
1307 if (p != NULL) {
1308 s = p + strspn(p, " \n");
1309 if (*s) {
1310 nf++;
1311 }
1312 } else {
1313 break;
1314 }
1315 }
1316 }
1317
1318 return nf;
1319 }
1320
1321 /* Implement "foreach" for arrays other than strings:
1322 convert to index loop with automatic max value set
1323 to the length of the array.
1324 */
1325
set_alt_each_loop(LOOPSET * loop,DATASET * dset,const char * ivar,int len)1326 static int set_alt_each_loop (LOOPSET *loop, DATASET *dset,
1327 const char *ivar, int len)
1328 {
1329 loop->type = INDEX_LOOP;
1330 loop->init.val = 1;
1331 loop->final.val = len;
1332 return loop_attach_index_var(loop, ivar, dset);
1333 }
1334
1335 static int
parse_as_each_loop(LOOPSET * loop,DATASET * dset,char * s)1336 parse_as_each_loop (LOOPSET *loop, DATASET *dset, char *s)
1337 {
1338 char ivar[VNAMELEN] = {0};
1339 int done = 0;
1340 int nf, err = 0;
1341
1342 /* we're looking at the string that follows "loop foreach" */
1343 if (*s == '\0') {
1344 return E_PARSE;
1345 }
1346
1347 s += strspn(s, " "); /* skip any spaces */
1348
1349 #if LOOP_DEBUG > 1
1350 fprintf(stderr, "parse_as_each_loop: s = '%s'\n", s);
1351 #endif
1352
1353 /* get the index variable name (as in "foreach i") */
1354 if (gretl_scan_varname(s, ivar) != 1) {
1355 return E_PARSE;
1356 }
1357
1358 s += strlen(ivar);
1359 nf = count_each_fields(s);
1360
1361 #if LOOP_DEBUG > 1
1362 fprintf(stderr, " number of fields = %d\n", nf);
1363 #endif
1364
1365 if (nf == 0) {
1366 return E_PARSE;
1367 }
1368
1369 if (nf <= 3 && strstr(s, "..") != NULL) {
1370 /* range of values, foo..quux */
1371 err = each_strings_from_list_of_vars(loop, dset, s, &nf,
1372 DOTTED_LIST);
1373 done = 1;
1374 } else if (nf == 1 && strchr(s, '*')) {
1375 err = each_strings_from_list_of_vars(loop, dset, s, &nf,
1376 WILDCARD_LIST);
1377 done = (err == 0);
1378 }
1379
1380 if (!done && nf == 1) {
1381 /* try for a named list or array? */
1382 int nelem = -1;
1383
1384 err = list_loop_setup(loop, s, &nf, &nelem);
1385 if (!err && nelem >= 0) {
1386 /* got an array, but not of strings */
1387 return set_alt_each_loop(loop, dset, ivar, nelem);
1388 }
1389 done = (err == 0);
1390 }
1391
1392 if (!done) {
1393 /* simple array of strings: allow for quoted substrings */
1394 loop->eachstrs = gretl_string_split_quoted(s, &nf, NULL, &err);
1395 }
1396
1397 if (!err) {
1398 loop->type = EACH_LOOP;
1399 loop->init.val = 1;
1400 loop->final.val = nf;
1401 loop->itermax = nf;
1402 err = loop_attach_index_var(loop, ivar, dset);
1403 }
1404
1405 #if LOOP_DEBUG > 1
1406 fprintf(stderr, "parse_as_each_loop: final.val=%g\n", loop->final.val);
1407 #endif
1408
1409 return err;
1410 }
1411
1412 /* try to parse out (expr1; expr2; expr3) */
1413
parse_as_for_loop(LOOPSET * loop,char * s)1414 static int parse_as_for_loop (LOOPSET *loop, char *s)
1415 {
1416 char *tmp, *q;
1417 int i, j, len;
1418 int sc = 0;
1419 int err = 0;
1420
1421 s += strcspn(s, "(");
1422 if (*s != '(') {
1423 return E_PARSE;
1424 }
1425
1426 s++;
1427 q = strrchr(s, ')');
1428 if (q == NULL) {
1429 return E_PARSE;
1430 }
1431
1432 len = q - s;
1433 if (len < 2) { /* minimal OK string is ";;" */
1434 return E_PARSE;
1435 }
1436
1437 tmp = malloc(len + 1);
1438 if (tmp == NULL) {
1439 return E_ALLOC;
1440 }
1441
1442 for (j=0; j<3 && s!=q && !err; j++) {
1443 /* make a compressed copy of field j */
1444 i = 0;
1445 while (s != q) {
1446 if (*s == ';') {
1447 sc++;
1448 s++;
1449 break; /* onto next field */
1450 }
1451 if (*s != ' ') {
1452 tmp[i++] = *s;
1453 }
1454 s++;
1455 }
1456 tmp[i] = '\0';
1457 err = set_forloop_element(tmp, loop, j);
1458 }
1459
1460 if (!err && (sc != 2 || s != q)) {
1461 /* we've reached the reached rightmost ')' but have not
1462 found two semi-colons */
1463 err = E_PARSE;
1464 }
1465
1466 free(tmp);
1467
1468 if (!err) {
1469 loop->type = FOR_LOOP;
1470 }
1471
1472 return err;
1473 }
1474
is_indexed_loop(const char * s,char * lvar,char ** start,char ** stop)1475 static int is_indexed_loop (const char *s,
1476 char *lvar,
1477 char **start,
1478 char **stop)
1479 {
1480 int n;
1481
1482 /* must conform to the pattern
1483
1484 lvar = start..stop
1485
1486 where @start and/or @stop may be compound terms,
1487 with or without whitespace between terms
1488 */
1489
1490 s += strspn(s, " ");
1491 n = gretl_namechar_spn(s);
1492
1493 if (n > 0 && n < VNAMELEN) {
1494 const char *s0 = s;
1495 const char *p = strstr(s, "..");
1496
1497 if (p != NULL) {
1498 s += n;
1499 s += strspn(s, " ");
1500 if (*s == '=' && *(s+1) != '=') {
1501 *lvar = '\0';
1502 strncat(lvar, s0, n);
1503 /* skip any space after '=' */
1504 s++;
1505 s += strspn(s, " ");
1506 *start = gretl_strndup(s, p - s);
1507 g_strchomp(*start);
1508 /* skip ".. " */
1509 p += 2;
1510 p += strspn(p, " ");
1511 *stop = gretl_strdup(p);
1512 g_strchomp(*stop);
1513 return 1;
1514 }
1515 }
1516 }
1517
1518 return 0;
1519 }
1520
parse_first_loopline(char * s,LOOPSET * loop,DATASET * dset)1521 static int parse_first_loopline (char *s, LOOPSET *loop,
1522 DATASET *dset)
1523 {
1524 char vname[VNAMELEN];
1525 char *start = NULL;
1526 char *stop = NULL;
1527 int err = 0;
1528
1529 /* skip preliminary string */
1530 while (isspace(*s)) s++;
1531 if (!strncmp(s, "loop", 4)) {
1532 s += 4;
1533 while (isspace(*s)) s++;
1534 }
1535
1536 /* syntactic slop: accept "for i=lo..hi" -> "i=lo..hi" */
1537 if (!strncmp(s, "for ", 4) && !strchr(s, ';')) {
1538 s += 4;
1539 }
1540
1541 #if LOOP_DEBUG > 1
1542 fprintf(stderr, "parse_first_loopline: '%s'\n", s);
1543 #endif
1544
1545 if (!strncmp(s, "foreach ", 8)) {
1546 err = parse_as_each_loop(loop, dset, s + 8);
1547 } else if (!strncmp(s, "for ", 4)) {
1548 err = parse_as_for_loop(loop, s + 4);
1549 } else if (!strncmp(s, "while ", 6)) {
1550 err = parse_as_while_loop(loop, s + 6);
1551 } else if (is_indexed_loop(s, vname, &start, &stop)) {
1552 err = parse_as_indexed_loop(loop, dset, vname, start, stop);
1553 free(start);
1554 free(stop);
1555 } else {
1556 /* must be a count loop, or erroneous */
1557 err = parse_as_count_loop(loop, dset, s);
1558 }
1559
1560 #if LOOP_DEBUG > 1
1561 fprintf(stderr, "parse_first_loopline: returning %d\n", err);
1562 #endif
1563
1564 return err;
1565 }
1566
1567 /**
1568 * start_new_loop:
1569 * @s: loop specification line.
1570 * @inloop: current loop struct pointer, or %NULL.
1571 * @dset: dataset struct.
1572 * @opt: options associated with new loop.
1573 * @nested: location to receive info on whether a new
1574 * loop was created, nested within the input loop.
1575 * @err: location to receive error code.
1576 *
1577 * Create a new LOOPSET based on the input line; this may or
1578 * may not be a child of @inloop.
1579 *
1580 * Returns: loop pointer on successful completion, %NULL on error.
1581 */
1582
start_new_loop(char * s,LOOPSET * inloop,DATASET * dset,gretlopt opt,int * nested,int * err)1583 static LOOPSET *start_new_loop (char *s, LOOPSET *inloop,
1584 DATASET *dset,
1585 gretlopt opt,
1586 int *nested,
1587 int *err)
1588 {
1589 LOOPSET *loop = NULL;
1590
1591 gretl_error_clear();
1592
1593 #if LOOP_DEBUG
1594 fprintf(stderr, "start_new_loop: inloop=%p, line='%s'\n",
1595 (void *) inloop, s);
1596 #endif
1597
1598 if (inloop == NULL || compile_level <= inloop->level) {
1599 loop = gretl_loop_new(NULL);
1600 } else {
1601 loop = gretl_loop_new(inloop);
1602 *nested = 1;
1603 }
1604
1605 if (loop == NULL) {
1606 gretl_errmsg_set(_("Out of memory!"));
1607 *err = E_ALLOC;
1608 return NULL;
1609 }
1610
1611 #if LOOP_DEBUG
1612 fprintf(stderr, " added loop at %p (%s)\n", (void *) loop,
1613 (*nested)? "nested" : "independent");
1614 #endif
1615
1616 *err = parse_first_loopline(s, loop, dset);
1617
1618 if (!*err) {
1619 *err = gretl_loop_prepare(loop);
1620 }
1621
1622 if (*err) {
1623 #if LOOP_DEBUG
1624 fprintf(stderr, "start_new_loop: aborting on error\n");
1625 #endif
1626 destroy_loop_stack(loop);
1627 loop = NULL;
1628 }
1629
1630 return loop;
1631 }
1632
1633 #if LOOP_DEBUG
1634 # define MAX_FOR_TIMES 10
1635 #else
1636 # define MAX_FOR_TIMES 50000000
1637 #endif
1638
loop_count_too_high(LOOPSET * loop)1639 static int loop_count_too_high (LOOPSET *loop)
1640 {
1641 int nt = loop->iter + 1;
1642
1643 if (loop->type == FOR_LOOP) {
1644 if (nt > MAX_FOR_TIMES) {
1645 gretl_errmsg_sprintf(_("Reached maximum iterations, %d"),
1646 MAX_FOR_TIMES);
1647 loop->err = 1;
1648 }
1649 } else {
1650 int maxit = libset_get_int(LOOP_MAXITER);
1651
1652 if (nt > maxit) {
1653 gretl_errmsg_sprintf(_("Reached maximum iterations, %d"),
1654 maxit);
1655 gretl_errmsg_append(_("You can use \"set loop_maxiter\" "
1656 "to increase the limit"), 0);
1657 loop->err = 1;
1658 }
1659 }
1660
1661 return loop->err;
1662 }
1663
1664 /**
1665 * loop_condition:
1666 * @loop: pointer to loop commands struct.
1667 * @dset: data information struct.
1668 * @err: location to receive error code.
1669 *
1670 * Check whether a loop continuation condition is still satisfied.
1671 *
1672 * Returns: 1 to indicate looping should continue, 0 to terminate.
1673 */
1674
loop_condition(LOOPSET * loop,DATASET * dset,int * err)1675 static int loop_condition (LOOPSET *loop, DATASET *dset, int *err)
1676 {
1677 int ok = 0;
1678
1679 if (loop->brk) {
1680 /* got "break" comand */
1681 loop->brk = 0;
1682 ok = 0;
1683 } else if (loop->type == COUNT_LOOP || indexed_loop(loop)) {
1684 if (loop->iter < loop->itermax) {
1685 ok = 1;
1686 if (indexed_loop(loop) && loop->iter > 0) {
1687 loop->idxval += 1;
1688 uvar_set_scalar_fast(loop->idxvar, loop->idxval);
1689 }
1690 }
1691 } else if (!loop_count_too_high(loop)) {
1692 /* more complex forms of control (for, while) */
1693 if (loop->type == FOR_LOOP) {
1694 if (loop->iter > 0) {
1695 loop_delta(loop, dset, err);
1696 }
1697 ok = loop_testval(loop, dset, err);
1698 } else if (loop->type == WHILE_LOOP) {
1699 ok = loop_testval(loop, dset, err);
1700 }
1701 }
1702
1703 return ok;
1704 }
1705
controller_init(controller * clr)1706 static void controller_init (controller *clr)
1707 {
1708 clr->val = NADBL;
1709 clr->vname[0] = '\0';
1710 clr->uv = NULL;
1711 clr->vsign = 1;
1712 clr->expr = NULL;
1713 clr->genr = NULL;
1714 clr->subst = -1;
1715 }
1716
controller_free(controller * clr)1717 static void controller_free (controller *clr)
1718 {
1719 if (clr->expr != NULL) {
1720 free(clr->expr);
1721 clr->expr = NULL;
1722 }
1723 if (clr->genr != NULL) {
1724 destroy_genr(clr->genr);
1725 clr->genr = NULL;
1726 }
1727 }
1728
loop_cmds_init(LOOPSET * loop,int i1,int i2)1729 static void loop_cmds_init (LOOPSET *loop, int i1, int i2)
1730 {
1731 int i;
1732
1733 for (i=i1; i<i2; i++) {
1734 loop->cmds[i].line = NULL;
1735 loop->cmds[i].ci = 0;
1736 loop->cmds[i].opt = 0;
1737 loop->cmds[i].genr = NULL;
1738 loop->cmds[i].flags = 0;
1739 }
1740 }
1741
gretl_loop_prepare(LOOPSET * loop)1742 static int gretl_loop_prepare (LOOPSET *loop)
1743 {
1744 #if HAVE_GMP
1745 mpf_set_default_prec(256);
1746 #endif
1747
1748 /* allocate some initial lines/commands for loop */
1749 loop->cmds = malloc(LOOP_BLOCK * sizeof *loop->cmds);
1750
1751 if (loop->cmds == NULL) {
1752 return E_ALLOC;
1753 } else {
1754 loop_cmds_init(loop, 0, LOOP_BLOCK);
1755 }
1756
1757 return 0;
1758 }
1759
1760 #if HAVE_GMP
1761
loop_model_free(LOOP_MODEL * lmod)1762 static void loop_model_free (LOOP_MODEL *lmod)
1763 {
1764 int i, n;
1765
1766 #if LOOP_DEBUG > 1
1767 fprintf(stderr, "loop_model_free: lmod at %p, model0 at %p\n",
1768 (void *) lmod, (void *) lmod->model0);
1769 #endif
1770
1771 n = 4 * lmod->model0->ncoeff;
1772
1773 for (i=0; i<n; i++) {
1774 mpf_clear(lmod->bigarray[i]);
1775 }
1776
1777 free(lmod->bigarray);
1778 free(lmod->cbak);
1779 free(lmod->cdiff);
1780
1781 gretl_model_free(lmod->model0);
1782 }
1783
1784 /* Reset the loop model */
1785
loop_model_zero(LOOP_MODEL * lmod,int started)1786 static void loop_model_zero (LOOP_MODEL *lmod, int started)
1787 {
1788 int i, bnc = 4 * lmod->nc;
1789
1790 #if LOOP_DEBUG > 1
1791 fprintf(stderr, "loop_model_zero: %p\n", (void *) lmod);
1792 #endif
1793
1794 for (i=0; i<bnc; i++) {
1795 if (started) {
1796 mpf_set_d(lmod->bigarray[i], 0.0);
1797 } else {
1798 mpf_init(lmod->bigarray[i]);
1799 }
1800 }
1801
1802 for (i=0; i<lmod->nc; i++) {
1803 lmod->cbak[i] = lmod->sbak[i] = NADBL;
1804 lmod->cdiff[i] = lmod->sdiff[i] = 0;
1805 }
1806
1807 lmod->n = 0;
1808 }
1809
1810 /* Set everything in lmod to 0/null in case of failure */
1811
loop_model_init(LOOP_MODEL * lmod,int lno)1812 static void loop_model_init (LOOP_MODEL *lmod, int lno)
1813 {
1814 lmod->lineno = lno;
1815 lmod->nc = 0;
1816 lmod->model0 = NULL;
1817 lmod->bigarray = NULL;
1818 lmod->cbak = NULL;
1819 lmod->cdiff = NULL;
1820 }
1821
1822 /* Start up a LOOP_MODEL struct: copy @pmod into place and
1823 allocate storage */
1824
loop_model_start(LOOP_MODEL * lmod,MODEL * pmod)1825 static int loop_model_start (LOOP_MODEL *lmod, MODEL *pmod)
1826 {
1827 int nc = pmod->ncoeff;
1828 int err = 0;
1829
1830 #if LOOP_DEBUG > 1
1831 fprintf(stderr, "init: copying model at %p\n", (void *) pmod);
1832 #endif
1833
1834 lmod->model0 = gretl_model_copy(pmod);
1835 if (lmod->model0 == NULL) {
1836 return E_ALLOC;
1837 }
1838
1839 lmod->nc = nc;
1840
1841 lmod->bigarray = malloc(nc * 4 * sizeof *lmod->bigarray);
1842 if (lmod->bigarray == NULL) {
1843 return E_ALLOC;
1844 }
1845
1846 lmod->sum_coeff = lmod->bigarray;
1847 lmod->ssq_coeff = lmod->sum_coeff + nc;
1848 lmod->sum_sderr = lmod->ssq_coeff + nc;
1849 lmod->ssq_sderr = lmod->sum_sderr + nc;
1850
1851 lmod->cbak = malloc(nc * 2 * sizeof *lmod->cbak);
1852 if (lmod->cbak == NULL) {
1853 err = E_ALLOC;
1854 } else {
1855 lmod->sbak = lmod->cbak + nc;
1856 }
1857
1858 if (!err) {
1859 lmod->cdiff = malloc(nc * 2 * sizeof *lmod->cdiff);
1860 if (lmod->cdiff == NULL) {
1861 err = E_ALLOC;
1862 } else {
1863 lmod->sdiff = lmod->cdiff + nc;
1864 }
1865 }
1866
1867 if (!err) {
1868 loop_model_zero(lmod, 0);
1869 #if LOOP_DEBUG > 1
1870 fprintf(stderr, " model copied to %p, returning 0\n",
1871 (void *) lmod->model0);
1872 #endif
1873 }
1874
1875 if (err) {
1876 free(lmod->bigarray);
1877 free(lmod->cbak);
1878 free(lmod->cdiff);
1879 }
1880
1881 return err;
1882 }
1883
loop_print_free(LOOP_PRINT * lprn)1884 static void loop_print_free (LOOP_PRINT *lprn)
1885 {
1886 int i;
1887
1888 for (i=0; i<lprn->nvars; i++) {
1889 mpf_clear(lprn->sum[i]);
1890 mpf_clear(lprn->ssq[i]);
1891 }
1892
1893 strings_array_free(lprn->names, lprn->nvars);
1894
1895 free(lprn->sum);
1896 free(lprn->ssq);
1897 free(lprn->xbak);
1898 free(lprn->diff);
1899 free(lprn->na);
1900 }
1901
loop_print_zero(LOOP_PRINT * lprn,int started)1902 static void loop_print_zero (LOOP_PRINT *lprn, int started)
1903 {
1904 int i;
1905
1906 lprn->n = 0;
1907
1908 for (i=0; i<lprn->nvars; i++) {
1909 if (started) {
1910 mpf_set_d(lprn->sum[i], 0.0);
1911 mpf_set_d(lprn->ssq[i], 0.0);
1912 } else {
1913 mpf_init(lprn->sum[i]);
1914 mpf_init(lprn->ssq[i]);
1915 }
1916 lprn->xbak[i] = NADBL;
1917 lprn->diff[i] = 0;
1918 lprn->na[i] = 0;
1919 }
1920 }
1921
1922 /* allocate and initialize @lprn, based on the number of
1923 elements in @namestr */
1924
loop_print_start(LOOP_PRINT * lprn,const char * namestr)1925 static int loop_print_start (LOOP_PRINT *lprn, const char *namestr)
1926 {
1927 int i, nv;
1928
1929 if (namestr == NULL || *namestr == '\0') {
1930 gretl_errmsg_set("'print' list is empty");
1931 return E_DATA;
1932 }
1933
1934 lprn->names = gretl_string_split(namestr, &lprn->nvars, NULL);
1935 if (lprn->names == NULL) {
1936 return E_ALLOC;
1937 }
1938
1939 nv = lprn->nvars;
1940
1941 for (i=0; i<nv; i++) {
1942 if (!gretl_is_scalar(lprn->names[i])) {
1943 gretl_errmsg_sprintf(_("'%s': not a scalar"), lprn->names[i]);
1944 strings_array_free(lprn->names, lprn->nvars);
1945 lprn->names = NULL;
1946 lprn->nvars = 0;
1947 return E_DATA;
1948 }
1949 }
1950
1951 lprn->sum = malloc(nv * sizeof *lprn->sum);
1952 if (lprn->sum == NULL) goto cleanup;
1953
1954 lprn->ssq = malloc(nv * sizeof *lprn->ssq);
1955 if (lprn->ssq == NULL) goto cleanup;
1956
1957 lprn->xbak = malloc(nv * sizeof *lprn->xbak);
1958 if (lprn->xbak == NULL) goto cleanup;
1959
1960 lprn->diff = malloc(nv * sizeof *lprn->diff);
1961 if (lprn->diff == NULL) goto cleanup;
1962
1963 lprn->na = malloc(nv);
1964 if (lprn->na == NULL) goto cleanup;
1965
1966 loop_print_zero(lprn, 0);
1967
1968 return 0;
1969
1970 cleanup:
1971
1972 strings_array_free(lprn->names, lprn->nvars);
1973 lprn->names = NULL;
1974 lprn->nvars = 0;
1975
1976 free(lprn->sum);
1977 free(lprn->ssq);
1978 free(lprn->xbak);
1979 free(lprn->diff);
1980 free(lprn->na);
1981
1982 lprn->sum = NULL;
1983 lprn->ssq = NULL;
1984 lprn->xbak = NULL;
1985 lprn->diff = NULL;
1986 lprn->na = NULL;
1987
1988 return E_ALLOC;
1989 }
1990
loop_print_init(LOOP_PRINT * lprn,int lno)1991 static void loop_print_init (LOOP_PRINT *lprn, int lno)
1992 {
1993 lprn->lineno = lno;
1994 lprn->nvars = 0;
1995 lprn->names = NULL;
1996 lprn->sum = NULL;
1997 lprn->ssq = NULL;
1998 lprn->xbak = NULL;
1999 lprn->diff = NULL;
2000 lprn->na = NULL;
2001 }
2002
get_loop_print_by_line(LOOPSET * loop,int lno,int * err)2003 static LOOP_PRINT *get_loop_print_by_line (LOOPSET *loop, int lno, int *err)
2004 {
2005 LOOP_PRINT *prns;
2006 int i, np = loop->n_prints;
2007
2008 for (i=0; i<np; i++) {
2009 if (loop->prns[i].lineno == lno) {
2010 return &loop->prns[i];
2011 }
2012 }
2013
2014 prns = realloc(loop->prns, (np + 1) * sizeof *prns);
2015 if (prns == NULL) {
2016 *err = E_ALLOC;
2017 return NULL;
2018 } else {
2019 loop->prns = prns;
2020 }
2021
2022 loop_print_init(&loop->prns[np], lno);
2023 loop->n_prints += 1;
2024
2025 return &loop->prns[np];
2026 }
2027
loop_store_free(LOOP_STORE * lstore)2028 static void loop_store_free (LOOP_STORE *lstore)
2029 {
2030 destroy_dataset(lstore->dset);
2031 lstore->dset = NULL;
2032
2033 strings_array_free(lstore->names, lstore->nvars);
2034 lstore->nvars = 0;
2035 lstore->names = NULL;
2036
2037 free(lstore->fname);
2038 lstore->fname = NULL;
2039
2040 lstore->lineno = -1;
2041 lstore->n = 0;
2042 lstore->opt = OPT_NONE;
2043 }
2044
loop_store_set_filename(LOOP_STORE * lstore,const char * fname,gretlopt opt)2045 static int loop_store_set_filename (LOOP_STORE *lstore,
2046 const char *fname,
2047 gretlopt opt)
2048 {
2049 if (fname == NULL || *fname == '\0') {
2050 return E_ARGS;
2051 }
2052
2053 lstore->fname = gretl_strdup(fname);
2054 if (lstore->fname == NULL) {
2055 return E_ALLOC;
2056 }
2057
2058 lstore->opt = opt;
2059
2060 return 0;
2061 }
2062
loop_store_init(LOOP_STORE * lstore)2063 static void loop_store_init (LOOP_STORE *lstore)
2064 {
2065 lstore->lineno = -1;
2066 lstore->n = 0;
2067 lstore->nvars = 0;
2068 lstore->names = NULL;
2069 lstore->fname = NULL;
2070 lstore->opt = OPT_NONE;
2071 lstore->dset = NULL;
2072 }
2073
2074 /* check, allocate and initialize loop data storage */
2075
loop_store_start(LOOPSET * loop,const char * names,const char * fname,gretlopt opt)2076 static int loop_store_start (LOOPSET *loop, const char *names,
2077 const char *fname, gretlopt opt)
2078 {
2079 LOOP_STORE *lstore = &loop->store;
2080 int i, n, err = 0;
2081
2082 if (names == NULL || *names == '\0') {
2083 gretl_errmsg_set("'store' list is empty");
2084 return E_DATA;
2085 }
2086
2087 lstore->names = gretl_string_split(names, &lstore->nvars, NULL);
2088 if (lstore->names == NULL) {
2089 return E_ALLOC;
2090 }
2091
2092 err = loop_store_set_filename(lstore, fname, opt);
2093 if (err) {
2094 return err;
2095 }
2096
2097 n = (loop->itermax > 0)? loop->itermax : DEFAULT_NOBS;
2098
2099 lstore->dset = create_auxiliary_dataset(lstore->nvars + 1, n, 0);
2100 if (lstore->dset == NULL) {
2101 return E_ALLOC;
2102 }
2103
2104 #if LOOP_DEBUG > 1
2105 fprintf(stderr, "loop_store_init: created sZ, v = %d, n = %d\n",
2106 lstore->dset->v, lstore->dset->n);
2107 #endif
2108
2109 for (i=0; i<lstore->nvars && !err; i++) {
2110 const char *s = lstore->names[i];
2111
2112 if (!gretl_is_scalar(s)) {
2113 gretl_errmsg_sprintf(_("'%s': not a scalar"), s);
2114 err = E_DATA;
2115 } else {
2116 strcpy(lstore->dset->varname[i+1], s);
2117 }
2118 }
2119
2120 return err;
2121 }
2122
loop_store_update(LOOPSET * loop,int j,const char * names,const char * fname,gretlopt opt)2123 static int loop_store_update (LOOPSET *loop, int j,
2124 const char *names,
2125 const char *fname,
2126 gretlopt opt)
2127 {
2128 LOOP_STORE *lstore = &loop->store;
2129 int i, t, err = 0;
2130
2131 if (lstore->lineno >= 0 && lstore->lineno != j) {
2132 gretl_errmsg_set("Only one 'store' command is allowed in a "
2133 "progressive loop");
2134 return E_DATA;
2135 }
2136
2137 if (lstore->dset == NULL) {
2138 /* not started yet */
2139 err = loop_store_start(loop, names, fname, opt);
2140 if (err) {
2141 return err;
2142 }
2143 lstore->lineno = j;
2144 loop->cmds[j].flags |= LOOP_CMD_PDONE;
2145 }
2146
2147 t = lstore->n;
2148
2149 if (t >= lstore->dset->n) {
2150 if (extend_loop_dataset(lstore)) {
2151 err = E_ALLOC;
2152 }
2153 }
2154
2155 for (i=0; i<lstore->nvars && !err; i++) {
2156 lstore->dset->Z[i+1][t] =
2157 gretl_scalar_get_value(lstore->names[i], &err);
2158 }
2159
2160 if (!err) {
2161 lstore->n += 1;
2162 }
2163
2164 return err;
2165 }
2166
2167 #endif /* HAVE_GMP: progressive option supported */
2168
2169 /* See if we already have a model recorder in place for the command on
2170 line @lno of the loop. If so, fetch it, otherwise create a new one
2171 and return it.
2172 */
2173
get_model_record_by_line(LOOPSET * loop,int lno,int * err)2174 static MODEL *get_model_record_by_line (LOOPSET *loop, int lno, int *err)
2175 {
2176 MODEL **models, *pmod;
2177 int *modlines;
2178 int n = loop->n_models;
2179 int i;
2180
2181 for (i=0; i<n; i++) {
2182 if (lno == loop->model_lines[i]) {
2183 return loop->models[i];
2184 }
2185 }
2186
2187 modlines = realloc(loop->model_lines, (n + 1) * sizeof *modlines);
2188 if (modlines == NULL) {
2189 *err = E_ALLOC;
2190 return NULL;
2191 } else {
2192 loop->model_lines = modlines;
2193 }
2194
2195 models = realloc(loop->models, (n + 1) * sizeof *models);
2196 if (models == NULL) {
2197 *err = E_ALLOC;
2198 return NULL;
2199 } else {
2200 loop->models = models;
2201 }
2202
2203 pmod = gretl_model_new();
2204 if (pmod == NULL) {
2205 *err = E_ALLOC;
2206 return NULL;
2207 }
2208
2209 /* 2016-10-24: I think this is right, AC. Note
2210 that there's a matching "unprotect" when a loop
2211 is destroyed.
2212 */
2213 gretl_model_protect(pmod);
2214
2215 loop->model_lines[n] = lno;
2216 pmod->ID = n + 1;
2217 loop->models[n] = pmod;
2218 loop->n_models += 1;
2219
2220 return pmod;
2221 }
2222
model_is_in_loop(const MODEL * pmod)2223 int model_is_in_loop (const MODEL *pmod)
2224 {
2225 LOOPSET *loop = currloop;
2226 int i;
2227
2228 while (loop != NULL) {
2229 for (i=0; i<loop->n_models; i++) {
2230 if (pmod == loop->models[i]) {
2231 return 1;
2232 }
2233 }
2234 loop = loop->parent;
2235 }
2236
2237 return 0;
2238 }
2239
2240 #if HAVE_GMP
2241
2242 /* See if we already have a LOOP_MODEL in place for the command
2243 on line @lno of the loop. If so, return it, else create
2244 a new LOOP_MODEL and return it.
2245 */
2246
2247 static LOOP_MODEL *
get_loop_model_by_line(LOOPSET * loop,int lno,int * err)2248 get_loop_model_by_line (LOOPSET *loop, int lno, int *err)
2249 {
2250 LOOP_MODEL *lmods;
2251 int n = loop->n_loop_models;
2252 int i;
2253
2254 #if LOOP_DEBUG > 1
2255 fprintf(stderr, "get_loop_model_by_line: loop->n_loop_models = %d\n",
2256 loop->n_loop_models);
2257 #endif
2258
2259 for (i=0; i<n; i++) {
2260 if (loop->lmodels[i].lineno == lno) {
2261 return &loop->lmodels[i];
2262 }
2263 }
2264
2265 lmods = realloc(loop->lmodels, (n + 1) * sizeof *loop->lmodels);
2266 if (lmods == NULL) {
2267 *err = E_ALLOC;
2268 return NULL;
2269 }
2270
2271 loop->lmodels = lmods;
2272 loop_model_init(&loop->lmodels[n], lno);
2273 loop->n_loop_models += 1;
2274
2275 return &loop->lmodels[n];
2276 }
2277
2278 #define realdiff(x,y) (fabs((x)-(y)) > 2.0e-13)
2279
2280 /* Update the info stored in LOOP_MODEL based on the results in pmod.
2281 If this is the first use we have to do some allocation first.
2282 */
2283
loop_model_update(LOOP_MODEL * lmod,MODEL * pmod)2284 static int loop_model_update (LOOP_MODEL *lmod, MODEL *pmod)
2285 {
2286 mpf_t m;
2287 int j, err = 0;
2288
2289 #if LOOP_DEBUG > 1
2290 fprintf(stderr, "loop_model_update: lmod = %p, pmod = %p\n",
2291 (void *) lmod, (void *) pmod);
2292 #endif
2293
2294 if (lmod == NULL) {
2295 fprintf(stderr, "loop_model_update: got NULL loop model\n");
2296 return E_DATA;
2297 }
2298
2299 if (lmod->nc == 0) {
2300 /* not started yet */
2301 err = loop_model_start(lmod, pmod);
2302 if (err) {
2303 return err;
2304 }
2305 } else if (pmod->ncoeff != lmod->nc) {
2306 gretl_errmsg_set(_("progressive loop: model must be of constant size"));
2307 return E_DATA;
2308 }
2309
2310 mpf_init(m);
2311
2312 for (j=0; j<pmod->ncoeff; j++) {
2313 mpf_set_d(m, pmod->coeff[j]);
2314 mpf_add(lmod->sum_coeff[j], lmod->sum_coeff[j], m);
2315 mpf_mul(m, m, m);
2316 mpf_add(lmod->ssq_coeff[j], lmod->ssq_coeff[j], m);
2317
2318 mpf_set_d(m, pmod->sderr[j]);
2319 mpf_add(lmod->sum_sderr[j], lmod->sum_sderr[j], m);
2320 mpf_mul(m, m, m);
2321 mpf_add(lmod->ssq_sderr[j], lmod->ssq_sderr[j], m);
2322 if (!na(lmod->cbak[j]) && realdiff(pmod->coeff[j], lmod->cbak[j])) {
2323 lmod->cdiff[j] = 1;
2324 }
2325 if (!na(lmod->sbak[j]) && realdiff(pmod->sderr[j], lmod->sbak[j])) {
2326 lmod->sdiff[j] = 1;
2327 }
2328 lmod->cbak[j] = pmod->coeff[j];
2329 lmod->sbak[j] = pmod->sderr[j];
2330 }
2331
2332 mpf_clear(m);
2333
2334 lmod->n += 1;
2335
2336 #if LOOP_DEBUG > 1
2337 fprintf(stderr, "loop_model_update: returning %d\n", err);
2338 #endif
2339
2340 return err;
2341 }
2342
2343 /* Update the LOOP_PRINT struct @lprn using the current values of the
2344 specified variables. If this is the first use we need to do some
2345 allocation first.
2346 */
2347
loop_print_update(LOOPSET * loop,int j,const char * names)2348 static int loop_print_update (LOOPSET *loop, int j, const char *names)
2349 {
2350 LOOP_PRINT *lprn;
2351 int err = 0;
2352
2353 lprn = get_loop_print_by_line(loop, j, &err);
2354
2355 if (!err && lprn->names == NULL) {
2356 /* not started yet */
2357 err = loop_print_start(lprn, names);
2358 if (!err) {
2359 loop->cmds[j].flags |= LOOP_CMD_PDONE;
2360 }
2361 }
2362
2363 if (!err) {
2364 mpf_t m;
2365 double x;
2366 int i;
2367
2368 mpf_init(m);
2369
2370 for (i=0; i<lprn->nvars; i++) {
2371 if (lprn->na[i]) {
2372 continue;
2373 }
2374 x = gretl_scalar_get_value(lprn->names[i], &err);
2375 if (err) {
2376 break;
2377 }
2378 if (na(x)) {
2379 lprn->na[i] = 1;
2380 continue;
2381 }
2382 mpf_set_d(m, x);
2383 mpf_add(lprn->sum[i], lprn->sum[i], m);
2384 mpf_mul(m, m, m);
2385 mpf_add(lprn->ssq[i], lprn->ssq[i], m);
2386 if (!na(lprn->xbak[i]) && realdiff(x, lprn->xbak[i])) {
2387 lprn->diff[i] = 1;
2388 }
2389 lprn->xbak[i] = x;
2390 }
2391
2392 mpf_clear(m);
2393
2394 lprn->n += 1;
2395 }
2396
2397 return err;
2398 }
2399
2400 #endif /* HAVE_GMP */
2401
add_more_loop_commands(LOOPSET * loop)2402 static int add_more_loop_commands (LOOPSET *loop)
2403 {
2404 int nb = 1 + (loop->n_cmds + 1) / LOOP_BLOCK;
2405 int totcmds = nb * LOOP_BLOCK;
2406 loop_command *cmds;
2407
2408 /* in case we ran out of space */
2409 cmds = realloc(loop->cmds, totcmds * sizeof *cmds);
2410
2411 if (cmds == NULL) {
2412 return E_ALLOC;
2413 }
2414
2415 loop->cmds = cmds;
2416 loop_cmds_init(loop, loop->n_cmds, totcmds);
2417
2418 return 0;
2419 }
2420
real_append_line(ExecState * s,LOOPSET * loop)2421 static int real_append_line (ExecState *s, LOOPSET *loop)
2422 {
2423 int n = loop->n_cmds;
2424 int err = 0;
2425
2426 #if LOOP_DEBUG > 1
2427 fprintf(stderr, "real_append_line: s->line = '%s'\n", s->line);
2428 #endif
2429
2430 if ((n + 1) % LOOP_BLOCK == 0) {
2431 if (add_more_loop_commands(loop)) {
2432 return E_ALLOC;
2433 }
2434 }
2435
2436 loop->cmds[n].line = gretl_strdup(s->line);
2437
2438 if (loop->cmds[n].line == NULL) {
2439 err = E_ALLOC;
2440 } else {
2441 if (s->cmd->ci == PRINT) {
2442 if (!loop_is_progressive(loop) || strchr(s->line, '"')) {
2443 /* printing a literal string, not a variable's value */
2444 loop->cmds[n].flags |= LOOP_CMD_LIT;
2445 }
2446 } else if (s->cmd->ci == RENAME || s->cmd->ci == OPEN) {
2447 loop_set_renaming(loop);
2448 } else if (s->cmd->ci == IF) {
2449 loop_set_has_cond(loop);
2450 }
2451 loop->cmds[n].ci = s->cmd->ci;
2452 loop->n_cmds += 1;
2453 }
2454
2455 #if LOOP_DEBUG > 1
2456 fprintf(stderr, "loop %p: n_cmds=%d, line[%d]='%s', ci=%d\n",
2457 (void *) loop, loop->n_cmds, n, loop->cmds[n].line,
2458 loop->cmds[n].ci);
2459 #endif
2460
2461 return err;
2462 }
2463
2464 /**
2465 * gretl_loop_append_line:
2466 * @s: program execution state.
2467 * @dset: dataset struct.
2468 *
2469 * Add the command line @s->line to accumulated loop buffer.
2470 *
2471 * Returns: 0 on success, non-zero code on error.
2472 */
2473
gretl_loop_append_line(ExecState * s,DATASET * dset)2474 int gretl_loop_append_line (ExecState *s, DATASET *dset)
2475 {
2476 LOOPSET *loop = currloop;
2477 LOOPSET *newloop = currloop;
2478 int err = 0;
2479
2480 warnmsg(s->prn); /* catch "end loop" if present */
2481 gretl_error_clear();
2482
2483 #if LOOP_DEBUG > 1
2484 fprintf(stderr, "gretl_loop_append_line: currloop = %p, line = '%s'\n",
2485 (void *) loop, s->line);
2486 #endif
2487
2488 if (!ok_in_loop(s->cmd->ci)) {
2489 gretl_errmsg_sprintf(_("The '%s' command is not available in loop mode"),
2490 gretl_command_word(s->cmd->ci));
2491 destroy_loop_stack(loop);
2492 return E_NOTIMP;
2493 }
2494
2495 if (s->cmd->ci == LOOP) {
2496 /* starting from scratch */
2497 char *spec = s->cmd->param;
2498 gretlopt opt = s->cmd->opt;
2499 int nested = 0;
2500
2501 if (spec == NULL) {
2502 fprintf(stderr, "GRETL_ERROR: loop line is unparsed\n");
2503 err = E_DATA;
2504 }
2505
2506 #if !HAVE_GMP
2507 if (opt & OPT_P) {
2508 gretl_errmsg_set("The progressive option is not available "
2509 "in this build");
2510 err = E_BADOPT;
2511 }
2512 #endif
2513
2514 if (!err) {
2515 newloop = start_new_loop(spec, loop, dset, opt,
2516 &nested, &err);
2517 #if GLOBAL_TRACE || LOOP_DEBUG
2518 fprintf(stderr, "got LOOP: newloop at %p (err = %d)\n",
2519 (void *) newloop, err);
2520 #endif
2521 if (newloop == NULL) {
2522 return err;
2523 } else {
2524 set_loop_opts(newloop, opt);
2525 compile_level++;
2526 if (!nested) {
2527 currloop = newloop;
2528 return 0; /* done */
2529 }
2530 }
2531 }
2532 } else if (s->cmd->ci == ENDLOOP) {
2533 /* got to the end */
2534 compile_level--;
2535 #if GLOBAL_TRACE || LOOP_DEBUG
2536 fprintf(stderr, "got ENDLOOP, compile_level now %d\n",
2537 compile_level);
2538 #endif
2539 if (compile_level == 0) {
2540 /* set flag to run the loop */
2541 loop_execute = 1;
2542 } else {
2543 /* back up a level */
2544 newloop = loop->parent;
2545 }
2546 }
2547
2548 if (!err && loop != NULL && s->cmd->ci != ENDLOOP) {
2549 err = real_append_line(s, loop);
2550 }
2551
2552 if (err) {
2553 if (loop != NULL) {
2554 gretl_loop_destroy(loop);
2555 compile_level = 0;
2556 }
2557 } else {
2558 currloop = newloop;
2559 }
2560
2561 return err;
2562 }
2563
2564 #if HAVE_GMP
2565
print_loop_coeff(const DATASET * dset,const LOOP_MODEL * lmod,int i,PRN * prn)2566 static void print_loop_coeff (const DATASET *dset,
2567 const LOOP_MODEL *lmod,
2568 int i, PRN *prn)
2569 {
2570 char pname[VNAMELEN];
2571 char tmp[NAMETRUNC];
2572 mpf_t c1, c2, m, sd1, sd2;
2573 unsigned long ln = lmod->n;
2574
2575 mpf_init(c1);
2576 mpf_init(c2);
2577 mpf_init(m);
2578 mpf_init(sd1);
2579 mpf_init(sd2);
2580
2581 mpf_div_ui(c1, lmod->sum_coeff[i], ln);
2582 if (lmod->cdiff[i] == 0) {
2583 mpf_set_d(sd1, 0.0);
2584 } else {
2585 mpf_mul(m, c1, c1);
2586 mpf_mul_ui(m, m, ln);
2587 mpf_sub(m, lmod->ssq_coeff[i], m);
2588 mpf_div_ui(sd1, m, ln);
2589 if (mpf_cmp_d(sd1, 0.0) > 0) {
2590 mpf_sqrt(sd1, sd1);
2591 } else {
2592 mpf_set_d(sd1, 0.0);
2593 }
2594 }
2595
2596 mpf_div_ui(c2, lmod->sum_sderr[i], ln);
2597 if (lmod->sdiff[i] == 0) {
2598 mpf_set_d(sd2, 0.0);
2599 } else {
2600 mpf_mul(m, c2, c2);
2601 mpf_mul_ui(m, m, ln);
2602 mpf_sub(m, lmod->ssq_sderr[i], m);
2603 mpf_div_ui(sd2, m, ln);
2604 if (mpf_cmp_d(sd2, 0.0) > 0) {
2605 mpf_sqrt(sd2, sd2);
2606 } else {
2607 mpf_set_d(sd2, 0.0);
2608 }
2609 }
2610
2611 gretl_model_get_param_name(lmod->model0, dset, i, pname);
2612 maybe_trim_varname(tmp, pname);
2613 pprintf(prn, "%*s", 15, tmp); /* FIXME length */
2614 pprintf(prn, "%#14g %#14g %#14g %#14g\n", mpf_get_d(c1), mpf_get_d(sd1),
2615 mpf_get_d(c2), mpf_get_d(sd2));
2616
2617 mpf_clear(c1);
2618 mpf_clear(c2);
2619 mpf_clear(m);
2620 mpf_clear(sd1);
2621 mpf_clear(sd2);
2622 }
2623
loop_model_print(LOOP_MODEL * lmod,const DATASET * dset,PRN * prn)2624 static void loop_model_print (LOOP_MODEL *lmod, const DATASET *dset,
2625 PRN *prn)
2626 {
2627 char startdate[OBSLEN], enddate[OBSLEN];
2628 int i;
2629
2630 ntolabel(startdate, lmod->model0->t1, dset);
2631 ntolabel(enddate, lmod->model0->t2, dset);
2632
2633 pputc(prn, '\n');
2634 pprintf(prn, _("%s estimates using the %d observations %s-%s\n"),
2635 _(estimator_string(lmod->model0, prn)), lmod->model0->nobs,
2636 startdate, enddate);
2637 print_model_vcv_info(lmod->model0, dset, prn);
2638 pprintf(prn, _("Statistics for %d repetitions\n"), lmod->n);
2639 pprintf(prn, _("Dependent variable: %s\n\n"),
2640 gretl_model_get_depvar_name(lmod->model0, dset));
2641
2642 pputs(prn, _(" mean of std. dev. of mean of"
2643 " std. dev. of\n"
2644 " estimated estimated"
2645 " estimated estimated\n"
2646 " Variable coefficients coefficients std. errors"
2647 " std. errors\n\n"));
2648
2649 for (i=0; i<lmod->model0->ncoeff; i++) {
2650 print_loop_coeff(dset, lmod, i, prn);
2651 }
2652
2653 pputc(prn, '\n');
2654 }
2655
loop_print_print(LOOP_PRINT * lprn,PRN * prn)2656 static void loop_print_print (LOOP_PRINT *lprn, PRN *prn)
2657 {
2658 bigval mean, m, sd;
2659 int len, maxlen = 7;
2660 int i, n;
2661 const char *s;
2662
2663 if (lprn == NULL) {
2664 return;
2665 }
2666
2667 n = lprn->n;
2668
2669 mpf_init(mean);
2670 mpf_init(m);
2671 mpf_init(sd);
2672
2673 for (i=0; i<lprn->nvars; i++) {
2674 len = strlen(lprn->names[i]);
2675 if (len > maxlen) {
2676 maxlen = len;
2677 }
2678 }
2679
2680 pprintf(prn, _("Statistics for %d repetitions\n"), n);
2681 pputc(prn, '\n');
2682 bufspace(maxlen + 1, prn);
2683
2684 len = get_utf_width(_("mean"), 14);
2685 pprintf(prn, "%*s ", len, _("mean"));
2686
2687 len = get_utf_width(_("std. dev"), 14);
2688 pprintf(prn, "%*s\n", len, _("std. dev"));
2689
2690 for (i=0; i<lprn->nvars; i++) {
2691 s = lprn->names[i];
2692 if (lprn->na[i]) {
2693 pprintf(prn, "%*s", maxlen + 1, s);
2694 pprintf(prn, "%14s %14s\n", "NA ", "NA ");
2695 continue;
2696 }
2697 mpf_div_ui(mean, lprn->sum[i], (unsigned long) n);
2698 if (lprn->diff[i] == 0) {
2699 mpf_set_d(sd, 0.0);
2700 } else {
2701 mpf_mul(m, mean, mean);
2702 mpf_mul_ui(m, m, (unsigned long) n);
2703 mpf_sub(sd, lprn->ssq[i], m);
2704 mpf_div_ui(sd, sd, (unsigned long) n);
2705 if (mpf_cmp_d(sd, 0.0) > 0) {
2706 mpf_sqrt(sd, sd);
2707 } else {
2708 mpf_set_d(sd, 0.0);
2709 }
2710 }
2711 pprintf(prn, "%*s", maxlen + 1, s);
2712 pprintf(prn, "%#14g %#14g\n", mpf_get_d(mean), mpf_get_d(sd));
2713 }
2714
2715 mpf_clear(mean);
2716 mpf_clear(m);
2717 mpf_clear(sd);
2718
2719 pputc(prn, '\n');
2720 }
2721
loop_store_save(LOOP_STORE * lstore,PRN * prn)2722 static int loop_store_save (LOOP_STORE *lstore, PRN *prn)
2723 {
2724 int *list;
2725 int err = 0;
2726
2727 list = gretl_consecutive_list_new(1, lstore->dset->v - 1);
2728 if (list == NULL) {
2729 return E_ALLOC;
2730 }
2731
2732 lstore->dset->t2 = lstore->n - 1;
2733 pprintf(prn, _("store: using filename %s\n"), lstore->fname);
2734 err = write_data(lstore->fname, list, lstore->dset, lstore->opt, prn);
2735
2736 if (err) {
2737 pprintf(prn, _("write of data file failed\n"));
2738 }
2739
2740 free(list);
2741
2742 return err;
2743 }
2744
extend_loop_dataset(LOOP_STORE * lstore)2745 static int extend_loop_dataset (LOOP_STORE *lstore)
2746 {
2747 double *x;
2748 int oldn = lstore->dset->n;
2749 int n = oldn + DEFAULT_NOBS;
2750 int i, t;
2751
2752 for (i=0; i<lstore->dset->v; i++) {
2753 x = realloc(lstore->dset->Z[i], n * sizeof *x);
2754 if (x == NULL) {
2755 return E_ALLOC;
2756 }
2757 lstore->dset->Z[i] = x;
2758 for (t=oldn; t<n; t++) {
2759 lstore->dset->Z[i][t] = (i == 0)? 1.0 : NADBL;
2760 }
2761 }
2762
2763 lstore->dset->n = n;
2764 lstore->dset->t2 = n - 1;
2765
2766 ntolabel(lstore->dset->endobs, n - 1, lstore->dset);
2767
2768 return 0;
2769 }
2770
progressive_loop_zero(LOOPSET * loop)2771 static void progressive_loop_zero (LOOPSET *loop)
2772 {
2773 int i;
2774
2775 /* What we're doing here is debatable: could we get
2776 away with just "zeroing" the relevant structures
2777 in an appropriate way, rather than destroying
2778 them? Maybe, but so long as we're destroying them
2779 we have to remove the "started" flags from
2780 associated "print" and "store" commands, or else
2781 things will go awry on the second execution of
2782 a nested progressive loop.
2783 */
2784
2785 if (loop->cmds != NULL) {
2786 for (i=0; i<loop->n_cmds; i++) {
2787 if (loop->cmds[i].ci == PRINT ||
2788 loop->cmds[i].ci == STORE) {
2789 /* reset */
2790 loop->cmds[i].flags &= ~LOOP_CMD_PDONE;
2791 }
2792 }
2793 }
2794
2795 for (i=0; i<loop->n_loop_models; i++) {
2796 loop_model_free(&loop->lmodels[i]);
2797 }
2798
2799 loop->lmodels = NULL;
2800 loop->n_loop_models = 0;
2801
2802 for (i=0; i<loop->n_prints; i++) {
2803 loop_print_free(&loop->prns[i]);
2804 }
2805
2806 loop->prns = NULL;
2807 loop->n_prints = 0;
2808
2809 loop_store_free(&loop->store);
2810 }
2811
2812 #endif /* HAVE_GMP */
2813
2814 #define loop_literal(l,i) (l->cmds[i].flags & LOOP_CMD_LIT)
2815
2816 /**
2817 * print_loop_results:
2818 * @loop: pointer to loop struct.
2819 * @dset: data information struct.
2820 * @prn: gretl printing struct.
2821 *
2822 * Print out the results after completion of the loop @loop.
2823 */
2824
print_loop_results(LOOPSET * loop,const DATASET * dset,PRN * prn)2825 static void print_loop_results (LOOPSET *loop, const DATASET *dset,
2826 PRN *prn)
2827 {
2828 #if HAVE_GMP
2829 int k = 0;
2830 #endif
2831 int i, j = 0;
2832
2833 for (i=0; i<loop->n_cmds; i++) {
2834 gretlopt opt = loop->cmds[i].opt;
2835 int ci = loop->cmds[i].ci;
2836
2837 #if LOOP_DEBUG > 1
2838 fprintf(stderr, "print_loop_results: loop command %d: %s\n",
2839 i, loop->cmds[i].line);
2840 #endif
2841
2842 if (ci == OLS && !loop_is_progressive(loop)) {
2843 if (model_print_deferred(opt)) {
2844 MODEL *pmod = loop->models[j++];
2845 gretlopt popt;
2846
2847 set_model_id(pmod, OPT_NONE);
2848 popt = get_printmodel_opt(pmod, opt);
2849 printmodel(pmod, dset, popt, prn);
2850 }
2851 }
2852
2853 #if HAVE_GMP
2854 if (loop_is_progressive(loop)) {
2855 if (plain_model_ci(ci) && !(opt & OPT_Q)) {
2856 loop_model_print(&loop->lmodels[j], dset, prn);
2857 loop_model_zero(&loop->lmodels[j], 1);
2858 j++;
2859 } else if (ci == PRINT && !loop_literal(loop, i)) {
2860 loop_print_print(&loop->prns[k], prn);
2861 loop_print_zero(&loop->prns[k], 1);
2862 k++;
2863 } else if (ci == STORE) {
2864 loop_store_save(&loop->store, prn);
2865 }
2866 }
2867 #endif
2868 }
2869 }
2870
substitute_dollar_targ(char * str,int maxlen,const LOOPSET * loop,const DATASET * dset,int * subst)2871 static int substitute_dollar_targ (char *str, int maxlen,
2872 const LOOPSET *loop,
2873 const DATASET *dset,
2874 int *subst)
2875 {
2876 char insert[32], targ[VNAMELEN + 3] = {0};
2877 char *p, *ins, *q, *s;
2878 int targlen, inslen, idx = 0;
2879 int incr, cumlen = 0;
2880 int err = 0;
2881
2882 #if SUBST_DEBUG
2883 fprintf(stderr, "subst_dollar_targ:\n original: '%s'\n", str);
2884 #endif
2885
2886 /* construct the target for substitution */
2887
2888 if (loop->type == FOR_LOOP) {
2889 if (!gretl_is_scalar(loop->init.vname)) {
2890 /* nothing to substitute */
2891 return 0;
2892 }
2893 sprintf(targ, "$%s", loop->init.vname);
2894 targlen = strlen(targ);
2895 } else if (indexed_loop(loop)) {
2896 sprintf(targ, "$%s", loop->idxname);
2897 targlen = strlen(targ);
2898 idx = loop->init.val + loop->iter;
2899 } else {
2900 /* shouldn't be here! */
2901 return 1;
2902 }
2903
2904 #if SUBST_DEBUG
2905 fprintf(stderr, " target = '%s', idx = %d\n", targ, idx);
2906 #endif
2907
2908 if (strstr(str, targ) == NULL) {
2909 /* nothing to be done */
2910 return 0;
2911 }
2912
2913 ins = insert;
2914
2915 /* prepare the substitute string */
2916
2917 if (loop->type == FOR_LOOP) {
2918 double x = gretl_scalar_get_value(loop->init.vname, NULL);
2919
2920 if (na(x)) {
2921 strcpy(insert, "NA");
2922 } else {
2923 sprintf(insert, "%g", x);
2924 }
2925 } else if (loop->type == INDEX_LOOP) {
2926 sprintf(insert, "%d", idx);
2927 } else if (loop->type == DATED_LOOP) {
2928 /* note: ntolabel is 0-based */
2929 ntolabel(insert, idx - 1, dset);
2930 } else if (loop->type == EACH_LOOP) {
2931 ins = loop->eachstrs[idx - 1];
2932 }
2933
2934 inslen = strlen(ins);
2935 incr = inslen - targlen;
2936 if (incr > 0) {
2937 /* substitution will lengthen the string */
2938 cumlen = strlen(str);
2939 }
2940
2941 q = malloc(strlen(strstr(str, targ)));
2942 if (q == NULL) {
2943 err = E_ALLOC;
2944 }
2945
2946 /* crawl along str, replacing targ with ins */
2947
2948 s = str;
2949 while ((p = strstr(s, targ)) != NULL && !err) {
2950 if (is_gretl_accessor(p)) {
2951 s++;
2952 continue;
2953 }
2954 if (incr > 0) {
2955 cumlen += incr;
2956 if (cumlen >= maxlen) {
2957 /* substitution would cause overflow */
2958 err = (maxlen == VNAMELEN)? E_UNKVAR : E_TOOLONG;
2959 break;
2960 }
2961 }
2962 strcpy(q, p + targlen);
2963 strcpy(p, ins);
2964 strcpy(p + inslen, q);
2965 if (subst != NULL) {
2966 *subst = 1;
2967 }
2968 s++; /* += strlen(ins)? */
2969 }
2970
2971 free(q);
2972
2973 #if SUBST_DEBUG
2974 fprintf(stderr, " after: '%s'\n", str);
2975 #endif
2976
2977 return err;
2978 }
2979
2980 /* When re-executing a loop that has been saved onto its
2981 calling function, the loop index variable may have been
2982 destroyed, in which case it has to be recreated.
2983 */
2984
loop_reattach_index_var(LOOPSET * loop,DATASET * dset)2985 static int loop_reattach_index_var (LOOPSET *loop, DATASET *dset)
2986 {
2987 char genline[64];
2988 int err = 0;
2989
2990 if (na(loop->init.val)) {
2991 sprintf(genline, "%s=NA", loop->idxname);
2992 } else {
2993 gretl_push_c_numeric_locale();
2994 sprintf(genline, "%s=%g", loop->idxname, loop->init.val);
2995 gretl_pop_c_numeric_locale();
2996 }
2997
2998 err = generate(genline, dset, GRETL_TYPE_DOUBLE, OPT_Q, NULL);
2999
3000 if (!err) {
3001 loop->idxvar = get_user_var_by_name(loop->idxname);
3002 }
3003
3004 return err;
3005 }
3006
3007 /* Called at the start of iteration for a given loop */
3008
top_of_loop(LOOPSET * loop,DATASET * dset)3009 static int top_of_loop (LOOPSET *loop, DATASET *dset)
3010 {
3011 int err = 0;
3012
3013 loop->iter = 0;
3014
3015 if (loop->eachname[0] != '\0') {
3016 err = loop_list_refresh(loop, dset);
3017 } else if (loop->type == INDEX_LOOP) {
3018 loop->init.val = controller_get_val(&loop->init, loop, dset, &err);
3019 } else if (loop->type == FOR_LOOP) {
3020 forloop_init(loop, dset, &err);
3021 }
3022
3023 if (!err && loop->idxname[0] != '\0' && loop->idxvar == NULL) {
3024 err = loop_reattach_index_var(loop, dset);
3025 }
3026
3027 if (!err && (loop->type == COUNT_LOOP || indexed_loop(loop))) {
3028 loop->final.val = controller_get_val(&loop->final, loop, dset, &err);
3029 if (na(loop->init.val) || na(loop->final.val)) {
3030 gretl_errmsg_set(_("error evaluating loop condition"));
3031 fprintf(stderr, "loop: got NA for init and/or final value\n");
3032 err = E_DATA;
3033 } else {
3034 loop->itermax = loop->final.val - loop->init.val + 1;
3035 #if LOOP_DEBUG > 1
3036 fprintf(stderr, "*** itermax = %g - %g + 1 = %d\n",
3037 loop->final.val, loop->init.val, loop->itermax);
3038 #endif
3039 }
3040 }
3041
3042 if (!err) {
3043 if (indexed_loop(loop)) {
3044 loop->idxval = loop->init.val;
3045 uvar_set_scalar_fast(loop->idxvar, loop->idxval);
3046 }
3047 /* initialization, in case this loop is being run more than
3048 once (i.e. it's embedded in an outer loop)
3049 */
3050 #if HAVE_GMP
3051 if (loop_is_progressive(loop)) {
3052 progressive_loop_zero(loop);
3053 } else {
3054 free(loop->models);
3055 loop->models = NULL;
3056 loop->n_models = 0;
3057 }
3058 #else
3059 free(loop->models);
3060 loop->models = NULL;
3061 loop->n_models = 0;
3062 #endif /* HAVE_GMP */
3063 }
3064
3065 return err;
3066 }
3067
3068 static const LOOPSET *
subst_loop_in_parentage(const LOOPSET * loop)3069 subst_loop_in_parentage (const LOOPSET *loop)
3070 {
3071 while ((loop = loop->parent) != NULL) {
3072 if (indexed_loop(loop) || loop->type == FOR_LOOP) break;
3073 }
3074
3075 return loop;
3076 }
3077
3078 static int
make_dollar_substitutions(char * str,int maxlen,const LOOPSET * loop,const DATASET * dset,int * subst,gretlopt opt)3079 make_dollar_substitutions (char *str, int maxlen,
3080 const LOOPSET *loop,
3081 const DATASET *dset,
3082 int *subst,
3083 gretlopt opt)
3084 {
3085 int err = 0;
3086
3087 if (subst != NULL) {
3088 *subst = 0;
3089 }
3090
3091 /* if (opt & OPT_T) we're just processing a variable name, at the top
3092 of a loop, so we can skip to the "parentage" bit
3093 */
3094
3095 if (!(opt & OPT_T) && (indexed_loop(loop) || loop->type == FOR_LOOP)) {
3096 err = substitute_dollar_targ(str, maxlen, loop, dset, subst);
3097 }
3098
3099 while (!err && (loop = subst_loop_in_parentage(loop)) != NULL) {
3100 err = substitute_dollar_targ(str, maxlen, loop, dset, subst);
3101 }
3102
3103 return err;
3104 }
3105
scalar_is_read_only_index(const char * name)3106 int scalar_is_read_only_index (const char *name)
3107 {
3108 const LOOPSET *loop = currloop;
3109
3110 while (loop != NULL) {
3111 if (indexed_loop(loop) && !strcmp(name, loop->idxname)) {
3112 return 1;
3113 }
3114 loop = loop->parent;
3115 }
3116
3117 return 0;
3118 }
3119
get_child_loop_by_line(LOOPSET * loop,int lno)3120 static LOOPSET *get_child_loop_by_line (LOOPSET *loop, int lno)
3121 {
3122 int i;
3123
3124 for (i=0; i<loop->n_children; i++) {
3125 if (loop->children[i]->parent_line == lno) {
3126 return loop->children[i];
3127 }
3128 }
3129
3130 return NULL;
3131 }
3132
add_loop_genr(LOOPSET * loop,int lno,CMD * cmd,DATASET * dset,PRN * prn)3133 static int add_loop_genr (LOOPSET *loop,
3134 int lno,
3135 CMD *cmd,
3136 DATASET *dset,
3137 PRN *prn)
3138 {
3139 GretlType gtype = cmd->gtype;
3140 const char *line = cmd->vstart;
3141 gretlopt gopt = OPT_NONE;
3142 int err = 0;
3143
3144 if (cmd->opt & OPT_O) {
3145 gopt |= OPT_O;
3146 }
3147
3148 loop->cmds[lno].genr = genr_compile(line, dset, gtype,
3149 gopt, prn, &err);
3150
3151 if (!err) {
3152 loop->cmds[lno].flags |= LOOP_CMD_GENR;
3153 } else if (err == E_EQN) {
3154 /* may be a non-compilable special such as "genr time" */
3155 err = 0;
3156 }
3157
3158 return err;
3159 }
3160
loop_print_save_model(MODEL * pmod,DATASET * dset,PRN * prn,ExecState * s)3161 static int loop_print_save_model (MODEL *pmod, DATASET *dset,
3162 PRN *prn, ExecState *s)
3163 {
3164 int err = pmod->errcode;
3165
3166 if (!err) {
3167 int havename = *s->cmd->savename != '\0';
3168 int window = (s->cmd->opt & OPT_W) != 0;
3169
3170 set_gretl_errno(0);
3171 if (!(s->cmd->opt & OPT_Q)) {
3172 gretlopt popt = get_printmodel_opt(pmod, s->cmd->opt);
3173
3174 printmodel(pmod, dset, popt, prn);
3175 }
3176 attach_subsample_to_model(pmod, dset);
3177 s->pmod = maybe_stack_model(pmod, s->cmd, prn, &err);
3178 if (!err && gretl_in_gui_mode() && s->callback != NULL &&
3179 (havename || window)) {
3180 s->callback(s, s->pmod, GRETL_OBJ_EQN);
3181 }
3182 }
3183
3184 return err;
3185 }
3186
3187 #define genr_compiled(l,j) (l->cmds[j].flags & LOOP_CMD_GENR)
3188 #define cond_compiled(l,j) (l->cmds[j].flags & LOOP_CMD_COND)
3189 #define loop_cmd_nodol(l,j) (l->cmds[j].flags & LOOP_CMD_NODOL)
3190 #define loop_cmd_nosub(l,j) (l->cmds[j].flags & LOOP_CMD_NOSUB)
3191 #define loop_cmd_catch(l,j) (l->cmds[j].flags & LOOP_CMD_CATCH)
3192 #define prog_cmd_started(l,j) (l->cmds[j].flags & LOOP_CMD_PDONE)
3193
3194 #define is_compiled(l,j) (l->cmds[j].genr != NULL || \
3195 l->cmds[j].ci == ELSE || \
3196 loop->cmds[j].ci == ENDIF)
3197
loop_process_error(LOOPSET * loop,int j,int err,PRN * prn)3198 static int loop_process_error (LOOPSET *loop, int j, int err, PRN *prn)
3199 {
3200 #if LOOP_DEBUG
3201 fprintf(stderr, "loop_process_error: j=%d, err=%d, catch=%d\n",
3202 j, err, loop_cmd_catch(loop, j));
3203 fprintf(stderr, " line: '%s'\n", loop->cmds[j].line);
3204 fprintf(stderr, " errmsg: '%s'\n", gretl_errmsg_get());
3205 #endif
3206 if (loop_cmd_catch(loop, j)) {
3207 set_gretl_errno(err);
3208 loop->flags |= LOOP_ERR_CAUGHT;
3209 err = 0;
3210 }
3211
3212 #if LOOP_DEBUG
3213 fprintf(stderr, " returning err = %d\n", err);
3214 #endif
3215
3216 return err;
3217 }
3218
3219 /* Based on the stored flags in the loop-line record, set
3220 or unset some flags for the command parser: this can
3221 reduce the amount of work the parser has to do on each
3222 iteration of a loop (maybe some of this obsolete?).
3223 */
3224
loop_info_to_cmd(LOOPSET * loop,int j,CMD * cmd)3225 static inline void loop_info_to_cmd (LOOPSET *loop, int j,
3226 CMD *cmd)
3227 {
3228 #if LOOP_DEBUG > 1
3229 fprintf(stderr, "loop_info_to_cmd: i=%d, j=%d: '%s'\n",
3230 loop->iter, j, loop->cmds[j].line);
3231 #endif
3232
3233 if (loop_is_progressive(loop)) {
3234 cmd->flags |= CMD_PROG;
3235 } else {
3236 cmd->flags &= ~CMD_PROG;
3237 }
3238
3239 if (loop_cmd_nosub(loop, j)) {
3240 /* tell parser not to bother trying for @-substitution */
3241 cmd->flags |= CMD_NOSUB;
3242 } else {
3243 cmd->flags &= ~CMD_NOSUB;
3244 }
3245
3246 /* readjust "catch" for commands that are not being
3247 sent through the parser again */
3248 if (loop_cmd_catch(loop, j)) {
3249 cmd->flags |= CMD_CATCH;
3250 } else if (!cmd->context) {
3251 cmd->flags &= ~CMD_CATCH;
3252 }
3253
3254 #if LOOP_DEBUG > 1
3255 fprintf(stderr, " flagged: prog %d, nosub %d, catch %d\n",
3256 (cmd->flags & CMD_PROG)? 1 : 0,
3257 (cmd->flags & CMD_NOSUB)? 1 : 0,
3258 (cmd->flags & CMD_CATCH)? 1 : 0);
3259 #endif
3260 }
3261
3262 /* Based on the parsed info in @cmd, maybe modify some flags in
3263 the current loop-line record.
3264 */
3265
cmd_info_to_loop(LOOPSET * loop,int j,CMD * cmd,int * subst)3266 static inline void cmd_info_to_loop (LOOPSET *loop, int j,
3267 CMD *cmd, int *subst)
3268 {
3269 loop_command *lcmd = &loop->cmds[j];
3270
3271 #if LOOP_DEBUG > 1
3272 fprintf(stderr, "cmd_info_to_loop: j=%d: '%s'\n",
3273 j, lcmd->line);
3274 #endif
3275
3276 if (!loop_cmd_nosub(loop, j)) {
3277 /* this loop line has not already been marked as
3278 free of @-substitution
3279 */
3280 if (cmd_subst(cmd)) {
3281 *subst = 1;
3282 } else {
3283 /* record: no @-substitution in this line */
3284 lcmd->flags |= LOOP_CMD_NOSUB;
3285 }
3286 }
3287
3288 if (cmd->ci == IF || cmd->ci == ELIF) {
3289 return;
3290 }
3291
3292 lcmd->opt = cmd->opt;
3293
3294 if (cmd->flags & CMD_CATCH) {
3295 lcmd->flags |= LOOP_CMD_CATCH;
3296 }
3297
3298 #if LOOP_DEBUG > 1
3299 fprintf(stderr, " loop-flagged: nosub %d, catch %d\n",
3300 loop_cmd_nosub(loop, j)? 1 : 0,
3301 loop_cmd_catch(loop, j)? 1 : 0);
3302 #endif
3303 }
3304
3305 /* We come here when the --force option has been applied to
3306 the "delete" command, trying to prevent deletion of the
3307 index variable for the loop: even --force can't allow that,
3308 on penalty of crashing.
3309 */
3310
loop_check_deletion(LOOPSET * loop,const char * param,PRN * prn)3311 static int loop_check_deletion (LOOPSET *loop, const char *param,
3312 PRN *prn)
3313 {
3314 user_var *uv = get_user_var_by_name(param);
3315
3316 if (uv != NULL) {
3317 while (loop != NULL) {
3318 if (loop->idxvar == uv) {
3319 pprintf(prn, _("delete %s: not allowed\n"), param);
3320 return 1;
3321 }
3322 loop = loop->parent;
3323 }
3324 }
3325
3326 return 0;
3327 }
3328
3329 /* We come here if the --force option has not been applied to
3330 the "delete" command, and we'll be conservative.
3331 */
3332
loop_delete_object(LOOPSET * loop,CMD * cmd,PRN * prn)3333 static int loop_delete_object (LOOPSET *loop, CMD *cmd, PRN *prn)
3334 {
3335 int err = 0;
3336
3337 if (cmd->list != NULL && cmd->list[0] > 0) {
3338 /* too dangerous! */
3339 pputs(prn, _("You cannot delete series in this context\n"));
3340 err = 1;
3341 } else if (gretl_is_scalar(cmd->param)) {
3342 /* could delete loop index */
3343 pputs(prn, _("You cannot delete scalars in this context\n"));
3344 err = 1;
3345 } else if (loop->parent != NULL || loop->n_children > 0) {
3346 /* not a "singleton" loop */
3347 pprintf(prn, _("delete %s: not allowed\n"), cmd->param);
3348 err = 1;
3349 } else {
3350 /* check for compiled genrs on board: don't let these
3351 get screwed up by deletion of variables of any kind
3352 */
3353 int i, ok = 1;
3354
3355 for (i=0; i<loop->n_cmds; i++) {
3356 if (loop->cmds[i].genr != NULL) {
3357 ok = 0;
3358 break;
3359 }
3360 }
3361 if (ok) {
3362 err = gretl_delete_var_by_name(cmd->param, prn);
3363 } else {
3364 pprintf(prn, _("delete %s: not allowed\n"), cmd->param);
3365 err = 1;
3366 }
3367 }
3368
3369 return err;
3370 }
3371
3372 static char *inner_errline;
3373
loop_report_error(LOOPSET * loop,int err,char * errline,ExecState * state,PRN * prn)3374 static int loop_report_error (LOOPSET *loop, int err,
3375 char *errline,
3376 ExecState *state,
3377 PRN *prn)
3378 {
3379 int fd = gretl_function_depth();
3380
3381 if (fd > 0 && inner_errline != NULL) {
3382 errline = inner_errline;
3383 }
3384
3385 if (err) {
3386 if (fd == 0) {
3387 errmsg(err, prn);
3388 if (errline != NULL && *errline != '\0') {
3389 pprintf(prn, ">> %s\n", errline);
3390 }
3391 }
3392 } else if (loop->err) {
3393 if (fd == 0) {
3394 errmsg(loop->err, prn);
3395 }
3396 err = loop->err;
3397 }
3398
3399 if (fd > 0 && err && errline != NULL && *errline != '\0') {
3400 strcpy(state->line, errline);
3401 }
3402
3403 return err;
3404 }
3405
loop_reset_error(void)3406 static void loop_reset_error (void)
3407 {
3408 if (inner_errline != NULL) {
3409 free(inner_errline);
3410 inner_errline = NULL;
3411 }
3412 }
3413
ends_condition(LOOPSET * loop,int j)3414 static int ends_condition (LOOPSET *loop, int j)
3415 {
3416 return loop->cmds[j].ci == ELSE || loop->cmds[j].ci == ENDIF;
3417 }
3418
do_compile_conditional(LOOPSET * loop,int j)3419 static int do_compile_conditional (LOOPSET *loop, int j)
3420 {
3421 int ret = 0;
3422
3423 if ((loop->cmds[j].ci == IF || loop->cmds[j].ci == ELIF) &&
3424 loop_cmd_nodol(loop, j) && loop_cmd_nosub(loop, j)) {
3425 ret = 1;
3426 }
3427
3428 return ret;
3429 }
3430
3431 #if HAVE_GMP
3432
model_command_post_process(ExecState * s,DATASET * dset,LOOPSET * loop,int j)3433 static int model_command_post_process (ExecState *s,
3434 DATASET *dset,
3435 LOOPSET *loop,
3436 int j)
3437 {
3438 int prog = loop_is_progressive(loop);
3439 int moderr = check_gretl_errno();
3440 int err = 0;
3441
3442 if (moderr) {
3443 if (prog || model_print_deferred(s->cmd->opt)) {
3444 err = moderr;
3445 } else {
3446 errmsg(moderr, s->prn);
3447 }
3448 } else if (prog && !(s->cmd->opt & OPT_Q)) {
3449 LOOP_MODEL *lmod = get_loop_model_by_line(loop, j, &err);
3450
3451 if (!err) {
3452 err = loop_model_update(lmod, s->model);
3453 set_as_last_model(s->model, GRETL_OBJ_EQN);
3454 }
3455 } else if (model_print_deferred(s->cmd->opt)) {
3456 MODEL *pmod = get_model_record_by_line(loop, j, &err);
3457
3458 if (!err) {
3459 swap_models(s->model, pmod);
3460 pmod->ID = j + 1;
3461 set_as_last_model(pmod, GRETL_OBJ_EQN);
3462 model_count_minus(NULL);
3463 }
3464 } else {
3465 loop_print_save_model(s->model, dset, s->prn, s);
3466 }
3467
3468 return err;
3469 }
3470
3471 #else
3472
model_command_post_process(ExecState * s,DATASET * dset,LOOPSET * loop,int j)3473 static int model_command_post_process (ExecState *s,
3474 DATASET *dset,
3475 LOOPSET *loop,
3476 int j)
3477 {
3478 int moderr = check_gretl_errno();
3479 int err = 0;
3480
3481 if (moderr) {
3482 if (model_print_deferred(s->cmd->opt)) {
3483 err = moderr;
3484 } else {
3485 errmsg(moderr, s->prn);
3486 }
3487 } else if (model_print_deferred(s->cmd->opt)) {
3488 MODEL *pmod = get_model_record_by_line(loop, j, &err);
3489
3490 if (!err) {
3491 swap_models(s->model, pmod);
3492 pmod->ID = j + 1;
3493 set_as_last_model(pmod, GRETL_OBJ_EQN);
3494 model_count_minus(NULL);
3495 }
3496 } else {
3497 loop_print_save_model(s->model, dset, s->prn, s);
3498 }
3499
3500 return err;
3501 }
3502
3503 #endif /* !HAVE_GMP */
3504
maybe_preserve_loop(LOOPSET * loop)3505 static int maybe_preserve_loop (LOOPSET *loop)
3506 {
3507 if (loop_err_caught(loop)) {
3508 return 0;
3509 }
3510
3511 if (!loop_is_attached(loop) && gretl_function_depth() > 0) {
3512 if (gretl_iteration_depth() > 0 || gretl_looping()) {
3513 int err = attach_loop_to_function(loop);
3514
3515 if (!err) {
3516 loop_set_attached(loop);
3517 #if GLOBAL_TRACE
3518 fprintf(stderr, "loop %p attached to function\n",
3519 (void *) loop);
3520 #endif
3521 }
3522 }
3523 }
3524
3525 return loop_is_attached(loop);
3526 }
3527
3528 /* loop_reset_uvars(): called on exit from a function onto
3529 which one or more "compiled" loops have been attached.
3530 The point is to reset to NULL the stored addresses of
3531 any "uservars" that have been recorded in the context
3532 of the loop, since in general on a subsequent invocation
3533 of the function a variable of a given name will occupy a
3534 different memory address. A reset to NULL will force a
3535 new lookup of these variables by name, both within "genr"
3536 and within the loop machinery.
3537 */
3538
loop_reset_uvars(LOOPSET * loop)3539 void loop_reset_uvars (LOOPSET *loop)
3540 {
3541 int i;
3542
3543 for (i=0; i<loop->n_children; i++) {
3544 loop_reset_uvars(loop->children[i]);
3545 }
3546
3547 /* stored references within "genrs" */
3548 if (loop->cmds != NULL) {
3549 for (i=0; i<loop->n_cmds; i++) {
3550 if (loop->cmds[i].genr != NULL) {
3551 genr_reset_uvars(loop->cmds[i].genr);
3552 }
3553 }
3554 }
3555
3556 /* stored refs in controllers? */
3557 if (loop->test.genr != NULL) {
3558 genr_reset_uvars(loop->test.genr);
3559 }
3560 if (loop->delta.genr != NULL) {
3561 genr_reset_uvars(loop->delta.genr);
3562 }
3563
3564 /* other (possibly) stored references */
3565 loop->idxvar = NULL;
3566 loop->init.uv = NULL;
3567 loop->final.uv = NULL;
3568 }
3569
abort_loop_execution(ExecState * s)3570 static void abort_loop_execution (ExecState *s)
3571 {
3572 *s->cmd->savename = '\0';
3573 gretl_cmd_destroy_context(s->cmd);
3574 errmsg(E_STOP, s->prn);
3575 }
3576
block_model(CMD * cmd)3577 static int block_model (CMD *cmd)
3578 {
3579 return cmd->ci == END &&
3580 (!strcmp(cmd->param, "mle") ||
3581 !strcmp(cmd->param, "nls") ||
3582 !strcmp(cmd->param, "gmm"));
3583 }
3584
3585 #if HAVE_GMP
3586
3587 #define not_ok_in_progloop(c) (NEEDS_MODEL_CHECK(c) || \
3588 c == NLS || \
3589 c == MLE || \
3590 c == GMM)
3591
handle_prog_command(LOOPSET * loop,int j,CMD * cmd,int * err)3592 static int handle_prog_command (LOOPSET *loop, int j,
3593 CMD *cmd, int *err)
3594 {
3595 int handled = 0;
3596
3597 if (cmd->ci == PRINT && !loop_literal(loop, j)) {
3598 if (prog_cmd_started(loop, j)) {
3599 *err = loop_print_update(loop, j, NULL);
3600 } else {
3601 *err = loop_print_update(loop, j, cmd->parm2);
3602 }
3603 handled = 1;
3604 } else if (cmd->ci == STORE) {
3605 if (prog_cmd_started(loop, j)) {
3606 *err = loop_store_update(loop, j, NULL, NULL, 0);
3607 } else {
3608 *err = loop_store_update(loop, j, cmd->parm2, cmd->param,
3609 cmd->opt);
3610 }
3611 handled = 1;
3612 } else if (not_ok_in_progloop(cmd->ci)) {
3613 gretl_errmsg_sprintf(_("%s: not implemented in 'progressive' loops"),
3614 gretl_command_word(cmd->ci));
3615 *err = 1;
3616 handled = 1;
3617 }
3618
3619 return handled;
3620 }
3621
3622 #endif /* HAVE_GMP */
3623
3624 #define LTRACE 0
3625
gretl_loop_exec(ExecState * s,DATASET * dset,LOOPSET * loop)3626 int gretl_loop_exec (ExecState *s, DATASET *dset, LOOPSET *loop)
3627 {
3628 char *line = s->line;
3629 CMD *cmd = s->cmd;
3630 PRN *prn = s->prn;
3631 char *currline = NULL;
3632 char *showline = NULL;
3633 int indent0;
3634 int gui_mode, echo;
3635 int show_activity = 0;
3636 int prev_messages;
3637 #if HAVE_GMP
3638 int progressive;
3639 #endif
3640 int err = 0;
3641
3642 if (loop == NULL) {
3643 loop = currloop;
3644 } else {
3645 currloop = loop;
3646 }
3647
3648 /* for the benefit of the caller: register the fact that execution
3649 of this loop is already under way */
3650 loop_execute = 0;
3651
3652 if (loop == NULL) {
3653 pputs(prn, "Got a NULL loop\n");
3654 set_loop_off();
3655 return 1;
3656 }
3657
3658 gui_mode = gretl_in_gui_mode();
3659 echo = gretl_echo_on();
3660 prev_messages = gretl_messages_on();
3661 if (!prev_messages && loop_is_verbose(loop)) {
3662 set_gretl_messages(1);
3663 }
3664 indent0 = gretl_if_state_record();
3665 set_loop_on();
3666 #if HAVE_GMP
3667 progressive = loop_is_progressive(loop);
3668 #endif
3669
3670 #if LOOP_DEBUG
3671 fprintf(stderr, "loop_exec: loop = %p\n", (void *) loop);
3672 #endif
3673
3674 err = top_of_loop(loop, dset);
3675
3676 if (!err) {
3677 if (loop_is_renaming(loop)) {
3678 loop_renaming = 1;
3679 }
3680 if (gui_mode) {
3681 show_activity = show_activity_func_installed();
3682 }
3683 }
3684
3685 while (!err && loop_condition(loop, dset, &err)) {
3686 /* respective iterations of a given loop */
3687 int j;
3688
3689 #if LOOP_DEBUG > 1
3690 fprintf(stderr, "*** top of loop: iter = %d\n", loop->iter);
3691 #endif
3692 if (gui_mode && loop->iter % 10 == 0 && check_for_stop()) {
3693 /* the GUI user clicked the "Stop" button */
3694 abort_loop_execution(s);
3695 err = E_STOP;
3696 break;
3697 }
3698
3699 for (j=0; j<loop->n_cmds && !err; j++) {
3700 /* exec commands on this iteration */
3701 int ci = loop->cmds[j].ci;
3702 int compiled = is_compiled(loop, j);
3703 int parse = 1;
3704 int subst = 0;
3705
3706 currline = loop->cmds[j].line;
3707 if (compiled) {
3708 /* just for "echo" purposes */
3709 showline = currline;
3710 } else {
3711 /* line may be modified below */
3712 showline = strcpy(line, currline);
3713 }
3714
3715 #if LTRACE || (LOOP_DEBUG > 1)
3716 fprintf(stderr, "iter=%d, j=%d, line='%s', ci=%d (%s), compiled=%d\n",
3717 loop->iter, j, showline, ci, gretl_command_word(ci),
3718 compiled);
3719 #endif
3720
3721 if (loop_has_cond(loop) && gretl_if_state_false()) {
3722 /* The only ways out of a blocked state are
3723 via ELSE, ELIF or ENDIF, and the only
3724 commands we need assess are the foregoing
3725 plus IF.
3726 */
3727 if (ci == ELSE || ci == ENDIF) {
3728 cmd->ci = ci;
3729 cmd->err = 0;
3730 flow_control(s, NULL, NULL);
3731 if (cmd->err) {
3732 err = cmd->err;
3733 goto handle_err;
3734 } else {
3735 continue;
3736 }
3737 } else if (ci == IF || ci == ELIF) {
3738 goto cond_next;
3739 } else {
3740 continue;
3741 }
3742 }
3743
3744 if (ci == BREAK || ci == LOOP) {
3745 /* no parsing needed */
3746 cmd->ci = ci;
3747 if (ci == BREAK) {
3748 loop->brk = 1;
3749 break;
3750 } else if (ci == LOOP) {
3751 goto child_loop;
3752 }
3753 }
3754
3755 if (genr_compiled(loop, j)) {
3756 /* no parsing needed */
3757 if (echo && loop_is_verbose(loop)) {
3758 pprintf(prn, "? %s\n", showline);
3759 }
3760 err = execute_genr(loop->cmds[j].genr, dset, prn);
3761 if (err) {
3762 goto handle_err;
3763 } else {
3764 continue;
3765 }
3766 }
3767
3768 cond_next:
3769
3770 if (!loop_cmd_nodol(loop, j)) {
3771 if (strchr(line, '$')) {
3772 /* handle loop-specific $-string substitution */
3773 err = make_dollar_substitutions(line, MAXLINE, loop,
3774 dset, &subst, OPT_NONE);
3775 if (err) {
3776 break;
3777 } else if (!subst) {
3778 loop->cmds[j].flags |= LOOP_CMD_NODOL;
3779 }
3780 } else {
3781 loop->cmds[j].flags |= LOOP_CMD_NODOL;
3782 }
3783 }
3784
3785 /* transcribe saved loop info -> cmd */
3786 loop_info_to_cmd(loop, j, cmd);
3787
3788 if (cond_compiled(loop, j)) {
3789 /* compiled IF or ELIF */
3790 cmd->ci = ci;
3791 flow_control(s, dset, &loop->cmds[j].genr);
3792 if (cmd->err) {
3793 /* we hit an error evaluating the if state */
3794 err = cmd->err;
3795 } else {
3796 cmd->ci = CMD_MASKED;
3797 }
3798 parse = 0;
3799 } else if (ends_condition(loop, j)) {
3800 /* plain ELSE or ENDIF */
3801 cmd->ci = ci;
3802 flow_control(s, NULL, NULL);
3803 if (cmd->err) {
3804 err = cmd->err;
3805 } else {
3806 cmd->ci = CMD_MASKED;
3807 }
3808 parse = 0;
3809 } else if (do_compile_conditional(loop, j)) {
3810 GENERATOR *ifgen = NULL;
3811
3812 err = parse_command_line(s, dset, &ifgen);
3813 if (ifgen != NULL) {
3814 loop->cmds[j].genr = ifgen;
3815 loop->cmds[j].flags |= LOOP_CMD_COND;
3816 }
3817 parse = 0;
3818 } else if (prog_cmd_started(loop, j)) {
3819 cmd->ci = ci;
3820 if (loop->cmds[j].flags & LOOP_CMD_NOSUB) {
3821 parse = 0;
3822 }
3823 }
3824
3825 if (parse && !err) {
3826 err = parse_command_line(s, dset, NULL);
3827 #if LOOP_DEBUG > 1
3828 fprintf(stderr, " after: '%s', ci=%d\n", line, cmd->ci);
3829 fprintf(stderr, " cmd->savename = '%s'\n", cmd->savename);
3830 fprintf(stderr, " err from parse_command_line: %d\n", err);
3831 #endif
3832 }
3833
3834 handle_err:
3835
3836 if (err) {
3837 cmd_info_to_loop(loop, j, cmd, &subst);
3838 cmd->err = err = loop_process_error(loop, j, err, prn);
3839 if (err) {
3840 break;
3841 } else {
3842 continue;
3843 }
3844 } else if (cmd->ci < 0) {
3845 /* blocked/masked */
3846 if (ci == IF || ci == ELIF) {
3847 cmd_info_to_loop(loop, j, cmd, &subst);
3848 }
3849 continue;
3850 } else {
3851 gretl_exec_state_transcribe_flags(s, cmd);
3852 cmd_info_to_loop(loop, j, cmd, &subst);
3853 }
3854
3855 if (echo) {
3856 if (s->cmd->ci == ENDLOOP) {
3857 if (indexed_loop(loop)) {
3858 pputc(prn, '\n');
3859 }
3860 } else if (loop_is_verbose(loop)) {
3861 gretl_echo_command(cmd, showline, prn);
3862 }
3863 }
3864
3865 /* now branch based on the command index: some commands
3866 require special treatment in loop context
3867 */
3868
3869 child_loop:
3870
3871 if (cmd->ci == LOOP) {
3872 currloop = get_child_loop_by_line(loop, j);
3873 if (currloop == NULL) {
3874 currloop = loop;
3875 fprintf(stderr, "Got a LOOP command, don't know what to do!\n");
3876 err = 1;
3877 } else {
3878 if (loop_is_attached(loop)) {
3879 loop_set_attached(currloop);
3880 }
3881 err = gretl_loop_exec(s, dset, NULL);
3882 }
3883 } else if (cmd->ci == BREAK) {
3884 loop->brk = 1;
3885 break;
3886 } else if (cmd->ci == FUNCRET) {
3887 /* The following clause added 2016-11-20: just in case
3888 the return value is, or references, an automatic
3889 loop index scalar.
3890 */
3891 loop->flags &= ~LOOP_DELVAR;
3892 err = set_function_should_return(line);
3893 loop->brk = 1;
3894 break;
3895 } else if (cmd->ci == ENDLOOP) {
3896 ; /* implicit break */
3897 } else if (cmd->ci == GENR) {
3898 if (subst || (loop->cmds[j].flags & LOOP_CMD_NOEQ)) {
3899 /* We can't use a "compiled" genr if string substitution
3900 has been done, since the genr expression will not
3901 be constant; in addition we can't compile if the
3902 genr command is a non-equation special such as
3903 "genr time".
3904 */
3905 if (!loop_is_verbose(loop)) {
3906 cmd->opt |= OPT_Q;
3907 }
3908 err = generate(cmd->vstart, dset, cmd->gtype, cmd->opt, prn);
3909 } else {
3910 err = add_loop_genr(loop, j, cmd, dset, prn);
3911 if (loop->cmds[j].genr == NULL && !err) {
3912 /* fallback */
3913 loop->cmds[j].flags |= LOOP_CMD_NOEQ;
3914 err = generate(cmd->vstart, dset, cmd->gtype,
3915 cmd->opt, prn);
3916 }
3917 }
3918 } else if (cmd->ci == DELEET && !(cmd->opt & (OPT_F | OPT_T))) {
3919 err = loop_delete_object(loop, cmd, prn);
3920 #if HAVE_GMP
3921 } else if (progressive && handle_prog_command(loop, j, cmd, &err)) {
3922 ; /* OK, or not */
3923 #endif
3924 } else {
3925 /* send command to the regular processor */
3926 int catch = cmd->flags & CMD_CATCH;
3927
3928 if (cmd->ci == DELEET && cmd->param != NULL) {
3929 /* don't delete loop indices! */
3930 err = loop_check_deletion(loop, cmd->param, prn);
3931 }
3932 if (!err) {
3933 err = gretl_cmd_exec(s, dset);
3934 }
3935 if (catch) {
3936 /* ensure "catch" hasn't been scrubbed */
3937 cmd->flags |= CMD_CATCH;
3938 }
3939 if (!err && plain_model_ci(cmd->ci)) {
3940 err = model_command_post_process(s, dset, loop, j);
3941 } else if (!err && !check_gretl_errno() && block_model(cmd)) {
3942 /* NLS, etc. */
3943 loop_print_save_model(s->model, dset, prn, s);
3944 }
3945 }
3946 if (err && (cmd->flags & CMD_CATCH)) {
3947 set_gretl_errno(err);
3948 cmd->flags ^= CMD_CATCH;
3949 err = 0;
3950 }
3951 } /* end execution of commands within loop */
3952
3953 if (err) {
3954 gretl_if_state_clear();
3955 } else if (loop->brk) {
3956 gretl_if_state_reset(indent0);
3957 } else {
3958 err = gretl_if_state_check(indent0);
3959 }
3960
3961 if (!err && !loop->brk) {
3962 loop->iter += 1;
3963 if (show_activity && (loop->iter % 10 == 0)) {
3964 show_activity_callback();
3965 }
3966 }
3967
3968 if (err && inner_errline == NULL) {
3969 inner_errline = gretl_strdup(currline);
3970 }
3971 } /* end iterations of loop */
3972
3973 cmd->flags &= ~CMD_NOSUB;
3974
3975 if (loop->brk) {
3976 /* turn off break flag */
3977 loop->brk = 0;
3978 }
3979
3980 if (err || loop->err) {
3981 err = loop_report_error(loop, err, currline, s, prn);
3982 }
3983
3984 if (!err && loop->iter > 0) {
3985 print_loop_results(loop, dset, prn);
3986 }
3987
3988 if (loop->n_models > 0) {
3989 /* we need to update models[0] */
3990 GretlObjType type;
3991 void *ptr = get_last_model(&type);
3992 int i;
3993
3994 if (type == GRETL_OBJ_EQN && s->model != ptr) {
3995 swap_models(s->model, loop->models[loop->n_models - 1]);
3996 set_as_last_model(s->model, GRETL_OBJ_EQN);
3997 }
3998 for (i=0; i<loop->n_models; i++) {
3999 gretl_model_unprotect(loop->models[i]);
4000 gretl_model_free(loop->models[i]);
4001 }
4002 }
4003
4004 if (err && gretl_function_depth() > 0) {
4005 ; /* leave 'line' alone */
4006 } else if (line != NULL) {
4007 *line = '\0';
4008 }
4009
4010 /* be sure to clear some loop-special parser flags */
4011 cmd->flags &= ~CMD_PROG;
4012
4013 if (err) {
4014 err = process_command_error(s, err);
4015 }
4016
4017 set_gretl_messages(prev_messages);
4018
4019 if (loop->parent == NULL) {
4020 /* reached top of stack: clean up */
4021 currloop = NULL;
4022 loop_renaming = 0;
4023 set_loop_off();
4024 loop_reset_error();
4025 if (!err && maybe_preserve_loop(loop)) {
4026 /* prevent destruction of saved loop */
4027 loop = NULL;
4028 }
4029 gretl_loop_destroy(loop);
4030 }
4031
4032 return err;
4033 }
4034