Logo Search packages:      
Sourcecode: gretl version File versions  Download package

gretl_func.c

/*
 *  Copyright (c) 2005 by Allin Cottrell
 *
 *   This program is free software; you can redistribute it and/or modify
 *   it under the terms of the GNU General Public License as published by
 *   the Free Software Foundation; either version 2 of the License, or
 *   (at your option) any later version.
 *
 *   This program is distributed in the hope that it will be useful,
 *   but WITHOUT ANY WARRANTY; without even the implied warranty of
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *   GNU General Public License for more details.
 *
 *   You should have received a copy of the GNU General Public License
 *   along with this program; if not, write to the Free Software
 *   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 */

#include "libgretl.h"
#include "gretl_func.h"
#include "libset.h"

#define CALLSTACK_DEPTH 8

#define FN_DEBUG 0

typedef struct ufunc_ ufunc;
typedef struct fncall_ fncall;

#define FN_NAMELEN 32

enum {
    ARG_SCALAR = 1,
    ARG_SERIES,
    ARG_LIST
};

struct ufunc_ {
    char name[FN_NAMELEN];
    int n_lines;
    char **lines;
    int n_returns;
    char **returns;
    char *rtype;
    int n_params;
    char **params;
    char *ptype;
};

struct fncall_ {
    ufunc *fun;
    int lnum;
    int argc;
    char **argv;
    char **assv;
    int *asslist;
};

static int n_ufuns;
static ufunc **ufuns;

static fncall **callstack;

static void free_fncall (fncall *call);

/* record of state, and communication of state with outside world */

static int compiling;
static int fn_executing;

int gretl_compiling_function (void)
{
    return compiling;
}

static void set_compiling_on (void)
{
    compiling = 1;
}

static void set_compiling_off (void)
{
    compiling = 0;
}

int gretl_executing_function (void)
{
    return fn_executing;
}

static void set_executing_on (fncall *call)
{
    fn_executing++;
#if FN_DEBUG
    fprintf(stderr, "set_executing_on: fun=%s, fn_executing=%d\n", 
          call->fun->name, fn_executing);
#endif
}

static void set_executing_off (fncall *call)
{
    fn_executing--;
#if FN_DEBUG
    fprintf(stderr, "set_executing_off: fun=%s, fn_executing=%d\n",
          call->fun->name, fn_executing);
#endif
}

/* function call stack mechanism */

static int callstack_init (void)
{
    int i, err = 0;

    if (callstack != NULL) {
      return 0;
    }

    callstack = malloc(CALLSTACK_DEPTH * sizeof *callstack);
    if (callstack == NULL) {
      err = E_ALLOC;
    } else {
      for (i=0; i<CALLSTACK_DEPTH; i++) {
          callstack[i] = NULL;
      }
    }

    return err;
}

static void callstack_destroy (void)
{
    int i;

    if (callstack != NULL) {
      for (i=0; i<CALLSTACK_DEPTH; i++) {
          if (callstack[i] != NULL) {
            free_fncall(callstack[i]);
          }
      }
    }

    free(callstack);
    callstack = NULL;
}

static int real_gretl_function_stack_depth (void)
{
    int i, n = 0;

    if (callstack == NULL) {
      callstack_init();
    }

    if (callstack != NULL) {
      for (i=0; i<CALLSTACK_DEPTH; i++) {
          if (callstack[i] != NULL) n++;
          else break;
      }
    }

    return n;
}

int gretl_function_stack_depth (void)
{
    return real_gretl_function_stack_depth();
}

static int push_fncall (fncall *call, const DATAINFO *pdinfo)
{
    int i, nc;

    if (callstack == NULL && callstack_init()) {
      return E_ALLOC;
    }

    nc = gretl_function_stack_depth();
    if (nc == CALLSTACK_DEPTH) {
      strcpy(gretl_errmsg, "Function call stack depth exceeded");
      return 1;
    }

    for (i=nc; i>0; i--) {
      callstack[i] = callstack[i-1];
    } 

    callstack[0] = call;

    set_executing_on(call);
    push_program_state(pdinfo);

    return 0;
}

static int on_returns_list (const char *vname, char **returns, int n_returns)
{
    int k, ret = 0;

    for (k=0; k<n_returns; k++) {
      if (!strcmp(vname, returns[k])) {
#if FN_DEBUG
          fprintf(stderr, "%s: this var is wanted\n", vname);
#endif
          ret = 1;
          break;
      }
    }

    return ret;
}

static void copy_values_to_assignee (int targ, int src, double **Z, 
                             const DATAINFO *pdinfo)
{
    int t, n = (pdinfo->vector[targ])? pdinfo->n : 1;

    for (t=0; t<n; t++) {
      Z[targ][t] = Z[src][t];
    }
}

static int 
destroy_or_assign_local_vars (fncall *call, double ***pZ, DATAINFO *pdinfo, 
                        int nc)
{
    int *locals = NULL;
    int nlocal = 0;
    int i, j, v;
    int anyerr = 0;
    int err = 0;

    for (i=1; i<pdinfo->v; i++) {
      if (STACK_LEVEL(pdinfo, i) == nc) {
          nlocal++;
      }
    }

    if (nlocal > 0) {
      locals = gretl_list_new(nlocal);
      if (locals == NULL) {
          err = E_ALLOC;
      } else {
          locals[0] = 0;
      }
    } 

    if (nlocal == 0 || err) {
      destroy_saved_lists_at_level(nc);
      return err;
    }

    v = 0;
    j = 1;

    /* now check for any local variables generated within the
       function: if they are on the return list and wanted by the
       caller, process them appropriately, otherwise tag them for
       deletion then delete them in a batch
    */

    for (i=1; i<pdinfo->v; i++) {
      int cv, saveit = 0;

      if (STACK_LEVEL(pdinfo, i) != nc) {
          continue;
      }

      if (v < call->asslist[0]) {
          saveit = on_returns_list(pdinfo->varname[i], call->fun->returns,
                             call->fun->n_returns);
      } 

      if (saveit) {
          /* does a variable of this name already exist at caller level? */
          cv = call->asslist[v+1];
#if FN_DEBUG
          fprintf(stderr, " wanted by caller as '%s' (#%d)\n", call->assv[v], cv);
#endif
          if (cv > 0) {
            copy_values_to_assignee(cv, i, *pZ, pdinfo);
            saveit = 0;
          } else {
            /* rename variable as caller desired: mark for preservation */
            strcpy(pdinfo->varname[i], call->assv[v]);
            STACK_LEVEL(pdinfo, i) -= 1; 
          }
          v++;
      }

      if (!saveit) {
#if FN_DEBUG
          fprintf(stderr, "local variable %d (%s) tagged for deletion\n", 
                i, pdinfo->varname[i]);
#endif
          locals[j++] = i;
          locals[0] += 1;
      }
    }

    anyerr = dataset_drop_listed_variables(locals, pZ, pdinfo, NULL);
    if (anyerr && !err) {
      err = anyerr;
    }

    free(locals);

    anyerr = destroy_saved_lists_at_level(nc);
    if (anyerr && !err) {
      err = anyerr;
    }

#if FN_DEBUG
    fprintf(stderr, "destroy_or_assign_local_vars: returning err = %d\n", err);
#endif

    return err;
}

static int unstack_fncall (double ***pZ, DATAINFO *pdinfo)
{
    fncall *call;   
    int i, nc;
    int err = 0;

    if (callstack == NULL) {
      return 1;
    }
    
    call = callstack[0];

    nc = gretl_function_stack_depth();

#if FN_DEBUG
    fprintf(stderr, "unstack_fncall: terminating call to "
          "function '%s' at depth %d\n", 
          call->fun->name, nc);
#endif

    err = destroy_or_assign_local_vars(call, pZ, pdinfo, nc);

    set_executing_off(call);
    pop_program_state(pdinfo);

    free_fncall(call);

    for (i=0; i<nc; i++) {
      if (i == nc - 1) {
          callstack[i] = NULL;
      } else {
          callstack[i] = callstack[i+1];
      }
    }

    return err;
}

static int function_is_on_stack (ufunc *func)
{
    int i;

    if (callstack != NULL) {
      for (i=0; i<CALLSTACK_DEPTH; i++) {
          if (callstack[i] == NULL) {
            break;
          }
          if ((callstack[i])->fun == func) {
            return 1;
          }
      }
    }

    return 0;
}

static fncall *current_call (void)
{
    if (callstack == NULL) {
      return NULL;
    } else {
      return callstack[0];
    }
}

/* constructors */

static ufunc *ufunc_new (void)
{
    ufunc *func = malloc(sizeof *func);

    if (func == NULL) {
      return NULL;
    }

    func->name[0] = '\0';

    func->n_lines = 0;
    func->lines = NULL;

    func->n_returns = 0;
    func->returns = NULL;
    func->rtype = NULL;

    func->n_params = 0;
    func->params = NULL;
    func->ptype = NULL;

    return func;
}

static fncall *fncall_new (ufunc *fun, int argc, char **argv,
                     int *asslist, char **assv)
{
    fncall *call = malloc(sizeof *call);

    if (call == NULL) {
      free_strings_array(argv, argc);
      free_strings_array(assv, asslist[0]);
      free(asslist);
      return NULL;
    }

    call->fun = fun;
    call->lnum = 0;

    call->argc = argc;
    call->argv = argv;

    call->asslist = asslist;
    call->assv = assv;

    return call;
}

static ufunc *add_ufunc (void)
{
    int nf = n_ufuns;
    ufunc **myfuns;

    myfuns = realloc(ufuns, (nf + 1) * sizeof *myfuns);
    if (myfuns == NULL) {
      return NULL;
    }
    ufuns = myfuns;

    ufuns[nf] = ufunc_new();
    if (ufuns[nf] == NULL) {
      return NULL;
    }

    n_ufuns++;

    return ufuns[nf];
}

/* destructors */

static void free_ufunc (ufunc *fun)
{
    free_strings_array(fun->lines, fun->n_lines);
    free_strings_array(fun->returns, fun->n_returns);
    free_strings_array(fun->params, fun->n_params);
    free(fun->ptype);
    free(fun->rtype);

    free(fun);
}

static void ufuncs_destroy (void)
{
    int i;

    for (i=0; i<n_ufuns; i++) {
      free_ufunc(ufuns[i]);
    }
    free(ufuns);

    ufuns = NULL;
    n_ufuns = 0;
}

static void free_fncall (fncall *call)
{
    free_strings_array(call->argv, call->argc);
    free_strings_array(call->assv, call->asslist[0]);
    free(call->asslist);

    free(call);
}

static ufunc *get_ufunc_by_name (const char *name)
{
    ufunc *fun = NULL;
    int i;

    for (i=0; i<n_ufuns; i++) {
      if (!strcmp(name, (ufuns[i])->name)) {
          fun = ufuns[i];
          break;
      }
    }

#if FN_DEBUG
    if (fun != NULL) {
      fprintf(stderr, "get_ufunc_by_name: name = '%s' (n_ufuns = %d);"
            " found match\n", name, n_ufuns);
    }
#endif

    return fun;
}

static char *function_name_from_line (const char *line, char *name)
{
    if (*line == '#' || !strncmp(line, "(*", 2)) {
      *name = '\0';
    } else {
      const char *p = strchr(line, '=');
      char *q;

      if (p == NULL) {
          p = line;
      } else {
          p++;
      }

      sscanf(p, "%31s", name);
      q = strchr(name, '(');
      if (q != NULL) {
          *q = 0;
      }
#if FN_DEBUG
      fprintf(stderr, "function_name_from_line: got '%s'\n", name);
#endif
    }

    return name;
}

int gretl_is_user_function (const char *line)
{
    int ret = 0;

    if (n_ufuns > 0 && !string_is_blank(line)) {
      char name[FN_NAMELEN];

#if FN_DEBUG > 1
      fprintf(stderr, "gretl_is_user_function: testing '%s'\n", line);
#endif
      function_name_from_line(line, name);
      if (get_ufunc_by_name(name) != NULL) {
          ret = 1;
      }
    }

    return ret;
}

static void delete_ufunc_from_list (ufunc *fun)
{
    if (n_ufuns == 0 || fun == NULL) {
      /* "can't happen" */
      return;
    }

    if (n_ufuns == 1) {
      free_ufunc(fun);
      free(ufuns);
      ufuns = NULL;
      n_ufuns = 0;
    } else {
      int i, gotit = 0;

      for (i=0; i<n_ufuns; i++) {
          if (gotit) {
            ufuns[i-1] = ufuns[i];
          }
          if (!gotit && ufuns[i] == fun) {
            gotit = 1;
            free_ufunc(fun);
          }
      }
      
      ufuns = realloc(ufuns, (n_ufuns - 1) * sizeof *ufuns);
      n_ufuns--;
    }
}

static int check_func_name (const char *fname)
{
    int i, err = 0;

    if (!isalpha((unsigned char) *fname)) {
      strcpy(gretl_errmsg, "function names must start with a letter");
      err = 1;
    } else if (gretl_command_number(fname)) {
      sprintf(gretl_errmsg, "'%s' is the name of a gretl command",
            fname);
      err = 1;
    } else {
      for (i=0; i<n_ufuns && !err; i++) {
          if (!strcmp(fname, (ufuns[i])->name)) {
            sprintf(gretl_errmsg, "'%s': function is already defined",
                fname);
            err = 1;
          }
      }
    }

    return err;
}

/* Parse line and return an allocated array of strings consisting of
   the space- or comma-separated fields in line, each one truncated if
   necessary to a maximum of maxlen characters.
*/ 

static char **
get_separated_fields (const char *line, int *nfields, int maxlen)
{
    char fmt[8];
    char **fields = NULL;
    char *cpy, *s;
    char str[9];
    int i, j, nf, err = 0;

    *nfields = 0;

    if (string_is_blank(line)) {
      return NULL;
    }

    cpy = gretl_strdup(line);
    if (cpy == NULL) {
      return NULL;
    }

    /* clean the string up */
    s = cpy;
    s += strspn(s, " ");
    if (*s == '(') {
      s++;
    }
    tailstrip(s);
    j = strlen(s);
    if (s[j-1] == ')') {
      s[j-1] = '\0';
    }    

    charsub(s, ',', ' ');

    nf = count_fields(s);
    fields = malloc(nf * sizeof *fields);
    if (fields == NULL) {
      free(s);
      return NULL;
    }

    sprintf(fmt, "%%%ds", maxlen);

    for (i=0; i<nf && !err; i++) {
      sscanf(s, fmt, str);
      fields[i] = gretl_strdup(str);
      if (fields[i] == NULL) {
          for (j=0; j<i; j++) {
            free(fields[j]);
          }
          free(fields);
          fields = NULL;
          err = 1;
      } else {
          s += strcspn(s, " ");
          s += strspn(s, " ");
      }
    }

    if (!err) {
      *nfields = nf;
    }

    free(cpy);

    return fields;
}

static int 
parse_function_args_etc (const char *s, int *argc, char ***pargv,
                   int **asslist, char ***passv)
{
    char **argv = NULL;
    char **assign = NULL;
    const char *p;
    int na = 0, err = 0;

    *argc = 0;
    *pargv = NULL;
    *passv = NULL;

    if ((p = strchr(s, '=')) != NULL && *s != '=') {
      char *astr = gretl_strndup(s, p - s);

      /* seems we have a left-hand side assignment */
      assign = get_separated_fields(astr, &na, 8);
      if (assign == NULL) {
          err = E_ALLOC;
      } 
      free(astr);
      s = p + 1;
    } else {
      s++;
    }

    if (na > 0) {
      *asslist = gretl_list_new(na);
    } else {
      *asslist = gretl_null_list();
    }

    if (asslist == NULL) {
      err = E_ALLOC;
      free_strings_array(assign, na);
    } else {
      *passv = assign;
    }

    if (!err) {
      /* skip over function name and spaces before args,
         or deal with the case where the args are parenthesized
      */
      const char *p = strchr(s, '(');

      if (p != NULL) {
          s = p;
      } else {
          s += strspn(s, " ");
          s += strcspn(s, " ");
          s += strspn(s, " ");
      }

      if (*s != '\0') {
#if FN_DEBUG
          fprintf(stderr, "function_args: looking at '%s'\n", s);
#endif
          argv = get_separated_fields(s, &na, 32);
          if (argv == NULL) {
            err = 1;
          } else {
            *pargv = argv;
            *argc = na;
          }
      }
    }

    return err;
}

static int maybe_delete_function (const char *fname)
{
    ufunc *fun = get_ufunc_by_name(fname);
    int err = 0;

    if (fun == NULL) {
      ; /* no-op */
    } else if (function_is_on_stack(fun)) {
      sprintf(gretl_errmsg, "%s: function is in use", fname);
      err = 1;
    } else {
      delete_ufunc_from_list(fun);
    } 

    return err;
}

static int get_param_type (const char *s)
{
    int ret = 0;

    if (!strcmp(s, "scalar")) {
      ret = ARG_SCALAR;
    } else if (!strcmp(s, "series")) {
      ret = ARG_SERIES;
    } else if (!strcmp(s, "list")) {
      ret = ARG_LIST;
    }

    return ret;
}

static int comma_count (const char *s)
{
    int nc = 0;

    while (*s) {
      if (*s == ',') nc++;
      s++;
    }

    return nc;
}

static int allocate_parmv_ptype (char ***pparmv, char **pptype, int n)
{
    char **parmv;
    char *ptype;
    int err = 0;

    parmv = create_strings_array(n);
    if (parmv == NULL) {
      err = E_ALLOC;
    }

    if (!err) {
      ptype = malloc(n * sizeof *ptype);
      if (ptype == NULL) {
          free(parmv);
          err = E_ALLOC;
      }
    }

    if (!err) {
      *pparmv = parmv;
      *pptype = ptype;
    }

    return err;
}

enum {
    FN_PARAMS,
    FN_RETURNS
};

static int parse_fn_element (char *s, char **parmv, char *ptype, int i,
                       int which)
{
    char tstr[8] = {0};
    int n, len;
    int err = 0;

    while (isspace((unsigned char) *s)) s++;
    len = strcspn(s, " ");
    if (len < 7) {
      n = len;
    } else {
      n = 7;
    }

    strncat(tstr, s, n);
    ptype[i] = get_param_type(tstr);
    if (ptype[i] == 0) {
      sprintf(gretl_errmsg, "Unrecognized data type '%s'", tstr);
      err = E_PARSE;
    } else if (ptype[i] == ARG_LIST && which == FN_RETURNS) {
      /* FIXME? */
      strcpy(gretl_errmsg, "A function cannot return a list");
      err = 1;
    }

    if (!err) {
      s += len;
      while (isspace((unsigned char) *s)) s++;
      len = strcspn(s, " ");
      if (len == 0) {
          if (which == FN_PARAMS) {
            sprintf(gretl_errmsg, "parameter %d: name is missing", i);
          } else {
            sprintf(gretl_errmsg, "return value %d: name is missing", i);
          }
          err = E_PARSE;
      }
    }

    if (!err) {
      if (len < 31) {
          n = len;
      } else {
          n = 31;
      }
      parmv[i] = gretl_strndup(s, n);
      if (parmv[i] == NULL) {
          err = E_ALLOC;
      }
    }

#if FN_DEBUG
    if (!err) {
      fprintf(stderr, " %s[%d] = '%s', ptype = %d\n", 
            (which == FN_PARAMS)? "parm" : "ret",
            i, parmv[i], ptype[i]);
    }
#endif

    return err;
}

static int 
parse_fn_definition_or_returns (char *fname, char ***pparmv, int *pnp,
                        char **pptype, const char *str)
{
    char **parmv = NULL;
    char *ptype = NULL;
    char *p, *s = NULL;
    int i, len, np = 0;
    int which, err = 0;

    if (fname != NULL) {
      which = FN_PARAMS;
    } else {
      which = FN_RETURNS;
    }

    while (isspace((unsigned char) *str)) str++;

    if (which == FN_PARAMS) {
      char fmt[8] = "%31s";

      /* get the function name */
      len = strcspn(str, " (");
      if (len == 0) {
          err = E_PARSE;
      } else if (len < FN_NAMELEN -1) {
          sprintf(fmt, "%%%ds", len);
      }
      if (!err) {
          if (sscanf(str, fmt, fname) != 1) {
            err = E_PARSE;
          }
      }
      if (!err) {
          err = check_func_name(fname);
      }
      if (!err) {
          str += len;
      }
    }

    /* move to next bit and make a copy */
    if (!err) {
      str += strspn(str, " (");
      if (*str == 0) {
          err = E_PARSE;
      } else {
          s = gretl_strdup(str);
          if (s == NULL) {
            err = E_ALLOC;
          }
      }
    }

    if (!err) {
      /* strip trailing ')' and space */
      tailstrip(s);
      len = strlen(s);
      if (s[len-1] == ')') {
          s[len-1] = 0;
      }
      np = comma_count(s) + 1;
      err = allocate_parmv_ptype(&parmv, &ptype, np);
      charsub(s, ',', 0);
    }

    if (!err) {
      p = s;
      for (i=0; i<np && !err; i++) {
          err = parse_fn_element(p, parmv, ptype, i, which);
          p += strlen(p) + 1;
      }
    }

    free(s);

    if (err) {
      free_strings_array(parmv, np);
      free(ptype);
    } else {
      *pparmv = parmv;
      *pptype = ptype;
      *pnp = np;
    }
    
    return err;
}

int gretl_start_compiling_function (const char *line)
{
    char **params = NULL;
    char *ptype = NULL;
    int n_params = 0;
    char fname[FN_NAMELEN];
    char extra[8];
    int nf;
    ufunc *fun = NULL;
    int err = 0;

    nf = sscanf(line, "function %31s %7s", fname, extra);

    if (nf <= 0) {
      return E_PARSE;
    } 

    if (nf == 2) {
      if (!strcmp(extra, "clear") || !strcmp(extra, "delete")) {
          maybe_delete_function(fname);
          return 0;
      }
    }

    err = parse_fn_definition_or_returns(fname, &params, &n_params, 
                               &ptype, line + 8);

    if (!err) {
      fun = add_ufunc();
      if (fun == NULL) {
          free_strings_array(params, n_params);
          free(ptype);
          err = E_ALLOC;
      }
    }

    if (!err) {
      strcpy(fun->name, fname);
      fun->params = params;
      fun->n_params = n_params;
      fun->ptype = ptype;
      set_compiling_on();
    }
    
    return err;
}

static ufunc *get_latest_ufunc (void)
{
    if (n_ufuns > 0) {
      return ufuns[n_ufuns - 1];
    } else {
      return NULL;
    }
}

static int create_function_return_list (ufunc *fun, const char *line)
{
    int err = 0;

    if (fun->returns != NULL) {
      sprintf(gretl_errmsg, "Function %s: return value is already defined",
            fun->name);
      return 1;
    }

    err = parse_fn_definition_or_returns(NULL, &fun->returns, 
                               &fun->n_returns, 
                               &fun->rtype, 
                               line);

    return err;
}

static int real_add_fn_line (ufunc *fun, const char *s)
{
    char **lines;
    int nl = fun->n_lines;
    int err = 0;

#if FN_DEBUG > 1
    fprintf(stderr, "real_add_fn_line: '%s'\n", s);
    fprintf(stderr, "currently fun->n_lines = %d\n", nl);
#endif

    lines = realloc(fun->lines, (nl + 1) * sizeof *lines);

    if (lines == NULL) {
      err = E_ALLOC;
    } else {
      fun->lines = lines;
      fun->lines[nl] = gretl_strdup(s);
      if (fun->lines[nl] == NULL) {
          err = E_ALLOC;
      } else {
          fun->n_lines += 1;
      }
    }

    return err;
}

static int end_of_function (const char *s)
{
    int ret = 0;

    if (!strncmp(s, "end ", 4)) {
      char word[9];

      if (sscanf(s + 4, "%8s", word) && !strcmp(word, "function")) {
          ret = 1;
      }
    }

    return ret;
}

int gretl_function_append_line (const char *line)
{
    ufunc *fun = get_latest_ufunc();
    int err = 0;

#if FN_DEBUG
    fprintf(stderr, "gretl_function_append_line: '%s'\n", line);
#endif

    if (fun == NULL) {
#if FN_DEBUG
      fprintf(stderr, " fun == NULL!\n");
#endif
      return 1;
    }

    if (string_is_blank(line)) {
      return 0;
    }

    if (end_of_function(line)) {
      if (fun->n_lines == 0) {
          sprintf(gretl_errmsg, "%s: empty function", fun->name);
          delete_ufunc_from_list(fun);
          err = 1;
      }
      set_compiling_off();
      return err;
    }

    if (!strncmp(line, "quit", 4)) {
      /* abort compilation */
      delete_ufunc_from_list(fun);
      set_compiling_off();
      return err;
    }

    if (!strncmp(line, "function", 8)) {
      strcpy(gretl_errmsg, "You can't define a function within a function");
      return 1;
    }

    if (!strncmp(line, "return ", 7)) {
      err = create_function_return_list(fun, line + 7);
    } else {    
      err = real_add_fn_line(fun, line);
    }

    return err;
}

#define LOCAL_COPY_LISTS 1

#ifdef LOCAL_COPY_LISTS

/* expand by one element the mapping (in the form of two parallel
   lists) between the ID numbers of "outer scope" variables and
   the ID numbers of the corresponding local copies of those
   variables */

static int 
grow_vars_mapping (int outv, int inv, int **p_outlist, int **p_inlist)
{
    int *outlist = NULL, *inlist = NULL;
    int n;

    if (*p_outlist != NULL) {
      n = (*p_outlist)[0] + 2;
    } else {
      n = 2;
    }

    outlist = realloc(*p_outlist, n * sizeof *outlist);
    if (outlist == NULL) {
      return 1;
    }

    inlist = realloc(*p_inlist, n * sizeof *inlist);
    if (inlist == NULL) {
      *p_outlist = outlist;
      return 1;
    }

    outlist[0] = inlist[0] = n - 1;
    
    outlist[n-1] = outv;
    inlist[n-1] = inv;

    *p_outlist = outlist;
    *p_inlist = inlist;

    return 0;
}

/* look up a variable by its "outer" ID number: if we've already made
   a local copy of the variable, return the ID number of the copy
   (otherwise return 0) */

static int find_mapped_var (int v, const int *outlist, const int *inlist)
{
    int i, match = 0;

    if (outlist != NULL && inlist != NULL) {
      for (i=1; i<=outlist[0]; i++) {
          if (v == outlist[i]) {
            match = inlist[i];
            break;
          }
      }
    }

    return match;
}

/* given a named list of variables supplied as an argument to a function,
   make a revised version of the list in which the original variable
   ID numbers are replaced by the ID numbers of local copies of those
   variables */

static int localize_list (const char *oldname, const char *newname,
                    double ***pZ, DATAINFO *pdinfo,
                    int **p_outlist, int **p_inlist)
{
    int *orig = NULL;
    int *new = NULL;
    int origv = pdinfo->v;
    int i, v, match, err = 0;

    orig = get_list_by_name(oldname);
    if (orig == NULL) {
      return 1;
    }

    new = gretl_list_copy(orig);
    if (new == NULL) {
      return E_ALLOC;
    }

    for (i=1; i<=orig[0] && !err; i++) {
      v = orig[i];
      if (v == pdinfo->v) {
          /* unknown variable */
          err = E_DATA;
      } else if ((match = find_mapped_var(v, *p_outlist, *p_inlist))) {
          /* a local copy of this variable already exists */
          new[i] = match;
      } else {
          /* add a local copy of the variable */
          err = dataset_copy_variable_as(v, pdinfo->varname[v], 
                                 pZ, pdinfo);
          if (!err) {
            new[i] = pdinfo->v - 1;
            err = grow_vars_mapping(v, pdinfo->v - 1, p_outlist, p_inlist);
          }
      }
    }
      
    if (!err) {
      /* save the new list at appropriate stacking level */
      err = stack_localized_list_as(new, newname);
    } else {
      dataset_drop_last_variables(pdinfo->v - origv, pZ, pdinfo);
      free(new);
    }

    return err;
}

#endif

static int check_and_allocate_function_args (ufunc *fun,
                                   int argc, char **argv, 
                                   double ***pZ,
                                   DATAINFO *pdinfo)
{
    int *outlist = NULL, *inlist = NULL;
    int i, v, err = 0;

    if (argc != fun->n_params) {
      sprintf(gretl_errmsg, _("Number of arguments (%d) does not "
                        "match the number of\nparameters for "
                        "function %s (%d)"),
            argc, fun->name, fun->n_params);
      err = 1;
    }

    for (i=0; i<argc && !err; i++) {
#if FN_DEBUG
      fprintf(stderr, "fn args: argv[%d]='%s', parm[%d]='%s' ptype[%d]=%d\n", 
            i, argv[i], i, fun->params[i], i, fun->ptype[i]);
#endif
      if (fun->ptype[i] == ARG_SCALAR) {
          if (numeric_string(argv[i])) {
            err = dataset_add_scalar_as(argv[i], fun->params[i], pZ, pdinfo);
          } else {
            v = varindex(pdinfo, argv[i]);
            if (v < pdinfo->v && !pdinfo->vector[v]) {
                err = dataset_copy_variable_as(v, fun->params[i], pZ, pdinfo);
                if (!err) {
                  err = grow_vars_mapping(v, pdinfo->v - 1, &outlist, &inlist);
                }
            } else {
                sprintf(gretl_errmsg, "argument %d (%s): not a scalar", i+1, argv[i]);
                err = 1;
            } 
          }
      } else if (fun->ptype[i] == ARG_SERIES) {
          if (numeric_string(argv[i])) {
            v = atoi(argv[i]);
          } else {
            v = varindex(pdinfo, argv[i]);
          }
          if (v < pdinfo->v && pdinfo->vector[v]) {
            err = dataset_copy_variable_as(v, fun->params[i], pZ, pdinfo);
            if (!err) {
                err = grow_vars_mapping(v, pdinfo->v - 1, &outlist, &inlist);
            }
          } else {
            sprintf(gretl_errmsg, "argument %d (%s): not a series", i+1, argv[i]);
            err = 1;
          } 
      } else if (fun->ptype[i] == ARG_LIST) {
          if (get_list_by_name(argv[i]) != NULL) {
#ifdef LOCAL_COPY_LISTS
            err = localize_list(argv[i], fun->params[i], pZ, pdinfo,
                            &outlist, &inlist);
#else
            err = copy_named_list_as(argv[i], fun->params[i]);
#endif
          } else {
            sprintf(gretl_errmsg, "argument %d (%s): not a list", i+1, argv[i]);
            err = 1;
          }
      } else {
          /* impossible */
          err = 1;
      }
    }

    free(outlist);
    free(inlist);

    return err;
}

static int check_function_assignments (ufunc *fun,
                               int *asslist, char **assv, 
                               DATAINFO *pdinfo)
{
    int i, v, err = 0;

    if (asslist[0] > fun->n_returns) {
      sprintf(gretl_errmsg, _("Number of assignments (%d) exceeds the "
                        "number of values returned by\n%s (%d)"), 
            asslist[0], fun->name, fun->n_returns);
      err = 1;
    }

    for (i=0; i<asslist[0] && !err; i++) {
#if FN_DEBUG
      fprintf(stderr, "checking assignment %d to '%s'\n", i, assv[i]);
#endif
      v = varindex(pdinfo, assv[i]);
      if (v < pdinfo->v) {
#if FN_DEBUG
          fprintf(stderr, " variable '%s' has ID %d, vector = %d\n", assv[i], 
                v, pdinfo->vector[v]);
#endif
          if ((fun->rtype[i] == ARG_SCALAR && pdinfo->vector[v]) ||
            (fun->rtype[i] == ARG_SERIES && !pdinfo->vector[v])) {
            sprintf(gretl_errmsg, "%s: wrong type for assignment", assv[i]);
            err = 1;
          } else {
            asslist[i+1] = v;
          }
      } else if (fun->rtype[i] == ARG_LIST) {
          /* FIXME? */
          fprintf(stderr, "requested return of list as '%s'\n", assv[i]);
      } else {
          err = check_varname(assv[i]);
      }
    }

    return err;
}

int gretl_function_start_exec (const char *line, double ***pZ,
                         DATAINFO *pdinfo)
{
    char **argv = NULL;
    char **assv = NULL;
    int *asslist = NULL;
    char fname[FN_NAMELEN];
    ufunc *fun;
    fncall *call = NULL;
    int argc = 0;
    int err = 0;

    function_name_from_line(line, fname);
    fun = get_ufunc_by_name(fname);

    if (fun == NULL) {
      return 1;
    }

    err = parse_function_args_etc(line, &argc, &argv, &asslist, &assv);
    if (err) {
      return E_ALLOC;
    }

    if (argc > 0) {
      err = check_and_allocate_function_args(fun, argc, argv, pZ, pdinfo);
    }
    
    if (!err && asslist[0] > 0) {
      err = check_function_assignments(fun, asslist, assv, pdinfo);
    }

    if (err) {
      free_strings_array(argv, argc);
      free_strings_array(assv, asslist[0]);
      free(asslist);
      return 1;
    }

    call = fncall_new(fun, argc, argv, asslist, assv);
    if (call == NULL) {
      return E_ALLOC;
    } 

    err = push_fncall(call, pdinfo);
    if (err) {
      free_fncall(call);
    }

    return err;
}

char *gretl_function_get_line (char *line, int len,
                         double ***pZ, DATAINFO *pdinfo,
                         int *err)
{
    fncall *call = current_call();
    const char *src;
    int unstack = 0;

    *err = 0;

    if (call == NULL || call->fun == NULL) {
#if FN_DEBUG
      fprintf(stderr, "gretl_function_get_line: returning NULL\n"); 
#endif
      return NULL;
    }

#if FN_DEBUG
    fprintf(stderr, "gretl_function_get_line: current fun='%s'\n", 
          call->fun->name);
#endif

    if (call->lnum > call->fun->n_lines - 1) {
      /* finished executing */
      unstack = 1;
    } else {
      src = call->fun->lines[call->lnum];
      if (!strncmp(src, "exit", 4)) {
          /* terminate execution */
          unstack = 1;
      }
    } 

    if (unstack) {
      *err = unstack_fncall(pZ, pdinfo);
      return "";
    } 

    call->lnum += 1;
    strcpy(line, src);

    return line;
}

void gretl_functions_cleanup (void)
{
    callstack_destroy();
    ufuncs_destroy();
}

void gretl_function_stop_on_error (DATAINFO *pdinfo, PRN *prn)
{
    gretl_function_flagged_error(NULL, prn);

    callstack_destroy();

    if (fn_executing > 0) {
      libset_restore_state_zero(pdinfo);
    }

    fn_executing = 0;
}

int gretl_function_flagged_error (const char *s, PRN *prn)
{
    fncall *call;

    if (!fn_executing) {
      return 0;
    }

    call = current_call();

    if (s != NULL && *s != '\0') {
      pprintf(prn, "%s: %s\n", call->fun->name, s);
    } else {
      pprintf(prn, _("Error condition in execution of function %s"),
            (callstack[0])->fun->name);
      pputc(prn, '\n');
    }

    return 1;
}

Generated by  Doxygen 1.6.0   Back to index