akbasic/src/variable.c

/**
 * @file variable.c
 * @brief Implements the named variable slot and its subscript arithmetic.
 */

#include <inttypes.h>

#include <akerror.h>
#include <akstdlib.h>

#include <akbasic/error.h>
#include <akbasic/variable.h>

/*
 * Flatten a subscript list to an index, walking the dimensions from the last to
 * the first exactly as the reference does. The bounds message is reproduced
 * character for character: tests/language/array_outofbounds.txt compares it with
 * strcmp, so a reworded message is a failing golden case.
 */
static akerr_ErrorContext *flatten_subscripts(akbasic_Variable *obj, int64_t *subscripts, int subscriptcount, int64_t *dest)
{
    PREPARE_ERROR(errctx);
    int64_t flatindex = 0;
    int64_t multiplier = 1;
    int i = 0;

    for ( i = subscriptcount - 1; i >= 0; i-- ) {
	FAIL_NONZERO_RETURN(errctx,
			    (subscripts[i] < 0 || subscripts[i] >= obj->dimensions[i]),
			    AKBASIC_ERR_BOUNDS,
			    "Variable index access out of bounds at dimension %d: %" PRId64 " (max %" PRId64 ")",
			    i, subscripts[i], obj->dimensions[i] - 1);
	flatindex += subscripts[i] * multiplier;
	multiplier *= obj->dimensions[i];
    }
    *dest = flatindex;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_init(akbasic_Variable *obj, akbasic_ValuePool *pool, int64_t *sizes, int sizecount)
{
    PREPARE_ERROR(errctx);
    int64_t totalsize = 1;
    size_t namelen = 0;
    char lastchar = '\0';
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL variable in init");
    FAIL_ZERO_RETURN(errctx, (pool != NULL), AKERR_NULLPOINTER, "NULL value pool in variable init");
    FAIL_ZERO_RETURN(errctx, (sizes != NULL), AKERR_NULLPOINTER, "NULL sizes in variable init");
    FAIL_ZERO_RETURN(errctx, (sizecount > 0 && sizecount <= AKBASIC_MAX_ARRAY_DEPTH),
		     AKBASIC_ERR_BOUNDS,
		     "Array dimension count %d out of range 1..%d",
		     sizecount, AKBASIC_MAX_ARRAY_DEPTH);

    PASS(errctx, aksl_strlen(obj->name, &namelen));
    FAIL_ZERO_RETURN(errctx, (namelen > 0), AKBASIC_ERR_VALUE, "Invalid variable name");

    /* Type comes from the suffix. A bare name keeps whatever type it had. */
    lastchar = obj->name[namelen - 1];
    switch ( lastchar ) {
    case '$':
	obj->valuetype = AKBASIC_TYPE_STRING;
	break;
    case '#':
	obj->valuetype = AKBASIC_TYPE_INTEGER;
	break;
    case '%':
	obj->valuetype = AKBASIC_TYPE_FLOAT;
	break;
    default:
	break;
    }

    for ( i = 0; i < sizecount; i++ ) {
	FAIL_NONZERO_RETURN(errctx, (sizes[i] <= 0), AKBASIC_ERR_VALUE,
			    "Array dimensions must be positive integers");
	FAIL_NONZERO_RETURN(errctx, (sizes[i] > AKBASIC_MAX_ARRAY_ELEMENTS),
			    AKBASIC_ERR_BOUNDS,
			    "Array dimension %d of %" PRId64 " exceeds the %d element limit",
			    i, sizes[i], AKBASIC_MAX_ARRAY_ELEMENTS);
	totalsize *= sizes[i];
	FAIL_NONZERO_RETURN(errctx, (totalsize > AKBASIC_MAX_ARRAY_ELEMENTS),
			    AKBASIC_ERR_BOUNDS,
			    "Array of %" PRId64 " total elements exceeds the %d element limit",
			    totalsize, AKBASIC_MAX_ARRAY_ELEMENTS);
	obj->dimensions[i] = sizes[i];
    }
    obj->dimensioncount = sizecount;

    /*
     * A scalar lives in the variable; only a run of more than one value comes
     * from the pool.
     *
     * That is not an optimisation, it is what makes a name created inside a
     * scope cost nothing. The pool never frees and a scope exit returns the
     * variable slot without returning its storage, so every GOSUB that created
     * a local used to spend slots that never came back -- 4096 creations and
     * the run was over, which a game loop reaches in half a minute. TODO.md
     * section 6 item 30 has the whole reduction.
     *
     * **A `@` name is the one exclusion**, and it is the whole of it. A
     * structure or a pointer to one keeps pool storage because a pointer may
     * outlive the scope that DIMmed it -- docs/16-structures.md says nothing is
     * reclaimed and akbasic_runtime_prev_environment() relies on it. The suffix
     * is the right test rather than `structtype`, which the DIM path sets
     * *after* calling this.
     *
     * Otherwise: reuse the existing slice when it is already big enough, which
     * makes a re-DIM to the same or a smaller size free; growing takes fresh
     * slots and abandons the old ones, as documented on akbasic_ValuePool.
     */
    if ( totalsize == 1 && lastchar != '@' ) {
	obj->values = &obj->inlinevalue;
    } else if ( obj->values == NULL || obj->valuecount < (int)totalsize ) {
	PASS(errctx, akbasic_valuepool_take(pool, (int)totalsize, &obj->values));
    }
    obj->valuecount = (int)totalsize;

    for ( i = 0; i < (int)totalsize; i++ ) {
	PASS(errctx, akbasic_value_init(&obj->values[i]));
	PASS(errctx, akbasic_value_zero(&obj->values[i]));
	obj->values[i].valuetype = obj->valuetype;
	obj->values[i].mutable_ = true;
    }
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_zero(akbasic_Variable *obj)
{
    PREPARE_ERROR(errctx);

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL variable in zero");
    /*
     * -1 rather than 0, because 0 is a perfectly good type index: a variable
     * that was never DIMmed AS anything would otherwise claim to be the first
     * type the program declared.
     */
    obj->structtype = -1;
    obj->ispointer = false;
    obj->valuetype = AKBASIC_TYPE_UNDEFINED;
    obj->mutable_ = true;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_get_subscript(akbasic_Variable *obj, int64_t *subscripts, int subscriptcount, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    int64_t index = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL variable in get_subscript");
    FAIL_ZERO_RETURN(errctx, (subscripts != NULL), AKERR_NULLPOINTER, "NULL subscripts in get_subscript");
    FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in get_subscript");
    FAIL_ZERO_RETURN(errctx, (obj->values != NULL), AKERR_NULLPOINTER,
		     "Variable %s has no storage", obj->name);
    FAIL_ZERO_RETURN(errctx, (subscriptcount == obj->dimensioncount),
		     AKBASIC_ERR_BOUNDS,
		     "Variable %s has %d dimensions, received %d",
		     obj->name, obj->dimensioncount, subscriptcount);

    PASS(errctx, flatten_subscripts(obj, subscripts, subscriptcount, &index));
    *dest = &obj->values[index];
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_set_subscript(akbasic_Variable *obj, akbasic_Value *value, int64_t *subscripts, int subscriptcount)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *slot = NULL;

    FAIL_ZERO_RETURN(errctx, (value != NULL), AKERR_NULLPOINTER, "NULL value in set_subscript");
    PASS(errctx, akbasic_variable_get_subscript(obj, subscripts, subscriptcount, &slot));
    PASS(errctx, akbasic_value_clone(value, slot));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_set_integer(akbasic_Variable *obj, int64_t value, int64_t *subscripts, int subscriptcount)
{
    PREPARE_ERROR(errctx);
    akbasic_Value tmp;

    PASS(errctx, akbasic_value_zero(&tmp));
    tmp.valuetype = AKBASIC_TYPE_INTEGER;
    tmp.intval = value;
    PASS(errctx, akbasic_variable_set_subscript(obj, &tmp, subscripts, subscriptcount));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_set_float(akbasic_Variable *obj, double value, int64_t *subscripts, int subscriptcount)
{
    PREPARE_ERROR(errctx);
    akbasic_Value tmp;

    PASS(errctx, akbasic_value_zero(&tmp));
    tmp.valuetype = AKBASIC_TYPE_FLOAT;
    tmp.floatval = value;
    PASS(errctx, akbasic_variable_set_subscript(obj, &tmp, subscripts, subscriptcount));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_variable_set_string(akbasic_Variable *obj, const char *value, int64_t *subscripts, int subscriptcount)
{
    PREPARE_ERROR(errctx);
    akbasic_Value tmp;
    size_t valuelen = 0;

    FAIL_ZERO_RETURN(errctx, (value != NULL), AKERR_NULLPOINTER, "NULL string in set_string");
    PASS(errctx, aksl_strlen(value, &valuelen));
    FAIL_ZERO_RETURN(errctx, (valuelen < AKBASIC_MAX_STRING_LENGTH),
		     AKBASIC_ERR_VALUE,
		     "String of %zu characters exceeds the %d character limit",
		     valuelen, AKBASIC_MAX_STRING_LENGTH - 1);
    PASS(errctx, akbasic_value_zero(&tmp));
    tmp.valuetype = AKBASIC_TYPE_STRING;
    PASS(errctx, aksl_strcpy(tmp.stringval, sizeof(tmp.stringval), value));
    PASS(errctx, akbasic_variable_set_subscript(obj, &tmp, subscripts, subscriptcount));
    SUCCEED_RETURN(errctx);
}