"Fossies" - the Fresh Open Source Software Archive

Member "gretl-2020b/lib/src/monte_carlo.c" (17 Mar 2020, 92720 Bytes) of package /linux/misc/gretl-2020b.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "monte_carlo.c" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 2020a_vs_2020b.

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