andrew/akbasic
1
0
Fork 0
Code Issues 27 Pull Requests Actions Packages Projects Releases Wiki Activity
Files
a69d28cbf77ba992d9ff17889c1ca4efcb5c6edf
akbasic/src/runtime_functions.c
Tachikoma 4e98dba423 Give argument lists their own link, not each argument's .right 
An identifier's subscript list, a unary's operand and a binary's right-hand
side all lived in the same field the argument chain used, so ABS(-9),
MOD(A#, B# + 12) and any array reference in a parameter list were counted as
extra arguments and refused. Subscript lists move to .expr and arguments now
chain through a dedicated .next.

This is the third time the same collision was fixed; the first two moved it
along rather than removing it.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Co-Authored-By: Andrew Kesterson <andrew@aklabs.net>
2026-07-31 11:58:15 -04:00

645 lines
24 KiB
C
Raw Blame History

/**
* @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 <akstdlib.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, aksl_atof(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->next;
}
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);
}
Reference in New Issue View Git Blame Copy Permalink