akbasic/src/runtime_functions.c

/**
 * @file runtime_functions.c
 * @brief The built-in function implementations.
 *
 * Ported from basicruntime_functions.go. The reference bootstraps its function
 * table by running a BASIC program of DEF statements through the interpreter at
 * startup and then nulling out the expressions so the native handlers take over
 * -- except MOD, SPC and STR, which stay as BASIC expressions. None of that is
 * reproduced: the signatures are data in the dispatch table and all three of
 * those are ordinary native handlers here, which removes the need to run the
 * interpreter before the interpreter is ready.
 */

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

#include <akerror.h>

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

#include "verbs.h"

/*
 * Every builtin starts the same way: find the argument list, evaluate the first
 * argument, and hand back a fresh value to write the answer into. Arity is
 * already guaranteed by the parser against the table's arity column.
 */
static akerr_ErrorContext *first_arg(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, const char *fname, akbasic_ASTLeaf **argleaf, akbasic_Value **argvalue, akbasic_Value **out)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *arg = NULL;

    FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "NIL leaf");
    arg = akbasic_leaf_first_argument(expr);
    FAIL_ZERO_RETURN(errctx, (arg != NULL), AKBASIC_ERR_SYNTAX,
		     "%s expected an argument", fname);
    if ( argvalue != NULL ) {
	PASS(errctx, akbasic_runtime_evaluate(obj, arg, argvalue));
    }
    if ( out != NULL ) {
	PASS(errctx, akbasic_environment_new_value(obj->environment, out));
	PASS(errctx, akbasic_value_zero(*out));
    }
    if ( argleaf != NULL ) {
	*argleaf = arg;
    }
    SUCCEED_RETURN(errctx);
}

/* Coerce an integer-or-float argument to double, the shape every trig call wants. */
static akerr_ErrorContext *arg_as_double(akbasic_Value *value, const char *fname, double *dest)
{
    PREPARE_ERROR(errctx);

    if ( value->valuetype == AKBASIC_TYPE_INTEGER ) {
	*dest = (double)value->intval;
	SUCCEED_RETURN(errctx);
    }
    if ( value->valuetype == AKBASIC_TYPE_FLOAT ) {
	*dest = value->floatval;
	SUCCEED_RETURN(errctx);
    }
    FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "%s expected integer or float", fname);
}

/* The trig family differs only by the libm call, so it is one shape. */
#define DEFINE_MATH_FUNCTION(__cname, __basicname, __call)			\
    akerr_ErrorContext *__cname(akbasic_Runtime *obj, akbasic_ASTLeaf *expr,	\
				akbasic_Value *lval, akbasic_Value *rval,	\
				akbasic_Value **dest)				\
    {										\
	PREPARE_ERROR(errctx);							\
	akbasic_Value *arg = NULL;						\
	akbasic_Value *out = NULL;						\
	double input = 0.0;							\
										\
	(void)lval; (void)rval;							\
	PASS(errctx, first_arg(obj, expr, __basicname, NULL, &arg, &out));	\
	PASS(errctx, arg_as_double(arg, __basicname, &input));			\
	out->valuetype = AKBASIC_TYPE_FLOAT;					\
	out->floatval = __call(input);						\
	*dest = out;								\
	SUCCEED_RETURN(errctx);							\
    }

DEFINE_MATH_FUNCTION(akbasic_fn_atn, "ATN", atan)
DEFINE_MATH_FUNCTION(akbasic_fn_cos, "COS", cos)
DEFINE_MATH_FUNCTION(akbasic_fn_sin, "SIN", sin)
DEFINE_MATH_FUNCTION(akbasic_fn_tan, "TAN", tan)
DEFINE_MATH_FUNCTION(akbasic_fn_log, "LOG", log)

akerr_ErrorContext *akbasic_fn_abs(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "ABS", NULL, &arg, &out));
    if ( arg->valuetype == AKBASIC_TYPE_INTEGER ) {
	out->valuetype = AKBASIC_TYPE_INTEGER;
	out->intval = (arg->intval < 0 ? -arg->intval : arg->intval);
    } else if ( arg->valuetype == AKBASIC_TYPE_FLOAT ) {
	out->valuetype = AKBASIC_TYPE_FLOAT;
	out->floatval = fabs(arg->floatval);
    } else {
	FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "ABS expected integer or float");
    }
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_rad(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;
    double input = 0.0;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "RAD", NULL, &arg, &out));
    PASS(errctx, arg_as_double(arg, "RAD", &input));
    out->valuetype = AKBASIC_TYPE_FLOAT;
    out->floatval = input * (M_PI / 180.0);
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_sgn(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;
    double input = 0.0;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "SGN", NULL, &arg, &out));
    PASS(errctx, arg_as_double(arg, "SGN", &input));
    out->valuetype = AKBASIC_TYPE_INTEGER;
    out->intval = (input < 0.0 ? -1 : (input > 0.0 ? 1 : 0));
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_chr(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;
    int64_t codepoint = 0;
    int written = 0;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "CHR", NULL, &arg, &out));
    FAIL_NONZERO_RETURN(errctx, (arg->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
			"CHR expected an integer codepoint");
    codepoint = arg->intval;
    FAIL_ZERO_RETURN(errctx, (codepoint >= 0 && codepoint <= 0x10FFFF), AKBASIC_ERR_VALUE,
		     "CHR codepoint %" PRId64 " is outside Unicode", codepoint);

    /* UTF-8 encode, matching the reference's string(rune(x)). */
    out->valuetype = AKBASIC_TYPE_STRING;
    if ( codepoint < 0x80 ) {
	out->stringval[written++] = (char)codepoint;
    } else if ( codepoint < 0x800 ) {
	out->stringval[written++] = (char)(0xC0 | (codepoint >> 6));
	out->stringval[written++] = (char)(0x80 | (codepoint & 0x3F));
    } else if ( codepoint < 0x10000 ) {
	out->stringval[written++] = (char)(0xE0 | (codepoint >> 12));
	out->stringval[written++] = (char)(0x80 | ((codepoint >> 6) & 0x3F));
	out->stringval[written++] = (char)(0x80 | (codepoint & 0x3F));
    } else {
	out->stringval[written++] = (char)(0xF0 | (codepoint >> 18));
	out->stringval[written++] = (char)(0x80 | ((codepoint >> 12) & 0x3F));
	out->stringval[written++] = (char)(0x80 | ((codepoint >> 6) & 0x3F));
	out->stringval[written++] = (char)(0x80 | (codepoint & 0x3F));
    }
    out->stringval[written] = '\0';
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_hex(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "HEX", NULL, &arg, &out));
    FAIL_NONZERO_RETURN(errctx, (arg->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
			"HEX expected an integer");
    out->valuetype = AKBASIC_TYPE_STRING;
    snprintf(out->stringval, sizeof(out->stringval), "%" PRIx64, arg->intval);
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_str(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "STR", NULL, &arg, &out));
    /*
     * The reference defines this as `"" + X#`, so it renders exactly the way
     * string concatenation does -- an integer as %d and a float as %f.
     */
    PASS(errctx, akbasic_value_to_string(arg, out->stringval, sizeof(out->stringval)));
    out->valuetype = AKBASIC_TYPE_STRING;
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_spc(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;
    int64_t i = 0;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "SPC", NULL, &arg, &out));
    FAIL_NONZERO_RETURN(errctx, (arg->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
			"SPC expected an integer");
    FAIL_ZERO_RETURN(errctx, (arg->intval >= 0 && arg->intval < AKBASIC_MAX_STRING_LENGTH),
		     AKBASIC_ERR_VALUE,
		     "SPC count %" PRId64 " is outside 0..%d",
		     arg->intval, AKBASIC_MAX_STRING_LENGTH - 1);
    out->valuetype = AKBASIC_TYPE_STRING;
    for ( i = 0; i < arg->intval; i++ ) {
	out->stringval[i] = ' ';
    }
    out->stringval[arg->intval] = '\0';
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_val(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "VAL", NULL, &arg, &out));
    FAIL_NONZERO_RETURN(errctx, (arg->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			"VAL expected a string");
    out->valuetype = AKBASIC_TYPE_FLOAT;
    /*
     * Through the strict converter, never aksl_atof: that family cannot report a
     * failure, so VAL("garbage") would quietly answer 0.0 instead of raising.
     * See TODO.md section 1.9.
     */
    PASS(errctx, akbasic_str_to_double(arg->stringval, &out->floatval));
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_len(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *argleaf = NULL;
    akbasic_Value *strval = NULL;
    akbasic_Value *out = NULL;
    akbasic_Variable *variable = NULL;

    (void)lval; (void)rval;
    /*
     * LEN must not evaluate a non-string argument. `LEN(A#)` on a
     * multi-dimensional array is legal and asks for the element count, but
     * evaluating a bare identifier supplies the single subscript {0}, which a
     * two-dimensional variable rightly rejects. So: inspect the leaf, and only
     * evaluate when it is a string.
     */
    PASS(errctx, first_arg(obj, expr, "LEN", &argleaf, NULL, NULL));
    FAIL_ZERO_RETURN(errctx,
		     (akbasic_leaf_is_identifier(argleaf) || akbasic_leaf_is_literal(argleaf)),
		     AKBASIC_ERR_SYNTAX, "Expected identifier or string literal");

    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_INTEGER;

    if ( argleaf->leaftype == AKBASIC_LEAF_LITERAL_STRING ||
	 argleaf->leaftype == AKBASIC_LEAF_IDENTIFIER_STRING ) {
	PASS(errctx, akbasic_runtime_evaluate(obj, argleaf, &strval));
	out->intval = (int64_t)strlen(strval->stringval);
    } else {
	PASS(errctx, akbasic_environment_get(obj->environment, argleaf->identifier, &variable));
	FAIL_ZERO_RETURN(errctx, (variable != NULL), AKBASIC_ERR_UNDEFINED,
			 "Identifier %s is undefined", argleaf->identifier);
	out->intval = variable->valuecount;
    }
    *dest = out;
    SUCCEED_RETURN(errctx);
}

/* Fetch argument N (zero-based) of a call, already evaluated. */
static akerr_ErrorContext *nth_arg(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, const char *fname, int n, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *arg = NULL;
    int i = 0;

    FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "NIL leaf");
    arg = akbasic_leaf_first_argument(expr);
    for ( i = 0; i < n && arg != NULL; i++ ) {
	arg = arg->right;
    }
    FAIL_ZERO_RETURN(errctx, (arg != NULL), AKBASIC_ERR_SYNTAX,
		     "%s is missing argument %d", fname, n + 1);
    PASS(errctx, akbasic_runtime_evaluate(obj, arg, dest));
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_instr(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *haystack = NULL;
    akbasic_Value *needle = NULL;
    akbasic_Value *out = NULL;
    char *hit = NULL;

    (void)lval; (void)rval;
    PASS(errctx, nth_arg(obj, expr, "INSTR", 0, &haystack));
    PASS(errctx, nth_arg(obj, expr, "INSTR", 1, &needle));
    FAIL_ZERO_RETURN(errctx,
		     (haystack->valuetype == AKBASIC_TYPE_STRING &&
		      needle->valuetype == AKBASIC_TYPE_STRING),
		     AKBASIC_ERR_TYPE, "INSTR expected two strings");
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_INTEGER;
    hit = strstr(haystack->stringval, needle->stringval);
    out->intval = (hit == NULL ? -1 : (int64_t)(hit - haystack->stringval));
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_left(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *source = NULL;
    akbasic_Value *count = NULL;
    akbasic_Value *out = NULL;
    int64_t take = 0;
    size_t sourcelen = 0;

    (void)lval; (void)rval;
    PASS(errctx, nth_arg(obj, expr, "LEFT", 0, &source));
    PASS(errctx, nth_arg(obj, expr, "LEFT", 1, &count));
    FAIL_NONZERO_RETURN(errctx, (source->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			"LEFT expected a string");
    FAIL_NONZERO_RETURN(errctx, (count->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
			"LEFT expected an integer count");
    sourcelen = strlen(source->stringval);
    take = count->intval;
    if ( take < 0 ) {
	take = 0;
    }
    if ( (size_t)take > sourcelen ) {
	take = (int64_t)sourcelen;	/* clamped to LEN, as the README says */
    }
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_STRING;
    memcpy(out->stringval, source->stringval, (size_t)take);
    out->stringval[take] = '\0';
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_right(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *source = NULL;
    akbasic_Value *count = NULL;
    akbasic_Value *out = NULL;
    int64_t take = 0;
    size_t sourcelen = 0;

    (void)lval; (void)rval;
    PASS(errctx, nth_arg(obj, expr, "RIGHT", 0, &source));
    PASS(errctx, nth_arg(obj, expr, "RIGHT", 1, &count));
    FAIL_NONZERO_RETURN(errctx, (source->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			"RIGHT expected a string");
    FAIL_NONZERO_RETURN(errctx, (count->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
			"RIGHT expected an integer count");
    sourcelen = strlen(source->stringval);
    take = count->intval;
    if ( take < 0 ) {
	take = 0;
    }
    if ( (size_t)take > sourcelen ) {
	take = (int64_t)sourcelen;
    }
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_STRING;
    memcpy(out->stringval, source->stringval + (sourcelen - (size_t)take), (size_t)take);
    out->stringval[take] = '\0';
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_mid(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *source = NULL;
    akbasic_Value *startval = NULL;
    akbasic_Value *lengthval = NULL;
    akbasic_Value *out = NULL;
    int64_t start = 0;
    int64_t length = 0;
    size_t sourcelen = 0;

    (void)lval; (void)rval;
    PASS(errctx, nth_arg(obj, expr, "MID", 0, &source));
    PASS(errctx, nth_arg(obj, expr, "MID", 1, &startval));
    PASS(errctx, nth_arg(obj, expr, "MID", 2, &lengthval));
    FAIL_NONZERO_RETURN(errctx, (source->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
			"MID expected a string");
    FAIL_ZERO_RETURN(errctx,
		     (startval->valuetype == AKBASIC_TYPE_INTEGER &&
		      lengthval->valuetype == AKBASIC_TYPE_INTEGER),
		     AKBASIC_ERR_TYPE, "MID expected integer start and length");

    sourcelen = strlen(source->stringval);
    start = startval->intval;
    length = lengthval->intval;
    FAIL_ZERO_RETURN(errctx, (start >= 0 && (size_t)start <= sourcelen), AKBASIC_ERR_BOUNDS,
		     "MID start %" PRId64 " is outside 0..%zu", start, sourcelen);
    if ( length < 0 ) {
	length = 0;
    }
    if ( (size_t)(start + length) > sourcelen ) {
	length = (int64_t)sourcelen - start;
    }
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_STRING;
    memcpy(out->stringval, source->stringval + start, (size_t)length);
    out->stringval[length] = '\0';
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_mod(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *left = NULL;
    akbasic_Value *right = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, nth_arg(obj, expr, "MOD", 0, &left));
    PASS(errctx, nth_arg(obj, expr, "MOD", 1, &right));
    FAIL_ZERO_RETURN(errctx,
		     (left->valuetype == AKBASIC_TYPE_INTEGER &&
		      right->valuetype == AKBASIC_TYPE_INTEGER),
		     AKBASIC_ERR_TYPE, "MOD expected two integers");
    FAIL_ZERO_RETURN(errctx, (right->intval != 0), AKBASIC_ERR_VALUE, "DIVISION BY ZERO");
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_INTEGER;
    /*
     * The reference defines MOD as `X% - (Y% * (X% / Y%))` in BASIC, which with
     * truncating integer division is exactly C's %.
     */
    out->intval = left->intval - (right->intval * (left->intval / right->intval));
    *dest = out;
    SUCCEED_RETURN(errctx);
}

/* SHL, SHR and XOR share a shape: two integers in, one integer out. */
static akerr_ErrorContext *two_integers(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, const char *fname, int64_t *a, int64_t *b, akbasic_Value **out)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *left = NULL;
    akbasic_Value *right = NULL;

    PASS(errctx, nth_arg(obj, expr, fname, 0, &left));
    PASS(errctx, nth_arg(obj, expr, fname, 1, &right));
    FAIL_ZERO_RETURN(errctx,
		     (left->valuetype == AKBASIC_TYPE_INTEGER &&
		      right->valuetype == AKBASIC_TYPE_INTEGER),
		     AKBASIC_ERR_TYPE, "%s expected two integers", fname);
    *a = left->intval;
    *b = right->intval;
    PASS(errctx, akbasic_environment_new_value(obj->environment, out));
    PASS(errctx, akbasic_value_zero(*out));
    (*out)->valuetype = AKBASIC_TYPE_INTEGER;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_shl(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *out = NULL;
    int64_t value = 0;
    int64_t bits = 0;

    (void)lval; (void)rval;
    PASS(errctx, two_integers(obj, expr, "SHL", &value, &bits, &out));
    FAIL_ZERO_RETURN(errctx, (bits >= 0 && bits < 64), AKBASIC_ERR_VALUE,
		     "SHL shift count %" PRId64 " is outside 0..63", bits);
    out->intval = (int64_t)((uint64_t)value << bits);
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_shr(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *out = NULL;
    int64_t value = 0;
    int64_t bits = 0;

    (void)lval; (void)rval;
    PASS(errctx, two_integers(obj, expr, "SHR", &value, &bits, &out));
    FAIL_ZERO_RETURN(errctx, (bits >= 0 && bits < 64), AKBASIC_ERR_VALUE,
		     "SHR shift count %" PRId64 " is outside 0..63", bits);
    out->intval = value >> bits;
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_xor(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_Value *out = NULL;
    int64_t left = 0;
    int64_t right = 0;

    (void)lval; (void)rval;
    PASS(errctx, two_integers(obj, expr, "XOR", &left, &right, &out));
    out->intval = left ^ right;
    *dest = out;
    SUCCEED_RETURN(errctx);
}

/*
 * PEEK, POINTER and POINTERVAR reach real memory. In Go these went through
 * unsafe.Pointer; in C they are ordinary casts and are simpler, not harder.
 *
 * They assume a little-endian host: tests/language/functions/pointer.bas sets
 * A# = 255 and expects PEEK(POINTER(A#)) to be 255, which only holds if the low
 * byte of the int64_t comes first.
 */
akerr_ErrorContext *akbasic_fn_peek(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *argleaf = NULL;
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;
    const uint8_t *source = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "PEEK", &argleaf, NULL, NULL));
    FAIL_ZERO_RETURN(errctx,
		     (argleaf->leaftype == AKBASIC_LEAF_LITERAL_INT ||
		      argleaf->leaftype == AKBASIC_LEAF_IDENTIFIER_INT),
		     AKBASIC_ERR_TYPE, "PEEK expected INTEGER or INTEGER VARIABLE");
    PASS(errctx, akbasic_runtime_evaluate(obj, argleaf, &arg));
    FAIL_ZERO_RETURN(errctx, (arg->valuetype == AKBASIC_TYPE_INTEGER && arg->intval != 0),
		     AKBASIC_ERR_VALUE, "PEEK got NIL pointer or uninitialized variable");
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    source = (const uint8_t *)(uintptr_t)arg->intval;
    out->valuetype = AKBASIC_TYPE_INTEGER;
    out->intval = (int64_t)(*source);
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_pointer(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *argleaf = NULL;
    akbasic_Value *arg = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "POINTER", &argleaf, NULL, NULL));
    FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(argleaf), AKBASIC_ERR_TYPE,
		     "POINTER expected IDENTIFIER");

    /* The address of the live storage, not of a copy of it. */
    obj->eval_clone_identifiers = false;
    ATTEMPT {
	CATCH(errctx, akbasic_runtime_evaluate(obj, argleaf, &arg));
    } CLEANUP {
	obj->eval_clone_identifiers = true;
    } PROCESS(errctx) {
    } FINISH(errctx, true);

    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_INTEGER;
    switch ( arg->valuetype ) {
    case AKBASIC_TYPE_INTEGER:
	out->intval = (int64_t)(uintptr_t)&arg->intval;
	break;
    case AKBASIC_TYPE_FLOAT:
	out->intval = (int64_t)(uintptr_t)&arg->floatval;
	break;
    case AKBASIC_TYPE_STRING:
	out->intval = (int64_t)(uintptr_t)&arg->stringval;
	break;
    default:
	FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "POINTER expects a INT, FLOAT or STRING variable");
    }
    *dest = out;
    SUCCEED_RETURN(errctx);
}

akerr_ErrorContext *akbasic_fn_pointervar(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
    PREPARE_ERROR(errctx);
    akbasic_ASTLeaf *argleaf = NULL;
    akbasic_Variable *variable = NULL;
    akbasic_Value *out = NULL;

    (void)lval; (void)rval;
    PASS(errctx, first_arg(obj, expr, "POINTERVAR", &argleaf, NULL, NULL));
    FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(argleaf), AKBASIC_ERR_TYPE,
		     "POINTERVAR expected IDENTIFIER");
    PASS(errctx, akbasic_environment_get(obj->environment, argleaf->identifier, &variable));
    FAIL_ZERO_RETURN(errctx, (variable != NULL), AKBASIC_ERR_UNDEFINED,
		     "Identifier %s is undefined", argleaf->identifier);
    PASS(errctx, akbasic_environment_new_value(obj->environment, &out));
    PASS(errctx, akbasic_value_zero(out));
    out->valuetype = AKBASIC_TYPE_INTEGER;
    out->intval = (int64_t)(uintptr_t)variable;
    *dest = out;
    SUCCEED_RETURN(errctx);
}