AI_Slop/DVX_GUI
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
DVX_GUI/src/apps/kpunch/dvxbasic/runtime/vm.c
Scott Duensing 52d13717ce Lots of new BASIC features.
2026-09-30 09:57:59 -05:00

10076 lines
308 KiB
C
Raw Blame History

// The MIT License (MIT)
//
// Copyright (C) 2026 Scott Duensing
//
// Permission is hereby granted, free of charge, to any person obtaining a copy
// of this software and associated documentation files (the "Software"), to
// deal in the Software without restriction, including without limitation the
// rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
// sell copies of the Software, and to permit persons to whom the Software is
// furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be included in
// all copies or substantial portions of the Software.
//
// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
// IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
// FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
// AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
// LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
// FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
// IN THE SOFTWARE.
// vm.c -- DVX BASIC virtual machine implementation
//
// Stack-based p-code interpreter. Executes one instruction per
// basVmStep() call, or runs until completion via basVmRun().
// PRINT/INPUT, forms and extern calls go through host-provided
// callbacks; file, directory and path statements use the C library
// (stdio, dirent, fnmatch, stat) and the DVX platform helpers.
#include "vm.h"
#include "../compiler/opcodes.h"
#include "basErrors.h"
#include "dates.h"
#include "dvxPlat.h"
#include "dvxPrefs.h"
#include "screen.h"
#include <ctype.h>
#include <dirent.h>
#include <fnmatch.h>
#include <limits.h>
#include <math.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
#include <sys/time.h>
#include <time.h>
#include <unistd.h>
// ============================================================
// Prototypes
// ============================================================
// Capacity of the work buffers used by the numeric formatter shared by
// OP_PRINT_USING and OP_FORMAT. Bounds the worst-case output of a
// pathological format string or numeric magnitude.
#define BAS_FORMAT_BUF_SIZE 256
// Fixed (non-argument) stack operands an OP_CALL_METHOD carries: the
// method-name value and the control-reference value, both below the args.
#define BAS_CALL_METHOD_FIXED_OPERANDS 2
// File attribute bits returned/accepted by GETATTR/SETATTR (BASIC vbReadOnly/
// vbDirectory).
#define BAS_ATTR_READONLY 1 // file is read-only
#define BAS_ATTR_DIRECTORY 16 // path is a directory
// Scratch buffer capacities used by individual opcode handlers.
#define BAS_INPUT_PROMPT_LEN 512 // OP_INPUT: user prompt + "? "
#define BAS_FILE_LINE_CHUNK 1024 // INPUT #/LINE INPUT #: fgets chunk while growing a line
#define BAS_RADIX_STR_LEN 16 // HEX$/OCT$ output ("FFFFFFFF", "37777777777")
#define BAS_TIME_STR_LEN 16 // TIME$ "HH:MM:SS"
#define BAS_DATE_STR_LEN 32 // DATE$ "MM-DD-YYYY"
#define BAS_SCI_FMT_LEN 32 // printf format built for PRINT USING ^^^^
#define BAS_FORMAT_PERCENT "PERCENT" // FORMAT$ named format
#define BAS_FORMAT_OVERFLOW_MARK '%' // PRINT USING: value wider than its field
#define BAS_USING_ESCAPE '_' // PRINT USING: next format character is literal
#define BAS_PRINTER_NEWLINE "\r\n" // line end sent to a printer
#define BAS_PRINTER_NEWLINE_LEN 2
#define BAS_PRINTER_NAME_PRN "PRN" // the printer in the settings
#define BAS_PRINTER_NAME_LPT "LPT" // LPT1..LPT3
#define BAS_PRINTER_NAME_MAX 5 // "LPT1:" / "PRN:"
#define BAS_PRINTER_FIRST_DIGIT '1'
#define BAS_SPOOL_CHUNK 512 // spool bytes sent per printer write
#define BAS_LOC_SEQ_BLOCK 128 // LOC on a sequential channel counts 128-byte blocks (QB)
#define BAS_SCI_MARKER "^^^^" // PRINT USING scientific-notation marker
// Directory permission bits for MKDIR on POSIX hosts (rwxr-xr-x).
#define BAS_MKDIR_MODE 0755
// Largest count STRING$/SPACE$/INPUT$ accept (VB3 string space limit).
#define BAS_STRING_FUNC_MAX 65535
// References a REDIM PRESERVE source array holds when the REDIM'd variable
// is its only owner: the variable itself plus the copy the statement
// loaded onto the eval stack. More means another variable shares it, so
// preserved TYPE elements are cloned rather than aliased.
#define BAS_REDIM_OWNER_REFS 2
// Classic BASIC FUNCTION result slot (the compiler stores the return
// value in local 0; the epilogue is LOAD_LOCAL 0 + RET_VAL).
#define BAS_FUNC_RESULT_SLOT 0
// TIMER: seconds per hour/minute and microseconds per second.
#define BAS_SECS_PER_HOUR 3600.0
#define BAS_SECS_PER_MINUTE 60.0
#define BAS_USEC_PER_SEC 1000000.0
#define BAS_SECS_PER_DAY 86400.0
// struct tm counts years from 1900.
#define BAS_TM_YEAR_BASE 1900
// OP_BUILTIN: fields of DATESERIAL / TIMESERIAL, the "all" value of
// counts and start positions (REPLACE$ count, SPLIT limit, INSTRREV
// start) and the delimiter SPLIT and JOIN$ use when none is given.
#define BAS_SERIAL_PARTS 3
#define BAS_COUNT_ALL (-1)
#define BAS_DEFAULT_DELIMITER " "
// SLEEP: pause between event pumps while waiting (microseconds).
#define BAS_SLEEP_POLL_USEC 10000
// BEEP / SOUND / PLAY / FRAMEWAIT waiting without an event pump: pause
// between checks (microseconds).
#define BAS_WAIT_POLL_USEC 1000
// RND: rand() scaled by RAND_MAX + 1 so the result stays below 1.0, and
// the multiplier that spreads a negative RND(n) argument's fraction into
// the reseed value (RND(-1.5) and RND(-1) must seed differently).
#define BAS_RND_SCALE ((double)RAND_MAX + 1.0)
#define BAS_RND_SEED_SPREAD 65536.0
// A seed is reduced modulo 2^32 before it becomes srand's unsigned int, so
// huge and negative seeds convert without undefined behaviour.
#define BAS_RND_SEED_MODULUS 4294967296.0
// RGB packing: bit offsets and per-channel mask.
#define BAS_RGB_RED_SHIFT 16
#define BAS_RGB_GREEN_SHIFT 8
#define BAS_RGB_CHANNEL_MASK 0xFF
#define BAS_CHAR_MASK 0xFF
// Accesses of an object member: a read, or an assignment made with Let
// (obj.p = v) or Set (Set obj.p = v).
#define BAS_MEMBER_OP_GET 0
#define BAS_MEMBER_OP_LET 1
#define BAS_MEMBER_OP_SET 2
// findMember: rank of a member that cannot serve the access.
#define BAS_MEMBER_NO_RANK 2
// Collection members, the most arguments Add takes (item, key, before,
// after), and how its item array grows.
#define BAS_COLL_ADD "Add"
#define BAS_COLL_COUNT "Count"
#define BAS_COLL_ITEM "Item"
#define BAS_COLL_REMOVE "Remove"
#define BAS_COLL_ADD_ARGS 4
#define BAS_COLL_MIN_CAP 4
#define BAS_COLL_GROWTH 2
// TYPENAME / TYPEOF names that are not class or control names, and the
// suffix of an array's type name ("Integer()").
#define BAS_TYPENAME_COLLECTION "Collection"
#define BAS_TYPENAME_CONTROL "Control"
#define BAS_TYPENAME_FORM "Form"
#define BAS_TYPENAME_NOTHING "Nothing"
#define BAS_TYPENAME_OBJECT "Object"
#define BAS_TYPENAME_UDT "UserType"
#define BAS_ARRAY_SUFFIX "()"
#define BAS_ARRAY_SUFFIX_LEN 3
// ISNUMERIC: the characters that start an exponent, and the length of
// the &H / &O prefix.
#define BAS_EXPONENT_CHARS "eEdD"
#define BAS_RADIX_PREFIX_LEN 2
// BASIC's True as a bit pattern (every bit set).
#define BAS_TRUE_BITS (-1)
// Divergence between the PRINT USING and FORMAT$ numeric formatters,
// captured as options so a single helper serves both call sites.
typedef struct BasNumFormatT {
bool hasDecimal;
bool hasComma;
bool plusAtStart;
bool plusAtEnd;
bool minusAtEnd;
bool asteriskFill;
bool dollarFloat;
bool markOverflow; // PRINT USING: prefix '%' when the value does not fit the field
int32_t width; // field width the result is right-aligned in
int32_t minIntDigits; // integer digits forced by '0' placeholders (zero padded)
int32_t digitsAfter;
} BasNumFormatT;
// One decoded TYPE layout entry (see BAS_LAYOUT_* in opcodes.h).
typedef struct BasLayoutEntryT {
uint8_t type;
int32_t fixedLen; // STRING: 0 = variable length
int32_t typeId; // UDT
int32_t fieldCount; // UDT
} BasLayoutEntryT;
// Output sink for PUT: writes to fp, or with fp NULL only counts the
// bytes (a RANDOM PUT measures its record before writing it).
typedef struct BasPutSinkT {
FILE *fp;
int32_t bytes;
} BasPutSinkT;
static BasVmResultE allocArray(BasVmT *vm, int32_t dims, uint8_t elementType, bool preserve, BasArrayT **outArr);
static int32_t argCompare(BasVmT *vm, BasValueT v, bool *outText);
static BasStringT *argString(BasValueT *arg);
static void arrayClear(BasArrayT *arr);
static BasValueT arrValue(BasArrayT *arr);
static BasVmResultE basVmStepExec(BasVmT *vm);
static BasVmResultE boundOp(BasVmT *vm, uint8_t op);
static int32_t builtinDate(uint8_t fn, BasValueT *args, BasValueT *out);
static int32_t builtinDefaults(uint8_t fn, BasValueT *args, int32_t argc);
static int32_t builtinObject(BasVmT *vm, uint8_t fn, BasValueT *args, BasValueT *out);
static int32_t builtinString(BasVmT *vm, uint8_t fn, BasValueT *args, int32_t argc, BasValueT *out);
static BasVmResultE callMember(BasVmT *vm, BasObjectT *obj, const BasClassMemberT *m, BasValueT *args, int32_t argc, bool wantResult);
static int32_t clampComponent(int32_t c);
static void clearErrorState(BasVmT *vm);
static bool closeChannel(BasVmT *vm, int32_t channel);
static BasVmResultE collectionAccess(BasVmT *vm, BasObjectT *coll, const char *name, BasValueT *args, int32_t argc, int32_t op);
static int32_t collectionAdd(BasObjectT *coll, BasValueT *args, int32_t argc);
static int32_t collectionFind(const BasObjectT *coll, BasValueT index, int32_t *outPos);
static int32_t collectionKeyPos(const BasObjectT *coll, const BasStringT *key);
static BasStringT *commandArg(const char *args, int32_t n);
static BasCallFrameT *currentFrame(BasVmT *vm);
static void defaultPrint(void *ctx, const char *text, bool newline);
static void derefArg(BasValueT *arg);
static BasValueT *derefSlot(BasValueT *slot);
static void dirClose(BasVmT *vm);
static const char *dirNext(BasVmT *vm);
static void discardFrame(BasVmT *vm);
static bool dispatchError(BasVmT *vm, BasVmResultE result, int32_t floorDepth, int32_t faultPc);
static BasVmResultE divByZero(BasVmT *vm);
static int64_t divMod32(uint8_t op, int32_t ia, int32_t ib);
static void dropArgs(BasValueT *args, int32_t count);
static void dropValues(BasVmT *vm, int32_t count);
static int32_t eachCount(BasValueT group, int32_t *outCount);
static void emptyOperand(BasValueT *v, BasValueT other);
static const char *errorText(int32_t errNum);
static BasVmResultE execArith(BasVmT *vm, uint8_t op);
static BasVmResultE execBuiltin(BasVmT *vm);
static BasVmResultE execCall(BasVmT *vm, bool keepMe);
static BasVmResultE execCompare(BasVmT *vm, uint8_t op);
static BasVmResultE execConvert(BasVmT *vm, uint8_t op);
static BasVmResultE execDevice(BasVmT *vm, uint8_t op);
static BasVmResultE execFileOp(BasVmT *vm, uint8_t op);
static BasVmResultE execFsOp(BasVmT *vm, uint8_t op);
static BasVmResultE execLogical(BasVmT *vm, uint8_t op);
static BasVmResultE execLprint(BasVmT *vm, uint8_t phase);
static BasVmResultE execMath(BasVmT *vm, uint8_t op);
static BasVmResultE execPrint(BasVmT *vm);
static BasVmResultE execStrAppend(BasVmT *vm);
static BasVmResultE execStringOp(BasVmT *vm, uint8_t op);
static BasStringT *fillString(char ch, int32_t count);
static int32_t filterScan(const BasArrayT *arr, const BasStringT *match, bool keep, bool ignoreCase, BasArrayT *out);
static const BasClassMemberT *findMember(const BasClassInfoT *cls, const char *name, int32_t op);
static BasValueT forCounterValue(uint8_t varType, bool stepFractional, double v);
static void formatNumber(double n, const BasNumFormatT *f, char *out, size_t outSize);
static int32_t forStackFloor(BasVmT *vm);
static void forStackTrim(BasVmT *vm, int32_t newDepth);
static int32_t indexArray(const BasArrayT *arr, BasValueT *args, int32_t argc, int32_t *outIdx);
static BasValueT iniRead(const char *path, const char *sec, const char *key, BasStringT *defStr);
static BasVmResultE iniWrite(BasVmT *vm, const char *path, const char *sec, const char *key, const char *val);
static BasValueT integralValue(double v);
static BasValueT intResult(int32_t v);
static int32_t intValue(BasValueT v);
static BasStringT *ioReadBytes(FILE *fp, int32_t len, bool pad);
static BasStringT *ioReadPrefixedString(FILE *fp);
static BasValueT ioReadScalar(FILE *fp, uint8_t type);
static void ioWritePrefixedString(BasPutSinkT *sink, const BasStringT *s);
static void ioWriteScalar(BasPutSinkT *sink, uint8_t type, BasValueT val);
static bool isIntegerType(uint8_t type);
static bool isOneDimArray(BasValueT v);
static int32_t joinScan(const BasArrayT *arr, const BasStringT *delim, char *out);
static bool layoutNext(const BasStringT *layout, int32_t *pos, BasLayoutEntryT *out);
static void localNow(struct tm *out, int32_t *outUsec);
static BasVmResultE logicalNull(BasVmT *vm, uint8_t op, BasValueT a, BasValueT b);
static void lprintWrite(BasVmT *vm, const char *data, int32_t len);
static BasVmResultE mathRangeError(BasVmT *vm, double result);
static int32_t memberRank(uint8_t kind, int32_t op);
static BasValueT *memberSlot(BasVmT *vm, uint16_t idx);
static BasVmResultE memberVarAccess(BasVmT *vm, BasObjectT *obj, const BasClassMemberT *m, BasValueT *args, int32_t argc, BasValueT *value, int32_t op);
static BasVmResultE newObject(BasVmT *vm, uint16_t cls);
static BasArrayT *newVector(int32_t count, uint8_t elementType);
static int32_t nextStatementPc(BasVmT *vm, int32_t start, bool includeStart);
static BasVmResultE noFormRuntime(BasVmT *vm);
static bool nullOperands(BasVmT *vm, BasValueT *a, BasValueT *b, BasVmResultE *rc);
static BasVmResultE objectAccess(BasVmT *vm, BasObjectT *obj, const char *name, BasValueT *args, int32_t argc, BasValueT *value, int32_t op);
static int32_t objectCheck(BasValueT v, uint16_t cls);
static const BasClassInfoT *objectClass(const BasVmT *vm, const BasObjectT *obj);
static BasVmResultE objectDefault(BasVmT *vm, int32_t argc, bool isStore);
static BasVmResultE objectMemberOp(BasVmT *vm, BasValueT objVal, BasValueT nameVal, BasValueT *args, int32_t argc, BasValueT *value, int32_t op);
static const char *objectTypeName(const BasVmT *vm, BasValueT v);
static BasVmResultE openPrinterChannel(BasVmT *vm, int32_t channel, int32_t port, uint8_t mode, int32_t recLen);
static bool operandFits(BasVmT *vm, int32_t size);
static void padArg(BasValueT *args, int32_t *argc, int32_t idx, BasValueT value);
static void parseNumFormat(const char *fmt, int32_t fmtLen, BasNumFormatT *f, bool *outSci);
static bool pop(BasVmT *vm, BasValueT *val);
static bool popArgs(BasVmT *vm, int32_t count, ...);
static BasVmResultE popArrayElement(BasVmT *vm, int32_t dims, BasValueT *outArr, int32_t *outIdx);
static void popCallFrame(BasVmT *vm);
static BasVmResultE popFileChannel(BasVmT *vm, int32_t *outChannel, bool requireOpen);
static bool popPair(BasVmT *vm, BasValueT *a, BasValueT *b);
static bool popStringArg(BasVmT *vm, BasValueT *out);
static void primeModuleFrame(BasVmT *vm);
static int32_t *printColumnOf(BasVmT *vm);
static bool printerDevice(const char *name, int32_t *outPort);
static void printText(BasVmT *vm, const char *text, bool newline);
static int32_t procLocalCount(const BasVmT *vm, int32_t codeAddr, int32_t minCount);
static bool push(BasVmT *vm, BasValueT val);
static BasCallFrameT *pushFrame(BasVmT *vm, int32_t returnPc, int32_t codeAddr, int32_t minLocals);
static void putBounded(char *out, int32_t *idx, int32_t limit, char c);
static BasVmResultE putValue(BasVmT *vm, BasPutSinkT *sink, int32_t mode, BasValueT val, const BasStringT *layout);
static void queueTerminate(void *ctx, BasObjectT *obj);
static BasVmResultE raiseError(BasVmT *vm, int32_t errNum);
static BasStringT *readField(FILE *fp);
static int16_t readInt16(BasVmT *vm);
static BasStringT *readLine(FILE *fp);
static void readRaw(FILE *fp, void *dst, size_t size);
static uint16_t readUint16(BasVmT *vm);
static uint8_t readUint8(BasVmT *vm);
static BasVmResultE recordBegin(BasVmT *vm, int32_t channel, int32_t recno, long *start);
static BasVmResultE recordEnd(BasVmT *vm, int32_t channel, long start, bool writing);
static void releaseVmState(BasVmT *vm);
static int32_t replaceScan(const BasStringT *s, int32_t start, const BasStringT *find, const BasStringT *repl, int32_t count, bool ignoreCase, char *out);
static BasVmResultE roundedOperand(BasVmT *vm, BasValueT v, int32_t *out);
static bool runSubLoop(BasVmT *vm, int32_t savedPc, int32_t savedCallDepth, bool savedRunning);
static void runtimeError(BasVmT *vm, int32_t errNum, const char *msg);
static BasValueT *scopedVarSlot(BasVmT *vm, uint16_t varIdx, uint8_t scopeTag);
static void seedRandom(double seed);
static BasVmResultE seekRecord(BasVmT *vm, int32_t channel, int32_t pos);
static bool sendSpool(BasVmT *vm, BasFileChannelT *ch);
static void sinkFill(BasPutSinkT *sink, char c, int32_t count);
static void sinkWrite(BasPutSinkT *sink, const void *data, int32_t len);
static bool sleepSeconds(BasVmT *vm, int32_t secs);
static int32_t splitScan(const BasStringT *s, const BasStringT *delim, int32_t limit, bool ignoreCase, BasArrayT *out);
static BasVmResultE startTerminate(BasVmT *vm);
static BasVmResultE storeConvert(BasVmT *vm, uint8_t dataType, BasValueT *val);
static bool storeElement(BasVmT *vm, BasValueT *target, BasValueT val);
static void storeValue(BasValueT *target, BasValueT val);
static int32_t stringFind(const BasStringT *haystack, int32_t start, const BasStringT *needle, bool ignoreCase);
static bool stringMatchAt(const BasStringT *haystack, int32_t i, const BasStringT *needle, bool ignoreCase);
static BasValueT strValue(BasStringT *s);
static void sweepObjects(BasVmT *vm);
static bool textIsNumeric(const BasStringT *s);
static const char *typeNameOf(const BasVmT *vm, uint8_t type, int32_t typeId);
static BasValueT udtDetach(BasValueT val);
static BasUdtT *udtFromLayout(BasVmT *vm, const BasStringT *layout, int32_t *pos, int32_t typeId, int32_t fieldCount, int32_t depth);
static BasVmResultE udtGet(BasVmT *vm, FILE *fp, BasUdtT *udt, const BasStringT *layout, int32_t *pos, int32_t depth);
static BasVmResultE udtPut(BasVmT *vm, BasPutSinkT *sink, const BasUdtT *udt, const BasStringT *layout, int32_t *pos, int32_t depth);
static BasVmResultE uiTarget(BasVmT *vm, bool hasCallback, BasValueT target);
static int32_t usingFieldLen(const char *fmt, int32_t fmtLen, int32_t pos);
static BasStringT *usingFormat(BasVmT *vm, const BasStringT *fmt, BasValueT val, bool last);
static bool validArrayDims(BasVmT *vm, int32_t dims);
static int32_t varTypeOf(uint8_t type);
static bool waitWhile(BasVmT *vm, bool (*busy)(void *ctx));
static double wallSeconds(void);
static BasValueT zeroValue(uint8_t type);
// Shared body of OP_DIM_ARRAY / OP_REDIM: pops the UDT typeId/fieldCount
// pair (UDT element type only) and the (lbound, ubound) pairs for each
// dimension and allocates the array. With preserve set (REDIM PRESERVE)
// the old array reference left on top of the stack supplies every element
// whose subscripts exist in both shapes, element by element, so a changed
// row stride keeps each value at its own subscript. UDT elements not
// preserved get fresh instances. On success *outArr holds a refCount-1
// array.
static BasVmResultE allocArray(BasVmT *vm, int32_t dims, uint8_t elementType, bool preserve, BasArrayT **outArr) {
if (!validArrayDims(vm, dims)) {
return BAS_VM_ERROR;
}
int32_t udtTypeId = -1;
int32_t udtFieldCnt = 0;
BasValueT layoutVal;
memset(&layoutVal, 0, sizeof(layoutVal));
if (elementType == BAS_TYPE_UDT) {
BasValueT fcVal;
BasValueT tiVal;
if (!popArgs(vm, 3, &fcVal, &tiVal, &layoutVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
udtFieldCnt = basValToInt32(fcVal);
udtTypeId = basValToInt32(tiVal);
basValRelease(&fcVal);
basValRelease(&tiVal);
if (layoutVal.type != BAS_TYPE_STRING || !layoutVal.strVal) {
basValRelease(&layoutVal);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return BAS_VM_TYPE_MISMATCH;
}
}
int32_t lbounds[BAS_ARRAY_MAX_DIMS];
int32_t ubounds[BAS_ARRAY_MAX_DIMS];
// Pop bounds in reverse order (last dim first)
for (int32_t d = dims - 1; d >= 0; d--) {
BasValueT ubVal;
BasValueT lbVal;
if (!popArgs(vm, 2, &ubVal, &lbVal)) {
basValRelease(&layoutVal);
return BAS_VM_STACK_UNDERFLOW;
}
ubounds[d] = basValToInt32(ubVal);
lbounds[d] = basValToInt32(lbVal);
basValRelease(&ubVal);
basValRelease(&lbVal);
}
BasArrayT *arr = basArrayNew(dims, lbounds, ubounds, elementType);
if (!arr) {
basValRelease(&layoutVal);
runtimeError(vm, BAS_ERR_OUT_OF_MEMORY, "Out of memory allocating array");
return BAS_VM_OUT_OF_MEMORY;
}
const BasArrayT *oldArr = NULL;
if (preserve && vm->sp > 0) {
const BasValueT *top = &vm->stack[vm->sp - 1];
if (top->type == BAS_TYPE_ARRAY && top->arrVal && top->arrVal->dims == dims) {
oldArr = top->arrVal;
}
}
bool oldShared = oldArr && oldArr->refCount > BAS_REDIM_OWNER_REFS;
int32_t idx[BAS_ARRAY_MAX_DIMS];
memcpy(idx, lbounds, sizeof(int32_t) * dims);
for (int32_t flat = 0; flat < arr->totalElements; flat++) {
int32_t oldFlat = oldArr ? basArrayIndex((BasArrayT *)oldArr, idx, dims) : -1;
if (oldFlat >= 0) {
BasValueT v = basValCopy(oldArr->elements[oldFlat]);
basValRelease(&arr->elements[flat]);
arr->elements[flat] = oldShared ? udtDetach(v) : v;
} else if (elementType == BAS_TYPE_UDT) {
int32_t pos = 0;
BasUdtT *udt = udtFromLayout(vm, layoutVal.strVal, &pos, udtTypeId, udtFieldCnt, 0);
if (!udt) {
basArrayFree(arr);
basValRelease(&layoutVal);
return BAS_VM_ERROR;
}
arr->elements[flat].type = BAS_TYPE_UDT;
arr->elements[flat].udtVal = udt;
}
// Advance the subscript counter, last dimension fastest.
for (int32_t d = dims - 1; d >= 0; d--) {
if (++idx[d] <= ubounds[d]) {
break;
}
idx[d] = lbounds[d];
}
}
basValRelease(&layoutVal);
*outArr = arr;
return BAS_VM_OK;
}
// Resolves an optional compare argument of the string functions
// (vbBinaryCompare, vbTextCompare or vbUseCompareOption). Returns 0 and
// sets *outText, else the BASIC error number.
static int32_t argCompare(BasVmT *vm, BasValueT v, bool *outText) {
int32_t mode = basValToInt32(v);
if (mode == BAS_COMPARE_USE_OPTION) {
*outText = vm->compareTextMode;
} else if (mode == BAS_COMPARE_MODE_BINARY || mode == BAS_COMPARE_MODE_TEXT) {
*outText = (mode == BAS_COMPARE_MODE_TEXT);
} else {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
return 0;
}
// The string an OP_BUILTIN argument holds, converting the argument in
// place (the caller releases every argument afterwards).
static BasStringT *argString(BasValueT *arg) {
if (arg->type != BAS_TYPE_STRING || !arg->strVal) {
BasValueT sv = basValToString(*arg);
basValRelease(arg);
*arg = sv;
}
return arg->strVal;
}
// ERASE on a fixed array: every element goes back to its declared zero
// value (TYPE elements keep their instance and have each field reset).
static void arrayClear(BasArrayT *arr) {
for (int32_t i = 0; i < arr->totalElements; i++) {
BasValueT *elem = &arr->elements[i];
if (elem->type == BAS_TYPE_UDT && elem->udtVal) {
BasUdtT *udt = elem->udtVal;
for (int32_t f = 0; f < udt->fieldCount; f++) {
BasValueT zero = zeroValue(udt->fields[f].type);
basValRelease(&udt->fields[f]);
udt->fields[f] = zero;
}
continue;
}
BasValueT zero = zeroValue(arr->elementType);
basValRelease(elem);
*elem = zero;
}
}
// Wraps an array the caller already owns a reference to (no extra ref).
static BasValueT arrValue(BasArrayT *arr) {
BasValueT v;
v.type = BAS_TYPE_ARRAY;
v.arrVal = arr;
return v;
}
bool basVmCallSub(BasVmT *vm, int32_t codeAddr) {
// Thin wrapper: no args, no out-args. basVmCallSubWithArgsOut handles
// NULL args / zero counts and contains the full validation + frame setup.
return basVmCallSubWithArgsOut(vm, codeAddr, NULL, 0, NULL, BAS_MEMBER_OP_GET);
}
bool basVmCallSubWithArgs(BasVmT *vm, int32_t codeAddr, const BasValueT *args, int32_t argCount) {
// Thin wrapper: in-args only, no out-args.
return basVmCallSubWithArgsOut(vm, codeAddr, args, argCount, NULL, 0);
}
bool basVmCallSubWithArgsOut(BasVmT *vm, int32_t codeAddr, const BasValueT *args, int32_t argCount, BasValueT *outArgs, int32_t outCount) {
if (!vm || !vm->module) {
return false;
}
if (vm->debugPaused) {
return false;
}
if (codeAddr < 0 || codeAddr >= vm->module->codeLen) {
return false;
}
if (vm->callDepth >= BAS_VM_CALL_STACK_SIZE - 1 || argCount < 0 || argCount > BAS_VM_MAX_LOCALS) {
return false;
}
int32_t savedPc = vm->pc;
int32_t savedCallDepth = vm->callDepth;
bool savedRunning = vm->running;
BasCallFrameT *frame = pushFrame(vm, savedPc, codeAddr, argCount);
for (int32_t i = 0; i < argCount; i++) {
frame->locals[i] = basValCopy(args[i]);
}
vm->pc = codeAddr;
vm->running = true;
// Arrange for the returning frame's locals to be copied into outArgs by
// OP_RET/OP_RET_VAL, BEFORE those opcodes release the locals. Reading
// them after runSubLoop returns would be a use-after-free because the
// RET path has already released every local in the frame. The fields
// are not reentrant, so save and restore them around the call in case
// the running sub itself makes another out-arg call.
BasValueT *savedOutArgs = vm->outArgs;
int32_t savedOutArgCount = vm->outArgCount;
int32_t savedOutArgFrame = vm->outArgFrame;
vm->outArgs = (outArgs && outCount > 0) ? outArgs : NULL;
vm->outArgCount = outCount;
vm->outArgFrame = savedCallDepth;
bool ok = runSubLoop(vm, savedPc, savedCallDepth, savedRunning);
vm->outArgs = savedOutArgs;
vm->outArgCount = savedOutArgCount;
vm->outArgFrame = savedOutArgFrame;
return ok;
}
BasVmT *basVmCreate(void) {
BasVmT *vm = (BasVmT *)calloc(1, sizeof(BasVmT));
if (!vm) {
return NULL;
}
vm->printFn = defaultPrint;
vm->stepOverDepth = -1;
vm->stepOutDepth = -1;
vm->runToCursorLine = -1;
vm->outArgFrame = -1;
return vm;
}
void basVmDestroy(BasVmT *vm) {
if (!vm) {
return;
}
// No Class_Terminate once the program is being torn down
for (BasObjectT *o = vm->liveObjects; o; o = o->liveNext) {
o->finalize = NULL;
}
// Release eval stack, globals, call-frame locals and FOR-stack values
releaseVmState(vm);
while (vm->terminateQueue) {
BasObjectT *obj = vm->terminateQueue;
vm->terminateQueue = obj->termNext;
basObjectUnref(obj);
}
sweepObjects(vm);
for (int32_t i = 0; i < BAS_VM_MAX_FILES; i++) {
closeChannel(vm, i);
}
if (vm->lprintJob) {
vm->printer.close(vm->printer.ctx, vm->lprintJob);
}
dirClose(vm);
basScreenDestroy(vm->screen);
free(vm->commandArgs);
free(vm->externCache);
free(vm);
}
bool basVmDoEvents(BasVmT *vm) {
basScreenPresent(vm);
if (vm->doEventsFn && !vm->doEventsFn(vm->doEventsCtx)) {
return false;
}
return !vm->stopRequested;
}
const char *basVmGetError(const BasVmT *vm) {
return vm ? vm->errorMsg : "";
}
void basVmLoadModule(BasVmT *vm, BasModuleT *module) {
if (!module) {
vm->module = NULL;
snprintf(vm->errorMsg, sizeof(vm->errorMsg), "No program loaded");
return;
}
if (module->globalCount > BAS_VM_MAX_GLOBALS) {
vm->module = NULL;
snprintf(vm->errorMsg, sizeof(vm->errorMsg), "Program needs %d global variables; the limit is %d", (int)module->globalCount, (int)BAS_VM_MAX_GLOBALS);
return;
}
// One extern-cache slot per constant, so OP_CALL_EXTERN finds a
// resolved function by its name index without searching.
BasExternCacheEntryT *cache = NULL;
if (module->constCount > 0) {
cache = (BasExternCacheEntryT *)calloc(module->constCount, sizeof(BasExternCacheEntryT));
if (!cache) {
vm->module = NULL;
snprintf(vm->errorMsg, sizeof(vm->errorMsg), "Out of memory loading program");
return;
}
}
free(vm->externCache);
vm->externCache = cache;
vm->externCacheCount = module->constCount;
vm->module = module;
vm->pc = module->entryPoint;
clearErrorState(vm);
// Initialize globals whose declared type requires a non-numeric
// default. Uninitialized slots are zero (type=INTEGER, value=0),
// which breaks STRING operations: `DIM s AS STRING : s = s + "x"`
// would do numeric addition instead of concatenation. STATIC
// variables also alias global slots, so the same issue applies.
// globalInits survives the compiler's strip pass, unlike debugVars.
for (int32_t i = 0; i < module->globalInitCount; i++) {
BasGlobalInitT *g = &module->globalInits[i];
if (g->index < 0 || g->index >= BAS_VM_MAX_GLOBALS) {
continue;
}
if (g->dataType == BAS_TYPE_STRING) {
basValRelease(&vm->globals[g->index]);
vm->globals[g->index].type = BAS_TYPE_STRING;
vm->globals[g->index].strVal = basStringNew("", 0);
}
}
// Prime the implicit main (module-level) frame. The IDE and test
// harness used to set this by hand; doing it here makes every entry
// path (including compiled apps via the stub) consistent.
primeModuleFrame(vm);
vm->stmtPc = -1;
}
void basVmRequestStop(BasVmT *vm) {
vm->stopRequested = true;
vm->running = false;
}
BasVmResultE basVmRun(BasVmT *vm) {
// basVmLoadModule refused the module (too many globals): report why
// instead of returning a clean HALTED for a program that never ran.
if (!vm->module && vm->errorMsg[0] != '\0') {
return BAS_VM_ERROR;
}
// The host asked the program to stop (its screen was closed)
if (vm->stopRequested) {
return BAS_VM_HALTED;
}
vm->running = true;
vm->stepCount = 0;
while (vm->running) {
// Check step limit: the host gets a turn, with the screen shown
if (vm->stepLimit > 0 && vm->stepCount >= vm->stepLimit) {
basScreenPresent(vm);
return BAS_VM_STEP_LIMIT;
}
// Save PC before each instruction for RESUME support
int32_t savedPc = vm->pc;
BasVmResultE result = basVmStep(vm);
vm->stepCount++;
if (result != BAS_VM_OK) {
// Debugger pauses are not errors: hand them straight back to
// the host without consulting ON ERROR handlers.
if (result == BAS_VM_BREAKPOINT) {
vm->running = false;
return result;
}
// Trappable error with a handler in scope: the dispatcher has
// unwound to the handler frame and pointed pc at it.
if (dispatchError(vm, result, 0, savedPc)) {
continue;
}
// END, the end of the program or an error: show what it drew
vm->running = false;
basScreenPresent(vm);
return result;
}
}
// Host callbacks (property setters, method dispatch, etc.) can
// abort execution by writing an error message and clearing
// vm->running. The step itself returns OK because the VM did
// nothing wrong; the failure happened on the host side. If the
// host left an error message, surface it as BAS_VM_ERROR so the
// caller (IDE, stub) can navigate to the line and stop the
// program instead of treating the halt as a normal END.
if (vm->errorMsg[0] != '\0') {
return BAS_VM_ERROR;
}
basScreenPresent(vm);
return BAS_VM_HALTED;
}
void basVmRunToCursor(BasVmT *vm, int32_t line) {
if (vm) {
vm->runToCursorLine = line;
}
}
void basVmSetBreakpoints(BasVmT *vm, int32_t *lines, int32_t count) {
if (!vm) {
return;
}
vm->breakpoints = lines;
vm->breakpointCount = count;
}
bool basVmSetCommand(BasVmT *vm, const char *args) {
free(vm->commandArgs);
vm->commandArgs = (args && args[0]) ? strdup(args) : NULL;
return vm->commandArgs != NULL || !args || !args[0];
}
void basVmSetCurrentForm(BasVmT *vm, void *formRef) {
vm->currentForm = formRef;
}
void basVmSetCurrentFormVars(BasVmT *vm, BasValueT *vars, int32_t count) {
vm->currentFormVars = vars;
vm->currentFormVarCount = count;
}
void basVmSetDeviceCallbacks(BasVmT *vm, const BasDeviceCallbacksT *device) {
vm->device = *device;
}
void basVmSetDoEventsCallback(BasVmT *vm, BasDoEventsFnT fn, void *ctx) {
vm->doEventsFn = fn;
vm->doEventsCtx = ctx;
}
void basVmSetExternCallbacks(BasVmT *vm, const BasExternCallbacksT *ext) {
vm->ext = *ext;
}
void basVmSetInputCallback(BasVmT *vm, BasInputFnT fn, void *ctx) {
vm->inputFn = fn;
vm->inputCtx = ctx;
}
void basVmSetPrintCallback(BasVmT *vm, BasPrintFnT fn, void *ctx) {
vm->printFn = fn;
vm->printCtx = ctx;
}
void basVmSetPrinterCallbacks(BasVmT *vm, const BasPrinterCallbacksT *printer) {
vm->printer = *printer;
}
void basVmSetScreenHost(BasVmT *vm, const BasScreenHostT *host) {
vm->screenHost = *host;
}
void basVmSetSqlCallbacks(BasVmT *vm, const BasSqlCallbacksT *sql) {
vm->sql = *sql;
}
void basVmSetStepLimit(BasVmT *vm, int32_t limit) {
vm->stepLimit = limit;
}
void basVmSetUiCallbacks(BasVmT *vm, const BasUiCallbacksT *ui) {
vm->ui = *ui;
}
BasVmResultE basVmStep(BasVmT *vm) {
basValNullUsed = false;
BasVmResultE result = basVmStepExec(vm);
// A string allocation that failed during the step substituted an
// empty string; surface it as Out of string space instead of letting
// the program continue on lost data.
if (basStringAllocFailed) {
basStringAllocFailed = false;
if (result == BAS_VM_OK) {
runtimeError(vm, BAS_ERR_OUT_OF_STRING, "Out of string space");
result = BAS_VM_OUT_OF_MEMORY;
}
}
// A Null reached a conversion: a number or text was needed
if (basValNullUsed) {
basValNullUsed = false;
if (result == BAS_VM_OK) {
result = raiseError(vm, BAS_ERR_INVALID_NULL);
}
}
// Class_Terminate of an object the instruction let go of runs now, as
// a call made between this instruction and the next
if (result == BAS_VM_OK && vm->terminateQueue) {
result = startTerminate(vm);
}
return result;
}
// Executes one instruction: the body of basVmStep, which adds the
// string-allocation check around it.
static BasVmResultE basVmStepExec(BasVmT *vm) {
// A prior step's operand read ran past code[] and clamped pc to codeLen.
// Check this BEFORE the halt guard below, otherwise pc == codeLen would
// report a clean BAS_VM_HALTED and mask the corruption. badOperand can
// only have been set while vm->module was non-NULL, so no NULL check here.
if (vm->badOperand) {
vm->badOperand = false;
vm->running = false;
return BAS_VM_BAD_OPCODE;
}
if (!vm->module || vm->pc < 0 || vm->pc >= vm->module->codeLen) {
vm->running = false;
return BAS_VM_HALTED;
}
vm->currentOpPc = vm->pc;
uint8_t op = vm->module->code[vm->pc++];
switch (op) {
case OP_NOP:
break;
// ============================================================
// Stack operations
// ============================================================
case OP_PUSH_INT16: {
int16_t val = readInt16(vm);
if (!push(vm, basValInteger(val))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_INT32: {
int16_t lo = readInt16(vm);
int16_t hi = readInt16(vm);
// Reconstruct through unsigned math: left-shifting a negative
// sign-extended high half would be signed-overflow UB.
int32_t val = (int32_t)(((uint32_t)(uint16_t)hi << 16) | (uint16_t)lo);
if (!push(vm, basValLong(val))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_FLT64: {
double val = 0.0;
if (operandFits(vm, (int32_t)sizeof(double))) {
memcpy(&val, &vm->module->code[vm->pc], sizeof(double));
vm->pc += sizeof(double);
}
if (!push(vm, basValDouble(val))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_STR: {
uint16_t idx = readUint16(vm);
BasStringT *str = (idx < (uint16_t)vm->module->constCount) ? vm->module->constants[idx] : basEmptyString;
if (!push(vm, basValString(str))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_SPECIAL: {
uint8_t kind = readUint8(vm);
BasValueT val = (kind == BAS_SPECIAL_NULL) ? basValNull() : basValEmpty();
if (kind == BAS_SPECIAL_NOTHING) {
val = basValObject(NULL);
}
if (!push(vm, val)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_TRUE:
if (!push(vm, basValBool(true))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
case OP_PUSH_FALSE:
if (!push(vm, basValBool(false))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
case OP_POP: {
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
basValRelease(&val);
break;
}
case OP_DUP: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!push(vm, basValCopy(vm->stack[vm->sp - 1]))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STMT:
// Release-build statement boundary: same bookkeeping as OP_LINE
// minus the line number and debugger checks.
vm->stmtSp = vm->sp;
vm->stmtPc = vm->currentOpPc;
break;
// ============================================================
// Variable access
// ============================================================
case OP_LOAD_LOCAL: {
uint16_t idx = readUint16(vm);
BasCallFrameT *frame = currentFrame(vm);
if (idx >= (uint16_t)frame->localCount) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid local variable index");
return BAS_VM_ERROR;
}
// ByRef: if the local holds a reference, dereference it
BasValueT *slot = derefSlot(&frame->locals[idx]);
if (!slot) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Subscript out of range");
return BAS_VM_SUBSCRIPT_RANGE;
}
if (!push(vm, basValCopy(*slot))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_LOCAL: {
uint16_t idx = readUint16(vm);
BasCallFrameT *frame = currentFrame(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (idx >= (uint16_t)frame->localCount) {
basValRelease(&val);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid local variable index");
return BAS_VM_ERROR;
}
// ByRef: if the local holds a reference, store through it
BasValueT *slot = derefSlot(&frame->locals[idx]);
if (!slot) {
basValRelease(&val);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Subscript out of range");
return BAS_VM_SUBSCRIPT_RANGE;
}
storeValue(slot, val);
break;
}
case OP_LOAD_GLOBAL: {
uint16_t idx = readUint16(vm);
if (idx >= BAS_VM_MAX_GLOBALS) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid global variable index");
return BAS_VM_ERROR;
}
if (!push(vm, basValCopy(vm->globals[idx]))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_GLOBAL: {
uint16_t idx = readUint16(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (idx >= BAS_VM_MAX_GLOBALS) {
basValRelease(&val);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid global variable index");
return BAS_VM_ERROR;
}
storeValue(&vm->globals[idx], val);
break;
}
case OP_PUSH_LOCAL_ADDR: {
uint16_t idx = readUint16(vm);
BasCallFrameT *frame = currentFrame(vm);
if (idx >= (uint16_t)frame->localCount) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid local variable index");
return BAS_VM_ERROR;
}
// A local that is itself a ByRef parameter passes its
// reference straight through (an ELEM_REF copy counts the
// array again), so a callee two levels down still reaches the
// original variable. Only a plain slot gets a new reference.
BasValueT *slot = &frame->locals[idx];
BasValueT ref;
if (slot->type == BAS_TYPE_REF || slot->type == BAS_TYPE_ELEM_REF) {
ref = basValCopy(*slot);
} else {
ref.type = BAS_TYPE_REF;
ref.refVal = slot;
}
if (!push(vm, ref)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_GLOBAL_ADDR: {
uint16_t idx = readUint16(vm);
if (idx >= BAS_VM_MAX_GLOBALS) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid global variable index");
return BAS_VM_ERROR;
}
BasValueT ref;
ref.type = BAS_TYPE_REF;
ref.refVal = &vm->globals[idx];
if (!push(vm, ref)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_LOAD_MEMBER: {
BasValueT *slot = memberSlot(vm, readUint16(vm));
if (!slot) {
return BAS_VM_ERROR;
}
if (!push(vm, basValCopy(*slot))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_MEMBER: {
uint16_t idx = readUint16(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *slot = memberSlot(vm, idx);
if (!slot) {
basValRelease(&val);
return BAS_VM_ERROR;
}
storeValue(slot, val);
break;
}
case OP_PUSH_MEMBER_ADDR: {
// The caller's frame holds Me for the whole call, so the slot
// outlives the callee that writes through the reference.
BasValueT *slot = memberSlot(vm, readUint16(vm));
if (!slot) {
return BAS_VM_ERROR;
}
BasValueT ref;
ref.type = BAS_TYPE_REF;
ref.refVal = slot;
if (!push(vm, ref)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// Arithmetic
// ============================================================
case OP_ADD_INT:
case OP_SUB_INT:
case OP_MUL_INT:
case OP_IDIV_INT:
case OP_MOD_INT:
case OP_DIV_FLT:
case OP_POW:
return execArith(vm, op);
case OP_NEG_INT: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
// -Null is Null; -Empty is 0
if (top->type == BAS_TYPE_NULL) {
break;
}
if (top->type == BAS_TYPE_EMPTY) {
*top = basValInteger(0);
}
// Negating the most negative INTEGER / LONG does not fit the
// type: promote exactly as 0 - x does in execArith. (The
// literal -2147483648 is folded by the compiler and never
// reaches here.)
if (top->type == BAS_TYPE_INTEGER) {
*top = (top->intVal == INT16_MIN) ? basValLong(-(int32_t)INT16_MIN) : basValInteger((int16_t)-top->intVal);
} else if (top->type == BAS_TYPE_LONG) {
*top = (top->longVal == INT32_MIN) ? basValDouble(-(double)INT32_MIN) : basValLong(-top->longVal);
} else {
double n = basValToNumber(*top);
basValRelease(top);
*top = basValDouble(-n);
}
break;
}
// ============================================================
// String operations
// ============================================================
case OP_STR_CONCAT:
case OP_STR_LEFT:
case OP_STR_RIGHT:
case OP_STR_MID:
case OP_STR_MID2:
case OP_STR_LEN:
case OP_STR_INSTR:
case OP_STR_INSTR3:
case OP_STR_UCASE:
case OP_STR_LCASE:
case OP_STR_TRIM:
case OP_STR_LTRIM:
case OP_STR_RTRIM:
case OP_STR_CHR:
case OP_STR_ASC:
case OP_STR_SPACE:
case OP_STR_FIXLEN:
case OP_STR_MID_ASGN:
return execStringOp(vm, op);
case OP_STR_APPEND:
return execStrAppend(vm);
// ============================================================
// Comparison
// ============================================================
case OP_CMP_EQ:
case OP_CMP_NE:
case OP_CMP_LT:
case OP_CMP_GT:
case OP_CMP_LE:
case OP_CMP_GE:
return execCompare(vm, op);
case OP_IS: {
BasValueT a;
BasValueT b;
if (!popPair(vm, &a, &b)) {
return BAS_VM_STACK_UNDERFLOW;
}
bool objects = basValIsObject(a) && basValIsObject(b);
bool same = objects && a.type == b.type && ((a.type == BAS_TYPE_OBJECT) ? a.objVal == b.objVal : a.instVal == b.instVal);
basValRelease(&a);
basValRelease(&b);
if (!objects) {
return raiseError(vm, BAS_ERR_OBJECT_REQUIRED);
}
if (!push(vm, basValBool(same))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_OBJ_CHECK: {
uint16_t cls = readUint16(vm);
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t err = objectCheck(vm->stack[vm->sp - 1], cls);
if (err != 0) {
return raiseError(vm, err);
}
break;
}
// ============================================================
// Logical / bitwise
// ============================================================
case OP_AND:
case OP_OR:
case OP_NOT:
case OP_XOR:
case OP_EQV:
case OP_IMP:
return execLogical(vm, op);
// ============================================================
// Control flow
// ============================================================
case OP_JMP: {
int16_t offset = readInt16(vm);
vm->pc += offset;
break;
}
case OP_JMP_TRUE: {
int16_t offset = readInt16(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (basValIsTruthy(val)) {
vm->pc += offset;
}
basValRelease(&val);
break;
}
case OP_JMP_FALSE: {
int16_t offset = readInt16(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!basValIsTruthy(val)) {
vm->pc += offset;
}
basValRelease(&val);
break;
}
case OP_CALL:
case OP_CALL_ME:
return execCall(vm, op == OP_CALL_ME);
case OP_RET: {
// The module frame (depth 1) is never popped: a RET reached at
// module level (corrupt bytecode) ends the program, otherwise
// later local accesses would use a frame teardown cannot see.
if (vm->callDepth <= 1) {
vm->running = false;
return BAS_VM_HALTED;
}
// A SUB or Property Let/Set reached through an object where a
// value is expected leaves Empty.
bool pushResult = vm->callStack[vm->callDepth - 1].pushResult;
popCallFrame(vm);
if (pushResult && !push(vm, basValEmpty())) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_RET_VAL: {
// Like RET but leaves TOS as the return value
BasValueT retVal;
if (!pop(vm, &retVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (vm->callDepth <= 1) {
basValRelease(&retVal);
vm->running = false;
return BAS_VM_HALTED;
}
popCallFrame(vm);
if (!push(vm, retVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_GOSUB: {
int16_t offset = readInt16(vm);
if (vm->gosubDepth >= BAS_VM_GOSUB_STACK_SIZE) {
return BAS_VM_STACK_OVERFLOW;
}
vm->gosubStack[vm->gosubDepth++] = vm->pc;
vm->pc += offset;
break;
}
case OP_GOSUB_RET: {
// Only a GOSUB made by the current SUB/FUNCTION (or the module
// level) can be returned from.
int32_t gosubFloor = (vm->callDepth > 0) ? vm->callStack[vm->callDepth - 1].savedGosubDepth : 0;
if (vm->gosubDepth <= gosubFloor) {
runtimeError(vm, BAS_ERR_RETURN_NO_GOSUB, errorText(BAS_ERR_RETURN_NO_GOSUB));
return BAS_VM_ERROR;
}
vm->pc = vm->gosubStack[--vm->gosubDepth];
break;
}
case OP_FOR_INIT: {
uint16_t varIdx = readUint16(vm);
uint8_t scopeTag = readUint8(vm);
int16_t skipOffset = readInt16(vm);
BasValueT stepVal;
BasValueT limitVal;
if (!popArgs(vm, 2, &stepVal, &limitVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *varSlot = scopedVarSlot(vm, varIdx, scopeTag);
if (!varSlot) {
basValRelease(&stepVal);
basValRelease(&limitVal);
return BAS_VM_ERROR;
}
// Re-entering a FOR whose frame is still live (a GOTO back to
// the FOR statement, or a jump that skipped its NEXT) must not
// stack a second frame: discard the old context and everything
// nested inside it, as classic BASIC does. Only frames owned
// by the current call frame are considered.
int32_t forFloor = forStackFloor(vm);
for (int32_t k = vm->forDepth - 1; k >= forFloor; k--) {
if (vm->forStack[k].varIdx == (int32_t)varIdx && vm->forStack[k].scopeTag == scopeTag) {
forStackTrim(vm, k);
break;
}
}
if (vm->forDepth >= BAS_VM_MAX_FOR_DEPTH) {
basValRelease(&stepVal);
basValRelease(&limitVal);
runtimeError(vm, BAS_ERR_FOR_NESTING, "FOR loop nesting too deep");
return BAS_VM_ERROR;
}
double stepNum = basValToNumber(stepVal);
double limNum = basValToNumber(limitVal);
double curVal = basValToNumber(*varSlot);
// Entry check: if the loop's range is already empty (e.g.
// FOR i = 10 TO 5 with positive step), skip the body without
// pushing FOR state. QBASIC semantics: body executes zero
// times when the range is empty.
bool enter = (stepNum >= 0) ? (curVal <= limNum) : (curVal >= limNum);
if (!enter) {
basValRelease(&stepVal);
basValRelease(&limitVal);
vm->pc += skipOffset;
break;
}
BasForStateT *fs = &vm->forStack[vm->forDepth++];
fs->varIdx = varIdx;
fs->scopeTag = scopeTag;
fs->integral = isIntegerType(limitVal.type) && isIntegerType(stepVal.type);
fs->stepFractional = (stepNum != floor(stepNum));
fs->limit = limitVal;
fs->step = stepVal;
fs->loopTop = vm->pc;
break;
}
case OP_FOR_NEXT: {
uint16_t varIdx = readUint16(vm);
uint8_t scopeTag = readUint8(vm);
int16_t loopTopOffset = readInt16(vm);
if (vm->forDepth <= 0) {
runtimeError(vm, BAS_ERR_NEXT_WITHOUT_FOR, "NEXT without FOR");
return BAS_VM_ERROR;
}
BasForStateT *fs = &vm->forStack[vm->forDepth - 1];
if (fs->varIdx != (int32_t)varIdx || fs->scopeTag != scopeTag) {
// A jump out of an inner FOR (EXIT DO, GOTO) leaves its
// frame on the FOR stack. Search down to this call frame's
// floor for the loop this NEXT belongs to and discard the
// stale frames above it, matching classic BASIC semantics.
int32_t forFloor = forStackFloor(vm);
int32_t matchIdx = -1;
for (int32_t k = vm->forDepth - 2; k >= forFloor; k--) {
if (vm->forStack[k].varIdx == (int32_t)varIdx && vm->forStack[k].scopeTag == scopeTag) {
matchIdx = k;
break;
}
}
if (matchIdx < 0) {
runtimeError(vm, BAS_ERR_NEXT_WITHOUT_FOR, "NEXT variable mismatch");
return BAS_VM_ERROR;
}
forStackTrim(vm, matchIdx + 1);
fs = &vm->forStack[matchIdx];
}
BasValueT *varSlot = scopedVarSlot(vm, varIdx, scopeTag);
if (!varSlot) {
return BAS_VM_ERROR;
}
// Increment var by step and test against the limit: continue
// while var <= limit for a non-negative step, var >= limit for
// a negative one. INTEGER/LONG counters with an INTEGER/LONG
// limit and step stay in integer math.
uint8_t varType = varSlot->type;
bool cont;
if (fs->integral && isIntegerType(varType)) {
int32_t stepInt = intValue(fs->step);
int32_t limInt = intValue(fs->limit);
int64_t next = (int64_t)intValue(*varSlot) + stepInt;
cont = (stepInt >= 0) ? (next <= limInt) : (next >= limInt);
*varSlot = forCounterValue(varType, false, (double)next);
} else {
double stepNum = basValToNumber(fs->step);
double varVal = basValToNumber(*varSlot) + stepNum;
cont = (stepNum >= 0) ? (varVal <= basValToNumber(fs->limit)) : (varVal >= basValToNumber(fs->limit));
basValRelease(varSlot);
*varSlot = forCounterValue(varType, fs->stepFractional, varVal);
}
if (cont) {
vm->pc += loopTopOffset;
} else {
// Loop done -- pop FOR state
basValRelease(&fs->limit);
basValRelease(&fs->step);
vm->forDepth--;
}
break;
}
case OP_FOR_POP: {
if (vm->forDepth <= 0) {
runtimeError(vm, BAS_ERR_NEXT_WITHOUT_FOR, "FOR stack underflow");
return BAS_VM_ERROR;
}
BasForStateT *fs = &vm->forStack[--vm->forDepth];
basValRelease(&fs->limit);
basValRelease(&fs->step);
break;
}
// ============================================================
// Type conversion
// ============================================================
case OP_CONV_INT_FLT:
case OP_CONV_FLT_INT:
case OP_CONV_STR_INT:
case OP_CONV_INT_STR:
case OP_CONV_STR_FLT:
case OP_CONV_INT_LONG:
case OP_CONV_DATE:
case OP_CONV_BOOL:
return execConvert(vm, op);
// ============================================================
// I/O
// ============================================================
case OP_PRINT:
return execPrint(vm);
case OP_PRINT_NL:
printText(vm, "", true);
break;
case OP_LPRINT:
return execLprint(vm, readUint8(vm));
case OP_PRINT_TAB: {
// Comma: advance to the next print zone.
int32_t column = *printColumnOf(vm);
int32_t target = (column / BAS_PRINT_ZONE_WIDTH + 1) * BAS_PRINT_ZONE_WIDTH;
char spaces[BAS_PRINT_ZONE_WIDTH + 1];
int32_t count = target - column;
memset(spaces, ' ', count);
spaces[count] = '\0';
printText(vm, spaces, false);
break;
}
case OP_PRINT_SPC_N: {
BasValueT nVal;
if (!pop(vm, &nVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t count = basValToInt32(nVal);
basValRelease(&nVal);
if (count < 0) {
count = 0;
}
if (count > BAS_PRINT_SPC_MAX) {
count = BAS_PRINT_SPC_MAX;
}
char spaces[BAS_PRINT_SPC_MAX + 1];
memset(spaces, ' ', count);
spaces[count] = '\0';
printText(vm, spaces, false);
break;
}
case OP_PRINT_TAB_N: {
BasValueT nVal;
if (!pop(vm, &nVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t col = basValToInt32(nVal);
basValRelease(&nVal);
if (col < 1) {
col = 1;
}
if (col > BAS_PRINT_SPC_MAX) {
col = BAS_PRINT_SPC_MAX;
}
// TAB(n) pads to column n (1-based). When the cursor is
// already past it, QB starts a new line first.
if (*printColumnOf(vm) > col - 1) {
printText(vm, "", true);
}
char spaces[BAS_PRINT_SPC_MAX + 1];
int32_t count = col - 1 - *printColumnOf(vm);
memset(spaces, ' ', count);
spaces[count] = '\0';
printText(vm, spaces, false);
break;
}
case OP_PRINT_USING: {
// [uint8 flags] pop value and format string (format is below
// value on stack); push the format back for the next value,
// then the literal text and formatted field for this one.
uint8_t flags = readUint8(vm);
BasValueT val;
BasValueT fmtVal;
if (!popArgs(vm, 2, &val, &fmtVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT fmtStr = basValToString(fmtVal);
basValRelease(&fmtVal);
if (flags & BAS_USING_FIRST) {
vm->usingPos = 0;
}
BasStringT *out = usingFormat(vm, fmtStr.strVal, val, (flags & BAS_USING_LAST) != 0);
basValRelease(&val);
if (!out) {
basValRelease(&fmtStr);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "PRINT USING field does not match the value");
return BAS_VM_TYPE_MISMATCH;
}
if (!push(vm, fmtStr)) {
basStringUnref(out);
return BAS_VM_STACK_OVERFLOW;
}
if (!push(vm, strValue(out))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_INPUT: {
// Pop the prompt string pushed by the parser
BasValueT promptVal;
if (!pop(vm, &promptVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
// Build the full prompt: "user prompt? "
char promptBuf[BAS_INPUT_PROMPT_LEN];
const char *userPrompt = "";
if (promptVal.type == BAS_TYPE_STRING && promptVal.strVal) {
userPrompt = promptVal.strVal->data;
}
if (userPrompt[0]) {
snprintf(promptBuf, sizeof(promptBuf), "%s? ", userPrompt);
} else {
snprintf(promptBuf, sizeof(promptBuf), "? ");
}
char buf[BAS_INPUT_LINE_LEN];
buf[0] = '\0';
if (vm->screen) {
if (!basScreenInput(vm, promptBuf, buf, sizeof(buf))) {
buf[0] = '\0';
}
} else if (vm->inputFn) {
if (!vm->inputFn(vm->inputCtx, promptBuf, buf, sizeof(buf))) {
buf[0] = '\0';
}
}
basValRelease(&promptVal);
if (!push(vm, basValStringFromC(buf))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// Math built-ins
// ============================================================
case OP_MATH_ABS:
case OP_MATH_INT:
case OP_MATH_FIX:
case OP_MATH_SGN:
case OP_MATH_SQR:
case OP_MATH_SIN:
case OP_MATH_COS:
case OP_MATH_TAN:
case OP_MATH_ATN:
case OP_MATH_LOG:
case OP_MATH_EXP:
case OP_MATH_RND:
case OP_MATH_RANDOMIZE:
return execMath(vm, op);
case OP_RGB: {
// RGB(r, g, b) -> long color 0x00RRGGBB
BasValueT vb;
BasValueT vg;
BasValueT vr;
if (!popArgs(vm, 3, &vb, &vg, &vr)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t r = clampComponent(basValToInt32(vr));
int32_t g = clampComponent(basValToInt32(vg));
int32_t b = clampComponent(basValToInt32(vb));
basValRelease(&vr);
basValRelease(&vg);
basValRelease(&vb);
if (!push(vm, basValLong((r << BAS_RGB_RED_SHIFT) | (g << BAS_RGB_GREEN_SHIFT) | b))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_GET_RED:
case OP_GET_GREEN:
case OP_GET_BLUE: {
BasValueT vc;
if (!pop(vm, &vc)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t color = basValToInt32(vc);
basValRelease(&vc);
int32_t component;
if (op == OP_GET_RED) {
component = (color >> BAS_RGB_RED_SHIFT) & BAS_RGB_CHANNEL_MASK;
} else if (op == OP_GET_GREEN) {
component = (color >> BAS_RGB_GREEN_SHIFT) & BAS_RGB_CHANNEL_MASK;
} else {
component = color & BAS_RGB_CHANNEL_MASK;
}
if (!push(vm, basValInteger((int16_t)component))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// Conversion built-ins
// ============================================================
case OP_STR_VAL: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
double n = basValToNumber(*top);
basValRelease(top);
*top = basValDouble(n);
break;
}
case OP_STR_STRF: {
// STR$(n): VB convention -- leading space for positive, "-" for negative
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT num = *top;
// Same digits as PRINT (basValFormatString), so STR$ and PRINT
// never disagree; booleans and strings go through as numbers.
if (num.type == BAS_TYPE_BOOLEAN || num.type == BAS_TYPE_STRING) {
num = basValDouble(basValToNumber(num));
}
BasStringT *digits = basValFormatString(num);
BasStringT *result;
// A date is its date text, with no sign position
if (digits->data[0] == '-' || num.type == BAS_TYPE_DATE) {
result = basStringRef(digits);
} else {
BasStringT *space = basStringNew(" ", 1);
result = basStringConcat(space, digits);
basStringUnref(space);
}
basStringUnref(digits);
basValRelease(top);
*top = strValue(result);
break;
}
case OP_STR_HEX: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
int32_t n = basValToInt32(*top);
char buf[BAS_RADIX_STR_LEN];
snprintf(buf, sizeof(buf), "%X", (unsigned int)n);
basValRelease(top);
*top = basValStringFromC(buf);
break;
}
case OP_STR_OCT: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
int32_t n = basValToInt32(*top);
char buf[BAS_RADIX_STR_LEN];
snprintf(buf, sizeof(buf), "%o", (unsigned int)n);
basValRelease(top);
*top = basValStringFromC(buf);
break;
}
case OP_STR_STRING: {
// STRING$(n, char)
BasValueT charVal;
BasValueT countVal;
if (!popArgs(vm, 2, &charVal, &countVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t count = basValToInt32(countVal);
basValRelease(&countVal);
char ch;
if (charVal.type == BAS_TYPE_STRING && charVal.strVal && charVal.strVal->len > 0) {
ch = charVal.strVal->data[0];
} else {
ch = (char)(basValToInt32(charVal) & BAS_CHAR_MASK);
}
basValRelease(&charVal);
if (count < 0 || count > BAS_STRING_FUNC_MAX) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
if (!push(vm, strValue(fillString(ch, count)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// Extended built-ins
// ============================================================
case OP_MATH_TIMER: {
// Push seconds since midnight as a double, with sub-second
// resolution so timing loops do not stall for up to a second.
struct tm t;
int32_t usec;
localNow(&t, &usec);
double secs = (double)t.tm_hour * BAS_SECS_PER_HOUR + (double)t.tm_min * BAS_SECS_PER_MINUTE + (double)t.tm_sec + (double)usec / BAS_USEC_PER_SEC;
if (!push(vm, basValDouble(secs))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_DATE_STR: {
// Push DATE$ as "MM-DD-YYYY"
struct tm t;
char buf[BAS_DATE_STR_LEN];
localNow(&t, NULL);
snprintf(buf, sizeof(buf), "%02d-%02d-%04d", t.tm_mon + 1, t.tm_mday, t.tm_year + 1900);
if (!push(vm, basValStringFromC(buf))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_TIME_STR: {
// Push TIME$ as "HH:MM:SS"
struct tm t;
char buf[BAS_TIME_STR_LEN];
localNow(&t, NULL);
snprintf(buf, sizeof(buf), "%02d:%02d:%02d", t.tm_hour, t.tm_min, t.tm_sec);
if (!push(vm, basValStringFromC(buf))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_SLEEP: {
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t secs = basValToInt32(val);
basValRelease(&val);
if (!sleepSeconds(vm, secs)) {
vm->running = false;
return BAS_VM_HALTED;
}
break;
}
case OP_ENVIRON: {
// Pop env var name, push value string
BasValueT nameVal;
if (!pop(vm, &nameVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT nameStr = basValToString(nameVal);
basValRelease(&nameVal);
const char *envVal = getenv(nameStr.strVal->data);
basValRelease(&nameStr);
if (envVal == NULL) {
envVal = "";
}
if (!push(vm, basValStringFromC(envVal))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// File I/O
// ============================================================
case OP_FILE_OPEN:
case OP_FILE_CLOSE:
case OP_FILE_PRINT:
case OP_FILE_INPUT:
case OP_FILE_EOF:
case OP_FILE_LINE_INPUT:
case OP_FILE_WRITE:
case OP_FILE_WRITE_SEP:
case OP_FILE_WRITE_NL:
case OP_FILE_GET:
case OP_FILE_PUT:
case OP_FILE_PUT_UDT:
case OP_FILE_SEEK:
case OP_FILE_SEEK_GET:
case OP_FILE_LOF:
case OP_FILE_LOC:
case OP_FILE_FREEFILE:
case OP_FILE_INPUT_N:
return execFileOp(vm, op);
case OP_FS_KILL:
case OP_FS_NAME:
case OP_FS_FILECOPY:
case OP_FS_MKDIR:
case OP_FS_RMDIR:
case OP_FS_CHDIR:
case OP_FS_CHDRIVE:
case OP_FS_CURDIR:
case OP_FS_DIR:
case OP_FS_DIR_NEXT:
case OP_FS_FILELEN:
case OP_FS_GETATTR:
case OP_FS_SETATTR:
return execFsOp(vm, op);
case OP_BEEP:
case OP_SOUND:
case OP_PLAY:
case OP_PLAY_COUNT:
case OP_STICK:
case OP_STRIG:
case OP_FRAME_WAIT:
return execDevice(vm, op);
case OP_BUILTIN:
return execBuiltin(vm);
// ============================================================
// DoEvents
// ============================================================
case OP_DO_EVENTS:
if (!basVmDoEvents(vm)) {
vm->running = false;
return BAS_VM_HALTED;
}
break;
// ============================================================
// Error handling
// ============================================================
case OP_ON_ERROR: {
int16_t handler = readInt16(vm);
int32_t target = (handler == 0) ? 0 : vm->pc + handler;
// Record the handler on the current call frame. The error
// dispatcher walks frames (innermost outward) to find a
// handler and unwinds the stack to that frame before
// jumping. Module-level code lives in frame 0.
currentFrame(vm)->errorHandler = target;
break;
}
case OP_ERR_NUM:
if (!push(vm, basValLong(vm->errorNumber))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
case OP_ERL:
if (!push(vm, basValLong(vm->errorLine))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
case OP_RESUME:
case OP_RESUME_NEXT: {
// RESUME re-executes the statement that raised the error;
// RESUME NEXT continues at the statement after it. Only this
// frame's own running handler can resume (QBASIC error 20).
BasCallFrameT *frame = currentFrame(vm);
if (!frame->inHandler) {
runtimeError(vm, BAS_ERR_RESUME_WITHOUT_ERR, "RESUME without error");
return BAS_VM_ERROR;
}
int32_t target = (op == OP_RESUME) ? frame->resumePc : frame->resumeNextPc;
if (target < 0) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "RESUME NEXT has no statement to continue at");
return BAS_VM_ERROR;
}
vm->pc = target;
frame->inHandler = false;
clearErrorState(vm);
break;
}
case OP_RAISE_ERR: {
BasValueT errVal;
if (!pop(vm, &errVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t errNum = basValToInt32(errVal);
basValRelease(&errVal);
runtimeError(vm, errNum, errorText(errNum));
return BAS_VM_ERROR;
}
// ============================================================
// Array / UDT operations
// ============================================================
case OP_DIM_ARRAY: {
uint8_t dims = readUint8(vm);
uint8_t elementType = readUint8(vm);
// dims=0 with elementType=BAS_TYPE_UDT means allocate a UDT instance
if (dims == 0 && elementType == BAS_TYPE_UDT) {
BasValueT fieldCountVal;
BasValueT typeIdVal;
BasValueT layoutVal;
if (!popArgs(vm, 3, &fieldCountVal, &typeIdVal, &layoutVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t fieldCount = basValToInt32(fieldCountVal);
int32_t typeId = basValToInt32(typeIdVal);
basValRelease(&fieldCountVal);
basValRelease(&typeIdVal);
if (layoutVal.type != BAS_TYPE_STRING || !layoutVal.strVal) {
basValRelease(&layoutVal);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return BAS_VM_TYPE_MISMATCH;
}
int32_t pos = 0;
BasUdtT *udt = udtFromLayout(vm, layoutVal.strVal, &pos, typeId, fieldCount, 0);
basValRelease(&layoutVal);
if (!udt) {
return BAS_VM_ERROR;
}
BasValueT udtVal;
udtVal.type = BAS_TYPE_UDT;
udtVal.udtVal = udt;
if (!push(vm, udtVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
BasArrayT *arr;
BasVmResultE rc = allocArray(vm, dims, elementType, false, &arr);
if (rc != BAS_VM_OK) {
return rc;
}
BasValueT arrVal;
arrVal.type = BAS_TYPE_ARRAY;
arrVal.arrVal = arr;
if (!push(vm, arrVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_LOAD_ARRAY: {
uint8_t dims = readUint8(vm);
// obj(args): the default member of a class instance or Collection
if (vm->sp > dims && vm->stack[vm->sp - 1 - dims].type == BAS_TYPE_INSTANCE) {
return objectDefault(vm, dims, false);
}
BasValueT arrRef;
int32_t flatIdx;
BasVmResultE rc = popArrayElement(vm, dims, &arrRef, &flatIdx);
if (rc != BAS_VM_OK) {
return rc;
}
BasValueT elem = basValCopy(arrRef.arrVal->elements[flatIdx]);
basValRelease(&arrRef);
if (!push(vm, elem)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_PUSH_ARR_ADDR: {
// Pass `arr(i)` as a BYREF parameter: push a BAS_TYPE_ELEM_REF
// that owns a counted reference to the array plus the element
// index. Holding the reference keeps the element storage alive
// even if the callee REDIMs or ERASEs the array variable, and
// the index is resolved on every load/store instead of caching
// a raw element pointer.
uint8_t dims = readUint8(vm);
BasValueT arrRef;
int32_t flatIdx;
BasVmResultE rc = popArrayElement(vm, dims, &arrRef, &flatIdx);
if (rc != BAS_VM_OK) {
return rc;
}
// The popped arrRef's reference count transfers to the REF.
BasValueT ref;
ref.type = BAS_TYPE_ELEM_REF;
ref.elemRef.arr = arrRef.arrVal;
ref.elemRef.idx = flatIdx;
if (!push(vm, ref)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_ARRAY:
case OP_STORE_ARRAY_FIELD: {
// [uint8 dims] (STORE_ARRAY_FIELD adds [uint16 fieldIdx]): pop
// the value, then the subscripts and array reference.
uint8_t dims = readUint8(vm);
uint16_t fieldIdx = (op == OP_STORE_ARRAY_FIELD) ? readUint16(vm) : 0;
BasValueT storeVal;
// obj(args) = value: the default member's Property Let
if (op == OP_STORE_ARRAY && vm->sp > dims + 1 && vm->stack[vm->sp - 2 - dims].type == BAS_TYPE_INSTANCE) {
return objectDefault(vm, dims, true);
}
if (!pop(vm, &storeVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT arrRef;
int32_t flatIdx;
BasVmResultE rc = popArrayElement(vm, dims, &arrRef, &flatIdx);
if (rc != BAS_VM_OK) {
basValRelease(&storeVal);
return rc;
}
BasValueT *target = &arrRef.arrVal->elements[flatIdx];
if (op == OP_STORE_ARRAY_FIELD) {
// Element must be a UDT
if (target->type != BAS_TYPE_UDT || !target->udtVal) {
basValRelease(&arrRef);
basValRelease(&storeVal);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Array element is not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
if (fieldIdx >= (uint16_t)target->udtVal->fieldCount) {
basValRelease(&arrRef);
basValRelease(&storeVal);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid field index");
return BAS_VM_ERROR;
}
target = &target->udtVal->fields[fieldIdx];
}
bool stored = storeElement(vm, target, storeVal);
basValRelease(&arrRef);
if (!stored) {
return BAS_VM_TYPE_MISMATCH;
}
break;
}
case OP_REDIM: {
uint8_t dims = readUint8(vm);
uint8_t preserve = readUint8(vm);
uint8_t elementType = readUint8(vm);
// Same stack layout as OP_DIM_ARRAY (bounds, then UDT typeId and
// fieldCount), with the old array reference underneath; PRESERVE
// copies its elements while it is still on the stack.
BasArrayT *newArr;
BasVmResultE rc = allocArray(vm, dims, elementType, preserve != 0, &newArr);
if (rc != BAS_VM_OK) {
return rc;
}
BasValueT oldRef;
if (!pop(vm, &oldRef)) {
basArrayUnref(newArr);
return BAS_VM_STACK_UNDERFLOW;
}
basValRelease(&oldRef);
BasValueT arrVal;
arrVal.type = BAS_TYPE_ARRAY;
arrVal.arrVal = newArr;
if (!push(vm, arrVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_ERASE: {
// [uint8 mode] A fixed array keeps its bounds and has every
// element reset; a dynamic array is released and stays
// undimensioned until the next REDIM.
uint8_t mode = readUint8(vm);
BasValueT arrRef;
if (!pop(vm, &arrRef)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (mode == BAS_ERASE_ZERO && arrRef.type == BAS_TYPE_ARRAY && arrRef.arrVal) {
arrayClear(arrRef.arrVal);
if (!push(vm, arrRef)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
basValRelease(&arrRef);
// Push an empty/zero value to store back
BasValueT empty;
memset(&empty, 0, sizeof(empty));
if (!push(vm, empty)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_LBOUND:
case OP_UBOUND:
return boundOp(vm, op);
case OP_LOAD_FIELD: {
uint16_t fieldIdx = readUint16(vm);
BasValueT udtRef;
if (!pop(vm, &udtRef)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (udtRef.type != BAS_TYPE_UDT || !udtRef.udtVal) {
basValRelease(&udtRef);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
if (fieldIdx >= (uint16_t)udtRef.udtVal->fieldCount) {
basValRelease(&udtRef);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid field index");
return BAS_VM_ERROR;
}
BasValueT fieldVal = basValCopy(udtRef.udtVal->fields[fieldIdx]);
basValRelease(&udtRef);
if (!push(vm, fieldVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_FIELD: {
uint16_t fieldIdx = readUint16(vm);
BasValueT storeVal;
if (!pop(vm, &storeVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT udtRef;
if (!pop(vm, &udtRef)) {
basValRelease(&storeVal);
return BAS_VM_STACK_UNDERFLOW;
}
if (udtRef.type != BAS_TYPE_UDT || !udtRef.udtVal) {
basValRelease(&udtRef);
basValRelease(&storeVal);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
if (fieldIdx >= (uint16_t)udtRef.udtVal->fieldCount) {
basValRelease(&udtRef);
basValRelease(&storeVal);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid field index");
return BAS_VM_ERROR;
}
bool stored = storeElement(vm, &udtRef.udtVal->fields[fieldIdx], storeVal);
basValRelease(&udtRef);
if (!stored) {
return BAS_VM_TYPE_MISMATCH;
}
break;
}
// ============================================================
// DATA/READ/RESTORE
// ============================================================
case OP_READ_DATA: {
if (vm->dataPtr >= vm->module->dataCount) {
runtimeError(vm, BAS_ERR_OUT_OF_DATA, "Out of DATA");
return BAS_VM_ERROR;
}
if (!push(vm, basValCopy(vm->module->dataPool[vm->dataPtr++]))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_RESTORE:
vm->dataPtr = 0;
break;
// ============================================================
// FORMAT$
// ============================================================
case OP_FORMAT: {
// Pop format string, then value
BasValueT fmtVal;
BasValueT val;
if (!popArgs(vm, 2, &fmtVal, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT fmtStr = basValToString(fmtVal);
basValRelease(&fmtVal);
const char *fmt = fmtStr.strVal->data;
int32_t fmtLen = fmtStr.strVal->len;
double n = basValToNumber(val);
char buf[BAS_FORMAT_BUF_SIZE];
buf[0] = '\0';
if (strcasecmp(fmt, BAS_FORMAT_PERCENT) == 0) {
snprintf(buf, sizeof(buf), "%.0f%%", n * 100.0);
} else if (basDateIsPattern(fmt) || (val.type == BAS_TYPE_DATE && fmtLen == 0)) {
// A date pattern formats the value as a date (a number as
// a serial, a string as the date it holds).
double serial = 0.0;
int32_t err = basValToDateSerial(val, &serial);
if (err != 0) {
basValRelease(&val);
basValRelease(&fmtStr);
return raiseError(vm, err);
}
basDateFormat(serial, fmt, buf, sizeof(buf));
} else {
BasNumFormatT f;
bool sciNotation;
parseNumFormat(fmt, fmtLen, &f, &sciNotation);
formatNumber(n, &f, buf, sizeof(buf));
}
basValRelease(&val);
basValRelease(&fmtStr);
if (!push(vm, basValStringFromC(buf))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// SHELL
// ============================================================
case OP_SHELL: {
BasValueT cmdVal;
if (!pop(vm, &cmdVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT cmdStr = basValToString(cmdVal);
basValRelease(&cmdVal);
int32_t result = 0;
if (cmdStr.strVal && cmdStr.strVal->len > 0) {
result = system(cmdStr.strVal->data);
}
basValRelease(&cmdStr);
if (!push(vm, basValInteger((int16_t)result))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// COMPARE_MODE
// ============================================================
case OP_COMPARE_MODE: {
uint8_t mode = readUint8(vm);
vm->compareTextMode = (mode == BAS_COMPARE_MODE_TEXT);
break;
}
// ============================================================
// Halt
// ============================================================
case OP_END:
case OP_HALT:
// Any error state left here belongs to a handler that ended
// the program, which has dealt with it: clear it so the host
// does not report a trapped error as an unhandled one.
clearErrorState(vm);
vm->running = false;
vm->ended = vm->ended || (op == OP_END);
return BAS_VM_HALTED;
// ============================================================
// UI / Event opcodes (name-based resolution)
// ============================================================
case OP_LOAD_PROP: {
BasValueT propNameVal;
BasValueT ctrlRefVal;
if (!popArgs(vm, 2, &propNameVal, &ctrlRefVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (ctrlRefVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, ctrlRefVal, propNameVal, NULL, 0, NULL, BAS_MEMBER_OP_GET);
}
BasVmResultE rc = uiTarget(vm, vm->ui.getProp != NULL, ctrlRefVal);
if (rc != BAS_VM_OK) {
basValRelease(&propNameVal);
basValRelease(&ctrlRefVal);
return rc;
}
BasValueT sv = basValToString(propNameVal);
BasValueT result = vm->ui.getProp(vm->ui.ctx, ctrlRefVal.objVal, sv.strVal->data);
basValRelease(&sv);
basValRelease(&propNameVal);
basValRelease(&ctrlRefVal);
if (!push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_PROP: {
BasValueT value;
BasValueT propNameVal;
BasValueT ctrlRefVal;
if (!popArgs(vm, 3, &value, &propNameVal, &ctrlRefVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (ctrlRefVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, ctrlRefVal, propNameVal, NULL, 0, &value, BAS_MEMBER_OP_LET);
}
BasVmResultE rc = uiTarget(vm, vm->ui.setProp != NULL, ctrlRefVal);
if (rc == BAS_VM_OK) {
BasValueT sv = basValToString(propNameVal);
vm->ui.setProp(vm->ui.ctx, ctrlRefVal.objVal, sv.strVal->data, value);
basValRelease(&sv);
}
basValRelease(&value);
basValRelease(&propNameVal);
basValRelease(&ctrlRefVal);
return rc;
}
case OP_CALL_METHOD: {
uint8_t argc = readUint8(vm);
int32_t argCount = argc;
BasValueT methodNameVal;
BasValueT ctrlRefVal;
BasValueT args[BAS_VM_MAX_CALL_ARGS];
// Reject an over-limit argc rather than silently truncating, which
// would leak the un-popped args and desync the eval stack. Drain
// every pushed operand (args + method name + control ref) first to
// keep the stack balanced, then raise the error.
if (argc > BAS_VM_MAX_CALL_ARGS) {
dropValues(vm, argc + BAS_CALL_METHOD_FIXED_OPERANDS);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Too many arguments in method call");
return BAS_VM_ERROR;
}
// Pop args in reverse
for (int32_t i = argCount - 1; i >= 0; i--) {
if (!pop(vm, &args[i])) {
for (int32_t j = i + 1; j < argCount; j++) {
basValRelease(&args[j]);
}
return BAS_VM_STACK_UNDERFLOW;
}
}
if (!pop(vm, &methodNameVal)) {
for (int32_t i = 0; i < argCount; i++) {
basValRelease(&args[i]);
}
return BAS_VM_STACK_UNDERFLOW;
}
if (!pop(vm, &ctrlRefVal)) {
// methodNameVal was already popped -- release it too or
// its reference leaks on this underflow path.
basValRelease(&methodNameVal);
for (int32_t i = 0; i < argCount; i++) {
basValRelease(&args[i]);
}
return BAS_VM_STACK_UNDERFLOW;
}
if (ctrlRefVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, ctrlRefVal, methodNameVal, args, argCount, NULL, BAS_MEMBER_OP_GET);
}
BasValueT result = basValInteger(0);
BasVmResultE rc = uiTarget(vm, vm->ui.callMethod != NULL, ctrlRefVal);
if (rc == BAS_VM_OK) {
// A host method takes values: ByRef arguments meant for a
// class member arrive as references
for (int32_t i = 0; i < argCount; i++) {
derefArg(&args[i]);
}
BasValueT sv = basValToString(methodNameVal);
result = vm->ui.callMethod(vm->ui.ctx, ctrlRefVal.objVal, sv.strVal->data, args, argCount);
basValRelease(&sv);
}
for (int32_t i = 0; i < argCount; i++) {
basValRelease(&args[i]);
}
basValRelease(&methodNameVal);
basValRelease(&ctrlRefVal);
if (rc != BAS_VM_OK) {
return rc;
}
if (!push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_LOAD_FORM: {
BasValueT nameVal;
if (!pop(vm, &nameVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
void *formRef = NULL;
if (vm->ui.loadForm) {
BasValueT sv = basValToString(nameVal);
formRef = vm->ui.loadForm(vm->ui.ctx, sv.strVal->data);
basValRelease(&sv);
}
// Set as current form for subsequent FIND_CTRL calls
if (formRef) {
vm->currentForm = formRef;
}
basValRelease(&nameVal);
if (!vm->ui.loadForm) {
return noFormRuntime(vm);
}
if (!push(vm, basValObject(formRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_UNLOAD_FORM: {
BasValueT formVal;
if (!pop(vm, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE rc = uiTarget(vm, vm->ui.unloadForm != NULL, formVal);
if (rc == BAS_VM_OK) {
vm->ui.unloadForm(vm->ui.ctx, formVal.objVal);
}
basValRelease(&formVal);
return rc;
}
case OP_SHOW_FORM: {
uint8_t modal = readUint8(vm);
BasValueT formVal;
if (!pop(vm, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE rc = uiTarget(vm, vm->ui.showForm != NULL, formVal);
if (rc == BAS_VM_OK) {
vm->ui.showForm(vm->ui.ctx, formVal.objVal, modal != 0);
}
basValRelease(&formVal);
return rc;
}
case OP_HIDE_FORM: {
BasValueT formVal;
if (!pop(vm, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE rc = uiTarget(vm, vm->ui.hideForm != NULL, formVal);
if (rc == BAS_VM_OK) {
vm->ui.hideForm(vm->ui.ctx, formVal.objVal);
}
basValRelease(&formVal);
return rc;
}
case OP_MSGBOX: {
// Stack: [message, flags, title] -- title on top
BasValueT titleVal;
BasValueT flagsVal;
BasValueT msgVal;
if (!popArgs(vm, 3, &titleVal, &flagsVal, &msgVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t flags = basValToInt32(flagsVal);
int32_t result = 1; // default OK
if (vm->ui.msgBox) {
BasValueT sv = basValToString(msgVal);
BasValueT tv = basValToString(titleVal);
result = vm->ui.msgBox(vm->ui.ctx, sv.strVal->data, flags, tv.strVal->data);
basValRelease(&sv);
basValRelease(&tv);
}
basValRelease(&titleVal);
basValRelease(&flagsVal);
basValRelease(&msgVal);
if (!vm->ui.msgBox) {
return noFormRuntime(vm);
}
if (!push(vm, basValInteger((int16_t)result))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_INPUTBOX: {
BasValueT defaultVal;
BasValueT titleVal;
BasValueT promptVal;
if (!popArgs(vm, 3, &defaultVal, &titleVal, &promptVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasStringT *result = NULL;
if (vm->ui.inputBox) {
BasValueT sp = basValToString(promptVal);
BasValueT st = basValToString(titleVal);
BasValueT sd = basValToString(defaultVal);
result = vm->ui.inputBox(vm->ui.ctx, sp.strVal->data, st.strVal->data, sd.strVal->data);
basValRelease(&sp);
basValRelease(&st);
basValRelease(&sd);
}
basValRelease(&defaultVal);
basValRelease(&titleVal);
basValRelease(&promptVal);
if (!vm->ui.inputBox) {
return noFormRuntime(vm);
}
if (!push(vm, strValue(result ? result : basStringRef(basEmptyString)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_ME_REF:
if (!push(vm, basValObject(vm->currentForm))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
case OP_ME_OBJ: {
BasValueT me = currentFrame(vm)->me;
if (me.type != BAS_TYPE_INSTANCE || !me.instVal) {
return raiseError(vm, BAS_ERR_OBJECT_NOT_SET);
}
if (!push(vm, basValCopy(me))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_NEW_OBJ:
return newObject(vm, readUint16(vm));
case OP_PROP_ASSIGN: {
uint8_t argc = readUint8(vm);
uint8_t flags = readUint8(vm);
BasValueT args[BAS_VM_MAX_CALL_ARGS];
BasValueT value;
BasValueT nameVal;
BasValueT objVal;
if (argc > BAS_VM_MAX_CALL_ARGS) {
dropValues(vm, argc + BAS_CALL_METHOD_FIXED_OPERANDS + 1);
return raiseError(vm, BAS_ERR_ILLEGAL_FUNC_CALL);
}
if (vm->sp < argc + BAS_CALL_METHOD_FIXED_OPERANDS + 1) {
return BAS_VM_STACK_UNDERFLOW;
}
pop(vm, &value);
vm->sp -= argc;
memcpy(args, &vm->stack[vm->sp], (size_t)argc * sizeof(BasValueT));
pop(vm, &nameVal);
pop(vm, &objVal);
if (objVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, objVal, nameVal, args, argc, &value, (flags & BAS_ASSIGN_SET) ? BAS_MEMBER_OP_SET : BAS_MEMBER_OP_LET);
}
// A form or control property takes no arguments
BasVmResultE rc = (argc > 0) ? raiseError(vm, BAS_ERR_NO_MEMBER) : uiTarget(vm, vm->ui.setProp != NULL, objVal);
if (rc == BAS_VM_OK) {
BasValueT sv = basValToString(nameVal);
vm->ui.setProp(vm->ui.ctx, objVal.objVal, sv.strVal->data, value);
basValRelease(&sv);
}
dropArgs(args, argc);
basValRelease(&value);
basValRelease(&nameVal);
basValRelease(&objVal);
return rc;
}
case OP_CREATE_CTRL: {
BasValueT nameVal;
BasValueT typeVal;
BasValueT formVal;
if (!popArgs(vm, 3, &nameVal, &typeVal, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
void *ctrlRef = NULL;
BasVmResultE rc = uiTarget(vm, vm->ui.createCtrl != NULL, formVal);
if (rc == BAS_VM_OK) {
BasValueT sv1 = basValToString(typeVal);
BasValueT sv2 = basValToString(nameVal);
ctrlRef = vm->ui.createCtrl(vm->ui.ctx, formVal.objVal, sv1.strVal->data, sv2.strVal->data);
basValRelease(&sv1);
basValRelease(&sv2);
}
basValRelease(&nameVal);
basValRelease(&typeVal);
basValRelease(&formVal);
if (rc != BAS_VM_OK) {
return rc;
}
if (!push(vm, basValObject(ctrlRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_CREATE_CTRL_EX: {
// Stack: [formRef, typeStr, nameStr, parentRef] -- parent on top
BasValueT parentVal;
BasValueT nameVal;
BasValueT typeVal;
BasValueT formVal;
if (!popArgs(vm, 4, &parentVal, &nameVal, &typeVal, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
void *ctrlRef = NULL;
BasVmResultE rc = uiTarget(vm, vm->ui.createCtrlEx != NULL, formVal);
if (rc == BAS_VM_OK) {
BasValueT sv1 = basValToString(typeVal);
BasValueT sv2 = basValToString(nameVal);
void *parentRef = (parentVal.type == BAS_TYPE_OBJECT) ? parentVal.objVal : NULL;
ctrlRef = vm->ui.createCtrlEx(vm->ui.ctx, formVal.objVal, sv1.strVal->data, sv2.strVal->data, parentRef);
basValRelease(&sv1);
basValRelease(&sv2);
}
basValRelease(&parentVal);
basValRelease(&nameVal);
basValRelease(&typeVal);
basValRelease(&formVal);
if (rc != BAS_VM_OK) {
return rc;
}
if (!push(vm, basValObject(ctrlRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FIND_CTRL: {
BasValueT nameVal;
BasValueT formVal;
if (!popArgs(vm, 2, &nameVal, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
// a.b.c on an object: member b of a
if (formVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, formVal, nameVal, NULL, 0, NULL, BAS_MEMBER_OP_GET);
}
void *ctrlRef = NULL;
if (vm->ui.findCtrl) {
// Use current form if formRef is NULL or not an object
void *formRef = (formVal.type == BAS_TYPE_OBJECT) ? formVal.objVal : vm->currentForm;
BasValueT sv = basValToString(nameVal);
ctrlRef = vm->ui.findCtrl(vm->ui.ctx, formRef, sv.strVal->data);
basValRelease(&sv);
}
basValRelease(&nameVal);
basValRelease(&formVal);
if (!vm->ui.findCtrl) {
return noFormRuntime(vm);
}
if (!push(vm, basValObject(ctrlRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FIND_CTRL_IDX: {
// Stack: [formRef, ctrlName, index] -- index on top
BasValueT idxVal;
BasValueT nameVal;
BasValueT formVal;
if (!popArgs(vm, 3, &idxVal, &nameVal, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
// a.b(i).c on an object: member b of a with argument i
if (formVal.type == BAS_TYPE_INSTANCE) {
return objectMemberOp(vm, formVal, nameVal, &idxVal, 1, NULL, BAS_MEMBER_OP_GET);
}
void *ctrlRef = NULL;
if (vm->ui.findCtrlIdx) {
void *formRef = (formVal.type == BAS_TYPE_OBJECT) ? formVal.objVal : vm->currentForm;
int32_t index = basValToInt32(idxVal);
BasValueT sv = basValToString(nameVal);
ctrlRef = vm->ui.findCtrlIdx(vm->ui.ctx, formRef, sv.strVal->data, index);
basValRelease(&sv);
}
basValRelease(&idxVal);
basValRelease(&nameVal);
basValRelease(&formVal);
if (!vm->ui.findCtrlIdx) {
return noFormRuntime(vm);
}
if (!push(vm, basValObject(ctrlRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_CREATE_FORM: {
// Stack: [nameStr, width, height] -- height on top
BasValueT heightVal;
BasValueT widthVal;
BasValueT nameVal;
if (!popArgs(vm, 3, &heightVal, &widthVal, &nameVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
void *formRef = NULL;
if (vm->ui.createForm) {
BasValueT sv = basValToString(nameVal);
int32_t w = basValToInt32(widthVal);
int32_t h = basValToInt32(heightVal);
formRef = vm->ui.createForm(vm->ui.ctx, sv.strVal->data, w, h);
basValRelease(&sv);
}
basValRelease(&nameVal);
basValRelease(&widthVal);
basValRelease(&heightVal);
if (!vm->ui.createForm) {
return noFormRuntime(vm);
}
if (!push(vm, basValObject(formRef))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_SET_EVENT: {
// Stack: [ctrlRef, eventNameStr, handlerNameStr] -- handler on top
BasValueT handlerVal;
BasValueT eventVal;
BasValueT ctrlVal;
if (!popArgs(vm, 3, &handlerVal, &eventVal, &ctrlVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE rc = uiTarget(vm, vm->ui.setEvent != NULL, ctrlVal);
if (rc == BAS_VM_OK) {
BasValueT sv1 = basValToString(eventVal);
BasValueT sv2 = basValToString(handlerVal);
vm->ui.setEvent(vm->ui.ctx, ctrlVal.objVal, sv1.strVal->data, sv2.strVal->data);
basValRelease(&sv1);
basValRelease(&sv2);
}
basValRelease(&handlerVal);
basValRelease(&eventVal);
basValRelease(&ctrlVal);
return rc;
}
case OP_REMOVE_CTRL: {
// Stack: [formRef, ctrlNameStr] -- name on top
BasValueT nameVal;
BasValueT formVal;
if (!popArgs(vm, 2, &nameVal, &formVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE rc = uiTarget(vm, vm->ui.removeCtrl != NULL, formVal);
if (rc == BAS_VM_OK) {
BasValueT sv = basValToString(nameVal);
vm->ui.removeCtrl(vm->ui.ctx, formVal.objVal, sv.strVal->data);
basValRelease(&sv);
}
basValRelease(&nameVal);
basValRelease(&formVal);
return rc;
}
// ============================================================
// Form-level variables
// ============================================================
case OP_LOAD_FORM_VAR: {
uint16_t idx = readUint16(vm);
if (!vm->currentFormVars || idx >= (uint16_t)vm->currentFormVarCount) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Form variable access outside form context");
return BAS_VM_ERROR;
}
if (!push(vm, basValCopy(vm->currentFormVars[idx]))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_STORE_FORM_VAR: {
uint16_t idx = readUint16(vm);
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!vm->currentFormVars || idx >= (uint16_t)vm->currentFormVarCount) {
basValRelease(&val);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Form variable access outside form context");
return BAS_VM_ERROR;
}
storeValue(&vm->currentFormVars[idx], val);
break;
}
case OP_PUSH_FORM_ADDR: {
uint16_t idx = readUint16(vm);
if (!vm->currentFormVars || idx >= (uint16_t)vm->currentFormVarCount) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Form variable address outside form context");
return BAS_VM_ERROR;
}
BasValueT ref;
ref.type = BAS_TYPE_REF;
ref.refVal = &vm->currentFormVars[idx];
if (!push(vm, ref)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// External library calls
// ============================================================
case OP_CALL_EXTERN: {
uint16_t libNameIdx = readUint16(vm);
uint16_t funcNameIdx = readUint16(vm);
uint8_t argc = readUint8(vm);
uint8_t retType = readUint8(vm);
const char *libName = (libNameIdx < (uint16_t)vm->module->constCount) ? vm->module->constants[libNameIdx]->data : "";
const char *funcName = (funcNameIdx < (uint16_t)vm->module->constCount) ? vm->module->constants[funcNameIdx]->data : "";
void *funcPtr = NULL;
// The cache holds one entry per function-name constant; a hit
// must also come from the same library.
BasExternCacheEntryT *cached = (funcNameIdx < (uint16_t)vm->externCacheCount) ? &vm->externCache[funcNameIdx] : NULL;
if (cached && cached->funcPtr && cached->libNameIdx == libNameIdx) {
funcPtr = cached->funcPtr;
} else {
if (vm->ext.resolveExtern) {
funcPtr = vm->ext.resolveExtern(vm->ext.ctx, libName, funcName);
}
if (!funcPtr) {
char msg[BAS_VM_ERROR_MSG_LEN];
dropValues(vm, argc);
snprintf(msg, sizeof(msg), "External function not found: %s", funcName[0] ? funcName : "?");
runtimeError(vm, BAS_ERR_EXTERNAL_NOT_FOUND, msg);
return BAS_VM_ERROR;
}
if (cached) {
cached->funcPtr = funcPtr;
cached->libNameIdx = libNameIdx;
}
}
// Reject an over-limit argc rather than silently truncating, which
// would leak the un-popped args and desync the eval stack. Drain
// the pushed args (extern has no extra fixed operands) to keep the
// stack balanced, then raise the error.
if (argc > BAS_VM_MAX_CALL_ARGS) {
dropValues(vm, argc);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Too many arguments in external call");
return BAS_VM_ERROR;
}
// Pop arguments (reverse order)
BasValueT args[BAS_VM_MAX_CALL_ARGS];
int32_t argCount = argc;
for (int32_t i = argCount - 1; i >= 0; i--) {
if (!pop(vm, &args[i])) {
for (int32_t j = i + 1; j < argCount; j++) {
basValRelease(&args[j]);
}
return BAS_VM_STACK_UNDERFLOW;
}
}
// Call through host callback
BasValueT result = basValInteger(0);
if (vm->ext.callExtern) {
result = vm->ext.callExtern(vm->ext.ctx, funcPtr, libName, funcName, args, argCount, retType);
}
for (int32_t i = 0; i < argCount; i++) {
basValRelease(&args[i]);
}
// Push return value (void functions still push a dummy 0)
if (!push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
// ============================================================
// Debugger statement boundaries
// ============================================================
case OP_LINE: {
uint16_t lineNum = readUint16(vm);
vm->currentLine = lineNum;
// Snapshot the eval-stack depth at this statement boundary so an
// ON ERROR GOTO dispatch can release any operands left half-pushed
// by an error mid-expression and reset sp to here. Also remember
// where the statement starts: RESUME re-executes it from here and
// RESUME NEXT scans from here for the following statement.
vm->stmtSp = vm->sp;
vm->stmtPc = vm->currentOpPc;
// Step into: break at any OP_LINE
if (vm->debugBreak) {
vm->debugBreak = false;
return BAS_VM_BREAKPOINT;
}
// Step over: break when call depth returns to target level
if (vm->stepOverDepth >= 0 && vm->callDepth <= vm->stepOverDepth) {
vm->stepOverDepth = -1;
return BAS_VM_BREAKPOINT;
}
// Step out: break when call depth drops below target
if (vm->stepOutDepth >= 0 && vm->callDepth < vm->stepOutDepth) {
vm->stepOutDepth = -1;
return BAS_VM_BREAKPOINT;
}
// Run to cursor
if (vm->runToCursorLine >= 0 && (int32_t)lineNum == vm->runToCursorLine) {
vm->runToCursorLine = -1;
return BAS_VM_BREAKPOINT;
}
// Breakpoint check (linear scan, typically < 20 entries)
for (int32_t i = 0; i < vm->breakpointCount; i++) {
if (vm->breakpoints[i] == (int32_t)lineNum) {
return BAS_VM_BREAKPOINT;
}
}
break;
}
case OP_COMMAND: {
// Replace the argument index on top with COMMAND$(n)
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
int32_t n = basValToInt32(*top);
if (n < 0) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
basValRelease(top);
*top = strValue(commandArg(vm->commandArgs, n));
break;
}
case OP_APP_PATH:
case OP_APP_CONFIG:
case OP_APP_DATA: {
const char *path = (op == OP_APP_PATH) ? vm->appPath : (op == OP_APP_CONFIG) ? vm->appConfig : vm->appData;
if (!push(vm, basValStringFromC(path))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_INI_READ: {
// Stack: file, section, key, default -> result string
BasValueT defVal;
BasValueT keyVal;
BasValueT secVal;
BasValueT fileVal;
if (!popArgs(vm, 4, &defVal, &keyVal, &secVal, &fileVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasStringT *fileStr = basValFormatString(fileVal);
BasStringT *secStr = basValFormatString(secVal);
BasStringT *keyStr = basValFormatString(keyVal);
BasStringT *defStr = basValFormatString(defVal);
BasValueT resultVal = iniRead(fileStr->data, secStr->data, keyStr->data, defStr);
basStringUnref(fileStr);
basStringUnref(secStr);
basStringUnref(keyStr);
basStringUnref(defStr);
basValRelease(&fileVal);
basValRelease(&secVal);
basValRelease(&keyVal);
basValRelease(&defVal);
if (!push(vm, resultVal)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_INI_WRITE: {
// Stack: file, section, key, value
BasValueT valVal;
BasValueT keyVal;
BasValueT secVal;
BasValueT fileVal;
if (!popArgs(vm, 4, &valVal, &keyVal, &secVal, &fileVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasStringT *fileStr = basValFormatString(fileVal);
BasStringT *secStr = basValFormatString(secVal);
BasStringT *keyStr = basValFormatString(keyVal);
BasStringT *valStr = basValFormatString(valVal);
BasVmResultE rc = iniWrite(vm, fileStr->data, secStr->data, keyStr->data, valStr->data);
basStringUnref(fileStr);
basStringUnref(secStr);
basStringUnref(keyStr);
basStringUnref(valStr);
basValRelease(&fileVal);
basValRelease(&secVal);
basValRelease(&keyVal);
basValRelease(&valVal);
return rc;
}
default:
runtimeError(vm, BAS_ERR_BAD_OPCODE, "Bad opcode");
return BAS_VM_BAD_OPCODE;
}
return BAS_VM_OK;
}
void basVmStepInto(BasVmT *vm) {
if (vm) {
vm->debugBreak = true;
}
}
void basVmStepOut(BasVmT *vm) {
if (vm) {
vm->stepOutDepth = vm->callDepth;
}
}
void basVmStepOver(BasVmT *vm) {
if (vm) {
vm->stepOverDepth = vm->callDepth;
}
}
// OP_LBOUND / OP_UBOUND: [uint8 dim] array ref on stack -> LONG bound.
static BasVmResultE boundOp(BasVmT *vm, uint8_t op) {
uint8_t dim = readUint8(vm);
BasValueT arrRef;
if (!pop(vm, &arrRef)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (arrRef.type != BAS_TYPE_ARRAY || !arrRef.arrVal) {
basValRelease(&arrRef);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not an array");
return BAS_VM_TYPE_MISMATCH;
}
if (dim < 1 || dim > (uint8_t)arrRef.arrVal->dims) {
basValRelease(&arrRef);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, (op == OP_LBOUND) ? "Invalid dimension for LBOUND" : "Invalid dimension for UBOUND");
return BAS_VM_SUBSCRIPT_RANGE;
}
int32_t bound = (op == OP_LBOUND) ? arrRef.arrVal->lbound[dim - 1] : arrRef.arrVal->ubound[dim - 1];
basValRelease(&arrRef);
if (!push(vm, basValLong(bound))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// The date functions of OP_BUILTIN. args holds every argument (defaults
// filled in). Returns 0 and sets *out, else the BASIC error number.
static int32_t builtinDate(uint8_t fn, BasValueT *args, BasValueT *out) {
double serial = 0.0;
int32_t err = 0;
BasDateIntervalE interval;
switch (fn) {
case BAS_FN_NOW:
case BAS_FN_DATE:
case BAS_FN_TIME: {
struct tm t;
double datePart = 0.0;
double timePart = 0.0;
localNow(&t, NULL);
if (fn != BAS_FN_TIME && !basDateSerial(t.tm_year + BAS_TM_YEAR_BASE, t.tm_mon + 1, t.tm_mday, &datePart)) {
return BAS_ERR_OVERFLOW;
}
if (fn != BAS_FN_DATE && !basTimeSerial(t.tm_hour, t.tm_min, t.tm_sec, &timePart)) {
return BAS_ERR_OVERFLOW;
}
*out = basValDate(datePart + timePart);
return 0;
}
case BAS_FN_DATESERIAL:
case BAS_FN_TIMESERIAL: {
int32_t parts[BAS_SERIAL_PARTS];
for (int32_t i = 0; i < BAS_SERIAL_PARTS; i++) {
if (!basValRoundToInt32(args[i], INT32_MIN, INT32_MAX, &parts[i])) {
return BAS_ERR_OVERFLOW;
}
}
bool ok = (fn == BAS_FN_DATESERIAL) ? basDateSerial(parts[0], parts[1], parts[2], &serial) : basTimeSerial(parts[0], parts[1], parts[2], &serial);
if (!ok) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
*out = basValDate(serial);
return 0;
}
case BAS_FN_ISDATE:
*out = basValBool(args[0].type == BAS_TYPE_DATE || (args[0].type == BAS_TYPE_STRING && basValToDateSerial(args[0], &serial) == 0));
return 0;
case BAS_FN_MONTHNAME:
case BAS_FN_WEEKDAYNAME: {
int32_t n = basValToInt32(args[0]);
bool abbr = basValIsTruthy(args[1]);
const char *name;
if (fn == BAS_FN_MONTHNAME) {
name = basDateMonthName(n, abbr);
} else {
int32_t first = basValToInt32(args[2]);
if (first < BAS_DATE_USE_SYSTEM_DAY || first > BAS_DATE_SATURDAY || n < 1 || n > BAS_DATE_DAYS_PER_WEEK) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
// n counts from the first day of the week
if (first == BAS_DATE_USE_SYSTEM_DAY) {
first = BAS_DATE_SUNDAY;
}
name = basDateWeekdayName((n - 1 + first - 1) % BAS_DATE_DAYS_PER_WEEK + 1, abbr);
}
if (name == NULL) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
*out = basValStringFromC(name);
return 0;
}
default:
break;
}
// Every other function reads a date: the third argument of DATEADD
// and DATEDIFF (the second date), the second of DATEPART and the first
// otherwise. The interval of the three is the first.
int32_t dateArg = 0;
if (fn == BAS_FN_DATEADD || fn == BAS_FN_DATEDIFF) {
dateArg = 2;
} else if (fn == BAS_FN_DATEPART) {
dateArg = 1;
}
err = basValToDateSerial(args[dateArg], &serial);
if (err != 0) {
return err;
}
if ((fn == BAS_FN_DATEADD || fn == BAS_FN_DATEDIFF || fn == BAS_FN_DATEPART) && !basDateParseInterval(argString(&args[0])->data, &interval)) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
BasDatePartsT parts;
basDateSplit(serial, &parts);
switch (fn) {
case BAS_FN_DATEVALUE:
*out = basValDate((double)parts.dayNumber);
return 0;
case BAS_FN_TIMEVALUE:
*out = basValDate((double)parts.secOfDay / BAS_SECS_PER_DAY);
return 0;
case BAS_FN_YEAR:
*out = basValInteger((int16_t)parts.year);
return 0;
case BAS_FN_MONTH:
*out = basValInteger((int16_t)parts.month);
return 0;
case BAS_FN_DAY:
*out = basValInteger((int16_t)parts.day);
return 0;
case BAS_FN_HOUR:
*out = basValInteger((int16_t)parts.hour);
return 0;
case BAS_FN_MINUTE:
*out = basValInteger((int16_t)parts.minute);
return 0;
case BAS_FN_SECOND:
*out = basValInteger((int16_t)parts.second);
return 0;
case BAS_FN_DATEADD: {
double n = trunc(basValToNumber(args[1]));
double result;
if (!(n >= INT32_MIN && n <= INT32_MAX)) {
return BAS_ERR_OVERFLOW;
}
if (!basDateAdd(interval, (int32_t)n, serial, &result)) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
*out = basValDate(result);
return 0;
}
default:
break;
}
// WEEKDAY, DATEDIFF and DATEPART take a first day of the week (and
// the last two a first week of the year) after their dates.
int32_t firstDayArg = (fn == BAS_FN_WEEKDAY) ? 1 : dateArg + 1;
int32_t firstDay = basValToInt32(args[firstDayArg]);
int32_t firstWeek = (fn == BAS_FN_WEEKDAY) ? BAS_DATE_FIRST_JAN1 : basValToInt32(args[firstDayArg + 1]);
if (firstDay < BAS_DATE_USE_SYSTEM_DAY || firstDay > BAS_DATE_SATURDAY || firstWeek < BAS_DATE_USE_SYSTEM_WEEK || firstWeek > BAS_DATE_FIRST_FULL_WEEK) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
if (fn == BAS_FN_WEEKDAY) {
*out = basValInteger((int16_t)basDateWeekday(serial, firstDay));
return 0;
}
if (fn == BAS_FN_DATEPART) {
*out = basValInteger((int16_t)basDatePart(interval, serial, firstDay, firstWeek));
return 0;
}
// DATEDIFF: the first date is args[1], the second (serial) args[2]
double from;
err = basValToDateSerial(args[1], &from);
if (err != 0) {
return err;
}
int64_t diff = basDateDiff(interval, from, serial, firstDay);
if (diff < INT32_MIN || diff > INT32_MAX) {
return BAS_ERR_OVERFLOW;
}
*out = basValLong((int32_t)diff);
return 0;
}
// Pads the optional trailing arguments of an OP_BUILTIN call with their
// defaults. Returns the new argument count.
static int32_t builtinDefaults(uint8_t fn, BasValueT *args, int32_t argc) {
switch (fn) {
case BAS_FN_REPLACE:
padArg(args, &argc, 3, basValLong(1));
padArg(args, &argc, 4, basValLong(BAS_COUNT_ALL));
padArg(args, &argc, 5, basValLong(BAS_COMPARE_USE_OPTION));
break;
case BAS_FN_SPLIT:
padArg(args, &argc, 1, basValStringFromC(BAS_DEFAULT_DELIMITER));
padArg(args, &argc, 2, basValLong(BAS_COUNT_ALL));
padArg(args, &argc, 3, basValLong(BAS_COMPARE_USE_OPTION));
break;
case BAS_FN_JOIN:
padArg(args, &argc, 1, basValStringFromC(BAS_DEFAULT_DELIMITER));
break;
case BAS_FN_INSTRREV:
padArg(args, &argc, 2, basValLong(BAS_COUNT_ALL));
padArg(args, &argc, 3, basValLong(BAS_COMPARE_USE_OPTION));
break;
case BAS_FN_STRCOMP:
padArg(args, &argc, 2, basValLong(BAS_COMPARE_USE_OPTION));
break;
case BAS_FN_FILTER:
padArg(args, &argc, 2, basValBool(true));
padArg(args, &argc, 3, basValLong(BAS_COMPARE_USE_OPTION));
break;
case BAS_FN_WEEKDAY:
padArg(args, &argc, 1, basValLong(BAS_DATE_SUNDAY));
break;
case BAS_FN_DATEDIFF:
padArg(args, &argc, 3, basValLong(BAS_DATE_SUNDAY));
padArg(args, &argc, 4, basValLong(BAS_DATE_FIRST_JAN1));
break;
case BAS_FN_DATEPART:
padArg(args, &argc, 2, basValLong(BAS_DATE_SUNDAY));
padArg(args, &argc, 3, basValLong(BAS_DATE_FIRST_JAN1));
break;
case BAS_FN_MONTHNAME:
padArg(args, &argc, 1, basValBool(false));
break;
case BAS_FN_WEEKDAYNAME:
padArg(args, &argc, 1, basValBool(false));
padArg(args, &argc, 2, basValLong(BAS_DATE_SUNDAY));
break;
default:
break;
}
return argc;
}
// The object and Variant functions of OP_BUILTIN (BAS_FN_OBJECT_FIRST ..
// BAS_FN_OBJECT_LAST). Returns 0 and sets *out, else the BASIC error
// number.
static int32_t builtinObject(BasVmT *vm, uint8_t fn, BasValueT *args, BasValueT *out) {
BasValueT v = args[0];
switch (fn) {
case BAS_FN_VARTYPE: {
int32_t vt = varTypeOf(v.type);
if (v.type == BAS_TYPE_ARRAY && v.arrVal) {
vt = BAS_VT_ARRAY + varTypeOf(v.arrVal->elementType);
}
*out = basValInteger((int16_t)vt);
return 0;
}
case BAS_FN_TYPENAME: {
char buf[BAS_MAX_IDENT + BAS_ARRAY_SUFFIX_LEN];
const char *name = basValIsObject(v) ? objectTypeName(vm, v) : typeNameOf(vm, v.type, v.type == BAS_TYPE_UDT && v.udtVal ? v.udtVal->typeId : -1);
if (v.type == BAS_TYPE_ARRAY && v.arrVal) {
snprintf(buf, sizeof(buf), "%s%s", typeNameOf(vm, v.arrVal->elementType, -1), BAS_ARRAY_SUFFIX);
name = buf;
}
*out = basValStringFromC(name);
return 0;
}
case BAS_FN_ISEMPTY:
*out = basValBool(v.type == BAS_TYPE_EMPTY);
return 0;
case BAS_FN_ISNULL:
*out = basValBool(v.type == BAS_TYPE_NULL);
return 0;
case BAS_FN_ISNUMERIC: {
bool numeric = isIntegerType(v.type) || v.type == BAS_TYPE_SINGLE || v.type == BAS_TYPE_DOUBLE || v.type == BAS_TYPE_BOOLEAN || v.type == BAS_TYPE_EMPTY;
if (v.type == BAS_TYPE_STRING && v.strVal) {
numeric = textIsNumeric(v.strVal);
}
*out = basValBool(numeric);
return 0;
}
case BAS_FN_ISOBJECT:
*out = basValBool(basValIsObject(v));
return 0;
case BAS_FN_ISARRAY:
*out = basValBool(v.type == BAS_TYPE_ARRAY);
return 0;
case BAS_FN_CVAR:
*out = basValCopy(v);
return 0;
case BAS_FN_TYPEOF: {
if (!basValIsObject(v)) {
return BAS_ERR_OBJECT_REQUIRED;
}
const char *want = argString(&args[1])->data;
const char *actual = objectTypeName(vm, v);
bool isHost = (v.type == BAS_TYPE_OBJECT && v.objVal);
bool match = strcasecmp(actual, want) == 0;
// Object is every object, Control every control on a form
if (strcasecmp(want, BAS_TYPENAME_OBJECT) == 0) {
match = !(v.type == BAS_TYPE_OBJECT && !v.objVal);
} else if (strcasecmp(want, BAS_TYPENAME_CONTROL) == 0) {
match = isHost && strcasecmp(actual, BAS_TYPENAME_FORM) != 0;
}
*out = basValBool(match);
return 0;
}
case BAS_FN_EACH_COUNT:
case BAS_FN_EACH_ITEM: {
int32_t count = 0;
int32_t err = eachCount(v, &count);
if (err != 0 || fn == BAS_FN_EACH_COUNT) {
*out = basValLong(count);
return err;
}
int32_t i = basValToInt32(args[1]);
if (i < 0 || i >= count) {
return BAS_ERR_SUBSCRIPT_RANGE;
}
*out = basValCopy((v.type == BAS_TYPE_ARRAY) ? v.arrVal->elements[i] : v.instVal->items[i].value);
return 0;
}
default:
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
}
// The string, array and choice functions of OP_BUILTIN. args holds every
// argument (defaults filled in). Returns 0 and sets *out, else the BASIC
// error number.
static int32_t builtinString(BasVmT *vm, uint8_t fn, BasValueT *args, int32_t argc, BasValueT *out) {
bool text = false;
int32_t err;
switch (fn) {
case BAS_FN_REPLACE: {
BasStringT *s = argString(&args[0]);
BasStringT *find = argString(&args[1]);
BasStringT *repl = argString(&args[2]);
int32_t start = basValToInt32(args[3]);
int32_t count = basValToInt32(args[4]);
err = argCompare(vm, args[5], &text);
if (err != 0 || start < 1 || count < BAS_COUNT_ALL) {
return err != 0 ? err : BAS_ERR_ILLEGAL_FUNC_CALL;
}
// VB returns the text from start on, with the replacements made
int32_t len = replaceScan(s, start - 1, find, repl, count, text, NULL);
BasStringT *result = basStringAlloc(len + 1);
if (result->cap >= len + 1) {
replaceScan(s, start - 1, find, repl, count, text, result->data);
result->len = len;
result->data[len] = '\0';
}
*out = strValue(result);
return 0;
}
case BAS_FN_SPLIT:
case BAS_FN_FILTER: {
int32_t limit = BAS_COUNT_ALL;
bool keep = true;
// SPLIT(s, delim, limit, compare) / FILTER(array, match, include, compare)
if (fn == BAS_FN_SPLIT) {
argString(&args[0]);
limit = basValToInt32(args[2]);
} else {
if (!isOneDimArray(args[0])) {
return BAS_ERR_TYPE_MISMATCH;
}
keep = basValIsTruthy(args[2]);
}
argString(&args[1]);
err = argCompare(vm, args[3], &text);
if (err != 0 || limit < BAS_COUNT_ALL) {
return err != 0 ? err : BAS_ERR_ILLEGAL_FUNC_CALL;
}
// Count the pieces, then fill an array of exactly that many
int32_t n = (fn == BAS_FN_SPLIT) ? splitScan(args[0].strVal, args[1].strVal, limit, text, NULL) : filterScan(args[0].arrVal, args[1].strVal, keep, text, NULL);
BasArrayT *arr = newVector(n, BAS_TYPE_STRING);
if (!arr) {
return BAS_ERR_OUT_OF_MEMORY;
}
if (fn == BAS_FN_SPLIT) {
splitScan(args[0].strVal, args[1].strVal, limit, text, arr);
} else {
filterScan(args[0].arrVal, args[1].strVal, keep, text, arr);
}
*out = arrValue(arr);
return 0;
}
case BAS_FN_JOIN: {
if (!isOneDimArray(args[0])) {
return BAS_ERR_TYPE_MISMATCH;
}
BasStringT *delim = argString(&args[1]);
int32_t len = joinScan(args[0].arrVal, delim, NULL);
BasStringT *result = basStringAlloc(len + 1);
if (result->cap >= len + 1) {
joinScan(args[0].arrVal, delim, result->data);
result->len = len;
result->data[len] = '\0';
}
*out = strValue(result);
return 0;
}
case BAS_FN_INSTRREV: {
BasStringT *s = argString(&args[0]);
BasStringT *find = argString(&args[1]);
int32_t start = basValToInt32(args[2]);
err = argCompare(vm, args[3], &text);
if (err != 0 || start == 0 || start < BAS_COUNT_ALL) {
return err != 0 ? err : BAS_ERR_ILLEGAL_FUNC_CALL;
}
if (start == BAS_COUNT_ALL) {
start = s->len;
}
int32_t pos = 0;
if (s->len > 0 && start <= s->len) {
pos = start;
if (find->len > 0) {
pos = 0;
for (int32_t i = start - find->len; i >= 0 && pos == 0; i--) {
if (stringMatchAt(s, i, find, text)) {
pos = i + 1;
}
}
}
}
*out = basValLong(pos);
return 0;
}
case BAS_FN_STRCOMP: {
BasStringT *a = argString(&args[0]);
BasStringT *b = argString(&args[1]);
err = argCompare(vm, args[2], &text);
if (err != 0) {
return err;
}
int32_t cmp = text ? basStringCompareCI(a, b) : basStringCompare(a, b);
*out = basValInteger((int16_t)((cmp > 0) - (cmp < 0)));
return 0;
}
case BAS_FN_STRREVERSE: {
BasStringT *s = argString(&args[0]);
BasStringT *result = basStringAlloc(s->len + 1);
if (result->cap >= s->len + 1) {
for (int32_t i = 0; i < s->len; i++) {
result->data[i] = s->data[s->len - 1 - i];
}
result->len = s->len;
result->data[s->len] = '\0';
}
*out = strValue(result);
return 0;
}
case BAS_FN_LSET:
case BAS_FN_RSET: {
// The target keeps its length; the value is cut or padded
if (args[0].type != BAS_TYPE_STRING) {
return BAS_ERR_TYPE_MISMATCH;
}
int32_t width = argString(&args[0])->len;
BasStringT *value = argString(&args[1]);
int32_t copy = DVX_MIN(value->len, width);
int32_t offset = (fn == BAS_FN_RSET) ? width - copy : 0;
BasStringT *result = fillString(' ', width);
if (result->len == width) {
memcpy(result->data + offset, value->data, copy);
}
*out = strValue(result);
return 0;
}
case BAS_FN_IIF:
*out = basValCopy(basValIsTruthy(args[0]) ? args[1] : args[2]);
return 0;
case BAS_FN_CHOOSE: {
// An index outside the choices gives Null (VB)
double index = trunc(basValToNumber(args[0]));
*out = (index >= 1 && index < argc) ? basValCopy(args[(int32_t)index]) : basValNull();
return 0;
}
case BAS_FN_PARAMARRAY: {
// (elementType, values...): the values move into a 0-based
// array; each keeps the type the compiler gave it.
int32_t elementType = basValToInt32(args[0]);
if (elementType > BAS_TYPE_BOOLEAN && elementType != BAS_TYPE_OBJECT && elementType != BAS_TYPE_DATE && elementType != BAS_TYPE_VARIANT) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
BasArrayT *arr = newVector(argc - 1, (uint8_t)elementType);
if (!arr) {
return BAS_ERR_OUT_OF_MEMORY;
}
for (int32_t i = 1; i < argc; i++) {
basValRelease(&arr->elements[i - 1]);
arr->elements[i - 1] = args[i];
args[i] = basValInteger(0);
}
*out = arrValue(arr);
return 0;
}
default:
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
}
// Runs procedure member m of obj: the arguments (taken over) become its
// parameters, omitted Optional ones their type's zero, the rest of a
// ParamArray's packed into an array. The procedure runs as a call made from here
// with obj as its Me; wantResult makes a SUB (or Property Let/Set) leave
// Empty where the caller expects a value. args has room for
// BAS_VM_MAX_CALL_ARGS + 1 values.
static BasVmResultE callMember(BasVmT *vm, BasObjectT *obj, const BasClassMemberT *m, BasValueT *args, int32_t argc, bool wantResult) {
const BasProcEntryT *proc = &vm->module->procs[m->index];
int32_t paramCount = proc->paramCount;
int32_t baseSlot = proc->isFunction ? 1 : 0;
bool packed = (m->flags & BAS_MEMBER_PARAMARRAY) != 0;
if (argc < m->requiredParams || (argc > paramCount && !packed)) {
dropArgs(args, argc);
return raiseError(vm, BAS_ERR_WRONG_ARGS);
}
if (packed) {
int32_t first = paramCount - 1;
int32_t extra = (argc > first) ? argc - first : 0;
BasArrayT *arr = newVector(extra, BAS_TYPE_VARIANT);
if (!arr) {
dropArgs(args, argc);
return raiseError(vm, BAS_ERR_OUT_OF_MEMORY);
}
for (int32_t i = 0; i < extra; i++) {
derefArg(&args[first + i]);
basValRelease(&arr->elements[i]);
arr->elements[i] = args[first + i];
}
args[first] = arrValue(arr);
argc = paramCount;
}
if (vm->callDepth >= BAS_VM_CALL_STACK_SIZE) {
dropArgs(args, argc);
return BAS_VM_CALL_OVERFLOW;
}
BasCallFrameT *frame = pushFrame(vm, vm->pc, proc->codeAddr, baseSlot + paramCount);
for (int32_t i = 0; i < paramCount; i++) {
frame->locals[baseSlot + i] = (i < argc) ? udtDetach(args[i]) : zeroValue(m->paramTypes[i]);
}
frame->me = basValInstance(basObjectRef(obj));
frame->pushResult = wantResult && !proc->isFunction;
vm->pc = proc->codeAddr;
return BAS_VM_OK;
}
// Clamps an RGB channel value into [0, BAS_RGB_COMPONENT_MAX].
static int32_t clampComponent(int32_t c) {
if (c < 0) {
return 0;
}
if (c > BAS_RGB_COMPONENT_MAX) {
return BAS_RGB_COMPONENT_MAX;
}
return c;
}
// Clears the Err state (ERR, ERL and the error message).
static void clearErrorState(BasVmT *vm) {
vm->errorNumber = 0;
vm->errorLine = 0;
vm->errorMsg[0] = '\0';
}
// Closes a file channel if it is open and marks it free.
// A printer channel's spooled output goes to the printer first; false
// when that failed or was cancelled.
static bool closeChannel(BasVmT *vm, int32_t channel) {
BasFileChannelT *ch = &vm->files[channel];
bool ok = true;
if (ch->printJob) {
ok = sendSpool(vm, ch);
}
if (ch->handle) {
fclose((FILE *)ch->handle);
}
ch->handle = NULL;
ch->printJob = NULL;
ch->mode = BAS_FILE_MODE_CLOSED;
return ok;
}
// Collection members: Add item [, key] [, before] [, after], Remove
// index-or-key, Item index-or-key (the default member, name NULL) and
// Count. Arguments given as Empty count as omitted. Takes over args.
static BasVmResultE collectionAccess(BasVmT *vm, BasObjectT *coll, const char *name, BasValueT *args, int32_t argc, int32_t op) {
BasValueT result = basValEmpty();
int32_t err = 0;
int32_t pos = 0;
for (int32_t i = 0; i < argc; i++) {
derefArg(&args[i]);
}
if (!name || strcasecmp(name, BAS_COLL_ITEM) == 0) {
err = (op != BAS_MEMBER_OP_GET) ? BAS_ERR_NO_MEMBER : ((argc != 1) ? BAS_ERR_WRONG_ARGS : collectionFind(coll, args[0], &pos));
if (err == 0) {
result = basValCopy(coll->items[pos].value);
}
} else if (strcasecmp(name, BAS_COLL_COUNT) == 0) {
err = (argc != 0) ? BAS_ERR_WRONG_ARGS : 0;
result = basValLong(coll->itemCount);
} else if (strcasecmp(name, BAS_COLL_ADD) == 0) {
err = (argc < 1 || argc > BAS_COLL_ADD_ARGS) ? BAS_ERR_WRONG_ARGS : collectionAdd(coll, args, argc);
} else if (strcasecmp(name, BAS_COLL_REMOVE) == 0) {
err = (argc != 1) ? BAS_ERR_WRONG_ARGS : collectionFind(coll, args[0], &pos);
if (err == 0) {
BasCollItemT gone = coll->items[pos];
coll->itemCount--;
memmove(&coll->items[pos], &coll->items[pos + 1], (size_t)(coll->itemCount - pos) * sizeof(BasCollItemT));
basStringUnref(gone.key);
basValRelease(&gone.value);
}
} else {
err = BAS_ERR_NO_MEMBER;
}
dropArgs(args, argc);
if (err != 0) {
basValRelease(&result);
return raiseError(vm, err);
}
// Add and Remove are statements, but the caller may still want a value
if (op == BAS_MEMBER_OP_GET && !push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// Collection.Add item, key, before, after (args[1..] may be missing or
// Empty). Returns 0 or the BASIC error number. The item is copied.
static int32_t collectionAdd(BasObjectT *coll, BasValueT *args, int32_t argc) {
bool hasKey = argc > 1 && args[1].type != BAS_TYPE_EMPTY;
bool hasBefore = argc > 2 && args[2].type != BAS_TYPE_EMPTY;
bool hasAfter = argc > 3 && args[3].type != BAS_TYPE_EMPTY;
int32_t pos = coll->itemCount;
int32_t err = 0;
if (hasKey && args[1].type != BAS_TYPE_STRING) {
return BAS_ERR_TYPE_MISMATCH;
}
if (hasBefore && hasAfter) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
if (hasBefore) {
err = collectionFind(coll, args[2], &pos);
} else if (hasAfter) {
err = collectionFind(coll, args[3], &pos);
pos++;
}
if (err != 0) {
return err;
}
if (hasKey && collectionKeyPos(coll, args[1].strVal) >= 0) {
return BAS_ERR_DUPLICATE_KEY;
}
if (coll->itemCount == coll->itemCap) {
int32_t cap = coll->itemCap ? coll->itemCap * BAS_COLL_GROWTH : BAS_COLL_MIN_CAP;
BasCollItemT *items = (BasCollItemT *)realloc(coll->items, (size_t)cap * sizeof(BasCollItemT));
if (!items) {
return BAS_ERR_OUT_OF_MEMORY;
}
coll->items = items;
coll->itemCap = cap;
}
memmove(&coll->items[pos + 1], &coll->items[pos], (size_t)(coll->itemCount - pos) * sizeof(BasCollItemT));
coll->items[pos].key = hasKey ? basStringRef(args[1].strVal) : NULL;
coll->items[pos].value = basValCopy(args[0]);
coll->itemCount++;
return 0;
}
// The 0-based position of the item index (1-based) or key (a string,
// matched without regard to case) names. Returns 0 and sets *outPos,
// else the BASIC error number.
static int32_t collectionFind(const BasObjectT *coll, BasValueT index, int32_t *outPos) {
if (index.type == BAS_TYPE_STRING) {
int32_t pos = collectionKeyPos(coll, index.strVal);
if (pos < 0) {
return BAS_ERR_ILLEGAL_FUNC_CALL;
}
*outPos = pos;
return 0;
}
if (!isIntegerType(index.type) && index.type != BAS_TYPE_SINGLE && index.type != BAS_TYPE_DOUBLE) {
return BAS_ERR_TYPE_MISMATCH;
}
int32_t n = basValToInt32(index);
if (n < 1 || n > coll->itemCount) {
return BAS_ERR_SUBSCRIPT_RANGE;
}
*outPos = n - 1;
return 0;
}
// The position of the item with key (case ignored), or -1.
static int32_t collectionKeyPos(const BasObjectT *coll, const BasStringT *key) {
for (int32_t i = 0; i < coll->itemCount; i++) {
if (coll->items[i].key && basStringCompareCI(coll->items[i].key, key) == 0) {
return i;
}
}
return -1;
}
// COMMAND$(n): the whole launch argument string for n = 0, else its nth
// argument without quotes ("" when there are fewer). An argument is
// never longer than the whole string, so that sizes the result.
static BasStringT *commandArg(const char *args, int32_t n) {
const char *p = args ? args : "";
int32_t len = (int32_t)strlen(p);
if (n == 0) {
return basStringNew(p, len);
}
BasStringT *s = basStringAlloc(len + 1);
bool quoted = false;
if (s->cap <= len) {
return s;
}
for (int32_t i = 0; i < n && p; i++) {
p = dvxNextArg(p, s->data, s->cap, &quoted);
}
if (!p) {
s->data[0] = '\0';
}
s->len = (int32_t)strlen(s->data);
return s;
}
static BasCallFrameT *currentFrame(BasVmT *vm) {
if (vm->callDepth <= 0) {
// Module-level: use callStack[0] as implicit main frame
return &vm->callStack[0];
}
return &vm->callStack[vm->callDepth - 1];
}
static void defaultPrint(void *ctx, const char *text, bool newline) {
(void)ctx;
fputs(text, stdout);
if (newline) {
fputc('\n', stdout);
}
}
// Turns a ByRef argument into the value it refers to (a host method, a
// variable member or a Collection takes values).
static void derefArg(BasValueT *arg) {
if (arg->type != BAS_TYPE_REF && arg->type != BAS_TYPE_ELEM_REF) {
return;
}
BasValueT *slot = derefSlot(arg);
BasValueT v = slot ? basValCopy(*slot) : basValEmpty();
basValRelease(arg);
*arg = v;
}
// Resolves a variable slot through any ByRef indirection it holds: a plain
// slot is returned as-is, a BAS_TYPE_REF yields the referenced slot, and a
// BAS_TYPE_ELEM_REF yields the array element it names (NULL if the index
// no longer exists in that array).
static BasValueT *derefSlot(BasValueT *slot) {
if (slot->type == BAS_TYPE_REF) {
return slot->refVal;
}
if (slot->type == BAS_TYPE_ELEM_REF) {
BasArrayT *arr = slot->elemRef.arr;
if (!arr || slot->elemRef.idx < 0 || slot->elemRef.idx >= arr->totalElements) {
return NULL;
}
return &arr->elements[slot->elemRef.idx];
}
return slot;
}
// Dir$ state lives in BasVmT (vm->dirHandle/dirPattern/dirPath) so that a
// second embedded VM cannot close another VM's in-progress enumeration.
static void dirClose(BasVmT *vm) {
if (vm->dirHandle) {
closedir((DIR *)vm->dirHandle);
vm->dirHandle = NULL;
}
}
// Next Dir$ match. Like QB/VB Dir$ without a directory attribute, only
// files are returned: ".", ".." and subdirectories are skipped.
static const char *dirNext(BasVmT *vm) {
if (!vm->dirHandle) {
return NULL;
}
struct dirent *ent;
while ((ent = readdir((DIR *)vm->dirHandle)) != NULL) {
if (ent->d_name[0] == '.' && (ent->d_name[1] == '\0' || (ent->d_name[1] == '.' && ent->d_name[2] == '\0'))) {
continue;
}
if (fnmatch(vm->dirPattern, ent->d_name, FNM_CASEFOLD) != 0) {
continue;
}
char full[DVX_MAX_PATH];
struct stat st;
snprintf(full, sizeof(full), "%s/%s", vm->dirPath, ent->d_name);
if (stat(full, &st) == 0 && S_ISDIR(st.st_mode)) {
continue;
}
return ent->d_name;
}
dirClose(vm);
return NULL;
}
// Releases the top call frame without returning through it: its locals
// are released, its FOR frames dropped and the caller's statement
// boundary restored. Used when an error unwinds frames (dispatchError,
// runSubLoop's failure and shutdown paths); no out-arg copy-back and no
// error-state change, unlike popCallFrame.
static void discardFrame(BasVmT *vm) {
BasCallFrameT *frame = &vm->callStack[vm->callDepth - 1];
for (int32_t i = 0; i < frame->localCount; i++) {
basValRelease(&frame->locals[i]);
}
basValRelease(&frame->me);
forStackTrim(vm, frame->savedForDepth);
vm->gosubDepth = frame->savedGosubDepth;
vm->stmtPc = frame->savedStmtPc;
vm->stmtSp = frame->savedStmtSp;
vm->callDepth--;
}
// ON ERROR dispatch shared by basVmRun and runSubLoop. Given a failing
// step result, finds the innermost frame (never below floorDepth) whose
// ON ERROR GOTO handler can trap -- one is installed and is not already
// running; an error raised inside a running handler passes to the
// caller's handler, as in VB. When one exists, the frames above it are
// discarded, the eval stack is truncated to the failing statement's
// boundary, the frame's RESUME / RESUME NEXT targets are recorded and pc
// points at the handler; returns true. Returns false, leaving every
// frame in place for the host and debugger, when the error is untrapped.
//
// Without the unwind an error raised inside a called SUB would fire the
// outer SUB's handler but OP_RET would then pop the inner frame and resume
// after the call site (effectively RESUME NEXT semantics), which is not
// what ON ERROR promises.
static bool dispatchError(BasVmT *vm, BasVmResultE result, int32_t floorDepth, int32_t faultPc) {
if (result == BAS_VM_HALTED || result == BAS_VM_BAD_OPCODE) {
return false;
}
// Eval/call stack exhaustion bypasses runtimeError(), so give the
// handler a real ERR value instead of 0.
if (result == BAS_VM_STACK_OVERFLOW || result == BAS_VM_STACK_UNDERFLOW || result == BAS_VM_CALL_OVERFLOW) {
runtimeError(vm, BAS_ERR_OUT_OF_STACK, "Out of stack space");
}
int32_t trapDepth = vm->callDepth;
while (trapDepth > floorDepth) {
const BasCallFrameT *frame = &vm->callStack[trapDepth - 1];
if (frame->errorHandler != 0 && !frame->inHandler) {
break;
}
trapDepth--;
}
if (trapDepth <= floorDepth) {
return false;
}
// Discard the frames above the handler's. RESUME must land in the
// handler frame's code, never in a discarded callee's: the resume
// point becomes the call that led out of the handler frame.
int32_t resumeStart = faultPc;
bool unwound = false;
while (vm->callDepth > trapDepth) {
resumeStart = vm->callStack[vm->callDepth - 1].returnPc;
unwound = true;
discardFrame(vm);
}
// Release any operands the failed statement half-pushed before the
// error fired, then truncate the eval stack back to the statement
// boundary so trapped errors in a loop don't leak values and grow sp
// without bound.
while (vm->sp > vm->stmtSp) {
basValRelease(&vm->stack[--vm->sp]);
}
// The eval stack is now at the failing statement's boundary, so RESUME
// re-runs that statement from its start and RESUME NEXT continues where
// nextStatementPc says the statement ends -- never mid-statement.
BasCallFrameT *frame = &vm->callStack[trapDepth - 1];
frame->inHandler = true;
frame->resumePc = (vm->stmtPc >= 0) ? vm->stmtPc : resumeStart;
frame->resumeNextPc = nextStatementPc(vm, resumeStart, unwound);
vm->errorPc = frame->resumePc;
vm->pc = frame->errorHandler;
return true;
}
static BasVmResultE divByZero(BasVmT *vm) {
runtimeError(vm, BAS_ERR_DIV_BY_ZERO, "Division by zero");
return BAS_VM_DIV_BY_ZERO;
}
// \ and MOD of 32-bit operands (ib != 0) in 32-bit arithmetic: a 64-bit
// division is a libgcc call on the 486. ib == -1 is handled without
// dividing because INT32_MIN / -1 traps; that one quotient does not fit
// 32 bits, so the result comes back widened for the caller to promote.
static int64_t divMod32(uint8_t op, int32_t ia, int32_t ib) {
if (ib == -1) {
return (op == OP_IDIV_INT) ? -(int64_t)ia : 0;
}
return (op == OP_IDIV_INT) ? ia / ib : ia % ib;
}
// Releases count values taken off the stack.
static void dropArgs(BasValueT *args, int32_t count) {
for (int32_t i = 0; i < count; i++) {
basValRelease(&args[i]);
}
}
// Pops and releases up to count values (drains operands on an error path).
static void dropValues(BasVmT *vm, int32_t count) {
for (int32_t i = 0; i < count && vm->sp > 0; i++) {
basValRelease(&vm->stack[--vm->sp]);
}
}
// Items FOR EACH walks in group: an array's elements or a Collection's
// items. Returns 0 and sets *outCount, else the BASIC error number.
static int32_t eachCount(BasValueT group, int32_t *outCount) {
if (group.type == BAS_TYPE_ARRAY && group.arrVal) {
*outCount = group.arrVal->totalElements;
return 0;
}
if (group.type == BAS_TYPE_INSTANCE && group.instVal && group.instVal->classIdx == BAS_OBJ_COLLECTION) {
*outCount = group.instVal->itemCount;
return 0;
}
return basValIsObject(group) ? BAS_ERR_NOT_COLLECTION : BAS_ERR_TYPE_MISMATCH;
}
// An Empty operand of a binary operator takes part as "" beside a
// string and as the Integer 0 otherwise.
static void emptyOperand(BasValueT *v, BasValueT other) {
if (v->type == BAS_TYPE_EMPTY) {
*v = (other.type == BAS_TYPE_STRING) ? basValString(NULL) : basValInteger(0);
}
}
// Standard message for a runtime error number (ERROR n raises it with the
// same text the VM uses when it raises that error itself).
static const char *errorText(int32_t errNum) {
switch (errNum) {
case BAS_ERR_NEXT_WITHOUT_FOR:
return "NEXT without FOR";
case BAS_ERR_RETURN_NO_GOSUB:
return "RETURN without GOSUB";
case BAS_ERR_OUT_OF_DATA:
return "Out of DATA";
case BAS_ERR_ILLEGAL_FUNC_CALL:
return "Illegal function call";
case BAS_ERR_OVERFLOW:
return "Overflow";
case BAS_ERR_OUT_OF_MEMORY:
return "Out of memory";
case BAS_ERR_SUBSCRIPT_RANGE:
return "Subscript out of range";
case BAS_ERR_DIV_BY_ZERO:
return "Division by zero";
case BAS_ERR_TYPE_MISMATCH:
return "Type mismatch";
case BAS_ERR_OUT_OF_STRING:
return "Out of string space";
case BAS_ERR_RESUME_WITHOUT_ERR:
return "RESUME without error";
case BAS_ERR_FOR_NESTING:
return "FOR loop nesting too deep";
case BAS_ERR_OUT_OF_STACK:
return "Out of stack space";
case BAS_ERR_BAD_FILE_NUM:
return "Bad file number";
case BAS_ERR_FILE_NOT_FOUND:
return "File not found";
case BAS_ERR_BAD_FILE_MODE:
return "Bad file mode";
case BAS_ERR_DEVICE_IO:
return "Device I/O error";
case BAS_ERR_FILE_EXISTS:
return "File already exists";
case BAS_ERR_BAD_RECORD_LEN:
return "Bad record length";
case BAS_ERR_BAD_RECORD_NUM:
return "Bad record number";
case BAS_ERR_TOO_MANY_FILES:
return "Too many files";
case BAS_ERR_DEVICE_UNAVAILABLE:
return "Device unavailable";
case BAS_ERR_PATH_FILE_ACCESS:
return "Path/File access error";
case BAS_ERR_PATH_NOT_FOUND:
return "Path not found";
case BAS_ERR_OBJECT_NOT_SET:
return "Object variable not set";
case BAS_ERR_INVALID_NULL:
return "Invalid use of Null";
case BAS_ERR_OBJECT_REQUIRED:
return "Object required";
case BAS_ERR_NO_MEMBER:
return "Object doesn't support this property or method";
case BAS_ERR_WRONG_ARGS:
return "Wrong number of arguments or invalid property assignment";
case BAS_ERR_NOT_COLLECTION:
return "Object not a collection";
case BAS_ERR_DUPLICATE_KEY:
return "This key is already associated with an element of this collection";
default:
return "User-defined error";
}
}
static BasVmResultE execArith(BasVmT *vm, uint8_t op) {
BasValueT a;
BasValueT b;
if (!popPair(vm, &a, &b)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE nullRc;
if (nullOperands(vm, &a, &b, &nullRc)) {
return nullRc;
}
// Empty takes part as "" beside a string, else as 0
emptyOperand(&a, b);
emptyOperand(&b, a);
// VB behavior: + on two strings concatenates
if (op == OP_ADD_INT && a.type == BAS_TYPE_STRING && b.type == BAS_TYPE_STRING) {
BasStringT *sa = a.strVal ? a.strVal : basEmptyString;
BasStringT *sb = b.strVal ? b.strVal : basEmptyString;
BasStringT *cat = basStringConcat(sa, sb);
basValRelease(&a);
basValRelease(&b);
if (!push(vm, strValue(cat))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// Integer-integer fast path -- avoids double conversion and FPU for
// tight integer loops. Only promotes on overflow/division range.
if (op != OP_POW && op != OP_DIV_FLT && isIntegerType(a.type) && isIntegerType(b.type)) {
int32_t ia = intValue(a);
int32_t ib = intValue(b);
int64_t wide = 0;
bool handled = true;
switch (op) {
case OP_ADD_INT:
wide = (int64_t)ia + (int64_t)ib;
break;
case OP_SUB_INT:
wide = (int64_t)ia - (int64_t)ib;
break;
case OP_MUL_INT:
wide = (int64_t)ia * (int64_t)ib;
break;
case OP_IDIV_INT:
case OP_MOD_INT:
if (ib == 0) {
return divByZero(vm);
}
wide = divMod32(op, ia, ib);
break;
default:
handled = false;
break;
}
if (handled && wide >= INT32_MIN && wide <= INT32_MAX) {
if (!push(vm, intResult((int32_t)wide))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
}
// Capture operand types BEFORE release so we know whether to keep
// the result as a float. The parser always emits OP_ADD_INT (the
// VM promotes based on operand types), so the opcode alone can't
// tell us whether this is an integer or floating-point op.
uint8_t aType = a.type;
uint8_t bType = b.type;
bool aDate = (aType == BAS_TYPE_DATE);
bool bDate = (bType == BAS_TYPE_DATE);
bool hadFloat = (aType == BAS_TYPE_SINGLE || aType == BAS_TYPE_DOUBLE || bType == BAS_TYPE_SINGLE || bType == BAS_TYPE_DOUBLE || aDate || bDate);
// A DATE takes part as its instant on the linear time line, so adding
// days to a date before 12/30/1899 keeps its time of day.
double na = aDate ? basDateToLinear(a.dblVal) : basValToNumber(a);
double nb = bDate ? basDateToLinear(b.dblVal) : basValToNumber(b);
basValRelease(&a);
basValRelease(&b);
double result;
switch (op) {
case OP_ADD_INT:
result = na + nb;
break;
case OP_SUB_INT:
result = na - nb;
break;
case OP_MUL_INT:
result = na * nb;
break;
case OP_IDIV_INT:
case OP_MOD_INT: {
// \ and MOD round their operands to LONG first (11.5 \ 2 = 6,
// 7.5 MOD 2 = 0) and raise Overflow when they do not fit.
int32_t ia;
int32_t ib;
BasVmResultE rc = roundedOperand(vm, basValDouble(na), &ia);
if (rc != BAS_VM_OK) {
return rc;
}
rc = roundedOperand(vm, basValDouble(nb), &ib);
if (rc != BAS_VM_OK) {
return rc;
}
if (ib == 0) {
return divByZero(vm);
}
result = (double)divMod32(op, ia, ib);
break;
}
case OP_DIV_FLT:
if (nb == 0.0) {
return divByZero(vm);
}
result = na / nb;
break;
case OP_POW:
result = pow(na, nb);
break;
default:
result = 0.0;
break;
}
// BASIC never yields infinity or NaN: an out-of-range result is an
// Overflow, an undefined one (negative base, fractional power) an
// Illegal function call.
if (!isfinite(result)) {
return mathRangeError(vm, result);
}
// Return appropriate type. An op that would normally produce an
// integer result (OP_ADD_INT, etc.) still has to yield a float when
// either operand was a float -- otherwise 1.5 + 2.25 truncates to 3.
bool intOp = (op == OP_ADD_INT || op == OP_SUB_INT || op == OP_MUL_INT || op == OP_IDIV_INT || op == OP_MOD_INT);
// DATE + n, n + DATE and DATE - n are dates; DATE - DATE is the number
// of days between them.
if ((op == OP_ADD_INT && (aDate || bDate)) || (op == OP_SUB_INT && aDate && !bDate)) {
double serial;
if (!basDateFromLinear(result, &serial)) {
return raiseError(vm, BAS_ERR_OVERFLOW);
}
if (!push(vm, basValDate(serial))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
if (!push(vm, (intOp && !hadFloat) ? integralValue(result) : basValDouble(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// OP_BUILTIN: [uint8 fn] [uint8 argc]. Pops the arguments (pushed in
// source order), fills in omitted optional ones and pushes the result.
static BasVmResultE execBuiltin(BasVmT *vm) {
uint8_t fn = readUint8(vm);
int32_t argc = readUint8(vm);
int32_t minArgs = 0;
int32_t maxArgs = 0;
BasValueT args[BAS_BUILTIN_MAX_ARGS];
if (!basBuiltinArity(fn, &minArgs, &maxArgs) || argc < minArgs || argc > maxArgs) {
dropValues(vm, argc);
runtimeError(vm, BAS_ERR_BAD_OPCODE, "Bad opcode");
return BAS_VM_BAD_OPCODE;
}
if (vm->sp < argc) {
return BAS_VM_STACK_UNDERFLOW;
}
// Take ownership of the arguments straight off the stack
vm->sp -= argc;
memcpy(args, &vm->stack[vm->sp], (size_t)argc * sizeof(BasValueT));
argc = builtinDefaults(fn, args, argc);
// The date functions are numbered NOW through WEEKDAYNAME, the program
// screen's BAS_FN_SCREEN_FIRST through _LAST.
BasValueT result = basValInteger(0);
int32_t err = 0;
if (fn >= BAS_FN_NOW && fn <= BAS_FN_WEEKDAYNAME) {
err = builtinDate(fn, args, &result);
} else if (fn >= BAS_FN_OBJECT_FIRST && fn <= BAS_FN_OBJECT_LAST) {
err = builtinObject(vm, fn, args, &result);
} else if (fn >= BAS_FN_SCREEN_FIRST && fn <= BAS_FN_SCREEN_LAST) {
err = basScreenExec(vm, fn, args, argc, &result);
} else {
err = builtinString(vm, fn, args, argc, &result);
}
for (int32_t i = 0; i < argc; i++) {
basValRelease(&args[i]);
}
if (err != 0) {
return raiseError(vm, err);
}
if (!push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// OP_CALL / OP_CALL_ME: [uint16 addr] [uint8 argc] [uint8 baseSlot]. The
// arguments move from the stack into the callee's locals; keepMe hands
// the caller's Me on (a class calling one of its own procedures).
static BasVmResultE execCall(BasVmT *vm, bool keepMe) {
uint16_t addr = readUint16(vm);
uint8_t argc = readUint8(vm);
uint8_t baseSlot = readUint8(vm);
// Guard the locals window: baseSlot and argc come straight from
// bytecode, and a corrupt module could otherwise make the arg copy
// below write past locals[]. Drain the pushed args first so the eval
// stack stays balanced.
if ((int32_t)baseSlot + (int32_t)argc > BAS_VM_MAX_LOCALS) {
dropValues(vm, argc);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "CALL argument slots out of range");
return BAS_VM_ERROR;
}
if (vm->callDepth >= BAS_VM_CALL_STACK_SIZE) {
return BAS_VM_CALL_OVERFLOW;
}
BasValueT me = keepMe ? basValCopy(currentFrame(vm)->me) : basValEmpty();
BasCallFrameT *frame = pushFrame(vm, vm->pc, addr, baseSlot + argc);
frame->me = me;
// Pop arguments into locals starting at baseSlot (in reverse order). A
// BYVAL TYPE argument must be the callee's own copy.
for (int32_t i = baseSlot + argc - 1; i >= baseSlot; i--) {
if (!pop(vm, &frame->locals[i])) {
return BAS_VM_STACK_UNDERFLOW;
}
frame->locals[i] = udtDetach(frame->locals[i]);
}
// The callee starts with no handler; if it raises an error the
// dispatcher will unwind to the nearest frame with one.
vm->pc = addr;
return BAS_VM_OK;
}
static BasVmResultE execCompare(BasVmT *vm, uint8_t op) {
BasValueT a;
BasValueT b;
if (!popPair(vm, &a, &b)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasVmResultE nullRc;
if (nullOperands(vm, &a, &b, &nullRc)) {
return nullRc;
}
int32_t cmp;
// Same-type integer fast path: loop conditions like i < n hit this on
// every iteration. Skip basValCompare's mixed-type handling.
if (a.type == BAS_TYPE_INTEGER && b.type == BAS_TYPE_INTEGER) {
cmp = (a.intVal < b.intVal) ? -1 : (a.intVal > b.intVal ? 1 : 0);
} else if (a.type == BAS_TYPE_LONG && b.type == BAS_TYPE_LONG) {
cmp = (a.longVal < b.longVal) ? -1 : (a.longVal > b.longVal ? 1 : 0);
} else {
cmp = vm->compareTextMode ? basValCompareCI(a, b) : basValCompare(a, b);
}
basValRelease(&a);
basValRelease(&b);
bool result;
switch (op) {
case OP_CMP_EQ:
result = (cmp == 0);
break;
case OP_CMP_NE:
result = (cmp != 0);
break;
case OP_CMP_LT:
result = (cmp < 0);
break;
case OP_CMP_GT:
result = (cmp > 0);
break;
case OP_CMP_LE:
result = (cmp <= 0);
break;
case OP_CMP_GE:
result = (cmp >= 0);
break;
default:
result = false;
break;
}
if (!push(vm, basValBool(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// The conversion opcodes (CINT, CLNG, CSNG, CDBL, CSTR, CDATE, CBOOL and
// the conversions stores into typed variables make), on the value on top
// of the stack.
static BasVmResultE execConvert(BasVmT *vm, uint8_t op) {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT conv = *top;
int32_t n = 0;
switch (op) {
case OP_CONV_INT_FLT:
conv = basValSingle((float)basValToNumber(*top));
break;
case OP_CONV_FLT_INT:
case OP_CONV_STR_INT:
if (!basValRoundToInt32(*top, INT16_MIN, INT16_MAX, &n)) {
return raiseError(vm, BAS_ERR_OVERFLOW);
}
conv = basValInteger((int16_t)n);
break;
case OP_CONV_INT_STR:
conv = basValToString(*top);
break;
case OP_CONV_STR_FLT:
conv = basValToDouble(*top);
break;
case OP_CONV_INT_LONG:
if (!basValRoundToInt32(*top, INT32_MIN, INT32_MAX, &n)) {
return raiseError(vm, BAS_ERR_OVERFLOW);
}
conv = basValLong(n);
break;
case OP_CONV_DATE: {
double serial = 0.0;
int32_t err = basValToDateSerial(*top, &serial);
if (err != 0) {
return raiseError(vm, err);
}
conv = basValDate(serial);
break;
}
case OP_CONV_BOOL:
conv = basValBool((top->type == BAS_TYPE_STRING) ? (top->strVal && top->strVal->len > 0) : (basValToNumber(*top) != 0.0));
break;
default:
return BAS_VM_OK;
}
basValRelease(top);
*top = conv;
return BAS_VM_OK;
}
// BEEP, SOUND, PLAY, PLAY(n), STICK, STRIG and FRAMEWAIT through the
// host's device callbacks (BasDeviceCallbacksT), with QBasic's argument
// ranges. The statements then wait, keeping the host's events running,
// for as long as the host says.
static BasVmResultE execDevice(BasVmT *vm, uint8_t op) {
const BasDeviceCallbacksT *d = &vm->device;
BasValueT a;
BasValueT b;
switch (op) {
case OP_BEEP:
if (d->beep) {
d->beep(d->ctx);
}
break;
case OP_SOUND: {
if (!popArgs(vm, 2, &b, &a)) {
return BAS_VM_STACK_UNDERFLOW;
}
double hz = basValToNumber(a);
double ticks = basValToNumber(b);
basValRelease(&a);
basValRelease(&b);
if (hz < BAS_SOUND_HZ_MIN || hz > BAS_SOUND_HZ_MAX || ticks < 0.0 || ticks > BAS_SOUND_TICKS_MAX) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
if (d->sound) {
d->sound(d->ctx, hz, ticks);
}
break;
}
case OP_PLAY: {
if (!popStringArg(vm, &a)) {
return BAS_VM_STACK_UNDERFLOW;
}
bool ok = !d->play || d->play(d->ctx, a.strVal->data);
basValRelease(&a);
if (!ok) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call (a mistake in the PLAY string)");
return BAS_VM_ERROR;
}
break;
}
case OP_FRAME_WAIT: {
if (!pop(vm, &a)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t hz = basValToInt32(a);
basValRelease(&a);
if (hz < 1) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
if (!d->frameStart || !d->frameBusy) {
runtimeError(vm, BAS_ERR_DEVICE_UNAVAILABLE, errorText(BAS_ERR_DEVICE_UNAVAILABLE));
return BAS_VM_ERROR;
}
d->frameStart(d->ctx, hz);
if (!waitWhile(vm, d->frameBusy)) {
vm->running = false;
return BAS_VM_HALTED;
}
return BAS_VM_OK;
}
default: {
// PLAY(n), STICK(n), STRIG(n): one argument, one result
if (!pop(vm, &a)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t n = basValToInt32(a);
int32_t result = 0;
basValRelease(&a);
if ((op == OP_STICK && (n < 0 || n >= BAS_STICK_COUNT)) || (op == OP_STRIG && (n < 0 || n >= BAS_STRIG_COUNT))) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
if (op == OP_PLAY_COUNT && d->playCount) {
result = d->playCount(d->ctx);
} else if (op == OP_STICK && d->stick) {
result = d->stick(d->ctx, n);
} else if (op == OP_STRIG && d->strig) {
result = d->strig(d->ctx, n);
}
return push(vm, basValLong(result)) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
}
// BEEP, SOUND and PLAY wait while the music is in the foreground.
if (d->soundBusy && !waitWhile(vm, d->soundBusy)) {
vm->running = false;
return BAS_VM_HALTED;
}
return BAS_VM_OK;
}
static BasVmResultE execFileOp(BasVmT *vm, uint8_t op) {
switch (op) {
case OP_FILE_OPEN: {
uint8_t mode = readUint8(vm);
BasValueT recLenVal;
if (!pop(vm, &recLenVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t recLen = basValToInt32(recLenVal);
basValRelease(&recLenVal);
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, false);
if (chResult != BAS_VM_OK) {
// popFileChannel consumed only the channel; the filename
// operand below it must come off too or the untrapped error
// path strands it on the eval stack. A channel underflow
// means the stack was empty, so this drop is a no-op there.
dropValues(vm, 1);
return chResult;
}
BasValueT fnStr;
if (!popStringArg(vm, &fnStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (recLen < 1 || recLen > BAS_VM_MAX_RECORD_LEN) {
basValRelease(&fnStr);
runtimeError(vm, BAS_ERR_BAD_RECORD_LEN, "Bad record length");
return BAS_VM_FILE_ERROR;
}
const char *modeStr;
switch (mode) {
case BAS_FILE_MODE_INPUT:
modeStr = "rb";
break;
case BAS_FILE_MODE_OUTPUT:
modeStr = "wb";
break;
case BAS_FILE_MODE_APPEND:
modeStr = "ab";
break;
case BAS_FILE_MODE_RANDOM:
case BAS_FILE_MODE_BINARY:
modeStr = "r+b";
break;
default:
basValRelease(&fnStr);
runtimeError(vm, BAS_ERR_BAD_FILE_MODE, "Bad file mode");
return BAS_VM_FILE_ERROR;
}
int32_t port;
if (printerDevice(fnStr.strVal->data, &port)) {
basValRelease(&fnStr);
return openPrinterChannel(vm, channel, port, mode, recLen);
}
// A valid OPEN replaces whatever the channel had open
closeChannel(vm, channel);
// For RANDOM/BINARY: create file if it doesn't exist, then reopen r+b
if (mode == BAS_FILE_MODE_RANDOM || mode == BAS_FILE_MODE_BINARY) {
FILE *test = fopen(fnStr.strVal->data, "r");
if (!test) {
// Create the file
test = fopen(fnStr.strVal->data, "w+b");
}
if (test) {
fclose(test);
}
}
FILE *fp = fopen(fnStr.strVal->data, modeStr);
basValRelease(&fnStr);
if (!fp) {
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found or cannot open");
return BAS_VM_FILE_ERROR;
}
vm->files[channel].handle = fp;
vm->files[channel].mode = mode;
vm->files[channel].recLen = recLen;
break;
}
case OP_FILE_CLOSE: {
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, false);
if (chResult != BAS_VM_OK) {
return chResult;
}
if (!closeChannel(vm, channel)) {
runtimeError(vm, BAS_ERR_DEVICE_IO, errorText(BAS_ERR_DEVICE_IO));
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FILE_PRINT: {
// Writes one value without a trailing newline. The parser emits
// OP_FILE_WRITE_NL separately when the PRINT statement finishes
// without a trailing ; so multi-value PRINT with `;` separator
// works correctly. Values are formatted exactly as PRINT does.
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
basValRelease(&val);
return chResult;
}
BasStringT *s = basValPrintString(val);
basValRelease(&val);
fwrite(s->data, 1, s->len, (FILE *)vm->files[channel].handle);
basStringUnref(s);
break;
}
case OP_FILE_INPUT:
case OP_FILE_LINE_INPUT: {
// INPUT # reads one comma-delimited, optionally quoted field;
// LINE INPUT # reads the whole line. Neither has a length cap.
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
FILE *fp = (FILE *)vm->files[channel].handle;
BasStringT *s = (op == OP_FILE_INPUT) ? readField(fp) : readLine(fp);
if (!push(vm, strValue(s))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_EOF: {
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
FILE *fp = (FILE *)vm->files[channel].handle;
bool isEof;
if (vm->files[channel].mode == BAS_FILE_MODE_INPUT) {
// Peek one byte: no seek, so the stdio read buffer survives
// the usual DO WHILE NOT EOF(n) loop.
int32_t c = fgetc(fp);
isEof = (c == EOF);
if (!isEof) {
ungetc(c, fp);
}
} else {
// Read/write channels: a read-ahead would need a seek before
// the next write, so compare against the end instead.
long curPos = ftell(fp);
fseek(fp, 0, SEEK_END);
long endPos = ftell(fp);
fseek(fp, curPos, SEEK_SET);
isEof = (curPos >= endPos);
}
if (!push(vm, basValBool(isEof))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_WRITE: {
// Pop value and channel, write value in WRITE format
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
basValRelease(&val);
return chResult;
}
FILE *fp = (FILE *)vm->files[channel].handle;
// Numbers: no leading space (unlike PRINT). Strings and
// dates: enclosed in quotes, so INPUT # reads a date back whole.
BasStringT *s = basValFormatString(val);
bool quoted = (val.type == BAS_TYPE_STRING || val.type == BAS_TYPE_DATE);
if (quoted) {
fputc('"', fp);
}
fwrite(s->data, 1, s->len, fp);
if (quoted) {
fputc('"', fp);
}
basStringUnref(s);
basValRelease(&val);
break;
}
case OP_FILE_WRITE_SEP:
case OP_FILE_WRITE_NL: {
// Pop channel, write the comma separator or record newline
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
fputc((op == OP_FILE_WRITE_SEP) ? ',' : '\n', (FILE *)vm->files[channel].handle);
break;
}
case OP_FILE_GET: {
// Pop type, [current string value | udt + layout], recno,
// channel; read data; push value. A STRING target carries
// its current value so BINARY mode knows how many bytes to
// read; a TYPE target carries the instance to fill in place
// and the compiler's field layout.
BasValueT typeVal;
if (!pop(vm, &typeVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t dataType = basValToInt32(typeVal);
int32_t strLen = 0;
BasValueT udtVal;
BasValueT layoutVal;
basValRelease(&typeVal);
memset(&udtVal, 0, sizeof(udtVal));
memset(&layoutVal, 0, sizeof(layoutVal));
if (dataType == BAS_TYPE_STRING) {
BasValueT curVal;
if (!pop(vm, &curVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
strLen = (curVal.type == BAS_TYPE_STRING && curVal.strVal) ? curVal.strVal->len : 0;
basValRelease(&curVal);
} else if (dataType == BAS_TYPE_UDT) {
if (!popArgs(vm, 2, &layoutVal, &udtVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (layoutVal.type != BAS_TYPE_STRING || !layoutVal.strVal || udtVal.type != BAS_TYPE_UDT || !udtVal.udtVal) {
basValRelease(&layoutVal);
basValRelease(&udtVal);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
}
BasValueT recnoVal;
if (!pop(vm, &recnoVal)) {
basValRelease(&layoutVal);
basValRelease(&udtVal);
return BAS_VM_STACK_UNDERFLOW;
}
int32_t recno = basValToInt32(recnoVal);
basValRelease(&recnoVal);
int32_t channel;
long start = 0;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult == BAS_VM_OK) {
chResult = recordBegin(vm, channel, recno, &start);
}
if (chResult != BAS_VM_OK) {
basValRelease(&layoutVal);
basValRelease(&udtVal);
return chResult;
}
FILE *fp = (FILE *)vm->files[channel].handle;
BasValueT result;
switch (dataType) {
case BAS_TYPE_INTEGER:
case BAS_TYPE_LONG:
case BAS_TYPE_SINGLE:
case BAS_TYPE_DOUBLE:
case BAS_TYPE_BOOLEAN:
result = ioReadScalar(fp, (uint8_t)dataType);
break;
case BAS_TYPE_STRING:
// BINARY reads as many raw bytes as the variable
// already holds (QB semantics); RANDOM records carry
// an int16 length prefix written by PUT.
if (vm->files[channel].mode == BAS_FILE_MODE_BINARY) {
result = strValue(ioReadBytes(fp, strLen, false));
} else {
result = strValue(ioReadPrefixedString(fp));
}
break;
case BAS_TYPE_UDT: {
int32_t pos = 0;
BasVmResultE rc = udtGet(vm, fp, udtVal.udtVal, layoutVal.strVal, &pos, 0);
basValRelease(&layoutVal);
if (rc != BAS_VM_OK) {
basValRelease(&udtVal);
return rc;
}
result = udtVal;
break;
}
default:
result = basValInteger(0);
break;
}
BasVmResultE endResult = recordEnd(vm, channel, start, false);
if (endResult != BAS_VM_OK) {
basValRelease(&result);
return endResult;
}
if (!push(vm, result)) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_PUT:
case OP_FILE_PUT_UDT: {
// PUT: pop value, recno, channel. PUT_UDT: pop layout, udt,
// recno, channel. The record is measured first so a value
// longer than a RANDOM record raises error 59 before a single
// byte is written over the next record.
BasValueT layoutVal;
BasValueT val;
BasValueT recnoVal;
memset(&layoutVal, 0, sizeof(layoutVal));
if (op == OP_FILE_PUT_UDT && !pop(vm, &layoutVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popArgs(vm, 2, &val, &recnoVal)) {
basValRelease(&layoutVal);
return BAS_VM_STACK_UNDERFLOW;
}
int32_t recno = basValToInt32(recnoVal);
basValRelease(&recnoVal);
int32_t channel;
BasVmResultE rc = popFileChannel(vm, &channel, true);
if (rc == BAS_VM_OK && op == OP_FILE_PUT_UDT && (layoutVal.type != BAS_TYPE_STRING || !layoutVal.strVal || val.type != BAS_TYPE_UDT || !val.udtVal)) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
rc = BAS_VM_TYPE_MISMATCH;
}
BasPutSinkT measure = { NULL, 0 };
if (rc == BAS_VM_OK) {
rc = putValue(vm, &measure, vm->files[channel].mode, val, layoutVal.strVal);
}
if (rc == BAS_VM_OK && vm->files[channel].mode == BAS_FILE_MODE_RANDOM && measure.bytes > vm->files[channel].recLen) {
runtimeError(vm, BAS_ERR_BAD_RECORD_LEN, "Record longer than LEN");
rc = BAS_VM_FILE_ERROR;
}
long start = 0;
if (rc == BAS_VM_OK) {
rc = recordBegin(vm, channel, recno, &start);
}
if (rc == BAS_VM_OK) {
BasPutSinkT out = { (FILE *)vm->files[channel].handle, 0 };
putValue(vm, &out, vm->files[channel].mode, val, layoutVal.strVal);
rc = recordEnd(vm, channel, start, true);
}
basValRelease(&layoutVal);
basValRelease(&val);
return rc;
}
case OP_FILE_SEEK: {
// SEEK #n, pos: a record number on RANDOM channels, a byte
// position otherwise; both are 1-based.
BasValueT posVal;
if (!pop(vm, &posVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t pos = basValToInt32(posVal);
basValRelease(&posVal);
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
if (pos < 1) {
runtimeError(vm, BAS_ERR_BAD_RECORD_NUM, "Bad record number");
return BAS_VM_FILE_ERROR;
}
return seekRecord(vm, channel, pos);
}
case OP_FILE_LOF: {
// Pop channel, push file length
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
FILE *fp = (FILE *)vm->files[channel].handle;
long savedPos = ftell(fp);
fseek(fp, 0, SEEK_END);
long length = ftell(fp);
fseek(fp, savedPos, SEEK_SET);
if (!push(vm, basValLong((int32_t)length))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_SEEK_GET: {
// SEEK(n): the 1-based record number the next GET/PUT uses on a
// RANDOM channel, the 1-based byte position otherwise.
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
long pos = ftell((FILE *)vm->files[channel].handle);
if (vm->files[channel].mode == BAS_FILE_MODE_RANDOM) {
pos /= vm->files[channel].recLen;
}
if (!push(vm, basValLong((int32_t)(pos + 1)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_LOC: {
// Pop channel, push LOC
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
return chResult;
}
// QB: BINARY reports the last byte read or written, RANDOM the
// last record number, sequential modes the 128-byte block count.
long pos = ftell((FILE *)vm->files[channel].handle);
int32_t loc;
if (vm->files[channel].mode == BAS_FILE_MODE_BINARY) {
loc = (int32_t)pos;
} else if (vm->files[channel].mode == BAS_FILE_MODE_RANDOM) {
loc = (int32_t)(pos / vm->files[channel].recLen);
} else {
loc = (int32_t)(pos / BAS_LOC_SEQ_BLOCK);
}
if (!push(vm, basValLong(loc))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_FREEFILE: {
// Push the next available file channel number
int32_t freeNum = 0;
for (int32_t i = 1; i < BAS_VM_MAX_FILES; i++) {
if (!vm->files[i].handle) {
freeNum = i;
break;
}
}
if (freeNum == 0) {
runtimeError(vm, BAS_ERR_TOO_MANY_FILES, "Too many files open");
return BAS_VM_FILE_ERROR;
}
if (!push(vm, basValInteger((int16_t)freeNum))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FILE_INPUT_N: {
// Pop channel and n, read n chars, push string
int32_t channel;
BasVmResultE chResult = popFileChannel(vm, &channel, true);
if (chResult != BAS_VM_OK) {
// Same shape as OP_FILE_OPEN: the count operand below the
// channel must be drained on the error path.
dropValues(vm, 1);
return chResult;
}
BasValueT nVal;
if (!pop(vm, &nVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t n = basValToInt32(nVal);
basValRelease(&nVal);
if (n < 0 || n > BAS_STRING_FUNC_MAX) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
if (!push(vm, strValue(ioReadBytes((FILE *)vm->files[channel].handle, n, false)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
default:
return BAS_VM_BAD_OPCODE;
}
return BAS_VM_OK;
}
static BasVmResultE execFsOp(BasVmT *vm, uint8_t op) {
switch (op) {
case OP_FS_KILL: {
BasValueT fnStr;
if (!popStringArg(vm, &fnStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t rc = remove(fnStr.strVal->data);
basValRelease(&fnStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_NAME: {
BasValueT newStr;
BasValueT oldStr;
if (!popStringArg(vm, &newStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &oldStr)) {
basValRelease(&newStr);
return BAS_VM_STACK_UNDERFLOW;
}
int32_t rc = rename(oldStr.strVal->data, newStr.strVal->data);
basValRelease(&oldStr);
basValRelease(&newStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_FILE_EXISTS, "File already exists or rename failed");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_FILECOPY: {
BasValueT dstStr;
BasValueT srcStr;
if (!popStringArg(vm, &dstStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &srcStr)) {
basValRelease(&dstStr);
return BAS_VM_STACK_UNDERFLOW;
}
bool copied = platformCopyFile(srcStr.strVal->data, dstStr.strVal->data);
basValRelease(&srcStr);
basValRelease(&dstStr);
if (!copied) {
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found or cannot create destination");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_MKDIR: {
BasValueT pathStr;
if (!popStringArg(vm, &pathStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
#ifdef _WIN32
int32_t rc = mkdir(pathStr.strVal->data);
#else
int32_t rc = mkdir(pathStr.strVal->data, BAS_MKDIR_MODE);
#endif
basValRelease(&pathStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_PATH_FILE_ACCESS, "Path/File access error");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_RMDIR: {
BasValueT pathStr;
if (!popStringArg(vm, &pathStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t rc = rmdir(pathStr.strVal->data);
basValRelease(&pathStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_PATH_FILE_ACCESS, "Path/File access error");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_CHDIR: {
BasValueT pathStr;
if (!popStringArg(vm, &pathStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t rc = platformChdir(pathStr.strVal->data);
basValRelease(&pathStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_PATH_NOT_FOUND, "Path not found");
return BAS_VM_FILE_ERROR;
}
break;
}
case OP_FS_CHDRIVE: {
BasValueT driveStr;
if (!popStringArg(vm, &driveStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
// Drive letters are a DOS-ism; platformChdir is a no-op on
// platforms without them.
if (driveStr.strVal->data[0]) {
char drivePath[4];
drivePath[0] = driveStr.strVal->data[0];
drivePath[1] = ':';
drivePath[2] = '\0';
platformChdir(drivePath);
}
basValRelease(&driveStr);
break;
}
case OP_FS_CURDIR: {
char cwd[DVX_MAX_PATH];
if (!getcwd(cwd, sizeof(cwd))) {
cwd[0] = '\0';
}
if (!push(vm, basValStringFromC(cwd))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FS_DIR: {
BasValueT patStr;
if (!popStringArg(vm, &patStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
dirClose(vm);
// Split pattern into directory + filename pattern
const char *pat = patStr.strVal->data;
const char *lastSep = NULL;
for (const char *c = pat; *c; c++) {
if (*c == '/' || *c == '\\') {
lastSep = c;
}
}
if (lastSep) {
int32_t dirLen = (int32_t)(lastSep - pat);
if (dirLen >= (int32_t)sizeof(vm->dirPath)) {
dirLen = (int32_t)sizeof(vm->dirPath) - 1;
}
memcpy(vm->dirPath, pat, dirLen);
vm->dirPath[dirLen] = '\0';
snprintf(vm->dirPattern, sizeof(vm->dirPattern), "%s", lastSep + 1);
} else {
snprintf(vm->dirPath, sizeof(vm->dirPath), ".");
snprintf(vm->dirPattern, sizeof(vm->dirPattern), "%s", pat);
}
basValRelease(&patStr);
if (vm->dirPattern[0] == '\0') {
snprintf(vm->dirPattern, sizeof(vm->dirPattern), "*");
}
vm->dirHandle = opendir(vm->dirPath);
if (!push(vm, basValStringFromC(dirNext(vm)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FS_DIR_NEXT: {
if (!push(vm, basValStringFromC(dirNext(vm)))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FS_FILELEN: {
BasValueT fnStr;
if (!popStringArg(vm, &fnStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
struct stat st;
int32_t rc = stat(fnStr.strVal->data, &st);
basValRelease(&fnStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found");
return BAS_VM_FILE_ERROR;
}
if (!push(vm, basValLong((int32_t)st.st_size))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FS_GETATTR: {
BasValueT fnStr;
if (!popStringArg(vm, &fnStr)) {
return BAS_VM_STACK_UNDERFLOW;
}
struct stat st;
int32_t attrs = 0;
int32_t rc = stat(fnStr.strVal->data, &st);
basValRelease(&fnStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found");
return BAS_VM_FILE_ERROR;
}
if (S_ISDIR(st.st_mode)) {
attrs |= BAS_ATTR_DIRECTORY;
}
if (!(st.st_mode & S_IWUSR)) {
attrs |= BAS_ATTR_READONLY;
}
if (!push(vm, basValInteger((int16_t)attrs))) {
return BAS_VM_STACK_OVERFLOW;
}
break;
}
case OP_FS_SETATTR: {
BasValueT attrVal;
BasValueT fnStr;
if (!pop(vm, &attrVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &fnStr)) {
basValRelease(&attrVal);
return BAS_VM_STACK_UNDERFLOW;
}
int32_t attrs = basValToInt32(attrVal);
basValRelease(&attrVal);
struct stat st;
if (stat(fnStr.strVal->data, &st) != 0) {
basValRelease(&fnStr);
runtimeError(vm, BAS_ERR_FILE_NOT_FOUND, "File not found");
return BAS_VM_FILE_ERROR;
}
mode_t mode = st.st_mode;
if (attrs & BAS_ATTR_READONLY) {
mode &= ~(S_IWUSR | S_IWGRP | S_IWOTH);
} else {
mode |= S_IWUSR;
}
int32_t rc = chmod(fnStr.strVal->data, mode);
basValRelease(&fnStr);
if (rc != 0) {
runtimeError(vm, BAS_ERR_PATH_FILE_ACCESS, "Path/File access error");
return BAS_VM_FILE_ERROR;
}
break;
}
default:
return BAS_VM_BAD_OPCODE;
}
return BAS_VM_OK;
}
static BasVmResultE execLogical(BasVmT *vm, uint8_t op) {
// Bitwise operators work on LONG operands: round (never truncate) so
// NOT 0.6 is NOT 1 = -2, and raise Overflow when a value does not fit.
if (op == OP_NOT) {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
int32_t n;
// NOT Null is Null
if (top->type == BAS_TYPE_NULL) {
return BAS_VM_OK;
}
BasVmResultE rc = roundedOperand(vm, *top, &n);
if (rc != BAS_VM_OK) {
return rc;
}
basValRelease(top);
int32_t r = ~n;
// Promote to LONG when the result exceeds INTEGER range, matching
// execArith -- truncation corrupts LONG masks like NOT &H10000.
*top = intResult(r);
return BAS_VM_OK;
}
BasValueT a;
BasValueT b;
if (!popPair(vm, &a, &b)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (a.type == BAS_TYPE_NULL || b.type == BAS_TYPE_NULL) {
return logicalNull(vm, op, a, b);
}
int32_t na;
int32_t nb;
BasVmResultE rc = roundedOperand(vm, a, &na);
if (rc == BAS_VM_OK) {
rc = roundedOperand(vm, b, &nb);
}
basValRelease(&a);
basValRelease(&b);
if (rc != BAS_VM_OK) {
return rc;
}
int32_t result;
switch (op) {
case OP_AND:
result = na & nb;
break;
case OP_OR:
result = na | nb;
break;
case OP_XOR:
result = na ^ nb;
break;
case OP_EQV:
result = ~(na ^ nb);
break;
case OP_IMP:
result = (~na) | nb;
break;
default:
result = 0;
break;
}
// Promote to LONG when the result exceeds INTEGER range, matching
// execArith -- truncation corrupts LONG masks like c& AND &HFF0000.
if (!push(vm, intResult(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
// LPRINT statement start (open the program's print job on first use)
// and end (report a failed or cancelled output; the job is closed so
// the next LPRINT starts a new one).
static BasVmResultE execLprint(BasVmT *vm, uint8_t phase) {
if (phase == BAS_LPRINT_BEGIN) {
if (!vm->lprintJob && vm->printer.open) {
vm->lprintJob = vm->printer.open(vm->printer.ctx, BAS_PRINTER_DEFAULT);
}
if (!vm->lprintJob) {
runtimeError(vm, BAS_ERR_DEVICE_UNAVAILABLE, errorText(BAS_ERR_DEVICE_UNAVAILABLE));
return BAS_VM_FILE_ERROR;
}
vm->lprinting = true;
vm->lprintFailed = false;
return BAS_VM_OK;
}
vm->lprinting = false;
if (vm->lprintFailed) {
vm->printer.close(vm->printer.ctx, vm->lprintJob);
vm->lprintJob = NULL;
vm->lprintColumn = 0;
runtimeError(vm, BAS_ERR_DEVICE_IO, errorText(BAS_ERR_DEVICE_IO));
return BAS_VM_FILE_ERROR;
}
return BAS_VM_OK;
}
static BasVmResultE execMath(BasVmT *vm, uint8_t op) {
if (op == OP_MATH_RND) {
// QBasic RND(n): n > 0 the next number, n = 0 the last one again,
// n < 0 reseeds from n first (the same n always gives the same
// number). The result is a DOUBLE in [0, 1).
BasValueT argVal;
if (!pop(vm, &argVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
double n = basValToNumber(argVal);
basValRelease(&argVal);
if (n < 0) {
seedRandom(n * BAS_RND_SEED_SPREAD);
}
if (n != 0) {
vm->rndLast = (double)rand() / BAS_RND_SCALE;
}
if (!push(vm, basValDouble(vm->rndLast))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
if (op == OP_MATH_RANDOMIZE) {
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
double n = basValToNumber(val);
basValRelease(&val);
if (n == BAS_RANDOMIZE_TIMER_SEED) {
srand((unsigned int)time(NULL));
} else {
seedRandom(n);
}
return BAS_VM_OK;
}
// All other math ops take one argument
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
// ABS, INT, FIX and SGN of Null are Null
if (top->type == BAS_TYPE_NULL && (op == OP_MATH_ABS || op == OP_MATH_INT || op == OP_MATH_FIX || op == OP_MATH_SGN)) {
return BAS_VM_OK;
}
double n = basValToNumber(*top);
double result;
// Domain errors are Illegal function call in BASIC, never NaN.
if ((op == OP_MATH_SQR && n < 0) || (op == OP_MATH_LOG && n <= 0)) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
switch (op) {
case OP_MATH_ABS:
result = fabs(n);
break;
case OP_MATH_INT:
result = floor(n);
break;
case OP_MATH_FIX:
result = (n >= 0) ? floor(n) : ceil(n);
break;
case OP_MATH_SGN:
result = (n > 0) ? 1.0 : (n < 0) ? -1.0 : 0.0;
break;
case OP_MATH_SQR:
result = sqrt(n);
break;
case OP_MATH_SIN:
result = sin(n);
break;
case OP_MATH_COS:
result = cos(n);
break;
case OP_MATH_TAN:
result = tan(n);
break;
case OP_MATH_ATN:
result = atan(n);
break;
case OP_MATH_LOG:
result = log(n);
break;
case OP_MATH_EXP:
result = exp(n);
break;
default:
result = 0.0;
break;
}
if (!isfinite(result)) {
return mathRangeError(vm, result);
}
basValRelease(top);
// INT, FIX and SGN return the INTEGER type the compiler's builtin
// table declares, widening to LONG / DOUBLE only when the value does
// not fit; the other functions return DOUBLE.
if (op == OP_MATH_INT || op == OP_MATH_FIX || op == OP_MATH_SGN) {
*top = integralValue(result);
} else {
*top = basValDouble(result);
}
return BAS_VM_OK;
}
static BasVmResultE execPrint(BasVmT *vm) {
BasValueT val;
if (!pop(vm, &val)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasStringT *s = basValPrintString(val);
basValRelease(&val);
printText(vm, s->data, false);
basStringUnref(s);
return BAS_VM_OK;
}
// OP_STR_APPEND: var = var + x (or var & x). The variable is not on the
// eval stack, so when it holds the only reference to its string the value
// is appended in place; otherwise the result is computed exactly as
// OP_ADD_INT / OP_STR_CONCAT would and stored back.
static BasVmResultE execStrAppend(BasVmT *vm) {
uint8_t flags = readUint8(vm);
uint8_t scopeTag = readUint8(vm);
uint16_t varIdx = readUint16(vm);
bool isAmp = (flags & BAS_APPEND_AMP) != 0;
BasValueT b;
if (!pop(vm, &b)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *slot = scopedVarSlot(vm, varIdx, scopeTag);
if (!slot) {
basValRelease(&b);
return BAS_VM_ERROR;
}
if (slot->type == BAS_TYPE_STRING && slot->strVal && (isAmp || b.type == BAS_TYPE_STRING)) {
BasValueT sb = basValToString(b);
basValRelease(&b);
if (basStringAppend(&slot->strVal, sb.strVal)) {
basValRelease(&sb);
return BAS_VM_OK;
}
b = sb;
}
if (!push(vm, basValCopy(*slot))) {
basValRelease(&b);
return BAS_VM_STACK_OVERFLOW;
}
if (!push(vm, b)) {
return BAS_VM_STACK_OVERFLOW;
}
BasVmResultE rc = isAmp ? execStringOp(vm, OP_STR_CONCAT) : execArith(vm, OP_ADD_INT);
BasValueT result;
if (rc != BAS_VM_OK) {
return rc;
}
if (!pop(vm, &result)) {
return BAS_VM_STACK_UNDERFLOW;
}
// The operators never run BASIC code, so slot is still valid.
storeValue(slot, result);
return BAS_VM_OK;
}
static BasVmResultE execStringOp(BasVmT *vm, uint8_t op) {
switch (op) {
case OP_STR_CONCAT: {
BasValueT sb;
BasValueT sa;
// Null & x is x; Null & Null stays Null
if (vm->sp >= 2 && vm->stack[vm->sp - 1].type == BAS_TYPE_NULL && vm->stack[vm->sp - 2].type == BAS_TYPE_NULL) {
vm->sp--;
return BAS_VM_OK;
}
for (int32_t i = 1; i <= 2 && i <= vm->sp; i++) {
if (vm->stack[vm->sp - i].type == BAS_TYPE_NULL) {
vm->stack[vm->sp - i] = basValString(NULL);
}
}
if (!popStringArg(vm, &sb)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &sa)) {
basValRelease(&sb);
return BAS_VM_STACK_UNDERFLOW;
}
BasStringT *result = basStringConcat(sa.strVal, sb.strVal);
basValRelease(&sa);
basValRelease(&sb);
if (!push(vm, strValue(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
case OP_STR_LEFT:
case OP_STR_RIGHT: {
BasValueT nVal;
BasValueT sv;
if (!pop(vm, &nVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &sv)) {
basValRelease(&nVal);
return BAS_VM_STACK_UNDERFLOW;
}
int32_t n = basValToInt32(nVal);
basValRelease(&nVal);
if (n < 0) {
basValRelease(&sv);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
int32_t start = 0;
if (op == OP_STR_RIGHT) {
start = sv.strVal->len - n;
if (start < 0) {
start = 0;
}
}
BasStringT *result = basStringSub(sv.strVal, start, n);
basValRelease(&sv);
if (!push(vm, strValue(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
case OP_STR_MID:
case OP_STR_MID2: {
// MID$(s$, start[, len]); a missing len means "to the end".
BasValueT lenVal;
BasValueT startVal;
BasValueT sv;
int32_t len = -1;
if (op == OP_STR_MID) {
if (!pop(vm, &lenVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
len = basValToInt32(lenVal);
basValRelease(&lenVal);
}
if (!pop(vm, &startVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t start = basValToInt32(startVal);
basValRelease(&startVal);
if (!popStringArg(vm, &sv)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (start < 1 || (op == OP_STR_MID && len < 0)) {
basValRelease(&sv);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
BasStringT *result = basStringSub(sv.strVal, start - 1, len);
basValRelease(&sv);
if (!push(vm, strValue(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
case OP_STR_LEN: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT sv = basValToString(*top);
int32_t len = sv.strVal->len;
basValRelease(&sv);
basValRelease(top);
*top = basValLong(len);
return BAS_VM_OK;
}
case OP_STR_INSTR:
case OP_STR_INSTR3: {
// INSTR([start,] string, find); positions are 1-based, LONG.
BasValueT fv;
BasValueT sv;
BasValueT startVal;
int32_t startPos = 0;
if (!popStringArg(vm, &fv)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (!popStringArg(vm, &sv)) {
basValRelease(&fv);
return BAS_VM_STACK_UNDERFLOW;
}
if (op == OP_STR_INSTR3) {
if (!pop(vm, &startVal)) {
basValRelease(&fv);
basValRelease(&sv);
return BAS_VM_STACK_UNDERFLOW;
}
startPos = basValToInt32(startVal) - 1;
basValRelease(&startVal);
if (startPos < 0) {
basValRelease(&fv);
basValRelease(&sv);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
}
int32_t pos = 0;
// OPTION COMPARE TEXT makes the search case-insensitive, as it
// does for the comparison operators.
if (startPos < sv.strVal->len) {
int32_t found = stringFind(sv.strVal, startPos, fv.strVal, vm->compareTextMode);
if (found >= 0) {
pos = found + 1;
}
}
basValRelease(&sv);
basValRelease(&fv);
if (!push(vm, basValLong(pos))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
case OP_STR_UCASE:
case OP_STR_LCASE:
case OP_STR_TRIM:
case OP_STR_LTRIM:
case OP_STR_RTRIM: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT sv = basValToString(*top);
basValRelease(top);
BasStringT *src = sv.strVal;
BasStringT *result;
if (op == OP_STR_UCASE || op == OP_STR_LCASE) {
result = basStringNew(src->data, src->len);
for (int32_t i = 0; i < result->len; i++) {
if (op == OP_STR_UCASE && result->data[i] >= 'a' && result->data[i] <= 'z') {
result->data[i] -= ('a' - 'A');
} else if (op == OP_STR_LCASE && result->data[i] >= 'A' && result->data[i] <= 'Z') {
result->data[i] += ('a' - 'A');
}
}
} else {
int32_t start = 0;
int32_t end = src->len;
if (op == OP_STR_LTRIM || op == OP_STR_TRIM) {
while (start < end && src->data[start] == ' ') {
start++;
}
}
if (op == OP_STR_RTRIM || op == OP_STR_TRIM) {
while (end > start && src->data[end - 1] == ' ') {
end--;
}
}
result = basStringSub(src, start, end - start);
}
basValRelease(&sv);
*top = strValue(result);
return BAS_VM_OK;
}
case OP_STR_CHR: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
// A one-byte string, length-sized so CHR$(0) is a real NUL
// character rather than an empty string.
BasValueT *top = &vm->stack[vm->sp - 1];
char ch = (char)(basValToInt32(*top) & BAS_CHAR_MASK);
basValRelease(top);
*top = strValue(basStringNew(&ch, 1));
return BAS_VM_OK;
}
case OP_STR_ASC: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT sv = basValToString(*top);
int32_t code = (sv.strVal->len > 0) ? (unsigned char)sv.strVal->data[0] : 0;
basValRelease(&sv);
basValRelease(top);
*top = basValInteger((int16_t)code);
return BAS_VM_OK;
}
case OP_STR_SPACE: {
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
int32_t n = basValToInt32(*top);
if (n < 0 || n > BAS_STRING_FUNC_MAX) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
basValRelease(top);
*top = strValue(fillString(' ', n));
return BAS_VM_OK;
}
case OP_STR_FIXLEN: {
// [uint16 len] pop string, pad/truncate to fixed length, push result
uint16_t fixLen = readUint16(vm);
if (vm->sp < 1) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT *top = &vm->stack[vm->sp - 1];
BasValueT sv = basValToString(*top);
basValRelease(top);
BasStringT *src = sv.strVal;
BasStringT *result = basStringAlloc(fixLen + 1);
if (result->cap >= (int32_t)fixLen + 1) {
int32_t copyLen = DVX_MIN(src->len, (int32_t)fixLen);
result->len = fixLen;
memcpy(result->data, src->data, copyLen);
// Pad with spaces
for (int32_t i = copyLen; i < (int32_t)fixLen; i++) {
result->data[i] = ' ';
}
result->data[fixLen] = '\0';
}
basValRelease(&sv);
*top = strValue(result);
return BAS_VM_OK;
}
case OP_STR_MID_ASGN: {
// Pop replacement, len, start, str; push modified string
BasValueT replVal;
BasValueT lenVal;
BasValueT startVal;
BasValueT strVal;
if (!popArgs(vm, 4, &replVal, &lenVal, &startVal, &strVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
BasValueT sv = basValToString(strVal);
BasValueT rv = basValToString(replVal);
int32_t start = basValToInt32(startVal) - 1; // 1-based to 0-based
int32_t len = basValToInt32(lenVal);
basValRelease(&strVal);
basValRelease(&startVal);
basValRelease(&lenVal);
basValRelease(&replVal);
if (start < 0 || (len < 0 && len != BAS_MID_LEN_OMITTED)) {
basValRelease(&sv);
basValRelease(&rv);
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
return BAS_VM_ERROR;
}
BasStringT *src = sv.strVal;
BasStringT *repl = rv.strVal;
int32_t srcLen = src->len;
int32_t replLen = repl->len;
// An omitted length replaces as much of the replacement as
// fits; an explicit 0 replaces nothing.
if (len == BAS_MID_LEN_OMITTED) {
len = replLen;
}
// Clamp to available replacement length
if (len > replLen) {
len = replLen;
}
// Create a copy of the original string
BasStringT *result = basStringNew(src->data, srcLen);
// Replace characters
if (start < srcLen && len > 0) {
int32_t maxReplace = srcLen - start;
if (len > maxReplace) {
len = maxReplace;
}
memcpy(result->data + start, repl->data, len);
}
basValRelease(&sv);
basValRelease(&rv);
if (!push(vm, strValue(result))) {
return BAS_VM_STACK_OVERFLOW;
}
return BAS_VM_OK;
}
default:
return BAS_VM_BAD_OPCODE;
}
}
// A new string of count copies of ch.
static BasStringT *fillString(char ch, int32_t count) {
BasStringT *s = basStringAlloc(count + 1);
if (s->cap >= count + 1) {
memset(s->data, ch, count);
s->data[count] = '\0';
s->len = count;
}
return s;
}
// FILTER: the elements of arr (as strings) that contain match when keep
// is set, or that do not when it is clear. Returns how many there are;
// with out non-NULL they are also stored into out's elements.
static int32_t filterScan(const BasArrayT *arr, const BasStringT *match, bool keep, bool ignoreCase, BasArrayT *out) {
int32_t n = 0;
for (int32_t i = 0; i < arr->totalElements; i++) {
BasValueT sv = basValToString(arr->elements[i]);
if ((stringFind(sv.strVal, 0, match, ignoreCase) >= 0) == keep) {
if (out) {
basValRelease(&out->elements[n]);
out->elements[n] = basValCopy(sv);
}
n++;
}
basValRelease(&sv);
}
return n;
}
// The public member of cls that a read (BAS_MEMBER_OP_GET), Let or Set
// named name reaches (name NULL: the default member). A read takes a
// variable, Property Get, Function or Sub; a Let a variable or Property
// Let, else Property Set; a Set a variable or Property Set, else Property
// Let. NULL when there is none.
static const BasClassMemberT *findMember(const BasClassInfoT *cls, const char *name, int32_t op) {
const BasClassMemberT *best = NULL;
int32_t bestRank = BAS_MEMBER_NO_RANK;
for (int32_t i = 0; i < cls->memberCount; i++) {
const BasClassMemberT *m = &cls->members[i];
bool match = name ? strcasecmp(m->name, name) == 0 : (m->flags & BAS_MEMBER_DEFAULT) != 0;
int32_t rank = match ? memberRank(m->kind, op) : BAS_MEMBER_NO_RANK;
if (rank < bestRank) {
best = m;
bestRank = rank;
}
}
return best;
}
// Shared numeric formatter for OP_PRINT_USING (numeric fields) and OP_FORMAT.
// Renders n per the flags in f, right-aligned in f->width: the sign (or a
// trailing sign), the floating dollar, the thousands-separated integer part
// zero-extended to f->minIntDigits, the decimals and the trailing sign make
// up the body; the remaining positions are filled with spaces or asterisks.
// Every cursor write is bounded against outSize, and every intermediate
// buffer is sized to BAS_FORMAT_BUF_SIZE and clamped, so a pathological
// format string or numeric magnitude cannot overflow the caller's buffer.
// The value a FOR counter of varType holds after an increment to v. The
// counter keeps its type: SINGLE stays SINGLE and INTEGER/LONG widen to
// LONG/DOUBLE only when v leaves their range, so the value read back next
// iteration matches the one the continue test used (an INTEGER counter
// crossing 32767 must not wrap). An integer counter stepped by a
// fractional STEP becomes DOUBLE so it can progress (FOR a = 0 TO 6.3
// STEP 0.2 with a holding the INTEGER 0).
static BasValueT forCounterValue(uint8_t varType, bool stepFractional, double v) {
if (varType == BAS_TYPE_SINGLE) {
return basValSingle((float)v);
}
if (varType == BAS_TYPE_INTEGER && !stepFractional) {
return integralValue(v);
}
if (varType == BAS_TYPE_LONG && !stepFractional && v >= (double)INT32_MIN && v <= (double)INT32_MAX) {
return basValLong((int32_t)v);
}
return basValDouble(v);
}
static void formatNumber(double n, const BasNumFormatT *f, char *out, size_t outSize) {
bool isNeg = (n < 0);
double absN = isNeg ? -n : n;
int32_t decimals = f->hasDecimal ? f->digitsAfter : 0;
int32_t limit = (int32_t)outSize - 1;
int32_t idx = 0;
char numBuf[BAS_FORMAT_BUF_SIZE];
// A magnitude or decimal count too wide for the work buffer cannot be
// laid out digit by digit: fall back to scientific notation (behind
// the '%' overflow mark for PRINT USING) rather than emit a truncated,
// wrong digit string.
if (snprintf(numBuf, sizeof(numBuf), "%.*f", (int)decimals, absN) >= (int)sizeof(numBuf)) {
char mark[2] = { f->markOverflow ? BAS_FORMAT_OVERFLOW_MARK : '\0', '\0' };
snprintf(out, outSize, "%s%E", mark, n);
return;
}
// Split into integer and decimal parts.
char intPart[BAS_FORMAT_BUF_SIZE];
char decPart[BAS_FORMAT_BUF_SIZE];
char *dot = strchr(numBuf, '.');
intPart[0] = '\0';
decPart[0] = '\0';
if (dot) {
int32_t intLen = (int32_t)(dot - numBuf);
if (intLen > (int32_t)sizeof(intPart) - 1) {
intLen = (int32_t)sizeof(intPart) - 1;
}
memcpy(intPart, numBuf, intLen);
intPart[intLen] = '\0';
strncpy(decPart, dot + 1, sizeof(decPart) - 1);
decPart[sizeof(decPart) - 1] = '\0';
} else {
strncpy(intPart, numBuf, sizeof(intPart) - 1);
intPart[sizeof(intPart) - 1] = '\0';
}
// Zero-extend to the '0' placeholders, then apply the thousands separator.
char fmtIntPart[BAS_FORMAT_BUF_SIZE];
int32_t intLen = (int32_t)strlen(intPart);
int32_t zeroPad = f->minIntDigits - intLen;
int32_t dstIdx = 0;
if (zeroPad < 0) {
zeroPad = 0;
}
for (int32_t i = 0; i < zeroPad + intLen; i++) {
if (f->hasComma && i > 0 && (zeroPad + intLen - i) % 3 == 0) {
putBounded(fmtIntPart, &dstIdx, (int32_t)sizeof(fmtIntPart) - 1, ',');
}
putBounded(fmtIntPart, &dstIdx, (int32_t)sizeof(fmtIntPart) - 1, (i < zeroPad) ? '0' : intPart[i - zeroPad]);
}
fmtIntPart[dstIdx] = '\0';
// Sign placement: a leading '+' position always shows the sign; a
// trailing '+' or '-' position carries it at the end; otherwise a
// negative value gets a floating leading '-'.
char lead = '\0';
char trail = '\0';
if (f->plusAtStart) {
lead = isNeg ? '-' : '+';
} else if (f->plusAtEnd) {
trail = isNeg ? '-' : '+';
} else if (f->minusAtEnd) {
trail = isNeg ? '-' : ' ';
} else if (isNeg) {
lead = '-';
}
int32_t decLen = (int32_t)strlen(decPart);
int32_t bodyLen = (lead ? 1 : 0) + (f->dollarFloat ? 1 : 0) + dstIdx + (f->hasDecimal ? 1 + decimals : 0) + (trail ? 1 : 0);
int32_t pad = f->width - bodyLen;
if (pad < 0) {
pad = 0;
if (f->markOverflow) {
putBounded(out, &idx, limit, BAS_FORMAT_OVERFLOW_MARK);
}
}
for (int32_t i = 0; i < pad; i++) {
putBounded(out, &idx, limit, f->asteriskFill ? '*' : ' ');
}
if (lead) {
putBounded(out, &idx, limit, lead);
}
if (f->dollarFloat) {
putBounded(out, &idx, limit, '$');
}
for (int32_t i = 0; fmtIntPart[i]; i++) {
putBounded(out, &idx, limit, fmtIntPart[i]);
}
// decimals comes from the runtime format string, so it can exceed the
// digits snprintf produced into decPart -- never read past decLen.
if (f->hasDecimal) {
putBounded(out, &idx, limit, '.');
for (int32_t i = 0; i < decimals; i++) {
putBounded(out, &idx, limit, (i < decLen) ? decPart[i] : '0');
}
}
if (trail) {
putBounded(out, &idx, limit, trail);
}
out[idx] = '\0';
}
// Lowest forStack index the currently-executing call frame may unwind
// to. FOR frames below this belong to callers and must never be
// touched by NEXT mismatch recovery or FOR re-entry cleanup.
static int32_t forStackFloor(BasVmT *vm) {
if (vm->callDepth > 0) {
return vm->callStack[vm->callDepth - 1].savedForDepth;
}
return 0;
}
// Release FOR-stack entries above newDepth and truncate the stack to it.
// Used when returning from a call frame, unwinding to an error handler,
// and discarding stale frames left by EXIT DO / GOTO jumps out of FORs.
static void forStackTrim(BasVmT *vm, int32_t newDepth) {
while (vm->forDepth > newDepth) {
BasForStateT *fs = &vm->forStack[--vm->forDepth];
basValRelease(&fs->limit);
basValRelease(&fs->step);
}
}
// Flat index of args[0..argc) in arr. Returns 0 and sets *outIdx, else
// the BASIC error number.
static int32_t indexArray(const BasArrayT *arr, BasValueT *args, int32_t argc, int32_t *outIdx) {
int32_t indices[BAS_ARRAY_MAX_DIMS];
if (argc > BAS_ARRAY_MAX_DIMS) {
return BAS_ERR_SUBSCRIPT_RANGE;
}
for (int32_t i = 0; i < argc; i++) {
derefArg(&args[i]);
indices[i] = basValToInt32(args[i]);
}
*outIdx = basArrayIndex((BasArrayT *)arr, indices, argc);
return (*outIdx < 0) ? BAS_ERR_SUBSCRIPT_RANGE : 0;
}
// IniRead: the value of key in [sec] of path through dvxPrefs, or a
// copy of defStr when the file, section or key is missing.
static BasValueT iniRead(const char *path, const char *sec, const char *key, BasStringT *defStr) {
PrefsHandleT *h = prefsLoad(path);
const char *value = prefsGetString(h, sec, key, NULL);
BasValueT result = value ? basValStringFromC(value) : basValString(defStr);
prefsClose(h);
return result;
}
// IniWrite: sets key = value in [sec] of path through dvxPrefs. Every
// other line is written back unchanged (lines end in CR LF); a missing
// key is added after its section's last key and a missing section at the
// end of the file. A file that exists but cannot be read is never
// rewritten, and a failed save leaves the old file intact (error 75).
static BasVmResultE iniWrite(BasVmT *vm, const char *path, const char *sec, const char *key, const char *val) {
PrefsHandleT *h = prefsLoad(path);
if (!h) {
runtimeError(vm, BAS_ERR_OUT_OF_MEMORY, "Out of memory");
return BAS_VM_OUT_OF_MEMORY;
}
prefsSetString(h, sec, key, val);
bool saved = prefsSave(h);
prefsClose(h);
if (!saved) {
runtimeError(vm, BAS_ERR_PATH_FILE_ACCESS, "Cannot write INI file");
return BAS_VM_FILE_ERROR;
}
return BAS_VM_OK;
}
// A whole-number result as the narrowest of INTEGER, LONG and DOUBLE that
// holds it (the promotion rule execArith uses).
static BasValueT integralValue(double v) {
if (v >= (double)INT32_MIN && v <= (double)INT32_MAX) {
return intResult((int32_t)v);
}
return basValDouble(v);
}
// An integer result as INTEGER when it fits, LONG otherwise.
static BasValueT intResult(int32_t v) {
return (v >= INT16_MIN && v <= INT16_MAX) ? basValInteger((int16_t)v) : basValLong(v);
}
// Integer value of an INTEGER or LONG (callers check isIntegerType).
static int32_t intValue(BasValueT v) {
return (v.type == BAS_TYPE_INTEGER) ? (int32_t)v.intVal : v.longVal;
}
// Reads up to len raw bytes into a new string sized by the bytes actually
// read, so a short record never exposes uninitialized heap. With pad set
// a short read is space-filled to len instead: a fixed-length TYPE field
// always holds exactly its declared length.
static BasStringT *ioReadBytes(FILE *fp, int32_t len, bool pad) {
BasStringT *s = basStringAlloc(len + 1);
if (s->cap < len + 1) {
return s;
}
int32_t got = (int32_t)fread(s->data, 1, len, fp);
if (pad) {
memset(s->data + got, ' ', len - got);
got = len;
}
s->data[got] = '\0';
s->len = got;
return s;
}
// GET of a variable-length string as PUT wrote it: an int16 length
// prefix, then the bytes.
static BasStringT *ioReadPrefixedString(FILE *fp) {
int16_t prefix = 0;
readRaw(fp, &prefix, sizeof(prefix));
return ioReadBytes(fp, (prefix < 0) ? 0 : prefix, false);
}
// GET of one numeric value in its binary form (INTEGER and BOOLEAN 2
// bytes, LONG 4, SINGLE 4, DOUBLE 8). Shared by scalar GET and TYPE fields.
static BasValueT ioReadScalar(FILE *fp, uint8_t type) {
switch (type) {
case BAS_TYPE_LONG: {
int32_t val = 0;
readRaw(fp, &val, sizeof(val));
return basValLong(val);
}
case BAS_TYPE_SINGLE: {
float val = 0.0f;
readRaw(fp, &val, sizeof(val));
return basValSingle(val);
}
case BAS_TYPE_DOUBLE:
case BAS_TYPE_DATE: {
double val = 0.0;
readRaw(fp, &val, sizeof(val));
return (type == BAS_TYPE_DATE) ? basValDate(val) : basValDouble(val);
}
case BAS_TYPE_BOOLEAN: {
int16_t val = 0;
readRaw(fp, &val, sizeof(val));
return basValBool(val != 0);
}
default: {
int16_t val = 0;
readRaw(fp, &val, sizeof(val));
return basValInteger(val);
}
}
}
// PUT counterpart of ioReadPrefixedString. The length is clamped before
// the int16 cast so an over-long string can't wrap to a negative prefix.
static void ioWritePrefixedString(BasPutSinkT *sink, const BasStringT *s) {
int32_t slen = s ? s->len : 0;
if (slen > INT16_MAX) {
slen = INT16_MAX;
}
int16_t len = (int16_t)slen;
sinkWrite(sink, &len, sizeof(len));
sinkWrite(sink, s ? s->data : "", len);
}
// PUT counterpart of ioReadScalar; val is converted to the layout type.
static void ioWriteScalar(BasPutSinkT *sink, uint8_t type, BasValueT val) {
switch (type) {
case BAS_TYPE_LONG: {
int32_t v = basValToInt32(val);
sinkWrite(sink, &v, sizeof(v));
break;
}
case BAS_TYPE_SINGLE: {
float v = (float)basValToNumber(val);
sinkWrite(sink, &v, sizeof(v));
break;
}
case BAS_TYPE_DOUBLE:
case BAS_TYPE_DATE: {
double v = basValToNumber(val);
sinkWrite(sink, &v, sizeof(v));
break;
}
case BAS_TYPE_BOOLEAN: {
int16_t v = basValIsTruthy(val) ? -1 : 0;
sinkWrite(sink, &v, sizeof(v));
break;
}
default: {
int16_t v = (int16_t)basValToInt32(val);
sinkWrite(sink, &v, sizeof(v));
break;
}
}
}
// INTEGER or LONG: the types the integer fast paths handle.
static bool isIntegerType(uint8_t type) {
return type == BAS_TYPE_INTEGER || type == BAS_TYPE_LONG;
}
// A one-dimensional array (what JOIN$ and FILTER take).
static bool isOneDimArray(BasValueT v) {
return v.type == BAS_TYPE_ARRAY && v.arrVal && v.arrVal->dims == 1;
}
// JOIN$: the elements of arr as strings with delim between them. Returns
// the length; with out non-NULL the text is also written there (not
// terminated).
static int32_t joinScan(const BasArrayT *arr, const BasStringT *delim, char *out) {
int32_t len = 0;
for (int32_t i = 0; i < arr->totalElements; i++) {
BasValueT sv = basValToString(arr->elements[i]);
if (i > 0) {
if (out) {
memcpy(out + len, delim->data, delim->len);
}
len += delim->len;
}
if (out) {
memcpy(out + len, sv.strVal->data, sv.strVal->len);
}
len += sv.strVal->len;
basValRelease(&sv);
}
return len;
}
// Reads the next TYPE layout entry (see BAS_LAYOUT_* in opcodes.h).
// Returns false when the layout is exhausted or truncated.
static bool layoutNext(const BasStringT *layout, int32_t *pos, BasLayoutEntryT *out) {
if (*pos >= layout->len) {
return false;
}
const uint8_t *d = (const uint8_t *)layout->data;
memset(out, 0, sizeof(*out));
out->type = d[*pos];
*pos += 1;
if (out->type == BAS_TYPE_STRING) {
if (*pos + 2 > layout->len) {
return false;
}
out->fixedLen = d[*pos] | (d[*pos + 1] << 8);
*pos += 2;
} else if (out->type == BAS_TYPE_UDT) {
if (*pos + 4 > layout->len) {
return false;
}
out->typeId = d[*pos] | (d[*pos + 1] << 8);
out->fieldCount = d[*pos + 2] | (d[*pos + 3] << 8);
*pos += 4;
}
return true;
}
// Local wall-clock time, with the sub-second part in microseconds when
// outUsec is non-NULL. Shared by TIMER, DATE$ and TIME$.
static void localNow(struct tm *out, int32_t *outUsec) {
struct timeval tv;
gettimeofday(&tv, NULL);
time_t secs = tv.tv_sec;
struct tm *local = localtime(&secs);
if (local) {
*out = *local;
} else {
memset(out, 0, sizeof(*out));
}
if (outUsec) {
*outUsec = (int32_t)tv.tv_usec;
}
}
// AND / OR / XOR / EQV / IMP with a Null operand, as VB: False AND Null is
// False, True OR Null is True, False IMP Null and Null IMP True are True;
// everything else is Null. Takes over both operands.
static BasVmResultE logicalNull(BasVmT *vm, uint8_t op, BasValueT a, BasValueT b) {
bool aNull = (a.type == BAS_TYPE_NULL);
bool bNull = (b.type == BAS_TYPE_NULL);
int32_t other = 0;
BasValueT result = basValNull();
if (!(aNull && bNull) && !basValRoundToInt32(aNull ? b : a, INT32_MIN, INT32_MAX, &other)) {
basValRelease(&a);
basValRelease(&b);
return raiseError(vm, BAS_ERR_OVERFLOW);
}
bool known = !(aNull && bNull);
if (known && op == OP_AND && other == 0) {
result = intResult(0);
} else if (known && op == OP_OR && other == BAS_TRUE_BITS) {
result = intResult(BAS_TRUE_BITS);
} else if (known && op == OP_IMP && ((bNull && other == 0) || (aNull && other == BAS_TRUE_BITS))) {
result = intResult(BAS_TRUE_BITS);
}
basValRelease(&a);
basValRelease(&b);
return push(vm, result) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
// Send LPRINT output; after a failure the rest of the statement is dropped.
static void lprintWrite(BasVmT *vm, const char *data, int32_t len) {
if (!vm->lprintFailed && len > 0) {
vm->lprintFailed = !vm->printer.write(vm->printer.ctx, vm->lprintJob, data, len);
}
}
// Raises the error for a math result BASIC cannot represent: Overflow for
// an infinity, Illegal function call for NaN (an undefined result).
static BasVmResultE mathRangeError(BasVmT *vm, double result) {
if (isnan(result)) {
runtimeError(vm, BAS_ERR_ILLEGAL_FUNC_CALL, "Illegal function call");
} else {
runtimeError(vm, BAS_ERR_OVERFLOW, "Overflow");
}
return BAS_VM_ERROR;
}
// How well a member of kind serves an access op: 0 as intended, 1 as a
// fallback (Let through Property Set and back), BAS_MEMBER_NO_RANK not.
static int32_t memberRank(uint8_t kind, int32_t op) {
switch (kind) {
case BAS_MEMBER_VAR:
return 0;
case BAS_MEMBER_GET:
case BAS_MEMBER_FUNCTION:
case BAS_MEMBER_SUB:
return (op == BAS_MEMBER_OP_GET) ? 0 : BAS_MEMBER_NO_RANK;
case BAS_MEMBER_LET:
return (op == BAS_MEMBER_OP_LET) ? 0 : ((op == BAS_MEMBER_OP_SET) ? 1 : BAS_MEMBER_NO_RANK);
case BAS_MEMBER_SET:
return (op == BAS_MEMBER_OP_SET) ? 0 : ((op == BAS_MEMBER_OP_LET) ? 1 : BAS_MEMBER_NO_RANK);
default:
return BAS_MEMBER_NO_RANK;
}
}
// Member variable idx of the running procedure's Me. Raises the error
// and returns NULL outside a class instance.
static BasValueT *memberSlot(BasVmT *vm, uint16_t idx) {
BasValueT me = currentFrame(vm)->me;
if (me.type == BAS_TYPE_INSTANCE && me.instVal && idx < (uint16_t)me.instVal->fieldCount) {
return &me.instVal->fields[idx];
}
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Member variable used outside a class instance");
return NULL;
}
// A public variable member read or assigned through an object: obj.v,
// obj.v(i) (an array element, or the default member of an object held
// there) and the same with a value (Let / Set; argc does not count it).
// Takes over args and value.
static BasVmResultE memberVarAccess(BasVmT *vm, BasObjectT *obj, const BasClassMemberT *m, BasValueT *args, int32_t argc, BasValueT *value, int32_t op) {
if (m->index < 0 || m->index >= obj->fieldCount) {
dropArgs(args, argc);
if (value) {
basValRelease(value);
}
return raiseError(vm, BAS_ERR_NO_MEMBER);
}
BasValueT *field = &obj->fields[m->index];
// obj.v(args): an element of the array v holds, or v's default member
if (argc > 0) {
if (field->type == BAS_TYPE_INSTANCE && field->instVal) {
BasObjectT *inner = basObjectRef(field->instVal);
BasVmResultE rc = objectAccess(vm, inner, NULL, args, argc, value, op);
basObjectUnref(inner);
return rc;
}
int32_t flat = 0;
int32_t err = (field->type == BAS_TYPE_ARRAY && field->arrVal) ? indexArray(field->arrVal, args, argc, &flat) : BAS_ERR_TYPE_MISMATCH;
dropArgs(args, argc);
if (err != 0) {
if (value) {
basValRelease(value);
}
return raiseError(vm, err);
}
if (value) {
return storeElement(vm, &field->arrVal->elements[flat], *value) ? BAS_VM_OK : BAS_VM_TYPE_MISMATCH;
}
return push(vm, basValCopy(field->arrVal->elements[flat])) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
if (!value) {
return push(vm, basValCopy(*field)) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
derefArg(value);
BasVmResultE rc = storeConvert(vm, m->dataType, value);
if (rc != BAS_VM_OK) {
return rc;
}
// The conversion ran no BASIC code, so the object still holds field
storeValue(field, *value);
return BAS_VM_OK;
}
// OP_NEW_OBJ: pushes a new Collection, or a new instance of class cls
// and runs its initialisation (member variables, then Class_Initialize)
// as a call made from here.
static BasVmResultE newObject(BasVmT *vm, uint16_t cls) {
if (cls == BAS_NEW_COLLECTION) {
BasObjectT *coll = basObjectNew(BAS_OBJ_COLLECTION, 0, &vm->liveObjects);
if (!coll) {
return raiseError(vm, BAS_ERR_OUT_OF_MEMORY);
}
return push(vm, basValInstance(coll)) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
if (cls >= vm->module->classCount) {
runtimeError(vm, BAS_ERR_BAD_OPCODE, "Bad class number");
return BAS_VM_BAD_OPCODE;
}
if (vm->callDepth >= BAS_VM_CALL_STACK_SIZE) {
return BAS_VM_CALL_OVERFLOW;
}
const BasClassInfoT *info = &vm->module->classes[cls];
BasObjectT *obj = basObjectNew(cls, info->varCount, &vm->liveObjects);
if (!obj) {
return raiseError(vm, BAS_ERR_OUT_OF_MEMORY);
}
// One reference for the stack, one for the initialisation's Me
basObjectRef(obj);
if (!push(vm, basValInstance(obj))) {
basObjectUnref(obj);
return BAS_VM_STACK_OVERFLOW;
}
// Class_Terminate only for an object that exists
if (info->terminateProc >= 0) {
obj->finalize = queueTerminate;
obj->finalizeCtx = vm;
}
// A class with no set-up code (none compiled) is ready as it is
if (info->initCodeAddr < 0) {
basObjectUnref(obj);
return BAS_VM_OK;
}
BasCallFrameT *frame = pushFrame(vm, vm->pc, info->initCodeAddr, 0);
frame->me = basValInstance(obj);
vm->pc = info->initCodeAddr;
return BAS_VM_OK;
}
// A one-dimensional 0-based array of count zero elements of elementType
// (LBOUND 0, UBOUND -1 when count is 0). NULL when out of memory.
static BasArrayT *newVector(int32_t count, uint8_t elementType) {
if (count == 0) {
return basArrayNewEmpty(elementType);
}
int32_t lb = 0;
int32_t ub = count - 1;
return basArrayNew(1, &lb, &ub, elementType);
}
// Returns the bytecode address the error dispatcher records for RESUME
// NEXT: where execution continues with the eval stack at the failing
// statement's boundary. Walks forward from start -- the failing
// instruction, or with includeStart the return address of a call whose
// callee was unwound -- to the first of:
// - the next statement boundary, or a structural opcode that IS what runs
// after the statement (a loop-closing OP_JMP/OP_FOR_NEXT, a SUB's OP_RET,
// OP_END/OP_HALT, a FUNCTION's LOAD_LOCAL result + RET_VAL epilogue);
// - a conditional jump (IF/ELSEIF/WHILE/DO/LOOP condition): resume as if
// it were taken when it jumps forward and not taken when it jumps
// backward, so a failed condition skips its block or leaves its loop;
// - OP_FOR_INIT (a failed FOR header): continue past the whole loop.
// A GOSUB is stepped over so the walk continues at its return address.
// Returns -1 when the walk reaches an
// opcode that would pop values the trap already released or runs off the
// end of the code.
static int32_t nextStatementPc(BasVmT *vm, int32_t start, bool includeStart) {
const uint8_t *code = vm->module->code;
int32_t codeLen = vm->module->codeLen;
int32_t pc = start;
while (pc >= 0 && pc < codeLen) {
uint8_t op = code[pc];
int32_t operand = basOpcodeOperandSize(op);
if (operand < 0 || pc + 1 + operand > codeLen) {
return -1;
}
int32_t after = pc + 1 + operand;
if (pc > start || includeStart) {
if (op == OP_LINE || op == OP_STMT || op == OP_JMP || op == OP_FOR_NEXT || op == OP_RET || op == OP_END || op == OP_HALT) {
return pc;
}
if (op == OP_LOAD_LOCAL && after < codeLen && code[after] == OP_RET_VAL && basReadU16LE(code + pc + 1) == BAS_FUNC_RESULT_SLOT) {
return pc;
}
if (op == OP_JMP_TRUE || op == OP_JMP_FALSE) {
int16_t offset = basReadI16LE(code + pc + 1);
return (offset > 0) ? after + offset : after;
}
if (op == OP_FOR_INIT) {
return after + basReadI16LE(code + pc + BAS_FOR_OFFSET_OPERAND);
}
if (op == OP_RET_VAL || op == OP_GOSUB_RET) {
return -1;
}
}
pc = after;
}
return -1;
}
// Form/control opcode executed with no form runtime attached (headless
// runs such as basrun or the test harnesses).
static BasVmResultE noFormRuntime(BasVmT *vm) {
runtimeError(vm, BAS_ERR_NO_FORM_RUNTIME, "No form runtime");
return BAS_VM_ERROR;
}
// The Null and object rules of an arithmetic or comparison operator: when
// either operand is Null both are dropped and Null is pushed; a class
// instance or Collection has no value to compute with (Type mismatch --
// compare objects with IS). Returns true when the operator is done
// (*rc set).
static bool nullOperands(BasVmT *vm, BasValueT *a, BasValueT *b, BasVmResultE *rc) {
bool isObj = (a->type == BAS_TYPE_INSTANCE || b->type == BAS_TYPE_INSTANCE);
if (!isObj && a->type != BAS_TYPE_NULL && b->type != BAS_TYPE_NULL) {
return false;
}
basValRelease(a);
basValRelease(b);
if (isObj) {
*rc = raiseError(vm, BAS_ERR_TYPE_MISMATCH);
} else {
*rc = push(vm, basValNull()) ? BAS_VM_OK : BAS_VM_STACK_OVERFLOW;
}
return true;
}
// obj.name(args) on a class instance or Collection (name NULL: the
// default member): a read (BAS_MEMBER_OP_GET), or with value a Let or
// Set. Takes over args and value. A read pushes its value, at once or
// when the member procedure returns.
static BasVmResultE objectAccess(BasVmT *vm, BasObjectT *obj, const char *name, BasValueT *args, int32_t argc, BasValueT *value, int32_t op) {
BasValueT callArgs[BAS_VM_MAX_CALL_ARGS + 1];
int32_t total = argc;
if (argc > 0) {
memcpy(callArgs, args, (size_t)argc * sizeof(BasValueT));
}
// Property Let / Set take the value as their last argument
if (value) {
callArgs[total++] = *value;
}
if (obj->classIdx == BAS_OBJ_COLLECTION) {
return collectionAccess(vm, obj, name, callArgs, total, op);
}
const BasClassInfoT *cls = objectClass(vm, obj);
const BasClassMemberT *m = cls ? findMember(cls, name, op) : NULL;
if (!m) {
dropArgs(callArgs, total);
return raiseError(vm, BAS_ERR_NO_MEMBER);
}
if (m->kind == BAS_MEMBER_VAR) {
return memberVarAccess(vm, obj, m, callArgs, argc, value ? &callArgs[argc] : NULL, op);
}
return callMember(vm, obj, m, callArgs, total, op == BAS_MEMBER_OP_GET);
}
// OP_OBJ_CHECK: 0 when v may be stored where class cls (an index,
// BAS_NEW_COLLECTION or BAS_OBJ_CHECK_ANY) is declared -- an object of
// that class, or Nothing -- else the BASIC error number.
static int32_t objectCheck(BasValueT v, uint16_t cls) {
if (!basValIsObject(v)) {
return BAS_ERR_OBJECT_REQUIRED;
}
if (cls == BAS_OBJ_CHECK_ANY || (v.type == BAS_TYPE_OBJECT && !v.objVal)) {
return 0;
}
int32_t want = (cls == BAS_NEW_COLLECTION) ? BAS_OBJ_COLLECTION : (int32_t)cls;
return (v.type == BAS_TYPE_INSTANCE && v.instVal && v.instVal->classIdx == want) ? 0 : BAS_ERR_TYPE_MISMATCH;
}
// The class module an instance belongs to (NULL for a Collection).
static const BasClassInfoT *objectClass(const BasVmT *vm, const BasObjectT *obj) {
if (obj->classIdx < 0 || obj->classIdx >= vm->module->classCount) {
return NULL;
}
return &vm->module->classes[obj->classIdx];
}
// obj(args) (OP_LOAD_ARRAY) or obj(args) = value (OP_STORE_ARRAY) on a
// class instance or Collection: its default member. The operands are on
// the stack (the value on top for a store).
static BasVmResultE objectDefault(BasVmT *vm, int32_t argc, bool isStore) {
BasValueT args[BAS_VM_MAX_CALL_ARGS];
BasValueT value;
BasValueT objVal;
if (argc > BAS_VM_MAX_CALL_ARGS) {
dropValues(vm, argc + 1 + (isStore ? 1 : 0));
return raiseError(vm, BAS_ERR_WRONG_ARGS);
}
if (isStore) {
pop(vm, &value);
}
vm->sp -= argc;
memcpy(args, &vm->stack[vm->sp], (size_t)argc * sizeof(BasValueT));
pop(vm, &objVal);
BasVmResultE rc = objectAccess(vm, objVal.instVal, NULL, args, argc, isStore ? &value : NULL, isStore ? BAS_MEMBER_OP_LET : BAS_MEMBER_OP_GET);
basValRelease(&objVal);
return rc;
}
// objectAccess for the member-access opcodes: takes over the object and
// member-name values as well.
static BasVmResultE objectMemberOp(BasVmT *vm, BasValueT objVal, BasValueT nameVal, BasValueT *args, int32_t argc, BasValueT *value, int32_t op) {
BasValueT sv = basValToString(nameVal);
BasVmResultE rc = objectAccess(vm, objVal.instVal, sv.strVal->data, args, argc, value, op);
basValRelease(&sv);
basValRelease(&nameVal);
basValRelease(&objVal);
return rc;
}
// TypeName of an object: "Nothing", the class name, "Collection", or what
// the host calls a form or control ("Object" when it does not say).
static const char *objectTypeName(const BasVmT *vm, BasValueT v) {
if (v.type == BAS_TYPE_INSTANCE && v.instVal) {
const BasClassInfoT *cls = objectClass(vm, v.instVal);
return cls ? cls->name : BAS_TYPENAME_COLLECTION;
}
if (v.type != BAS_TYPE_OBJECT || !v.objVal) {
return BAS_TYPENAME_NOTHING;
}
const char *name = vm->ui.typeName ? vm->ui.typeName(vm->ui.ctx, v.objVal) : NULL;
return name ? name : BAS_TYPENAME_OBJECT;
}
// OPEN "LPTn:" / "PRN" FOR OUTPUT or APPEND: the channel writes to an
// anonymous spool file that goes to the printer at CLOSE.
static BasVmResultE openPrinterChannel(BasVmT *vm, int32_t channel, int32_t port, uint8_t mode, int32_t recLen) {
if (mode != BAS_FILE_MODE_OUTPUT && mode != BAS_FILE_MODE_APPEND) {
runtimeError(vm, BAS_ERR_BAD_FILE_MODE, errorText(BAS_ERR_BAD_FILE_MODE));
return BAS_VM_FILE_ERROR;
}
closeChannel(vm, channel);
void *job = vm->printer.open ? vm->printer.open(vm->printer.ctx, port) : NULL;
if (!job) {
runtimeError(vm, BAS_ERR_DEVICE_UNAVAILABLE, errorText(BAS_ERR_DEVICE_UNAVAILABLE));
return BAS_VM_FILE_ERROR;
}
FILE *spool = tmpfile();
if (!spool) {
vm->printer.close(vm->printer.ctx, job);
runtimeError(vm, BAS_ERR_PATH_FILE_ACCESS, "Cannot create the printer spool file");
return BAS_VM_FILE_ERROR;
}
vm->files[channel].handle = spool;
vm->files[channel].printJob = job;
vm->files[channel].mode = mode;
vm->files[channel].recLen = recLen;
return BAS_VM_OK;
}
// Returns whether `size` bytes can be read at vm->pc without running past
// the end of code[]. On overflow it flags the VM and clamps pc to codeLen so
// the next basVmStep entry raises BAS_VM_BAD_OPCODE. Compared as
// `codeLen - size` (not `pc + size`) to avoid signed overflow; codeLen is
// always >= 0 and size is a small operand width.
static inline bool operandFits(BasVmT *vm, int32_t size) {
if (vm->pc < 0 || vm->pc > vm->module->codeLen - size) {
vm->badOperand = true;
vm->pc = vm->module->codeLen;
return false;
}
return true;
}
// Appends value as argument idx when the call left it out (the arguments
// before it are all present); otherwise value is released.
static void padArg(BasValueT *args, int32_t *argc, int32_t idx, BasValueT value) {
if (*argc == idx) {
args[(*argc)++] = value;
} else {
basValRelease(&value);
}
}
// Scans a PRINT USING / FORMAT$ numeric format string into f. Both
// statements share the placeholder grammar: '#' and '0' (and '*' before
// the decimal point) are digit positions, '0' also fixes the minimum
// number of integer digits, '.' and ',' set the decimal and thousands
// flags, a leading '+' or a trailing '+'/'-' selects the sign style,
// leading "**" and "$$" select fills, and "^^^^" requests scientific
// notation (reported through outSci). The field width is the length of
// the format string.
static void parseNumFormat(const char *fmt, int32_t fmtLen, BasNumFormatT *f, bool *outSci) {
memset(f, 0, sizeof(*f));
int32_t scanStart = (fmtLen > 0 && fmt[0] == '+') ? 1 : 0;
f->plusAtStart = (scanStart == 1);
f->asteriskFill = (fmtLen >= scanStart + 2 && fmt[scanStart] == '*' && fmt[scanStart + 1] == '*');
if (f->asteriskFill) {
scanStart += 2;
}
f->dollarFloat = (fmtLen >= scanStart + 2 && fmt[scanStart] == '$' && fmt[scanStart + 1] == '$');
f->plusAtEnd = (fmtLen > scanStart && fmt[fmtLen - 1] == '+');
f->minusAtEnd = (fmtLen > scanStart && fmt[fmtLen - 1] == '-');
f->width = fmtLen;
*outSci = (strstr(fmt, BAS_SCI_MARKER) != NULL);
int32_t intDigits = 0;
for (int32_t i = 0; i < fmtLen; i++) {
if (fmt[i] == '.') {
f->hasDecimal = true;
} else if (fmt[i] == ',') {
f->hasComma = true;
} else if (fmt[i] == '#' || fmt[i] == '0' || (fmt[i] == '*' && !f->hasDecimal)) {
if (f->hasDecimal) {
f->digitsAfter++;
} else {
intDigits++;
if (fmt[i] == '0' && f->minIntDigits == 0) {
// Every position from the first '0' to the decimal
// point is a forced digit.
f->minIntDigits = -intDigits;
}
}
}
}
if (f->minIntDigits < 0) {
f->minIntDigits = intDigits + f->minIntDigits + 1;
}
}
static bool pop(BasVmT *vm, BasValueT *val) {
if (vm->sp <= 0) {
return false;
}
*val = vm->stack[--vm->sp];
return true;
}
// Pops count values, top of stack first, into the BasValueT pointers that
// follow. On underflow every value already popped is released so a
// malformed program cannot leak them, and false is returned.
static bool popArgs(BasVmT *vm, int32_t count, ...) {
va_list ap;
va_start(ap, count);
for (int32_t i = 0; i < count; i++) {
BasValueT *out = va_arg(ap, BasValueT *);
if (!pop(vm, out)) {
va_end(ap);
va_start(ap, count);
for (int32_t j = 0; j < i; j++) {
basValRelease(va_arg(ap, BasValueT *));
}
va_end(ap);
return false;
}
}
va_end(ap);
return true;
}
// Pops dims subscripts and the array reference beneath them and resolves
// the element they name. On success *outArr holds the popped (counted)
// array reference, which the caller releases, and *outIdx the flat element
// index. On failure everything popped is released and the error raised.
static BasVmResultE popArrayElement(BasVmT *vm, int32_t dims, BasValueT *outArr, int32_t *outIdx) {
if (!validArrayDims(vm, dims)) {
return BAS_VM_ERROR;
}
int32_t indices[BAS_ARRAY_MAX_DIMS];
// Subscripts were pushed first dimension first, so pop in reverse
for (int32_t d = dims - 1; d >= 0; d--) {
BasValueT idxVal;
if (!pop(vm, &idxVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
indices[d] = basValToInt32(idxVal);
basValRelease(&idxVal);
}
if (!pop(vm, outArr)) {
return BAS_VM_STACK_UNDERFLOW;
}
if (outArr->type != BAS_TYPE_ARRAY || !outArr->arrVal) {
basValRelease(outArr);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not an array");
return BAS_VM_TYPE_MISMATCH;
}
*outIdx = basArrayIndex(outArr->arrVal, indices, dims);
if (*outIdx < 0) {
basValRelease(outArr);
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Subscript out of range");
return BAS_VM_SUBSCRIPT_RANGE;
}
return BAS_VM_OK;
}
// Pops the top call frame (the shared SUB/FUNCTION return epilogue used by
// OP_RET and OP_RET_VAL). The caller MUST have already verified callDepth > 0.
// Copies out-args, releases locals and restores PC.
static void popCallFrame(BasVmT *vm) {
BasCallFrameT *frame = &vm->callStack[--vm->callDepth];
// Copy out-args (for basVmCallSubWithArgsOut) BEFORE releasing the
// locals -- reading them after release is a use-after-free.
if (vm->outArgs && vm->callDepth == vm->outArgFrame) {
for (int32_t i = 0; i < vm->outArgCount && i < frame->localCount; i++) {
vm->outArgs[i] = basValCopy(frame->locals[i]);
}
vm->outArgFrame = -1;
}
// Release locals and Me
for (int32_t i = 0; i < frame->localCount; i++) {
basValRelease(&frame->locals[i]);
}
basValRelease(&frame->me);
// Discard any FOR frames the callee left open (EXIT SUB/FUNCTION
// from inside a FOR body jumps straight to this epilogue) and
// restore the caller's statement boundary for error dispatch.
forStackTrim(vm, frame->savedForDepth);
vm->gosubDepth = frame->savedGosubDepth;
vm->stmtPc = frame->savedStmtPc;
vm->stmtSp = frame->savedStmtSp;
vm->pc = frame->returnPc;
// A procedure returning from inside its own running handler has dealt
// with the error: QBASIC documents that an unresumed handler is cleared
// when the procedure that installed it returns. A procedure that merely
// installed a handler leaves the caller's Err state alone.
if (frame->inHandler) {
clearErrorState(vm);
}
frame->errorHandler = 0;
frame->inHandler = false;
}
static BasVmResultE popFileChannel(BasVmT *vm, int32_t *outChannel, bool requireOpen) {
BasValueT channelVal;
if (!pop(vm, &channelVal)) {
return BAS_VM_STACK_UNDERFLOW;
}
int32_t channel = basValToInt32(channelVal);
basValRelease(&channelVal);
if (channel < 1 || channel >= BAS_VM_MAX_FILES || (requireOpen && !vm->files[channel].handle)) {
runtimeError(vm, BAS_ERR_BAD_FILE_NUM, requireOpen ? "Bad file number or file not open" : "Bad file channel number");
return BAS_VM_FILE_ERROR;
}
*outChannel = channel;
return BAS_VM_OK;
}
// Pops the two operands of a binary operator: *b from the top of the
// stack, *a from beneath it.
static bool popPair(BasVmT *vm, BasValueT *a, BasValueT *b) {
if (vm->sp < 2) {
return false;
}
*b = vm->stack[vm->sp - 1];
*a = vm->stack[vm->sp - 2];
vm->sp -= 2;
return true;
}
// Pops one operand and converts it to a STRING value (*out always holds a
// non-NULL strVal on success). Returns false on stack underflow.
static bool popStringArg(BasVmT *vm, BasValueT *out) {
BasValueT raw;
if (!pop(vm, &raw)) {
return false;
}
*out = basValToString(raw);
basValRelease(&raw);
return true;
}
// Primes callStack[0] as the implicit main (module-level) frame. Module
// code runs in frame 0; without callDepth >= 1 the error dispatcher's
// unwind never inspects that frame, so a module-level ON ERROR GOTO never
// traps. Module-level variables are globals, so the frame has no locals.
// Frames an untrapped error left on a reused VM are released first.
static void primeModuleFrame(BasVmT *vm) {
while (vm->callDepth > 1) {
discardFrame(vm);
}
vm->callDepth = 1;
vm->gosubDepth = 0;
vm->callStack[0].localCount = 0;
vm->callStack[0].errorHandler = 0;
vm->callStack[0].inHandler = false;
vm->callStack[0].savedForDepth = 0;
vm->callStack[0].savedGosubDepth = 0;
vm->callStack[0].savedStmtPc = -1;
vm->callStack[0].savedStmtSp = 0;
vm->callStack[0].pushResult = false;
memset(&vm->callStack[0].me, 0, sizeof(vm->callStack[0].me));
// Hosts that run module-level expressions (the IDE's watch evaluator)
// widen localCount themselves, so leave the slots zeroed.
memset(vm->callStack[0].locals, 0, sizeof(vm->callStack[0].locals));
}
// The output column of what PRINT is writing to: the screen, or the
// printer during an LPRINT.
static int32_t *printColumnOf(BasVmT *vm) {
if (vm->lprinting) {
return &vm->lprintColumn;
}
// The program screen keeps its own cursor (LOCATE moves it)
if (vm->screen) {
vm->printColumn = basScreenColumn(vm->screen);
}
return &vm->printColumn;
}
// True when name is a printer device: "LPT1".."LPT3" (outPort 0..2) or
// "PRN" (BAS_PRINTER_DEFAULT), in any case, with or without a colon.
static bool printerDevice(const char *name, int32_t *outPort) {
char dev[BAS_PRINTER_NAME_MAX + 1];
int32_t len = (int32_t)strlen(name);
if (len > 0 && name[len - 1] == ':') {
len--;
}
if (len >= (int32_t)sizeof(dev)) {
return false;
}
for (int32_t i = 0; i < len; i++) {
dev[i] = (char)toupper((unsigned char)name[i]);
}
dev[len] = '\0';
if (strcmp(dev, BAS_PRINTER_NAME_PRN) == 0) {
*outPort = BAS_PRINTER_DEFAULT;
return true;
}
int32_t lptLen = (int32_t)strlen(BAS_PRINTER_NAME_LPT);
if (len == lptLen + 1 && strncmp(dev, BAS_PRINTER_NAME_LPT, (size_t)lptLen) == 0 && dev[lptLen] >= BAS_PRINTER_FIRST_DIGIT && dev[lptLen] < BAS_PRINTER_FIRST_DIGIT + BAS_PRINTER_PORTS) {
*outPort = dev[lptLen] - BAS_PRINTER_FIRST_DIGIT;
return true;
}
return false;
}
// Every PRINT byte goes through here so the output column is known for
// comma zones and TAB().
static void printText(BasVmT *vm, const char *text, bool newline) {
int32_t *column = printColumnOf(vm);
// Once the program has its screen, PRINT writes there
if (!vm->lprinting && vm->screen) {
basScreenPrint(vm->screen, text, newline);
*column = basScreenColumn(vm->screen);
return;
}
if (vm->lprinting) {
lprintWrite(vm, text, (int32_t)strlen(text));
if (newline) {
lprintWrite(vm, BAS_PRINTER_NEWLINE, BAS_PRINTER_NEWLINE_LEN);
}
} else if (vm->printFn) {
vm->printFn(vm->printCtx, text, newline);
}
for (const char *c = text; *c; c++) {
*column = (*c == '\n') ? 0 : *column + 1;
}
if (newline) {
*column = 0;
}
}
// Local-slot count for a call to codeAddr: the procedure's recorded local
// count (the proc table is sorted by code address), never less than
// minCount (the slots the arguments fill). Code without a proc entry gets
// the full BAS_VM_MAX_LOCALS. The compiler and the module loader reject a
// count over BAS_VM_MAX_LOCALS; the final bound keeps the frame inside
// locals[] whatever built the module.
static int32_t procLocalCount(const BasVmT *vm, int32_t codeAddr, int32_t minCount) {
const BasProcEntryT *procs = vm->module->procs;
int32_t lo = 0;
int32_t hi = vm->module->procCount - 1;
int32_t count = BAS_VM_MAX_LOCALS;
while (lo <= hi) {
int32_t mid = lo + (hi - lo) / 2;
if (procs[mid].codeAddr < codeAddr) {
lo = mid + 1;
} else if (procs[mid].codeAddr > codeAddr) {
hi = mid - 1;
} else {
count = (procs[mid].localCount < minCount) ? minCount : procs[mid].localCount;
break;
}
}
return (count > BAS_VM_MAX_LOCALS) ? BAS_VM_MAX_LOCALS : count;
}
// Pushes val, taking ownership of it: on stack overflow the value is
// released here so no caller has to remember to.
static bool push(BasVmT *vm, BasValueT val) {
if (vm->sp >= BAS_VM_STACK_SIZE) {
basValRelease(&val);
return false;
}
vm->stack[vm->sp++] = val;
return true;
}
// Pushes a call frame for a call to codeAddr returning to returnPc (the
// caller has checked the call-stack depth). Only the procedure's own
// local slots are zeroed; every local access is bounded by localCount,
// and popCallFrame/discardFrame release exactly those slots.
static BasCallFrameT *pushFrame(BasVmT *vm, int32_t returnPc, int32_t codeAddr, int32_t minLocals) {
BasCallFrameT *frame = &vm->callStack[vm->callDepth++];
frame->returnPc = returnPc;
frame->localCount = procLocalCount(vm, codeAddr, minLocals);
frame->errorHandler = 0;
frame->inHandler = false;
frame->savedForDepth = vm->forDepth;
frame->savedGosubDepth = vm->gosubDepth;
frame->savedStmtPc = vm->stmtPc;
frame->savedStmtSp = vm->stmtSp;
frame->pushResult = false;
memset(&frame->me, 0, sizeof(frame->me));
memset(frame->locals, 0, sizeof(BasValueT) * frame->localCount);
return frame;
}
// Bounded single-character append used throughout formatNumber: writes c at
// out[*idx] and advances *idx only while it stays under limit, so no formatter
// cursor write can overflow the caller's buffer.
static void putBounded(char *out, int32_t *idx, int32_t limit, char c) {
if (*idx < limit) {
out[(*idx)++] = c;
}
}
// Encodes one PUT value into sink: numerics in their binary form, strings
// raw on BINARY channels and length-prefixed otherwise, a TYPE instance
// field by field from layout (non-NULL only for PUT of a TYPE).
static BasVmResultE putValue(BasVmT *vm, BasPutSinkT *sink, int32_t mode, BasValueT val, const BasStringT *layout) {
if (layout) {
int32_t pos = 0;
return udtPut(vm, sink, val.udtVal, layout, &pos, 0);
}
switch (val.type) {
case BAS_TYPE_INTEGER:
case BAS_TYPE_LONG:
case BAS_TYPE_SINGLE:
case BAS_TYPE_DOUBLE:
case BAS_TYPE_BOOLEAN:
ioWriteScalar(sink, val.type, val);
break;
case BAS_TYPE_STRING:
if (mode == BAS_FILE_MODE_BINARY) {
if (val.strVal) {
sinkWrite(sink, val.strVal->data, val.strVal->len);
}
} else {
ioWritePrefixedString(sink, val.strVal);
}
break;
default: {
int16_t zero = 0;
sinkWrite(sink, &zero, sizeof(zero));
break;
}
}
return BAS_VM_OK;
}
// Finalizer of instances whose class has a Class_Terminate: the object
// (now unreferenced) waits in the VM's queue, alive again, until
// basVmStep starts its Class_Terminate after the current instruction.
static void queueTerminate(void *ctx, BasObjectT *obj) {
BasVmT *vm = (BasVmT *)ctx;
obj->refCount = 1;
obj->finalize = NULL;
obj->termNext = vm->terminateQueue;
vm->terminateQueue = obj;
}
// Raises BASIC error errNum with its standard message.
static BasVmResultE raiseError(BasVmT *vm, int32_t errNum) {
runtimeError(vm, errNum, errorText(errNum));
return BAS_VM_ERROR;
}
// INPUT #: reads one field the way WRITE # wrote it -- leading blanks are
// skipped, a quoted field runs to the closing quote, an unquoted field runs
// to the next comma or end of line, and the field's delimiter (comma or
// line end) is consumed. Returns the field as a new string.
static BasStringT *readField(FILE *fp) {
int32_t ch = fgetc(fp);
while (ch == ' ' || ch == '\t') {
ch = fgetc(fp);
}
if (ch == EOF) {
return basStringRef(basEmptyString);
}
// An empty line between records is its own (empty) field.
if (ch == '\n' || ch == '\r') {
if (ch == '\r') {
ch = fgetc(fp);
if (ch != '\n' && ch != EOF) {
ungetc(ch, fp);
}
}
return basStringRef(basEmptyString);
}
int32_t cap = BAS_FILE_LINE_CHUNK;
int32_t len = 0;
char *buf = (char *)malloc(cap);
bool quoted = (ch == '"');
if (!buf) {
return basStringRef(basEmptyString);
}
if (!quoted) {
ungetc(ch, fp);
}
for (;;) {
ch = fgetc(fp);
if (ch == EOF) {
break;
}
if (quoted) {
if (ch == '"') {
// Skip to the field delimiter that follows the closing quote.
do {
ch = fgetc(fp);
} while (ch == ' ' || ch == '\t');
if (ch != ',' && ch != '\n' && ch != '\r' && ch != EOF) {
ungetc(ch, fp);
}
break;
}
} else if (ch == ',' || ch == '\n' || ch == '\r') {
break;
}
if (len + 1 >= cap) {
int32_t newCap = cap * 2;
char *grown = (char *)realloc(buf, newCap);
if (!grown) {
break;
}
buf = grown;
cap = newCap;
}
buf[len++] = (char)ch;
}
// Swallow the LF of a CR LF pair so the next field starts cleanly.
if (ch == '\r') {
ch = fgetc(fp);
if (ch != '\n' && ch != EOF) {
ungetc(ch, fp);
}
}
// Unquoted fields drop trailing blanks, as QB does (the growth check
// above always leaves room for the terminator).
if (!quoted) {
buf[len] = '\0';
len = dvxTrimRight(buf);
}
BasStringT *s = basStringNew(buf, len);
free(buf);
return s;
}
// memcpy with constant size is folded to a single load by the compiler and
// is alignment-safe (bytecode operands aren't guaranteed 2-byte aligned).
static inline int16_t readInt16(BasVmT *vm) {
int16_t val = 0;
if (operandFits(vm, (int32_t)sizeof(int16_t))) {
memcpy(&val, &vm->module->code[vm->pc], sizeof(int16_t));
vm->pc += sizeof(int16_t);
}
return val;
}
// LINE INPUT #: reads a whole line of any length (fgets chunks are joined
// until the newline arrives), with the trailing CR/LF stripped. Returns an
// empty string at end of file.
static BasStringT *readLine(FILE *fp) {
int32_t cap = BAS_FILE_LINE_CHUNK;
int32_t len = 0;
char *buf = (char *)malloc(cap);
if (!buf) {
return basStringRef(basEmptyString);
}
buf[0] = '\0';
while (fgets(buf + len, cap - len, fp)) {
len += (int32_t)strlen(buf + len);
if (len > 0 && buf[len - 1] == '\n') {
break;
}
if (len + 1 >= cap - 1) {
int32_t newCap = cap * 2;
char *grown = (char *)realloc(buf, newCap);
if (!grown) {
break;
}
buf = grown;
cap = newCap;
}
}
while (len > 0 && (buf[len - 1] == '\n' || buf[len - 1] == '\r')) {
len--;
}
BasStringT *s = basStringNew(buf, len);
free(buf);
return s;
}
// GET/PUT record read whose short-read result is deliberately ignored: a
// record past end of file yields the caller's zero default.
static void readRaw(FILE *fp, void *dst, size_t size) {
size_t got = fread(dst, 1, size, fp);
(void)got;
}
static inline uint16_t readUint16(BasVmT *vm) {
uint16_t val = 0;
if (operandFits(vm, (int32_t)sizeof(uint16_t))) {
memcpy(&val, &vm->module->code[vm->pc], sizeof(uint16_t));
vm->pc += sizeof(uint16_t);
}
return val;
}
static inline uint8_t readUint8(BasVmT *vm) {
if (!operandFits(vm, (int32_t)sizeof(uint8_t))) {
return 0;
}
return vm->module->code[vm->pc++];
}
// Positions a channel for GET/PUT (see seekRecord; 0 keeps the current
// position, a negative number is Bad record number) and stores the start
// offset in *start so recordEnd can frame the transfer.
static BasVmResultE recordBegin(BasVmT *vm, int32_t channel, int32_t recno, long *start) {
if (recno < 0) {
runtimeError(vm, BAS_ERR_BAD_RECORD_NUM, "Bad record number");
return BAS_VM_FILE_ERROR;
}
if (recno > 0) {
BasVmResultE rc = seekRecord(vm, channel, recno);
if (rc != BAS_VM_OK) {
return rc;
}
}
*start = ftell((FILE *)vm->files[channel].handle);
return BAS_VM_OK;
}
// Completes a GET/PUT. RANDOM channels always transfer whole LEN-byte
// records: a PUT pads the record with zeros and a GET skips to the next
// record; a GET that read past LEN raises error 59 (PUT measures its
// record beforehand).
static BasVmResultE recordEnd(BasVmT *vm, int32_t channel, long start, bool writing) {
FILE *fp = (FILE *)vm->files[channel].handle;
if (vm->files[channel].mode == BAS_FILE_MODE_RANDOM) {
long recLen = vm->files[channel].recLen;
long used = ftell(fp) - start;
if (used > recLen) {
runtimeError(vm, BAS_ERR_BAD_RECORD_LEN, "Record longer than LEN");
return BAS_VM_FILE_ERROR;
}
if (writing) {
for (long i = used; i < recLen; i++) {
fputc(0, fp);
}
} else {
fseek(fp, start + recLen, SEEK_SET);
}
}
if (writing) {
fflush(fp);
}
return BAS_VM_OK;
}
// Releases every refcounted value the VM holds: the eval stack, the
// globals, all call-frame locals across callDepth, and the FOR-stack
// limit/step across forDepth. Must run BEFORE the caller zeroes
// sp/callDepth/forDepth, because the loops use those counts.
static void releaseVmState(BasVmT *vm) {
// Release eval stack values
for (int32_t i = 0; i < vm->sp; i++) {
basValRelease(&vm->stack[i]);
}
// Release global variables
for (int32_t i = 0; i < BAS_VM_MAX_GLOBALS; i++) {
basValRelease(&vm->globals[i]);
}
// Release call frame locals and Me
for (int32_t d = 0; d < vm->callDepth; d++) {
for (int32_t i = 0; i < vm->callStack[d].localCount; i++) {
basValRelease(&vm->callStack[d].locals[i]);
}
basValRelease(&vm->callStack[d].me);
}
// Release FOR stack
for (int32_t i = 0; i < vm->forDepth; i++) {
basValRelease(&vm->forStack[i].limit);
basValRelease(&vm->forStack[i].step);
}
}
// REPLACE$: s from byte start on with up to count (BAS_COUNT_ALL: every)
// occurrences of find replaced by repl. Returns the result length; with
// out non-NULL the result is also written there (not terminated).
static int32_t replaceScan(const BasStringT *s, int32_t start, const BasStringT *find, const BasStringT *repl, int32_t count, bool ignoreCase, char *out) {
int32_t len = 0;
int32_t done = 0;
int32_t pos = start;
while (pos < s->len && find->len > 0 && (count == BAS_COUNT_ALL || done < count)) {
int32_t hit = stringFind(s, pos, find, ignoreCase);
if (hit < 0) {
break;
}
if (out) {
memcpy(out + len, s->data + pos, hit - pos);
memcpy(out + len + hit - pos, repl->data, repl->len);
}
len += hit - pos + repl->len;
pos = hit + find->len;
done++;
}
if (pos < s->len) {
if (out) {
memcpy(out + len, s->data + pos, s->len - pos);
}
len += s->len - pos;
}
return len;
}
// Rounds a numeric operand to LONG (banker's rounding) for the integer
// operators; raises Overflow when it does not fit.
static BasVmResultE roundedOperand(BasVmT *vm, BasValueT v, int32_t *out) {
if (!basValRoundToInt32(v, INT32_MIN, INT32_MAX, out)) {
runtimeError(vm, BAS_ERR_OVERFLOW, "Overflow");
return BAS_VM_ERROR;
}
return BAS_VM_OK;
}
// Executes instructions until callDepth drops back to savedCallDepth
// (meaning the subroutine returned). Periodically yields via the
// doEvents callback to keep the GUI responsive during long-running
// event handlers.
static bool runSubLoop(BasVmT *vm, int32_t savedPc, int32_t savedCallDepth, bool savedRunning) {
int32_t stepsSinceYield = 0;
bool hadBreakpoint = false;
while (vm->running && vm->callDepth > savedCallDepth) {
int32_t stepPc = vm->pc; // save for ON ERROR dispatch
BasVmResultE result = basVmStep(vm);
if (result == BAS_VM_HALTED) {
break;
}
if (result == BAS_VM_BREAKPOINT) {
// Pause in place: yield to the GUI until the host resumes.
// This ensures the sub runs to completion before returning
// to the caller (critical for form init code, event handlers).
vm->running = false;
hadBreakpoint = true;
// Notify host to update debug UI (highlight line, locals, etc.)
if (vm->breakpointFn) {
vm->breakpointFn(vm->breakpointCtx, vm->currentLine);
}
while (!vm->running && vm->doEventsFn) {
if (!vm->doEventsFn(vm->doEventsCtx)) {
// Host is shutting down: drop the paused frames like
// every other exit path before handing back.
while (vm->callDepth > savedCallDepth) {
discardFrame(vm);
}
vm->pc = savedPc;
vm->running = savedRunning;
return false;
}
}
// User resumed -- continue executing the sub
stepsSinceYield = 0;
continue;
}
if (result != BAS_VM_OK) {
// Try ON ERROR GOTO within the current sub-call boundary
// (savedCallDepth) so event handlers fired via basVmCallSub
// behave like module-level code when it comes to trapping.
if (dispatchError(vm, result, savedCallDepth, stepPc)) {
stepsSinceYield = 0;
continue;
}
// Untrapped: the frames still hold refcounted locals; discard
// them so force-restoring callDepth cannot orphan them above
// releaseVmState's reach. Not popCallFrame: no out-arg
// copy-back on the failure path, and it would clear the error
// state the host reads.
while (vm->callDepth > savedCallDepth) {
discardFrame(vm);
}
vm->pc = savedPc;
vm->running = savedRunning;
return false;
}
// Yield periodically to keep the GUI responsive
if (++stepsSinceYield >= BAS_VM_DEFAULT_STEP_SLICE) {
stepsSinceYield = 0;
if (!basVmDoEvents(vm)) {
vm->running = false;
break;
}
}
}
// END/OP_HALT and doEvents aborts break out of the loop with the
// callee's frames still pushed (OP_RET never ran for them). Pop them
// properly -- out-arg copy-back, local release, FOR-stack trim --
// instead of force-lowering callDepth, which would strand the frames'
// refcounted locals above callDepth where releaseVmState never walks,
// and would drop ByRef out-args (e.g. Cancel = 1 set before END).
while (vm->callDepth > savedCallDepth) {
popCallFrame(vm);
}
vm->pc = savedPc;
vm->running = savedRunning;
// Show what the handler drew before the host carries on
basScreenPresent(vm);
// If we paused at a breakpoint during this sub, notify the host
// so it can pause the event loop before any new event fires.
if (hadBreakpoint && vm->breakpointFn) {
vm->breakpointFn(vm->breakpointCtx, -1);
}
return true;
}
static void runtimeError(BasVmT *vm, int32_t errNum, const char *msg) {
vm->errorNumber = errNum;
vm->errorLine = vm->currentLine;
vm->lprinting = false;
if (vm->currentLine > 0) {
snprintf(vm->errorMsg, sizeof(vm->errorMsg), "Runtime error %d on line %d" BAS_VM_ERROR_TEXT_SEP "%s", (int)errNum, (int)vm->currentLine, msg);
} else {
snprintf(vm->errorMsg, sizeof(vm->errorMsg), "Runtime error %d at PC %d" BAS_VM_ERROR_TEXT_SEP "%s", (int)errNum, (int)vm->currentOpPc, msg);
}
}
// Resolves a variable operand (local, form or global slot, by scope tag)
// through any ByRef indirection, the way OP_LOAD_LOCAL/OP_STORE_LOCAL do,
// so FOR or an append on a ByRef parameter reaches the caller's variable. Raises the runtime error
// and returns NULL when the slot does not exist.
static BasValueT *scopedVarSlot(BasVmT *vm, uint16_t varIdx, uint8_t scopeTag) {
BasValueT *slot = NULL;
const char *what = "Invalid global variable index";
if (scopeTag == SCOPE_MEMBER) {
return memberSlot(vm, varIdx);
}
if (scopeTag == SCOPE_LOCAL) {
BasCallFrameT *frame = currentFrame(vm);
what = "Invalid local variable index";
if (varIdx < (uint16_t)frame->localCount) {
slot = &frame->locals[varIdx];
}
} else if (scopeTag == SCOPE_FORM) {
what = "Invalid form variable index";
if (vm->currentFormVars && varIdx < (uint16_t)vm->currentFormVarCount) {
slot = &vm->currentFormVars[varIdx];
}
} else if (varIdx < BAS_VM_MAX_GLOBALS) {
slot = &vm->globals[varIdx];
}
if (!slot) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, what);
return NULL;
}
slot = derefSlot(slot);
if (!slot) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Subscript out of range");
}
return slot;
}
// srand with the integer part of seed taken modulo 2^32 (a non-finite
// seed counts as 0).
static void seedRandom(double seed) {
double reduced = isfinite(seed) ? fmod(seed, BAS_RND_SEED_MODULUS) : 0.0;
srand((unsigned int)(int64_t)reduced);
}
// Positions a channel at a 1-based record number (RANDOM) or byte
// position (every other mode) for GET/PUT and SEEK. A position whose
// byte offset does not fit a long raises Bad record number.
static BasVmResultE seekRecord(BasVmT *vm, int32_t channel, int32_t pos) {
long unit = (vm->files[channel].mode == BAS_FILE_MODE_RANDOM) ? vm->files[channel].recLen : 1;
if ((long)(pos - 1) > LONG_MAX / unit) {
runtimeError(vm, BAS_ERR_BAD_RECORD_NUM, "Bad record number");
return BAS_VM_FILE_ERROR;
}
fseek((FILE *)vm->files[channel].handle, (long)(pos - 1) * unit, SEEK_SET);
return BAS_VM_OK;
}
// A printer channel's spool to its job with CR LF line ends (PRINT #
// writes LF), then the job is closed. False when anything failed.
static bool sendSpool(BasVmT *vm, BasFileChannelT *ch) {
FILE *fp = (FILE *)ch->handle;
char in[BAS_SPOOL_CHUNK];
char out[BAS_SPOOL_CHUNK * BAS_PRINTER_NEWLINE_LEN];
bool ok = true;
bool prevCr = false;
size_t n;
rewind(fp);
while (ok && (n = fread(in, 1, sizeof(in), fp)) > 0) {
int32_t len = 0;
for (size_t i = 0; i < n; i++) {
if (in[i] == '\n' && !prevCr) {
out[len++] = '\r';
}
prevCr = (in[i] == '\r');
out[len++] = in[i];
}
ok = vm->printer.write(vm->printer.ctx, ch->printJob, out, len);
}
return vm->printer.close(vm->printer.ctx, ch->printJob) && ok;
}
// Appends count copies of c to a PUT sink (fixed-length string padding).
static void sinkFill(BasPutSinkT *sink, char c, int32_t count) {
for (int32_t i = 0; i < count; i++) {
sinkWrite(sink, &c, 1);
}
}
// Appends len bytes to a PUT sink (counted only when it has no file).
static void sinkWrite(BasPutSinkT *sink, const void *data, int32_t len) {
if (sink->fp && len > 0) {
fwrite(data, 1, len, sink->fp);
}
sink->bytes += len;
}
// SLEEP: waits secs seconds while pumping the host's event loop, so the
// GUI keeps running; SLEEP 0 (or a negative count) yields to the host
// once. Returns false when the host asks the program to stop. Without an
// event pump (headless runs) the process just sleeps.
static bool sleepSeconds(BasVmT *vm, int32_t secs) {
if (!vm->doEventsFn) {
if (secs > 0) {
sleep((unsigned int)secs);
}
return true;
}
double deadline = wallSeconds() + secs;
do {
if (!basVmDoEvents(vm)) {
return false;
}
if (secs > 0) {
usleep(BAS_SLEEP_POLL_USEC);
}
} while (wallSeconds() < deadline);
return true;
}
// SPLIT: the pieces of s between occurrences of delim, at most limit of
// them (BAS_COUNT_ALL: no limit; the last piece keeps the rest). Returns
// how many there are; with out non-NULL they are also stored into out's
// elements. An empty s has no pieces; an empty delim gives s whole.
static int32_t splitScan(const BasStringT *s, const BasStringT *delim, int32_t limit, bool ignoreCase, BasArrayT *out) {
int32_t n = 0;
int32_t pos = 0;
if (s->len == 0 || limit == 0) {
return 0;
}
while (true) {
int32_t hit = (delim->len > 0 && (limit == BAS_COUNT_ALL || n < limit - 1)) ? stringFind(s, pos, delim, ignoreCase) : -1;
int32_t end = (hit < 0) ? s->len : hit;
if (out) {
basValRelease(&out->elements[n]);
out->elements[n] = strValue(basStringSub(s, pos, end - pos));
}
n++;
if (hit < 0) {
return n;
}
pos = hit + delim->len;
}
}
// Starts the Class_Terminate of the next queued instance as a call made
// between two instructions. The call's Me holds the queue's reference;
// when Class_Terminate returns the object is freed (unless it stored a
// reference to itself somewhere).
static BasVmResultE startTerminate(BasVmT *vm) {
BasObjectT *obj = vm->terminateQueue;
vm->terminateQueue = obj->termNext;
obj->termNext = NULL;
const BasClassInfoT *cls = objectClass(vm, obj);
if (!cls || cls->terminateProc < 0 || vm->callDepth >= BAS_VM_CALL_STACK_SIZE) {
basObjectUnref(obj);
return BAS_VM_OK;
}
int32_t addr = vm->module->procs[cls->terminateProc].codeAddr;
BasCallFrameT *frame = pushFrame(vm, vm->pc, addr, 0);
frame->me = basValInstance(obj);
vm->pc = addr;
return BAS_VM_OK;
}
// Converts *val (in place) to a declared type the way a store into a
// variable of that type does (the conversion opcode basConvOpForStore names).
static BasVmResultE storeConvert(BasVmT *vm, uint8_t dataType, BasValueT *val) {
uint8_t op = basConvOpForStore(dataType);
if (op == OP_NOP) {
return BAS_VM_OK;
}
if (!push(vm, *val)) {
return BAS_VM_STACK_OVERFLOW;
}
BasVmResultE rc = execConvert(vm, op);
pop(vm, val);
if (rc != BAS_VM_OK) {
basValRelease(val);
}
return rc;
}
// Stores into an array element or TYPE field. An array reference is
// refused there: the compiler never emits one (elements and fields are
// scalars or TYPE instances) and a corrupt module storing an array
// inside itself would build a reference cycle nothing ever frees.
static bool storeElement(BasVmT *vm, BasValueT *target, BasValueT val) {
if (val.type == BAS_TYPE_ARRAY) {
basValRelease(&val);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Array reference cannot be stored in an element");
return false;
}
storeValue(target, val);
return true;
}
// Replaces *target with val, releasing the old value. A TYPE value that is
// still shared with another variable is deep-copied first so assignment has
// value semantics (b = a must not alias a).
static void storeValue(BasValueT *target, BasValueT val) {
basValRelease(target);
*target = udtDetach(val);
}
// Length-aware substring search (strings may contain NUL bytes). Returns
// the 0-based offset of the first occurrence of needle in haystack at or
// after start, or -1; ignoreCase compares ASCII letters case-insensitively.
// An empty needle matches at start (INSTR semantics).
static int32_t stringFind(const BasStringT *haystack, int32_t start, const BasStringT *needle, bool ignoreCase) {
if (needle->len == 0) {
return start;
}
for (int32_t i = start; i + needle->len <= haystack->len; i++) {
if (stringMatchAt(haystack, i, needle, ignoreCase)) {
return i;
}
}
return -1;
}
// True when needle occurs in haystack at byte i (the caller keeps i +
// needle->len within haystack).
static bool stringMatchAt(const BasStringT *haystack, int32_t i, const BasStringT *needle, bool ignoreCase) {
if (!ignoreCase) {
return memcmp(haystack->data + i, needle->data, needle->len) == 0;
}
for (int32_t k = 0; k < needle->len; k++) {
if (toupper((unsigned char)haystack->data[i + k]) != toupper((unsigned char)needle->data[k])) {
return false;
}
}
return true;
}
// Wraps a string the caller already owns a reference to (no extra ref).
static BasValueT strValue(BasStringT *s) {
BasValueT v;
v.type = BAS_TYPE_STRING;
v.strVal = s;
return v;
}
// Releases every object the VM made that is still alive when it is
// destroyed. Each object is held while all of them let go of what they
// hold (breaking reference cycles), then the holds are dropped: objects
// nothing else refers to are freed, the rest (still referenced by the
// host) leave the VM's list and live on. No Class_Terminate runs.
static void sweepObjects(BasVmT *vm) {
for (BasObjectT *o = vm->liveObjects; o; o = o->liveNext) {
o->finalize = NULL;
o->refCount++;
}
for (BasObjectT *o = vm->liveObjects; o; o = o->liveNext) {
basObjectClear(o);
}
BasObjectT *o = vm->liveObjects;
while (o) {
BasObjectT *next = o->liveNext;
basObjectUnref(o);
o = next;
}
for (o = vm->liveObjects; o; o = vm->liveObjects) {
vm->liveObjects = o->liveNext;
o->liveList = NULL;
o->livePrev = NULL;
o->liveNext = NULL;
}
}
// ISNUMERIC of a string: optional blanks, a sign, digits with an
// optional point and exponent (or an &H / &O number), optional blanks.
static bool textIsNumeric(const BasStringT *s) {
const char *p = s->data;
const char *end = s->data + s->len;
int32_t digits = 0;
while (p < end && *p == ' ') {
p++;
}
if (p < end && (*p == '+' || *p == '-')) {
p++;
}
if (end - p >= BAS_RADIX_PREFIX_LEN && p[0] == '&' && (toupper((unsigned char)p[1]) == 'H' || toupper((unsigned char)p[1]) == 'O')) {
bool hex = toupper((unsigned char)p[1]) == 'H';
for (p += BAS_RADIX_PREFIX_LEN; p < end && (hex ? isxdigit((unsigned char)*p) : (*p >= '0' && *p <= '7')); p++) {
digits++;
}
} else {
for (; p < end && isdigit((unsigned char)*p); p++) {
digits++;
}
if (p < end && *p == '.') {
for (p++; p < end && isdigit((unsigned char)*p); p++) {
digits++;
}
}
if (digits > 0 && p < end && strchr(BAS_EXPONENT_CHARS, *p)) {
int32_t expDigits = 0;
p++;
if (p < end && (*p == '+' || *p == '-')) {
p++;
}
for (; p < end && isdigit((unsigned char)*p); p++) {
expDigits++;
}
digits = (expDigits > 0) ? digits : 0;
}
}
while (p < end && *p == ' ') {
p++;
}
return digits > 0 && p == end;
}
// TypeName of a value of a non-object type (typeId names a TYPE).
static const char *typeNameOf(const BasVmT *vm, uint8_t type, int32_t typeId) {
switch (type) {
case BAS_TYPE_EMPTY:
return "Empty";
case BAS_TYPE_NULL:
return "Null";
case BAS_TYPE_INTEGER:
return "Integer";
case BAS_TYPE_LONG:
return "Long";
case BAS_TYPE_SINGLE:
return "Single";
case BAS_TYPE_DOUBLE:
return "Double";
case BAS_TYPE_DATE:
return "Date";
case BAS_TYPE_STRING:
return "String";
case BAS_TYPE_BOOLEAN:
return "Boolean";
case BAS_TYPE_VARIANT:
return "Variant";
case BAS_TYPE_OBJECT:
case BAS_TYPE_INSTANCE:
return BAS_TYPENAME_OBJECT;
case BAS_TYPE_UDT:
for (int32_t i = 0; i < vm->module->debugUdtDefCount; i++) {
if (vm->module->debugUdtDefs[i].typeId == typeId) {
return vm->module->debugUdtDefs[i].name;
}
}
return BAS_TYPENAME_UDT;
default:
return "Unknown";
}
}
// Gives val its own TYPE instance when the one it carries is shared. The
// shared reference is released; a clone failure leaves the value shared.
static BasValueT udtDetach(BasValueT val) {
if (val.type != BAS_TYPE_UDT || !val.udtVal || val.udtVal->refCount <= 1) {
return val;
}
BasUdtT *copy = basUdtClone(val.udtVal);
if (!copy) {
return val;
}
basUdtUnref(val.udtVal);
val.udtVal = copy;
return val;
}
// Builds a TYPE instance from its layout: fixed strings start as spaces,
// variable strings empty, numerics as typed zeros, nested types are
// built recursively. NULL on a malformed layout or out of memory.
static BasUdtT *udtFromLayout(BasVmT *vm, const BasStringT *layout, int32_t *pos, int32_t typeId, int32_t fieldCount, int32_t depth) {
if (depth >= BAS_LAYOUT_MAX_DEPTH || fieldCount < 0) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return NULL;
}
BasUdtT *udt = basUdtNew(typeId, fieldCount);
if (!udt) {
runtimeError(vm, BAS_ERR_OUT_OF_MEMORY, "Out of memory allocating TYPE");
return NULL;
}
for (int32_t i = 0; i < fieldCount; i++) {
BasLayoutEntryT entry;
if (!layoutNext(layout, pos, &entry)) {
basUdtUnref(udt);
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return NULL;
}
if (entry.type == BAS_TYPE_UDT) {
BasUdtT *child = udtFromLayout(vm, layout, pos, entry.typeId, entry.fieldCount, depth + 1);
if (!child) {
basUdtUnref(udt);
return NULL;
}
udt->fields[i].type = BAS_TYPE_UDT;
udt->fields[i].udtVal = child;
} else if (entry.type == BAS_TYPE_STRING && entry.fixedLen > 0) {
udt->fields[i] = strValue(fillString(' ', entry.fixedLen));
} else {
udt->fields[i] = zeroValue(entry.type);
}
}
return udt;
}
// GET into a TYPE instance: walks the compiler's layout (one entry per
// field, nested types inline) and fills each field in place.
static BasVmResultE udtGet(BasVmT *vm, FILE *fp, BasUdtT *udt, const BasStringT *layout, int32_t *pos, int32_t depth) {
if (depth >= BAS_LAYOUT_MAX_DEPTH) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "TYPE nesting too deep");
return BAS_VM_TYPE_MISMATCH;
}
for (int32_t i = 0; i < udt->fieldCount; i++) {
BasLayoutEntryT entry;
if (!layoutNext(layout, pos, &entry)) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return BAS_VM_TYPE_MISMATCH;
}
uint8_t type = entry.type;
int32_t fixedLen = entry.fixedLen;
BasValueT *field = &udt->fields[i];
if (type == BAS_TYPE_UDT) {
if (field->type != BAS_TYPE_UDT || !field->udtVal) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
BasVmResultE rc = udtGet(vm, fp, field->udtVal, layout, pos, depth + 1);
if (rc != BAS_VM_OK) {
return rc;
}
continue;
}
if (type == BAS_TYPE_STRING) {
storeValue(field, strValue(fixedLen > 0 ? ioReadBytes(fp, fixedLen, true) : ioReadPrefixedString(fp)));
continue;
}
storeValue(field, ioReadScalar(fp, type));
}
return BAS_VM_OK;
}
// PUT counterpart of udtGet.
static BasVmResultE udtPut(BasVmT *vm, BasPutSinkT *sink, const BasUdtT *udt, const BasStringT *layout, int32_t *pos, int32_t depth) {
if (depth >= BAS_LAYOUT_MAX_DEPTH) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "TYPE nesting too deep");
return BAS_VM_TYPE_MISMATCH;
}
for (int32_t i = 0; i < udt->fieldCount; i++) {
BasLayoutEntryT entry;
if (!layoutNext(layout, pos, &entry)) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Bad TYPE layout");
return BAS_VM_TYPE_MISMATCH;
}
uint8_t type = entry.type;
int32_t fixedLen = entry.fixedLen;
BasValueT field = udt->fields[i];
if (type == BAS_TYPE_UDT) {
if (field.type != BAS_TYPE_UDT || !field.udtVal) {
runtimeError(vm, BAS_ERR_TYPE_MISMATCH, "Not a TYPE instance");
return BAS_VM_TYPE_MISMATCH;
}
BasVmResultE rc = udtPut(vm, sink, field.udtVal, layout, pos, depth + 1);
if (rc != BAS_VM_OK) {
return rc;
}
continue;
}
if (type == BAS_TYPE_STRING) {
BasValueT sv = basValToString(field);
if (fixedLen > 0) {
int32_t copyLen = DVX_MIN(sv.strVal->len, fixedLen);
sinkWrite(sink, sv.strVal->data, copyLen);
sinkFill(sink, ' ', fixedLen - copyLen);
} else {
ioWritePrefixedString(sink, sv.strVal);
}
basValRelease(&sv);
continue;
}
ioWriteScalar(sink, type, field);
}
return BAS_VM_OK;
}
// Checks a form/control opcode can run: the host must provide the
// callback (no form runtime otherwise) and the target must be an object
// reference -- an unset object variable holds a number and raises Object
// variable not set. A NULL object is passed on for the host to report.
static BasVmResultE uiTarget(BasVmT *vm, bool hasCallback, BasValueT target) {
if (!hasCallback) {
return noFormRuntime(vm);
}
if (target.type != BAS_TYPE_OBJECT) {
runtimeError(vm, BAS_ERR_OBJECT_NOT_SET, "Object variable not set");
return BAS_VM_ERROR;
}
return BAS_VM_OK;
}
// Length of the PRINT USING field starting at fmt[pos], or 0 when the
// character there is literal text. String fields are '!', '&' and a
// backslash pair; numeric fields start with '#', '.', "**", "$$" or a
// '+' followed by one of those, run over the digit, comma and point
// positions, and may end in "^^^^" and a trailing sign.
static int32_t usingFieldLen(const char *fmt, int32_t fmtLen, int32_t pos) {
char c = fmt[pos];
if (c == '!' || c == '&') {
return 1;
}
if (c == '\\') {
for (int32_t i = pos + 1; i < fmtLen; i++) {
if (fmt[i] == '\\') {
return i - pos + 1;
}
}
return 0;
}
int32_t i = pos;
bool hasFill = false;
bool leadPlus = (c == '+');
if (leadPlus) {
i++;
}
if (i + 1 < fmtLen && fmt[i] == '*' && fmt[i + 1] == '*') {
hasFill = true;
i += 2;
}
if (i + 1 < fmtLen && fmt[i] == '$' && fmt[i + 1] == '$') {
hasFill = true;
i += 2;
}
// A numeric field needs a digit position ('#' or ".#") or a fill;
// a lone '+' (for example the end of "Total+") is literal text.
if (!hasFill && (i >= fmtLen || (fmt[i] != '#' && !(fmt[i] == '.' && i + 1 < fmtLen && fmt[i + 1] == '#')))) {
return 0;
}
while (i < fmtLen && (fmt[i] == '#' || fmt[i] == '0' || fmt[i] == ',' || fmt[i] == '.')) {
i++;
}
if (i + (int32_t)strlen(BAS_SCI_MARKER) <= fmtLen && strncmp(fmt + i, BAS_SCI_MARKER, strlen(BAS_SCI_MARKER)) == 0) {
i += (int32_t)strlen(BAS_SCI_MARKER);
}
if (!leadPlus && i < fmtLen && (fmt[i] == '+' || fmt[i] == '-')) {
i++;
}
return i - pos;
}
// Formats one PRINT USING value: emits the literal text from the current
// scan position up to the next field, the field rendered from val, and,
// for the last value of the statement, the literal text after it. The
// scan wraps to the start of the format when it runs out of fields.
// Returns NULL when the field type does not match the value.
static BasStringT *usingFormat(BasVmT *vm, const BasStringT *fmt, BasValueT val, bool last) {
int32_t valLen = (val.type == BAS_TYPE_STRING && val.strVal) ? val.strVal->len : 0;
int32_t cap = fmt->len * 2 + valLen + BAS_FORMAT_BUF_SIZE + 1;
char *buf = (char *)malloc(cap);
if (!buf) {
return basStringRef(basEmptyString);
}
int32_t idx = 0;
int32_t limit = cap - 1;
int32_t fieldLen = 0;
bool wrapped = false;
// Literal text up to the next field; wrap at most once.
while (vm->usingPos < fmt->len || !wrapped) {
if (vm->usingPos >= fmt->len) {
wrapped = true;
vm->usingPos = 0;
if (fmt->len == 0) {
break;
}
}
char c = fmt->data[vm->usingPos];
if (c == BAS_USING_ESCAPE && vm->usingPos + 1 < fmt->len) {
putBounded(buf, &idx, limit, fmt->data[vm->usingPos + 1]);
vm->usingPos += 2;
continue;
}
fieldLen = usingFieldLen(fmt->data, fmt->len, vm->usingPos);
if (fieldLen > 0) {
break;
}
putBounded(buf, &idx, limit, c);
vm->usingPos++;
}
if (fieldLen == 0) {
// No field anywhere in the format: the value prints as-is.
BasStringT *plain = basValFormatString(val);
for (int32_t i = 0; i < plain->len; i++) {
putBounded(buf, &idx, limit, plain->data[i]);
}
basStringUnref(plain);
buf[idx] = '\0';
BasStringT *result = basStringNew(buf, idx);
free(buf);
return result;
}
const char *field = fmt->data + vm->usingPos;
bool strField = (field[0] == '!' || field[0] == '&' || field[0] == '\\');
vm->usingPos += fieldLen;
if (strField != (val.type == BAS_TYPE_STRING)) {
free(buf);
return NULL;
}
if (strField) {
const char *src = val.strVal ? val.strVal->data : "";
int32_t srcLen = val.strVal ? val.strVal->len : 0;
int32_t width = (field[0] == '!') ? 1 : (field[0] == '&') ? srcLen : fieldLen;
for (int32_t i = 0; i < width; i++) {
putBounded(buf, &idx, limit, (i < srcLen) ? src[i] : ' ');
}
} else {
double n = basValToNumber(val);
BasNumFormatT f;
bool sciNotation;
char numBuf[BAS_FORMAT_BUF_SIZE];
parseNumFormat(field, fieldLen, &f, &sciNotation);
f.markOverflow = true;
if (sciNotation) {
char sciFmt[BAS_SCI_FMT_LEN];
int32_t decimals = f.hasDecimal ? f.digitsAfter : 0;
snprintf(sciFmt, sizeof(sciFmt), "%%%d.%dE", (int)fieldLen, (int)decimals);
snprintf(numBuf, sizeof(numBuf), sciFmt, n);
} else {
formatNumber(n, &f, numBuf, sizeof(numBuf));
}
for (int32_t i = 0; numBuf[i]; i++) {
putBounded(buf, &idx, limit, numBuf[i]);
}
}
// Trailing literal text after the last value, up to the next field.
if (last) {
while (vm->usingPos < fmt->len) {
char c = fmt->data[vm->usingPos];
if (c == BAS_USING_ESCAPE && vm->usingPos + 1 < fmt->len) {
putBounded(buf, &idx, limit, fmt->data[vm->usingPos + 1]);
vm->usingPos += 2;
continue;
}
if (usingFieldLen(fmt->data, fmt->len, vm->usingPos) > 0) {
break;
}
putBounded(buf, &idx, limit, c);
vm->usingPos++;
}
}
buf[idx] = '\0';
BasStringT *result = basStringNew(buf, idx);
free(buf);
return result;
}
static bool validArrayDims(BasVmT *vm, int32_t dims) {
if (dims < 1 || dims > BAS_ARRAY_MAX_DIMS) {
runtimeError(vm, BAS_ERR_SUBSCRIPT_RANGE, "Invalid array dimension count");
return false;
}
return true;
}
// VARTYPE of a type tag (VB's vbInteger ... vbVariant).
static int32_t varTypeOf(uint8_t type) {
switch (type) {
case BAS_TYPE_EMPTY:
return BAS_VT_EMPTY;
case BAS_TYPE_NULL:
return BAS_VT_NULL;
case BAS_TYPE_INTEGER:
return BAS_VT_INTEGER;
case BAS_TYPE_LONG:
return BAS_VT_LONG;
case BAS_TYPE_SINGLE:
return BAS_VT_SINGLE;
case BAS_TYPE_DOUBLE:
return BAS_VT_DOUBLE;
case BAS_TYPE_DATE:
return BAS_VT_DATE;
case BAS_TYPE_STRING:
return BAS_VT_STRING;
case BAS_TYPE_BOOLEAN:
return BAS_VT_BOOLEAN;
case BAS_TYPE_VARIANT:
return BAS_VT_VARIANT;
case BAS_TYPE_UDT:
return BAS_VT_USERTYPE;
default:
return BAS_VT_OBJECT;
}
}
// Keep the host's events running until busy says the wait is over (or
// just check again after a pause without an event pump). False when the
// host asks the program to stop.
static bool waitWhile(BasVmT *vm, bool (*busy)(void *ctx)) {
while (busy(vm->device.ctx)) {
if (!vm->doEventsFn) {
usleep(BAS_WAIT_POLL_USEC);
} else if (!basVmDoEvents(vm)) {
return false;
}
}
return true;
}
// Wall-clock time in seconds (sub-second resolution), for SLEEP deadlines.
static double wallSeconds(void) {
struct timeval tv;
gettimeofday(&tv, NULL);
return (double)tv.tv_sec + (double)tv.tv_usec / BAS_USEC_PER_SEC;
}
// The declared zero of a data type: "" for strings, False for booleans,
// a typed numeric zero otherwise.
static BasValueT zeroValue(uint8_t type) {
switch (type) {
case BAS_TYPE_STRING:
return strValue(basStringRef(basEmptyString));
case BAS_TYPE_BOOLEAN:
return basValBool(false);
case BAS_TYPE_LONG:
return basValLong(0);
case BAS_TYPE_SINGLE:
return basValSingle(0.0f);
case BAS_TYPE_DOUBLE:
return basValDouble(0.0);
case BAS_TYPE_DATE:
return basValDate(0.0);
case BAS_TYPE_VARIANT:
return basValEmpty();
case BAS_TYPE_OBJECT:
return basValObject(NULL);
default:
return basValInteger(0);
}
}
Reference in a new issue View git blame Copy permalink