andrew/akbasic
1
0
Fork 0
Code Issues 27 Pull Requests Actions Packages Projects Releases Wiki Activity

Port the BASIC interpreter from Go to C

Browse Source 
Reproduces deps/basicinterpret in C, in the idiom of the ak* libraries. All 41
.bas files in the reference's corpus produce byte-identical stdout, including
the trailing double newline on an error line -- that comes from basicError
building a string ending in \n and handing it to Println, and
array_outofbounds.txt encodes it.

The corpus is driven in place from the submodule as 41 individual CTest cases
rather than copied, so it cannot drift from upstream. Eighteen unit tests cover
what the corpus cannot reach.

Three structural changes carry most of the work. Go's three reflection lookups
(Command*, Function*, ParseCommand*) become one sorted dispatch table in
src/verbs.c searched with bsearch; adding a verb is a row and two functions. The
five Go maps become one fixed open-addressed table over aksl_strhash_djb2. And
run(), which owned the process until MODE_QUIT, splits into step() plus a
bounded run() -- goal 3 requires a host game to be able to bound execution, and
nothing in the library now terminates the process or touches SDL.

Output goes through an akbasic_TextSink vtable. src/sink_stdio.c is what makes
the corpus runnable with no SDL present; the akgl-backed sink is still to come
and is blocked on libakgl having no text-measurement call.

src/convert.c exists because libakstdlib's aksl_ato* family cannot report a
conversion failure (its TODO.md 2.1.5). The reference checks strconv's error at
four sites and turns it into a BASIC error; routing those through aksl_atoi
would have turned four diagnosable errors into wrong answers, with VAL("garbage")
quietly returning 0. TODO.md 1.9 records which libakstdlib calls are cleared for
use here and which are not.

Reference defects are reproduced, not fixed: the golden files encode the observed
behaviour and a silent correction is a behaviour change. TODO.md section 6 lists
sixteen, and tests/known_reference_defects.c asserts the *correct* contract for
six of them under AKBASIC_KNOWN_FAILING_TESTS, so a fix shows up as
"unexpectedly passed". Five of the sixteen were found by this port and are new:
subtraction stops after one operator so 1-2-3 computes 1-2 and abandons the rest
of the line (a wrong answer, not a refused one); a unary-minus argument inflates
a function's arity so ABS(-9) is rejected; a comparison operator in a line's
final column is dropped; hex literals never survive the scanner; and the
"Reserved word in variable name" check is dead code.

Where the reference reaches undefined behaviour by a route that is defined in Go
-- an out-of-range shift, a negative string multiplier, integer division by zero
-- this raises instead of inheriting the UB. No golden case exercises any of
them.

The top-level CMakeLists shadows add_test, set_tests_properties and
add_custom_target around all three add_subdirectory calls. Without it libakerror's
tests land in our suite as Not Run, and its un-namespaced `coverage` target stops
a coverage build from configuring at all. Test targets are akbasic_test_<name>:
bare test_<name> collides with libakstdlib's, which is what broke libakgl's
configure in c2b16d3.

ctest 59/59; ASan+UBSan 59/59; 92.3% line and 96.9% function coverage; no
warnings under -Wall -Wextra. Branch coverage is not a target, for the reason
libakstdlib and libakgl both record: the akerror macros expand into large branch
trees at every call site.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Co-Authored-By: Andrew Kesterson <andrew@aklabs.net>
This commit is contained in:
Tachikoma
2026-07-30 23:53:56 -04:00
commit 4e188b2794
60 changed files with 10192 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

65
src/convert.c Normal file
View File

@@ -0,0 +1,65 @@
/**
* @file convert.c
* @brief Implements strict string-to-number conversion over strtoll/strtod.
*/
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/convert.h>
#include <akbasic/error.h>
akerr_ErrorContext *akbasic_str_to_int64(const char *str, int base, int64_t *dest)
{
PREPARE_ERROR(errctx);
char *endptr = NULL;
long long result = 0;
FAIL_ZERO_RETURN(errctx, (str != NULL), AKERR_NULLPOINTER,
"NULL string in integer conversion");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER,
"NULL destination in integer conversion");
errno = 0;
result = strtoll(str, &endptr, base);
/* No digits consumed at all. */
FAIL_NONZERO_RETURN(errctx, (endptr == str), AKBASIC_ERR_VALUE,
"INTEGER CONVERSION ON '%s'", str);
/* Trailing junk. The whole lexeme must be the number. */
FAIL_NONZERO_RETURN(errctx, (*endptr != '\0'), AKBASIC_ERR_VALUE,
"INTEGER CONVERSION ON '%s'", str);
FAIL_NONZERO_RETURN(errctx, (errno == ERANGE), ERANGE,
"Integer literal '%s' is out of range", str);
*dest = (int64_t)result;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_str_to_double(const char *str, double *dest)
{
PREPARE_ERROR(errctx);
char *endptr = NULL;
double result = 0.0;
FAIL_ZERO_RETURN(errctx, (str != NULL), AKERR_NULLPOINTER,
"NULL string in float conversion");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER,
"NULL destination in float conversion");
errno = 0;
result = strtod(str, &endptr);
FAIL_NONZERO_RETURN(errctx, (endptr == str), AKBASIC_ERR_VALUE,
"FLOAT CONVERSION ON '%s'", str);
FAIL_NONZERO_RETURN(errctx, (*endptr != '\0'), AKBASIC_ERR_VALUE,
"FLOAT CONVERSION ON '%s'", str);
FAIL_NONZERO_RETURN(errctx, (errno == ERANGE), ERANGE,
"Float literal '%s' is out of range", str);
*dest = result;
SUCCEED_RETURN(errctx);
}

379
src/environment.c Normal file
View File

@@ -0,0 +1,379 @@
/**
* @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->gosubReturnLine = 0;
obj->readReturnLine = 0;
obj->readIdentifierIdx = 0;
obj->waitingForCommand[0] = '\0';
obj->errorToken = NULL;
memset(obj->readIdentifierLeaves, 0, sizeof(obj->readIdentifierLeaves));
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;
akbasic_Variable *variable = NULL;
int64_t sizes[1] = { 1 };
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_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->right != NULL &&
lval->right->leaftype == AKBASIC_LEAF_ARGUMENTLIST &&
lval->right->operator_ == AKBASIC_TOK_ARRAY_SUBSCRIPT ) {
for ( expr = lval->right->right; expr != NULL; expr = expr->right ) {
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);
}

38
src/error.c Normal file
View File

@@ -0,0 +1,38 @@
/**
* @file error.c
* @brief Implements the error subsystem: claims and names the akbasic status band.
*/
#include <akerror.h>
#include <akbasic/error.h>
akerr_ErrorContext *akbasic_error_register(void)
{
PREPARE_ERROR(errctx);
/*
* Claim the whole band before naming anything in it: libakerror refuses a
* name for a status we do not own. Any collision propagates to the caller --
* another component owning part of our range is an initialization failure,
* not a warning.
*/
PASS(errctx, akerr_reserve_status_range(AKBASIC_ERR_BASE,
AKBASIC_ERR_LIMIT - AKBASIC_ERR_BASE,
AKBASIC_OWNER));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_SYNTAX,
"Syntax Error"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_TYPE,
"Type Error"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_UNDEFINED,
"Undefined Reference"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_BOUNDS,
"Out Of Bounds"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_ENVIRONMENT,
"Environment Error"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_VALUE,
"Value Error"));
PASS(errctx, akerr_register_status_name(AKBASIC_OWNER, AKBASIC_ERR_STATE,
"State Error"));
SUCCEED_RETURN(errctx);
}

393
src/grammar.c Normal file
View File

@@ -0,0 +1,393 @@
/**
* @file grammar.c
* @brief Implements token and AST leaf construction.
*/
#include <inttypes.h>
#include <stdio.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/convert.h>
#include <akbasic/error.h>
#include <akbasic/grammar.h>
/* Copy into a leaf's inline identifier/literal buffer, refusing truncation. */
static akerr_ErrorContext *copy_bounded(char *dest, const char *src, const char *what)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (src != NULL), AKERR_NULLPOINTER, "NULL %s", what);
FAIL_ZERO_RETURN(errctx, (strlen(src) < AKBASIC_MAX_STRING_LENGTH),
AKBASIC_ERR_VALUE,
"%s of %zu characters exceeds the %d character limit",
what, strlen(src), AKBASIC_MAX_STRING_LENGTH - 1);
strncpy(dest, src, AKBASIC_MAX_STRING_LENGTH - 1);
dest[AKBASIC_MAX_STRING_LENGTH - 1] = '\0';
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_token_init(akbasic_Token *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL token in init");
obj->tokentype = AKBASIC_TOK_UNDEFINED;
obj->lineno = 0;
obj->lexeme[0] = '\0';
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_init(akbasic_ASTLeaf *obj, akbasic_LeafType leaftype)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in init");
obj->leaftype = leaftype;
obj->parent = NULL;
obj->left = NULL;
obj->right = NULL;
obj->expr = NULL;
obj->identifier[0] = '\0';
obj->literal_int = 0;
obj->literal_float = 0.0;
obj->literal_string[0] = '\0';
obj->operator_ = AKBASIC_TOK_UNDEFINED;
SUCCEED_RETURN(errctx);
}
/*
* Take one leaf from the pool. Recursion in clone_into() is bounded by the pool
* capacity, so a cyclic tree exhausts the pool and errors rather than running
* off the stack.
*/
static akerr_ErrorContext *pool_take(akbasic_LeafPool *pool, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (pool != NULL), AKERR_NULLPOINTER, "NULL leaf pool");
FAIL_ZERO_RETURN(errctx, (pool->leaves != NULL), AKERR_NULLPOINTER, "Leaf pool has no storage");
FAIL_ZERO_RETURN(errctx, (pool->next < pool->capacity), AKBASIC_ERR_BOUNDS,
"No more leaves available");
*dest = &pool->leaves[pool->next];
pool->next += 1;
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *clone_into(akbasic_ASTLeaf *self, akbasic_LeafPool *pool, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *copy = NULL;
if ( self == NULL ) {
*dest = NULL;
SUCCEED_RETURN(errctx);
}
PASS(errctx, pool_take(pool, &copy));
PASS(errctx, akbasic_leaf_init(copy, self->leaftype));
copy->parent = self->parent;
copy->literal_int = self->literal_int;
copy->literal_float = self->literal_float;
memcpy(copy->literal_string, self->literal_string, sizeof(copy->literal_string));
memcpy(copy->identifier, self->identifier, sizeof(copy->identifier));
copy->operator_ = self->operator_;
PASS(errctx, clone_into(self->left, pool, &copy->left));
PASS(errctx, clone_into(self->right, pool, &copy->right));
PASS(errctx, clone_into(self->expr, pool, &copy->expr));
*dest = copy;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_clone(akbasic_ASTLeaf *self, akbasic_LeafPool *pool, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in clone");
PASS(errctx, clone_into(self, pool, dest));
SUCCEED_RETURN(errctx);
}
akbasic_ASTLeaf *akbasic_leaf_first_argument(akbasic_ASTLeaf *self)
{
if ( self == NULL ||
self->right == NULL ||
self->right->leaftype != AKBASIC_LEAF_ARGUMENTLIST ||
self->right->operator_ != AKBASIC_TOK_FUNCTION_ARGUMENT ) {
return NULL;
}
return self->right->right;
}
akbasic_ASTLeaf *akbasic_leaf_first_subscript(akbasic_ASTLeaf *self)
{
if ( self == NULL ||
self->right == NULL ||
self->right->leaftype != AKBASIC_LEAF_ARGUMENTLIST ||
self->right->operator_ != AKBASIC_TOK_ARRAY_SUBSCRIPT ) {
return NULL;
}
return self->right->right;
}
bool akbasic_leaf_is_identifier(akbasic_ASTLeaf *self)
{
return (self != NULL &&
(self->leaftype == AKBASIC_LEAF_IDENTIFIER ||
self->leaftype == AKBASIC_LEAF_IDENTIFIER_INT ||
self->leaftype == AKBASIC_LEAF_IDENTIFIER_FLOAT ||
self->leaftype == AKBASIC_LEAF_IDENTIFIER_STRING));
}
bool akbasic_leaf_is_literal(akbasic_ASTLeaf *self)
{
return (self != NULL &&
(self->leaftype == AKBASIC_LEAF_LITERAL_INT ||
self->leaftype == AKBASIC_LEAF_LITERAL_FLOAT ||
self->leaftype == AKBASIC_LEAF_LITERAL_STRING));
}
akerr_ErrorContext *akbasic_leaf_new_comparison(akbasic_ASTLeaf *obj, akbasic_ASTLeaf *left, akbasic_TokenType op, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_comparison");
FAIL_ZERO_RETURN(errctx, (left != NULL && right != NULL), AKERR_NULLPOINTER,
"nil pointer arguments");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_COMPARISON));
obj->left = left;
obj->right = right;
switch ( op ) {
case AKBASIC_TOK_LESS_THAN:
case AKBASIC_TOK_LESS_THAN_EQUAL:
case AKBASIC_TOK_NOT_EQUAL:
case AKBASIC_TOK_GREATER_THAN:
case AKBASIC_TOK_GREATER_THAN_EQUAL:
SUCCEED_RETURN(errctx);
default:
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX, "Invalid operator %d for comparison", (int)op);
}
}
akerr_ErrorContext *akbasic_leaf_new_binary(akbasic_ASTLeaf *obj, akbasic_ASTLeaf *left, akbasic_TokenType op, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_binary");
FAIL_ZERO_RETURN(errctx, (left != NULL && right != NULL), AKERR_NULLPOINTER,
"nil pointer arguments");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_BINARY));
obj->left = left;
obj->right = right;
obj->operator_ = op;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_unary(akbasic_ASTLeaf *obj, akbasic_TokenType op, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_unary");
FAIL_ZERO_RETURN(errctx, (right != NULL), AKERR_NULLPOINTER, "nil pointer arguments");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_UNARY));
obj->right = right;
obj->operator_ = op;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_function(akbasic_ASTLeaf *obj, const char *fname, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_function");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_FUNCTION));
obj->right = right;
obj->operator_ = AKBASIC_TOK_COMMAND;
PASS(errctx, copy_bounded(obj->identifier, fname, "function name"));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_command(akbasic_ASTLeaf *obj, const char *cmdname, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_command");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_COMMAND));
obj->right = right;
obj->operator_ = AKBASIC_TOK_COMMAND;
PASS(errctx, copy_bounded(obj->identifier, cmdname, "command name"));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_immediate_command(akbasic_ASTLeaf *obj, const char *cmdname, akbasic_ASTLeaf *right)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_immediate_command");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_COMMAND_IMMEDIATE));
obj->right = right;
obj->operator_ = AKBASIC_TOK_COMMAND_IMMEDIATE;
PASS(errctx, copy_bounded(obj->identifier, cmdname, "command name"));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_branch(akbasic_ASTLeaf *obj, akbasic_ASTLeaf *expr, akbasic_ASTLeaf *trueleaf, akbasic_ASTLeaf *falseleaf)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_branch");
FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "nil pointer arguments");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_BRANCH));
obj->expr = expr;
obj->left = trueleaf;
obj->right = falseleaf;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_grouping(akbasic_ASTLeaf *obj, akbasic_ASTLeaf *expr)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_grouping");
FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "nil pointer arguments");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_GROUPING));
obj->expr = expr;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_literal_int(akbasic_ASTLeaf *obj, const char *lexeme)
{
PREPARE_ERROR(errctx);
int base = 10;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_literal_int");
FAIL_ZERO_RETURN(errctx, (lexeme != NULL), AKERR_NULLPOINTER, "NULL lexeme in new_literal_int");
FAIL_ZERO_RETURN(errctx, (lexeme[0] != '\0'), AKBASIC_ERR_VALUE, "Empty integer literal");
/*
* The reference selects base 8 for any lexeme starting with '0', so `010`
* parses as 8 and `08` is an error. Commodore BASIC has no octal literals
* and this is TODO.md section 12 item 10 -- but it is reproduced here,
* because "port the behaviour first" is the rule and the fix is its own
* commit with its own test.
*/
if ( strlen(lexeme) > 2 && strncmp(lexeme, "0x", 2) == 0 ) {
base = 16;
} else if ( lexeme[0] == '0' ) {
base = 8;
}
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_LITERAL_INT));
PASS(errctx, akbasic_str_to_int64(lexeme, base, &obj->literal_int));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_literal_float(akbasic_ASTLeaf *obj, const char *lexeme)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_literal_float");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_LITERAL_FLOAT));
PASS(errctx, akbasic_str_to_double(lexeme, &obj->literal_float));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_literal_string(akbasic_ASTLeaf *obj, const char *lexeme)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_literal_string");
PASS(errctx, akbasic_leaf_init(obj, AKBASIC_LEAF_LITERAL_STRING));
PASS(errctx, copy_bounded(obj->literal_string, lexeme, "string literal"));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_leaf_new_identifier(akbasic_ASTLeaf *obj, akbasic_LeafType leaftype, const char *lexeme)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL leaf in new_identifier");
PASS(errctx, akbasic_leaf_init(obj, leaftype));
PASS(errctx, copy_bounded(obj->identifier, lexeme, "identifier"));
SUCCEED_RETURN(errctx);
}
static const char *operator_to_str(akbasic_TokenType op)
{
switch ( op ) {
case AKBASIC_TOK_EQUAL: return "=";
case AKBASIC_TOK_LESS_THAN: return "<";
case AKBASIC_TOK_GREATER_THAN: return ">";
case AKBASIC_TOK_LESS_THAN_EQUAL: return "<=";
case AKBASIC_TOK_GREATER_THAN_EQUAL: return ">=";
case AKBASIC_TOK_NOT_EQUAL: return "<>";
case AKBASIC_TOK_PLUS: return "+";
case AKBASIC_TOK_MINUS: return "-";
case AKBASIC_TOK_STAR: return "*";
case AKBASIC_TOK_LEFT_SLASH: return "/";
case AKBASIC_TOK_CARAT: return "^";
case AKBASIC_TOK_NOT: return "NOT";
case AKBASIC_TOK_AND: return "AND";
case AKBASIC_TOK_OR: return "OR";
default: return "";
}
}
akerr_ErrorContext *akbasic_leaf_to_string(akbasic_ASTLeaf *self, char *dest, size_t len)
{
PREPARE_ERROR(errctx);
char sub1[AKBASIC_MAX_STRING_LENGTH];
char sub2[AKBASIC_MAX_STRING_LENGTH];
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL leaf in to_string");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in to_string");
FAIL_ZERO_RETURN(errctx, (len > 0), AKBASIC_ERR_BOUNDS, "Zero-length destination in to_string");
switch ( self->leaftype ) {
case AKBASIC_LEAF_LITERAL_INT:
snprintf(dest, len, "%" PRId64, self->literal_int);
break;
case AKBASIC_LEAF_LITERAL_FLOAT:
snprintf(dest, len, "%f", self->literal_float);
break;
case AKBASIC_LEAF_LITERAL_STRING:
snprintf(dest, len, "%s", self->literal_string);
break;
case AKBASIC_LEAF_IDENTIFIER_INT:
case AKBASIC_LEAF_IDENTIFIER_FLOAT:
case AKBASIC_LEAF_IDENTIFIER_STRING:
case AKBASIC_LEAF_IDENTIFIER:
snprintf(dest, len, "%s", self->identifier);
break;
case AKBASIC_LEAF_IDENTIFIER_STRUCT:
snprintf(dest, len, "NOT IMPLEMENTED");
break;
case AKBASIC_LEAF_UNARY:
PASS(errctx, akbasic_leaf_to_string(self->right, sub1, sizeof(sub1)));
snprintf(dest, len, "(%s %s)", operator_to_str(self->operator_), sub1);
break;
case AKBASIC_LEAF_BINARY:
PASS(errctx, akbasic_leaf_to_string(self->left, sub1, sizeof(sub1)));
PASS(errctx, akbasic_leaf_to_string(self->right, sub2, sizeof(sub2)));
snprintf(dest, len, "(%s %s %s)", operator_to_str(self->operator_), sub1, sub2);
break;
case AKBASIC_LEAF_GROUPING:
PASS(errctx, akbasic_leaf_to_string(self->expr, sub1, sizeof(sub1)));
snprintf(dest, len, "(group %s)", sub1);
break;
case AKBASIC_LEAF_COMMAND:
case AKBASIC_LEAF_COMMAND_IMMEDIATE:
case AKBASIC_LEAF_FUNCTION:
/*
* The reference falls through to Go's %+v struct dump here, which has no
* useful C equivalent. Print something a test can assert on instead.
*/
snprintf(dest, len, "(%s)", self->identifier);
break;
default:
snprintf(dest, len, "(leaf %d)", (int)self->leaftype);
break;
}
SUCCEED_RETURN(errctx);
}

62
src/main.c Normal file
View File

@@ -0,0 +1,62 @@
/**
* @file main.c
* @brief The standalone driver.
*
* Everything that belongs to a program rather than to a library lives here: argv
* handling, sink selection, the unbounded run loop, and the one FINISH_NORETURN
* in the tree. The interpreter library itself never terminates the process.
*
* The runtime is static rather than automatic because it carries every pool the
* interpreter owns -- several megabytes -- and that will not fit on a default
* stack. An embedding game would place it in its own state for the same reason.
*/
#include <stdio.h>
#include <stdlib.h>
#include <akerror.h>
#include <akstdlib.h>
#include <akbasic/error.h>
#include <akbasic/runtime.h>
#include <akbasic/sink.h>
static akbasic_Runtime RUNTIME;
static akbasic_TextSink SINK;
static akbasic_StdioSink SINKSTATE;
int main(int argc, char **argv)
{
PREPARE_ERROR(errctx);
FILE *program = NULL;
int rc = EXIT_SUCCESS;
ATTEMPT {
if ( argc > 1 ) {
/*
* A file argument: read the program from it in RUNSTREAM mode, which
* files each line under its line number and then switches to RUN.
*/
CATCH(errctx, aksl_fopen(argv[1], "r", &program));
CATCH(errctx, akbasic_sink_init_stdio(&SINK, &SINKSTATE, stdout, program));
CATCH(errctx, akbasic_runtime_init(&RUNTIME, &SINK));
CATCH(errctx, akbasic_runtime_start(&RUNTIME, AKBASIC_MODE_RUNSTREAM));
} else {
CATCH(errctx, akbasic_sink_init_stdio(&SINK, &SINKSTATE, stdout, stdin));
CATCH(errctx, akbasic_runtime_init(&RUNTIME, &SINK));
CATCH(errctx, akbasic_runtime_start(&RUNTIME, AKBASIC_MODE_REPL));
}
/* Unbounded: this is the driver, and it has nothing else to do. */
CATCH(errctx, akbasic_runtime_run(&RUNTIME, 0));
} CLEANUP {
if ( program != NULL ) {
IGNORE(aksl_fclose(program));
}
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
LOG_ERROR_WITH_MESSAGE(errctx, "akbasic terminated on an unhandled error");
rc = EXIT_FAILURE;
} FINISH_NORETURN(errctx);
return rc;
}

617
src/parser.c Normal file
View File

@@ -0,0 +1,617 @@
/**
* @file parser.c
* @brief Implements the recursive-descent parser.
*
* A faithful port of basicparser.go, with two changes. The reflection lookup for
* a verb's special parse path becomes a table lookup, and the debug.PrintStack()
* the reference calls on a parse failure is gone: an interpreter library does not
* dump the host's stack to stderr, and the akerr stack trace already carries what
* that call was for.
*/
#include <inttypes.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/error.h>
#include <akbasic/parser.h>
#include <akbasic/verbs.h>
akerr_ErrorContext *akbasic_parser_init(akbasic_Parser *obj, akbasic_Runtime *runtime)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL parser in init");
FAIL_ZERO_RETURN(errctx, (runtime != NULL), AKERR_NULLPOINTER, "nil runtime argument");
obj->runtime = runtime;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_zero(akbasic_Parser *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "nil self reference!");
PASS(errctx, akbasic_environment_zero_parser(obj->runtime->environment));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_new_leaf(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, akbasic_environment_new_leaf(obj->runtime->environment, dest));
SUCCEED_RETURN(errctx);
}
bool akbasic_parser_is_at_end(akbasic_Parser *obj)
{
akbasic_Environment *env = NULL;
if ( obj == NULL || obj->runtime == NULL || obj->runtime->environment == NULL ) {
return true;
}
env = obj->runtime->environment;
return (env->curtoken >= (AKBASIC_MAX_TOKENS - 1) || env->curtoken >= env->nexttoken);
}
akbasic_Token *akbasic_parser_peek(akbasic_Parser *obj)
{
if ( akbasic_parser_is_at_end(obj) ) {
return NULL;
}
return &obj->runtime->environment->tokens[obj->runtime->environment->curtoken];
}
akerr_ErrorContext *akbasic_parser_previous(akbasic_Parser *obj, akbasic_Token **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in previous");
FAIL_ZERO_RETURN(errctx, (obj->runtime->environment->curtoken != 0), AKBASIC_ERR_SYNTAX,
"Current token is index 0, no previous token");
*dest = &obj->runtime->environment->tokens[obj->runtime->environment->curtoken - 1];
SUCCEED_RETURN(errctx);
}
static bool check(akbasic_Parser *obj, akbasic_TokenType tokentype)
{
akbasic_Token *next = NULL;
if ( akbasic_parser_is_at_end(obj) ) {
return false;
}
next = akbasic_parser_peek(obj);
return (next != NULL && next->tokentype == tokentype);
}
static void advance(akbasic_Parser *obj)
{
if ( !akbasic_parser_is_at_end(obj) ) {
obj->runtime->environment->curtoken += 1;
}
}
bool akbasic_parser_match(akbasic_Parser *obj, const akbasic_TokenType *types, int count)
{
int i = 0;
for ( i = 0; i < count; i++ ) {
if ( check(obj, types[i]) ) {
advance(obj);
return true;
}
}
return false;
}
bool akbasic_parser_match1(akbasic_Parser *obj, akbasic_TokenType type)
{
return akbasic_parser_match(obj, &type, 1);
}
akerr_ErrorContext *akbasic_parser_error(akbasic_Parser *obj, const char *message)
{
PREPARE_ERROR(errctx);
akbasic_Token *token = NULL;
token = akbasic_parser_peek(obj);
obj->runtime->environment->errorToken = token;
FAIL_ZERO_RETURN(errctx, (token != NULL), AKBASIC_ERR_SYNTAX, "peek() returned nil token!");
if ( token->tokentype == AKBASIC_TOK_EOF ) {
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX, "%" PRId64 " at end %s", token->lineno, message);
}
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX, "%" PRId64 " at '%s', %s",
token->lineno, token->lexeme, message);
}
static akerr_ErrorContext *consume(akbasic_Parser *obj, akbasic_TokenType tokentype, const char *message)
{
PREPARE_ERROR(errctx);
if ( check(obj, tokentype) ) {
advance(obj);
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_parser_error(obj, message));
SUCCEED_RETURN(errctx);
}
/* Forward declarations for the grammar chain. */
static akerr_ErrorContext *logicalandor(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *logicalnot(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *subtraction(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *addition(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *multiplication(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *division(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *unary(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *exponent(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
static akerr_ErrorContext *function_call(akbasic_Parser *obj, akbasic_ASTLeaf **dest);
akerr_ErrorContext *akbasic_parser_parse(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in parse");
PASS(errctx, akbasic_parser_command(obj, dest));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_command(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
static const akbasic_TokenType COMMANDS[] = {
AKBASIC_TOK_COMMAND, AKBASIC_TOK_COMMAND_IMMEDIATE
};
akbasic_ASTLeaf *expr = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_Token *operator_ = NULL;
akbasic_Token *righttoken = NULL;
const akbasic_Verb *verb = NULL;
akbasic_TokenType optype = AKBASIC_TOK_UNDEFINED;
char opname[AKBASIC_MAX_LINE_LENGTH];
if ( !akbasic_parser_match(obj, COMMANDS, 2) ) {
PASS(errctx, akbasic_parser_assignment(obj, dest));
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_parser_previous(obj, &operator_));
optype = operator_->tokentype;
strncpy(opname, operator_->lexeme, sizeof(opname) - 1);
opname[sizeof(opname) - 1] = '\0';
/* Does this verb need its own parse path? */
PASS(errctx, akbasic_verb_lookup(opname, &verb));
if ( verb != NULL && verb->parse != NULL ) {
PASS(errctx, verb->parse(obj, dest));
SUCCEED_RETURN(errctx);
}
/*
* Some verbs take no rval. Do not fail when there is not one -- but do fail
* when there is one and it will not parse.
*/
righttoken = akbasic_parser_peek(obj);
if ( righttoken != NULL && righttoken->tokentype != AKBASIC_TOK_UNDEFINED ) {
PASS(errctx, akbasic_parser_expression(obj, &right));
}
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
if ( optype == AKBASIC_TOK_COMMAND_IMMEDIATE ) {
PASS(errctx, akbasic_leaf_new_immediate_command(expr, opname, right));
} else {
PASS(errctx, akbasic_leaf_new_command(expr, opname, right));
}
*dest = expr;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_assignment(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *identifier = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_ASTLeaf *right = NULL;
PASS(errctx, akbasic_parser_expression(obj, &identifier));
if ( identifier == NULL ||
(identifier->leaftype != AKBASIC_LEAF_IDENTIFIER_INT &&
identifier->leaftype != AKBASIC_LEAF_IDENTIFIER_FLOAT &&
identifier->leaftype != AKBASIC_LEAF_IDENTIFIER_STRING) ) {
*dest = identifier;
SUCCEED_RETURN(errctx);
}
if ( akbasic_parser_match1(obj, AKBASIC_TOK_ASSIGNMENT) ) {
PASS(errctx, akbasic_parser_expression(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, identifier, AKBASIC_TOK_ASSIGNMENT, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
*dest = identifier;
SUCCEED_RETURN(errctx);
}
/*
* An argument list is just .right-joined expressions continuing ad infinitum.
* When requireparens is false and there is no opening paren, this still builds a
* list -- that is how DATA and READ take a bare comma-separated series.
*/
akerr_ErrorContext *akbasic_parser_argument_list(akbasic_Parser *obj, akbasic_TokenType arglisttype, bool requireparens, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *expr = NULL;
*dest = NULL;
if ( !akbasic_parser_match1(obj, AKBASIC_TOK_LEFT_PAREN) && requireparens ) {
SUCCEED_RETURN(errctx);
}
FAIL_ZERO_RETURN(errctx,
(arglisttype == AKBASIC_TOK_ARRAY_SUBSCRIPT ||
arglisttype == AKBASIC_TOK_FUNCTION_ARGUMENT),
AKBASIC_ERR_SYNTAX,
"argumentList expects argListType [ARRAY_SUBSCRIPT || FUNCTION_ARGUMENT]");
PASS(errctx, akbasic_parser_new_leaf(obj, &arglist));
arglist->leaftype = AKBASIC_LEAF_ARGUMENTLIST;
arglist->operator_ = arglisttype;
PASS(errctx, akbasic_parser_expression(obj, &arglist->right));
expr = arglist->right;
while ( expr != NULL && akbasic_parser_match1(obj, AKBASIC_TOK_COMMA) ) {
PASS(errctx, akbasic_parser_expression(obj, &expr->right));
expr = expr->right;
}
if ( !akbasic_parser_match1(obj, AKBASIC_TOK_RIGHT_PAREN) && requireparens ) {
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX, "Unbalanced parenthesis");
}
*dest = arglist;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_expression(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, logicalandor(obj, dest));
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *logicalandor(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
static const akbasic_TokenType OPS[] = { AKBASIC_TOK_AND, AKBASIC_TOK_OR };
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, logicalnot(obj, &left));
if ( akbasic_parser_match(obj, OPS, 2) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, logicalnot(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
*dest = left;
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *logicalnot(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
if ( akbasic_parser_match1(obj, AKBASIC_TOK_NOT) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, akbasic_parser_relation(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_unary(expr, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_parser_relation(obj, dest));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_relation(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
static const akbasic_TokenType OPS[] = {
AKBASIC_TOK_LESS_THAN, AKBASIC_TOK_LESS_THAN_EQUAL, AKBASIC_TOK_EQUAL,
AKBASIC_TOK_NOT_EQUAL, AKBASIC_TOK_GREATER_THAN, AKBASIC_TOK_GREATER_THAN_EQUAL
};
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, subtraction(obj, &left));
if ( akbasic_parser_match(obj, OPS, 6) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, subtraction(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
*dest = left;
SUCCEED_RETURN(errctx);
}
/*
* subtraction and exponent return after one operator where addition,
* multiplication and division loop. That asymmetry is the reference's, not a
* transcription slip: `1 - 2 - 3` parses as `1 - (2 - 3)` there. Reproduced,
* because the golden corpus encodes the observed associativity.
*/
static akerr_ErrorContext *subtraction(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, addition(obj, &left));
if ( akbasic_parser_match1(obj, AKBASIC_TOK_MINUS) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, addition(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
*dest = left;
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *addition(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, multiplication(obj, &left));
while ( akbasic_parser_match1(obj, AKBASIC_TOK_PLUS) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, multiplication(obj, &right));
if ( expr != NULL ) {
left = expr;
}
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
}
*dest = (expr != NULL ? expr : left);
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *multiplication(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, division(obj, &left));
while ( akbasic_parser_match1(obj, AKBASIC_TOK_STAR) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, division(obj, &right));
if ( expr != NULL ) {
left = expr;
}
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
}
*dest = (expr != NULL ? expr : left);
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *division(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, unary(obj, &left));
while ( akbasic_parser_match1(obj, AKBASIC_TOK_LEFT_SLASH) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, unary(obj, &right));
if ( expr != NULL ) {
left = expr;
}
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
}
*dest = (expr != NULL ? expr : left);
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *unary(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
if ( akbasic_parser_match1(obj, AKBASIC_TOK_MINUS) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, akbasic_parser_primary(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_unary(expr, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
PASS(errctx, exponent(obj, dest));
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *exponent(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *left = NULL;
akbasic_ASTLeaf *right = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, function_call(obj, &left));
if ( akbasic_parser_match1(obj, AKBASIC_TOK_CARAT) ) {
PASS(errctx, akbasic_parser_previous(obj, &operator_));
PASS(errctx, function_call(obj, &right));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_binary(expr, left, operator_->tokentype, right));
*dest = expr;
SUCCEED_RETURN(errctx);
}
*dest = left;
SUCCEED_RETURN(errctx);
}
/* Count the .right-joined chain hanging off an argument list. */
static int arglist_length(akbasic_ASTLeaf *arglist)
{
akbasic_ASTLeaf *leaf = NULL;
int count = 0;
if ( arglist == NULL ) {
return 0;
}
for ( leaf = arglist->right; leaf != NULL; leaf = leaf->right ) {
count += 1;
}
return count;
}
/*
* Called for function *calls* only, never for a DEF. A FUNCTION token is either
* a table builtin or a user DEF; both check their argument count here, so a
* wrong-arity call is a parse error rather than a runtime surprise.
*/
static akerr_ErrorContext *function_call(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *leaf = NULL;
akbasic_Token *operator_ = NULL;
const akbasic_Verb *verb = NULL;
akbasic_FunctionDef *fndef = NULL;
void *fnptr = NULL;
char fname[AKBASIC_MAX_LINE_LENGTH];
int wanted = 0;
int given = 0;
bool found = false;
if ( !akbasic_parser_match1(obj, AKBASIC_TOK_FUNCTION) ) {
PASS(errctx, akbasic_parser_primary(obj, dest));
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_parser_previous(obj, &operator_));
strncpy(fname, operator_->lexeme, sizeof(fname) - 1);
fname[sizeof(fname) - 1] = '\0';
PASS(errctx, akbasic_verb_lookup(fname, &verb));
if ( verb != NULL && verb->tokentype == AKBASIC_TOK_FUNCTION ) {
wanted = verb->arity;
found = true;
} else {
ATTEMPT {
CATCH(errctx, akbasic_environment_get_function(obj->runtime->environment, fname, &fnptr));
found = true;
} CLEANUP {
} PROCESS(errctx) {
} HANDLE(errctx, AKERR_KEY) {
found = false;
} FINISH(errctx, true);
if ( found ) {
fndef = (akbasic_FunctionDef *)fnptr;
wanted = arglist_length(fndef->arglist);
}
}
FAIL_ZERO_RETURN(errctx, found, AKBASIC_ERR_UNDEFINED, "No such function %s", fname);
PASS(errctx, akbasic_parser_argument_list(obj, AKBASIC_TOK_FUNCTION_ARGUMENT, true, &arglist));
given = arglist_length(arglist);
FAIL_ZERO_RETURN(errctx, (given == wanted), AKBASIC_ERR_SYNTAX,
"function %s takes %d arguments, received %d", fname, wanted, given);
PASS(errctx, akbasic_parser_new_leaf(obj, &leaf));
PASS(errctx, akbasic_leaf_new_function(leaf, fname, arglist));
*dest = leaf;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parser_primary(akbasic_Parser *obj, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
static const akbasic_TokenType PRIMARIES[] = {
AKBASIC_TOK_LITERAL_INT, AKBASIC_TOK_LITERAL_FLOAT, AKBASIC_TOK_LITERAL_STRING,
AKBASIC_TOK_IDENTIFIER, AKBASIC_TOK_IDENTIFIER_STRING, AKBASIC_TOK_IDENTIFIER_FLOAT,
AKBASIC_TOK_IDENTIFIER_INT, AKBASIC_TOK_FUNCTION
};
akbasic_ASTLeaf *expr = NULL;
akbasic_ASTLeaf *groupexpr = NULL;
akbasic_Token *previous = NULL;
if ( akbasic_parser_match(obj, PRIMARIES, 8) ) {
PASS(errctx, akbasic_parser_previous(obj, &previous));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
switch ( previous->tokentype ) {
case AKBASIC_TOK_LITERAL_INT:
PASS(errctx, akbasic_leaf_new_literal_int(expr, previous->lexeme));
break;
case AKBASIC_TOK_LITERAL_FLOAT:
PASS(errctx, akbasic_leaf_new_literal_float(expr, previous->lexeme));
break;
case AKBASIC_TOK_LITERAL_STRING:
PASS(errctx, akbasic_leaf_new_literal_string(expr, previous->lexeme));
break;
case AKBASIC_TOK_IDENTIFIER_INT:
PASS(errctx, akbasic_leaf_new_identifier(expr, AKBASIC_LEAF_IDENTIFIER_INT, previous->lexeme));
PASS(errctx, akbasic_parser_argument_list(obj, AKBASIC_TOK_ARRAY_SUBSCRIPT, true, &expr->right));
break;
case AKBASIC_TOK_IDENTIFIER_FLOAT:
PASS(errctx, akbasic_leaf_new_identifier(expr, AKBASIC_LEAF_IDENTIFIER_FLOAT, previous->lexeme));
PASS(errctx, akbasic_parser_argument_list(obj, AKBASIC_TOK_ARRAY_SUBSCRIPT, true, &expr->right));
break;
case AKBASIC_TOK_IDENTIFIER_STRING:
PASS(errctx, akbasic_leaf_new_identifier(expr, AKBASIC_LEAF_IDENTIFIER_STRING, previous->lexeme));
PASS(errctx, akbasic_parser_argument_list(obj, AKBASIC_TOK_ARRAY_SUBSCRIPT, true, &expr->right));
break;
case AKBASIC_TOK_FUNCTION:
case AKBASIC_TOK_IDENTIFIER:
PASS(errctx, akbasic_leaf_new_identifier(expr, AKBASIC_LEAF_IDENTIFIER, previous->lexeme));
break;
default:
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX, "Invalid literal type, command or function name");
}
*dest = expr;
SUCCEED_RETURN(errctx);
}
if ( akbasic_parser_match1(obj, AKBASIC_TOK_LEFT_PAREN) ) {
PASS(errctx, akbasic_parser_expression(obj, &groupexpr));
PASS(errctx, consume(obj, AKBASIC_TOK_RIGHT_PAREN, "Missing ) after expression"));
PASS(errctx, akbasic_parser_new_leaf(obj, &expr));
PASS(errctx, akbasic_leaf_new_grouping(expr, groupexpr));
*dest = expr;
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_parser_error(obj, "Expected expression or literal"));
SUCCEED_RETURN(errctx);
}

356
src/parser_commands.c Normal file
View File

@@ -0,0 +1,356 @@
/**
* @file parser_commands.c
* @brief Verbs that need their own parse path rather than a plain expression.
*
* Ported from basicparser_commands.go. Two of these mutate runtime state from
* inside the parser and that is not an accident: DEF installs the function so a
* later line can call it, and FOR builds and installs the loop's environment
* before the body is ever scanned. The waitingForCommand scheme depends on the
* latter.
*/
#include <inttypes.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/error.h>
#include <akbasic/parser.h>
#include <akbasic/runtime.h>
#include "verbs.h"
akerr_ErrorContext *akbasic_parse_let(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
/*
* LET is optional in this dialect and in Commodore BASIC 7.0. Assignment is
* handled by expression evaluation, so LET parses as a bare assignment and
* its exec handler does nothing.
*/
PASS(errctx, akbasic_parser_assignment(parser, dest));
SUCCEED_RETURN(errctx);
}
/* LABEL and DIM share a shape: the verb, then one identifier. */
static akerr_ErrorContext *parse_verb_with_identifier(akbasic_Parser *parser, const char *verbname, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *identifier = NULL;
akbasic_ASTLeaf *command = NULL;
PASS(errctx, akbasic_parser_primary(parser, &identifier));
FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(identifier), AKBASIC_ERR_SYNTAX,
"Expected identifier");
PASS(errctx, akbasic_parser_new_leaf(parser, &command));
PASS(errctx, akbasic_leaf_new_command(command, verbname, identifier));
*dest = command;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parse_label(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, parse_verb_with_identifier(parser, "LABEL", dest));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parse_dim(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, parse_verb_with_identifier(parser, "DIM", dest));
SUCCEED_RETURN(errctx);
}
/*
* DEF NAME (A, ...) [= expression]
* COMMAND IDENTIFIER ARGUMENTLIST [ASSIGNMENT EXPRESSION]
*
* With an `=` the function is a single expression. Without one it is a
* multi-line subroutine whose body starts on the next line and ends at RETURN,
* so the environment is told to skip forward to that RETURN rather than execute
* the body during the definition.
*/
akerr_ErrorContext *akbasic_parse_def(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_Runtime *runtime = parser->runtime;
akbasic_ASTLeaf *identifier = NULL;
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *expression = NULL;
akbasic_ASTLeaf *walk = NULL;
akbasic_ASTLeaf *command = NULL;
akbasic_FunctionDef *fndef = NULL;
size_t i = 0;
PASS(errctx, akbasic_parser_primary(parser, &identifier));
FAIL_ZERO_RETURN(errctx, (identifier->leaftype == AKBASIC_LEAF_IDENTIFIER),
AKBASIC_ERR_SYNTAX, "Expected identifier");
PASS(errctx, akbasic_parser_argument_list(parser, AKBASIC_TOK_FUNCTION_ARGUMENT, true, &arglist));
FAIL_ZERO_RETURN(errctx, (arglist != NULL), AKBASIC_ERR_SYNTAX,
"Expected argument list (identifier names)");
for ( walk = arglist->right; walk != NULL; walk = walk->right ) {
FAIL_ZERO_RETURN(errctx,
(walk->leaftype == AKBASIC_LEAF_IDENTIFIER_STRING ||
walk->leaftype == AKBASIC_LEAF_IDENTIFIER_INT ||
walk->leaftype == AKBASIC_LEAF_IDENTIFIER_FLOAT),
AKBASIC_ERR_SYNTAX,
"Only variable identifiers are valid arguments for DEF");
}
PASS(errctx, akbasic_runtime_new_function(runtime, &fndef));
/* Uppercase the name: verbs and function names are case-insensitive. */
FAIL_ZERO_RETURN(errctx, (strlen(identifier->identifier) < sizeof(fndef->name)),
AKBASIC_ERR_BOUNDS, "Function name '%s' is too long", identifier->identifier);
for ( i = 0; i < strlen(identifier->identifier); i++ ) {
char c = identifier->identifier[i];
fndef->name[i] = (char)((c >= 'a' && c <= 'z') ? (c - 'a' + 'A') : c);
}
fndef->name[strlen(identifier->identifier)] = '\0';
if ( akbasic_parser_match1(parser, AKBASIC_TOK_ASSIGNMENT) ) {
PASS(errctx, akbasic_parser_expression(parser, &expression));
PASS(errctx, akbasic_leaf_clone(expression, &fndef->leafpool, &fndef->expression));
} else {
/*
* No expression: the body is the lines that follow. Record where it
* starts and skip to RETURN so the definition itself does not execute
* the body.
*/
fndef->expression = NULL;
PASS(errctx, akbasic_environment_wait_for_command(runtime->environment, "RETURN"));
}
PASS(errctx, akbasic_leaf_clone(arglist, &fndef->leafpool, &fndef->arglist));
fndef->lineno = runtime->environment->lineno + 1;
PASS(errctx, akbasic_symtab_set(&runtime->environment->functions, fndef->name, fndef, 0));
PASS(errctx, akbasic_parser_new_leaf(parser, &command));
PASS(errctx, akbasic_leaf_new_command(command, "DEF", NULL));
*dest = command;
SUCCEED_RETURN(errctx);
}
/*
* FOR ... TO .... [STEP ...]
* COMMAND ASSIGNMENT EXPRESSION [COMMAND EXPRESSION]
*
* Sets up the loop's environment with the TO and STEP expressions and the first
* body line, then makes it the active environment. The FOR leaf itself carries
* the assignment.
*/
akerr_ErrorContext *akbasic_parse_for(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_Runtime *runtime = parser->runtime;
akbasic_ASTLeaf *assignment = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_Token *operator_ = NULL;
akbasic_Environment *parent = runtime->environment;
akbasic_Environment *newenv = NULL;
int64_t firstline = 0;
PASS(errctx, akbasic_parser_assignment(parser, &assignment));
FAIL_ZERO_RETURN(errctx, akbasic_parser_match1(parser, AKBASIC_TOK_COMMAND),
AKBASIC_ERR_SYNTAX,
"Expected FOR (assignment) TO (expression) [STEP (expression)]");
PASS(errctx, akbasic_parser_previous(parser, &operator_));
FAIL_NONZERO_RETURN(errctx, strcmp(operator_->lexeme, "TO"), AKBASIC_ERR_SYNTAX,
"Expected FOR (assignment) TO (expression) [STEP (expression)]");
FAIL_ZERO_RETURN(errctx,
(assignment != NULL && akbasic_leaf_is_identifier(assignment->left)),
AKBASIC_ERR_SYNTAX,
"Expected FOR (assignment) TO (expression) [STEP (expression)]");
firstline = parent->lineno + 1;
/*
* The loop body is scanned against the *parent* environment's token stream,
* so the new environment cannot become active until parsing is done. Parse
* TO and STEP first, then switch.
*/
PASS(errctx, akbasic_runtime_new_environment(runtime));
newenv = runtime->environment;
runtime->environment = parent;
PASS(errctx, akbasic_parser_expression(parser, &newenv->forToLeaf));
if ( akbasic_parser_match1(parser, AKBASIC_TOK_COMMAND) ) {
PASS(errctx, akbasic_parser_previous(parser, &operator_));
FAIL_NONZERO_RETURN(errctx, strcmp(operator_->lexeme, "STEP"), AKBASIC_ERR_SYNTAX,
"Expected FOR (assignment) TO (expression) [STEP (expression)]");
PASS(errctx, akbasic_parser_expression(parser, &newenv->forStepLeaf));
} else {
/*
* Dartmouth BASIC says not to infer a negative step: it is either given
* explicitly or assumed to be +1.
*/
PASS(errctx, akbasic_parser_new_leaf(parser, &newenv->forStepLeaf));
PASS(errctx, akbasic_leaf_new_literal_int(newenv->forStepLeaf, "1"));
}
/* A NEXT already being awaited means this is an inner loop over the same variable. */
if ( strcmp(parent->waitingForCommand, "NEXT") == 0 ) {
newenv->forNextVariable = parent->forNextVariable;
}
newenv->loopFirstLine = firstline;
PASS(errctx, akbasic_parser_new_leaf(parser, &expr));
PASS(errctx, akbasic_leaf_new_command(expr, "FOR", assignment));
runtime->environment = newenv;
*dest = expr;
SUCCEED_RETURN(errctx);
}
/*
* READ VARNAME [, ...]
* COMMAND ARGUMENTLIST
*
* The identifier leaves are deep-copied into the environment, because the DATA
* line that fills them is parsed later and will have overwritten the per-line
* leaf pool by then.
*/
akerr_ErrorContext *akbasic_parse_read(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_Environment *env = parser->runtime->environment;
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_ASTLeaf *command = NULL;
int i = 0;
PASS(errctx, akbasic_parser_argument_list(parser, AKBASIC_TOK_FUNCTION_ARGUMENT, false, &arglist));
FAIL_ZERO_RETURN(errctx, (arglist != NULL && arglist->right != NULL), AKBASIC_ERR_SYNTAX,
"Expected identifier");
env->readLeafPool.next = 0;
expr = arglist->right;
for ( i = 0; i < AKBASIC_MAX_LEAVES; i++ ) {
if ( expr == NULL ) {
env->readIdentifierLeaves[i] = NULL;
continue;
}
FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(expr), AKBASIC_ERR_SYNTAX,
"Expected identifier");
PASS(errctx, akbasic_leaf_clone(expr, &env->readLeafPool, &env->readIdentifierLeaves[i]));
/*
* A cloned identifier keeps its .right chain, which for READ is the
* *next* identifier, not a subscript. Sever it so evaluating this leaf
* cannot walk into its sibling.
*/
env->readIdentifierLeaves[i]->right = NULL;
expr = expr->right;
}
env->readReturnLine = env->lineno + 1;
PASS(errctx, akbasic_parser_new_leaf(parser, &command));
PASS(errctx, akbasic_leaf_new_command(command, "READ", arglist));
*dest = command;
SUCCEED_RETURN(errctx);
}
/*
* DATA LITERAL [, ...]
* COMMAND ARGUMENTLIST
*/
akerr_ErrorContext *akbasic_parse_data(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *expr = NULL;
akbasic_ASTLeaf *command = NULL;
PASS(errctx, akbasic_parser_argument_list(parser, AKBASIC_TOK_FUNCTION_ARGUMENT, false, &arglist));
FAIL_ZERO_RETURN(errctx, (arglist != NULL && arglist->right != NULL), AKBASIC_ERR_SYNTAX,
"Expected literal");
for ( expr = arglist->right; expr != NULL; expr = expr->right ) {
FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_literal(expr), AKBASIC_ERR_SYNTAX,
"Expected literal");
}
PASS(errctx, akbasic_parser_new_leaf(parser, &command));
PASS(errctx, akbasic_leaf_new_command(command, "DATA", arglist));
*dest = command;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_parse_poke(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *arglist = NULL;
akbasic_ASTLeaf *expr = NULL;
PASS(errctx, akbasic_parser_argument_list(parser, AKBASIC_TOK_FUNCTION_ARGUMENT, false, &arglist));
FAIL_ZERO_RETURN(errctx, (arglist != NULL), AKBASIC_ERR_SYNTAX,
"POKE expected INTEGER, INTEGER");
PASS(errctx, akbasic_parser_new_leaf(parser, &expr));
PASS(errctx, akbasic_leaf_new_command(expr, "POKE", arglist));
*dest = expr;
SUCCEED_RETURN(errctx);
}
/*
* IF relation THEN command [ELSE command]
* becomes BRANCH(expr=relation, left=then_command, right=else_command).
*/
akerr_ErrorContext *akbasic_parse_if(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *relation = NULL;
akbasic_ASTLeaf *then_command = NULL;
akbasic_ASTLeaf *else_command = NULL;
akbasic_ASTLeaf *branch = NULL;
akbasic_Token *operator_ = NULL;
PASS(errctx, akbasic_parser_relation(parser, &relation));
FAIL_ZERO_RETURN(errctx, akbasic_parser_match1(parser, AKBASIC_TOK_COMMAND),
AKBASIC_ERR_SYNTAX, "Incomplete IF statement");
PASS(errctx, akbasic_parser_previous(parser, &operator_));
FAIL_NONZERO_RETURN(errctx, strcmp(operator_->lexeme, "THEN"), AKBASIC_ERR_SYNTAX,
"Expected IF ... THEN");
PASS(errctx, akbasic_parser_command(parser, &then_command));
if ( akbasic_parser_match1(parser, AKBASIC_TOK_COMMAND) ) {
PASS(errctx, akbasic_parser_previous(parser, &operator_));
FAIL_NONZERO_RETURN(errctx, strcmp(operator_->lexeme, "ELSE"), AKBASIC_ERR_SYNTAX,
"Expected IF ... THEN ... ELSE ...");
PASS(errctx, akbasic_parser_command(parser, &else_command));
}
PASS(errctx, akbasic_parser_new_leaf(parser, &branch));
PASS(errctx, akbasic_leaf_new_branch(branch, relation, then_command, else_command));
*dest = branch;
SUCCEED_RETURN(errctx);
}
/*
* INPUT "PROMPT" VARIABLE
* COMMAND EXPRESSION IDENTIFIER
*
* The prompt is hung off the identifier's .left, which is where the exec handler
* looks for it.
*/
akerr_ErrorContext *akbasic_parse_input(akbasic_Parser *parser, akbasic_ASTLeaf **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *promptexpr = NULL;
akbasic_ASTLeaf *identifier = NULL;
akbasic_ASTLeaf *command = NULL;
PASS(errctx, akbasic_parser_expression(parser, &promptexpr));
PASS(errctx, akbasic_parser_primary(parser, &identifier));
FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(identifier), AKBASIC_ERR_SYNTAX,
"Expected identifier");
PASS(errctx, akbasic_parser_new_leaf(parser, &command));
PASS(errctx, akbasic_leaf_new_command(command, "INPUT", identifier));
identifier->left = promptexpr;
*dest = command;
SUCCEED_RETURN(errctx);
}

797
src/runtime.c Normal file
View File

@@ -0,0 +1,797 @@
/**
* @file runtime.c
* @brief Implements the interpreter core: pools, evaluation and the step loop.
*/
#include <inttypes.h>
#include <stdio.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/error.h>
#include <akbasic/parser.h>
#include <akbasic/runtime.h>
#include <akbasic/scanner.h>
#include <akbasic/verbs.h>
/* ------------------------------------------------------------------ pools -- */
akerr_ErrorContext *akbasic_runtime_new_variable(akbasic_Runtime *obj, akbasic_Variable **dest)
{
PREPARE_ERROR(errctx);
int i = 0;
FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in new_variable");
for ( i = 0; i < AKBASIC_MAX_VARIABLES; i++ ) {
if ( !obj->variables[i].used ) {
memset(&obj->variables[i], 0, sizeof(obj->variables[i]));
obj->variables[i].used = true;
*dest = &obj->variables[i];
SUCCEED_RETURN(errctx);
}
}
FAIL_RETURN(errctx, AKBASIC_ERR_BOUNDS, "Maximum runtime variables reached");
}
akerr_ErrorContext *akbasic_runtime_new_function(akbasic_Runtime *obj, akbasic_FunctionDef **dest)
{
PREPARE_ERROR(errctx);
int i = 0;
FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in new_function");
for ( i = 0; i < AKBASIC_MAX_FUNCTIONS; i++ ) {
if ( !obj->functions[i].used ) {
memset(&obj->functions[i], 0, sizeof(obj->functions[i]));
obj->functions[i].used = true;
obj->functions[i].leafpool.next = 0;
obj->functions[i].leafpool.capacity = AKBASIC_MAX_LEAVES * 2;
obj->functions[i].leafpool.leaves = obj->functions[i].leafstorage;
*dest = &obj->functions[i];
SUCCEED_RETURN(errctx);
}
}
FAIL_RETURN(errctx, AKBASIC_ERR_BOUNDS, "Maximum function definitions reached");
}
static akerr_ErrorContext *env_acquire(akbasic_Runtime *obj, akbasic_Environment **dest)
{
PREPARE_ERROR(errctx);
int i = 0;
for ( i = 0; i < AKBASIC_MAX_ENVIRONMENTS; i++ ) {
if ( !obj->environments[i].used ) {
obj->environments[i].used = true;
*dest = &obj->environments[i];
SUCCEED_RETURN(errctx);
}
}
FAIL_RETURN(errctx, AKBASIC_ERR_ENVIRONMENT,
"Environment pool exhausted at line %" PRId64 " (%d in use)",
(obj->environment == NULL ? 0 : obj->environment->lineno),
AKBASIC_MAX_ENVIRONMENTS);
}
akerr_ErrorContext *akbasic_runtime_new_environment(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
akbasic_Environment *env = NULL;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in new_environment");
PASS(errctx, env_acquire(obj, &env));
PASS(errctx, akbasic_environment_init(env, obj, obj->environment));
obj->environment = env;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_prev_environment(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
akbasic_Environment *popped = NULL;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in prev_environment");
FAIL_ZERO_RETURN(errctx, (obj->environment->parent != NULL), AKBASIC_ERR_ENVIRONMENT,
"No previous environment to return to");
popped = obj->environment;
obj->environment = popped->parent;
/*
* Release it. The reference never does, which is a leak the GC papers over;
* here the pool is finite, so an unreleased environment is a bug that shows
* up as exhaustion a few thousand GOSUBs later.
*/
popped->used = false;
SUCCEED_RETURN(errctx);
}
/* ------------------------------------------------------------- lifecycle -- */
akerr_ErrorContext *akbasic_runtime_zero(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in zero");
PASS(errctx, akbasic_environment_zero(obj->environment));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_init(akbasic_Runtime *obj, akbasic_TextSink *sink)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in init");
FAIL_ZERO_RETURN(errctx, (sink != NULL), AKERR_NULLPOINTER, "NULL text sink in init");
/*
* Claim the status band before anything can raise one of our codes, or the
* first error out of this function prints "Unknown Error". Idempotent, so a
* host that already called it loses nothing.
*/
PASS(errctx, akbasic_error_register());
memset(obj, 0, sizeof(*obj));
obj->sink = sink;
obj->environment = NULL;
obj->autoLineNumber = 0;
obj->eval_clone_identifiers = true;
obj->errclass = AKBASIC_ERRCLASS_NONE;
obj->mode = AKBASIC_MODE_REPL;
obj->run_finished_mode = AKBASIC_MODE_REPL;
obj->inputEof = false;
PASS(errctx, akbasic_valuepool_init(&obj->valuepool));
PASS(errctx, akbasic_value_zero(&obj->staticTrueValue));
PASS(errctx, akbasic_value_zero(&obj->staticFalseValue));
PASS(errctx, akbasic_value_set_bool(&obj->staticTrueValue, true));
PASS(errctx, akbasic_value_set_bool(&obj->staticFalseValue, false));
PASS(errctx, akbasic_runtime_new_environment(obj));
PASS(errctx, akbasic_runtime_zero(obj));
PASS(errctx, akbasic_scanner_zero(obj));
SUCCEED_RETURN(errctx);
}
/* ---------------------------------------------------------------- output -- */
akerr_ErrorContext *akbasic_runtime_write(akbasic_Runtime *obj, const char *text)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && text != NULL), AKERR_NULLPOINTER,
"NULL argument in write");
PASS(errctx, obj->sink->write(obj->sink, text));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_println(akbasic_Runtime *obj, const char *text)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && text != NULL), AKERR_NULLPOINTER,
"NULL argument in println");
PASS(errctx, obj->sink->writeln(obj->sink, text));
SUCCEED_RETURN(errctx);
}
static const char *errclass_to_string(akbasic_ErrorClass errclass)
{
switch ( errclass ) {
case AKBASIC_ERRCLASS_IO: return "IO ERROR";
case AKBASIC_ERRCLASS_PARSE: return "PARSE ERROR";
case AKBASIC_ERRCLASS_RUNTIME: return "RUNTIME ERROR";
case AKBASIC_ERRCLASS_SYNTAX: return "SYNTAX ERROR";
default: return "UNDEF";
}
}
akerr_ErrorContext *akbasic_runtime_error(akbasic_Runtime *obj, akbasic_ErrorClass errclass, const char *message)
{
PREPARE_ERROR(errctx);
char line[AKBASIC_MAX_LINE_LENGTH * 2];
FAIL_ZERO_RETURN(errctx, (obj != NULL && message != NULL), AKERR_NULLPOINTER,
"NULL argument in runtime error");
obj->errclass = errclass;
/*
* The format, the trailing \n inside the string, and the second newline
* writeln adds are all part of the acceptance contract --
* tests/language/array_outofbounds.txt ends in 0a 0a. See TODO.md 1.8.
*/
snprintf(line, sizeof(line), "? %" PRId64 " : %s %s\n",
obj->environment->lineno, errclass_to_string(errclass), message);
PASS(errctx, akbasic_runtime_println(obj, line));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_set_mode(akbasic_Runtime *obj, int mode)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in set_mode");
obj->mode = mode;
if ( obj->mode == AKBASIC_MODE_REPL ) {
PASS(errctx, akbasic_runtime_println(obj, "READY"));
}
SUCCEED_RETURN(errctx);
}
/* ------------------------------------------------------------ evaluation -- */
/*
* Report a runtime error carrying an akerr message, then re-raise. Used where
* the reference calls basicError() and returns the error: the BASIC-visible line
* goes to the sink and the context keeps propagating.
*/
static akerr_ErrorContext *report_and_reraise(akbasic_Runtime *obj, akerr_ErrorContext *cause)
{
PREPARE_ERROR(errctx);
char message[AKERR_MAX_ERROR_CONTEXT_STRING_LENGTH];
int status = cause->status;
snprintf(message, sizeof(message), "%s", cause->message);
cause->handled = true;
IGNORE(akerr_release_error(cause));
PASS(errctx, akbasic_runtime_error(obj, AKBASIC_ERRCLASS_RUNTIME, message));
FAIL_RETURN(errctx, status, "%s", message);
}
static akerr_ErrorContext *evaluate_identifier(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *texpr = NULL;
akbasic_Value *tval = NULL;
akbasic_Value *slot = NULL;
akbasic_Value *copy = NULL;
akbasic_Variable *variable = NULL;
int64_t subscripts[AKBASIC_MAX_ARRAY_DEPTH];
int subscriptcount = 0;
/*
* A .right hanging off an identifier is an array subscript only when it is
* an ARRAY_SUBSCRIPT argument list; anything else belongs to the enclosing
* expression and must not be followed.
*/
texpr = expr->right;
if ( texpr != NULL &&
texpr->leaftype == AKBASIC_LEAF_ARGUMENTLIST &&
texpr->operator_ == AKBASIC_TOK_ARRAY_SUBSCRIPT ) {
for ( texpr = texpr->right; texpr != NULL; texpr = texpr->right ) {
FAIL_ZERO_RETURN(errctx, (subscriptcount < AKBASIC_MAX_ARRAY_DEPTH),
AKBASIC_ERR_BOUNDS,
"More than %d array subscripts", AKBASIC_MAX_ARRAY_DEPTH);
PASS(errctx, akbasic_runtime_evaluate(obj, texpr, &tval));
FAIL_NONZERO_RETURN(errctx, (tval->valuetype != AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE,
"Array dimensions must evaluate to integer (C)");
subscripts[subscriptcount] = tval->intval;
subscriptcount += 1;
}
}
if ( subscriptcount == 0 ) {
subscripts[0] = 0;
subscriptcount = 1;
}
PASS(errctx, akbasic_environment_get(obj->environment, expr->identifier, &variable));
FAIL_ZERO_RETURN(errctx, (variable != NULL), AKBASIC_ERR_UNDEFINED,
"Identifier %s is undefined", expr->identifier);
PASS(errctx, akbasic_variable_get_subscript(variable, subscripts, subscriptcount, &slot));
if ( !obj->eval_clone_identifiers ) {
*dest = slot;
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_environment_new_value(obj->environment, &copy));
PASS(errctx, akbasic_value_clone(slot, copy));
*dest = copy;
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *evaluate_binary(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *lval = NULL;
akbasic_Value *rval = NULL;
akbasic_Value *scratch = NULL;
PASS(errctx, akbasic_runtime_evaluate(obj, expr->left, &lval));
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &rval));
if ( expr->operator_ == AKBASIC_TOK_ASSIGNMENT ) {
PASS(errctx, akbasic_environment_assign(obj->environment, expr->left, rval, dest));
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_environment_new_value(obj->environment, &scratch));
switch ( expr->operator_ ) {
case AKBASIC_TOK_MINUS:
PASS(errctx, akbasic_value_math_minus(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_PLUS:
PASS(errctx, akbasic_value_math_plus(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_LEFT_SLASH:
PASS(errctx, akbasic_value_math_divide(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_STAR:
PASS(errctx, akbasic_value_math_multiply(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_AND:
PASS(errctx, akbasic_value_bitwise_and(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_OR:
PASS(errctx, akbasic_value_bitwise_or(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_LESS_THAN:
PASS(errctx, akbasic_value_less_than(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_LESS_THAN_EQUAL:
PASS(errctx, akbasic_value_less_than_equal(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_EQUAL:
PASS(errctx, akbasic_value_is_equal(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_NOT_EQUAL:
PASS(errctx, akbasic_value_is_not_equal(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_GREATER_THAN:
PASS(errctx, akbasic_value_greater_than(lval, rval, scratch, dest));
break;
case AKBASIC_TOK_GREATER_THAN_EQUAL:
PASS(errctx, akbasic_value_greater_than_equal(lval, rval, scratch, dest));
break;
default:
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX,
"Don't know how to perform binary operation %d", (int)expr->operator_);
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_evaluate(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *lval = NULL;
akbasic_Value *rval = NULL;
akbasic_Value *scratch = NULL;
const akbasic_Verb *verb = NULL;
FAIL_ZERO_RETURN(errctx, (obj != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in evaluate");
FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "NULL expression in evaluate");
PASS(errctx, akbasic_environment_new_value(obj->environment, &lval));
PASS(errctx, akbasic_value_zero(lval));
*dest = lval;
switch ( expr->leaftype ) {
case AKBASIC_LEAF_GROUPING:
PASS(errctx, akbasic_runtime_evaluate(obj, expr->expr, dest));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_BRANCH:
ATTEMPT {
CATCH(errctx, akbasic_runtime_evaluate(obj, expr->expr, &rval));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
PASS(errctx, report_and_reraise(obj, errctx));
} FINISH(errctx, true);
if ( rval->boolvalue == AKBASIC_TRUE ) {
PASS(errctx, akbasic_runtime_evaluate(obj, expr->left, dest));
SUCCEED_RETURN(errctx);
}
if ( expr->right != NULL ) {
/* A false branch is optional for some branching operations. */
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, dest));
SUCCEED_RETURN(errctx);
}
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_IDENTIFIER_INT:
case AKBASIC_LEAF_IDENTIFIER_FLOAT:
case AKBASIC_LEAF_IDENTIFIER_STRING:
PASS(errctx, evaluate_identifier(obj, expr, dest));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_IDENTIFIER:
/* A bare identifier with no type suffix is a label. */
lval->valuetype = AKBASIC_TYPE_INTEGER;
PASS(errctx, akbasic_environment_get_label(obj->environment, expr->identifier, &lval->intval));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_LITERAL_INT:
lval->valuetype = AKBASIC_TYPE_INTEGER;
lval->intval = expr->literal_int;
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_LITERAL_FLOAT:
lval->valuetype = AKBASIC_TYPE_FLOAT;
lval->floatval = expr->literal_float;
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_LITERAL_STRING:
lval->valuetype = AKBASIC_TYPE_STRING;
memcpy(lval->stringval, expr->literal_string, sizeof(lval->stringval));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_UNARY:
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &rval));
PASS(errctx, akbasic_environment_new_value(obj->environment, &scratch));
if ( expr->operator_ == AKBASIC_TOK_MINUS ) {
PASS(errctx, akbasic_value_invert(rval, scratch, dest));
} else if ( expr->operator_ == AKBASIC_TOK_NOT ) {
PASS(errctx, akbasic_value_bitwise_not(rval, scratch, dest));
} else {
FAIL_RETURN(errctx, AKBASIC_ERR_SYNTAX,
"Don't know how to perform operation %d on unary type %d",
(int)expr->operator_, (int)rval->valuetype);
}
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_FUNCTION:
PASS(errctx, akbasic_verb_lookup(expr->identifier, &verb));
if ( verb != NULL && verb->exec != NULL && verb->tokentype == AKBASIC_TOK_FUNCTION ) {
PASS(errctx, verb->exec(obj, expr, lval, rval, dest));
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_user_function(obj, expr, dest));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_COMMAND_IMMEDIATE:
case AKBASIC_LEAF_COMMAND:
PASS(errctx, akbasic_verb_lookup(expr->identifier, &verb));
FAIL_ZERO_RETURN(errctx, (verb != NULL && verb->exec != NULL), AKBASIC_ERR_UNDEFINED,
"Unknown command %s", expr->identifier);
PASS(errctx, verb->exec(obj, expr, lval, rval, dest));
SUCCEED_RETURN(errctx);
case AKBASIC_LEAF_BINARY:
PASS(errctx, evaluate_binary(obj, expr, dest));
SUCCEED_RETURN(errctx);
default:
SUCCEED_RETURN(errctx);
}
}
akerr_ErrorContext *akbasic_runtime_interpret(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && expr != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in interpret");
/*
* While an environment is skipping forward to a verb, nothing runs but that
* verb. This is what keeps a zero-iteration FOR body from executing, given
* that the loop condition is evaluated at the bottom of the structure.
*/
if ( akbasic_environment_is_waiting_for_any(obj->environment) ) {
if ( expr->leaftype != AKBASIC_LEAF_COMMAND ||
!akbasic_environment_is_waiting_for(obj->environment, expr->identifier) ) {
*dest = &obj->staticTrueValue;
SUCCEED_RETURN(errctx);
}
}
ATTEMPT {
CATCH(errctx, akbasic_runtime_evaluate(obj, expr, dest));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
PASS(errctx, report_and_reraise(obj, errctx));
} FINISH(errctx, true);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_interpret_immediate(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL && expr != NULL && dest != NULL), AKERR_NULLPOINTER,
"NULL argument in interpret_immediate");
*dest = NULL;
if ( expr->leaftype != AKBASIC_LEAF_COMMAND_IMMEDIATE ) {
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_evaluate(obj, expr, dest));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_user_function(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_FunctionDef *fndef = NULL;
akbasic_Environment *targetenv = obj->environment;
akbasic_ASTLeaf *leafptr = NULL;
akbasic_ASTLeaf *argptr = NULL;
akbasic_Value *argvalue = NULL;
akbasic_Value *unused = NULL;
void *fnptr = NULL;
PASS(errctx, akbasic_environment_get_function(obj->environment, expr->identifier, &fnptr));
fndef = (akbasic_FunctionDef *)fnptr;
/*
* The function's environment is owned by the funcdef, not by the pool free
* list: it is reset on every call and outlives any single one. The reference
* holds it by value inside BasicFunctionDef for the same reason.
*/
if ( fndef->environment == NULL ) {
PASS(errctx, akbasic_runtime_new_environment(obj));
fndef->environment = obj->environment;
obj->environment = targetenv;
}
PASS(errctx, akbasic_environment_init(fndef->environment, obj, obj->environment));
/* Bind arguments into the function's scope before entering it. */
leafptr = (expr->right != NULL ? expr->right->right : NULL);
argptr = (fndef->arglist != NULL ? fndef->arglist->right : NULL);
while ( leafptr != NULL && argptr != NULL ) {
akbasic_Environment *callerenv = obj->environment;
PASS(errctx, akbasic_runtime_evaluate(obj, leafptr, &argvalue));
obj->environment = fndef->environment;
PASS(errctx, akbasic_environment_assign(fndef->environment, argptr, argvalue, &unused));
obj->environment = callerenv;
leafptr = leafptr->right;
argptr = argptr->right;
}
obj->environment = fndef->environment;
if ( fndef->expression != NULL ) {
PASS(errctx, akbasic_runtime_evaluate(obj, fndef->expression, dest));
obj->environment = obj->environment->parent;
SUCCEED_RETURN(errctx);
}
/*
* A multi-line subroutine. Hand control to its environment and let the
* caller's step loop run it until RETURN pops back out. The result is the
* value RETURN parked in the child environment.
*/
obj->environment->gosubReturnLine = obj->environment->lineno + 1;
obj->environment->nextline = fndef->lineno;
while ( obj->environment != targetenv && obj->mode == AKBASIC_MODE_RUN ) {
PASS(errctx, akbasic_runtime_process_line_run(obj));
}
*dest = &fndef->environment->returnValue;
SUCCEED_RETURN(errctx);
}
/* ------------------------------------------------------------ line cycle -- */
int64_t akbasic_runtime_find_previous_lineno(akbasic_Runtime *obj)
{
int64_t i = 0;
for ( i = obj->environment->lineno - 1; i > 0; i-- ) {
if ( obj->source[i].code[0] != '\0' ) {
return i;
}
}
return obj->environment->lineno;
}
akerr_ErrorContext *akbasic_runtime_store_line(akbasic_Runtime *obj, int64_t lineno, const char *code)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (lineno >= 0 && lineno < AKBASIC_MAX_SOURCE_LINES),
AKBASIC_ERR_BOUNDS,
"Line number %" PRId64 " is outside 0..%d",
lineno, AKBASIC_MAX_SOURCE_LINES - 1);
FAIL_ZERO_RETURN(errctx, (strlen(code) < AKBASIC_MAX_LINE_LENGTH), AKBASIC_ERR_BOUNDS,
"Source line exceeds the %d character limit", AKBASIC_MAX_LINE_LENGTH - 1);
strncpy(obj->source[lineno].code, code, AKBASIC_MAX_LINE_LENGTH - 1);
obj->source[lineno].code[AKBASIC_MAX_LINE_LENGTH - 1] = '\0';
obj->source[lineno].lineno = lineno;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_process_line_runstream(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
char buffer[AKBASIC_MAX_LINE_LENGTH];
char scanned[AKBASIC_MAX_LINE_LENGTH];
bool eof = false;
PASS(errctx, obj->sink->readline(obj->sink, buffer, sizeof(buffer), &eof));
if ( eof ) {
obj->environment->nextline = 0;
PASS(errctx, akbasic_runtime_set_mode(obj, AKBASIC_MODE_RUN));
SUCCEED_RETURN(errctx);
}
/*
* All this mode does is pick the line number off the front and file the
* source line under it. DLOAD reaches this from REPL mode, where the line
* numbers must be stripped the same way the REPL strips them.
*/
PASS(errctx, akbasic_scanner_scan(obj, buffer, scanned, sizeof(scanned)));
if ( obj->mode == AKBASIC_MODE_REPL ) {
PASS(errctx, akbasic_runtime_store_line(obj, obj->environment->lineno, scanned));
} else {
PASS(errctx, akbasic_runtime_store_line(obj, obj->environment->lineno, buffer));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_process_line_repl(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
char prompt[32];
char scanned[AKBASIC_MAX_LINE_LENGTH];
akbasic_ASTLeaf *leaf = NULL;
akbasic_Value *value = NULL;
akbasic_Parser parser;
bool eof = false;
if ( obj->autoLineNumber > 0 ) {
snprintf(prompt, sizeof(prompt), "%" PRId64 " ",
obj->environment->lineno + obj->autoLineNumber);
PASS(errctx, akbasic_runtime_write(obj, prompt));
}
PASS(errctx, obj->sink->readline(obj->sink, obj->userline, sizeof(obj->userline), &eof));
if ( eof ) {
obj->inputEof = true;
PASS(errctx, akbasic_runtime_set_mode(obj, AKBASIC_MODE_QUIT));
SUCCEED_RETURN(errctx);
}
if ( obj->userline[0] == '\0' ) {
SUCCEED_RETURN(errctx);
}
obj->environment->lineno += obj->autoLineNumber;
PASS(errctx, akbasic_scanner_scan(obj, obj->userline, scanned, sizeof(scanned)));
PASS(errctx, akbasic_parser_init(&parser, obj));
while ( !akbasic_parser_is_at_end(&parser) ) {
ATTEMPT {
CATCH(errctx, akbasic_parser_parse(&parser, &leaf));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
char message[AKERR_MAX_ERROR_CONTEXT_STRING_LENGTH];
snprintf(message, sizeof(message), "%s", errctx->message);
IGNORE(akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE, message));
} FINISH(errctx, false);
if ( obj->errclass != AKBASIC_ERRCLASS_NONE ) {
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_interpret_immediate(obj, leaf, &value));
if ( value == NULL ) {
/* Not an immediate command, so it is program text: file it. */
PASS(errctx, akbasic_runtime_store_line(obj, obj->environment->lineno, scanned));
} else if ( obj->autoLineNumber > 0 ) {
obj->environment->lineno = akbasic_runtime_find_previous_lineno(obj);
}
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_process_line_run(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
char line[AKBASIC_MAX_LINE_LENGTH];
akbasic_ASTLeaf *leaf = NULL;
akbasic_Value *value = NULL;
akbasic_Parser parser;
if ( obj->environment->nextline >= AKBASIC_MAX_SOURCE_LINES ) {
PASS(errctx, akbasic_runtime_set_mode(obj, obj->run_finished_mode));
SUCCEED_RETURN(errctx);
}
strncpy(line, obj->source[obj->environment->nextline].code, sizeof(line) - 1);
line[sizeof(line) - 1] = '\0';
obj->environment->lineno = obj->environment->nextline;
obj->environment->nextline += 1;
if ( line[0] == '\0' ) {
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_scanner_scan(obj, line, NULL, 0));
PASS(errctx, akbasic_parser_init(&parser, obj));
while ( !akbasic_parser_is_at_end(&parser) ) {
ATTEMPT {
CATCH(errctx, akbasic_parser_parse(&parser, &leaf));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
char message[AKERR_MAX_ERROR_CONTEXT_STRING_LENGTH];
snprintf(message, sizeof(message), "%s", errctx->message);
IGNORE(akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE, message));
IGNORE(akbasic_runtime_set_mode(obj, obj->run_finished_mode));
} FINISH(errctx, false);
if ( obj->errclass != AKBASIC_ERRCLASS_NONE ) {
SUCCEED_RETURN(errctx);
}
/*
* The reference discards both results here. An error has already been
* reported to the sink by interpret(); swallowing the context keeps a
* BASIC-level error from tearing down the host, which is the whole point
* of goal 3.
*/
ATTEMPT {
CATCH(errctx, akbasic_runtime_interpret(obj, leaf, &value));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
} FINISH(errctx, false);
if ( obj->errclass != AKBASIC_ERRCLASS_NONE ) {
SUCCEED_RETURN(errctx);
}
}
SUCCEED_RETURN(errctx);
}
/* ------------------------------------------------------------- step loop -- */
akerr_ErrorContext *akbasic_runtime_start(akbasic_Runtime *obj, int mode)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in start");
obj->run_finished_mode = (mode == AKBASIC_MODE_REPL ? AKBASIC_MODE_REPL : AKBASIC_MODE_QUIT);
PASS(errctx, akbasic_runtime_set_mode(obj, mode));
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_step(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in step");
if ( obj->mode == AKBASIC_MODE_QUIT ) {
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_zero(obj));
PASS(errctx, akbasic_scanner_zero(obj));
switch ( obj->mode ) {
case AKBASIC_MODE_RUNSTREAM:
PASS(errctx, akbasic_runtime_process_line_runstream(obj));
break;
case AKBASIC_MODE_REPL:
PASS(errctx, akbasic_runtime_process_line_repl(obj));
break;
case AKBASIC_MODE_RUN:
PASS(errctx, akbasic_runtime_process_line_run(obj));
break;
default:
break;
}
/*
* The reference never clears runtime.errno, so the first BASIC-level error
* ends the program: in a file run, run_finished_mode is QUIT. Reproduced
* deliberately -- tests/language/array_outofbounds.txt depends on exactly one
* error line being printed and nothing after it.
*/
if ( obj->errclass != AKBASIC_ERRCLASS_NONE ) {
PASS(errctx, akbasic_runtime_set_mode(obj, obj->run_finished_mode));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_runtime_run(akbasic_Runtime *obj, int maxsteps)
{
PREPARE_ERROR(errctx);
int steps = 0;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in run");
while ( obj->mode != AKBASIC_MODE_QUIT ) {
PASS(errctx, akbasic_runtime_step(obj));
steps += 1;
if ( maxsteps > 0 && steps >= maxsteps ) {
break;
}
}
SUCCEED_RETURN(errctx);
}

789
src/runtime_commands.c Normal file
View File

@@ -0,0 +1,789 @@
/**
* @file runtime_commands.c
* @brief The verb implementations.
*
* Ported from basicruntime_commands.go. Every handler has the signature the
* dispatch table demands, and every one returns its result through `dest`.
*/
#include <inttypes.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <akerror.h>
#include <akstdlib.h>
#include <akbasic/error.h>
#include <akbasic/runtime.h>
#include <akbasic/convert.h>
#include <akbasic/scanner.h>
#include "verbs.h"
/* Most verbs answer "did something happen"; this is that answer. */
#define SUCCEED_TRUE(__obj, __dest) \
do { \
*(__dest) = &(__obj)->staticTrueValue; \
} while ( 0 )
akerr_ErrorContext *akbasic_cmd_let(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
/*
* LET is not required in this dialect or in Commodore BASIC 7.0. Assignment
* is part of expression evaluation, so there is nothing for LET to do.
*/
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_def(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
/* The parse handler already installed the function. */
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_print(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
char rendered[AKBASIC_MAX_STRING_LENGTH];
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL), AKERR_NULLPOINTER, "NIL leaf");
if ( expr->right == NULL ) {
PASS(errctx, akbasic_runtime_println(obj, ""));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, dest));
PASS(errctx, akbasic_value_to_string(*dest, rendered, sizeof(rendered)));
PASS(errctx, akbasic_runtime_println(obj, rendered));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_goto(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *target = NULL;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKERR_NULLPOINTER,
"Expected GOTO (line number or label)");
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &target));
FAIL_NONZERO_RETURN(errctx, (target->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected integer");
obj->environment->nextline = target->intval;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_gosub(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *target = NULL;
int64_t returnline = 0;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKERR_NULLPOINTER,
"Expected GOSUB (line number or label)");
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &target));
FAIL_NONZERO_RETURN(errctx, (target->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected integer");
returnline = obj->environment->lineno + 1;
PASS(errctx, akbasic_runtime_new_environment(obj));
obj->environment->gosubReturnLine = returnline;
obj->environment->nextline = target->intval;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_return(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *result = NULL;
(void)lval; (void)rval;
/*
* A RETURN reached while skipping forward to one is the end of a DEF body,
* not a subroutine return. Stop waiting and carry on.
*/
if ( akbasic_environment_is_waiting_for(obj->environment, "RETURN") ) {
PASS(errctx, akbasic_environment_stop_waiting(obj->environment, "RETURN"));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
FAIL_ZERO_RETURN(errctx, (obj->environment->gosubReturnLine != 0), AKBASIC_ERR_STATE,
"RETURN outside the context of GOSUB");
if ( expr != NULL && expr->right != NULL ) {
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &result));
} else {
result = &obj->staticTrueValue;
}
FAIL_ZERO_RETURN(errctx, (obj->environment->parent != NULL), AKBASIC_ERR_ENVIRONMENT,
"RETURN from an orphaned environment");
obj->environment->parent->nextline = obj->environment->gosubReturnLine;
PASS(errctx, akbasic_value_clone(result, &obj->environment->returnValue));
PASS(errctx, akbasic_runtime_prev_environment(obj));
*dest = result;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_stop(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
PASS(errctx, akbasic_runtime_set_mode(obj, AKBASIC_MODE_REPL));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_quit(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
/*
* Sets a mode and returns. Nothing in this library calls exit() -- the
* driver's main() decides what quitting means, and an embedding game may
* decide it means something else entirely.
*/
PASS(errctx, akbasic_runtime_set_mode(obj, AKBASIC_MODE_QUIT));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_run(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *target = NULL;
(void)lval; (void)rval;
obj->environment->nextline = 0;
if ( expr != NULL && expr->right != NULL ) {
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &target));
FAIL_NONZERO_RETURN(errctx, (target->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected RUN (line number)");
obj->environment->nextline = target->intval;
}
PASS(errctx, akbasic_runtime_set_mode(obj, AKBASIC_MODE_RUN));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_label(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKERR_NULLPOINTER,
"Expected LABEL IDENTIFIER");
FAIL_ZERO_RETURN(errctx, akbasic_leaf_is_identifier(expr->right), AKBASIC_ERR_SYNTAX,
"Expected identifier");
PASS(errctx, akbasic_environment_set_label(obj->environment, expr->right->identifier,
obj->environment->lineno));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_auto(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *step = NULL;
(void)lval; (void)rval;
if ( expr == NULL || expr->right == NULL ) {
obj->autoLineNumber = 0;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &step));
FAIL_NONZERO_RETURN(errctx, (step->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected AUTO (integer)");
obj->autoLineNumber = step->intval;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_dim(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Variable *variable = NULL;
akbasic_ASTLeaf *walk = NULL;
akbasic_Value *size = NULL;
int64_t sizes[AKBASIC_MAX_ARRAY_DEPTH];
int sizecount = 0;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx,
(expr != NULL && expr->right != NULL && expr->right->right != NULL &&
expr->right->right->leaftype == AKBASIC_LEAF_ARGUMENTLIST &&
expr->right->right->operator_ == AKBASIC_TOK_ARRAY_SUBSCRIPT &&
akbasic_leaf_is_identifier(expr->right)),
AKBASIC_ERR_SYNTAX, "Expected DIM IDENTIFIER(DIMENSIONS, ...)");
PASS(errctx, akbasic_environment_get(obj->environment, expr->right->identifier, &variable));
FAIL_ZERO_RETURN(errctx, (variable != NULL), AKBASIC_ERR_UNDEFINED,
"Unable to get variable for identifier %s", expr->right->identifier);
for ( walk = expr->right->right->right; walk != NULL; walk = walk->right ) {
FAIL_ZERO_RETURN(errctx, (sizecount < AKBASIC_MAX_ARRAY_DEPTH), AKBASIC_ERR_BOUNDS,
"More than %d array dimensions", AKBASIC_MAX_ARRAY_DEPTH);
PASS(errctx, akbasic_runtime_evaluate(obj, walk, &size));
FAIL_NONZERO_RETURN(errctx, (size->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Array dimensions must evaluate to integer");
sizes[sizecount] = size->intval;
sizecount += 1;
}
PASS(errctx, akbasic_variable_init(variable, &obj->valuepool, sizes, sizecount));
PASS(errctx, akbasic_variable_zero(variable));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
/*
* POKE and PEEK write and read a single byte at a caller-supplied address.
*
* The pointer.bas golden case sets A# = 255 and expects PEEK(POINTER(A#)) to be
* 255, which holds only on a little-endian machine: A# is an int64_t and the
* low byte has to come first. Stated here rather than discovered later.
*/
akerr_ErrorContext *akbasic_cmd_poke(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *arg = NULL;
akbasic_Value *addrval = NULL;
akbasic_Value *byteval = NULL;
uint8_t *target = NULL;
(void)lval; (void)rval;
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, "POKE expected INTEGER, INTEGER");
/* The address must be the live value, not a copy of it. */
obj->eval_clone_identifiers = false;
ATTEMPT {
CATCH(errctx, akbasic_runtime_evaluate(obj, arg, &addrval));
} CLEANUP {
obj->eval_clone_identifiers = true;
} PROCESS(errctx) {
} FINISH(errctx, true);
FAIL_NONZERO_RETURN(errctx, (addrval->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"POKE expected INTEGER, INTEGER");
FAIL_ZERO_RETURN(errctx,
(arg->right != NULL &&
(arg->right->leaftype == AKBASIC_LEAF_LITERAL_INT ||
arg->right->leaftype == AKBASIC_LEAF_IDENTIFIER_INT)),
AKBASIC_ERR_SYNTAX, "POKE expected INTEGER, INTEGER");
FAIL_ZERO_RETURN(errctx, (addrval->intval != 0), AKBASIC_ERR_VALUE,
"POKE got NIL pointer or uninitialized variable");
PASS(errctx, akbasic_runtime_evaluate(obj, arg->right, &byteval));
target = (uint8_t *)(uintptr_t)addrval->intval;
*target = (uint8_t)byteval->intval;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_input(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_ASTLeaf *identifier = NULL;
akbasic_Value *prompt = NULL;
akbasic_Value *entered = NULL;
akbasic_Value *unused = NULL;
char rendered[AKBASIC_MAX_STRING_LENGTH];
char buffer[AKBASIC_MAX_LINE_LENGTH];
bool eof = false;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKERR_NULLPOINTER,
"Expected INPUT \"PROMPT\" IDENTIFIER");
identifier = expr->right;
if ( identifier->left != NULL ) {
PASS(errctx, akbasic_runtime_evaluate(obj, identifier->left, &prompt));
PASS(errctx, akbasic_value_to_string(prompt, rendered, sizeof(rendered)));
PASS(errctx, akbasic_runtime_write(obj, rendered));
}
PASS(errctx, obj->sink->readline(obj->sink, buffer, sizeof(buffer), &eof));
if ( eof ) {
obj->inputEof = true;
buffer[0] = '\0';
}
PASS(errctx, akbasic_environment_new_value(obj->environment, &entered));
PASS(errctx, akbasic_value_zero(entered));
switch ( identifier->leaftype ) {
case AKBASIC_LEAF_IDENTIFIER_INT:
entered->valuetype = AKBASIC_TYPE_INTEGER;
PASS(errctx, akbasic_str_to_int64(buffer, 10, &entered->intval));
break;
case AKBASIC_LEAF_IDENTIFIER_FLOAT:
entered->valuetype = AKBASIC_TYPE_FLOAT;
PASS(errctx, akbasic_str_to_double(buffer, &entered->floatval));
break;
default:
entered->valuetype = AKBASIC_TYPE_STRING;
FAIL_ZERO_RETURN(errctx, (strlen(buffer) < AKBASIC_MAX_STRING_LENGTH), AKBASIC_ERR_VALUE,
"Input line exceeds the %d character limit", AKBASIC_MAX_STRING_LENGTH - 1);
strncpy(entered->stringval, buffer, AKBASIC_MAX_STRING_LENGTH - 1);
entered->stringval[AKBASIC_MAX_STRING_LENGTH - 1] = '\0';
break;
}
PASS(errctx, akbasic_environment_assign(obj->environment, identifier, entered, &unused));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
/* LIST and DELETE share the range grammar: bare, n, -n, or n-n. */
static akerr_ErrorContext *parse_line_range(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, int64_t *startidx, int64_t *endidx)
{
PREPARE_ERROR(errctx);
akbasic_Value *value = NULL;
*startidx = 0;
*endidx = AKBASIC_MAX_SOURCE_LINES - 1;
if ( expr == NULL || expr->right == NULL ) {
SUCCEED_RETURN(errctx);
}
if ( expr->right->leaftype == AKBASIC_LEAF_BINARY &&
expr->right->operator_ == AKBASIC_TOK_MINUS ) {
/* n-n: a subtraction leaf is how the expression parser sees a range. */
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right->left, &value));
FAIL_NONZERO_RETURN(errctx, (value->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected a line number range");
*startidx = value->intval;
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right->right, &value));
FAIL_NONZERO_RETURN(errctx, (value->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected a line number range");
*endidx = value->intval;
SUCCEED_RETURN(errctx);
}
if ( expr->right->leaftype == AKBASIC_LEAF_UNARY &&
expr->right->operator_ == AKBASIC_TOK_MINUS ) {
/* -n: from the start through n. */
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right->right, &value));
FAIL_NONZERO_RETURN(errctx, (value->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected a line number range");
*endidx = value->intval;
SUCCEED_RETURN(errctx);
}
/* n: from n to the end. */
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &value));
FAIL_NONZERO_RETURN(errctx, (value->valuetype != AKBASIC_TYPE_INTEGER), AKBASIC_ERR_TYPE,
"Expected a line number range");
*startidx = value->intval;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_list(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
char line[AKBASIC_MAX_LINE_LENGTH * 2];
int64_t startidx = 0;
int64_t endidx = 0;
int64_t i = 0;
(void)lval; (void)rval;
PASS(errctx, parse_line_range(obj, expr, &startidx, &endidx));
if ( startidx < 0 ) {
startidx = 0;
}
if ( endidx >= AKBASIC_MAX_SOURCE_LINES ) {
endidx = AKBASIC_MAX_SOURCE_LINES - 1;
}
for ( i = startidx; i <= endidx; i++ ) {
if ( obj->source[i].code[0] == '\0' ) {
continue;
}
snprintf(line, sizeof(line), "%" PRId64 " %s", i, obj->source[i].code);
PASS(errctx, akbasic_runtime_println(obj, line));
}
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_delete(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
int64_t startidx = 0;
int64_t endidx = 0;
int64_t i = 0;
(void)lval; (void)rval;
PASS(errctx, parse_line_range(obj, expr, &startidx, &endidx));
if ( startidx < 0 ) {
startidx = 0;
}
if ( endidx >= AKBASIC_MAX_SOURCE_LINES ) {
endidx = AKBASIC_MAX_SOURCE_LINES - 1;
}
for ( i = startidx; i <= endidx; i++ ) {
obj->source[i].code[0] = '\0';
obj->source[i].lineno = 0;
}
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
/* Resolve a DLOAD/DSAVE filename argument to a string. */
static akerr_ErrorContext *filename_argument(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, char *dest, size_t len)
{
PREPARE_ERROR(errctx);
akbasic_Value *value = NULL;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKBASIC_ERR_SYNTAX,
"Expected a filename");
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &value));
FAIL_NONZERO_RETURN(errctx, (value->valuetype != AKBASIC_TYPE_STRING), AKBASIC_ERR_TYPE,
"Expected a filename string");
FAIL_ZERO_RETURN(errctx, (value->stringval[0] != '\0'), AKBASIC_ERR_VALUE,
"Filename must not be empty");
FAIL_ZERO_RETURN(errctx, (strlen(value->stringval) < len), AKBASIC_ERR_BOUNDS,
"Filename exceeds the %zu character limit", len - 1);
strncpy(dest, value->stringval, len - 1);
dest[len - 1] = '\0';
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_dload(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
char filename[AKBASIC_MAX_STRING_LENGTH];
char buffer[AKBASIC_MAX_LINE_LENGTH];
char scanned[AKBASIC_MAX_LINE_LENGTH];
FILE *fp = NULL;
size_t used = 0;
int64_t i = 0;
(void)lval; (void)rval;
/*
* aksl_fopen does not NULL-check pathname or mode and fopen(NULL, ...) is
* undefined, so the name is validated here before it is handed over --
* deps/libakstdlib/TODO.md 2.2.2.
*/
PASS(errctx, filename_argument(obj, expr, filename, sizeof(filename)));
/* DLOAD replaces the program in memory, so clear it before reading. */
for ( i = 0; i < AKBASIC_MAX_SOURCE_LINES; i++ ) {
obj->source[i].code[0] = '\0';
obj->source[i].lineno = 0;
}
obj->environment->lineno = 0;
obj->environment->nextline = 0;
ATTEMPT {
CATCH(errctx, aksl_fopen(filename, "r", &fp));
while ( fgets(buffer, sizeof(buffer), fp) != NULL ) {
used = strlen(buffer);
while ( used > 0 && (buffer[used - 1] == '\n' || buffer[used - 1] == '\r') ) {
buffer[used - 1] = '\0';
used -= 1;
}
if ( buffer[0] == '\0' ) {
continue;
}
/*
* PASS inside the loop, never CATCH: CATCH expands to a break, which
* would leave this loop rather than the ATTEMPT and let the rest of
* the block run with an error pending.
*/
PASS(errctx, akbasic_scanner_scan(obj, buffer, scanned, sizeof(scanned)));
PASS(errctx, akbasic_runtime_store_line(obj, obj->environment->lineno, scanned));
}
} CLEANUP {
if ( fp != NULL ) {
IGNORE(aksl_fclose(fp));
}
} PROCESS(errctx) {
} FINISH(errctx, true);
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_dsave(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
char filename[AKBASIC_MAX_STRING_LENGTH];
char line[AKBASIC_MAX_LINE_LENGTH * 2];
FILE *fp = NULL;
int64_t i = 0;
int count = 0;
(void)lval; (void)rval;
PASS(errctx, filename_argument(obj, expr, filename, sizeof(filename)));
ATTEMPT {
CATCH(errctx, aksl_fopen(filename, "w", &fp));
for ( i = 0; i < AKBASIC_MAX_SOURCE_LINES; i++ ) {
if ( obj->source[i].code[0] == '\0' ) {
continue;
}
snprintf(line, sizeof(line), "%" PRId64 " %s\n", i, obj->source[i].code);
PASS(errctx, aksl_fwrite(line, 1, strlen(line), fp));
count += 1;
}
} CLEANUP {
if ( fp != NULL ) {
IGNORE(aksl_fclose(fp));
}
} PROCESS(errctx) {
} FINISH(errctx, true);
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_if(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)obj; (void)expr; (void)lval; (void)rval; (void)dest;
/*
* Unreachable in practice: the IF parse handler produces a BRANCH leaf, and
* evaluate() handles BRANCH directly. It exists so the table has an exec
* handler for IF and a stray IF leaf produces a diagnosis rather than
* "Unknown command".
*/
FAIL_RETURN(errctx, AKBASIC_ERR_STATE, "Malformed IF statement");
}
/*
* The loop condition, evaluated at the bottom of the structure. A negative step
* means the loop runs while the counter is at or above the TO value; a positive
* one, at or below. True means the loop is finished.
*/
static akerr_ErrorContext *evaluate_for_condition(akbasic_Runtime *obj, akbasic_Value *counter, bool *met)
{
PREPARE_ERROR(errctx);
akbasic_Value zero;
akbasic_Value scratch;
akbasic_Value *truth = NULL;
FAIL_ZERO_RETURN(errctx, (counter != NULL), AKERR_NULLPOINTER, "NIL pointer for rval");
PASS(errctx, akbasic_value_zero(&zero));
zero.valuetype = AKBASIC_TYPE_INTEGER;
zero.intval = 0;
PASS(errctx, akbasic_value_less_than(&obj->environment->forStepValue, &zero, &scratch, &truth));
if ( akbasic_value_is_true(truth) ) {
PASS(errctx, akbasic_value_greater_than_equal(&obj->environment->forToValue, counter,
&scratch, &truth));
} else {
PASS(errctx, akbasic_value_less_than_equal(&obj->environment->forToValue, counter,
&scratch, &truth));
}
*met = akbasic_value_is_true(truth);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_for(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *assignval = NULL;
akbasic_Value *tmp = NULL;
akbasic_Value *counter = NULL;
int64_t zerosubscript[1] = { 0 };
bool met = false;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (obj->environment->forToLeaf != NULL && expr != NULL && expr->right != NULL),
AKBASIC_ERR_STATE, "Expected FOR ... TO [STEP ...]");
FAIL_ZERO_RETURN(errctx,
(expr->right->left != NULL &&
(expr->right->left->leaftype == AKBASIC_LEAF_IDENTIFIER_INT ||
expr->right->left->leaftype == AKBASIC_LEAF_IDENTIFIER_FLOAT ||
expr->right->left->leaftype == AKBASIC_LEAF_IDENTIFIER_STRING)),
AKBASIC_ERR_SYNTAX, "Expected variable in FOR loop");
PASS(errctx, akbasic_runtime_evaluate(obj, expr->right, &assignval));
PASS(errctx, akbasic_environment_get(obj->environment, expr->right->left->identifier,
&obj->environment->forNextVariable));
FAIL_ZERO_RETURN(errctx, (obj->environment->forNextVariable != NULL), AKBASIC_ERR_UNDEFINED,
"Unable to get loop variable %s", expr->right->left->identifier);
PASS(errctx, akbasic_variable_set_subscript(obj->environment->forNextVariable, assignval,
zerosubscript, 1));
PASS(errctx, akbasic_runtime_evaluate(obj, obj->environment->forToLeaf, &tmp));
PASS(errctx, akbasic_value_clone(tmp, &obj->environment->forToValue));
PASS(errctx, akbasic_runtime_evaluate(obj, obj->environment->forStepLeaf, &tmp));
PASS(errctx, akbasic_value_clone(tmp, &obj->environment->forStepValue));
obj->environment->forToLeaf = NULL;
obj->environment->forStepLeaf = NULL;
PASS(errctx, akbasic_variable_get_subscript(obj->environment->forNextVariable,
zerosubscript, 1, &counter));
PASS(errctx, evaluate_for_condition(obj, counter, &met));
if ( met ) {
/* Zero iterations: skip the body entirely by waiting for the NEXT. */
PASS(errctx, akbasic_environment_wait_for_command(obj->environment, "NEXT"));
}
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_next(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Variable *nextvar = NULL;
akbasic_Value *counter = NULL;
akbasic_Value *updated = NULL;
akbasic_Value scratch;
int64_t zerosubscript[1] = { 0 };
bool met = false;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (obj->environment->forNextVariable != NULL), AKBASIC_ERR_STATE,
"NEXT outside the context of FOR");
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKBASIC_ERR_SYNTAX,
"Expected NEXT IDENTIFIER");
FAIL_ZERO_RETURN(errctx,
(expr->right->leaftype == AKBASIC_LEAF_IDENTIFIER_INT ||
expr->right->leaftype == AKBASIC_LEAF_IDENTIFIER_FLOAT),
AKBASIC_ERR_TYPE, "FOR ... NEXT only valid over INT and FLOAT types");
obj->environment->loopExitLine = obj->environment->lineno + 1;
/*
* A NEXT for someone else's loop variable: this environment is done, hand
* the line back to the parent and pop. That is how nested loops unwind.
*/
if ( strcmp(expr->right->identifier, obj->environment->forNextVariable->name) != 0 ) {
FAIL_ZERO_RETURN(errctx, (obj->environment->parent != NULL), AKBASIC_ERR_ENVIRONMENT,
"NEXT in an orphaned environment");
obj->environment->parent->nextline = obj->environment->nextline;
PASS(errctx, akbasic_runtime_prev_environment(obj));
*dest = &obj->staticFalseValue;
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_environment_get(obj->environment, expr->right->identifier, &nextvar));
FAIL_ZERO_RETURN(errctx, (nextvar != NULL), AKBASIC_ERR_UNDEFINED,
"Unable to get loop variable %s", expr->right->identifier);
PASS(errctx, akbasic_variable_get_subscript(nextvar, zerosubscript, 1, &counter));
PASS(errctx, evaluate_for_condition(obj, counter, &met));
PASS(errctx, akbasic_environment_stop_waiting(obj->environment, "NEXT"));
if ( met ) {
if ( obj->environment->parent != NULL ) {
obj->environment->parent->nextline = obj->environment->nextline;
PASS(errctx, akbasic_runtime_prev_environment(obj));
}
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
/*
* Advance the counter. The stored value is mutable, so math_plus updates it
* in place -- see TODO.md section 12 item 4. Changing that without changing
* this breaks every FOR loop.
*/
PASS(errctx, akbasic_value_math_plus(counter, &obj->environment->forStepValue,
&scratch, &updated));
obj->environment->nextline = obj->environment->loopFirstLine;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_exit(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
FAIL_NONZERO_RETURN(errctx,
(obj->environment->forToValue.valuetype == AKBASIC_TYPE_UNDEFINED),
AKBASIC_ERR_STATE, "EXIT outside the context of FOR");
FAIL_ZERO_RETURN(errctx, (obj->environment->parent != NULL), AKBASIC_ERR_ENVIRONMENT,
"EXIT in an orphaned environment");
obj->environment->parent->nextline = obj->environment->loopExitLine;
/*
* The reference pops without clearing the wait, which leaves the parent
* waiting for a NEXT that will never arrive (TODO.md section 12 item 8). The
* wait is cleared here first: leaving it set would hang the interpreter
* rather than merely misbehave, and no golden case depends on the hang.
*/
PASS(errctx, akbasic_environment_stop_waiting(obj->environment, "NEXT"));
PASS(errctx, akbasic_runtime_prev_environment(obj));
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_read(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
(void)expr; (void)lval; (void)rval;
/*
* READ does not read: it declares that the next DATA line should fill these
* identifiers, and skips forward until one appears.
*/
PASS(errctx, akbasic_environment_wait_for_command(obj->environment, "DATA"));
obj->environment->readIdentifierIdx = 0;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_cmd_data(akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Environment *env = obj->environment;
akbasic_ASTLeaf *literal = NULL;
akbasic_ASTLeaf *identifier = NULL;
akbasic_ASTLeaf assign;
akbasic_Value *unused = NULL;
(void)lval; (void)rval;
FAIL_ZERO_RETURN(errctx, (expr != NULL && expr->right != NULL), AKERR_NULLPOINTER,
"NIL expression or argument list");
for ( literal = expr->right->right; literal != NULL; literal = literal->right ) {
if ( env->readIdentifierIdx >= AKBASIC_MAX_LEAVES ) {
break;
}
identifier = env->readIdentifierLeaves[env->readIdentifierIdx];
if ( identifier == NULL ) {
break;
}
/*
* Build the assignment by hand rather than through the parser: the
* identifier leaf is a stored copy and the literal belongs to this
* line's pool, so there is no source text to re-parse.
*/
PASS(errctx, akbasic_leaf_init(&assign, AKBASIC_LEAF_BINARY));
assign.left = identifier;
assign.right = literal;
assign.operator_ = AKBASIC_TOK_ASSIGNMENT;
PASS(errctx, akbasic_runtime_evaluate(obj, &assign, &unused));
env->readIdentifierIdx += 1;
}
if ( literal == NULL &&
env->readIdentifierIdx < AKBASIC_MAX_LEAVES &&
env->readIdentifierLeaves[env->readIdentifierIdx] != NULL ) {
/* Out of DATA with READ items outstanding: stay in waiting mode. */
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}
PASS(errctx, akbasic_environment_stop_waiting(env, "DATA"));
env->lineno = env->readReturnLine;
env->readIdentifierIdx = 0;
SUCCEED_TRUE(obj, dest);
SUCCEED_RETURN(errctx);
}

644
src/runtime_functions.c Normal file
View File

@@ -0,0 +1,644 @@
/**
* @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);
}

376
src/scanner.c Normal file
View File

@@ -0,0 +1,376 @@
/**
* @file scanner.c
* @brief Implements the line tokenizer.
*/
#include <ctype.h>
#include <inttypes.h>
#include <stdio.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/convert.h>
#include <akbasic/error.h>
#include <akbasic/scanner.h>
#include <akbasic/verbs.h>
akerr_ErrorContext *akbasic_scanner_zero(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in scanner zero");
obj->current = 0;
obj->start = 0;
obj->hasError = false;
SUCCEED_RETURN(errctx);
}
static bool is_at_end(akbasic_Runtime *obj)
{
return (obj->current >= (int)strlen(obj->line));
}
static bool peek(akbasic_Runtime *obj, char *dest)
{
if ( is_at_end(obj) ) {
return false;
}
*dest = obj->line[obj->current];
return true;
}
static bool peek_next(akbasic_Runtime *obj, char *dest)
{
if ( (obj->current + 1) >= (int)strlen(obj->line) ) {
return false;
}
*dest = obj->line[obj->current + 1];
return true;
}
/*
* The lexeme is the span [start, current), with two special cases the reference
* relies on: at end of line it runs to the end, and a zero-width span yields the
* single character at `start` -- unless we are closing a string literal, where
* an empty span really is the empty string.
*/
static akerr_ErrorContext *get_lexeme(akbasic_Runtime *obj, char *dest, size_t len)
{
PREPARE_ERROR(errctx);
int linelen = (int)strlen(obj->line);
int span = 0;
if ( obj->current == linelen ) {
span = linelen - obj->start;
} else if ( obj->start == obj->current ) {
if ( obj->tokentype == AKBASIC_TOK_LITERAL_STRING ) {
dest[0] = '\0';
SUCCEED_RETURN(errctx);
}
span = 1;
} else {
span = obj->current - obj->start;
}
FAIL_ZERO_RETURN(errctx, (span >= 0 && (size_t)span < len), AKBASIC_ERR_BOUNDS,
"Lexeme of %d characters exceeds the %zu character limit", span, len - 1);
memcpy(dest, obj->line + obj->start, (size_t)span);
dest[span] = '\0';
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *add_token(akbasic_Runtime *obj, akbasic_TokenType token, const char *lexeme)
{
PREPARE_ERROR(errctx);
akbasic_Environment *env = obj->environment;
FAIL_ZERO_RETURN(errctx, (env->nexttoken < AKBASIC_MAX_TOKENS), AKBASIC_ERR_BOUNDS,
"Line %" PRId64 " has more than %d tokens",
env->lineno, AKBASIC_MAX_TOKENS);
FAIL_ZERO_RETURN(errctx, (strlen(lexeme) < AKBASIC_MAX_LINE_LENGTH), AKBASIC_ERR_BOUNDS,
"Token lexeme exceeds the %d character limit", AKBASIC_MAX_LINE_LENGTH - 1);
env->tokens[env->nexttoken].tokentype = token;
env->tokens[env->nexttoken].lineno = env->lineno;
strncpy(env->tokens[env->nexttoken].lexeme, lexeme, AKBASIC_MAX_LINE_LENGTH - 1);
env->tokens[env->nexttoken].lexeme[AKBASIC_MAX_LINE_LENGTH - 1] = '\0';
env->nexttoken += 1;
SUCCEED_RETURN(errctx);
}
/* Consume one more character when it matches, choosing between two token types. */
static bool match_next_char(akbasic_Runtime *obj, char cm, akbasic_TokenType truetype, akbasic_TokenType falsetype)
{
char nc = '\0';
if ( !peek(obj, &nc) ) {
return false;
}
if ( nc == cm ) {
obj->current += 1;
obj->tokentype = truetype;
return true;
}
obj->tokentype = falsetype;
return false;
}
static akerr_ErrorContext *match_string(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
char c = '\0';
while ( !is_at_end(obj) ) {
if ( !peek(obj, &c) ) {
PASS(errctx, akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE,
"UNTERMINATED STRING LITERAL\n"));
obj->hasError = true;
SUCCEED_RETURN(errctx);
}
if ( c == '"' ) {
break;
}
obj->current += 1;
}
obj->tokentype = AKBASIC_TOK_LITERAL_STRING;
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *match_number(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
bool linenumber = (obj->environment->nexttoken == 0);
char lexeme[AKBASIC_MAX_LINE_LENGTH];
char c = '\0';
char nc = '\0';
int64_t lineno = 0;
obj->tokentype = AKBASIC_TOK_LITERAL_INT;
while ( !is_at_end(obj) ) {
(void)peek(obj, &c);
if ( c == '.' ) {
if ( !peek_next(obj, &nc) || !isdigit((unsigned char)nc) ) {
PASS(errctx, akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE,
"INVALID FLOATING POINT LITERAL\n"));
obj->hasError = true;
SUCCEED_RETURN(errctx);
}
obj->tokentype = AKBASIC_TOK_LITERAL_FLOAT;
} else if ( !isdigit((unsigned char)c) && c != 'x' ) {
/* 'x' is allowed through so 0x-prefixed hex reaches the parser. */
break;
}
obj->current += 1;
}
if ( obj->tokentype == AKBASIC_TOK_LITERAL_INT && linenumber ) {
PASS(errctx, get_lexeme(obj, lexeme, sizeof(lexeme)));
ATTEMPT {
CATCH(errctx, akbasic_str_to_int64(lexeme, 10, &lineno));
} CLEANUP {
} PROCESS(errctx) {
} HANDLE_DEFAULT(errctx) {
char message[AKBASIC_MAX_LINE_LENGTH + 32];
snprintf(message, sizeof(message), "INTEGER CONVERSION ON '%s'", lexeme);
/*
* Reporting can itself fail if the sink is broken. Nothing useful
* remains to be done about that here, so record the flag and let the
* next operation surface it.
*/
IGNORE(akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE, message));
obj->hasError = true;
} FINISH(errctx, false);
if ( obj->hasError ) {
SUCCEED_RETURN(errctx);
}
obj->environment->lineno = lineno;
obj->tokentype = AKBASIC_TOK_LINE_NUMBER;
}
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *match_identifier(akbasic_Runtime *obj)
{
PREPARE_ERROR(errctx);
char lexeme[AKBASIC_MAX_LINE_LENGTH];
const akbasic_Verb *verb = NULL;
void *fndef = NULL;
bool userfunction = false;
char c = '\0';
obj->tokentype = AKBASIC_TOK_IDENTIFIER;
while ( !is_at_end(obj) ) {
(void)peek(obj, &c);
if ( isdigit((unsigned char)c) || isalpha((unsigned char)c) ) {
obj->current += 1;
continue;
}
switch ( c ) {
case '@':
obj->tokentype = AKBASIC_TOK_IDENTIFIER_STRUCT;
obj->current += 1;
break;
case '$':
obj->tokentype = AKBASIC_TOK_IDENTIFIER_STRING;
obj->current += 1;
break;
case '%':
obj->tokentype = AKBASIC_TOK_IDENTIFIER_FLOAT;
obj->current += 1;
break;
case '#':
obj->tokentype = AKBASIC_TOK_IDENTIFIER_INT;
obj->current += 1;
break;
default:
break;
}
break;
}
PASS(errctx, get_lexeme(obj, lexeme, sizeof(lexeme)));
PASS(errctx, akbasic_verb_lookup(lexeme, &verb));
ATTEMPT {
CATCH(errctx, akbasic_environment_get_function(obj->environment, lexeme, &fndef));
userfunction = true;
} CLEANUP {
} PROCESS(errctx) {
} HANDLE(errctx, AKERR_KEY) {
userfunction = false;
} FINISH(errctx, true);
if ( obj->tokentype == AKBASIC_TOK_IDENTIFIER ) {
if ( verb != NULL ) {
obj->tokentype = verb->tokentype;
} else if ( userfunction ) {
obj->tokentype = AKBASIC_TOK_FUNCTION;
}
} else if ( verb != NULL ) {
/*
* A suffixed identifier that collides with a verb or function name.
* PRINT$ is not a variable.
*/
PASS(errctx, akbasic_runtime_error(obj, AKBASIC_ERRCLASS_SYNTAX,
"Reserved word in variable name\n"));
obj->hasError = true;
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_scanner_scan(akbasic_Runtime *obj, const char *line, char *dest, size_t len)
{
PREPARE_ERROR(errctx);
char lexeme[AKBASIC_MAX_LINE_LENGTH];
char c = '\0';
bool done = false;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL runtime in scan");
FAIL_ZERO_RETURN(errctx, (line != NULL), AKERR_NULLPOINTER, "NULL line in scan");
FAIL_ZERO_RETURN(errctx, (strlen(line) < AKBASIC_MAX_LINE_LENGTH), AKBASIC_ERR_BOUNDS,
"Source line of %zu characters exceeds the %d character limit",
strlen(line), AKBASIC_MAX_LINE_LENGTH - 1);
strncpy(obj->line, line, AKBASIC_MAX_LINE_LENGTH - 1);
obj->line[AKBASIC_MAX_LINE_LENGTH - 1] = '\0';
PASS(errctx, akbasic_environment_zero_parser(obj->environment));
obj->current = 0;
obj->start = 0;
obj->hasError = false;
while ( !is_at_end(obj) && !done ) {
c = obj->line[obj->current];
obj->current += 1;
switch ( c ) {
case '@': obj->tokentype = AKBASIC_TOK_ATSYMBOL; break;
case '^': obj->tokentype = AKBASIC_TOK_CARAT; break;
case '(': obj->tokentype = AKBASIC_TOK_LEFT_PAREN; break;
case ')': obj->tokentype = AKBASIC_TOK_RIGHT_PAREN; break;
case '+': obj->tokentype = AKBASIC_TOK_PLUS; break;
case '-': obj->tokentype = AKBASIC_TOK_MINUS; break;
case '/': obj->tokentype = AKBASIC_TOK_LEFT_SLASH; break;
case '*': obj->tokentype = AKBASIC_TOK_STAR; break;
case ',': obj->tokentype = AKBASIC_TOK_COMMA; break;
case ':': obj->tokentype = AKBASIC_TOK_COLON; break;
case '[': obj->tokentype = AKBASIC_TOK_LEFT_SQUAREBRACKET; break;
case ']': obj->tokentype = AKBASIC_TOK_RIGHT_SQUAREBRACKET; break;
case '=':
(void)match_next_char(obj, '=', AKBASIC_TOK_EQUAL, AKBASIC_TOK_ASSIGNMENT);
break;
case '<':
if ( !match_next_char(obj, '=', AKBASIC_TOK_LESS_THAN_EQUAL, AKBASIC_TOK_LESS_THAN) ) {
(void)match_next_char(obj, '>', AKBASIC_TOK_NOT_EQUAL, AKBASIC_TOK_LESS_THAN);
}
break;
case '>':
(void)match_next_char(obj, '=', AKBASIC_TOK_GREATER_THAN_EQUAL, AKBASIC_TOK_GREATER_THAN);
break;
case '"':
obj->start = obj->current;
PASS(errctx, match_string(obj));
break;
case '\t':
case ' ':
obj->start = obj->current;
break;
case '\r':
case '\n':
done = true;
break;
default:
if ( isdigit((unsigned char)c) ) {
PASS(errctx, match_number(obj));
} else if ( isalpha((unsigned char)c) ) {
PASS(errctx, match_identifier(obj));
} else {
char message[AKBASIC_MAX_LINE_LENGTH];
snprintf(message, sizeof(message), "UNKNOWN TOKEN %c\n", c);
PASS(errctx, akbasic_runtime_error(obj, AKBASIC_ERRCLASS_PARSE, message));
obj->hasError = true;
obj->start = obj->current;
}
break;
}
if ( done ) {
break;
}
if ( obj->tokentype != AKBASIC_TOK_UNDEFINED && !obj->hasError ) {
if ( obj->tokentype == AKBASIC_TOK_REM ) {
/* Everything after REM is a comment. Stop, keeping the line intact. */
break;
} else if ( obj->tokentype == AKBASIC_TOK_LINE_NUMBER ) {
/*
* The line number is not kept as a token. Rewrite the line to
* everything after it, minus leading spaces, and restart the
* cursor -- the REPL reads the rewritten line back out and
* stores *that* as the program text.
*/
int skip = obj->current;
while ( obj->line[skip] == ' ' ) {
skip += 1;
}
memmove(obj->line, obj->line + skip, strlen(obj->line + skip) + 1);
obj->current = 0;
} else {
PASS(errctx, get_lexeme(obj, lexeme, sizeof(lexeme)));
PASS(errctx, add_token(obj, obj->tokentype, lexeme));
if ( obj->tokentype == AKBASIC_TOK_LITERAL_STRING ) {
/* Scanning stopped on the closing quote; step past it. */
obj->current += 1;
}
}
obj->tokentype = AKBASIC_TOK_UNDEFINED;
obj->start = obj->current;
}
}
if ( dest != NULL ) {
FAIL_ZERO_RETURN(errctx, (strlen(obj->line) < len), AKBASIC_ERR_BOUNDS,
"Scanned line does not fit the caller's buffer");
strncpy(dest, obj->line, len - 1);
dest[len - 1] = '\0';
}
SUCCEED_RETURN(errctx);
}

104
src/sink_stdio.c Normal file
View File

@@ -0,0 +1,104 @@
/**
* @file sink_stdio.c
* @brief The stdio-backed text sink.
*
* This is what makes the golden corpus runnable with no SDL on the machine. It
* writes exactly what the reference's fmt.Printf/fmt.Println mirror wrote, byte
* for byte, including the newline writeln appends -- an error line therefore
* ends in two newlines, because the caller's message already carries one. That
* is the acceptance contract, not an accident. See TODO.md section 1.8.
*/
#include <stdio.h>
#include <string.h>
#include <akerror.h>
#include <akstdlib.h>
#include <akbasic/error.h>
#include <akbasic/sink.h>
static akerr_ErrorContext *stdio_write(akbasic_TextSink *self, const char *text)
{
PREPARE_ERROR(errctx);
akbasic_StdioSink *state = NULL;
int count = 0;
FAIL_ZERO_RETURN(errctx, (self != NULL && text != NULL), AKERR_NULLPOINTER,
"NULL argument in sink write");
state = (akbasic_StdioSink *)self->self;
PASS(errctx, aksl_fprintf(&count, state->out, "%s", text));
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *stdio_writeln(akbasic_TextSink *self, const char *text)
{
PREPARE_ERROR(errctx);
akbasic_StdioSink *state = NULL;
int count = 0;
FAIL_ZERO_RETURN(errctx, (self != NULL && text != NULL), AKERR_NULLPOINTER,
"NULL argument in sink writeln");
state = (akbasic_StdioSink *)self->self;
PASS(errctx, aksl_fprintf(&count, state->out, "%s\n", text));
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *stdio_readline(akbasic_TextSink *self, char *dest, size_t len, bool *eof)
{
PREPARE_ERROR(errctx);
akbasic_StdioSink *state = NULL;
size_t used = 0;
FAIL_ZERO_RETURN(errctx, (self != NULL && dest != NULL && eof != NULL), AKERR_NULLPOINTER,
"NULL argument in sink readline");
FAIL_ZERO_RETURN(errctx, (len > 1), AKBASIC_ERR_BOUNDS,
"Read buffer of %zu bytes is too small", len);
state = (akbasic_StdioSink *)self->self;
*eof = false;
dest[0] = '\0';
if ( fgets(dest, (int)len, state->in) == NULL ) {
*eof = true;
SUCCEED_RETURN(errctx);
}
/*
* Strip the line terminator. The scanner treats \r and \n as end-of-line
* anyway, but leaving them on would make a stored source line differ from
* the same line typed at the REPL.
*/
used = strlen(dest);
while ( used > 0 && (dest[used - 1] == '\n' || dest[used - 1] == '\r') ) {
dest[used - 1] = '\0';
used -= 1;
}
SUCCEED_RETURN(errctx);
}
static akerr_ErrorContext *stdio_clear(akbasic_TextSink *self)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL sink in clear");
/* A terminal has no screen to clear that the golden corpus would agree on. */
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_sink_init_stdio(akbasic_TextSink *obj, akbasic_StdioSink *state, FILE *out, FILE *in)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL sink in init");
FAIL_ZERO_RETURN(errctx, (state != NULL), AKERR_NULLPOINTER, "NULL sink state in init");
state->out = (out != NULL ? out : stdout);
state->in = (in != NULL ? in : stdin);
obj->self = state;
obj->write = stdio_write;
obj->writeln = stdio_writeln;
obj->readline = stdio_readline;
obj->clear = stdio_clear;
SUCCEED_RETURN(errctx);
}

133
src/symtab.c Normal file
View File

@@ -0,0 +1,133 @@
/**
* @file symtab.c
* @brief Implements the fixed-capacity open-addressed symbol table.
*/
#include <string.h>
#include <akerror.h>
#include <akstdlib.h>
#include <akbasic/error.h>
#include <akbasic/symtab.h>
/*
* Probe for `key`. On success *slot points at either the slot holding the key or
* the first free slot it could occupy; *found says which. Uses
* aksl_strhash_djb2 rather than a private hash. That wrapper sign-extends char,
* so a high-bit byte hashes wrong (deps/libakstdlib/TODO.md 1.6) -- harmless
* here because BASIC identifiers are 7-bit ASCII, and it would only ever cost
* probe efficiency, never correctness, since the key comparison is a strcmp.
*/
static akerr_ErrorContext *probe(akbasic_SymbolTable *obj, const char *key, int *slot, bool *found)
{
PREPARE_ERROR(errctx);
uint32_t hashval = 0;
int index = 0;
int i = 0;
PASS(errctx, aksl_strhash_djb2((char *)key, strlen(key), &hashval));
*found = false;
index = (int)(hashval % (uint32_t)obj->capacity);
for ( i = 0; i < obj->capacity; i++ ) {
int probeidx = (index + i) % obj->capacity;
if ( !obj->slots[probeidx].used ) {
*slot = probeidx;
SUCCEED_RETURN(errctx);
}
if ( strcmp(obj->slots[probeidx].key, key) == 0 ) {
*slot = probeidx;
*found = true;
SUCCEED_RETURN(errctx);
}
}
FAIL_RETURN(errctx, AKBASIC_ERR_BOUNDS,
"Symbol table is full (%d entries), cannot place '%s'",
obj->capacity, key);
}
akerr_ErrorContext *akbasic_symtab_init(akbasic_SymbolTable *obj, int capacity)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER,
"NULL symbol table in init");
FAIL_ZERO_RETURN(errctx, (capacity > 0 && capacity <= AKBASIC_SYMTAB_MAX_SLOTS),
AKBASIC_ERR_BOUNDS,
"Symbol table capacity %d out of range 1..%d",
capacity, AKBASIC_SYMTAB_MAX_SLOTS);
memset(obj, 0, sizeof(*obj));
obj->capacity = capacity;
obj->count = 0;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_symtab_set(akbasic_SymbolTable *obj, const char *key, void *value, int64_t ivalue)
{
PREPARE_ERROR(errctx);
int slot = 0;
bool found = false;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER,
"NULL symbol table in set");
FAIL_ZERO_RETURN(errctx, (key != NULL), AKERR_NULLPOINTER,
"NULL key in symbol table set");
FAIL_ZERO_RETURN(errctx, (strlen(key) < AKBASIC_SYMTAB_MAX_KEY),
AKBASIC_ERR_BOUNDS,
"Symbol name '%s' exceeds %d characters",
key, AKBASIC_SYMTAB_MAX_KEY - 1);
PASS(errctx, probe(obj, key, &slot, &found));
if ( !found ) {
strncpy(obj->slots[slot].key, key, AKBASIC_SYMTAB_MAX_KEY - 1);
obj->slots[slot].key[AKBASIC_SYMTAB_MAX_KEY - 1] = '\0';
obj->slots[slot].used = true;
obj->count += 1;
}
obj->slots[slot].value = value;
obj->slots[slot].ivalue = ivalue;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_symtab_get(akbasic_SymbolTable *obj, const char *key, void **value, int64_t *ivalue)
{
PREPARE_ERROR(errctx);
int slot = 0;
bool found = false;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER,
"NULL symbol table in get");
FAIL_ZERO_RETURN(errctx, (key != NULL), AKERR_NULLPOINTER,
"NULL key in symbol table get");
FAIL_ZERO_RETURN(errctx, (strlen(key) < AKBASIC_SYMTAB_MAX_KEY),
AKERR_KEY,
"Symbol '%s' is not present", key);
PASS(errctx, probe(obj, key, &slot, &found));
FAIL_ZERO_RETURN(errctx, found, AKERR_KEY, "Symbol '%s' is not present", key);
if ( value != NULL ) {
*value = obj->slots[slot].value;
}
if ( ivalue != NULL ) {
*ivalue = obj->slots[slot].ivalue;
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_symtab_clear(akbasic_SymbolTable *obj)
{
PREPARE_ERROR(errctx);
int capacity = 0;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER,
"NULL symbol table in clear");
capacity = obj->capacity;
memset(obj, 0, sizeof(*obj));
obj->capacity = capacity;
SUCCEED_RETURN(errctx);
}

517
src/value.c Normal file
View File

@@ -0,0 +1,517 @@
/**
* @file value.c
* @brief Implements the BASIC value type and its operators.
*
* A faithful port of basicvalue.go. Where the reference does something
* arithmetically odd -- adding both of the right operand's numeric fields, for
* instance -- this reproduces it, because the golden corpus encodes the observed
* behaviour and a "fix" here is a silent behaviour change. Each one is catalogued
* in TODO.md section 12.
*/
#include <inttypes.h>
#include <stdio.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/error.h>
#include <akbasic/value.h>
/*
* The reference writes `rval.intval + int64(rval.floatval)` on every integer
* operation and the mirror image on every float one. It works only because the
* unused field of a typed value is always zero. Named so the intent -- "whatever
* numeric payload the right operand is carrying" -- is legible, and so there is
* one place to change when TODO.md section 12 item 5 is fixed.
*/
static int64_t rval_as_int(akbasic_Value *rval)
{
return rval->intval + (int64_t)rval->floatval;
}
static double rval_as_float(akbasic_Value *rval)
{
return rval->floatval + (double)rval->intval;
}
/* Copy a string into a value's inline buffer. Truncation is an error. */
static akerr_ErrorContext *set_string(akbasic_Value *dest, const char *src)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (strlen(src) < AKBASIC_MAX_STRING_LENGTH),
AKBASIC_ERR_VALUE,
"String result of %zu characters exceeds the %d character limit",
strlen(src), AKBASIC_MAX_STRING_LENGTH - 1);
strncpy(dest->stringval, src, AKBASIC_MAX_STRING_LENGTH - 1);
dest->stringval[AKBASIC_MAX_STRING_LENGTH - 1] = '\0';
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_valuepool_init(akbasic_ValuePool *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL pool in init");
memset(obj, 0, sizeof(*obj));
obj->next = 0;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_valuepool_take(akbasic_ValuePool *obj, int count, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
int i = 0;
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL pool in take");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in take");
FAIL_ZERO_RETURN(errctx, (count > 0), AKBASIC_ERR_BOUNDS,
"Array element count %d must be positive", count);
FAIL_ZERO_RETURN(errctx, (count <= AKBASIC_MAX_ARRAY_VALUES - obj->next),
AKBASIC_ERR_BOUNDS,
"Array of %d elements does not fit in the %d remaining value slots",
count, AKBASIC_MAX_ARRAY_VALUES - obj->next);
*dest = &obj->values[obj->next];
for ( i = 0; i < count; i++ ) {
PASS(errctx, akbasic_value_zero(&obj->values[obj->next + i]));
}
obj->next += count;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_init(akbasic_Value *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL value in init");
/*
* BasicValue.init() is empty in the reference; the zeroing happens in
* zero(). Keeping both means the call sites port one-for-one.
*/
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_zero(akbasic_Value *obj)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL value in zero");
obj->valuetype = AKBASIC_TYPE_UNDEFINED;
obj->stringval[0] = '\0';
obj->mutable_ = false;
obj->intval = 0;
obj->floatval = 0.0;
obj->boolvalue = AKBASIC_FALSE;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_clone(akbasic_Value *self, akbasic_Value *dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL source in clone");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in clone");
if ( self == dest ) {
SUCCEED_RETURN(errctx);
}
dest->valuetype = self->valuetype;
memcpy(dest->stringval, self->stringval, sizeof(dest->stringval));
dest->intval = self->intval;
dest->floatval = self->floatval;
dest->boolvalue = self->boolvalue;
/* mutable_ is deliberately not copied: the reference's clone() does not. */
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_to_string(akbasic_Value *self, char *dest, size_t len)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in to_string");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in to_string");
FAIL_ZERO_RETURN(errctx, (len > 0), AKBASIC_ERR_BOUNDS, "Zero-length destination in to_string");
switch ( self->valuetype ) {
case AKBASIC_TYPE_STRING:
snprintf(dest, len, "%s", self->stringval);
break;
case AKBASIC_TYPE_INTEGER:
snprintf(dest, len, "%" PRId64, self->intval);
break;
case AKBASIC_TYPE_FLOAT:
snprintf(dest, len, "%f", self->floatval);
break;
case AKBASIC_TYPE_BOOLEAN:
/* Go's %t, which is "true"/"false" and not the numeric -1/0. */
snprintf(dest, len, "%s", (self->boolvalue == AKBASIC_TRUE ? "true" : "false"));
break;
default:
snprintf(dest, len, "(UNDEFINED STRING REPRESENTATION FOR %d)", (int)self->valuetype);
break;
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_set_bool(akbasic_Value *obj, bool result)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (obj != NULL), AKERR_NULLPOINTER, "NULL value in set_bool");
obj->valuetype = AKBASIC_TYPE_BOOLEAN;
obj->boolvalue = (result ? AKBASIC_TRUE : AKBASIC_FALSE);
SUCCEED_RETURN(errctx);
}
bool akbasic_value_is_true(akbasic_Value *self)
{
if ( self == NULL || self->valuetype != AKBASIC_TYPE_BOOLEAN ) {
return false;
}
return (self->boolvalue == AKBASIC_TRUE);
}
/* Shared prologue for the unary operators: validate, clone into scratch. */
static akerr_ErrorContext *unary_prologue(akbasic_Value *self, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in unary operation");
FAIL_ZERO_RETURN(errctx, (scratch != NULL), AKERR_NULLPOINTER, "NULL scratch in unary operation");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in unary operation");
PASS(errctx, akbasic_value_clone(self, scratch));
*dest = scratch;
SUCCEED_RETURN(errctx);
}
/* Shared prologue for the binary operators: validate, clone into scratch. */
static akerr_ErrorContext *binary_prologue(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in binary operation");
FAIL_ZERO_RETURN(errctx, (rval != NULL), AKERR_NULLPOINTER, "nil rval");
FAIL_ZERO_RETURN(errctx, (scratch != NULL), AKERR_NULLPOINTER, "NULL scratch in binary operation");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in binary operation");
PASS(errctx, akbasic_value_clone(self, scratch));
*dest = scratch;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_invert(akbasic_Value *self, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in invert");
FAIL_NONZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_STRING),
AKBASIC_ERR_TYPE, "Cannot invert a string");
PASS(errctx, unary_prologue(self, scratch, dest));
(*dest)->intval = -(self->intval);
(*dest)->floatval = -(self->floatval);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_bitwise_not(akbasic_Value *self, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in bitwise not");
FAIL_ZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Cannot only perform bitwise operations on integers");
PASS(errctx, unary_prologue(self, scratch, dest));
(*dest)->intval = ~(self->intval);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_shift_left(akbasic_Value *self, int64_t bits, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in shift left");
FAIL_ZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Only integer datatypes can be bit-shifted");
/*
* Go's << on a negative or >=64 count is defined; C's is undefined. Refuse
* rather than inherit the UB -- no golden case exercises it, so this cannot
* change observed behaviour.
*/
FAIL_ZERO_RETURN(errctx, (bits >= 0 && bits < 64), AKBASIC_ERR_VALUE,
"Shift count %" PRId64 " is out of range 0..63", bits);
PASS(errctx, unary_prologue(self, scratch, dest));
(*dest)->intval = (int64_t)((uint64_t)(*dest)->intval << bits);
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_shift_right(akbasic_Value *self, int64_t bits, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in shift right");
FAIL_ZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Only integer datatypes can be bit-shifted");
FAIL_ZERO_RETURN(errctx, (bits >= 0 && bits < 64), AKBASIC_ERR_VALUE,
"Shift count %" PRId64 " is out of range 0..63", bits);
PASS(errctx, unary_prologue(self, scratch, dest));
(*dest)->intval = (*dest)->intval >> bits;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_bitwise_and(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in bitwise and");
FAIL_ZERO_RETURN(errctx, (rval != NULL), AKERR_NULLPOINTER, "nil rval");
FAIL_ZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Cannot perform bitwise operations on string or float");
PASS(errctx, binary_prologue(self, rval, scratch, dest));
(*dest)->intval = self->intval & rval->intval;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_bitwise_or(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in bitwise or");
FAIL_ZERO_RETURN(errctx, (rval != NULL), AKERR_NULLPOINTER, "nil rval");
FAIL_ZERO_RETURN(errctx, (self->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Can only perform bitwise operations on integers");
PASS(errctx, binary_prologue(self, rval, scratch, dest));
(*dest)->intval = self->intval | rval->intval;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_bitwise_xor(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in bitwise xor");
FAIL_ZERO_RETURN(errctx, (rval != NULL), AKERR_NULLPOINTER, "nil rval");
FAIL_ZERO_RETURN(errctx,
(self->valuetype == AKBASIC_TYPE_INTEGER && rval->valuetype == AKBASIC_TYPE_INTEGER),
AKBASIC_ERR_TYPE, "Can only perform bitwise operations on integers");
PASS(errctx, binary_prologue(self, rval, scratch, dest));
(*dest)->intval = self->intval ^ rval->intval;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_math_plus(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
akbasic_Value *out = NULL;
char buf[AKBASIC_MAX_STRING_LENGTH * 2];
FAIL_ZERO_RETURN(errctx, (self != NULL), AKERR_NULLPOINTER, "NULL value in math plus");
FAIL_ZERO_RETURN(errctx, (rval != NULL), AKERR_NULLPOINTER, "nil rval");
FAIL_ZERO_RETURN(errctx, (scratch != NULL), AKERR_NULLPOINTER, "NULL scratch in math plus");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in math plus");
/*
* The asymmetry with every other operator is deliberate and load-bearing:
* mathPlus mutates self in place when self is mutable, and CommandNEXT's
* loop increment relies on that to advance the loop variable. TODO.md
* section 12 item 4.
*/
if ( !self->mutable_ ) {
PASS(errctx, akbasic_value_clone(self, scratch));
out = scratch;
} else {
out = self;
}
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
out->intval = self->intval + rval_as_int(rval);
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
out->floatval = self->floatval + rval_as_float(rval);
} else if ( self->valuetype == AKBASIC_TYPE_STRING && rval->valuetype == AKBASIC_TYPE_STRING ) {
snprintf(buf, sizeof(buf), "%s%s", self->stringval, rval->stringval);
PASS(errctx, set_string(out, buf));
} else if ( self->valuetype == AKBASIC_TYPE_STRING && rval->valuetype == AKBASIC_TYPE_INTEGER ) {
snprintf(buf, sizeof(buf), "%s%" PRId64, self->stringval, rval->intval);
PASS(errctx, set_string(out, buf));
} else if ( self->valuetype == AKBASIC_TYPE_STRING && rval->valuetype == AKBASIC_TYPE_FLOAT ) {
snprintf(buf, sizeof(buf), "%s%f", self->stringval, rval->floatval);
PASS(errctx, set_string(out, buf));
} else {
FAIL_RETURN(errctx, AKBASIC_ERR_TYPE, "Invalid arithmetic operation");
}
*dest = out;
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_math_minus(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
FAIL_NONZERO_RETURN(errctx,
(self->valuetype == AKBASIC_TYPE_STRING || rval->valuetype == AKBASIC_TYPE_STRING),
AKBASIC_ERR_TYPE, "Cannot perform subtraction on strings");
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
(*dest)->intval = self->intval - rval_as_int(rval);
} else {
(*dest)->floatval = self->floatval - rval_as_float(rval);
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_math_divide(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
FAIL_NONZERO_RETURN(errctx,
(self->valuetype == AKBASIC_TYPE_STRING || rval->valuetype == AKBASIC_TYPE_STRING),
AKBASIC_ERR_TYPE, "Cannot perform division on strings");
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
/*
* Integer division by zero is UB in C where Go panics. Neither is
* acceptable in a library, and no golden case divides by zero, so raise.
*/
FAIL_NONZERO_RETURN(errctx, (rval_as_int(rval) == 0), AKBASIC_ERR_VALUE,
"DIVISION BY ZERO");
(*dest)->intval = self->intval / rval_as_int(rval);
} else {
(*dest)->floatval = self->floatval / rval_as_float(rval);
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_math_multiply(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
char buf[AKBASIC_MAX_STRING_LENGTH];
int64_t i = 0;
size_t srclen = 0;
size_t offset = 0;
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_STRING ) {
FAIL_NONZERO_RETURN(errctx, (rval->valuetype == AKBASIC_TYPE_STRING),
AKBASIC_ERR_TYPE, "String multiplication requires an integer multiple");
/*
* Go's strings.Repeat panics on a negative count. Refusing is strictly
* better than either panicking or reading off the end of the buffer, and
* no golden case does it.
*/
FAIL_NONZERO_RETURN(errctx, (rval->intval < 0), AKBASIC_ERR_VALUE,
"String multiplier %" PRId64 " must not be negative", rval->intval);
srclen = strlen((*dest)->stringval);
FAIL_NONZERO_RETURN(errctx,
(srclen != 0 && (uint64_t)rval->intval > (AKBASIC_MAX_STRING_LENGTH - 1) / srclen),
AKBASIC_ERR_VALUE,
"Repeated string of %zu x %" PRId64 " characters exceeds the %d character limit",
srclen, rval->intval, AKBASIC_MAX_STRING_LENGTH - 1);
for ( i = 0; i < rval->intval; i++ ) {
memcpy(buf + offset, (*dest)->stringval, srclen);
offset += srclen;
}
buf[offset] = '\0';
PASS(errctx, set_string(*dest, buf));
}
/*
* Not an `else if`. The reference falls through to the numeric branches even
* for a string, where self->floatval is 0 and the write is a harmless no-op.
* Kept so the port is provably faithful.
*/
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
(*dest)->intval = self->intval * rval_as_int(rval);
} else {
(*dest)->floatval = self->floatval * rval_as_float(rval);
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_less_than(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval < rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval < rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) < 0));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_less_than_equal(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval <= rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval <= rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) <= 0));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_greater_than(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval > rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval > rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) > 0));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_greater_than_equal(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval >= rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval >= rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) >= 0));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_is_equal(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval == rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval == rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) == 0));
}
SUCCEED_RETURN(errctx);
}
akerr_ErrorContext *akbasic_value_is_not_equal(akbasic_Value *self, akbasic_Value *rval, akbasic_Value *scratch, akbasic_Value **dest)
{
PREPARE_ERROR(errctx);
PASS(errctx, binary_prologue(self, rval, scratch, dest));
if ( self->valuetype == AKBASIC_TYPE_INTEGER ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->intval != rval_as_int(rval)));
} else if ( self->valuetype == AKBASIC_TYPE_FLOAT ) {
PASS(errctx, akbasic_value_set_bool(*dest, self->floatval != rval_as_float(rval)));
} else {
PASS(errctx, akbasic_value_set_bool(*dest, strcmp(self->stringval, rval->stringval) != 0));
}
SUCCEED_RETURN(errctx);
}

192
src/variable.c Normal file
View File

@@ -0,0 +1,192 @@
/**
* @file variable.c
* @brief Implements the named variable slot and its subscript arithmetic.
*/
#include <inttypes.h>
#include <string.h>
#include <akerror.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);
namelen = strlen(obj->name);
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;
/*
* Reuse the existing slice when it is already big enough. That makes a
* re-DIM to the same or a smaller size free, which is the only re-DIM any
* real program performs; growing takes fresh slots and abandons the old
* ones, as documented on akbasic_ValuePool.
*/
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");
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;
FAIL_ZERO_RETURN(errctx, (value != NULL), AKERR_NULLPOINTER, "NULL string in set_string");
FAIL_ZERO_RETURN(errctx, (strlen(value) < AKBASIC_MAX_STRING_LENGTH),
AKBASIC_ERR_VALUE,
"String of %zu characters exceeds the %d character limit",
strlen(value), AKBASIC_MAX_STRING_LENGTH - 1);
PASS(errctx, akbasic_value_zero(&tmp));
tmp.valuetype = AKBASIC_TYPE_STRING;
strncpy(tmp.stringval, value, AKBASIC_MAX_STRING_LENGTH - 1);
tmp.stringval[AKBASIC_MAX_STRING_LENGTH - 1] = '\0';
PASS(errctx, akbasic_variable_set_subscript(obj, &tmp, subscripts, subscriptcount));
SUCCEED_RETURN(errctx);
}

135
src/verbs.c Normal file
View File

@@ -0,0 +1,135 @@
/**
* @file verbs.c
* @brief The dispatch table: every verb, function and reserved word in one place.
*/
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
#include <akerror.h>
#include <akbasic/error.h>
#include <akbasic/verbs.h>
#include "verbs.h"
/*
* Sorted by name so bsearch() is valid -- tests/verbs_table.c asserts the
* ordering, because a mis-sorted row silently becomes an unfindable verb rather
* than a compile error.
*
* A NULL parse handler means the rval parses as a plain expression. A NULL exec
* handler means the token is consumed by some other verb's parse handler and is
* never evaluated on its own: ELSE, STEP, THEN and TO are all in that class, as
* are the four reserved words, which exist here only so the scanner can give
* them their token type.
*
* The reference bootstraps MOD, SPC and STR by running a BASIC program of DEF
* statements through the interpreter at startup and keeping their expressions
* (basicruntime_functions.go:14). That hack is not reproduced: they are ordinary
* native handlers here, which removes the need to run the interpreter before the
* interpreter is ready.
*/
static const akbasic_Verb VERBS[] = {
/* name token type arity parse handler exec handler */
{ "ABS", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_abs },
{ "AND", AKBASIC_TOK_AND, -1, NULL, NULL },
{ "ATN", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_atn },
{ "AUTO", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_auto },
{ "CHR", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_chr },
{ "COS", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_cos },
{ "DATA", AKBASIC_TOK_COMMAND, -1, akbasic_parse_data, akbasic_cmd_data },
{ "DEF", AKBASIC_TOK_COMMAND, -1, akbasic_parse_def, akbasic_cmd_def },
{ "DELETE", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_delete },
{ "DIM", AKBASIC_TOK_COMMAND, -1, akbasic_parse_dim, akbasic_cmd_dim },
{ "DLOAD", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_dload },
{ "DSAVE", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_dsave },
{ "ELSE", AKBASIC_TOK_COMMAND, -1, NULL, NULL },
{ "EXIT", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_exit },
{ "FOR", AKBASIC_TOK_COMMAND, -1, akbasic_parse_for, akbasic_cmd_for },
{ "GOSUB", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_gosub },
{ "GOTO", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_goto },
{ "HEX", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_hex },
{ "IF", AKBASIC_TOK_COMMAND, -1, akbasic_parse_if, akbasic_cmd_if },
{ "INPUT", AKBASIC_TOK_COMMAND, -1, akbasic_parse_input, akbasic_cmd_input },
{ "INSTR", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_instr },
{ "LABEL", AKBASIC_TOK_COMMAND, -1, akbasic_parse_label, akbasic_cmd_label },
{ "LEFT", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_left },
{ "LEN", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_len },
{ "LET", AKBASIC_TOK_COMMAND, -1, akbasic_parse_let, akbasic_cmd_let },
{ "LIST", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_list },
{ "LOG", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_log },
{ "MID", AKBASIC_TOK_FUNCTION, 3, NULL, akbasic_fn_mid },
{ "MOD", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_mod },
{ "NEXT", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_next },
{ "NOT", AKBASIC_TOK_NOT, -1, NULL, NULL },
{ "OR", AKBASIC_TOK_OR, -1, NULL, NULL },
{ "PEEK", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_peek },
{ "POINTER", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_pointer },
{ "POINTERVAR", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_pointervar },
{ "POKE", AKBASIC_TOK_COMMAND, -1, akbasic_parse_poke, akbasic_cmd_poke },
{ "PRINT", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_print },
{ "QUIT", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_quit },
{ "RAD", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_rad },
{ "READ", AKBASIC_TOK_COMMAND, -1, akbasic_parse_read, akbasic_cmd_read },
{ "REM", AKBASIC_TOK_REM, -1, NULL, NULL },
{ "RETURN", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_return },
{ "RIGHT", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_right },
{ "RUN", AKBASIC_TOK_COMMAND_IMMEDIATE, -1, NULL, akbasic_cmd_run },
{ "SGN", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_sgn },
{ "SHL", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_shl },
{ "SHR", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_shr },
{ "SIN", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_sin },
{ "SPC", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_spc },
{ "STEP", AKBASIC_TOK_COMMAND, -1, NULL, NULL },
{ "STOP", AKBASIC_TOK_COMMAND, -1, NULL, akbasic_cmd_stop },
{ "STR", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_str },
{ "TAN", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_tan },
{ "THEN", AKBASIC_TOK_COMMAND, -1, NULL, NULL },
{ "TO", AKBASIC_TOK_COMMAND, -1, NULL, NULL },
{ "VAL", AKBASIC_TOK_FUNCTION, 1, NULL, akbasic_fn_val },
{ "XOR", AKBASIC_TOK_FUNCTION, 2, NULL, akbasic_fn_xor },
};
#define VERB_COUNT ((int)(sizeof(VERBS) / sizeof(VERBS[0])))
static int verb_compare(const void *key, const void *element)
{
const akbasic_Verb *verb = (const akbasic_Verb *)element;
return strcmp((const char *)key, verb->name);
}
const akbasic_Verb *akbasic_verb_table(int *count)
{
if ( count != NULL ) {
*count = VERB_COUNT;
}
return VERBS;
}
akerr_ErrorContext *akbasic_verb_lookup(const char *name, const akbasic_Verb **dest)
{
PREPARE_ERROR(errctx);
char upper[AKBASIC_MAX_STRING_LENGTH];
size_t i = 0;
size_t len = 0;
FAIL_ZERO_RETURN(errctx, (name != NULL), AKERR_NULLPOINTER, "NULL name in verb lookup");
FAIL_ZERO_RETURN(errctx, (dest != NULL), AKERR_NULLPOINTER, "NULL destination in verb lookup");
*dest = NULL;
len = strlen(name);
if ( len == 0 || len >= sizeof(upper) ) {
/* Too long to be any verb we know. Not an error, just a miss. */
SUCCEED_RETURN(errctx);
}
for ( i = 0; i < len; i++ ) {
upper[i] = (char)toupper((unsigned char)name[i]);
}
upper[len] = '\0';
*dest = (const akbasic_Verb *)bsearch(upper, VERBS, VERB_COUNT, sizeof(VERBS[0]), verb_compare);
SUCCEED_RETURN(errctx);
}

82
src/verbs.h Normal file
View File

@@ -0,0 +1,82 @@
/**
* @file src/verbs.h
* @brief Internal declarations of every parse and exec handler in the table.
*
* These are not part of the public API -- callers reach them only through the
* dispatch table in src/verbs.c -- but they cannot be `static`, because the
* table lives in one translation unit and the handlers live in three others.
* This header keeps the declarations in one place so a signature cannot drift
* from its definition.
*/
#ifndef _AKBASIC_SRC_VERBS_H_
#define _AKBASIC_SRC_VERBS_H_
#include <akbasic/verbs.h>
/* Parse handlers -- src/parser_commands.c */
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_data(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_def(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_dim(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_for(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_if(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_input(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_label(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_let(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_poke(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_parse_read(struct akbasic_Parser *parser, akbasic_ASTLeaf **dest);
/* Verb handlers -- src/runtime_commands.c */
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_auto(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_data(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_def(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_delete(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_dim(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_dload(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_dsave(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_exit(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_for(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_gosub(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_goto(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_if(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_input(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_label(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_let(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_list(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_next(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_poke(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_print(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_quit(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_read(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_return(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_run(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_cmd_stop(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
/* Function handlers -- src/runtime_functions.c */
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_abs(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_atn(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_chr(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_cos(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_hex(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_instr(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_left(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_len(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_log(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_mid(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_mod(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_peek(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_pointer(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_pointervar(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_rad(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_right(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_sgn(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_shl(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_shr(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_sin(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_spc(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_str(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_tan(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_val(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
akerr_ErrorContext AKERR_NOIGNORE *akbasic_fn_xor(struct akbasic_Runtime *obj, akbasic_ASTLeaf *expr, akbasic_Value *lval, akbasic_Value *rval, akbasic_Value **dest);
#endif // _AKBASIC_SRC_VERBS_H_