/* 
 *  gretl -- Gnu Regression, Econometrics and Time-series Library
 *  Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
 * 
 *  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 3 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, see <http://www.gnu.org/licenses/>.
 * 
 */

#include "libgretl.h"
#include "monte_carlo.h"
#include "var.h"
#include "johansen.h"
#include "system.h"
#include "objstack.h"
#include "usermat.h"
#include "forecast.h"
#include "kalman.h"

#define ODEBUG 0

typedef struct stacker_ stacker;

struct stacker_ {
    int type;
    void *ptr;
};

static stacker *ostack;
static int n_obj;
static int n_sys;
static int n_vars;

static stacker last_model;

static GretlObjType get_stacked_type_by_data (void *ptr)
{
    int i;

    for (i=0; i<n_obj; i++) {
	if (ostack[i].ptr == ptr) {
	    return ostack[i].type;
	}
    }

    return GRETL_OBJ_NULL;
}

#if ODEBUG

static int object_get_refcount (void *ptr, GretlObjType type)
{
    int rc = -999;

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) ptr;

	if (pmod != NULL) {
	    rc = pmod->refcount;
	}
	rc = pmod->refcount;
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) ptr;

	if (var != NULL) {
	    rc = var->refcount;
	}
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) ptr;

	if (sys != NULL) {
	    rc = sys->refcount;
	}
    }

    return rc;
} 

#endif

#if ODEBUG > 1

static void print_ostack (void)
{
    fprintf(stderr, "\n*** object stack: n_obj = %d\n", n_obj);

    if (n_obj > 0) {
	void *p;
	int i, t;

	for (i=0; i<n_obj; i++) {
	    p = ostack[i].ptr;
	    t = ostack[i].type;
	    fprintf(stderr, " %d: %p (type=%d, refcount=%d)\n", i, p, 
		    t, object_get_refcount(p, t));
	}
	fputc('\n', stderr);
    }
}

#endif

/**
 * gretl_object_ref:
 * @ptr: pointer to gretl obejct (e.g. #MODEL).
 * @type: type of object.
 *
 * Augments the reference count for the object represented by
 * @ptr, of type @type.
 */

void gretl_object_ref (void *ptr, GretlObjType type)
{
    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) ptr;

	if (pmod != NULL) {
	    pmod->refcount += 1;
#if ODEBUG
	    fprintf(stderr, "gretl_object_ref: refcount on %p is now %d\n",
		    (void *) pmod, pmod->refcount);
#endif
	}
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) ptr;

	if (var != NULL) {
	    var->refcount += 1;
	}
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) ptr;

	if (sys != NULL) {
	    sys->refcount += 1;
	}
    }
}

enum {
    UNSTACK_REMOVE,
    UNSTACK_DESTROY
};

static int unstack_replace;

static void gretl_object_unstack (void *ptr, int action)
{
    int i, pos = -1;

#if ODEBUG
    fprintf(stderr, "gretl_object_unstack: ptr=%p, action=%d\n", ptr, action);
#endif

    if (action == UNSTACK_DESTROY && ptr == last_model.ptr) {
#if ODEBUG
	fprintf(stderr, " %p is 'last_model'\n", ptr);
#endif
	/* avoid double-freeing */
	last_model.ptr = NULL;
	last_model.type = GRETL_OBJ_NULL;
    }

    if (unstack_replace) {
	return;
    }

    for (i=0; i<n_obj; i++) {
	if (ptr == ostack[i].ptr) {
	    pos = i;
	    break;
	}
    }

#if ODEBUG
    fprintf(stderr, " stack pos for %p = %d, n_obj = %d\n",
	    ptr, pos, n_obj);
#endif
    
    if (pos >= 0) {
	n_obj--;
	if (n_obj == 0) {
	    free(ostack);
	    ostack = NULL;
	} else {
	    stacker *new_stack;

	    for (i=pos; i<n_obj; i++) {
		ostack[i] = ostack[i+1];
	    }

	    new_stack = realloc(ostack, n_obj * sizeof *new_stack);
	    if (new_stack != NULL) {
		ostack = new_stack;
	    }
	}
    }
}

static void gretl_object_destroy (void *ptr, GretlObjType type)
{
#if ODEBUG
    fprintf(stderr, "gretl_object_destroy: ptr %p, type %d\n",
	    ptr, type);
#endif

    gretl_object_unstack(ptr, UNSTACK_DESTROY);
    
    if (type == GRETL_OBJ_EQN) {
	gretl_model_free(ptr);
    } else if (type == GRETL_OBJ_VAR) {
	gretl_VAR_free(ptr);
    } else if (type == GRETL_OBJ_SYS) {
	equation_system_destroy(ptr);
    }
}

/* The stuff below: Note that we can't "protect" a model (against
   deletion) simply by setting its refcount to some special value,
   when models are being reused, since the refcount will go to 0 every
   time the model is assigned to!  Hence we need to set up this
   "protected species" list.
*/

static MODEL **protected_models;
static int n_prot;

int gretl_model_protect (MODEL *pmod)
{
    MODEL **prmod;
    int err = 0;

    prmod = realloc(protected_models, (n_prot + 1) * sizeof *prmod);

    if (prmod == NULL) {
	fprintf(stderr, "gretl_model_protect: out of memory!\n");
	err = E_ALLOC;
    } else {
	protected_models = prmod;
	protected_models[n_prot++] = pmod;
    }

    return err;
}

static int gretl_model_unprotect (MODEL *pmod)
{
    MODEL **prmod;
    int match = 0;
    int i, j, err = 0;

    for (i=0; i<n_prot; i++) {
	if (protected_models[i] == pmod) {
	    match = 1;
	    for (j=i; j<n_prot-1; j++) {
		protected_models[j] = protected_models[j+1];
	    }
	    break;
	}
    }

    if (match) {
	if (n_prot == 1) {
	    free(protected_models);
	    protected_models = NULL;
	    n_prot = 0;
	} else {
	    prmod = realloc(protected_models, (n_prot - 1) * sizeof *prmod);
	    if (prmod == NULL) {
		fprintf(stderr, "gretl_model_unprotect: out of memory!\n");
		err = E_ALLOC;
	    } else {
		protected_models = prmod;
		n_prot--;
	    }
	}
    }

    return err;
}

static int model_is_protected (MODEL *pmod)
{
    int i, prot = 0;

    for (i=0; i<n_prot; i++) {
	if (pmod == protected_models[i]) {
	    prot = 1;
	    break;
	}
    }

    if (!prot) {
	prot = model_is_in_loop(pmod);
    }

#if ODEBUG
    if (prot) {
	fprintf(stderr, "model at %p is protected\n", (void *) pmod);
    }
#endif

    return prot;
}

/**
 * gretl_object_unref:
 * @ptr: pointer to gretl object (e.g. #MODEL).
 * @type: type of object.
 *
 * Decrements the reference count for the object represented by
 * @ptr, of type @type. When the count reaches zero the object
 * is destroyed.
 */

void gretl_object_unref (void *ptr, GretlObjType type)
{
    int *rc = NULL;

    if (ptr == NULL) {
	/* no-op */
	return;
    }

    if (type == GRETL_OBJ_ANY) {
	type = get_stacked_type_by_data(ptr);
    } 

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) ptr;

	if (pmod != NULL) {
	    if (model_is_protected(pmod)) {
		return; /* note! */
	    }
	    rc = &pmod->refcount;
	}
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) ptr;

	if (var != NULL) {
	    rc = &var->refcount;
	}
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) ptr;

	if (sys != NULL) {
	    rc = &sys->refcount;
	}
    } else {
	fprintf(stderr, "gretl_object_unref: %p: bad object type\n",
		ptr);
	return;
    }

#if ODEBUG
    fprintf(stderr, "gretl_object_unref: %p (incoming count = %d)\n", 
	    ptr, *rc);
#endif

    if (rc != NULL) {
	*rc -= 1;
	if (*rc <= 0) {
	    gretl_object_destroy(ptr, type);
	}
    }

#if ODEBUG > 1
    print_ostack();
#endif
}

/**
 * set_as_last_model:
 * @ptr: pointer to gretl object (e.g. #MODEL).
 * @type: type of object.
 *
 * Puts @ptr in place as the "last model" (which will be
 * accessed by default via accessors such as "$uhat").
 */

void set_as_last_model (void *ptr, GretlObjType type)
{
#if ODEBUG
    fprintf(stderr, "set_as_last_model: ptr=%p, type=%d; 'old' ptr=%p\n",
	    ptr, type, last_model.ptr);
#endif

    if (last_model.ptr != ptr && last_model.ptr != NULL) {
#if ODEBUG
	fprintf(stderr, " unrefing old object at %p (type %d)\n",
		last_model.ptr, last_model.type);
#endif
	gretl_object_unref(last_model.ptr, last_model.type);
    }

    if (last_model.ptr != ptr || last_model.type != type) {
	last_model.ptr = ptr;
	last_model.type = type;
	if (ptr != NULL) {
	    gretl_object_ref(ptr, type);
	}
    }

#if ODEBUG
    if (last_model.ptr != NULL) {
	fprintf(stderr, " refcount on \"last_model\" = %d\n",
		object_get_refcount(last_model.ptr, last_model.type));
    }
#endif
}

/**
 * get_last_model:
 * @type: location to receive type of last model, or %NULL.
 *
 * Returns: pointer to the last model estimated.  Note that
 * this may be %NULL if no model has been estimated.
 */

void *get_last_model (GretlObjType *type)
{
    if (type != NULL) {
	*type = last_model.type;
    }

    return last_model.ptr;
}

/**
 * get_last_model_type:
 *
 * Returns: the type indentifier for the last model estimated.
 */

GretlObjType get_last_model_type (void)
{
    return last_model.type;
}

/**
 * gretl_object_get_name:
 * @p: pointer to gretl object (e.g. #MODEL).
 * @type: type of object.
 *
 * Returns: the name of the object of type @type with
 * location @p, or %NULL if the object is not found.
 * The return value may be ovewritten (up to
 * MAXSAVENAME-1 characters), but must not be freed.
 */

char *gretl_object_get_name (void *p, GretlObjType type)
{
    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = p;

	if (pmod->name == NULL) {
	    pmod->name = calloc(MAXSAVENAME, 1);
	}
	return pmod->name;
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = p;

	if (var->name == NULL) {
	    var->name = calloc(MAXSAVENAME, 1);
	}
	return var->name;
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = p;

	if (sys->name == NULL) {
	    sys->name = calloc(MAXSAVENAME, 1);
	}
	return sys->name;
    }

    return NULL;
}

static stacker *
get_stacker_by_name (const char *oname, GretlObjType type, int *onum)
{
    stacker *s = NULL;
    const char *test;
    int i;

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

    for (i=0; i<n_obj; i++) {
	if (type == GRETL_OBJ_ANY || type == ostack[i].type) {
	    test = gretl_object_get_name(ostack[i].ptr, ostack[i].type);
	    if (!strcmp(oname, test)) {
		if (onum != NULL) {
		    *onum = i;
		}
		s = &ostack[i];
		break;
	    }
	}
    }

#if ODEBUG
    fprintf(stderr, "get_stacker_by_name: name='%s', type=%d: got s=%p\n",
	    oname, type, (void *) s);
#endif
    
    return s;
}

static void *
get_object_by_name (const char *oname, GretlObjType type, int *onum)
{
    void *ptr = NULL;
    const char *test;
    int i;

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

    for (i=0; i<n_obj; i++) {
	if (type == GRETL_OBJ_ANY || type == ostack[i].type) {
	    test = gretl_object_get_name(ostack[i].ptr, ostack[i].type);
	    if (!strcmp(oname, test)) {
		if (onum != NULL) {
		    *onum = i;
		}
		ptr = ostack[i].ptr;
		break;
	    }
	}
    }

#if ODEBUG
    fprintf(stderr, "get_object_by_name: name='%s', type=%d, ptr=%p\n",
	    oname, type, (void *) ptr);
    if (ptr == NULL) {
	if (n_obj == 0) {
	    fprintf(stderr, "(no currently saved objects)\n");
	} else {
	    fprintf(stderr, "failed: current objects:\n");
	    for (i=0; i<n_obj; i++) {
		fprintf(stderr, " %02d: '%s' (%p, type %d)\n", i,
			gretl_object_get_name(ostack[i].ptr, ostack[i].type),
			ostack[i].ptr, ostack[i].type);
	    }
	}
    }
#endif    

    return ptr;
}

void *gretl_get_object_by_name (const char *name)
{
    return get_object_by_name(name, GRETL_OBJ_ANY, NULL);
}

int 
gretl_get_object_and_type (const char *name, void **pp, GretlObjType *type)
{
    int err = E_DATA;

    *pp = NULL;
    *type = 0;

    if (name == NULL) {
	return err;
    }

    if (!strcmp(name, "$system")) {
	*pp = get_anonymous_equation_system();
	if (*pp != NULL) {
	    *type = GRETL_OBJ_SYS; 
	    err = 0;
	}
    } else {
	const char *test;
	int i;

	for (i=0; i<n_obj; i++) {
	    test = gretl_object_get_name(ostack[i].ptr, ostack[i].type);
	    if (!strcmp(name, test)) {
		*pp = ostack[i].ptr;
		*type = ostack[i].type;
		err = 0;
		break;
	    }
	}
    }

    return err;
}

MODEL *get_model_by_ID (int ID) 
{
    MODEL *pmod;
    int i;

    for (i=0; i<n_obj; i++) {
	if (ostack[i].type == GRETL_OBJ_EQN) {
	    pmod = (MODEL *) ostack[i].ptr;
	    if (pmod->ID == ID) {
		return pmod;
	    }
	}
    }

    return NULL;
}

MODEL *get_model_by_name (const char *mname)
{
    return get_object_by_name(mname, GRETL_OBJ_EQN, NULL);
}

GRETL_VAR *get_VAR_by_name (const char *vname)
{
    return get_object_by_name(vname, GRETL_OBJ_VAR, NULL);
}

GRETL_VAR *get_VECM_by_name (const char *vname)
{
    GRETL_VAR *var = get_object_by_name(vname, GRETL_OBJ_VAR, NULL);

    if (var != NULL && var->ci == VECM) {
	return var;
    } else {
	return NULL;
    }
}

equation_system *get_equation_system_by_name (const char *sname)
{
    return get_object_by_name(sname, GRETL_OBJ_SYS, NULL);
}

int gretl_object_compose_name (void *p, GretlObjType type)
{
    char name[32];
    int err = 0;

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) p;

	sprintf(name, "%s %d", _("Model"), pmod->ID);
	gretl_model_set_name(pmod, name);
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) p;

	if (var->ci == VAR) {
	    sprintf(name, "%s %d", _("VAR"), ++n_vars);
	} else {
	    sprintf(name, "%s %d", _("VECM"), gretl_VECM_id(var));
	}
	gretl_VAR_set_name(var, name);
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) p;

	sprintf(name, "%s %d", _("System"), ++n_sys);
	equation_system_set_name(sys, name);
    } else {
	err = 1;
    }

    return err;
}

int gretl_object_compose_unique_name (void *p, GretlObjType type)
{
    char name[32];
    int id, err = 0;

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) p;
	
	id = pmod->ID;
	sprintf(name, "%s %d", _("Model"), id);
	while (get_model_by_name(name) != NULL) {
	    sprintf(name, "%s %d", _("Model"), ++id);
	}
	gretl_model_set_name(pmod, name);
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) p;

	if (var->ci == VAR) {
	    id = ++n_vars;
	    sprintf(name, "%s %d", _("VAR"), id);
	    while (get_VAR_by_name(name) != NULL) {
		sprintf(name, "%s %d", _("VAR"), ++id);
	    }
	} else {
	    id = gretl_VECM_id(var);
	    sprintf(name, "%s %d", _("VECM"), id);
	    while (get_VECM_by_name(name) != NULL) {
		sprintf(name, "%s %d", _("VECM"), ++id);
	    }
	}
	gretl_VAR_set_name(var, name);
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) p;
	
	id = ++n_sys;
	sprintf(name, "%s %d", _("System"), id);
	while (get_equation_system_by_name(name) != NULL) {
	    sprintf(name, "%s %d", _("System"), ++id);
	}
	equation_system_set_name(sys, name);
    } else {
	err = 1;
    }

    return err;
}

int gretl_object_rename (void *p, GretlObjType type, const char *oname)
{
    int err = 0;

    if (type == GRETL_OBJ_EQN) {
	gretl_model_set_name((MODEL *) p, oname);
    } else if (type == GRETL_OBJ_VAR) {
	gretl_VAR_set_name((GRETL_VAR *) p, oname);
    } else if (type == GRETL_OBJ_SYS) {
	equation_system_set_name((equation_system *) p, oname);
    } else {
	err = 1;
    }

    return err;
}

/* safety measure prior to freeing models on exit */

void remove_model_from_stack_on_exit (MODEL *pmod)
{
    int i;

    for (i=0; i<n_obj; i++) {
	if (pmod == ostack[i].ptr) {
	    ostack[i].ptr = NULL;
	    ostack[i].type = 0;
	    break;
	}
    }

    if (last_model.ptr == pmod) {
	last_model.ptr = NULL;
	last_model.type = 0;
    }

    gretl_model_unprotect(pmod);
}

void gretl_object_remove_from_stack (void *ptr, GretlObjType type)
{
#if ODEBUG
    fprintf(stderr, "gretl_object_remove_from_stack\n");
#endif
    gretl_object_unstack(ptr, UNSTACK_REMOVE);
    gretl_object_unref(ptr, type);
}

static int object_stack_index (const void *p)
{
    int i, ret = -1;

    for (i=0; i<n_obj; i++) {
	if (p == ostack[i].ptr) {
	    ret = i;
	    break;
	}
    }

#if ODEBUG
    if (ret >= 0) {
	fprintf(stderr, "object_on_stack: object at %p already stacked "
		"at pos %d\n", p, ret);
    }
#endif

    return ret;
}

int object_is_on_stack (const void *ptr)
{
    return (object_stack_index(ptr) >= 0);
}

static int 
real_stack_object (void *p, GretlObjType type, const char *name, PRN *prn)
{
    stacker *orig;
    int onum, err = 0;

#if ODEBUG
    fprintf(stderr, "real_stack_object: on entry, p=%p, type=%d, name='%s'\n", 
	    (void *) p, type, name);
#endif

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

    if (object_stack_index(p) >= 0) {
#if ODEBUG
	fprintf(stderr, " real_stack_object: done, no-op\n");
#endif
	return 0;
    }

    if (name == NULL || *name == '\0') {
	err = gretl_object_compose_name(p, type);
    } else {
	err = gretl_object_rename(p, type, name);
    }

    if (err) {
	return err;
    }

    orig = get_stacker_by_name(name, type, &onum);

    if (orig != NULL) {
	/* replace existing object of same name */
#if ODEBUG
	fprintf(stderr, "  replacing at %p (onum = %d, ptr = %p)\n", 
		orig, onum, orig->ptr);
#endif
	unstack_replace = 1;
	gretl_object_unref(orig->ptr, orig->type);
	unstack_replace = 0;
	ostack[onum].ptr = p;
	ostack[onum].type = type;
	pprintf(prn, "Replaced object '%s'\n", name);
	gretl_object_ref(p, type);
    } else {
	stacker *tmp;

	tmp = realloc(ostack, (n_obj + 1) * sizeof *ostack);
	if (tmp == NULL) {
	    return E_ALLOC;
	}
	ostack = tmp;
	ostack[n_obj].ptr = p;
	ostack[n_obj].type = type;
	gretl_object_ref(p, type);
	n_obj++;
	pprintf(prn, "Added object '%s'\n", name);
    }

#if ODEBUG
    fprintf(stderr, " real_stack_object, on exit: '%s', type=%d, ptr=%p (n_obj=%d)\n",
	    name, type, (void *) p, n_obj);
#endif 

#if ODEBUG > 1
    print_ostack();
#endif

    return 0;
}

int gretl_stack_object (void *ptr, GretlObjType type)
{
    char *name = gretl_object_get_name(ptr, type);

    return real_stack_object(ptr, type, name, NULL);
}

int gretl_stack_object_as (void *ptr, GretlObjType type, const char *name)
{
    return real_stack_object(ptr, type, name, NULL);
}

int maybe_stack_var (GRETL_VAR *var, CMD *cmd)
{
    int err = 0;

    if (var != NULL) {
	const char *name = gretl_cmd_get_savename(cmd);

	set_as_last_model(var, GRETL_OBJ_VAR);
	if (*name != '\0') {
	    err = real_stack_object(var, GRETL_OBJ_VAR, name, NULL);
	}
    }

    return err;
}

/* Called from interact.c, after sucessful estimation of a
   (single-equation) model.  We automatically put the model in place
   as the "last model" for reference purposes (e.g. in genr).  In
   addition, if the model has been assigned a "savename" (via
   something like "mymod <- ols 1 0 2"), we make a copy and add it to
   the stack of saved objects.  We need to do the copying so that
   if/when the original model pointer is reassigned to, via a further
   estimation command, we do not lose the saved (named) model content.

   Reference counting: the model that is passed in should have its
   refcount raised by 1 on account of set_as_last_model.  The refcount of
   the copy (if applicable) should be 1, since the only reference to
   this model pointer is the one on the stack of named objects.

   We return a pointer to the model as stacked, in case any further
   action has to be taken (e.g. in the GUI).
*/

MODEL *maybe_stack_model (MODEL *pmod, CMD *cmd, PRN *prn, int *err)
{
    const char *name = gretl_cmd_get_savename(cmd);
    MODEL *smod = NULL;

    if (*name != '\0') {
	MODEL *cpy = gretl_model_copy(pmod);

	if (cpy == NULL) {
	    *err = E_ALLOC;
	} else {
	    *err = real_stack_object(cpy, GRETL_OBJ_EQN, name, NULL);
	}

	if (!*err) {
	    set_as_last_model(cpy, GRETL_OBJ_EQN);
	    pprintf(prn, _("%s saved\n"), name);
	} else {
	    errmsg(*err, prn);
	}
	smod = cpy;
    } else {
	set_as_last_model(pmod, GRETL_OBJ_EQN);
	smod = pmod;
    }

    return smod;
}

#define INVALID_STAT -999.999

/* retrieve from an object some value that is stored on the object in
   the form of a simple scalar */

static double real_get_obj_scalar (void *p, GretlObjType type, 
				   DATASET *dset, int idx)
{
    double x = INVALID_STAT;
    int err = 0;
    
    if (idx <= 0) {
	return x;
    }

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) p;

	x = gretl_model_get_scalar(pmod, idx, dset, &err);
	if (err) {
	    x = INVALID_STAT;
	}
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) p;

	if (idx == M_T) {
	    x = sys->T;
	} else if (idx == M_LNL) {
	    x = sys->ll;
	} else if (idx == M_ESS) {
	    x = sys->ess;
	} else if (idx == M_DF) {
	    x = sys->df;
	} else if (idx == M_DIAGTEST) {
	    err = system_diag_test(sys, &x, NULL);
	} else if (idx == M_DIAGPVAL) {
	    err = system_diag_test(sys, NULL, &x);
	}
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) p;

	if (idx == M_T) {
	    x = var->T;
	} else if (idx == M_DF) {
	    x = var->df;
	} else if (idx == M_NCOEFF) {
	    x = var->ncoeff;
	} else if (idx == M_LNL) {
	    x = var->ll;
	} else if (idx == M_AIC) {
	    x = var->AIC;
	} else if (idx == M_BIC) {
	    x = var->BIC;	
	} else if (idx == M_HQC) {
	    x = var->HQC;
	}
    }

    return x;
}

/* find out what sort of object we're dealing with, and call
   the appropriate function to get the requested matrix 
*/

static gretl_matrix *
real_get_obj_matrix (void *p, GretlObjType type, int idx, int *err)
{
    gretl_matrix *M = NULL;
    
    if (idx <= 0) {
	*err = 1;
	return M;
    }

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) p;

	M = gretl_model_get_matrix(pmod, idx, err);
    } else if (type == GRETL_OBJ_SYS) {
	equation_system *sys = (equation_system *) p;

	M = equation_system_get_matrix(sys, idx, err);
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) p;

	M = gretl_VAR_get_matrix(var, idx, err);
    }

    return M;
}

#define list_carrying_type(t) (t == GRETL_OBJ_EQN || \
			       t == GRETL_OBJ_VAR || \
			       t == GRETL_OBJ_SYS)

static int *
real_get_obj_list (void *p, GretlObjType type, int idx, int *err)
{
    const MODEL *pmod = NULL;
    const GRETL_VAR *var = NULL;
    const equation_system *sys = NULL;
    const int *list = NULL;
    int *ret = NULL;
    
    if (idx <= 0 || p == NULL || !list_carrying_type(type)) {
	*err = E_DATA;
	return NULL;
    }

    if (type == GRETL_OBJ_EQN) {
	pmod = p;
    } else if (type == GRETL_OBJ_VAR) {
	var = p;
    } else {
	sys = p;
    }

    if (idx == M_XLIST) {
	if (type == GRETL_OBJ_EQN) {
	    /* the list is already a copy */
	    ret = gretl_model_get_x_list(pmod);
	} else {
	    if (type == GRETL_OBJ_VAR) {
		list = var->xlist;
	    } else {
		list = sys->xlist;
	    }
	    if (list == NULL) {
		*err = E_BADSTAT;
	    } else {
		ret = gretl_list_copy(list);
	    }
	}
    } else if (idx == M_YLIST) {
	if (type == GRETL_OBJ_EQN) {
	    ret = gretl_model_get_y_list(pmod);
	} else {
	    if (type == GRETL_OBJ_VAR) {
		list = gretl_VAR_get_endo_list(var);
	    } else {
		list = system_get_endog_vars(sys);
	    }
	    if (list == NULL) {
		*err = E_BADSTAT;
	    } else {
		ret = gretl_list_copy(list);
	    }
	}
    } else {
	*err = E_BADSTAT;
    }

    if (ret == NULL && !*err) {
	*err = E_ALLOC;
    }

    return ret;
}

static char *
real_get_obj_string (void *p, GretlObjType type, int idx, 
		     const DATASET *dset, int *err)
{
    char *str = NULL;

    if (idx <= 0) {
	*err = 1;
	return str;
    }

    if (type == GRETL_OBJ_EQN && idx == M_COMMAND) {
	MODEL *pmod = (MODEL *) p;

	str = gretl_strdup(gretl_command_word(pmod->ci));
    } else if (type == GRETL_OBJ_EQN && idx == M_DEPVAR) {
	const char *s = gretl_model_get_depvar_name((MODEL *) p, 
						    dset);

	str = gretl_strdup(s);
    } else {
	*err = E_BADSTAT;
    }

    return str;
}

static stacker genr_model;

void set_genr_model (void *ptr, GretlObjType type)
{
    genr_model.ptr = ptr;
    genr_model.type = type;
}

void unset_genr_model (void)
{
    genr_model.type = GRETL_OBJ_NULL;
    genr_model.ptr = NULL;
}

void *get_genr_model (GretlObjType *type)
{
    if (type != NULL) {
	*type = genr_model.type;
    }

    return genr_model.ptr;
}

static stacker *find_smatch (const char *oname)
{
    stacker *smatch = NULL;

    if (oname == NULL || *oname == '\0') {
	if (genr_model.ptr != NULL) {
	    smatch = &genr_model;
	} else {
	    smatch = &last_model;
	}
    } else {
	const char *test;
	int i;
	
	for (i=0; i<n_obj; i++) {
	    test = gretl_object_get_name(ostack[i].ptr, ostack[i].type);
	    if (!strcmp(oname, test)) {
		smatch = &ostack[i];
		break;
	    }
	}
    }

    return smatch;
}

/* Retrieve the type of a named model, or of the last model if @name
   is NULL.  If it's a single-equation model and @ci is non-NULL,
   also retrieve the model's command index in @ci.
*/

GretlObjType gretl_model_get_type_and_ci (const char *name,
					  int *ci)
{
    stacker *smatch = find_smatch(name);
    GretlObjType ret = GRETL_OBJ_NULL;

    if (ci != NULL) {
	*ci = 0;
    }

    if (smatch != NULL) {
	ret = smatch->type;
	if (ret == GRETL_OBJ_EQN && ci != NULL) {
	    MODEL *pmod = smatch->ptr;

	    *ci = pmod->ci;
	}
    }

    return ret;
}

int *saved_object_get_list (const char *oname, int idx, int *err)
{
    int *ret = NULL;
    stacker *smatch;

    smatch = find_smatch(oname);

    if (smatch != NULL) {
	ret = real_get_obj_list(smatch->ptr, smatch->type, idx, err);
    }

    return ret;
}

char *saved_object_get_string (const char *oname, int idx, 
			       const DATASET *dset, int *err)
{
    char *ret = NULL;
    stacker *smatch;

    smatch = find_smatch(oname);

    if (smatch != NULL) {
	ret = real_get_obj_string(smatch->ptr, smatch->type, idx, 
				  dset, err);
    }

    return ret;
}

double saved_object_get_scalar (const char *oname, int idx, 
				DATASET *dset, int *err)
{
    double ret = INVALID_STAT;
    stacker *smatch;

    smatch = find_smatch(oname);

    if (smatch != NULL) {
	ret = real_get_obj_scalar(smatch->ptr, smatch->type, 
				  dset, idx);
    }

    if (ret == INVALID_STAT) {
	*err = E_BADSTAT;
    }

    return ret;
}

int saved_object_get_series (double *x, const char *oname, 
			     int idx, const DATASET *dset)
{
    int err = 0;

    if (idx <= 0) {
	err = E_DATA;
    } else {
	stacker *smatch = find_smatch(oname);

	if (smatch == NULL || smatch->type != GRETL_OBJ_EQN) {
	    err = E_BADSTAT;
	} else {
	    MODEL *pmod = (MODEL *) smatch->ptr;

	    err = gretl_model_get_series(x, pmod, dset, idx);
	}
    }

    return err;
}

/* starting point for getting a matrix from a saved model
   of one kind or another.  We start by looking for the right
   model: this is either a match for @oname, or if @oname
   is NULL or blank, the last model estimated.
*/

gretl_matrix *
saved_object_get_matrix (const char *oname, int idx, int *err)
{
    gretl_matrix *M = NULL;

    if (idx == M_FCAST || idx == M_FCERR) {
	M = get_forecast_matrix(idx, err);
    } else if (idx == M_KLLT || idx == M_KUHAT) {
	M = user_kalman_get_matrix(idx, err);
    } else {
	stacker *smatch = find_smatch(oname);

	if (smatch != NULL) {
	    M = real_get_obj_matrix(smatch->ptr, smatch->type, idx, err);
	}
    }

    if (M == NULL && !*err) {
	*err = E_BADSTAT;
    }    

    return M;
}

/* similar to the above, but in this case the matrix to be
   retrieved is not pre-built, and requires (or may require)
   access to the current dataset for its building.
*/

gretl_matrix *
saved_object_build_matrix (const char *oname, int idx, 
			   const DATASET *dset,
			   int *err)
{
    stacker *smatch = find_smatch(oname);
    gretl_matrix *M = NULL;

    if (smatch == NULL) {
	*err = E_DATA;
    } else if (idx == M_MNLPROBS && smatch->type == GRETL_OBJ_EQN) {
	M = mn_logit_probabilities(smatch->ptr, dset, err);
    } else if (idx == M_EC && smatch->type == GRETL_OBJ_VAR) {
	M = VECM_get_EC_matrix(smatch->ptr, dset, err);
    } else if (idx == M_VMA && smatch->type == GRETL_OBJ_VAR) {
	M = gretl_VAR_get_vma_matrix(smatch->ptr, dset, err);
    } else if (idx == M_FEVD && smatch->type == GRETL_OBJ_VAR) {
	M = gretl_VAR_get_full_FEVD_matrix(smatch->ptr, dset, err);
    } else {
	*err = E_BADSTAT;
    }

    return M;
}

gretl_matrix *
last_model_get_irf_matrix (int targ, int shock, double alpha, 
			   const DATASET *dset, int *err)
{
    stacker *smatch = find_smatch(NULL);
    gretl_matrix *M = NULL;

    if (smatch == NULL || smatch->type != GRETL_OBJ_VAR) {
	*err = E_BADSTAT;
    } else {
	M = gretl_VAR_get_impulse_response(smatch->ptr, targ, shock, 0,
					   alpha, dset, err);
    }

    return M;
}

gretl_bundle *last_model_get_irf_bundle (int targ, int shock, double alpha, 
					 const DATASET *dset, int *err)
{
    stacker *smatch = find_smatch(NULL);
    GRETL_VAR *var = NULL;
    gretl_matrix *m = NULL;
    gretl_bundle *b = NULL;

    if (smatch == NULL || smatch->type != GRETL_OBJ_VAR) {
	*err = E_BADSTAT;
    } else {
	var = smatch->ptr;
	m = gretl_VAR_get_impulse_response(var, targ, shock, 0,
					   alpha, dset, err);
    }

    if (!*err) {
	b = gretl_bundle_new();
	if (b == NULL) {
	    *err = E_ALLOC;
	} else {
	    int vtarg = gretl_VAR_get_variable_number(var, targ);
	    int vshock = gretl_VAR_get_variable_number(var, shock);
	    const char *tname = dset->varname[vtarg];
	    const char *sname = dset->varname[vshock];
	    const char *label = dataset_period_label(dset);
	    int i, errs[6];

	    errs[0] = gretl_bundle_set_payload_matrix(b, m);
	    errs[1] = gretl_bundle_set_string(b, "targname", tname);
	    errs[2] = gretl_bundle_set_string(b, "shockname", sname);
	    errs[3] = gretl_bundle_set_string(b, "period_label", label);
	    errs[4] = gretl_bundle_set_scalar(b, "alpha", alpha);
	    errs[5] = gretl_bundle_set_creator(b, "gretl::irf");

	    for (i=0; i<6; i++) {
		if (errs[i]) {
		    *err = errs[i];
		    break;
		}
	    }

	    if (*err) {
		gretl_bundle_destroy(b);
		b = NULL;
	    }
	}
    }

    gretl_matrix_free(m);

    return b;
}

void *last_model_get_data (const char *key, GretlType *type, 
			   int *size, int *err)
{
    stacker *smatch = find_smatch(NULL);
    void *ret = NULL;

    if (smatch == NULL || smatch->type != GRETL_OBJ_EQN) {
	*err = E_DATA;
    } else {
	const MODEL *pmod = smatch->ptr;
	size_t sz = 0;

	ret = gretl_model_get_data_full(pmod, key, type, &sz);
	if (ret == NULL) {
	    *err = E_DATA;
	} else {
	    *size = sz;
	}
    }

    if (*err) {
	gretl_errmsg_sprintf("\"%s\": %s", key, _("no such item"));
    }

    return ret;
}

char *last_model_get_vcv_type (void)
{
    stacker *smatch = find_smatch(NULL);
    static char ret[16];

    *ret = '\0';

    if (smatch != NULL && smatch->type == GRETL_OBJ_EQN) {
	const MODEL *pmod = smatch->ptr;
	VCVInfo *vi;

	vi = gretl_model_get_data(pmod, "vcv_info");

	if (vi != NULL && vi->vmaj == VCV_ML) {
	    if (vi->vmin == ML_HESSIAN) {
		strcpy(ret, "Hessian");
	    } else if (vi->vmin == ML_OP) {
		strcpy(ret, "OPG");
	    } else if (vi->vmin == ML_QML) {
		strcpy(ret, "Sandwich");
	    }
	}
    }

    return (*ret != '\0')? ret : NULL;
}

static int namechar_spn_with_space (const char *s)
{
    const char *ok = "abcdefghijklmnopqrstuvwxyz"
	"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
	"0123456789_ ";
    int ret = 0;

    if (isalpha(*s)) {
	ret = strspn(s, ok);
    }

    return ret;
}

#define OPDEBUG 0

/* try to parse an "object-oriented" command, such as
   MyModel.free or "System 1".show */

int parse_object_command (const char *s, char *name, char **cmd)
{
    int len, quoted = 0;
    int err = 0;

    *name = 0;
    *cmd = 0;

    /* skip any leading whitespace */
    while (*s && isspace(*s)) {
	s++;
    }

    /* skip an opening quote */
    if (*s == '"') {
	quoted = 1;
	s++;
    }

    if (quoted) {
	len = namechar_spn_with_space(s);
    } else {
	len = gretl_namechar_spn(s);
    }

    if (len == 0) {
	return 0;
    } 

    if (len > MAXSAVENAME - 1) {
	len = MAXSAVENAME - 1;
    }

    strncat(name, s, len);
    s += len;

    if (quoted && *s == '"') {
	s++;
    }

    /* is an object command embedded? */
    if (*s == '.') {
	s++;
	if (*s && !isspace(*s)) {
	    *cmd = gretl_strdup(s);
	    if (*cmd == NULL) {
		err = 1;
	    }
	}
    }

#if OPDEBUG
    if (*cmd != NULL) {
	fprintf(stderr, "name='%s', cmd='%s'\n", name, *cmd);
    } else {
	fprintf(stderr, "name='%s'\n", name);
    }
#endif
    
    return err;
}

int match_object_command (const char *s)
{
    if (strcmp(s, "show") == 0) {
	return OBJ_ACTION_SHOW;
    } else if (strcmp(s, "free") == 0) {
	return OBJ_ACTION_FREE;
    } else {
	return OBJ_ACTION_INVALID;
    }
}

static void saved_object_free (stacker *s)
{
    if (s == NULL) {
	return;
    }

    if (s->type == GRETL_OBJ_EQN) {
	if (!model_is_protected(s->ptr)) {
	    gretl_model_free(s->ptr);
	}
    } else if (s->type == GRETL_OBJ_VAR) {
	gretl_VAR_free(s->ptr);
    } else if (s->type == GRETL_OBJ_SYS) {
	equation_system_destroy(s->ptr);
    }
}

#define sys_modtest_opt_ok(o) (o & (OPT_A | OPT_H | OPT_N))

int last_model_test_ok (int ci, gretlopt opt, const DATASET *dset, 
			PRN *prn)
{
    GretlObjType type;
    void *ptr;
    int err = 0;

    ptr = get_last_model(&type);  
    if (ptr == NULL) {
	pputs(prn, _("Can't do this: no model has been estimated yet\n"));
	return E_DATA;
    }

    if (type == GRETL_OBJ_EQN) {
	MODEL *pmod = (MODEL *) ptr;
  
	if (!model_test_ok(ci, opt, pmod, dset)) {
	    err = E_NOTIMP;
	}
	if (model_sample_problem(pmod, dset)) {
	    pputs(prn, _("Can't do: the current data set is different from "
			 "the one on which\nthe reference model was estimated\n"));
	    err = E_DATA;
	}
    } else if (type == GRETL_OBJ_SYS) {
	err = E_NOTIMP;
	if (ci == RESTRICT || ci == FCAST) {
	    err = 0;
	} else if (ci == MODTEST && sys_modtest_opt_ok(opt)) {
	    err = 0;
	}
    } else if (type == GRETL_OBJ_VAR) {
	GRETL_VAR *var = (GRETL_VAR *) ptr;
	int r = gretl_VECM_rank(var);

	err = E_NOTIMP;

	if (ci == RESTRICT && r > 0) {
	    err = 0;
	} else if (ci == FCAST) {
	    err = 0;
	} else if (ci == MODTEST && sys_modtest_opt_ok(opt)) {
	    err = 0;
	} else if (ci == OMIT && r == 0 && !(opt & OPT_A)) {
	    /* we can handle a test on exogenous terms in a VAR */
	    err = 0;
	}
    }

    return err;
}

int last_model_test_uhat (DATASET *dset, gretlopt opt, PRN *prn)
{
    GretlObjType type;
    void *ptr;
    int err = 0;

    ptr = get_last_model(&type);  
    if (ptr == NULL) {
	return E_DATA;
    }

    if (type == GRETL_OBJ_EQN) {
	err = model_error_dist(ptr, dset, opt, prn);
    } else if (type == GRETL_OBJ_SYS) {
	err = system_normality_test(ptr, prn);
    } else if (type == GRETL_OBJ_VAR) {
	err = gretl_VAR_normality_test(ptr, prn);
    } else {
	err = E_DATA;
    }

    return err;
}

int highest_numbered_var_in_saved_object (const DATASET *dset)
{
    GretlObjType type;
    void *ptr;
    int i, mvm, vmax = 0;

    for (i=-1; i<n_obj; i++) {
	if (i < 0) {
	    ptr = get_last_model(&type);
	} else {
	    ptr = ostack[i].ptr;
	    type = ostack[i].type;
	}
	if (ptr == NULL) {
	    continue;
	}
	if (type == GRETL_OBJ_EQN) {
	    mvm = highest_numbered_var_in_model((MODEL *) ptr, dset);
	    if (mvm > vmax) {
		vmax = mvm;
	    }
	} else if (type == GRETL_OBJ_VAR) {
	    mvm = gretl_VAR_get_highest_variable((GRETL_VAR *) ptr);
	    if (mvm > vmax) {
		vmax = mvm;
	    }
	} else if (type == GRETL_OBJ_SYS) {
	    mvm = highest_numbered_var_in_system((equation_system *) ptr, dset);
	    if (mvm > vmax) {
		vmax = mvm;
	    }
	}
    }

    return vmax;
}

int check_variable_deletion_list (int *list, const DATASET *dset)
{
    int pruned = 0;
    int i, vsave;

    vsave = highest_numbered_var_in_saved_object(dset);

    for (i=list[0]; i>0; i--) {
	if (list[i] <= vsave) {
	    gretl_list_delete_at_pos(list, i);
	    pruned = 1;
	}
    }

    return pruned;
}

void gretl_saved_objects_cleanup (void)
{
    void *lmp = last_model.ptr;
    int lmt = last_model.type;
    int i;

#if ODEBUG
    fprintf(stderr, "gretl_saved_objects_cleanup, n_obj = %d\n", n_obj);
#endif

    for (i=0; i<n_obj; i++) {
	if (ostack[i].ptr == lmp) {
	    /* stacked object i also occupies the "last model" place;
	       so we drop the associated refcount and nullify the
	       last model pointer to guard against double-freeing
	    */
	    gretl_object_unref(lmp, lmt);
	    lmp = NULL;
	}
#if ODEBUG
	fprintf(stderr, " calling saved_object_free on ostack[%d] (%p)\n", 
		i, ostack[i].ptr);
#endif
	saved_object_free(&ostack[i]);
    }

    free(ostack);
    ostack = NULL;

    n_obj = 0;
    n_sys = 0;
    n_vars = 0;

    if (lmp != NULL) {
	if (lmt != GRETL_OBJ_EQN || !model_is_protected(lmp)) {
#if ODEBUG
	    fprintf(stderr, "gretl_saved_objects_cleanup:\n"
		    " calling gretl_object_destroy on last_model (%p)\n", lmp);
#endif
	    gretl_object_destroy(lmp, lmt);
	}
	last_model.ptr = NULL;
	last_model.type = 0;
    }
}

