akbasic/src/host.c

/**
 * @file host.c
 * @brief Implements host structure binding and the conversions it needs.
 *
 * A host type joins the same table a `TYPE` declaration fills, so everything the
 * language already does with a structure works across the boundary with no
 * second set of rules. What differs is only where a field's bytes are.
 *
 * **The sharing is done with shadow slots.** A binding takes a run of value
 * slots from the same pool a `DIM`med record uses; a field read refreshes its
 * slot from host memory first, and a field write converts back and stores. So a
 * script always sees current values and its writes always land, and the rest of
 * the interpreter goes on seeing one storage model instead of two.
 *
 * **Every conversion refuses rather than truncates.** Writing 70000 into an
 * `int16_t` is an error naming the field, because a silent wrap is the failure
 * mode that gets found three frames later in somebody else's code.
 */

#include <inttypes.h>
#include <stdio.h>

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

#include <akbasic/error.h>
#include <akbasic/host.h>
#include <akbasic/runtime.h>
#include <akbasic/structtype.h>

/**
 * @brief The BASIC type a host field presents as.
 *
 * Every integer width is an integer here, because BASIC has one integer type and
 * a 64-bit one at that. The width still matters -- it is what a write is range
 * checked against -- but it does not change what the script sees.
 */
static akbasic_Type basic_type_of(akbasic_HostFieldKind kind)
{
    switch ( kind ) {
    case AKBASIC_HOSTFIELD_FLOAT:
    case AKBASIC_HOSTFIELD_DOUBLE:	return AKBASIC_TYPE_FLOAT;
    case AKBASIC_HOSTFIELD_CSTRING:	return AKBASIC_TYPE_STRING;
    case AKBASIC_HOSTFIELD_STRUCT:	return AKBASIC_TYPE_STRUCT;
    default:				return AKBASIC_TYPE_INTEGER;
    }
}

/** @brief The type suffix a field name must carry for the C type it describes. */
static char suffix_for(akbasic_HostFieldKind kind)
{
    switch ( basic_type_of(kind) ) {
    case AKBASIC_TYPE_FLOAT:	return '%';
    case AKBASIC_TYPE_STRING:	return '$';
    case AKBASIC_TYPE_STRUCT:	return '@';
    default:			return '#';
    }
}

akerr_ErrorContext *akbasic_host_read_field(akbasic_Runtime *obj, akbasic_StructField *field,
					    void *hostbase, akbasic_Value *dest)
{
    PREPARE_ERROR(errctx);
    const char *at = (const char *)hostbase + field->hostoffset;
    char text[AKBASIC_MAX_STRING_LENGTH];

    (void)obj;
    FAIL_ZERO_RETURN(errctx, (hostbase != NULL && dest != NULL), AKERR_NULLPOINTER,
		     "NULL argument in host read");
    PASS(errctx, akbasic_value_zero(dest));

    switch ( field->hostkind ) {
    case AKBASIC_HOSTFIELD_INT8:   dest->intval = *(const int8_t *)at;   break;
    case AKBASIC_HOSTFIELD_INT16:  dest->intval = *(const int16_t *)at;  break;
    case AKBASIC_HOSTFIELD_INT32:  dest->intval = *(const int32_t *)at;  break;
    case AKBASIC_HOSTFIELD_INT64:  dest->intval = *(const int64_t *)at;  break;
    case AKBASIC_HOSTFIELD_UINT8:  dest->intval = *(const uint8_t *)at;  break;
    case AKBASIC_HOSTFIELD_UINT16: dest->intval = *(const uint16_t *)at; break;
    case AKBASIC_HOSTFIELD_UINT32: dest->intval = *(const uint32_t *)at; break;
    case AKBASIC_HOSTFIELD_BOOL:
	/* -1 and 0, the Commodore convention every condition here already uses. */
	dest->intval = (*(const bool *)at ? AKBASIC_TRUE : AKBASIC_FALSE);
	break;
    case AKBASIC_HOSTFIELD_FLOAT:  dest->floatval = (double)*(const float *)at; break;
    case AKBASIC_HOSTFIELD_DOUBLE: dest->floatval = *(const double *)at;	break;
    case AKBASIC_HOSTFIELD_CSTRING:
	/*
	 * Copied out rather than pointed at, and NUL-terminated even if the host
	 * left it full: a BASIC string is inline and fixed, so there is nothing
	 * to alias and nothing that can outlive the read.
	 */
	/*
	 * Raw snprintf: the host's bytes need not be terminated, and `%.*s`
	 * bounded by hostwidth is what reads at most that many of them. A field
	 * wider than the destination truncates, which is the documented contract
	 * for reading a host string into a fixed BASIC one. libakstdlib #34.
	 */
	snprintf(text, sizeof(text), "%.*s", (int)field->hostwidth, at);
	PASS(errctx, aksl_strcpy(dest->stringval, sizeof(dest->stringval), text));
	break;
    default:
	FAIL_RETURN(errctx, AKBASIC_ERR_TYPE,
		    "Host field %s cannot be read as a value", field->name);
    }
    dest->valuetype = basic_type_of(field->hostkind);
    SUCCEED_RETURN(errctx);
}

/**
 * @brief Convert a value back into the host's own representation, or refuse.
 *
 * The range checks are the reason this is not a memcpy. A host `int16_t` holds
 * -32768..32767 and a script that assigns 70000 has made a mistake -- wrapping
 * it silently would hand the game a number it never asked for and no way to
 * find out where it came from.
 */
akerr_ErrorContext *akbasic_host_write_field(akbasic_Runtime *obj, akbasic_StructField *field,
					     void *hostbase, akbasic_Value *src)
{
    PREPARE_ERROR(errctx);
    char *at = (char *)hostbase + field->hostoffset;
    int64_t n = 0;
    double d = 0.0;
    size_t len = 0;

    (void)obj;
    FAIL_ZERO_RETURN(errctx, (hostbase != NULL && src != NULL), AKERR_NULLPOINTER,
		     "NULL argument in host write");

    if ( basic_type_of(field->hostkind) == AKBASIC_TYPE_INTEGER ) {
	n = (src->valuetype == AKBASIC_TYPE_FLOAT ? (int64_t)src->floatval : src->intval);
    } else if ( basic_type_of(field->hostkind) == AKBASIC_TYPE_FLOAT ) {
	d = (src->valuetype == AKBASIC_TYPE_INTEGER ? (double)src->intval : src->floatval);
    }

#define AKBASIC_HOST_RANGE(__lo, __hi)						\
    FAIL_ZERO_RETURN(errctx, (n >= (int64_t)(__lo) && n <= (int64_t)(__hi)),	\
		     AKBASIC_ERR_VALUE,						\
		     "%" PRId64 " does not fit in %s, which holds %" PRId64	\
		     " to %" PRId64, n, field->name, (int64_t)(__lo), (int64_t)(__hi))

    switch ( field->hostkind ) {
    case AKBASIC_HOSTFIELD_INT8:
	AKBASIC_HOST_RANGE(INT8_MIN, INT8_MAX);   *(int8_t *)at = (int8_t)n;   break;
    case AKBASIC_HOSTFIELD_INT16:
	AKBASIC_HOST_RANGE(INT16_MIN, INT16_MAX); *(int16_t *)at = (int16_t)n; break;
    case AKBASIC_HOSTFIELD_INT32:
	AKBASIC_HOST_RANGE(INT32_MIN, INT32_MAX); *(int32_t *)at = (int32_t)n; break;
    case AKBASIC_HOSTFIELD_INT64:
	*(int64_t *)at = n; break;
    case AKBASIC_HOSTFIELD_UINT8:
	AKBASIC_HOST_RANGE(0, UINT8_MAX);   *(uint8_t *)at = (uint8_t)n;   break;
    case AKBASIC_HOSTFIELD_UINT16:
	AKBASIC_HOST_RANGE(0, UINT16_MAX);  *(uint16_t *)at = (uint16_t)n; break;
    case AKBASIC_HOSTFIELD_UINT32:
	AKBASIC_HOST_RANGE(0, UINT32_MAX);  *(uint32_t *)at = (uint32_t)n; break;
    case AKBASIC_HOSTFIELD_BOOL:
	/* Any nonzero is true, which is what AKBASIC_TRUE being -1 requires. */
	*(bool *)at = (n != 0);
	break;
    case AKBASIC_HOSTFIELD_FLOAT:
	*(float *)at = (float)d;
	break;
    case AKBASIC_HOSTFIELD_DOUBLE:
	*(double *)at = d;
	break;
    case AKBASIC_HOSTFIELD_CSTRING:
	FAIL_ZERO_RETURN(errctx, (src->valuetype == AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			 "%s is a string field", field->name);
	/*
	 * Refused rather than truncated, and the width is the host's: a
	 * `char[32]` holds 31 characters and a script assigning 40 has lost
	 * eight of them. BASIC strings have no width, so this is the one place
	 * the two models genuinely disagree and the disagreement is reported.
	 */
	PASS(errctx, aksl_strlen(src->stringval, &len));
	FAIL_ZERO_RETURN(errctx, (len < field->hostwidth),
			 AKBASIC_ERR_VALUE,
			 "A string of %zu characters does not fit in %s, which holds %zu",
			 len, field->name, field->hostwidth - 1);
	PASS(errctx, aksl_memset(at, 0, field->hostwidth));
	PASS(errctx, aksl_memcpy(at, src->stringval, len));
	break;
    default:
	FAIL_RETURN(errctx, AKBASIC_ERR_TYPE,
		    "Host field %s cannot be written from a value", field->name);
    }
#undef AKBASIC_HOST_RANGE
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_host_refresh(akbasic_Runtime *obj, int typeindex,
					 void *hostbase, akbasic_Value *slots)
{
    PREPARE_ERROR(errctx);
    akbasic_StructType *type = NULL;
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && hostbase != NULL && slots != NULL),
		     AKERR_NULLPOINTER, "NULL argument in host refresh");
    type = &obj->structtypes.types[typeindex];
    for ( i = 0; i < type->fieldcount; i++ ) {
	akbasic_StructField *field = &type->fields[i];
	if ( field->kind == AKBASIC_FIELD_STRUCT ) {
	    PASS(errctx, akbasic_host_refresh(obj, field->typeindex,
					      (char *)hostbase + field->hostoffset,
					      slots + field->offset));
	    continue;
	}
	PASS(errctx, akbasic_host_read_field(obj, field, hostbase, slots + field->offset));
    }
    SUCCEED_RETURN(errctx);
}

/* ------------------------------------------------------------ the API --- */

akerr_ErrorContext *akbasic_host_register_type(akbasic_Runtime *obj, const akbasic_HostType *type)
{
    PREPARE_ERROR(errctx);
    akbasic_StructType *dest = NULL;
    int existing = -1;
    int offset = 0;
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && type != NULL && type->name != NULL),
		     AKERR_NULLPOINTER, "NULL argument in host register_type");
    PASS(errctx, akbasic_structtype_find(&obj->structtypes, type->name, &existing));
    FAIL_NONZERO_RETURN(errctx, (existing >= 0), AKBASIC_ERR_VALUE,
			"TYPE %s is already registered", type->name);
    FAIL_ZERO_RETURN(errctx, (obj->structtypes.count < AKBASIC_MAX_STRUCT_TYPES),
		     AKBASIC_ERR_BOUNDS, "More than %d types", AKBASIC_MAX_STRUCT_TYPES);
    FAIL_ZERO_RETURN(errctx, (type->fieldcount > 0 && type->fieldcount <= AKBASIC_MAX_STRUCT_FIELDS),
		     AKBASIC_ERR_BOUNDS, "%s declares %d fields, which is outside 1..%d",
		     type->name, type->fieldcount, AKBASIC_MAX_STRUCT_FIELDS);

    dest = &obj->structtypes.types[obj->structtypes.count];
    PASS(errctx, aksl_memset(dest, 0, sizeof(*dest)));
    /*
     * Raw snprintf, and a latent defect rather than a settled decision: a host
     * type name over 31 characters truncates silently here, and two that share a
     * 31-character prefix then collide in akbasic_structtype_find. scan_names()
     * in structtype.c already refuses the same case for a script-declared type
     * with an explicit limit message, so the two paths disagree. Converting this
     * to aksl_strcpy is the fix and it is a behaviour change on a public
     * registration call, so it wants its own issue rather than this port.
     */
    snprintf(dest->name, sizeof(dest->name), "%s", type->name);
    dest->used = true;
    dest->ishost = true;
    dest->hostsize = type->size;
    dest->firstline = -1;
    dest->lastline = -1;

    for ( i = 0; i < type->fieldcount; i++ ) {
	const akbasic_HostField *src = &type->fields[i];
	akbasic_StructField *field = &dest->fields[i];
	size_t len = 0;

	FAIL_ZERO_RETURN(errctx, (src->name != NULL), AKERR_NULLPOINTER,
			 "%s field %d has no name", type->name, i);
	PASS(errctx, aksl_strlen(src->name, &len));
	/*
	 * The suffix has to agree with the C type. A host that writes "HP%" over
	 * an int32_t has said two different things about one field, and the
	 * script would believe the suffix -- so the disagreement is refused here
	 * rather than discovered as a wrong answer later.
	 */
	FAIL_ZERO_RETURN(errctx, (len >= 2 && src->name[len - 1] == suffix_for(src->kind)),
			 AKBASIC_ERR_VALUE,
			 "%s.%s must end in '%c' for the C type it describes",
			 type->name, src->name, suffix_for(src->kind));

	/* Same silent truncation as the type name above, and the same fix. */
	snprintf(field->name, sizeof(field->name), "%s", src->name);
	field->hostkind = src->kind;
	field->hostoffset = src->offset;
	field->hostwidth = src->width;
	field->valuetype = basic_type_of(src->kind);
	field->typeindex = -1;
	field->offset = offset;

	if ( src->kind == AKBASIC_HOSTFIELD_STRUCT ) {
	    int nested = -1;
	    FAIL_ZERO_RETURN(errctx, (src->typename_ != NULL), AKERR_NULLPOINTER,
			     "%s.%s is a nested structure and must name its type",
			     type->name, src->name);
	    PASS(errctx, akbasic_structtype_find(&obj->structtypes, src->typename_, &nested));
	    FAIL_ZERO_RETURN(errctx, (nested >= 0), AKBASIC_ERR_UNDEFINED,
			     "%s.%s names type %s, which is not registered",
			     type->name, src->name, src->typename_);
	    field->kind = AKBASIC_FIELD_STRUCT;
	    field->typeindex = nested;
	    field->slotcount = obj->structtypes.types[nested].slotcount;
	} else {
	    field->kind = AKBASIC_FIELD_PRIMITIVE;
	    field->slotcount = 1;
	}
	offset += field->slotcount;
    }
    dest->fieldcount = type->fieldcount;
    dest->slotcount = offset;
    obj->structtypes.count += 1;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_host_bind(akbasic_Runtime *obj, const char *name,
				      const char *typename_, void *instance)
{
    PREPARE_ERROR(errctx);
    akbasic_Variable *variable = NULL;
    int64_t sizes[1] = { 1 };
    size_t len = 0;
    int typeindex = -1;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && name != NULL && typename_ != NULL && instance != NULL),
		     AKERR_NULLPOINTER, "NULL argument in host bind");
    PASS(errctx, aksl_strlen(name, &len));
    FAIL_ZERO_RETURN(errctx, (len >= 2 && name[len - 1] == '@'), AKBASIC_ERR_VALUE,
		     "A structure variable's name ends in '@', so \"%s\" cannot be bound", name);
    PASS(errctx, akbasic_structtype_find(&obj->structtypes, typename_, &typeindex));
    FAIL_ZERO_RETURN(errctx, (typeindex >= 0), AKBASIC_ERR_UNDEFINED,
		     "TYPE %s is not registered", typename_);
    FAIL_ZERO_RETURN(errctx, (obj->structtypes.types[typeindex].ishost), AKBASIC_ERR_TYPE,
		     "TYPE %s was declared by the script, not registered by the host",
		     typename_);

    /*
     * The outermost scope, for the reason akbasic_runtime_global() exists: a
     * binding made while a script is suspended would otherwise land in whatever
     * FOR or GOSUB body is active and die with it.
     */
    PASS(errctx, akbasic_runtime_global(obj, name, &variable));
    if ( variable->structtype < 0 ) {
	sizes[0] = obj->structtypes.types[typeindex].slotcount;
	PASS(errctx, akbasic_variable_init(variable, &obj->valuepool, sizes, 1));
	variable->valuetype = AKBASIC_TYPE_STRUCT;
	variable->structtype = typeindex;
	variable->ispointer = false;
    }
    FAIL_ZERO_RETURN(errctx, (variable->structtype == typeindex), AKBASIC_ERR_TYPE,
		     "%s is already bound to a different type", name);
    variable->hostbase = instance;
    PASS(errctx, akbasic_host_refresh(obj, typeindex, instance, variable->values));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_host_rebind(akbasic_Runtime *obj, const char *name, void *instance)
{
    PREPARE_ERROR(errctx);
    akbasic_Variable *variable = NULL;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && name != NULL && instance != NULL),
		     AKERR_NULLPOINTER, "NULL argument in host rebind");
    PASS(errctx, akbasic_runtime_global(obj, name, &variable));
    FAIL_ZERO_RETURN(errctx, (variable->structtype >= 0 && variable->hostbase != NULL),
		     AKBASIC_ERR_UNDEFINED, "%s is not bound to a host structure", name);
    variable->hostbase = instance;
    PASS(errctx, akbasic_host_refresh(obj, variable->structtype, instance, variable->values));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_host_unbind(akbasic_Runtime *obj, const char *name)
{
    PREPARE_ERROR(errctx);
    akbasic_Variable *variable = NULL;

    FAIL_ZERO_RETURN(errctx, (obj != NULL && name != NULL), AKERR_NULLPOINTER,
		     "NULL argument in host unbind");
    PASS(errctx, akbasic_runtime_global(obj, name, &variable));
    FAIL_ZERO_RETURN(errctx, (variable->structtype >= 0 && variable->hostbase != NULL),
		     AKBASIC_ERR_UNDEFINED, "%s is not bound to a host structure", name);
    /*
     * The shadow slots keep whatever they last held, but the binding is gone --
     * so a later read is refused by name rather than following a pointer into
     * storage the host may already have freed. That refusal is the whole reason
     * this entry point exists.
     */
    variable->hostbase = NULL;
    variable->structtype = -1;
    SUCCEED_RETURN(errctx);
}