akbasic/src/environment.c

/**
 * @file environment.c
 * @brief Implements the scope and per-line working state.
 */

#include <inttypes.h>
#include <string.h>

#include <akerror.h>

#include <akbasic/environment.h>
#include <akbasic/error.h>
#include <akbasic/runtime.h>

akerr_ErrorContext *akbasic_environment_init(akbasic_Environment *obj, akbasic_Runtime *runtime, akbasic_Environment *parent)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL environment in init");
    FAIL_ZERO_RETURN(errctx, (runtime != NULL), AKERR_NULLPOINTER, "NULL runtime in environment init");

    PASS(errctx, akbasic_symtab_init(&obj->variables, AKBASIC_MAX_VARIABLES));
    PASS(errctx, akbasic_symtab_init(&obj->functions, AKBASIC_MAX_FUNCTIONS));
    PASS(errctx, akbasic_symtab_init(&obj->labels, AKBASIC_MAX_LABELS));

    obj->parent = parent;
    obj->runtime = runtime;
    obj->forNextVariable = NULL;
    obj->forStepLeaf = NULL;
    obj->forToLeaf = NULL;
    obj->loopFirstLine = 0;
    obj->loopExitLine = 0;
    obj->exiting = false;
    obj->doConditionLeaf = NULL;
    obj->doConditionKind = AKBASIC_LOOPCOND_NONE;
    obj->isDoLoop = false;
    obj->gosubReturnLine = 0;
    obj->readReturnLine = 0;
    obj->readIdentifierIdx = 0;
    obj->waitingForCommand[0] = '\0';
    obj->errorToken = NULL;
    memset(obj->readIdentifierLeaves, 0, sizeof(obj->readIdentifierLeaves));
    obj->doLeafPool.next = 0;
    obj->doLeafPool.capacity = AKBASIC_MAX_CONDITION_LEAVES;
    obj->doLeafPool.leaves = obj->doLeafStorage;
    obj->readLeafPool.next = 0;
    obj->readLeafPool.capacity = AKBASIC_MAX_LEAVES;
    obj->readLeafPool.leaves = obj->readLeafStorage;

    PASS(errctx, akbasic_value_zero(&obj->forStepValue));
    PASS(errctx, akbasic_value_zero(&obj->forToValue));
    PASS(errctx, akbasic_value_zero(&obj->returnValue));

    if ( obj->parent != NULL ) {
	obj->lineno = obj->parent->lineno;
	obj->nextline = obj->parent->nextline;
    } else {
	obj->lineno = 0;
	obj->nextline = 0;
    }
    obj->nextvalue = 0;
    PASS(errctx, akbasic_environment_zero_parser(obj));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_zero(akbasic_Environment *obj)
{
    PREPARE_ERROR(errctx);
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL environment in zero");
    for ( i = 0; i < AKBASIC_MAX_VALUES; i++ ) {
	PASS(errctx, akbasic_value_init(&obj->values[i]));
    }
    obj->nextvalue = 0;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_zero_parser(akbasic_Environment *obj)
{
    PREPARE_ERROR(errctx);
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL environment in zero_parser");
    for ( i = 0; i < AKBASIC_MAX_LEAVES; i++ ) {
	PASS(errctx, akbasic_leaf_init(&obj->leaves[i], AKBASIC_LEAF_UNDEFINED));
    }
    for ( i = 0; i < AKBASIC_MAX_TOKENS; i++ ) {
	PASS(errctx, akbasic_token_init(&obj->tokens[i]));
    }
    obj->curtoken = 0;
    obj->nexttoken = 0;
    obj->nextleaf = 0;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_new_value(akbasic_Environment *obj, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in new_value");
    FAIL_ZERO_RETURN(errctx, (obj->nextvalue < AKBASIC_MAX_VALUES), AKBASIC_ERR_BOUNDS,
		     "Maximum values per line reached");
    *dest = &obj->values[obj->nextvalue];
    obj->nextvalue += 1;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_new_leaf(akbasic_Environment *obj, akbasic_ASTLeaf **dest)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in new_leaf");
    FAIL_ZERO_RETURN(errctx, (obj->nextleaf < AKBASIC_MAX_LEAVES), AKBASIC_ERR_BOUNDS,
		     "No more leaves available");
    *dest = &obj->leaves[obj->nextleaf];
    obj->nextleaf += 1;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_wait_for_command(akbasic_Environment *obj, const char *command)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && command != NULL), AKERR_NULLPOINTER,
		     "NULL argument in wait_for_command");
    /*
     * The reference panics here. An interpreter library may not take the process
     * with it, so this raises instead -- but it is still a hard failure, because
     * two pending waits in one environment means the block structure is already
     * corrupt.
     */
    FAIL_NONZERO_RETURN(errctx, (obj->waitingForCommand[0] != '\0'), AKBASIC_ERR_STATE,
			"Can't wait on multiple commands in the same environment : %s",
			obj->waitingForCommand);
    FAIL_ZERO_RETURN(errctx, (strlen(command) < sizeof(obj->waitingForCommand)),
		     AKBASIC_ERR_BOUNDS, "Command name '%s' is too long to wait on", command);
    strncpy(obj->waitingForCommand, command, sizeof(obj->waitingForCommand) - 1);
    obj->waitingForCommand[sizeof(obj->waitingForCommand) - 1] = '\0';
    SUCCEED_RETURN(errctx);
}

bool akbasic_environment_is_waiting_for_any(akbasic_Environment *obj)
{
    if ( obj == NULL ) {
	return false;
    }
    if ( obj->waitingForCommand[0] != '\0' ) {
	return true;
    }
    return akbasic_environment_is_waiting_for_any(obj->parent);
}

bool akbasic_environment_is_waiting_for(akbasic_Environment *obj, const char *command)
{
    if ( obj == NULL || command == NULL ) {
	return false;
    }
    if ( strcmp(obj->waitingForCommand, command) == 0 ) {
	return true;
    }
    return akbasic_environment_is_waiting_for(obj->parent, command);
}

akerr_ErrorContext *akbasic_environment_stop_waiting(akbasic_Environment *obj, const char *command)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && command != NULL), AKERR_NULLPOINTER,
		     "NULL argument in stop_waiting");
    /*
     * The reference ignores `command` and clears unconditionally, which lets an
     * inner block clear an outer block's wait (TODO.md section 12 item 3). The
     * argument is honoured here only to the extent of walking to the environment
     * that is actually waiting for it -- clearing the wrong one outright would
     * change observable control flow, so the search stops at the first match and
     * a miss is silently tolerated, exactly as today.
     */
    while ( obj != NULL ) {
	if ( strcmp(obj->waitingForCommand, command) == 0 ) {
	    obj->waitingForCommand[0] = '\0';
	    SUCCEED_RETURN(errctx);
	}
	obj = obj->parent;
    }
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_get_function(akbasic_Environment *obj, const char *fname, void **dest)
{
    PREPARE_ERROR(errctx);
    char upper[AKBASIC_SYMTAB_MAX_KEY];
    size_t i = 0;
    size_t len = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && fname != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in get_function");
    len = strlen(fname);
    FAIL_ZERO_RETURN(errctx, (len < sizeof(upper)), AKERR_KEY, "Function '%s' is not defined", fname);
    for ( i = 0; i < len; i++ ) {
	char c = fname[i];
	upper[i] = (char)((c >= 'a' && c <= 'z') ? (c - 'a' + 'A') : c);
    }
    upper[len] = '\0';

    while ( obj != NULL ) {
	akerr_ErrorContext *found = akbasic_symtab_get(&obj->functions, upper, dest, NULL);
	if ( found == NULL ) {
	    SUCCEED_RETURN(errctx);
	}
	found->handled = true;
	IGNORE(akerr_release_error(found));
	obj = obj->parent;
    }
    FAIL_RETURN(errctx, AKERR_KEY, "Function '%s' is not defined", fname);
}

akerr_ErrorContext *akbasic_environment_get_label(akbasic_Environment *obj, const char *label, int64_t *dest)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && label != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in get_label");
    while ( obj != NULL ) {
	akerr_ErrorContext *found = akbasic_symtab_get(&obj->labels, label, NULL, dest);
	if ( found == NULL ) {
	    SUCCEED_RETURN(errctx);
	}
	found->handled = true;
	IGNORE(akerr_release_error(found));
	obj = obj->parent;
    }
    FAIL_RETURN(errctx, AKBASIC_ERR_UNDEFINED,
		"Unable to find or create label %s in environment", label);
}

akerr_ErrorContext *akbasic_environment_set_label(akbasic_Environment *obj, const char *label, int64_t value)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL && label != NULL), AKERR_NULLPOINTER,
		     "NULL argument in set_label");
    /* Only the top-level environment creates labels. */
    while ( obj != NULL && obj->runtime->environment != obj ) {
	obj = obj->parent;
    }
    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKBASIC_ERR_ENVIRONMENT,
		     "Unable to create label in orphaned environment");
    PASS(errctx, akbasic_symtab_set(&obj->labels, label, NULL, value));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_get(akbasic_Environment *obj, const char *varname, akbasic_Variable **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Environment *walk = NULL;
    void *slot = NULL;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && varname != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in environment get");

    *dest = NULL;
    for ( walk = obj; walk != NULL; walk = walk->parent ) {
	akerr_ErrorContext *found = akbasic_symtab_get(&walk->variables, varname, &slot, NULL);
	if ( found == NULL ) {
	    *dest = (akbasic_Variable *)slot;
	    SUCCEED_RETURN(errctx);
	}
	found->handled = true;
	IGNORE(akerr_release_error(found));
    }

    /*
     * Parents do not create variables for their children: only the currently
     * active environment auto-creates. A miss anywhere else returns NULL without
     * error, which the caller is expected to notice.
     */
    if ( obj->runtime->environment != obj ) {
	SUCCEED_RETURN(errctx);
    }

    PASS(errctx, akbasic_environment_create(obj, varname, dest));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_create(akbasic_Environment *obj, const char *varname, akbasic_Variable **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Variable *variable = NULL;
    int64_t sizes[1] = { 1 };
    void *slot = NULL;
    akerr_ErrorContext *found = NULL;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && varname != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in environment create");

    /*
     * This scope only. Unlike akbasic_environment_get() there is no walk up the
     * parent chain: the caller has already said *which* scope it means, and
     * finding an outer one would put the variable somewhere other than where it
     * was asked for.
     */
    *dest = NULL;
    found = akbasic_symtab_get(&obj->variables, varname, &slot, NULL);
    if ( found == NULL ) {
	*dest = (akbasic_Variable *)slot;
	SUCCEED_RETURN(errctx);
    }
    found->handled = true;
    IGNORE(akerr_release_error(found));

    PASS(errctx, akbasic_runtime_new_variable(obj->runtime, &variable));
    FAIL_ZERO_RETURN(errctx, (strlen(varname) < sizeof(variable->name)), AKBASIC_ERR_BOUNDS,
		     "Variable name '%s' is too long", varname);
    strncpy(variable->name, varname, sizeof(variable->name) - 1);
    variable->name[sizeof(variable->name) - 1] = '\0';
    variable->valuetype = AKBASIC_TYPE_UNDEFINED;
    variable->mutable_ = true;
    PASS(errctx, akbasic_variable_init(variable, &obj->runtime->valuepool, sizes, 1));
    PASS(errctx, akbasic_symtab_set(&obj->variables, varname, variable, 0));
    *dest = variable;
    SUCCEED_RETURN(errctx);
}

/*
 * Evaluate an lvalue's subscript list, if it has one, into `subscripts`. A bare
 * identifier yields the single subscript {0}, which is how a scalar is addressed
 * -- every variable is really a one-element array.
 */
static akerr_ErrorContext *collect_subscripts(akbasic_Environment *obj, akbasic_ASTLeaf *lval, int64_t *subscripts, int *count)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *expr = NULL;
    akbasic_Value *tval = NULL;

    *count = 0;
    if ( lval->expr != NULL &&
	 lval->expr->leaftype == AKBASIC_LEAF_ARGUMENTLIST &&
	 lval->expr->operator_ == AKBASIC_TOK_ARRAY_SUBSCRIPT ) {
	for ( expr = lval->expr->right; expr != NULL; expr = expr->next ) {
	    FAIL_ZERO_RETURN(errctx, (*count < AKBASIC_MAX_ARRAY_DEPTH), AKBASIC_ERR_BOUNDS,
			     "More than %d array subscripts", AKBASIC_MAX_ARRAY_DEPTH);
	    PASS(errctx, akbasic_runtime_evaluate(obj->runtime, expr, &tval));
	    FAIL_NONZERO_RETURN(errctx, (tval->valuetype != AKBASIC_TYPE_INTEGER),
				AKBASIC_ERR_TYPE,
				"Array dimensions must evaluate to integer (B)");
	    subscripts[*count] = tval->intval;
	    *count += 1;
	}
    }
    if ( *count == 0 ) {
	subscripts[0] = 0;
	*count = 1;
    }
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_environment_assign(akbasic_Environment *obj, akbasic_ASTLeaf *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Variable *variable = NULL;
    int64_t subscripts[AKBASIC_MAX_ARRAY_DEPTH];
    int subscriptcount = 0;
    akbasic_Value *slot = NULL;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && lval != NULL && rval != NULL && dest != NULL),
		     AKERR_NULLPOINTER, "nil pointer");

    PASS(errctx, akbasic_environment_get(obj, lval->identifier, &variable));
    FAIL_ZERO_RETURN(errctx, (variable != NULL), AKBASIC_ERR_UNDEFINED,
		     "Identifier %s is undefined", lval->identifier);
    PASS(errctx, collect_subscripts(obj, lval, subscripts, &subscriptcount));

    /*
     * Resolve the slot before the type switch. The reference notes that moving
     * this below the switch corrupts the subscript list; here it is simply the
     * clearer order, and the returned pointer is what an assignment expression
     * evaluates to.
     */
    PASS(errctx, akbasic_variable_get_subscript(variable, subscripts, subscriptcount, &slot));

    switch ( lval->leaftype ) {
    case AKBASIC_LEAF_IDENTIFIER_INT:
	if ( rval->valuetype == AKBASIC_TYPE_INTEGER ) {
	    PASS(errctx, akbasic_variable_set_integer(variable, rval->intval, subscripts, subscriptcount));
	} else if ( rval->valuetype == AKBASIC_TYPE_FLOAT ) {
	    PASS(errctx, akbasic_variable_set_integer(variable, (int64_t)rval->floatval, subscripts, subscriptcount));
	} else {
	    FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "Incompatible types in variable assignment");
	}
	break;
    case AKBASIC_LEAF_IDENTIFIER_FLOAT:
	if ( rval->valuetype == AKBASIC_TYPE_INTEGER ) {
	    PASS(errctx, akbasic_variable_set_float(variable, (double)rval->intval, subscripts, subscriptcount));
	} else if ( rval->valuetype == AKBASIC_TYPE_FLOAT ) {
	    PASS(errctx, akbasic_variable_set_float(variable, rval->floatval, subscripts, subscriptcount));
	} else {
	    FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "Incompatible types in variable assignment");
	}
	break;
    case AKBASIC_LEAF_IDENTIFIER_STRING:
	FAIL_NONZERO_RETURN(errctx, (rval->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			    "Incompatible types in variable assignment");
	PASS(errctx, akbasic_variable_set_string(variable, rval->stringval, subscripts, subscriptcount));
	break;
    default:
	FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "Invalid assignment");
    }
    variable->valuetype = rval->valuetype;
    *dest = slot;
    SUCCEED_RETURN(errctx);
}