/***********************************************************************
 *               Copyright (C) 1995 Joe English
 *                   Freely redistributable
 ***********************************************************************
 *
 * bindings.c,v 1.8 1998/11/10 00:06:50 jenglish Exp"
 *
 * Author: 	Joe English
 * Created: 	7 May 1995
 * Description: Scoped name=value bindings.
 *		%%% How about some comments, Joe?
 *		%%% Rename the structures while you're at it.
 *
 * 1998/11/10 00:06:50
 * 1.8
 */

#include <stdlib.h>
#include <string.h>
#include "tcl.h"
#include "project.h"

/*
 * Data structures:
 */

typedef struct Env EnvRec, *Env;
typedef struct Vcell VcellRec, *Vcell;
typedef struct Bindings BindingsRec, *Bindings;

struct Vcell	/* value cell */
{
    char 	*value; 	/* current value */
    int 	level;	/* environment in which this binding was made */
};

struct Env
{
    Env		prev; 		/* previous environment */
    Vcell	vcell;
    VcellRec 	saved;		/* saved previous value of vcell */
    int 	level;
};

struct Bindings
{
    Tcl_HashTable	vcells;		/* map name -> vcell */
    int			curlevel;	/* current grouping level */
    Env 		stack;		/* save stack */
};

Bindings env_create(void)
{
    Bindings b = malloc(sizeof(*b));

    Tcl_InitHashTable(&b->vcells, TCL_STRING_KEYS);
    b->curlevel = 0;
    b->stack = 0;

    return b;
}

static Vcell env_lookup(Bindings b, const char *name)
{
    Tcl_HashEntry *h;
    Vcell v;
    int new;

    h = Tcl_CreateHashEntry(&b->vcells, (/*!const*/char *)name, &new);
    if (new) {
	v = malloc(sizeof(*v));
	v->level = -1;
	v->value = 0;
	Tcl_SetHashValue(h,(ClientData)v);
    } else {
	v = (Vcell)Tcl_GetHashValue(h);
    }

    return v;
}

char *env_get(Bindings b, const char *name)
{
    Vcell v = env_lookup(b,name);
    return v->value;
}

void env_set(Bindings b, const char *name, const char *val)
{
    Vcell v = env_lookup(b,name);
    char *value;
    Env s;

    value = malloc(strlen(val) + 1);
    strcpy(value,val);
    if (v->level == b->curlevel)
    {	/* replace existing binding */
	free(v->value);
	v->value = value;
	return;
    }
    ASSERT(v->level < b->curlevel, "Oops.");

    /* Create new save stack entry: */
    s = malloc(sizeof(*s));
    s->prev = b->stack; b->stack = s;
    s->vcell = v;
    s->saved = *v;
    s->level = b->curlevel;

    v->level = b->curlevel;
    v->value = value;
    return;
}

void env_save(Bindings b)
{
    ++b->curlevel;
}

int env_restore(Bindings b)
{
    Env s = b->stack;

    if (b->curlevel <= 0)
	return 0;

    --b->curlevel;

    while (s && s->level > b->curlevel)
    {
	ASSERT(s->level == b->curlevel + 1, "Oops 2.");
	free(s->vcell->value);
	*(s->vcell) = s->saved;
	s = s->prev;
	free(b->stack);
	b->stack = s;
    }

    return 1;
}

void env_destroy(Bindings b)
{
    Tcl_HashEntry *h;
    Tcl_HashSearch hs;
    Env s = b->stack;

    while (s)
    {
	Env ss = s->prev;
	if (s->saved.value) free(s->saved.value);
	free(s);
	s = ss;
    }

    h = Tcl_FirstHashEntry(&b->vcells, &hs);
    while (h)
    {
	Vcell v = (Vcell)Tcl_GetHashValue(h);
	if (v->value) free(v->value);
	free(v);
	h = Tcl_NextHashEntry(&hs);
    }

    Tcl_DeleteHashTable(&b->vcells);
    free(b);
    return;
}

/*
 * Tcl interface:
 */

/* auxilliary routine: set multiple bindings. */
static int setbindings(Tcl_Interp *interp, Bindings b, char **nvpairs, int len)
{
    int i;
    char **pairs = 0;

    if (len == 1) {
	int status = Tcl_SplitList(interp, nvpairs[0], &len, &pairs);
	if (status == TCL_ERROR) return TCL_ERROR;
    } else {
	pairs = nvpairs;
    }

    if (len % 2 != 0) {
	Tcl_SetResult(interp, "odd number of elements in name-value list",
		TCL_STATIC);
	if (pairs != nvpairs) Tcl_FreeSplitList(pairs);
	return TCL_ERROR;
    }
    for (i=0; i<len; i += 2)
	env_set(b,pairs[i],pairs[i+1]);

    if (pairs != nvpairs) Tcl_FreeSplitList(pairs);

    return TCL_OK;
}

static int EnvironmentProc(ClientData clientData, Tcl_Interp *interp,
			int argc, char *argv[])
{
    Bindings b = (Bindings)clientData;
    char *subcmd = argv[1];

    if (argc <= 1)
	goto usage;

    if (!strcmp(subcmd,"get"))
    {
	char *name;
	char *value;
	if (argc < 3 || argc > 4) goto usage;
	name = argv[2];
	value = env_get(b,name);
	if (value) {
	    Tcl_SetResult(interp, value, TCL_VOLATILE);
	    return TCL_OK;
	} else if (argc == 4)  {
	    Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
	    return TCL_OK;
	} else {
	    Tcl_AppendResult(interp, argv[0], ": no binding for ", name, NULL);
	    return TCL_ERROR;
	}
    }
    else if (!strcmp(subcmd,"set"))
    {
	if (argc < 3) goto usage;
	return setbindings(interp, b, argv+2, argc - 2);
    }
    else if (!strcmp(subcmd,"save") || !strcmp(subcmd,"bgroup"))
    {
	if (argc < 2) goto usage;
	env_save(b);
	return setbindings(interp, b, argv+2, argc - 2);
    }
    else if (!strcmp(subcmd,"restore") || !strcmp(subcmd,"egroup"))
    {
	int status;
	if (argc != 2) goto usage;
	status = env_restore(b);
	if (status)
	    return TCL_OK;
	/* else */
	Tcl_AppendResult(interp, argv[0], ": overpopped stack", NULL);
	return TCL_ERROR;
    }
    /* else  */
usage:
    Tcl_AppendResult(interp, "Usage: ", argv[0],
	" [save ?name value ...? | restore | get name | set ?name value...?]",
	0);
    return TCL_ERROR;
}

static void DeleteEnvironmentProc(ClientData clientData)
{
    env_destroy((Bindings)clientData);
}

/* defineEnvironment envname [ n1 v1 n2 v2 ... ] */
	/*ARGSUSED*/
int DefineEnvironmentProc(ClientData clientData, Tcl_Interp *interp,
			int argc, char *argv[])
{
    char *cmdName;
    Bindings b;

    if (argc < 2) {
	Tcl_AppendResult(interp,
	    "Usage: ", argv[0], " envname", " ?name value...?", NULL);
	return TCL_ERROR;
    }

    cmdName = argv[1];
    b = env_create();
    Tcl_CreateCommand(interp,cmdName,EnvironmentProc,
	(ClientData)b,DeleteEnvironmentProc);

    Tcl_SetResult(interp, cmdName, TCL_VOLATILE);
    return setbindings(interp, b, argv+2, argc-2);
}