"Fossies" - the Fresh Open Source Software Archive

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