// 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. // test_compiler.c -- End-to-end test: source -> compiler -> VM -> output // // Build: make -C dvxbasic tests #include "compiler/front.h" #include "runtime/vm.h" #include "runtime/values.h" #include "runtime/screen.h" #include "runtime/serialize.h" #include "testCapture.h" // The DVX 8x16 font, so screen text draws real glyphs #define DVX_FONT_IMPL #include "dvxFont.h" #include #include #include #include #include #include // Count of failed checks. main() returns non-zero when this is > 0 so // `make tests` actually gates on these assertions instead of the harness // always exiting 0 while printing FAIL. static int32_t gFailCount = 0; // Generated-source limit tests (testCompilerLimits / testLexerLimits). #define TEST_LIMIT_CONSTS 65600 // one past the 16-bit constant pool #define TEST_LIMIT_JUMPBODY 3500 // IF body wider than an int16 jump (and, with the FOR body, code past 64 KB) #define TEST_LIMIT_FORBODY 3000 // FOR body wider than an int16 jump #define TEST_LIMIT_GOSUB_ADD 1000 // what the far GOSUB adds #define TEST_LIMIT_GLOBALS 520 // one past BAS_VM_MAX_GLOBALS #define TEST_LIMIT_LOCALS 65 // one past BAS_VM_MAX_LOCALS #define TEST_LIMIT_READ_ELEMS 40 // READ targets whose temps must not pile up #define TEST_LIMIT_SRC_CAP (2 * 1024 * 1024) #define TEST_LIMIT_EXPECT_LEN 64 // Compile time against program size (testFrontEnd): procedures in the // small program, how many times as many the large one has, the most its // compile may take relative to the small one's (linear growth gives about // TEST_SCALE_FACTOR, quadratic its square), the runs each is timed over // (the best counts) and the generated source per procedure. #define TEST_SCALE_PROCS 1000 #define TEST_SCALE_FACTOR 4 #define TEST_SCALE_LIMIT 8.0 #define TEST_SCALE_RUNS 5 #define TEST_SCALE_LINE_MAX 96 #define TEST_LONG_STRING_LEN 300 // past BAS_MAX_STRING_LEN #define TEST_LONG_STRING_SRC 512 #define TEST_NAMED_EXTRA 4 // named arguments past BAS_VM_MAX_CALL_ARGS #define TEST_NAMED_PAD (BAS_MAX_IDENT - 1 - 3) // zeros after "Nnn": the longest identifier #define TEST_NAMED_SRC_LEN 2048 // a call with BAS_VM_MAX_CALL_ARGS + TEST_NAMED_EXTRA of them #define TEST_TOKEN_NAME_SWEEP 512 // covers the whole token enum #define TEST_SWAP_LINES 600 // element SWAPs sharing the temporaries #define TEST_EXTERN_REC_LEN 128 // one recorded extern call #define TEST_ROW_TEXT_LEN 96 // one screen text row read back #define TEST_KEYS_MAX 16 // keys a screen test types #define TEST_MOUSE_STEPS 4 // mouse moves a screen test makes, one per DoEvents #define TEST_PEN_X1 100 // the PEN test's press (SCREEN 12 pixels) ... #define TEST_PEN_Y1 50 #define TEST_PEN_X2 300 // ... and where the mouse goes after it #define TEST_PEN_Y2 200 #define TEST_PROGRAM_MAX 8192 // a program built from a template (runBothBindings) #define TEST_TITLE_MAX 256 // its test title // Keys a screen test's DoEvents stub types into the program screen (once, // on its first call), and the mouse it moves there (one step a call). typedef struct { BasVmT *vm; int32_t keys[TEST_KEYS_MAX]; int32_t count; int32_t calls; int32_t mouseX[TEST_MOUSE_STEPS]; // the mouse over the screen at DoEvents call i int32_t mouseY[TEST_MOUSE_STEPS]; bool mouseDown[TEST_MOUSE_STEPS]; int32_t mouseCount; } TestKeysT; // Function prototypes static double bestCompileSeconds(int32_t procs); static bool capturePlayMacro(void *ctx, const char *macro); static int32_t cellPixels(const BasScreenT *scr, int32_t row, int32_t col, uint8_t color); static void checkTrue(const char *what, bool ok); static void compileOnly(const char *name, const char *source); static void expectCompileError(const char *name, const char *source, const char *needle); static void expectValidatorParse(const char *name, const char *source, const char *needle); static uint8_t fbAt(const BasScreenT *scr, int32_t x, int32_t y); static double globalNum(const BasVmT *vm, const char *name); static void rowText(const BasScreenT *scr, int32_t row, char *out); static void runBothBindings(const char *name, const char *source, const char *expected); static void runExternProgram(const char *name, const char *source, const char *expected); static void runFastAndStepped(const char *name, const char *source, const char *expected); static void runProgram(const char *name, const char *source, const char *expected); static void runProgramPlay(const char *name, const char *source, const char *expected, bool capturePlay); static BasVmT *screenRun(const char *name, const char *source, CaptureT *cap, TestKeysT *keys); static void screenRunFree(BasVmT *vm); static uint8_t shownAt(const BasScreenT *scr, int32_t x, int32_t y); static BasValueT stubCallExtern(void *ctx, void *funcPtr, const char *libName, const char *funcName, BasValueT *args, int32_t argc, uint8_t retType, uint32_t binaryMask); static bool stubIsMethodValid(void *ctx, const char *wgtType, const char *methodName); static bool stubIsPropValid(void *ctx, const char *wgtType, const char *propName); static const char *stubLookupCtrlType(void *ctx, const char *ctrlName); static int32_t stubMsgBox(void *ctx, const char *msg, int32_t flags, const char *title); static void *stubResolveExtern(void *ctx, const char *libName, const char *funcName); static void testClassWithEvents(void); static void testCompilerFixes(void); static void testCompilerLimits(void); static void testConsoleGraphics(void); static void testConstEnumParamArray(void); static void testEarlyBinding(void); static void testEventsAndInterfaces(void); static void testFastLoop(void); static void testFollowUp(void); static void testFrontEnd(void); static void testGapClosure(void); static bool testKeysDoEvents(void *ctx); static void testKeywordApi(void); static void testLexerLimits(void); static void testMissingAndValues(void); static void testObjectsAndVariants(void); static void testParamArrayByRef(void); static void testParamDefaults(void); static void testReferences(void); static void testScreenModesPages(void); static void testStringsAndDates(void); static void testTokenNames(void); static void testUserControl(void); static void ucEventHost(void *ctx, const BasObjectT *obj, int32_t eventIdx, BasValueT *args, int32_t argc); // Headless stand-in for the form runtime: MsgBox answers OK so programs // that show one still run to completion (every other form/control // operation raises error 1000 without a callback). static const BasUiCallbacksT sStubUi = { .msgBox = stubMsgBox }; // The best of TEST_SCALE_RUNS compile times (CPU seconds) of a program // of procs one-line FUNCTIONs, each calling the one before; -1 when it // fails to compile. static double bestCompileSeconds(int32_t procs) { char *src = (char *)malloc((size_t)(procs + 1) * TEST_SCALE_LINE_MAX); if (src == NULL) { return -1.0; } int32_t len = snprintf(src, TEST_SCALE_LINE_MAX, "PRINT F%d(1)\n", (int32_t)(procs - 1)); for (int32_t i = 0; i < procs; i++) { len += snprintf(src + len, TEST_SCALE_LINE_MAX, "FUNCTION F%d(BYVAL a AS LONG) AS LONG\nF%d = a%s\nEND FUNCTION\n", (int)i, (int)i, (i > 0) ? " + 1" : ""); } double best = -1.0; for (int32_t r = 0; r < TEST_SCALE_RUNS; r++) { clock_t start = clock(); BasCompilerT *compiler = basCompilerCreate(src, len); bool ok = compiler != NULL && basCompile(compiler); double secs = (double)(clock() - start) / CLOCKS_PER_SEC; basCompilerDestroy(compiler); if (!ok) { free(src); return -1.0; } if (best < 0.0 || secs < best) { best = secs; } } free(src); return best; } // A PLAY device callback for runProgramPlay: ctx is the CaptureT. static bool capturePlayMacro(void *ctx, const char *macro) { captureAppend((CaptureT *)ctx, "[PLAY "); captureAppend((CaptureT *)ctx, macro); captureAppend((CaptureT *)ctx, "]\n"); return true; } // One named check of a screen test. // Pixels of one colour in a text cell of the shown page. static int32_t cellPixels(const BasScreenT *scr, int32_t row, int32_t col, uint8_t color) { int32_t count = 0; for (int32_t y = row * scr->cellH; y < (row + 1) * scr->cellH; y++) { for (int32_t x = col * BAS_GFX_GLYPH_W; x < (col + 1) * BAS_GFX_GLYPH_W; x++) { count += shownAt(scr, x, y) == color; } } return count; } static void checkTrue(const char *what, bool ok) { if (!ok) { printf("FAIL: %s\n", what); gFailCount++; } } // Compile source expecting success without running it (constructs whose // execution needs a form runtime or host I/O). static void compileOnly(const char *name, const char *source) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); if (!basCompile(compiler)) { printf("FAIL: compile error: %s\n\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); return; } BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("FAIL: module build failed\n\n"); gFailCount++; return; } basModuleFree(mod); printf("OK\n\n"); } // Compile source expecting it to be rejected; the error text must // contain needle. static void expectCompileError(const char *name, const char *source, const char *needle) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); bool ok = basCompile(compiler); if (ok) { printf("FAIL: compiled but expected error containing [%s]\n\n", needle); gFailCount++; } else if (strstr(basCompilerError(compiler), needle) == NULL) { printf("FAIL: error [%s] does not contain [%s]\n\n", basCompilerError(compiler), needle); gFailCount++; } else { printf("OK (expected error: %s)\n\n", basCompilerError(compiler)); } basCompilerDestroy(compiler); } // Compile with the stub control validator attached. A NULL needle means // the source must compile; otherwise it must fail with the needle in the // error text. static void expectValidatorParse(const char *name, const char *source, const char *needle) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); BasCtrlValidatorT validator = { stubLookupCtrlType, stubIsMethodValid, stubIsPropValid, compiler }; basCompilerSetValidator(compiler, &validator); bool ok = basCompile(compiler); if (needle == NULL) { if (ok) { printf("OK\n\n"); } else { printf("FAIL: compile error: %s\n\n", basCompilerError(compiler)); gFailCount++; } } else if (ok) { printf("FAIL: compiled but expected error containing [%s]\n\n", needle); gFailCount++; } else if (strstr(basCompilerError(compiler), needle) == NULL) { printf("FAIL: error [%s] does not contain [%s]\n\n", basCompilerError(compiler), needle); gFailCount++; } else { printf("OK (expected error: %s)\n\n", basCompilerError(compiler)); } basCompilerDestroy(compiler); } // Compile and run source. PRINT output is captured and, when expected // is not NULL, must match it exactly; a compile error or a VM error is // always a failure. // Compile and run source with DECLARE LIBRARY resolution stubbed out; // every extern call records "Name(types)" (see stubCallExtern) and the // record must equal expected. static uint8_t fbAt(const BasScreenT *scr, int32_t x, int32_t y) { return scr->fb[y * scr->width + x]; } // A module-level variable's value by name (the module's debug names). static double globalNum(const BasVmT *vm, const char *name) { for (int32_t i = 0; i < vm->module->debugVarCount; i++) { const BasDebugVarT *v = &vm->module->debugVars[i]; if (v->procIndex < 0 && strcasecmp(v->name, name) == 0) { return basValToNumber(vm->globals[v->index]); } } printf("FAIL: no variable %s\n", name); gFailCount++; return 0.0; } // A screen text row, trailing blanks removed. static void rowText(const BasScreenT *scr, int32_t row, char *out) { int32_t len = scr->cols; memcpy(out, &scr->chars[row * scr->cols], (size_t)len); while (len > 0 && out[len - 1] == ' ') { len--; } out[len] = '\0'; } // Runs program template twice, its @T@ standing for the class Acct (members // bound at compile time) and for Object (late bound): both must print // expected. static void runBothBindings(const char *name, const char *source, const char *expected) { static const char *const types[] = { "Acct", "Object" }; static const char token[] = "@T@"; for (int32_t t = 0; t < DVX_ARRAY_LEN(types); t++) { char program[TEST_PROGRAM_MAX]; char title[TEST_TITLE_MAX]; int32_t len = 0; const char *p = source; while (*p != '\0' && len < (int32_t)sizeof(program) - 1) { if (strncmp(p, token, sizeof(token) - 1) == 0) { len += snprintf(program + len, sizeof(program) - (size_t)len, "%s", types[t]); p += sizeof(token) - 1; } else { program[len++] = *p++; } } program[DVX_MIN(len, (int32_t)sizeof(program) - 1)] = '\0'; snprintf(title, sizeof(title), "%s (As %s)", name, types[t]); runProgram(title, program, expected); } } static void runExternProgram(const char *name, const char *source, const char *expected) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); return; } BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("MODULE BUILD FAILED\n\n"); gFailCount++; return; } CaptureT cap; BasExternCallbacksT ext; BasVmT *vm = basVmCreate(); cap.buf[0] = '\0'; cap.len = 0; ext.resolveExtern = stubResolveExtern; ext.callExtern = stubCallExtern; ext.ctx = ∩ basVmLoadModule(vm, mod); basVmSetExternCallbacks(vm, &ext); BasVmResultE result = basVmRun(vm); printf("%s\n", cap.buf); if (result != BAS_VM_HALTED && result != BAS_VM_OK) { printf("[VM error %d: %s]\n", result, basVmGetError(vm)); gFailCount++; } else if (strcmp(cap.buf, expected) != 0) { printf("FAIL: expected [%s]\n", expected); gFailCount++; } basVmDestroy(vm); basModuleFree(mod); printf("\n"); } // Runs a program (without ON ERROR: basVmStep alone dispatches no error // handler) twice: with basVmRun, whose fast loop runs the frequent // instructions inline, and one basVmStep at a time, the reference // implementation. Both must print expected. static void runFastAndStepped(const char *name, const char *source, const char *expected) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); return; } BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("MODULE BUILD FAILED\n\n"); gFailCount++; return; } for (int32_t stepped = 0; stepped <= 1; stepped++) { CaptureT cap; BasVmT *vm = basVmCreate(); BasVmResultE result = BAS_VM_OK; captureReset(&cap); basVmLoadModule(vm, mod); basVmSetPrintCallback(vm, capturePrint, &cap); basVmSetUiCallbacks(vm, &sStubUi); if (stepped) { vm->running = true; while (vm->running && result == BAS_VM_OK) { result = basVmStep(vm); } } else { result = basVmRun(vm); } fputs(cap.buf, stdout); if (result != BAS_VM_HALTED && result != BAS_VM_OK) { printf("[%s: VM error %d: %s]\n", stepped ? "stepped" : "run", result, basVmGetError(vm)); gFailCount++; } else if (expected != NULL && strcmp(cap.buf, expected) != 0) { printf("FAIL (%s): expected output [%s]\n", stepped ? "stepped" : "run", expected); gFailCount++; } basVmDestroy(vm); } basModuleFree(mod); printf("\n"); } static void runProgram(const char *name, const char *source, const char *expected) { runProgramPlay(name, source, expected, false); } // runProgram; with capturePlay each PLAY's macro (as the music library // gets it) is captured as "[PLAY macro]" lines among the output. static void runProgramPlay(const char *name, const char *source, const char *expected, bool capturePlay) { printf("=== %s ===\n", name); int32_t len = (int32_t)strlen(source); BasCompilerT *compiler = basCompilerCreate(source, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); return; } BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("MODULE BUILD FAILED\n\n"); gFailCount++; return; } CaptureT cap; cap.buf[0] = '\0'; cap.len = 0; BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); basVmSetPrintCallback(vm, capturePrint, &cap); basVmSetUiCallbacks(vm, &sStubUi); if (capturePlay) { BasDeviceCallbacksT device; memset(&device, 0, sizeof(device)); device.play = capturePlayMacro; device.ctx = ∩ basVmSetDeviceCallbacks(vm, &device); } BasVmResultE result = basVmRun(vm); // A normal end releases the module variables (Class_Terminate), as // the hosts do if (result == BAS_VM_HALTED && basVmFinish(vm)) { result = basVmRun(vm); } fputs(cap.buf, stdout); if (result != BAS_VM_HALTED && result != BAS_VM_OK) { printf("[VM error %d: %s]\n", result, basVmGetError(vm)); gFailCount++; } else if (expected != NULL && strcmp(cap.buf, expected) != 0) { printf("FAIL: expected output [%s]\n", expected); gFailCount++; } basVmDestroy(vm); basModuleFree(mod); printf("\n"); } // Compile and run a program that uses the program screen; the VM is // returned for the checks (screenRunFree ends it), NULL when the program // did not compile or made no screen. keys (optional) are typed at the // first DoEvents. static BasVmT *screenRun(const char *name, const char *source, CaptureT *cap, TestKeysT *keys) { printf("=== %s ===\n", name); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); if (!basCompile(compiler)) { printf("FAIL: compile error: %s\n\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); return NULL; } BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("FAIL: module build failed\n\n"); gFailCount++; return NULL; } BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); captureReset(cap); basVmSetPrintCallback(vm, capturePrint, cap); basVmSetUiCallbacks(vm, &sStubUi); if (keys) { keys->vm = vm; keys->calls = 0; basVmSetDoEventsCallback(vm, testKeysDoEvents, keys); } BasVmResultE result = basVmRun(vm); if (result != BAS_VM_HALTED && result != BAS_VM_OK) { printf("FAIL: [VM error %d: %s]\n", result, basVmGetError(vm)); gFailCount++; } if (vm->screen == NULL) { printf("FAIL: the program made no screen\n\n"); gFailCount++; screenRunFree(vm); return NULL; } return vm; } static void screenRunFree(BasVmT *vm) { BasModuleT *mod = vm->module; basVmDestroy(vm); basModuleFree(mod); printf("\n"); } // A pixel of the visual page. static uint8_t shownAt(const BasScreenT *scr, int32_t x, int32_t y) { return scr->shown[y * scr->width + x]; } // Extern call stub: appends "Func(t,t,...)" to the capture (ctx), one // type letter per argument, and returns 0. static BasValueT stubCallExtern(void *ctx, void *funcPtr, const char *libName, const char *funcName, BasValueT *args, int32_t argc, uint8_t retType, uint32_t binaryMask) { CaptureT *c = (CaptureT *)ctx; char rec[TEST_EXTERN_REC_LEN]; int32_t n = 0; (void)funcPtr; (void)libName; (void)retType; n += snprintf(rec + n, sizeof(rec) - n, "%s%s(", c->len > 0 ? " " : "", funcName); for (int32_t i = 0; i < argc; i++) { char t = '?'; switch (args[i].type) { case BAS_TYPE_INTEGER: t = 'I'; break; case BAS_TYPE_LONG: t = 'L'; break; case BAS_TYPE_SINGLE: t = 'S'; break; case BAS_TYPE_DOUBLE: t = 'D'; break; case BAS_TYPE_STRING: t = (binaryMask & (1u << i)) ? 'b' : '$'; break; case BAS_TYPE_BOOLEAN: t = 'B'; break; default: break; } n += snprintf(rec + n, sizeof(rec) - n, "%s%c", i > 0 ? "," : "", t); } snprintf(rec + n, sizeof(rec) - n, ")%s", (binaryMask & BAS_EXTERN_BINARY_RET) ? "b" : ""); captureAppend(c, rec); return basValInteger(0); } static bool stubIsMethodValid(void *ctx, const char *wgtType, const char *methodName) { (void)ctx; (void)wgtType; return strcasecmp(methodName, "BadMethod") != 0; } static bool stubIsPropValid(void *ctx, const char *wgtType, const char *propName) { (void)ctx; (void)wgtType; return strcasecmp(propName, "BadProp") != 0; } // Text1 is a TextBox on every form; Lbl2 is a Label only on form F1 (the // validator ctx is the compiler, asked for the form being compiled). static const char *stubLookupCtrlType(void *ctx, const char *ctrlName) { if (strcasecmp(ctrlName, "Text1") == 0) { return "TextBox"; } if (strcasecmp(ctrlName, "Lbl2") == 0 && strcasecmp(basCompilerFormScope((const BasCompilerT *)ctx), "F1") == 0) { return "Label"; } return NULL; } static int32_t stubMsgBox(void *ctx, const char *msg, int32_t flags, const char *title) { (void)ctx; (void)msg; (void)flags; (void)title; return 1; } // Resolve every extern to a dummy non-NULL pointer. static void *stubResolveExtern(void *ctx, const char *libName, const char *funcName) { (void)libName; (void)funcName; return ctx; } // Regression tests for the compiler fixes: label ownership, local CONST, // DEF FN scope, literal forms, store targets, argument passing and the // missing-terminator checks. static void testClassWithEvents(void) { runProgram("WithEvents in a class: each instance handles its own source with itself as Me", "DIM a AS NEW Listener\n" "DIM b AS NEW Listener\n" "a.Nm = \"A\"\n" "b.Nm = \"B\"\n" "a.Go 1\n" "b.Go 2\n" "a.Share b\n" "b.Go 3\n" "BEGINCLASS \"Source\"\n" "Public Event Ping(ByVal n AS INTEGER, reply AS STRING)\n" "Public Sub Fire(n AS INTEGER)\n" " DIM r AS STRING\n" " RaiseEvent Ping(n, r)\n" " PRINT \"reply=\"; r\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Listener\"\n" "Public Nm AS STRING\n" "Private WithEvents src AS Source\n" "Private Sub Class_Initialize()\n" " SET src = NEW Source\n" "End Sub\n" "Public Sub Go(n AS INTEGER)\n" " src.Fire n\n" "End Sub\n" "Public Sub Share(other AS Listener)\n" " other.Take src\n" "End Sub\n" "Public Sub Take(s AS Source)\n" " SET src = s\n" "End Sub\n" "Private Sub src_Ping(ByVal n AS INTEGER, reply AS STRING)\n" " PRINT Nm; n;\n" " reply = reply + Me.Nm\n" "End Sub\n" "ENDCLASS\n", "A1 reply=A\n" "B2 reply=B\n" "B3 A3 reply=BA\n" ); runProgram("WithEvents in a class: a freed listener hears nothing; its Terminate order", "DIM keep AS Source\n" "DIM l AS Listener\n" "SET l = NEW Listener\n" "SET keep = l.Src\n" "keep.Fire 1\n" "SET l = Nothing\n" "keep.Fire 2\n" "PRINT \"end\"\n" "BEGINCLASS \"Source\"\n" "Public Event Ping(ByVal n AS INTEGER)\n" "Public Sub Fire(n AS INTEGER)\n" " PRINT \"fire\"; n\n" " RaiseEvent Ping(n)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Listener\"\n" "Public WithEvents Src AS Source\n" "Private Sub Class_Initialize()\n" " SET Src = NEW Source\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"listener gone\"\n" " Src.Fire 9\n" "End Sub\n" "Private Sub Src_Ping(ByVal n AS INTEGER)\n" " PRINT \"heard\"; n\n" "End Sub\n" "ENDCLASS\n", "fire1 \n" "heard1 \n" "listener gone\n" "fire9 \n" "heard9 \n" "fire2 \n" "end\n" ); runProgram("WithEvents in a class: a source holding its listener (cycle) is collected, Terminates run", "MakePair\n" "PRINT \"after\"\n" "SUB MakePair()\n" " DIM l AS NEW Listener\n" " l.Poke\n" "END SUB\n" "BEGINCLASS \"Source\"\n" "Public Event Ping()\n" "Public Owner AS Listener\n" "Public Sub Fire()\n" " RaiseEvent Ping()\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"source term\"\n" " RaiseEvent Ping()\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Listener\"\n" "Private WithEvents s AS Source\n" "Private Sub Class_Initialize()\n" " SET s = NEW Source\n" " SET s.Owner = Me\n" "End Sub\n" "Public Sub Poke()\n" " s.Fire\n" "End Sub\n" "Private Sub s_Ping()\n" " PRINT \"ping\"\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"listener term\"\n" "End Sub\n" "ENDCLASS\n", "ping\n" "after\n" "listener term\n" "source term\n" "ping\n" ); runProgram("WithEvents in a class: handler drops the last outside reference and rebinds", "DIM SHARED g AS Listener\n" "SET g = NEW Listener\n" "g.Go\n" "PRINT \"done\"\n" "BEGINCLASS \"Source\"\n" "Public Event Ping(ByVal n AS INTEGER)\n" "Public Sub Fire(n AS INTEGER)\n" " RaiseEvent Ping(n)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Listener\"\n" "Private WithEvents s AS Source\n" "Private keepS AS Source\n" "Private Sub Class_Initialize()\n" " SET s = NEW Source\n" " SET keepS = s\n" "End Sub\n" "Public Sub Go()\n" " keepS.Fire 1\n" " keepS.Fire 2\n" "End Sub\n" "Private Sub s_Ping(ByVal n AS INTEGER)\n" " PRINT \"ping\"; n\n" " SET s = Nothing\n" " SET g = Nothing\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"term\"\n" "End Sub\n" "ENDCLASS\n", "ping1 \n" "term\n" "done\n" ); runProgram("WithEvents in a class: many listeners and sources made and dropped in a loop", "DIM i AS INTEGER\n" "DIM total AS LONG\n" "FOR i = 1 TO 3000\n" " DIM l AS Listener\n" " SET l = NEW Listener\n" " total = total + l.Run(i)\n" "NEXT\n" "PRINT total\n" "BEGINCLASS \"Source\"\n" "Public Event Ping(v AS LONG)\n" "Public Back AS Object\n" "Public Sub Fire(v AS LONG)\n" " RaiseEvent Ping(v)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Listener\"\n" "Private WithEvents s AS Source\n" "Public Function Run(n AS INTEGER) AS LONG\n" " DIM v AS LONG\n" " SET s = NEW Source\n" " SET s.Back = Me\n" " v = n\n" " s.Fire v\n" " Run = v\n" "End Function\n" "Private Sub s_Ping(v AS LONG)\n" " v = v * 2\n" "End Sub\n" "ENDCLASS\n", "9003000 \n" ); expectCompileError("WithEvents in a class: handler must match the event", "BEGINCLASS \"K\"\n" "Event E(a AS INTEGER)\n" "ENDCLASS\n" "BEGINCLASS \"L\"\n" "Private WithEvents kk AS K\n" "Private Sub kk_E(a AS STRING)\n" "End Sub\n" "ENDCLASS\n", "does not match the declaration of event E"); expectCompileError("WithEvents in a class: not inside a procedure", "BEGINCLASS \"K\"\n" "Event E()\n" "Public Sub F()\n" " DIM WithEvents k AS K\n" "End Sub\n" "ENDCLASS\n", "WithEvents variables belong at module level"); } static void testCompilerFixes(void) { // Labels are their own namespace and must be defined (S4-004, S3-028, S3-035, S3-036) expectCompileError("GOSUB to a SUB name is not a label", "PRINT \"start\"\n" "GOSUB Foo\n" "END\n" "SUB Foo\n" "END SUB\n", "Label not defined: Foo" ); expectCompileError("GOTO a variable name is not a label", "x = 1\n" "GOTO x\n" "PRINT \"fell through\"\n", "Label not defined: x" ); expectCompileError("Undefined GOTO label rejected", "GOTO nowhere\n" "PRINT \"fell through\"\n", "Label not defined: nowhere" ); expectCompileError("ON ERROR GOTO a variable rejected", "x = 1\n" "ON ERROR GOTO x\n" "y = 1 / 0\n", "Label not defined: x" ); expectCompileError("Undefined ON ERROR label rejected", "ON ERROR GOTO handlr\n" "PRINT 1\n", "Label not defined: handlr" ); // Labels belong to their procedure (S3-029, S3-041) expectCompileError("GOTO into another SUB rejected", "SUB A\n" "GOTO fin\n" "END SUB\n" "SUB B\n" "fin:\n" "PRINT \"B fin\"\n" "END SUB\n" "A\n", "Label not defined: fin" ); expectCompileError("GOTO from module into a SUB rejected", "GOTO inner\n" "SUB S\n" "inner:\n" "PRINT \"inside S\"\n" "END SUB\n", "Label not defined: inner" ); expectCompileError("GOTO from a SUB to a module label rejected", "top:\n" "SUB S\n" "GOTO top\n" "END SUB\n", "Label not defined: top" ); runProgram("Same label name in several procedures", "SUB A\n" "GOTO fin\n" "fin:\n" "PRINT \"A fin\"\n" "END SUB\n" "SUB B\n" "GOTO fin\n" "fin:\n" "PRINT \"B fin\"\n" "END SUB\n" "A\n" "B\n" "GOTO fin\n" "PRINT \"skipped\"\n" "fin:\n" "PRINT \"module fin\"\n", "A fin\nB fin\nmodule fin\n" ); runProgram("ON ERROR GOTO a label in the same SUB", "SUB S\n" "ON ERROR GOTO h\n" "x = 1 / 0\n" "PRINT \"after\"\n" "EXIT SUB\n" "h:\n" "PRINT \"handled\"\n" "RESUME NEXT\n" "END SUB\n" "S\n", "handled\nafter\n" ); // Suffixed literals keep their fraction/exponent (S3-026) runProgram("Integer suffix on a fraction or exponent rounds", "PRINT 1E3%; 1.5&; 2E3&; 2.5%; 3.5%\n", "1000 2 2000 2 4 \n" ); // S3-027: arr(i) + 1 goes by value, a bare arr(i) still by reference runProgram("BYREF argument that is an element expression", "SUB Inc(x)\n" "x = x + 1\n" "END SUB\n" "SUB Show1(x)\n" "PRINT x\n" "END SUB\n" "DIM a(3)\n" "a(1) = 5\n" "Show1 a(1) + 1\n" "Inc a(1)\n" "PRINT a(1)\n", "6 \n6 \n" ); // S3-030 runProgram("CONST in a SUB is local", "CONST MAXV = 5\n" "SUB A\n" "CONST MAXV = 10\n" "PRINT MAXV\n" "END SUB\n" "A\n" "PRINT MAXV\n" "SUB B\n" "CONST MAXV = 7\n" "PRINT MAXV\n" "END SUB\n" "B\n", "10 \n5 \n7 \n" ); // S3-031 runProgram("DEF FN free variables are module variables", "DEF FNx(a) = a * rate\n" "rate = 2\n" "PRINT FNx(5)\n" "PRINT rate\n", "10 \n2 \n" ); // S3-032 runProgram("DIM with several declarators", "DIM name$, count%, total&\n" "DIM a AS INTEGER, b AS STRING, c(2) AS LONG\n" "name$ = \"n\": count% = 2: total& = 70000: a = 3: b = \"s\": c(2) = 9\n" "PRINT name$; count%; total&; a; b; c(2)\n", "n2 70000 3 s9 \n" ); // S3-033 expectCompileError("ENDFORM inside a SUB rejected", "BEGINFORM \"F1\"\n" "SUB S\n" "ENDFORM\n" "END SUB\n" "PRINT \"x\"\n", "ENDFORM inside SUB/FUNCTION is not allowed" ); // S2-074 expectCompileError("BEGINFORM without ENDFORM rejected", "BEGINFORM \"F1\"\n" "DIM x AS INTEGER\n", "BEGINFORM without ENDFORM" ); // S3-037 runProgram("DEFINT applies to parameters, STATIC and FUNCTION results", "DEFINT A-Z\n" "SUB S(x)\n" "x = 7 / 2\n" "PRINT x\n" "END SUB\n" "SUB T\n" "STATIC n\n" "n = 7 / 2\n" "PRINT n\n" "END SUB\n" "FUNCTION F()\n" "F = 7 / 2\n" "END FUNCTION\n" "S 1\n" "T\n" "PRINT F\n", "4 \n4 \n4 \n" ); runProgram("FUNCTION AS INTEGER converts its result", "FUNCTION G() AS INTEGER\n" "G = 2.5\n" "END FUNCTION\n" "FUNCTION H$()\n" "H$ = \"ok\"\n" "END FUNCTION\n" "PRINT G; H$\n", "2 ok\n" ); // S3-038 expectCompileError("SUB called in an expression rejected", "SUB MySub(a)\n" "END SUB\n" "x = MySub(1)\n", "Sub 'MySub' cannot be used in an expression" ); expectCompileError("Scalar variable called like a function rejected", "x = 5\n" "y = x()\n", "'x' is not an array or function" ); expectCompileError("CONST indexed like an array rejected", "CONST C = 5\n" "y = C(1)\n", "'C' is not an array or function" ); expectCompileError("Assignment to an element of a scalar rejected", "x = 5\n" "x(1) = 2\n", "'x' is not an array" ); // S3-039 runProgram("PRINT USING separators and trailing ;", "PRINT USING \"##\"; 5;\n" "PRINT \"X\"\n" "PRINT USING \"##\"; 1, 2\n" "PRINT USING \"##\"; 3,\n" "PRINT \"Y\"\n", " 5X\n 1 2\n 3Y\n" ); // S3-042 runProgram("SWAP evaluates each subscript once", "DIM SHARED c\n" "DIM a(2)\n" "FUNCTION N()\n" "c = c + 1\n" "N = c\n" "END FUNCTION\n" "a(1) = 10: a(2) = 20: a(0) = 99\n" "SWAP a(N), a(0)\n" "PRINT a(0); a(1); a(2); c\n" "DIM x, y\n" "x = 1: y = 2\n" "SWAP x, y\n" "PRINT x; y\n", "10 99 20 1 \n2 1 \n" ); // S2-073 runProgram("FUNCTION called as a statement", "FUNCTION F(n)\n" "PRINT \"F\"; n\n" "F = n\n" "END FUNCTION\n" "F 3\n", "F3 \n" ); // S2-075 runProgram("CONST AS type converts the literal", "CONST N AS INTEGER = 2.5\n" "CONST M AS LONG = 3.5\n" "CONST S AS SINGLE = 0.1\n" "CONST B AS BOOLEAN = 5\n" "PRINT N; M; B\n" "PRINT S\n", "2 4 True \n0.1 \n" ); expectCompileError("CONST AS STRING with a number rejected", "CONST S AS STRING = 5\n", "Type mismatch in CONST" ); expectCompileError("CONST AS INTEGER overflow rejected", "CONST N AS INTEGER = 40000\n", "Overflow in CONST" ); // S2-076, S2-077 runProgram("Most negative INTEGER and LONG literals", "CONST M = -2147483648\n" "CONST H = &H80000000\n" "PRINT M; H; -32768%; -2147483648&\n" "DATA -2147483648, -32768%\n" "READ a&, b%\n" "PRINT a&; b%\n", "-2147483648 -2147483648 -32768 -2147483648 \n-2147483648 -32768 \n" ); // A CONST value is an expression: -&H80000000 negates the LONG // -2147483648 as it would anywhere else, an Overflow (VB) expectCompileError("Negated LONG minimum constant overflows", "CONST H = -&H80000000\n", "Error in constant expression: Overflow" ); // S2-078 runProgram("Unquoted DATA text is read raw", "DATA Apple, Name, Red Green, 12abc, -, Print\n" "FOR i = 1 TO 6\n" "READ s$\n" "PRINT \"[\"; s$; \"]\"\n" "NEXT\n", "[Apple]\n[Name]\n[Red Green]\n[12abc]\n[-]\n[Print]\n" ); // S2-081 expectCompileError("Nine array dimensions rejected", "DIM a(1, 1, 1, 1, 1, 1, 1, 1, 1)\n", "Too many array dimensions" ); expectCompileError("Nine subscripts rejected", "DIM a(1)\n" "x = a(1, 1, 1, 1, 1, 1, 1, 1, 1)\n", "Too many array dimensions" ); // S2-090 expectCompileError("UBOUND dimension out of range rejected", "DIM a(10)\n" "PRINT UBOUND(a, 257)\n", "UBOUND dimension must be a constant integer from 1 to 8" ); // S2-092 compileOnly("Control array members may be keywords or methods", "x$ = Foo(0).Name\n" "y = Foo(0).Move(1)\n" "Foo(1).Name = \"n\"\n" "Me.Foo(0).Text = \"t\"\n" "Me.Refresh\n" ); // S2-093 runProgram("READ, INPUT # and LINE INPUT # into elements and fields", "TYPE P\n" "x AS INTEGER\n" "n AS STRING\n" "END TYPE\n" "DIM q AS P\n" "DIM arr(2) AS P\n" "DIM a(3), t(2)\n" "DATA 4, \"nm\", 6, 7, 8\n" "READ q.x, q.n, arr(1).x, a(1), a(2)\n" "PRINT q.x; q.n; arr(1).x; a(1); a(2)\n" "OPEN \"dvxbasic_readelem.txt\" FOR OUTPUT AS #1\n" "PRINT #1, 5\n" "PRINT #1,\n" "PRINT #1, \"z\"\n" "CLOSE #1\n" "OPEN \"dvxbasic_readelem.txt\" FOR INPUT AS #1\n" "INPUT #1, t(1)\n" "LINE INPUT #1, e$\n" "LINE INPUT #1, arr(2).n\n" "CLOSE #1\n" "KILL \"dvxbasic_readelem.txt\"\n" "PRINT t(1); \"[\"; e$; \"]\"; arr(2).n\n", "4 nm6 7 8 \n5 []z\n" ); // S2-096 expectCompileError("Missing END SUB rejected", "PRINT \"x\"\n" "SUB S\n" "PRINT 1\n", "Expected END SUB" ); expectCompileError("Missing END FUNCTION rejected", "FUNCTION F\n" "F = 1\n", "Expected END FUNCTION" ); expectCompileError("Missing END TYPE rejected", "TYPE T\n" "x AS INTEGER\n", "Expected END TYPE" ); expectCompileError("Missing END DECLARE rejected", "DECLARE LIBRARY \"x\"\n" "DECLARE SUB F()\n", "END DECLARE" ); // S2-068 expectCompileError("Lexer error reported at the token start once", "PRINT 99999999999\n", "Line 1, Col 7: Integer literal out of range" ); // S1-073 expectCompileError("Over-long numeric literal rejected", "PRINT 0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000007\n", "Numeric literal too long" ); // S1-078 runProgram("Trailing-dot float literal", "PRINT 1.; 2. + 1\n", "1 3 \n" ); // S1-088 expectCompileError("DEF FN used before its definition rejected", "PRINT FNsq(2)\n" "DEF FNsq(x) = x * x\n", "must be defined before it is used" ); // S1-087 expectCompileError("DECLARE with a different BYVAL rejected", "DECLARE SUB S(BYVAL x AS INTEGER)\n" "SUB S(x AS INTEGER)\n" "END SUB\n", "does not match its definition" ); // S1-104 runProgram("Negated LONG minimum raised to a power", "x& = -2147483648 ^ 1\n" "PRINT x&\n", "-2147483648 \n" ); // VM coordination: bare RND is RND(1) (a negative argument reseeds) runProgram("Bare RND gives the next number", "a = RND\n" "b = RND\n" "c = RND()\n" "PRINT a <> b; b <> c; a < 1\n", "True True True \n" ); // MID$ statement without a length replaces as much as fits runProgram("MID$ statement with the length omitted", "s$ = \"abcdef\"\n" "MID$(s$, 2) = \"XY\"\n" "PRINT s$\n" "MID$(s$, 4, 1) = \"QQ\"\n" "PRINT s$\n", "aXYdef\naXYQef\n" ); // An INTEGER/LONG FOR counter stays whole: limit and STEP convert, // a constant fractional STEP is rejected expectCompileError("Fractional STEP for an INTEGER counter rejected", "DIM i AS INTEGER\n" "FOR i = 1 TO 2 STEP 0.5\n" "NEXT\n", "FOR STEP must be a whole number" ); runProgram("Computed FOR STEP rounds to an INTEGER/LONG counter", "DIM k AS INTEGER\n" "st = 1.6\n" "FOR k = 1 TO 3 STEP st\n" "PRINT k;\n" "NEXT\n" "PRINT\n" "FOR k = 1 TO 2.6\n" "PRINT k;\n" "NEXT\n" "PRINT\n" "DIM l AS LONG\n" "FOR l = 1 TO 3 STEP -1.5 + 2.5\n" "PRINT l;\n" "NEXT\n" "PRINT\n", "1 3 \n1 2 \n1 2 3 \n" ); // RESUME NEXT after an error in a CASE test or an ON selector keeps the // eval stack balanced (OP_STMT per CASE clause, selector temporary); // the failed CASE test counts as false, so the next CASE is tried. runProgram("RESUME NEXT from a CASE test and an ON selector", "ON ERROR GOTO h\n" "z = 0\n" "x = 2\n" "SELECT CASE x\n" "CASE 1 / z\n" " PRINT \"one\"\n" "CASE 2\n" " PRINT \"two\"\n" "END SELECT\n" "ON 1 / z GOTO l1, l2\n" "PRINT \"after on\"\n" "END\n" "l1:\n" "PRINT \"l1\"\n" "END\n" "l2:\n" "PRINT \"l2\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "err11 \ntwo\nerr11 \nafter on\n" ); // Compiler temporaries are reused per statement (S2-071): 600 element // SWAPs need a handful of temporaries, not one global slot each. char *src = (char *)malloc(TEST_LIMIT_SRC_CAP); int32_t n = 0; if (src == NULL) { printf("FAIL: temporaries source buffer\n"); gFailCount++; return; } n += snprintf(src + n, TEST_LIMIT_SRC_CAP - n, "DIM a(2)\na(1) = 1\n"); for (int32_t i = 0; i < TEST_SWAP_LINES; i++) { n += snprintf(src + n, TEST_LIMIT_SRC_CAP - n, "SWAP a(1), a(2)\n"); } snprintf(src + n, TEST_LIMIT_SRC_CAP - n, "PRINT a(1); a(2)\n"); runProgram("Compiler temporaries are reused", src, "1 0 \n"); free(src); // DECLARE LIBRARY arguments arrive typed as declared (contract C2) runExternProgram("Extern arguments converted to the declared types", "DECLARE LIBRARY \"x\"\n" " DECLARE SUB F(BYVAL a AS INTEGER, BYVAL b AS DOUBLE, BYVAL c AS STRING, BYVAL d AS SINGLE, BYVAL e AS LONG, BYVAL f AS BOOLEAN)\n" " DECLARE SUB G(OPTIONAL BYVAL a AS SINGLE)\n" "END DECLARE\n" "F 1.4, 2, 3, 4, 5.5, 7\n" "G\n", "F(I,D,$,S,L,B) G(S)" ); // BINARY STRING parameters and results reach the host flagged runExternProgram("Extern BINARY STRING parameters and result flagged", "DECLARE LIBRARY \"x\"\n" " DECLARE FUNCTION H$(BYVAL a AS BINARY STRING, BYVAL b AS LONG, BYVAL c AS STRING, BYVAL d AS BINARY STRING) AS BINARY STRING\n" " DECLARE FUNCTION K(BYVAL a AS STRING) AS BINARY STRING\n" "END DECLARE\n" "s$ = H$(\"a\" + CHR$(0), 2, \"c\", 4)\n" "s$ = K(\"z\")\n", "H(b,L,$,b)b K($)b" ); } // Compiler hard limits that need generated sources: constant pool // overflow, global and local slot tables; and a module past 64 KB of // code (no limit there: jumps, calls, FOR, GOSUB and ON ERROR all span it). static void testCompilerLimits(void) { char *src = (char *)malloc(TEST_LIMIT_SRC_CAP); if (src == NULL) { printf("FAIL: limits source buffer\n"); gFailCount++; return; } int32_t len = 0; // One more distinct string constant than the pool can index. for (int32_t i = 0; i < TEST_LIMIT_CONSTS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "A$ = \"c%d\"\n", (int)i); } expectCompileError("Constant pool overflow rejected", src, "Too many string constants"); // More than 64 KB of code: an IF body and a FOR body wider than a // 16-bit jump, then a GOSUB, a SUB call and an ON ERROR handler whose // targets lie past 64 KB. len = snprintf(src, TEST_LIMIT_SRC_CAP, "DIM z AS INTEGER\nL = 0\nON ERROR GOTO Handler\nIF z = 0 THEN\n"); for (int32_t i = 0; i < TEST_LIMIT_JUMPBODY; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "L = L + 1\n"); } len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "END IF\nFOR i = 1 TO 2\n"); for (int32_t i = 0; i < TEST_LIMIT_FORBODY; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "L = L + 1\n"); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "NEXT\nGOSUB Far\nFarSub 5\nERROR 5\nPRINT L\nEND\nHandler:\nPRINT \"handled\"; ERR\nRESUME NEXT\nFar:\nL = L + %d\nRETURN\nSUB FarSub(n)\nPRINT \"far\"; n\nEND SUB\n", (int32_t)TEST_LIMIT_GOSUB_ADD); char expected[TEST_LIMIT_EXPECT_LEN]; snprintf(expected, sizeof(expected), "far5 \nhandled5 \n%d \n", (int32_t)(TEST_LIMIT_JUMPBODY + 2 * TEST_LIMIT_FORBODY + TEST_LIMIT_GOSUB_ADD)); runProgram("Module past 64 KB runs", src, expected); // More module-level variables than the VM has global slots. len = 0; for (int32_t i = 0; i < TEST_LIMIT_GLOBALS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "DIM v%d AS INTEGER\n", (int)i); } expectCompileError("Too many globals rejected", src, "Too many module-level variables"); // More member variables or form variables than their 16-bit operands // address. len = snprintf(src, TEST_LIMIT_SRC_CAP, "BEGINCLASS \"Big\"\n"); for (int32_t i = 0; i <= BAS_VM_MAX_MEMBER_VARS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "DIM v%d AS INTEGER\n", (int)i); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "ENDCLASS\n"); expectCompileError("Too many member variables rejected", src, "Too many member variables in Big"); len = snprintf(src, TEST_LIMIT_SRC_CAP, "BEGINFORM \"F1\"\n"); for (int32_t i = 0; i <= BAS_VM_MAX_MEMBER_VARS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "DIM v%d AS INTEGER\n", (int)i); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "ENDFORM\n"); expectCompileError("Too many form variables rejected", src, "Too many form-level variables"); // More locals than a call frame holds fails at compile time, not with // a runtime "Invalid local variable index". len = snprintf(src, TEST_LIMIT_SRC_CAP, "SUB S\n"); for (int32_t i = 0; i < TEST_LIMIT_LOCALS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "DIM v%d AS INTEGER\n", (int)i); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "END SUB\nS\n"); expectCompileError("Too many locals rejected", src, "Too many local variables in S"); // A frame just under the limit whose statements take hidden // temporaries: the SWAP's element temps must fit too. len = snprintf(src, TEST_LIMIT_SRC_CAP, "SUB S\n"); for (int32_t i = 0; i < BAS_VM_MAX_LOCALS - 1; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "DIM v%d AS INTEGER\n", (int)i); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "SWAP v0, v1\nDIM b(2, 2)\nSWAP b(1, 1), b(2, 2)\nEND SUB\nS\n"); expectCompileError("Temporaries past the frame rejected", src, "Too many local variables in S"); // READ into many array elements reuses each target's temporaries, so // the SUB stays well inside its frame. len = snprintf(src, TEST_LIMIT_SRC_CAP, "S\nSUB S\nDIM a(%d) AS INTEGER\nREAD a(1)", (int32_t)TEST_LIMIT_READ_ELEMS); for (int32_t i = 2; i <= TEST_LIMIT_READ_ELEMS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, ", a(%d)", (int)i); } len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "\nPRINT a(1); a(%d)\nEND SUB\nDATA 1", (int32_t)TEST_LIMIT_READ_ELEMS); for (int32_t i = 2; i <= TEST_LIMIT_READ_ELEMS; i++) { len += snprintf(src + len, TEST_LIMIT_SRC_CAP - len, ", %d", (int)i); } snprintf(src + len, TEST_LIMIT_SRC_CAP - len, "\n"); runProgram("READ many elements in a SUB", src, "1 40 \n"); free(src); } // The keyword enumeration API used by the IDE's syntax highlighter. // Phase 3: constant expressions, ENUM and ParamArray. // Phase 4: the program screen (console text, SCREEN 12 / 13 graphics, // INKEY$ / INPUT from typed keys, PALETTE, VIEW / WINDOW, FULLSCREEN). static void testConsoleGraphics(void) { CaptureT cap; TestKeysT keys; char row[TEST_ROW_TEXT_LEN]; BasVmT *vm = NULL; basGfxSetFont(font8x16); // PRINT goes to the host until the program uses the screen vm = screenRun("Console: PRINT moves to the screen after CLS", "PRINT \"before\"\n" "CLS\n" "PRINT \"HI\"; 12\n" "PRINT \"A\"; TAB(10); \"B\"; SPC(2); \"C\"\n" "PRINT \"X\", \"Y\"\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("host got only the first PRINT", strcmp(cap.buf, "before\n") == 0); checkTrue("screen made in SCREEN 0 80x25", scr->mode == BAS_SCREEN_MODE_TEXT && scr->cols == 80 && scr->rows == 25 && scr->width == 640 && scr->height == 400); rowText(scr, 0, row); checkTrue("row 1 text", strcmp(row, "HI12") == 0); rowText(scr, 1, row); checkTrue("TAB and SPC", strcmp(row, "A B C") == 0); rowText(scr, 2, row); checkTrue("comma zones", strcmp(row, "X Y") == 0); checkTrue("cursor on row 4", scr->row == 3 && scr->col == 0); // 'H' at (0,0): some pixels in the foreground (7), background 0 int32_t on = 0; for (int32_t y = 0; y < BAS_GFX_GLYPH_TALL; y++) { for (int32_t x = 0; x < BAS_GFX_GLYPH_W; x++) { on += fbAt(scr, x, y) == 7; } } checkTrue("glyph drawn in colour 7", on > 0 && fbAt(scr, 0, 0) == 0); screenRunFree(vm); } vm = screenRun("Console: LOCATE, COLOR, CSRLIN, POS, SCREEN()", "LOCATE 5, 10\n" "COLOR 14, 1\n" "PRINT \"Z\";\n" "r = CSRLIN\n" "c = POS(0)\n" "ch = SCREEN(5, 10)\n" "at = SCREEN(5, 10, 1)\n" "LOCATE , , 1\n" "LOCATE 25, 80\n" "PRINT \"E\";\n" "c2 = POS(0)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("character at row 5 col 10", scr->chars[4 * 80 + 9] == 'Z'); checkTrue("attribute yellow on blue", scr->attrs[4 * 80 + 9] == (14 | 1 << 4)); checkTrue("CSRLIN", globalNum(vm, "r") == 5); checkTrue("POS after Z", globalNum(vm, "c") == 11); checkTrue("SCREEN() char", globalNum(vm, "ch") == 'Z'); checkTrue("SCREEN() colour", globalNum(vm, "at") == (14 | 1 << 4)); checkTrue("cursor visible", scr->cursorVisible && scr->cursorDrawn); checkTrue("last cell, no scroll yet", scr->chars[24 * 80 + 79] == 'E' && scr->row == 24 && globalNum(vm, "c2") == 80); screenRunFree(vm); } vm = screenRun("Console: scrolling and CLS colours", "COLOR 7, 4\n" "CLS\n" "FOR i = 1 TO 26\n" " PRINT i\n" "NEXT i\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; rowText(scr, 0, row); checkTrue("scrolled two lines", strcmp(row, "3") == 0); rowText(scr, 23, row); checkTrue("last number", strcmp(row, "26") == 0); checkTrue("background 4 kept", fbAt(scr, 600, 5) == 4 && fbAt(scr, 600, 399) == 4); screenRunFree(vm); } // INKEY$: a character, an extended key, then nothing memset(&keys, 0, sizeof(keys)); keys.keys[keys.count++] = 'a'; keys.keys[keys.count++] = BAS_SCREEN_KEY_EXT | 0x48; vm = screenRun("Console: INKEY$", "CLS\n" "DoEvents\n" "a$ = INKEY$\n" "b$ = INKEY$\n" "c$ = INKEY$\n" "n1 = ASC(a$)\n" "n2 = LEN(b$)\n" "n3 = ASC(MID$(b$, 2))\n" "n4 = ASC(b$)\n" "n5 = LEN(c$)\n", &cap, &keys); if (vm) { checkTrue("INKEY$ character", globalNum(vm, "n1") == 'a'); checkTrue("INKEY$ extended = CHR$(0) + scan", globalNum(vm, "n2") == 2 && globalNum(vm, "n3") == 0x48 && globalNum(vm, "n4") == 0); checkTrue("INKEY$ empty", globalNum(vm, "n5") == 0); screenRunFree(vm); } // INPUT and LINE INPUT at the console, with Backspace memset(&keys, 0, sizeof(keys)); keys.keys[keys.count++] = '4'; keys.keys[keys.count++] = '3'; keys.keys[keys.count++] = 8; keys.keys[keys.count++] = '2'; keys.keys[keys.count++] = 13; keys.keys[keys.count++] = 'h'; keys.keys[keys.count++] = ','; keys.keys[keys.count++] = 'i'; keys.keys[keys.count++] = 13; vm = screenRun("Console: INPUT and LINE INPUT", "CLS\n" "INPUT \"N\"; n\n" "LINE INPUT \"Say: \"; t$\n" "PRINT n * 2; t$\n", &cap, &keys); if (vm) { BasScreenT *scr = vm->screen; checkTrue("INPUT value", globalNum(vm, "n") == 42); rowText(scr, 0, row); checkTrue("INPUT echo", strcmp(row, "N? 42") == 0); rowText(scr, 1, row); checkTrue("LINE INPUT echo", strcmp(row, "Say: h,i") == 0); rowText(scr, 2, row); checkTrue("result line", strcmp(row, "84 h,i") == 0); checkTrue("cursor hidden again", !scr->cursorDrawn && !scr->inputActive); screenRunFree(vm); } vm = screenRun("SCREEN 13: PSET, PRESET, LINE, B, BF, STEP, POINT", "SCREEN 13\n" "PSET (10, 10), 4\n" "PSET STEP(1, 1)\n" "PRESET (12, 12)\n" "LINE (0, 20)-(9, 20), 2\n" "LINE -STEP(0, 5), 3\n" "LINE (30, 30)-(40, 40), 5, B\n" "LINE (50, 30)-(60, 40), 6, BF\n" "LINE (70, 30)-(85, 30), 7, , &HFF00\n" "p = POINT(10, 10)\n" "q = POINT(500, 10)\n" "lx = POINT(0)\n" "ly = POINT(1)\n" "COLOR 9\n" "PSET (100, 100)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("SCREEN 13 is 320x200", scr->mode == BAS_SCREEN_MODE_VGA256 && scr->width == 320 && scr->height == 200 && scr->cols == 40); checkTrue("PSET colour", fbAt(scr, 10, 10) == 4); checkTrue("PSET STEP in foreground 15", fbAt(scr, 11, 11) == 15); checkTrue("PRESET background", fbAt(scr, 12, 12) == 0); checkTrue("LINE horizontal", fbAt(scr, 0, 20) == 2 && fbAt(scr, 8, 20) == 2 && fbAt(scr, 10, 20) == 0); checkTrue("LINE -STEP from the last point", fbAt(scr, 9, 25) == 3 && fbAt(scr, 9, 23) == 3); checkTrue("LINE B outline", fbAt(scr, 30, 30) == 5 && fbAt(scr, 40, 40) == 5 && fbAt(scr, 30, 35) == 5 && fbAt(scr, 35, 35) == 0); checkTrue("LINE BF filled", fbAt(scr, 55, 35) == 6 && fbAt(scr, 60, 40) == 6); checkTrue("LINE style", fbAt(scr, 70, 30) == 7 && fbAt(scr, 77, 30) == 7 && fbAt(scr, 78, 30) == 0 && fbAt(scr, 85, 30) == 0); checkTrue("POINT", globalNum(vm, "p") == 4 && globalNum(vm, "q") == -1); checkTrue("POINT(0/1) = last point", globalNum(vm, "lx") == 85 && globalNum(vm, "ly") == 30); checkTrue("COLOR sets the foreground", fbAt(scr, 100, 100) == 9); checkTrue("default VGA palette", scr->palette[32 * 3 + 2] == 255 && scr->palette[32 * 3] == 0 && scr->palette[40 * 3] == 255 && scr->palette[40 * 3 + 1] == 0 && scr->palette[31 * 3] == 255 && scr->palette[248 * 3 + 1] == 0); screenRunFree(vm); } vm = screenRun("SCREEN 13: CIRCLE, arcs, aspect, PAINT", "SCREEN 13\n" "CIRCLE (160, 100), 40, 5, , , 1\n" "PAINT (160, 100), 6, 5\n" "CIRCLE (60, 60), 20, 3\n" "CIRCLE (60, 150), 20, 4, 0, 3.14159\n" "CIRCLE (260, 150), 20, 2, -0.0001, -1.5708\n" "cx = POINT(2)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("circle outline", fbAt(scr, 200, 100) == 5 && fbAt(scr, 120, 100) == 5 && fbAt(scr, 160, 60) == 5 && fbAt(scr, 160, 140) == 5); checkTrue("PAINT inside", fbAt(scr, 160, 100) == 6 && fbAt(scr, 190, 100) == 6); checkTrue("PAINT stops at the border", fbAt(scr, 205, 100) == 0 && fbAt(scr, 0, 0) == 0); checkTrue("default aspect: round on 4:3", fbAt(scr, 80, 60) == 3 && fbAt(scr, 60, 60 - 17) == 3 && fbAt(scr, 60, 40) == 0); checkTrue("upper half arc only", fbAt(scr, 60, 150 - 17) == 4 && fbAt(scr, 60, 150 + 17) == 0); checkTrue("radius lines of negative angles", fbAt(scr, 270, 150) == 2 && fbAt(scr, 260, 145) == 2); checkTrue("CIRCLE sets the last point", globalNum(vm, "cx") == 260); screenRunFree(vm); } vm = screenRun("SCREEN 13: DRAW", "SCREEN 13\n" "DRAW \"C2 BM100,100 R10 D10 L10 U10\"\n" "DRAW \"BM200,50 C3 E5 F5 NG3 H2\"\n" "DRAW \"BM50,150 S8 C4 R5\"\n" "DRAW \"BM20,180 TA90 C5 R10\"\n" "DRAW \"BM10,10 A2 C6 R4 P7,6\"\n" "DRAW \"BM150,150 S4 TA0 C1 M+10,+0\"\n" "px = POINT(0)\n" "py = POINT(1)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("DRAW square", fbAt(scr, 105, 100) == 2 && fbAt(scr, 110, 105) == 2 && fbAt(scr, 105, 110) == 2 && fbAt(scr, 100, 105) == 2 && fbAt(scr, 105, 105) == 0); checkTrue("DRAW diagonals", fbAt(scr, 205, 45) == 3 && fbAt(scr, 210, 50) == 3); checkTrue("DRAW N returns", fbAt(scr, 207, 53) == 3 && fbAt(scr, 208, 48) == 3); checkTrue("DRAW S8 doubles", fbAt(scr, 60, 150) == 4 && fbAt(scr, 61, 150) == 0); checkTrue("DRAW TA90 turns R upwards", fbAt(scr, 20, 170) == 5 && fbAt(scr, 30, 180) == 0); checkTrue("DRAW A2 turns R left", fbAt(scr, 6, 10) == 6); checkTrue("DRAW relative M and the pen position", fbAt(scr, 160, 150) == 1 && globalNum(vm, "px") == 160 && globalNum(vm, "py") == 150); screenRunFree(vm); } vm = screenRun("PALETTE, PALETTE USING, SCREEN 12", "SCREEN 12\n" "PALETTE 1, &H3F0000\n" "b1 = 1\n" "DIM pal(15) AS LONG\n" "FOR i = 0 TO 15\n" " pal(i) = -1\n" "NEXT i\n" "pal(2) = 63\n" "PALETTE USING pal\n" "CIRCLE (320, 240), 100, 2\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("SCREEN 12 is 640x480, 80x30", scr->mode == BAS_SCREEN_MODE_VGA16 && scr->width == 640 && scr->height == 480 && scr->rows == 30); checkTrue("PALETTE blue", scr->palette[3] == 0 && scr->palette[5] == 255 && scr->paletteChanged); checkTrue("PALETTE USING red, -1 keeps", scr->palette[6] == 255 && scr->palette[7] == 0 && scr->palette[5] == 255); checkTrue("SCREEN 12 circle is round (aspect 1)", fbAt(scr, 420, 240) == 2 && fbAt(scr, 320, 140) == 2); screenRunFree(vm); } vm = screenRun("PALETTE reset, SCREEN 0 EGA numbers", "PALETTE 1, 63\n" "w = 1\n", &cap, NULL); if (vm) { checkTrue("EGA 63 is white", vm->screen->palette[3] == 255 && vm->screen->palette[4] == 255 && vm->screen->palette[5] == 255); screenRunFree(vm); } vm = screenRun("VIEW and WINDOW", "SCREEN 13\n" "VIEW (10, 10)-(50, 50), 1, 2\n" "PSET (0, 0), 7\n" "PSET (100, 100), 7\n" "vx = POINT(0, 0)\n" "VIEW SCREEN (100, 100)-(150, 150)\n" "PSET (100, 100), 8\n" "PSET (10, 10), 8\n" "VIEW\n" "WINDOW (0, 0)-(100, 100)\n" "PSET (0, 0), 9\n" "PSET (100, 100), 9\n" "WINDOW SCREEN (0, 0)-(100, 100)\n" "PSET (0, 0), 10\n" "WINDOW\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("VIEW fill and border", fbAt(scr, 30, 30) == 1 && fbAt(scr, 9, 9) == 2 && fbAt(scr, 51, 30) == 2); checkTrue("VIEW origin and clipping", fbAt(scr, 10, 10) == 7 && fbAt(scr, 110, 110) == 0); checkTrue("VIEW POINT is view-relative", globalNum(vm, "vx") == 7); checkTrue("VIEW SCREEN absolute", fbAt(scr, 100, 100) == 8 && fbAt(scr, 10, 10) == 7); checkTrue("WINDOW y up", fbAt(scr, 0, 199) == 9 && fbAt(scr, 319, 0) == 9); checkTrue("WINDOW SCREEN y down", fbAt(scr, 0, 0) == 10); screenRunFree(vm); } vm = screenRun("CLS 1 clears only the view; WIDTH; FULLSCREEN without a host", "SCREEN 13\n" "LINE (0, 0)-(319, 199), 4, BF\n" "VIEW (10, 10)-(20, 20)\n" "CLS\n" "VIEW\n" "SCREEN 0\n" "WIDTH 80, 50\n" "FULLSCREEN\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("WIDTH 80, 50", scr->mode == BAS_SCREEN_MODE_TEXT && scr->rows == 50 && scr->cellH == BAS_GFX_GLYPH_SHORT); checkTrue("FULLSCREEN flag", scr->fullScreen); screenRunFree(vm); } vm = screenRun("CLS in a view", "SCREEN 13\n" "LINE (0, 0)-(319, 199), 4, BF\n" "VIEW (10, 10)-(20, 20)\n" "CLS\n", &cap, NULL); if (vm) { checkTrue("CLS cleared the view only", fbAt(vm->screen, 15, 15) == 0 && fbAt(vm->screen, 5, 5) == 4); screenRunFree(vm); } vm = screenRun("Errors: graphics in SCREEN 0, bad colours, bad WIDTH", "ON ERROR GOTO h\n" "PSET (1, 1)\n" "SCREEN 13\n" "COLOR 300\n" "COLOR 1, 2\n" "WIDTH 80\n" "SCREEN 4\n" "DRAW \"Q\"\n" "PALETTE 1, &H400000\n" "LOCATE 26\n" "END\n" "h:\n" "n = n + 1\n" "IF ERR <> 5 THEN bad = bad + 1\n" "RESUME NEXT\n", &cap, NULL); if (vm) { checkTrue("eight Illegal function calls", globalNum(vm, "n") == 8 && globalNum(vm, "bad") == 0); screenRunFree(vm); } // The program's own names win; LINE syntax errors runProgram("A variable named COLOR and a SUB named Cls", "color = 5\n" "PRINT color\n" "Cls 3\n" "SUB Cls (n)\n" " PRINT \"mine\"; n\n" "END SUB\n", "5 \nmine3 \n" ); expectCompileError("LINE needs B or BF", "SCREEN 13\nLINE (0, 0)-(1, 1), 2, X\n", "B or BF" ); expectCompileError("VIEW PRINT needs TO", "VIEW PRINT 1, 5\n", "TO" ); expectCompileError("PALETTE USING needs an array", "x = 1\nPALETTE USING x\n", "array name" ); compileOnly("Drawing methods compile on objects", "Picture1.Line (0, 0)-(10, 10), RGB(255, 0, 0), BF\n" "Picture1.Circle STEP(5, 5), 10\n" "Me.PSet (1, 2)\n" "Picture1.Print \"a\"; 1, TAB(5); SPC(2); \"b\";\n" "Picture1.Cls\n" "x = Picture1.Point(1, 1)\n" ); } static void testConstEnumParamArray(void) { // ---- CONST with constant expressions ---- runProgram("CONST arithmetic and earlier constants", "CONST A = 2 + 3 * 4\n" "CONST B = (A - 4) \\ 3\n" "CONST C = A MOD 5, D = -A\n" "CONST E = 2 ^ 10\n" "CONST F = 7 / 2\n" "PRINT A; B; C; D; E; F\n", "14 3 4 -14 1024 3.5 \n" ); runProgram("CONST comparison and logic", "CONST T = 3 > 2\n" "CONST U = NOT T\n" "CONST M = &HF0 AND &H3C OR 1\n" "CONST X = 5 XOR 3\n" "CONST Q = (1 = 1) AND (2 <> 3)\n" "PRINT T; U; M; X; Q\n", // NOT and AND of Booleans give Booleans here as they do at run time "True False 49 6 True \n" ); runProgram("CONST string expressions and pure built-ins", "CONST P = \"DVX\"\n" "CONST S = P & \" \" + \"BASIC\"\n" "CONST L = LEN(S)\n" "CONST CR = CHR$(13)\n" "CONST H = HEX$(255) & LCASE$(\"AB\") & UCASE$(LEFT$(\"xyz\", 2))\n" "CONST K = ASC(\"A\") + ABS(-2) + INT(2.7) + FIX(-2.7) + SGN(-9)\n" "CONST R = RGB(1, 2, 3)\n" "CONST G = GetGreen(R)\n" "CONST M2 = MID$(S, 5), T2 = TRIM$(\" a \") & STRING$(3, \"-\")\n" "CONST I = IIf(L > 5, \"long\", \"short\")\n" "PRINT S; L; ASC(CR); H; K\n" "PRINT R; G; M2; T2; I\n", "DVX BASIC9 13 FFabXY66 \n197121 2 BASICa---long\n" ); runProgram("CONST holding NUL characters", "CONST Z = \"a\" & CHR$(0) & \"b\"\n" "PRINT LEN(Z); ASC(MID$(Z, 2, 1)); RIGHT$(Z, 1)\n", "3 0 b\n" ); runProgram("CONST AS type converts the expression", "CONST N AS INTEGER = 10 / 4\n" "CONST D AS DOUBLE = 1 + 2\n" "CONST B AS BOOLEAN = 3 - 3\n" "CONST S AS STRING = \"a\" & \"b\"\n" "CONST DT AS DATE = DateSerial(2026, 9, 29)\n" "PRINT N; D; B; S; Year(DT)\n", "2 3 False ab2026 \n" ); runProgram("CONST in a SUB and in SELECT CASE", "CONST LO = 1, HI = LO + 9\n" "SUB Disp(v)\n" " CONST MSG = \"v=\" & \"\"\n" " SELECT CASE v\n" " CASE LO TO HI: PRINT MSG; v\n" " CASE ELSE: PRINT \"out\"\n" " END SELECT\n" "END SUB\n" "Disp 5\n" "Disp HI + 1\n", "v=5 \nout\n" ); runProgram("OPTION COMPARE TEXT applies to constant comparisons", "OPTION COMPARE TEXT\n" "CONST SAME = \"abc\" = \"ABC\"\n" "PRINT SAME\n", "True \n" ); expectCompileError("CONST of a FUNCTION call rejected", "FUNCTION F()\nF = 1\nEND FUNCTION\n" "CONST A = F()\n", "Constant expression required: 'F' is not a constant" ); expectCompileError("CONST of an undeclared name rejected", "CONST A = Nope + 1\n", "Constant expression required: 'Nope' is not a constant" ); expectCompileError("CONST of a clock built-in rejected", "CONST A = TIMER\n", "Constant expression required" ); expectCompileError("CONST of RND rejected", "CONST A = RND(1)\n", "Constant expression required" ); expectCompileError("CONST of NOW rejected", "CONST A = Now\n", "Constant expression required" ); expectCompileError("CONST referring to itself rejected", "CONST A = A + 1\n", "'A' is not a constant" ); expectCompileError("CONST division by zero reported", "CONST A = 1 \\ 0\n", "Error in constant expression: Division by zero" ); expectCompileError("CONST INTEGER overflow reported", "CONST A AS INTEGER = 200 * 200\n", "Overflow in CONST" ); expectCompileError("CONST string too long rejected", "CONST A = STRING$(300, \"x\")\n", "Constant string longer than" ); expectCompileError("CONST string into a number rejected", "CONST A AS LONG = \"1\" & \"2\"\n", "Type mismatch in CONST" ); expectCompileError("CONST list duplicate rejected", "CONST A = 1, A = 2\n", "Duplicate constant" ); // ---- ENUM ---- runProgram("ENUM auto-numbering, explicit values and continuation", "ENUM Color\n" " Red\n" " Green\n" " Blue = 10\n" " Cyan\n" " Dark = -5\n" " Darker\n" "END ENUM\n" "PRINT Red; Green; Blue; Cyan; Dark; Darker\n" "PRINT Color.Red; Color.Cyan\n", "0 1 10 11 -5 -4 \n0 11 \n" ); runProgram("ENUM values from constant expressions", "CONST START0 = 100\n" "ENUM Flags\n" " fNone = 0\n" " fA = 1\n" " fB = fA * 2\n" " fC = Flags.fB * 2\n" " fAll = fA OR fB OR fC\n" " fBase = START0 + 1\n" "END ENUM\n" "PRINT fB; fC; fAll; fBase\n", "2 4 7 101 \n" ); runProgram("ENUM as a type: DIM, parameters, returns, TYPE fields", "ENUM Shape\n" " Circle = 1\n" " Square\n" "END ENUM\n" "TYPE Item\n" " kind AS Shape\n" " size AS INTEGER\n" "END TYPE\n" "FUNCTION Other(s AS Shape) AS Shape\n" " IF s = Circle THEN Other = Square ELSE Other = Circle\n" "END FUNCTION\n" "DIM s AS Shape\n" "DIM it AS Item\n" "s = 2.6\n" "it.kind = Other(s)\n" "PRINT s; it.kind; Other(Shape.Circle)\n", "3 1 2 \n" ); runProgram("ENUM used before its SUB definition and in SELECT CASE", "ENUM Heading\n" " North\n" " South\n" "END ENUM\n" "Go South\n" "SUB Go(d AS Heading)\n" " SELECT CASE d\n" " CASE North: PRINT \"N\"\n" " CASE Heading.South: PRINT \"S\"\n" " END SELECT\n" "END SUB\n", "S\n" ); runProgram("ENUM member shared by two ENUMs is usable qualified", "ENUM A\n" " Same = 1\n" " OnlyA\n" "END ENUM\n" "ENUM B\n" " Same = 5\n" "END ENUM\n" "PRINT A.Same; B.Same; OnlyA\n", "1 5 2 \n" ); compileOnly("DECLARE with an ENUM parameter matches its definition", "ENUM E\n" " One = 1\n" "END ENUM\n" "DECLARE SUB S(v AS E)\n" "SUB S(v AS E)\n" "END SUB\n" ); expectCompileError("Ambiguous ENUM member rejected unqualified", "ENUM A\n Same\nEND ENUM\n" "ENUM B\n Same\nEND ENUM\n" "PRINT Same\n", "Ambiguous name 'Same'" ); expectCompileError("Duplicate ENUM member rejected", "ENUM E\n X\n Y\n X\nEND ENUM\n", "Duplicate member 'X' in ENUM 'E'" ); expectCompileError("Duplicate ENUM rejected", "ENUM E\n X\nEND ENUM\n" "ENUM E\n Y\nEND ENUM\n", "'E' is already defined" ); expectCompileError("ENUM member clashing with a CONST rejected", "CONST X = 1\n" "ENUM E\n X\nEND ENUM\n", "ENUM member 'X' is already defined" ); expectCompileError("Unknown qualified ENUM member rejected", "ENUM E\n X\nEND ENUM\n" "PRINT E.Y\n", "'Y' is not a member of ENUM 'E'" ); expectCompileError("ENUM inside a SUB rejected", "SUB S\n" "ENUM E\n X\nEND ENUM\n" "END SUB\n", "ENUM cannot be defined inside SUB or FUNCTION" ); expectCompileError("ENUM without END ENUM rejected", "ENUM E\n X\n", "Expected END ENUM" ); expectCompileError("Empty ENUM rejected", "ENUM E\nEND ENUM\n", "ENUM 'E' has no members" ); expectCompileError("ENUM value that is not constant rejected", "DIM v\n" "ENUM E\n X = v\nEND ENUM\n", "Constant expression required: 'v' is not a constant" ); expectCompileError("ENUM string value rejected", "ENUM E\n X = \"a\"\nEND ENUM\n", "Type mismatch in ENUM" ); expectCompileError("ENUM auto value overflow rejected", "ENUM E\n X = 2147483647\n Y\nEND ENUM\n", "Overflow in ENUM" ); expectCompileError("ENUM member assignment rejected", "ENUM E\n X\nEND ENUM\n" "X = 3\n", "Cannot assign to a constant" ); // ---- ParamArray ---- runProgram("ParamArray receives the remaining arguments", "SUB ShowAll(title AS STRING, ParamArray items())\n" " DIM i\n" " PRINT title; LBOUND(items); UBOUND(items)\n" " FOR i = LBOUND(items) TO UBOUND(items)\n" " PRINT items(i);\n" " NEXT\n" " PRINT\n" "END SUB\n" "ShowAll \"three:\", 1, \"two\", 3.5\n" "ShowAll \"none:\"\n" "CALL ShowAll(\"one:\", \"x\")\n", "three:0 2 \n1 two3.5 \n" "none:0 -1 \n\n" "one:0 0 \nx\n" ); runProgram("Typed ParamArray converts each argument", "FUNCTION Sum(ParamArray n() AS DOUBLE) AS DOUBLE\n" " DIM i, t AS DOUBLE\n" " FOR i = 0 TO UBOUND(n)\n" " t = t + n(i)\n" " NEXT\n" " Sum = t\n" "END FUNCTION\n" "FUNCTION Cat$(ParamArray s() AS STRING)\n" " Cat$ = Join$(s, \"-\")\n" "END FUNCTION\n" "PRINT Sum(1, 2.5, \"3\"); Sum()\n" "PRINT Cat$(1, \"b\", 2.5)\n", "6.5 0 \n1-b-2.5\n" ); runProgram("ParamArray called before its definition", "PRINT Count(1, 2, 3); Count()\n" "FUNCTION Count(ParamArray a()) AS LONG\n" " Count = UBOUND(a) + 1\n" "END FUNCTION\n", "3 0 \n" ); expectCompileError("ParamArray not last rejected", "SUB S(ParamArray a(), b)\nEND SUB\n", "ParamArray must be the last parameter" ); expectCompileError("ParamArray with Optional rejected", "SUB S(OPTIONAL a, ParamArray b())\nEND SUB\n", "ParamArray cannot be used with Optional parameters" ); expectCompileError("ParamArray without () rejected", "SUB S(ParamArray b)\nEND SUB\n", "ParamArray parameter must be an array" ); expectCompileError("ParamArray ByVal rejected", "SUB S(BYVAL ParamArray b())\nEND SUB\n", "ParamArray cannot be ByVal or ByRef" ); expectCompileError("ParamArray of a TYPE rejected", "TYPE T\n x AS INTEGER\nEND TYPE\n" "SUB S(ParamArray b() AS T)\nEND SUB\n", "ParamArray elements cannot be a TYPE" ); expectCompileError("ParamArray in DEF FN rejected", "DEF FNa(ParamArray b()) = 1\n", "ParamArray is not allowed in DEF FN" ); expectCompileError("BINARY STRING outside DECLARE LIBRARY rejected", "SUB S(BYVAL x AS BINARY STRING)\nEND SUB\n", "BINARY STRING is only allowed in a DECLARE LIBRARY block" ); expectCompileError("BINARY STRING in DIM rejected", "DIM x AS BINARY STRING\n", "BINARY STRING is only allowed in a DECLARE LIBRARY block" ); expectCompileError("BINARY needs STRING", "DECLARE LIBRARY \"x\"\n" "DECLARE SUB F(BYVAL b AS BINARY LONG)\n" "END DECLARE\n", "STRING after BINARY" ); expectCompileError("ParamArray in DECLARE LIBRARY rejected", "DECLARE LIBRARY \"x\"\n" "DECLARE SUB F(ParamArray b())\n" "END DECLARE\n", "ParamArray is not allowed in DECLARE LIBRARY" ); expectCompileError("Too few arguments before a ParamArray rejected", "SUB S(a, b, ParamArray c())\nEND SUB\n" "S 1\n", "Sub 'S' expects at least 2 arguments, got 1" ); expectCompileError("Too many ParamArray arguments rejected", "SUB S(ParamArray c())\nEND SUB\n" "S 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32\n", "Too many ParamArray arguments (at most 31)" ); expectCompileError("DECLARE disagreeing on ParamArray rejected", "DECLARE SUB S(a())\n" "SUB S(ParamArray a())\nEND SUB\n", "DECLARE for 'S' does not match its definition" ); } // Compile-time member binding (redesign Phase 3): members of objects of a // known class reached by index give what late binding by name gives, // VB's compile-time member errors, Implements calls through interface // maps, events by index, and the late-bound fallback for an object of // another class. static void testEarlyBinding(void) { runBothBindings("Early binding: methods, properties, variables, ByRef / Optional / ParamArray arguments, chains and Collections give what late binding gives", "FUNCTION MakeAcct(BYVAL n AS LONG) AS @T@\n" " DIM a AS @T@\n" " SET a = NEW Acct\n" " a.Deposit n\n" " SET MakeAcct = a\n" "END FUNCTION\n" "\n" "SUB Exercise(a AS @T@)\n" " DIM x AS INTEGER\n" " DIM arr(2) AS INTEGER\n" " a.Deposit 10\n" " a.Rate = 3\n" " a.Visits = a.Visits + 1\n" " PRINT a.Balance; a.Rate; a.Visits\n" " x = 5\n" " a.Bump x\n" " arr(1) = 7\n" " a.Bump arr(1)\n" " a.Bump (x)\n" " PRINT x; arr(1)\n" " PRINT a.Sum(1, 2, 3); a.Sum()\n" " a.Sum 4, 5\n" " PRINT a.Greet(); \" \"; a.Greet(\"Bob\")\n" " a.Tags(1) = \"t1\"\n" " a.Items(2) = 9\n" " PRINT a.Tags(1); a.Items(2)\n" " SET a.Partner = MakeAcct(4)\n" " a.Partner.Deposit 1\n" " PRINT a.Partner.Balance\n" " a.History.Add \"x\", \"k1\"\n" " a.History.Add \"y\"\n" " PRINT a.History.Count; a.History.Item(1); a.History(\"k1\")\n" " a.History.Remove \"k1\"\n" " PRINT a.History.Count; a.Self.Balance\n" " PRINT a.Describe; a.Rate\n" "END SUB\n" "\n" "DIM g AS @T@\n" "SET g = NEW Acct\n" "Exercise g\n" "PRINT g.Balance\n" "\n" "BEGINCLASS \"Acct\"\n" "Public Visits As Long\n" "Public Items(3) As Integer\n" "Public History As New Collection\n" "Private mBal As Long\n" "Private mRate As Integer\n" "Private mTags(2) As String\n" "Private mPartner As Acct\n" "Public Sub Deposit(BYVAL n AS LONG)\n" " mBal = mBal + n\n" "End Sub\n" "Public Sub Bump(n AS INTEGER)\n" " n = n + 1\n" "End Sub\n" "Property Get Balance() As Long\n" " Balance = mBal\n" "End Property\n" "Property Get Rate() As Integer\n" " Rate = mRate\n" "End Property\n" "Property Let Rate(v As Integer)\n" " mRate = v\n" "End Property\n" "Property Get Tags(i As Integer) As String\n" " Tags = mTags(i)\n" "End Property\n" "Property Let Tags(i As Integer, s As String)\n" " mTags(i) = s\n" "End Property\n" "Property Get Partner() As Acct\n" " SET Partner = mPartner\n" "End Property\n" "Property Set Partner(p As Acct)\n" " SET mPartner = p\n" "End Property\n" "Public Function Sum(ParamArray v()) As Long\n" " DIM t AS LONG\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " Sum = t\n" "End Function\n" "Public Function Greet(Optional who As String = \"World\") As String\n" " Greet = \"Hi \" & who\n" "End Function\n" "Public Function Self() As Acct\n" " SET Self = Me\n" "End Function\n" "Public Function Describe() As String\n" " Me.Rate = Me.Rate + 1\n" " Describe = \"bal\" & Me.Balance & \" rate\" & Me.Rate & \" \" & Me.Tags(1)\n" "End Function\n" "ENDCLASS\n", "10 3 1 \n" "6 8 \n" "6 0 \n" "Hi World Hi Bob\n" "t19 \n" "5 \n" "2 xx\n" "1 10 \n" "bal10 rate4 t14 \n" "10 \n" ); runProgram("Early binding: Implements calls reach each class's implementation through its interface map", "DIM shapes(2) AS IShape\n" "DIM s AS IShape\n" "DIM i AS INTEGER\n" "DIM n AS INTEGER\n" "SET shapes(0) = NEW Square\n" "SET shapes(1) = NEW Circle\n" "SET shapes(2) = NEW IShape\n" "FOR i = 0 TO 2\n" " shapes(i).Name = \"s\" & i\n" " shapes(i).Resize 2\n" " n = 1\n" " shapes(i).Grow n\n" " PRINT shapes(i).Name; \" \"; shapes(i).Area; \" \"; shapes(i).Kind; n\n" "NEXT\n" "SET s = shapes(1)\n" "PRINT s.Total(1, 2, 3)\n" "\n" "BEGINCLASS \"IShape\"\n" "Public Name As String\n" "Public Function Area() As Double\n" " Area = -1\n" "End Function\n" "Public Sub Resize(BYVAL f AS DOUBLE)\n" "End Sub\n" "Public Sub Grow(n AS INTEGER)\n" " n = n + 100\n" "End Sub\n" "Property Get Kind() As String\n" " Kind = \"abstract\"\n" "End Property\n" "Public Function Total(ParamArray v()) As Long\n" " Total = -1\n" "End Function\n" "ENDCLASS\n" "\n" "BEGINCLASS \"Square\"\n" "Implements IShape\n" "Private mName As String\n" "Private mSide As Double\n" "Private Sub Class_Initialize()\n" " mSide = 1\n" "End Sub\n" "Private Property Get IShape_Name() As String\n" " IShape_Name = \"sq:\" & mName\n" "End Property\n" "Private Property Let IShape_Name(v As String)\n" " mName = v\n" "End Property\n" "Private Function IShape_Area() As Double\n" " IShape_Area = mSide * mSide\n" "End Function\n" "Private Sub IShape_Resize(BYVAL f AS DOUBLE)\n" " mSide = mSide * f\n" "End Sub\n" "Private Sub IShape_Grow(BYVAL n AS INTEGER)\n" " n = n + 10\n" "End Sub\n" "Private Property Get IShape_Kind() As String\n" " IShape_Kind = \"square\"\n" "End Property\n" "Private Function IShape_Total(ParamArray v()) As Long\n" " IShape_Total = UBOUND(v) + 1\n" "End Function\n" "ENDCLASS\n" "\n" "BEGINCLASS \"Circle\"\n" "Implements IShape\n" "Private mName As String\n" "Private mR As Double\n" "Private Sub Class_Initialize()\n" " mR = 1\n" "End Sub\n" "Private Property Get IShape_Name() As String\n" " IShape_Name = \"ci:\" & mName\n" "End Property\n" "Private Property Let IShape_Name(v As String)\n" " mName = v\n" "End Property\n" "Private Function IShape_Area() As Double\n" " IShape_Area = 3 * mR * mR\n" "End Function\n" "Private Sub IShape_Resize(BYVAL f AS DOUBLE)\n" " mR = mR * f\n" "End Sub\n" "Private Sub IShape_Grow(n AS INTEGER)\n" " n = n + 1\n" "End Sub\n" "Private Property Get IShape_Kind() As String\n" " IShape_Kind = \"circle\"\n" "End Property\n" "Private Function IShape_Total(ParamArray v()) As Long\n" " DIM t AS LONG\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " IShape_Total = t\n" "End Function\n" "ENDCLASS\n", "sq:s0 4 square1 \n" "ci:s1 12 circle2 \n" "s2 -1 abstract101 \n" "6 \n" ); runProgram("Early binding: Nothing, members used before their declaration, Me with Private members, an object of another class by name", "ON ERROR GOTO h\n" "DIM k AS Keeper\n" "k.Show\n" "PRINT \"a\"\n" "SET k = NEW Keeper\n" "k.Show\n" "PRINT k.Peek\n" "DIM o AS Object\n" "SET o = NEW Other\n" "Poke o\n" "PRINT o.count\n" "k.Count = 7\n" "PRINT k.Count; k.Twice\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "SUB Poke(x AS Keeper)\n" " x.Count = 41\n" " x.Show\n" "END SUB\n" "BEGINCLASS \"Keeper\"\n" "Public Function Twice() As Integer\n" " Twice = Count * 2 + mHidden\n" "End Function\n" "Public Sub Show()\n" " mHidden = mHidden + 1\n" " PRINT \"show\"; Me.mHidden\n" "End Sub\n" "Public Function Peek() As Integer\n" " Peek = Me.mHidden\n" "End Function\n" "Private mHidden As Integer\n" "Public Count As Integer\n" "ENDCLASS\n" "BEGINCLASS \"Other\"\n" "Public Count As Integer\n" "Public Sub Show()\n" " PRINT \"other show\"; Count\n" "End Sub\n" "ENDCLASS\n", "err91 \n" "a\n" "show1 \n" "1 \n" "other show41 \n" "41 \n" "7 15 \n" ); runProgram("Early binding: events dispatch by index", "DIM WithEvents a AS Alpha\n" "DIM WithEvents b AS Beta\n" "SET a = NEW Alpha\n" "SET b = NEW Beta\n" "a.Fire\n" "b.Fire\n" "SUB a_Second(BYVAL n AS INTEGER)\n" " PRINT \"a2\"; n\n" "END SUB\n" "SUB a_First(BYVAL n AS INTEGER)\n" " PRINT \"a1\"; n\n" "END SUB\n" "SUB b_First(BYVAL n AS INTEGER)\n" " PRINT \"b1\"; n\n" "END SUB\n" "SUB b_Second(BYVAL n AS INTEGER)\n" " PRINT \"b2\"; n\n" "END SUB\n" "BEGINCLASS \"Alpha\"\n" "Event First(BYVAL n AS INTEGER)\n" "Event Second(BYVAL n AS INTEGER)\n" "Public Sub Fire()\n" " RaiseEvent Second(2)\n" " RaiseEvent First(1)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Beta\"\n" "Event Second(BYVAL n AS INTEGER)\n" "Event First(BYVAL n AS INTEGER)\n" "Public Sub Fire()\n" " RaiseEvent First(10)\n" " RaiseEvent Second(20)\n" "End Sub\n" "ENDCLASS\n", "a22 \n" "a11 \n" "b110 \n" "b220 \n" ); expectCompileError("Early binding: an unknown member is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.Nope = 1\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Line 3, Col 4: Method or data member not found: 'Nope' is not a member of class 'Klass'" ); expectCompileError("Early binding: a Private member is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "PRINT kk.mHidden\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "'mHidden' is Private in class 'Klass'" ); expectCompileError("Early binding: too many arguments is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.Go 1, 2\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Sub 'Klass.Go' expects 1 arguments, got 2" ); expectCompileError("Early binding: too few arguments is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.Go\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Sub 'Klass.Go' expects 1 arguments, got 0" ); expectCompileError("Early binding: arguments for a Function without parameters is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "x = kk.F(1)\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Function 'Klass.F' expects 0 arguments, got 1" ); expectCompileError("Early binding: a Sub used as a value is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "x = kk.Go(1)\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Expected Function or variable: 'Go' is a Sub of class 'Klass'" ); expectCompileError("Early binding: a variable used as a statement is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.V\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Invalid use of property: 'V' of class 'Klass' is not a method" ); expectCompileError("Early binding: a read-only property assigned is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.RO = 3\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Can't assign to read-only property" ); expectCompileError("Early binding: a write-only property read is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "PRINT kk.WO\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "'WO' of class 'Klass' has no Property Get" ); expectCompileError("Early binding: a method assigned is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "kk.F = 2\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Cannot assign to method 'F' of class 'Klass'" ); expectCompileError("Early binding: an unknown Collection member is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "c.Push 1\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "'Push' is not a member of Collection" ); expectCompileError("Early binding: Collection.Add used as a value is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "x = c.Add(1)\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Collection.Add is a method" ); expectCompileError("Early binding: Collection.Count given an argument is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "PRINT c.Count(1)\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Collection.Count takes 0, got 1" ); expectCompileError("Early binding: Collection.Count assigned is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "c.Count = 3\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Can't assign to Collection.Count" ); expectCompileError("Early binding: a literal for an object parameter is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "TakeK 5\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Type mismatch: argument 1 of 'TakeK' must be an object" ); expectCompileError("Early binding: an object of another class is a compile error", "DIM kk AS NEW Klass\n" "DIM c AS NEW Collection\n" "TakeK NEW Jlass\n" "BEGINCLASS \"Klass\"\n" "Public V As Integer\n" "Private mHidden As Integer\n" "Public Sub Go(BYVAL n AS INTEGER)\n" "End Sub\n" "Public Function F() As Integer\n" "End Function\n" "Property Get RO() As Integer\n" "End Property\n" "Property Let WO(v As Integer)\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Jlass\"\n" "ENDCLASS\n" "SUB TakeK(x AS Klass)\n" "END SUB\n", "Type mismatch: argument 1 of 'TakeK' expects Klass, got Jlass" ); expectCompileError("Early binding: an implementation must keep the interface's ParamArray", "BEGINCLASS \"Iface\"\n" "Public Function Total(ParamArray v()) As Long\n" "End Function\n" "ENDCLASS\n" "BEGINCLASS \"Impl\"\n" "Implements Iface\n" "Private Function Iface_Total(v As Variant) As Long\n" "End Function\n" "ENDCLASS\n", "with 1 parameter(s) ending in a ParamArray for interface 'Iface'" ); } // Events (Event / RaiseEvent / WithEvents), Implements and the cycle // collector. static void testEventsAndInterfaces(void) { runProgram("Events: WithEvents handlers, ByRef arguments, two holders, rebinding", "DIM WithEvents w AS Worker\n" "DIM WithEvents w2 AS Worker\n" "DIM n AS INTEGER\n" "SET w = NEW Worker\n" "SET w2 = w\n" "n = 5\n" "w.Go n\n" "PRINT \"after\"; n\n" "SET w2 = NEW Worker\n" "w.Go n\n" "PRINT \"second\"; n\n" "SET w = Nothing\n" "w2.Go n\n" "PRINT \"third\"; n\n" "SUB w_Progress(ByVal pct AS INTEGER, cancel AS BOOLEAN)\n" " PRINT \"w\"; pct;\n" " IF pct >= 50 THEN cancel = TRUE\n" "END SUB\n" "SUB w2_Progress(ByVal pct AS INTEGER, cancel AS BOOLEAN)\n" " PRINT \"w2\"; pct;\n" "END SUB\n" "SUB w_Done(x AS INTEGER)\n" " PRINT \"done\"; x\n" " x = x * 2\n" "END SUB\n" "BEGINCLASS \"Worker\"\n" "Public Event Progress(ByVal pct AS INTEGER, cancel AS BOOLEAN)\n" "Event Done(x AS INTEGER)\n" "Public Sub Go(v AS INTEGER)\n" " DIM c AS BOOLEAN\n" " DIM i AS INTEGER\n" " FOR i = 25 TO 100 STEP 25\n" " RaiseEvent Progress(i, c)\n" " IF c THEN EXIT FOR\n" " NEXT\n" " RaiseEvent Done(v)\n" "End Sub\n" "ENDCLASS\n", "w25 w225 w50 w250 done5 \n" "after10 \n" "w25 w50 done10 \n" "second20 \n" "w225 w250 w275 w2100 third20 \n" ); runProgram("Events: a member variable passed ByRef, no holder, raised from Class_Initialize", "DIM WithEvents c AS Counter\n" "SET c = NEW Counter\n" "c.Tick\n" "c.Tick\n" "PRINT c.Count\n" "DIM lone AS NEW Counter\n" "lone.Tick\n" "PRINT lone.Count\n" "SUB c_Changed(total AS INTEGER)\n" " total = total + 100\n" "END SUB\n" "BEGINCLASS \"Counter\"\n" "Public Count AS INTEGER\n" "Event Changed(total AS INTEGER)\n" "Private Sub Class_Initialize()\n" " RaiseEvent Changed(Count)\n" "End Sub\n" "Public Sub Tick()\n" " Count = Count + 1\n" " RaiseEvent Changed(Count)\n" "End Sub\n" "ENDCLASS\n", "202 \n" "1 \n" ); runProgram("Events: TYPE fields and array elements go ByRef, every handler writes through the same reference (fixed length kept); a parenthesised value is one temporary they share", "TYPE Pt\n" " x AS INTEGER\n" " s AS STRING * 4\n" "END TYPE\n" "DIM SHARED g(3) AS Pt\n" "DIM WithEvents a AS Src\n" "DIM WithEvents b AS Src\n" "SET a = NEW Src\n" "SET b = a\n" "a.Go\n" "SUB a_Moved(v AS INTEGER, t AS STRING)\n" " PRINT \"a\"; v; \"[\"; t; \"]\"\n" " v = v + 10\n" " t = t + \"x\"\n" "END SUB\n" "SUB b_Moved(v AS INTEGER, t AS STRING)\n" " PRINT \"b\"; v; \"[\"; t; \"]\"\n" " v = v * 2\n" " t = \"q\" + t\n" "END SUB\n" "BEGINCLASS \"Src\"\n" "Event Moved(v AS INTEGER, t AS STRING)\n" "Public Sub Go()\n" " DIM p AS Pt\n" " DIM arr(2) AS Pt\n" " DIM n(3) AS INTEGER\n" " DIM s AS STRING\n" " p.x = 1\n" " p.s = \"ab\"\n" " RaiseEvent Moved(p.x, p.s)\n" " PRINT p.x; \"[\"; p.s; \"]\"\n" " arr(1).x = 5\n" " RaiseEvent Moved(arr(1).x, arr(1).s)\n" " PRINT arr(1).x; \"[\"; arr(1).s; \"]\"\n" " n(2) = 7\n" " RaiseEvent Moved(n(2), s)\n" " PRINT n(2); \"[\"; s; \"]\"\n" " g(2).x = 3\n" " RaiseEvent Moved(g(2).x, (g(2).s))\n" " PRINT g(2).x; \"[\"; g(2).s; \"]\"\n" "End Sub\n" "ENDCLASS\n", "a1 [ab ]\n" "b11 [ab ]\n" "22 [qab ]\n" "a5 [ ]\n" "b15 [ ]\n" "30 [q ]\n" "a7 []\n" "b17 [x]\n" "34 [qx]\n" "a3 [ ]\n" "b13 [ x]\n" "26 [ ]\n" ); runProgram("Events: ByRef element and field arrays locked (error 10), stores convert (overflow in the handler)", "TYPE Pt\n" " x AS INTEGER\n" "END TYPE\n" "DIM SHARED g(3) AS Pt\n" "DIM SHARED n(3) AS LONG\n" "DIM WithEvents a AS Src\n" "SET a = NEW Src\n" "a.Go\n" "SUB a_Moved(v)\n" " ON ERROR GOTO bad\n" " PRINT \"h\"; v\n" " v = v + 1.6\n" " REDIM g(5)\n" " REDIM n(5)\n" " ERASE g\n" " EXIT SUB\n" "bad:\n" " PRINT \"err\"; ERR\n" " RESUME NEXT\n" "END SUB\n" "BEGINCLASS \"Src\"\n" "Event Moved(v)\n" "Public Sub Go()\n" " g(2).x = 3\n" " RaiseEvent Moved(g(2).x)\n" " PRINT g(2).x\n" " REDIM g(4)\n" " PRINT UBOUND(g)\n" " n(1) = 4\n" " RaiseEvent Moved(n(1))\n" " PRINT n(1)\n" " ON ERROR GOTO over\n" " g(1).x = 32767\n" " RaiseEvent Moved(g(1).x)\n" " PRINT \"no\"\n" " EXIT SUB\n" "over:\n" " PRINT \"over\"; ERR; g(1).x\n" "End Sub\n" "ENDCLASS\n", "h3 \n" "err10 \n" "0 \n" "4 \n" "h4 \n" "err10 \n" "6 \n" "h32767 \n" "err6 \n" "err10 \n" "no\n" ); expectCompileError("Events: a handler must match the event", "DIM WithEvents w AS K\n" "SUB w_E(a AS STRING)\n" "END SUB\n" "BEGINCLASS \"K\"\n" "Event E(a AS INTEGER)\n" "ENDCLASS\n", "does not match the declaration of event E" ); expectCompileError("Events: RaiseEvent of an undeclared event", "BEGINCLASS \"K\"\n" "Sub S()\n" " RaiseEvent Nope\n" "End Sub\n" "ENDCLASS\n", "Event 'Nope' is not declared" ); expectCompileError("Events: RaiseEvent argument count", "BEGINCLASS \"K\"\n" "Event E(a AS INTEGER)\n" "Sub S()\n" " RaiseEvent E\n" "End Sub\n" "ENDCLASS\n", "takes 1 argument(s), got 0" ); expectCompileError("Events: RaiseEvent outside a class", "SUB S\n" " RaiseEvent E\n" "END SUB\n", "RaiseEvent belongs in a procedure of a class module" ); expectCompileError("Events: WithEvents inside a procedure", "SUB S\n" " DIM WithEvents x AS K\n" "END SUB\n" "BEGINCLASS \"K\"\n" "ENDCLASS\n", "WithEvents variables belong at module level" ); expectCompileError("Events: WithEvents needs a class", "DIM WithEvents x AS INTEGER\n", "declared As a class module" ); expectCompileError("Events: WithEvents cannot use New", "DIM WithEvents x AS NEW K\n" "BEGINCLASS \"K\"\n" "ENDCLASS\n", "(without New)" ); expectCompileError("Events: optional event parameter", "BEGINCLASS \"K\"\n" "Event E(OPTIONAL a AS INTEGER)\n" "ENDCLASS\n", "cannot be Optional or a ParamArray" ); expectCompileError("Events: an event is always public", "BEGINCLASS \"K\"\n" "Private Event E()\n" "ENDCLASS\n", "An Event cannot be Private" ); expectCompileError("Events: an event and a method share a name", "BEGINCLASS \"K\"\n" "Event E()\n" "Public Sub E()\n" "End Sub\n" "ENDCLASS\n", "'E' is an Event of class 'K'" ); runProgram("Events: Event and WithEvents are ordinary names elsewhere", "DIM event AS INTEGER, withevents AS INTEGER\n" "event = 3\n" "withevents = 4\n" "PRINT event + withevents\n", "7 \n" ); runProgram("Implements: members through the interface, own members, TypeOf, Set checks", "DIM s AS IShape\n" "DIM c AS NEW Circle\n" "SET s = c\n" "PRINT s.Area; s.Name; \" \"; c.Name\n" "s.Scale 2\n" "PRINT s.Area\n" "s.Tag = \"hi\"\n" "PRINT s.Tag\n" "PRINT TypeOf s Is IShape; TypeOf s Is Circle; TypeOf c Is Collection; TypeName(s)\n" "DIM plain AS NEW IShape\n" "SET s = plain\n" "PRINT s.Name\n" "DIM o AS OBJECT\n" "SET o = c\n" "PRINT o.Name\n" "ON ERROR GOTO bad\n" "DIM k AS NEW Collection\n" "SET s = k\n" "PRINT \"end\"\n" "END\n" "bad:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "BEGINCLASS \"IShape\"\n" "Public Tag AS STRING\n" "Public Function Area() AS DOUBLE\n" "End Function\n" "Public Function Name() AS STRING\n" " Name = \"ishape\"\n" "End Function\n" "Public Sub Scale(f AS DOUBLE)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Circle\"\n" "Implements IShape\n" "Private r AS DOUBLE\n" "Private t AS STRING\n" "Private Sub Class_Initialize()\n" " r = 1\n" "End Sub\n" "Public Function Name() AS STRING\n" " Name = \"circle\"\n" "End Function\n" "Private Function IShape_Area() AS DOUBLE\n" " IShape_Area = 3 * r * r\n" "End Function\n" "Private Function IShape_Name() AS STRING\n" " IShape_Name = \"circle-as-ishape\"\n" "End Function\n" "Private Sub IShape_Scale(f AS DOUBLE)\n" " r = r * f\n" "End Sub\n" "Private Property Get IShape_Tag() AS STRING\n" " IShape_Tag = t\n" "End Property\n" "Private Property Let IShape_Tag(v AS STRING)\n" " t = \"[\" & v & \"]\"\n" "End Property\n" "ENDCLASS\n", "3 circle-as-ishape circle\n" "12 \n" "[hi]\n" "True True False Circle\n" "ishape\n" "circle\n" "err13 \n" "end\n" ); expectCompileError("Implements: every member must be implemented", "BEGINCLASS \"I\"\n" "Public Sub M(a AS INTEGER)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"K\"\n" "Implements I\n" "Private Sub I_M()\n" "End Sub\n" "ENDCLASS\n", "Class 'K' must implement Sub I_M with 1 parameter(s) for interface 'I'" ); expectCompileError("Implements: needs a class module", "BEGINCLASS \"K\"\n" "Implements Nowhere\n" "ENDCLASS\n", "the name of a class module after Implements" ); expectCompileError("Implements: not itself", "BEGINCLASS \"K\"\n" "Implements K\n" "ENDCLASS\n", "A class cannot implement itself" ); runProgram("Cycles: collected while the program runs, Class_Terminate once", "DIM SHARED ended AS LONG\n" "DIM keep AS Node\n" "FOR i = 1 TO 2500\n" " DIM a AS Node, b AS Node\n" " SET a = NEW Node\n" " SET b = NEW Node\n" " SET a.Other = b\n" " SET b.Other = a\n" "NEXT\n" "SET a = Nothing\n" "SET b = Nothing\n" "PRINT ended > 4000\n" "BEGINCLASS \"Node\"\n" "Public Other AS Node\n" "Private Sub Class_Terminate()\n" " ended = ended + 1\n" "End Sub\n" "ENDCLASS\n", "True \n" ); runProgram("Cycles: a Class_Terminate that keeps its object; oldest first at the end", "DIM SHARED saved AS Node\n" "DIM a AS NEW Node, b AS NEW Node\n" "a.Id = 1\n" "b.Id = 2\n" "SET a.Other = b\n" "SET b.Other = a\n" "SET a = Nothing\n" "SET b = Nothing\n" "PRINT \"end\"\n" "BEGINCLASS \"Node\"\n" "Public Id AS INTEGER\n" "Public Other AS Node\n" "Private Sub Class_Terminate()\n" " PRINT \"bye\"; Id\n" " IF Id = 2 THEN SET saved = Me\n" "End Sub\n" "ENDCLASS\n", "end\n" "bye1 \n" "bye2 \n" ); } // The fast loop (runtime/vm.c runFast) against the reference // implementation: type limits, conversions, fused compares and jumps, // FOR counters, objects let go of by stores and returns, the // superinstructions (OP_*_K16, OP_STORE_*_CONV) and their errors. static void testFastLoop(void) { runFastAndStepped("Fast loop: integer and floating arithmetic at the type limits", "DIM a AS INTEGER\n" "DIM l AS LONG\n" "DIM v AS VARIANT\n" "a = 32767\n" "v = a + 1: PRINT v; TYPENAME(v)\n" "v = a * 2: PRINT v; TYPENAME(v)\n" "v = a - 1: PRINT v; TYPENAME(v)\n" "l = 5\n" "PRINT TYPENAME(l + 1); TYPENAME(l - a); TYPENAME(l * 2); TYPENAME(l \\ 2); TYPENAME(l MOD 2); TYPENAME(-l); TYPENAME(l AND 1)\n" "l = -2147483647 - 1\n" "v = l MOD -1: PRINT v\n" "PRINT 100 \\ 7; 100 MOD 7; -7 \\ 2; -7 MOD 2\n" "v = 2.5\n" "PRINT v + 1; v * 3; v - 1; v / 2; TYPENAME(v + 1)\n" "v = NULL\n" "PRINT ISNULL(v + 1); ISNULL(v * 2)\n" "PRINT -a; -(l + 1); -v\n", "32768 Long\n" "65534 Long\n" "32766 Integer\n" "LongLongLongLongLongLongLong\n" "0 \n" "14 2 -3 -1 \n" "3.5 7.5 1.5 1.25 Double\n" "True True \n" "-32767 2147483647 Null\n" ); // A LONG result that does not fit is an Overflow (VB; two INTEGERs // widen to a LONG) runProgram("LONG arithmetic that overflows", "DIM l AS LONG\n" "DIM v AS VARIANT\n" "l = 2147483647\n" "ON ERROR RESUME NEXT\n" "v = 0: v = l + 1: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "v = 0: v = l * 3: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "v = 0: v = l + l: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "l = -2147483647 - 1\n" "v = 0: v = l \\ -1: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "v = 0: v = -l: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "v = 0: v = l - 1: PRINT ERR.NUMBER; v: ERR.CLEAR\n" "v = 0: v = l * 1.5: PRINT ERR.NUMBER; v: ERR.CLEAR\n", "6 0 \n6 0 \n6 0 \n6 0 \n6 0 \n6 0 \n0 -3221225472 \n" ); runFastAndStepped("Fast loop: comparisons fused with the jump that tests them", "DIM s AS STRING\n" "DIM i AS LONG\n" "s = \"abc\": i = 5\n" "IF s < \"abd\" THEN PRINT \"lt\"\n" "IF s = \"abc\" THEN PRINT \"eq\"\n" "IF s > \"ABC\" THEN PRINT \"gt\"\n" "IF 1.5 > 1 THEN PRINT \"dbl\"\n" "IF 2 = 2.0 THEN PRINT \"mixed\"\n" "IF i >= 5 AND i <= 5 THEN PRINT \"range\"\n" "IF NOT (i < 5) THEN PRINT \"not\"\n" "IF i <> 5 THEN PRINT \"wrong\" ELSE PRINT \"else\"\n" "PRINT (i = 5); (s <> \"abc\")\n", "lt\n" "eq\n" "gt\n" "dbl\n" "mixed\n" "range\n" "not\n" "else\n" "True False \n" ); runFastAndStepped("Fast loop: FOR counters at their limits, stores that convert", "DIM i AS INTEGER\n" "DIM n AS LONG\n" "DIM k AS INTEGER\n" "DIM g AS SINGLE\n" "FOR i = 32760 TO 32767\n" " n = n + 1\n" "NEXT i\n" "PRINT n; i; TYPENAME(i)\n" "FOR i = 10 TO 1 STEP -3: PRINT i;: NEXT: PRINT\n" "FOR n = 2147483645 TO 2147483647: PRINT n;: NEXT: PRINT\n" "k = 300 * 100 \\ 1000: PRINT k\n" "g = 1 / 3: PRINT g\n" "k = 2.5: PRINT k\n" "k = 3.5: PRINT k\n", "8 32768 Long\n" "10 7 4 1 \n" "2147483645 2147483646 2147483647 \n" "30 \n" "0.3333333 \n" "2 \n" "4 \n" ); runFastAndStepped("Fast loop: objects let go of by stores and returns", "SUB Pair()\n" " DIM a AS Thing\n" " DIM b AS Thing\n" " SET a = NEW Thing\n" " a.Tag = \"pair\"\n" " SET b = a\n" "END SUB\n" "FUNCTION Make(nm AS STRING) AS Thing\n" " DIM t AS Thing\n" " SET t = NEW Thing\n" " t.Tag = nm\n" " SET Make = t\n" "END FUNCTION\n" "DIM x AS Thing\n" "Pair\n" "PRINT \"after pair\"\n" "SET x = Make(\"kept\")\n" "PRINT x.Tag\n" "SET x = Make(\"second\")\n" "PRINT \"after second\"\n" "PRINT Make(\"temp\").Tag\n" "SET x = NOTHING\n" "PRINT \"end\"\n" "BEGINCLASS \"Thing\"\n" "Public Tag As String\n" "SUB Class_Terminate()\n" " PRINT \"bye \"; Tag\n" "END SUB\n" "ENDCLASS\n", "bye pair\n" "after pair\n" "kept\n" "bye kept\n" "after second\n" "bye temp\n" "temp\n" "bye second\n" "end\n" ); runProgram("Fast loop: a store that overflows raises the error at the statement", "ON ERROR GOTO h\n" "DIM i AS INTEGER\n" "DIM l AS LONG\n" "i = 1\n" "i = 40000\n" "PRINT \"after\"; i\n" "l = 2147483647\n" "l = l + 1\n" "PRINT \"long\"; l\n" "i = i \\ 0\n" "PRINT \"div\"; i\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "err6 \n" "after1 \n" "err6 \n" "long2147483647 \n" "err11 \n" "div1 \n" ); } // The follow-up round: Byte and Currency, error 13 for text that is not // a number, VB's &HBBGGRR colours, named arguments, QBasic line numbers, // STATIC arrays and TYPEs, and typed variables that start typed. static void testFollowUp(void) { runProgram("Follow-up: Byte holds 0 to 255", "DIM b AS BYTE\n" "ON ERROR GOTO h\n" "b = 200\n" "PRINT b; VARTYPE(b); TYPENAME(b)\n" "b = b + 55\n" "PRINT b; VARTYPE(b + b); -b; VARTYPE(-b)\n" "b = 256\n" "PRINT \"no\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR; CBYTE(3.5); CBYTE(4.5)\n", "200 17 Byte\n" "255 2 -255 2 \n" "err6 4 4 \n" ); runProgram("Follow-up: Currency is exact to four places", "DIM c AS CURRENCY\n" "DIM i AS INTEGER\n" "FOR i = 1 TO 10\n" " c = c + 0.1@\n" "NEXT\n" "PRINT c; c = 1; VARTYPE(c); TYPENAME(c)\n" "PRINT CCUR(1.23456); CCUR(2.00005); CCUR(2.00015)\n" "c = 12.5\n" "PRINT c * 3; c / 4; c \\ 4; FORMAT(c, \"0.00\"); STR$(c)\n" "c = 922337203685477.5807@\n" "PRINT c\n" "ON ERROR GOTO h\n" "c = c + 1\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n", "1 True 6 Currency\n" "1.2346 2 2.0002 \n" "37.5 3.125 3 12.50 12.5\n" "922337203685477.5807 \n" "err6 \n" ); runProgram("Follow-up: Currency counters and DEFCUR", "DEFCUR C\n" "FOR cnt = 0 TO 0.3 STEP 0.1\n" " PRINT cnt;\n" "NEXT\n" "PRINT VARTYPE(cnt)\n", "0 0.1 0.2 0.3 6 \n" ); runProgram("Follow-up: text that is not a number is error 13 and stores nothing", "DIM n AS INTEGER\n" "ON ERROR GOTO h\n" "n = \"12\"\n" "PRINT n\n" "n = \" 3.6 \"\n" "PRINT n\n" "n = \"abc\"\n" "PRINT n\n" "PRINT n + \"x\"\n" "PRINT VAL(\"12abc\"); ISNUMERIC(\"12abc\"); ISNUMERIC(\"1E3\")\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "12 \n" "4 \n" "err13 \n" "4 \n" "err13 \n" "12 False True \n" ); runProgram("Follow-up: RGB and QBColor are &HBBGGRR", "PRINT RGB(255, 0, 0); RGB(0, 0, 255); HEX$(RGB(1, 2, 3))\n" "PRINT QBCOLOR(4); QBCOLOR(9); vbRed; vbBlue\n" "PRINT GETRED(RGB(10, 20, 30)); GETGREEN(RGB(10, 20, 30)); GETBLUE(RGB(10, 20, 30))\n" "ON ERROR GOTO h\n" "PRINT QBCOLOR(16)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n", "255 16711680 30201\n" "128 16711680 255 16711680 \n" "10 20 30 \n" "err5 \n" ); runProgram("Follow-up: named arguments", "SUB Info(a AS INTEGER, OPTIONAL b AS STRING = \"B\", OPTIONAL c AS INTEGER = 9)\n" " PRINT a; b; c\n" "END SUB\n" "FUNCTION Sum(x AS INTEGER, y AS INTEGER) AS INTEGER\n" " Sum = x * 10 + y\n" "END FUNCTION\n" "BEGINCLASS \"K\"\n" "PUBLIC FUNCTION F(x AS INTEGER, OPTIONAL y AS INTEGER = 2) AS INTEGER\n" " F = x * 10 + y\n" "END FUNCTION\n" "ENDCLASS\n" "Info c:=3, a:=1\n" "Info 2, c:=5\n" "PRINT Sum(y:=1, x:=2)\n" "PRINT MID$(start:=2, string:=\"hello\", length:=3)\n" "PRINT INSTR(String1:=\"abcabc\", String2:=\"c\")\n" "DIM col AS NEW Collection\n" "col.Add \"one\", Key:=\"k1\"\n" "col.Add Item:=\"two\", Key:=\"k2\", Before:=1\n" "PRINT col(1); col(\"k1\")\n" "DIM kk AS NEW K\n" "PRINT kk.F(y:=5, x:=1)\n" "DIM o AS OBJECT\n" "SET o = NEW K\n" "PRINT o.F(y:=5, x:=1); o.F(x:=3)\n" "ON ERROR GOTO h\n" "PRINT o.F(z:=1)\n" "PRINT o.F(1, x:=1)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "1 B3 \n" "2 B5 \n" "21 \n" "ell\n" "3 \n" "twoone\n" "15 \n" "15 32 \n" "err448 \n" "err450 \n" ); expectCompileError("Follow-up: a named argument the SUB does not have", "SUB S(a)\nEND SUB\nS b:=2\n", "b" ); runProgram("Follow-up: QBasic line numbers", "10 n = 1\n" "20 ON n GOTO 100, 200\n" "100 PRINT \"at 100\"\n" "110 IF n = 1 THEN 200 ELSE 300\n" "200 PRINT \"at 200\"\n" "210 n = n + 1\n" "215 IF n < 3 GOTO 110\n" "220 RESTORE 500\n" "230 READ a, b\n" "240 PRINT a; b\n" "250 ON ERROR GOTO 400\n" "260 x = 1 / 0\n" "270 GOSUB 600\n" "290 END\n" "300 PRINT \"at 300\"\n" "310 GOTO 220\n" "400 PRINT \"err\"; ERR; ERL\n" "410 RESUME 270\n" "450 DATA 1, 2\n" "500 DATA 7, 8\n" "600 PRINT \"sub\"\n" "610 RETURN\n", "at 100\n" "at 200\n" "at 300\n" "7 8 \n" "err11 260 \n" "sub\n" ); expectCompileError("Follow-up: a line number past 65529", "65530 PRINT 1\n", "Line number out of range" ); runProgram("Follow-up: STATIC arrays and TYPEs keep their values", "TYPE Pt\n" " x AS INTEGER\n" "END TYPE\n" "SUB S\n" " STATIC a(2) AS INTEGER, p AS Pt\n" " a(1) = a(1) + 1\n" " p.x = p.x + 2\n" " PRINT a(1); p.x\n" "END SUB\n" "S\n" "S\n", "1 2 \n" "2 4 \n" ); runProgram("Follow-up: typed variables start as their type", "DIM a AS LONG, s AS STRING, d AS DOUBLE, b AS BYTE, c AS CURRENCY\n" "PRINT VARTYPE(a); VARTYPE(s); VARTYPE(d); VARTYPE(b); VARTYPE(c)\n" "SUB T\n" " DIM l AS SINGLE\n" " PRINT VARTYPE(l)\n" "END SUB\n" "T\n", "3 8 5 17 6 \n" "4 \n" ); } // The front end: what names mean (the resolver's rules), error positions, // compile time against program size, and TYPE values assigned into the // record that is there. static void testFrontEnd(void) { // Rule 1: a declared name wins -- a local over a module variable, a // FUNCTION or variable over a built-in of the name; an unshared module // variable is not seen inside a procedure, a DEF FN sees it runProgram("Resolver: declared names win, scopes", "DIM SHARED x AS INTEGER\n" "DIM y AS INTEGER\n" "x = 1\n" "y = 3\n" "S\n" "PRINT x; y\n" "DEF FNtwice(n) = n * 2 + y\n" "PRINT FNtwice(5)\n" "PRINT StrReverse(\"abc\")\n" "DIM Sgn AS INTEGER\n" "Sgn = 7\n" "PRINT Sgn\n" "SUB S\n" " DIM x AS INTEGER\n" " x = 2\n" " PRINT x; y\n" "END SUB\n" "FUNCTION StrReverse(s AS STRING) AS STRING\n" " StrReverse = \"[\" + s + \"]\"\n" "END FUNCTION\n", "2 0 \n1 3 \n13 \n[abc]\n7 \n" ); // Rule 1 in a class: its member wins over a module variable of the name runProgram("Resolver: a class member wins over a module variable", "DIM SHARED n AS INTEGER\n" "n = 5\n" "DIM o AS NEW Box\n" "o.SetN 9\n" "PRINT n; o.n\n" "BEGINCLASS \"Box\"\n" "Public n AS INTEGER\n" "Public Sub SetN(BYVAL v AS INTEGER)\n" " n = v\n" "End Sub\n" "ENDCLASS\n", "5 9 \n" ); // Rule 4: OPTION EXPLICIT refuses a name nothing declares expectCompileError("Resolver: OPTION EXPLICIT refuses an implicit variable", "OPTION EXPLICIT\n" "DIM a AS INTEGER\n" "a = b + 1\n", "Line 3, Col 5: Variable not declared: b" ); // Errors carry the column of what is wrong expectCompileError("Errors: missing operand", "x = 1 +\n", "Line 1, Col 8: Expected expression, got newline"); expectCompileError("Errors: a SUB used as a value", "PRINT Foo(1)\nSUB Foo(a)\nEND SUB\n", "Line 1, Col 7: Sub 'Foo' cannot be used in an expression"); expectCompileError("Errors: constant expression", "CONST K = 1 / 0\n", "Line 1, Col 13: Error in constant expression: Division by zero"); expectCompileError("Errors: unknown field", "TYPE T\nx AS INTEGER\nEND TYPE\nDIM v AS T\nPRINT v.y\n", "Line 5, Col 9: Unknown field 'y' in TYPE 'T'"); expectCompileError("Errors: NEXT of another loop", "FOR i = 1 TO 3\nNEXT j\n", "Line 2, Col 6: NEXT j does not match FOR i"); // Compile time grows with the program, not faster double small = bestCompileSeconds(TEST_SCALE_PROCS); double large = bestCompileSeconds(TEST_SCALE_PROCS * TEST_SCALE_FACTOR); printf("=== Compile time against procedure count ===\n"); if (small < 0.0 || large < 0.0) { printf("FAIL: generated program did not compile\n\n"); gFailCount++; } else if (small > 0.0 && large > small * TEST_SCALE_LIMIT) { printf("FAIL: %d procedures took %.4fs, %d took %.4fs\n\n", TEST_SCALE_PROCS, small, TEST_SCALE_PROCS * TEST_SCALE_FACTOR, large); gFailCount++; } else { printf("OK (%.4fs, %.4fs)\n\n", small, large); } // A TYPE value assigned to a TYPE variable, element or field is copied // into the record there (VB): copies stay apart, and a ByRef reference // to a field taken before the assignment sees the new value runProgram("Records: assignment copies into the record", "TYPE Inner\n" " v AS INTEGER\n" "END TYPE\n" "TYPE Rec\n" " n AS LONG\n" " s AS STRING * 4\n" " i AS Inner\n" "END TYPE\n" "DIM a AS Rec\n" "DIM b AS Rec\n" "DIM arr(2) AS Rec\n" "a.n = 1: a.s = \"ab\": a.i.v = 9\n" "b = a\n" "a.n = 2\n" "PRINT b.n; a.n; \"[\"; b.s; \"]\"; b.i.v\n" "arr(1) = a\n" "a.n = 3\n" "PRINT arr(1).n; a.n\n" "Bump a.n, a\n" "PRINT a.n; a.s\n" "arr(2).i = b.i\n" "b.i.v = 4\n" "PRINT arr(2).i.v; b.i.v\n" "SUB Bump(f AS LONG, r AS Rec)\n" " DIM t AS Rec\n" " t.n = 100\n" " t.s = \"zz\"\n" " r = t\n" " f = f + 1\n" "END SUB\n", "1 2 [ab ]9 \n2 3 \n101 zz \n9 4 \n" ); } // Gap closure (basicGapsPlan.md): the language limits closed in the // final pass, one program each. static void testGapClosure(void) { runProgram("Gap closure: a call's result indexed (c(1)(0), Split(s)(n))", "DIM c AS NEW Collection\n" "DIM a(2) AS INTEGER\n" "a(0) = 11\n" "c.Add a\n" "PRINT c(1)(0); SPLIT(\"x,y,z\", \",\")(2); c.Item(1)(0)\n" "DIM v AS VARIANT\n" "v = c\n" "PRINT v(1)(0)\n", "11 z11 \n" "11 \n" ); runProgram("Gap closure: Null through the Variant string, search and date functions; the $ forms raise error 94", "DIM v AS VARIANT\n" "v = NULL\n" "PRINT ISNULL(LEFT(v, 1)); ISNULL(MID(v, 1)); ISNULL(MID(v, 1, 2)); ISNULL(UCASE(v)); ISNULL(TRIM(v)); ISNULL(LEN(v))\n" "PRINT ISNULL(INSTR(v, \"a\")); ISNULL(INSTR(1, \"a\", v)); ISNULL(STRCOMP(v, \"a\")); ISNULL(INSTRREV(\"a\", v)); ISNULL(STR(v)); ISNULL(HEX(v)); ISNULL(STRING(3, v)); ISNULL(YEAR(v)); ISNULL(DATEPART(\"yyyy\", v))\n" "PRINT LEFT(\"abc\", 2); MID(\"abcdef\", 2, 3); UCASE(\"x\"); STRING(3, \"z\"); STR(5); HEX(255); CHR(65); SPACE(2); \"|\"; LEN(\"abcd\"); TRIM(\" q \")\n" "v = \"hello\"\n" "PRINT LEFT(v, 2); LEN(v)\n" "ON ERROR GOTO h\n" "v = NULL\n" "PRINT LEFT$(v, 1)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "True True True True True True \n" "True True True True True True True True True \n" "abbcdXzzz 5FFA |4 q\n" "he5 \n" "err94 \n" ); runProgram("Gap closure: CLOSE with a list or nothing, RESET, ERASE of a list", "OPEN \"gapc1.txt\" FOR OUTPUT AS #1: OPEN \"gapc2.txt\" FOR OUTPUT AS #2: OPEN \"gapc3.txt\" FOR OUTPUT AS #3\n" "PRINT #1, \"one\": PRINT #2, \"two\": PRINT #3, \"three\"\n" "CLOSE #1, #2\n" "PRINT FREEFILE\n" "CLOSE\n" "PRINT FREEFILE\n" "OPEN \"gapc1.txt\" FOR INPUT AS #4\n" "RESET\n" "PRINT FREEFILE\n" "DIM a(3), b(3) AS STRING\n" "a(1) = 5: b(1) = \"x\"\n" "ERASE a, b\n" "PRINT a(1); \"[\"; b(1); \"]\"\n" "CLOSE #9\n" "ON ERROR GOTO h\n" "CLOSE 1, 99\n" "END\n" "h: PRINT \"err\"; ERR: RESUME NEXT\n", "1 \n" "1 \n" "1 \n" "0 []\n" "err52 \n" ); runProgram("Gap closure: STATIC lists, fixed-length strings, each object's own copies", "DIM a AS NEW Ctr, b AS NEW Ctr\n" "PRINT a.Hit; a.Hit; b.Hit; a.Hit; \"[\"; a.Name; \"]\"; a.Tot(2); b.Tot(5); a.Tot(1)\n" "BEGINCLASS \"Ctr\"\n" "Public Function Hit() As Integer\n" " STATIC n AS INTEGER\n" " n = n + 1\n" " Hit = n\n" "End Function\n" "Public Function Name() As String\n" " STATIC s AS STRING\n" " Name = s & \"x\"\n" "End Function\n" "Public Function Tot(k AS INTEGER) AS LONG\n" " STATIC t\n" " t = t + k\n" " Tot = t\n" "End Function\n" "ENDCLASS\n" "SUB L\n" " STATIC a, b AS STRING, f AS STRING * 3\n" " a = a + 1: b = b + \"y\"\n" " PRINT a; b; \"[\"; f; \"]\"\n" " f = \"q\"\n" "END SUB\n" "L\n" "L\n", "1 2 1 3 [x]2 5 3 \n" "1 y[]\n" "2 yy[q ]\n" ); runProgram("Gap closure: SUB / FUNCTION ... STATIC keep every local between calls (each object its own)", "S\n" "S\n" "PRINT F(2); F(3)\n" "DIM o AS NEW K\n" "DIM p AS NEW K\n" "PRINT o.Hit; o.Hit; p.Hit\n" "SUB S STATIC\n" " DIM t AS STRING\n" " n = n + 1\n" " t = t + \"x\"\n" " PRINT n; t\n" "END SUB\n" "FUNCTION F(k AS INTEGER) AS INTEGER STATIC\n" " tot = tot + k\n" " F = tot\n" "END FUNCTION\n" "BEGINCLASS \"K\"\n" "Public Function Hit() As Integer Static\n" " c = c + 1\n" " Hit = c\n" "End Function\n" "ENDCLASS\n", "1 x\n" "2 xx\n" "2 5 \n" "1 2 1 \n" ); runProgram("Gap closure: WITH ... END WITH on records, nested, objects, New and Me", "TYPE P\n" " x AS INTEGER\n" " y AS INTEGER\n" "END TYPE\n" "TYPE Q\n" " pt AS P\n" " n AS STRING\n" "END TYPE\n" "DIM pt AS P, qs(3) AS Q\n" "WITH pt\n" " .x = 3\n" " .y = .x + 1\n" "END WITH\n" "PRINT pt.x; pt.y\n" "i = 2\n" "WITH qs(i)\n" " .n = \"two\"\n" " WITH .pt\n" " .x = 7\n" " Bump .y\n" " END WITH\n" "END WITH\n" "PRINT qs(2).n; qs(2).pt.x; qs(2).pt.y\n" "DIM b AS NEW Box\n" "WITH b\n" " .Value = 5\n" " .Add 3\n" " PRINT .Value; .Twice()\n" "END WITH\n" "WITH New Box\n" " .Value = 9\n" " PRINT .Value\n" "END WITH\n" "DIM o AS OBJECT\n" "SET o = b\n" "WITH o\n" " .Add 1\n" " PRINT .Value\n" "END WITH\n" "SUB Bump(n AS INTEGER)\n" " n = n + 100\n" "END SUB\n" "BEGINCLASS \"Box\"\n" "Public Value AS INTEGER\n" "Public Sub Add(k AS INTEGER)\n" " Value = Value + k\n" "End Sub\n" "Public Function Twice() AS INTEGER\n" " WITH Me\n" " Twice = .Value * 2\n" " END WITH\n" "End Function\n" "Private Sub Class_Terminate()\n" " PRINT \"[term\"; Value; \"]\"\n" "End Sub\n" "ENDCLASS\n", "3 4 \n" "two7 100 \n" "8 16 \n" "9 \n" "[term9 ]\n" "9 \n" "[term9 ]\n" ); runProgram("Gap closure: Friend procedures and properties for the program's own code", "DIM o AS NEW K\n" "PRINT o.F(2); o.Size\n" "o.Size = 5\n" "PRINT o.Size\n" "BEGINCLASS \"K\"\n" "Private m AS INTEGER\n" "Friend Function F(n AS INTEGER) AS INTEGER\n" " DIM t AS INTEGER\n" " t = n * 3\n" " F = t\n" "End Function\n" "Friend Property Get Size() AS INTEGER\n" " Size = m\n" "End Property\n" "Friend Property Let Size(v AS INTEGER)\n" " m = v\n" "End Property\n" "ENDCLASS\n", "6 0 \n" "5 \n" ); runProgram("Gap closure: a Friend member is not reached through late binding (error 438)", "DIM o AS NEW K\n" "DIM x AS OBJECT\n" "SET x = o\n" "ON ERROR GOTO h\n" "PRINT x.F(2)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "END\n" "BEGINCLASS \"K\"\n" "Private m AS INTEGER\n" "Friend Function F(n AS INTEGER) AS INTEGER\n" " DIM t AS INTEGER\n" " t = n * 3\n" " F = t\n" "End Function\n" "Friend Property Get Size() AS INTEGER\n" " Size = m\n" "End Property\n" "Friend Property Let Size(v AS INTEGER)\n" " m = v\n" "End Property\n" "ENDCLASS\n", "err438 \n" ); runProgram("Gap closure: Property procedures in a standard module", "DIM SHARED m AS INTEGER\n" "DIM SHARED arr(5) AS STRING\n" "Size = 4\n" "PRINT Size\n" "Item(2) = \"two\"\n" "PRINT Item(2); \"|\"; arr(2)\n" "SUB T\n" " Size = Size + 1\n" " PRINT Size\n" "END SUB\n" "T\n" "DIM o AS NEW K\n" "o.Go\n" "PROPERTY GET Size() AS INTEGER\n" " Size = m * 2\n" "END PROPERTY\n" "PROPERTY LET Size(n AS INTEGER)\n" " m = n\n" "END PROPERTY\n" "PROPERTY GET Item(i AS INTEGER) AS STRING\n" " Item = arr(i)\n" "END PROPERTY\n" "PROPERTY LET Item(i AS INTEGER, v AS STRING)\n" " arr(i) = UCASE$(v)\n" "END PROPERTY\n" "BEGINCLASS \"K\"\n" "Private mv AS INTEGER\n" "Public Property Get V() AS INTEGER\n" " V = mv\n" "End Property\n" "Public Property Let V(n AS INTEGER)\n" " mv = n\n" "End Property\n" "Public Sub Go()\n" " V = 7\n" " PRINT V; Size\n" "End Sub\n" "ENDCLASS\n", "8 \n" "TWO|TWO\n" "18 \n" "7 18 \n" ); runProgram("Gap closure: Private CONST / ENUM belong to their class", "PRINT K1\n" "DIM o AS NEW C\n" "o.Show1\n" "BEGINCLASS \"C\"\n" "PRIVATE CONST K1 = 7\n" "PRIVATE ENUM EE\n" " Zap = 4\n" "END ENUM\n" "Public Sub Show1()\n" " PRINT K1; Zap\n" "End Sub\n" "ENDCLASS\n", "0 \n" "7 4 \n" ); runProgram("Gap closure: Private CONST / ENUM belong to their module file; Public ones are seen everywhere", "BEGINMODULE \"m1\"\n" "PRIVATE CONST K = 1\n" "PRIVATE ENUM E\n" " Zed = 10\n" "END ENUM\n" "SUB A\n" " PRINT K; Zed\n" "END SUB\n" "ENDMODULE\n" "BEGINMODULE \"m2\"\n" "PRIVATE CONST K = 2\n" "PUBLIC CONST P = 3\n" "SUB B\n" " PRINT K; P\n" "END SUB\n" "A\n" "B\n" "ENDMODULE\n", "1 10 \n" "2 3 \n" ); runProgram("Gap closure: the constants of a class module or form belong to their file", "BEGINCLASS \"C\"\n" "CONST KC = 7\n" "ENDCLASS\n" "BEGINFORM \"F\"\n" "CONST KF = 8\n" "ENDFORM\n" "BEGINFORM \"G\"\n" "CONST KF = 9\n" "ENDFORM\n" "PRINT KC; KF\n", "0 0 \n" ); runProgram("Gap closure: PUBLIC / PRIVATE on ENUM and CONST at module level", "PUBLIC ENUM Colors\n" " Red\n" " Green = 5\n" "END ENUM\n" "PRIVATE CONST K = 3\n" "PUBLIC CONST L AS LONG = 4\n" "PRINT Red; Green; K; L; Colors.Green\n", "0 5 3 4 5 \n" ); runProgram("Gap closure: typed parameters convert their arguments (ByVal, values, late binding, copies for mismatched variables)", "SUB V(BYVAL x AS INTEGER)\n" " PRINT x;\n" "END SUB\n" "SUB R(x AS INTEGER)\n" " x = x + 1\n" " PRINT x;\n" "END SUB\n" "SUB S(t AS STRING, d AS DATE, b AS BOOLEAN, g AS DOUBLE)\n" " PRINT t; \"|\"; d; \"|\"; b; \"|\"; g\n" "END SUB\n" "V 3.7\n" "R 3.7\n" "DIM d AS DOUBLE\n" "d = 2.6\n" "V d\n" "R ((d))\n" "DIM n AS INTEGER\n" "n = 5\n" "R n\n" "PRINT n\n" "S 5, \"1/2/2020\", 1, \"2.5\"\n" "u = 7.6\n" "R u\n" "PRINT u\n" "DIM o AS OBJECT\n" "SET o = NEW K\n" "o.M 4.6\n" "DIM lng AS LONG\n" "lng = 9\n" "o.N lng\n" "PRINT lng\n" "o.N n\n" "PRINT n\n" "BEGINCLASS \"K\"\n" "Public Sub M(x AS INTEGER)\n" " PRINT x\n" "End Sub\n" "Public Sub N(x AS INTEGER)\n" " x = x * 10\n" "End Sub\n" "ENDCLASS\n", "4 5 3 4 6 6 \n" "5|1/2/2020|True |2.5 \n" "9 9 \n" "5 \n" "9 \n" "60 \n" ); runProgram("Gap closure: name (x) without CALL passes x by value", "SUB V(BYVAL x AS INTEGER)\n" " PRINT x;\n" "END SUB\n" "SUB R(x AS INTEGER)\n" " PRINT x;\n" "END SUB\n" "FUNCTION F(x AS LONG) AS LONG\n" " F = x\n" "END FUNCTION\n" "V 3.7\n" "R 3.7\n" "d# = 2.6\n" "V d#\n" "R (d#)\n" "PRINT F(2.5); F(3.5)\n" "DIM o AS NEW K\n" "o.M 4.6\n" "BEGINCLASS \"K\"\n" "Public Sub M(x AS INTEGER)\n" " PRINT x\n" "End Sub\n" "ENDCLASS\n", "4 4 3 3 2 4 \n" "5 \n" ); runProgram("Gap closure: stores into STRING and DOUBLE variables convert", "DIM s AS STRING\n" "s = 5\n" "PRINT LEN(s); VARTYPE(s); \"[\"; s; \"]\"\n" "DIM d AS DOUBLE\n" "d = \"2.5\"\n" "PRINT VARTYPE(d); d * 2\n", "1 8 [5]\n" "5 5 \n" ); runProgram("Gap closure: an object's default member stands for it in expressions (no default: error 13)", "DIM o AS NEW Box\n" "o.Value = 7\n" "DIM x AS INTEGER\n" "x = o\n" "PRINT x; o + 1; \"[\"; o; \"]\"\n" "DIM v AS OBJECT\n" "SET v = o\n" "PRINT v * 2; v = 7; LEN(v & \"\")\n" "IF v THEN PRINT \"true\"\n" "DIM s AS STRING\n" "s = o\n" "PRINT s; \"|\"; UCASE$(o)\n" "DIM n AS NEW Named\n" "PRINT n & \"!\"; n.Twice\n" "ON ERROR GOTO h\n" "DIM w AS NEW NoDef\n" "PRINT w + 1\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "END\n" "BEGINCLASS \"Box\"\n" "Private m As Integer\n" "Public Property Get Value() As Integer\n" "Attribute Value.VB_UserMemId = 0\n" " Value = m\n" "End Property\n" "Public Property Let Value(n As Integer)\n" " m = n\n" "End Property\n" "ENDCLASS\n" "BEGINCLASS \"Named\"\n" "Public Label As String\n" "Attribute Label.VB_UserMemId = 0\n" "Private Sub Class_Initialize()\n" " Label = \"nm\"\n" "End Sub\n" "Public Function Twice() As String\n" " Twice = Me & Me\n" "End Function\n" "ENDCLASS\n" "BEGINCLASS \"NoDef\"\n" "Public q As Integer\n" "ENDCLASS\n", "7 8 [7 ]\n" "14 True 1 \n" "true\n" "7|7\n" "nm!nmnm\n" "err13 \n" ); runProgram("Gap closure: a store into an object variable without SET goes to its default member", "DIM o AS NEW Box\n" "DIM p AS Box\n" "p = o\n" "PRINT TYPENAME(p)\n" "DIM q AS OBJECT\n" "q = o\n" "PRINT TYPENAME(q)\n" "o = 9\n" "PRINT TYPENAME(o)\n" "BEGINCLASS \"Box\"\n" "Public v AS INTEGER\n" "Attribute v.VB_UserMemId = 0\n" "ENDCLASS\n", "Box\n" "Box\n" "Box\n" ); runProgram("Gap closure: Property Let as the default member, through Object too", "DIM o AS NEW Box\n" "o = 9\n" "PRINT o.Value; o\n" "DIM q AS OBJECT\n" "SET q = o\n" "q = 3 + 4\n" "PRINT o\n" "BEGINCLASS \"Box\"\n" "Private m As Integer\n" "Public Property Get Value() As Integer\n" "Attribute Value.VB_UserMemId = 0\n" " Value = m\n" "End Property\n" "Public Property Let Value(n As Integer)\n" " m = n\n" "End Property\n" "ENDCLASS\n", "9 9 \n" "7 \n" ); runProgram("Gap closure: PRINT # columns, zones, TAB, SPC, USING and WIDTH #", "OPEN \"gapw.txt\" FOR OUTPUT AS #1\n" "WIDTH #1, 5\n" "PRINT #1, \"abcdefghijkl\"\n" "PRINT #1, \"ab\"; \"cdef\"\n" "WIDTH #1, 255\n" "PRINT #1, \"a\", \"b\"; TAB(20); \"c\"; SPC(2); \"d\"\n" "PRINT #1, USING \"##.#\"; 3.14159; 2.5\n" "PRINT #1, 1; 2\n" "PRINT #1,\n" "CLOSE #1\n" "OPEN \"gapw.txt\" FOR INPUT AS #1\n" "DO WHILE NOT EOF(1)\n" "LINE INPUT #1, a$\n" "PRINT \"[\"; a$; \"]\"\n" "LOOP\n" "CLOSE\n", "[abcde]\n" "[fghij]\n" "[kl]\n" "[ab]\n" "[cdef]\n" "[a b c d]\n" "[ 3.1 2.5]\n" "[1 2 ]\n" "[]\n" ); runProgram("Gap closure: WIDTH of devices and files: errors 64, 52 and 5; PRINT # stopped by an error", "ON ERROR GOTO h\n" "WIDTH \"COM9:\", 10\n" "WIDTH #3, 10\n" "WIDTH LPRINT 0\n" "WIDTH \"LPT2:\", 255\n" "OPEN \"gapx.txt\" FOR OUTPUT AS #2\n" "PRINT #2, 1 / 0; \"after\"\n" "PRINT \"console\"\n" "CLOSE #2\n" "END\n" "h: PRINT \"err\"; ERR: RESUME NEXT\n", "err64 \n" "err52 \n" "err5 \n" "err11 \n" "console\n" ); runProgram("Gap closure: a parenthesised RaiseEvent value is one temporary every handler shares", "DIM WithEvents a AS Src\n" "DIM WithEvents b AS Src\n" "SET a = NEW Src\n" "SET b = a\n" "a.Fire\n" "SUB a_E(n AS INTEGER)\n" " PRINT \"a\"; n;\n" " n = n + 1\n" "END SUB\n" "SUB b_E(n AS INTEGER)\n" " PRINT \"b\"; n;\n" " n = n + 10\n" "END SUB\n" "BEGINCLASS \"Src\"\n" "Event E(n AS INTEGER)\n" "Public Sub Fire()\n" " DIM x AS INTEGER\n" " x = 5\n" " RaiseEvent E((x))\n" " RaiseEvent E(x + 0)\n" " RaiseEvent E(x)\n" " PRINT \"x\"; x\n" "End Sub\n" "ENDCLASS\n", "a5 b6 a5 b6 a5 b6 x16 \n" ); runProgram("Gap closure: a left-out argument through an interface takes the interface's default", "DIM i AS IFoo\n" "SET i = NEW Impl\n" "i.Go\n" "BEGINCLASS \"IFoo\"\n" "Public Sub Go(Optional n AS INTEGER = 5)\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"Impl\"\n" "Implements IFoo\n" "Private Sub IFoo_Go(Optional n AS INTEGER = 9)\n" " PRINT n\n" "End Sub\n" "ENDCLASS\n", "5 \n" ); runProgram("Gap closure: Class_Terminate runs for objects still held when the program ends", "DIM o AS K\n" "SET o = NEW K\n" "PRINT \"end of code\"\n" "BEGINCLASS \"K\"\n" "Private Sub Class_Terminate()\n" " PRINT \"terminate\"\n" "End Sub\n" "ENDCLASS\n", "end of code\n" "terminate\n" ); runProgram("Gap closure: a late-bound ByVal parameter given a TYPE field leaves the field alone", "TYPE R\n" " f AS INTEGER\n" "END TYPE\n" "DIM r1 AS R\n" "r1.f = 5\n" "DIM o AS OBJECT\n" "SET o = NEW K\n" "o.M r1.f\n" "PRINT r1.f\n" "o.N r1.f\n" "PRINT r1.f\n" "BEGINCLASS \"K\"\n" "Public Sub M(ByVal x AS INTEGER)\n" " x = 99\n" "End Sub\n" "Public Sub N(x AS INTEGER)\n" " x = 77\n" "End Sub\n" "ENDCLASS\n", "5 \n" "77 \n" ); runProgram("Gap closure: RaiseEvent passes a TYPE field by reference, a parenthesised one by value", "TYPE R\n" " f AS INTEGER\n" "END TYPE\n" "DIM r1 AS R\n" "DIM WithEvents s AS Src\n" "SET s = NEW Src\n" "s.Go\n" "SUB s_Ping(n AS INTEGER)\n" " n = n + 10\n" "END SUB\n" "BEGINCLASS \"Src\"\n" "Event Ping(n AS INTEGER)\n" "Public Sub Go()\n" " DIM q AS R\n" " q.f = 1\n" " RaiseEvent Ping(q.f)\n" " PRINT q.f\n" " RaiseEvent Ping((q.f))\n" " PRINT q.f\n" "End Sub\n" "ENDCLASS\n", "11 \n" "11 \n" ); runProgram("Gap closure: ON ERROR RESUME NEXT, in the procedure and in ones it calls; Err.Number / Description; Err.Clear", "ON ERROR RESUME NEXT\n" "x = 1 / 0\n" "PRINT \"after\"; ERR; Err.Number; \"[\"; Err.Description; \"]\"\n" "Err.Clear\n" "PRINT ERR\n" "S\n" "PRINT \"back\"; ERR\n" "SUB S\n" " PRINT 1 / 0\n" " PRINT \"not here\"\n" "END SUB\n", "after11 11 [Division by zero]\n" "0 \n" "back11 \n" ); runProgram("Gap closure: Err.Raise with number, source and description", "ON ERROR GOTO h\n" "ERROR 5\n" "Err.Raise 1001, \"Mine\", \"Custom thing\"\n" "Err.Raise 9\n" "END\n" "h: PRINT ERR; Err.Number; Err.Description; \"|\"; Err.Source: RESUME NEXT\n", "5 5 Illegal function call|\n" "1001 1001 Custom thing|Mine\n" "9 9 Subscript out of range|\n" ); runProgram("Gap closure: Err.Number = n sets the error without raising it", "Err.Number = 11\n" "PRINT ERR; Err.Description\n" "Err.Clear\n" "PRINT ERR; \"[\"; Err.Description; \"]\"\n", "11 Division by zero\n" "0 []\n" ); runProgram("Gap closure: LIKE patterns (* ? # [list] [!list]), OPTION COMPARE TEXT, Null, error 93", "PRINT \"abc\" LIKE \"a*\"; \"abc\" LIKE \"a?d\"; \"a1\" LIKE \"a#\"; \"b\" LIKE \"[a-c]\"; \"x\" LIKE \"[!a-c]\"; \"ABC\" LIKE \"abc\"; \"a*b\" LIKE \"a[*]b\"; \"\" LIKE \"*\"; \"abc\" LIKE \"*c\"; \"aXbXc\" LIKE \"a*b*c\"\n" "OPTION COMPARE TEXT\n" "PRINT \"ABC\" LIKE \"abc\"\n" "v = NULL\n" "PRINT ISNULL(v LIKE \"a\")\n" "ON ERROR GOTO h\n" "PRINT \"a\" LIKE \"[ab\"\n" "END\n" "h: PRINT \"err\"; ERR: RESUME NEXT\n", "True False True True True False True True True True \n" "True \n" "True \n" "err93 \n" ); runProgram("Gap closure: ERROR$ / ERROR give an error's text", "PRINT ERROR$(5); \"|\"; ERROR(11); \"|\"; ERROR$(0); \"|\"\n" "ON ERROR RESUME NEXT\n" "ERROR 6\n" "PRINT ERROR$; \"|\"; ERROR\n", "Illegal function call|Division by zero||\n" "Overflow|Overflow\n" ); runProgram("Gap closure: FILEATTR gives a file's mode and handle", "OPEN \"gapf1.txt\" FOR OUTPUT AS #1\n" "OPEN \"gapf2.txt\" FOR BINARY AS #2\n" "PRINT FILEATTR(1, 1); FILEATTR(2, 1); FILEATTR(1, 2) > 0\n" "ON ERROR GOTO h\n" "PRINT FILEATTR(3, 1)\n" "PRINT FILEATTR(1, 7)\n" "END\n" "h: PRINT \"err\"; ERR: RESUME NEXT\n", "2 32 True \n" "err52 \n" "err5 \n" ); runProgram("Gap closure: ASC of an empty string is error 5", "a$ = \"\"\n" "ON ERROR GOTO h\n" "PRINT ASC(a$)\n" "PRINT ASC(\"Q\")\n" "END\n" "h: PRINT \"err\"; ERR: RESUME NEXT\n", "err5 \n" "81 \n" ); runProgram("Gap closure: ARRAY builds a Variant array", "DIM v AS VARIANT, w AS VARIANT\n" "v = ARRAY(1, \"two\", 3.5)\n" "PRINT LBOUND(v); UBOUND(v); v(1); TYPENAME(v)\n" "w = ARRAY()\n" "PRINT UBOUND(w)\n" "FOR EACH x IN ARRAY(4, 5)\n" "PRINT x;\n" "NEXT\n" "PRINT\n", "0 2 twoVariant()\n" "-1 \n" "4 5 \n" ); runProgram("Gap closure: ARRAY under OPTION BASE 1 starts at 1", "OPTION BASE 1\n" "DIM v AS VARIANT\n" "v = ARRAY(7, 8)\n" "PRINT LBOUND(v); UBOUND(v); v(1)\n", "1 2 7 \n" ); expectCompileError("Gap closure: a variable of another type given ByRef to a typed parameter", "SUB S(x AS INTEGER)\nEND SUB\nDIM d AS DOUBLE\nS d\n", "ByRef argument type mismatch: argument 1 of 'S' is Double, the parameter is Integer" ); expectCompileError("Gap closure: Public CONST in a class module", "BEGINCLASS \"C\"\nPUBLIC CONST K = 1\nENDCLASS\n", "Constants are not allowed as Public members of a class module or form" ); expectCompileError("Gap closure: EnumName.Member = x", "ENUM E\n A\n B\nEND ENUM\nE.A = 3\n", "Cannot assign to a constant" ); runProgram("Follow-up: an array in a STATIC procedure keeps its values", "SUB S STATIC\n DIM a(3)\n a(1) = a(1) + 1\n PRINT a(1)\nEND SUB\nS\nS\n", "1 \n2 \n" ); expectCompileError("Gap closure: Err has no such value", "PRINT Err.Foo\n", "Err has no value 'Foo'" ); expectCompileError("Gap closure: Err has no such statement", "Err.Bogus\n", "Err has no statement 'Bogus'" ); // PEN: the mouse on the program screen stands in for the light pen CaptureT cap; TestKeysT keys; memset(&keys, 0, sizeof(keys)); keys.mouseX[0] = TEST_PEN_X1; keys.mouseY[0] = TEST_PEN_Y1; keys.mouseDown[0] = true; keys.mouseX[1] = TEST_PEN_X2; keys.mouseY[1] = TEST_PEN_Y2; keys.mouseCount = 2; BasVmT *vm = screenRun("Gap closure: PEN ON, PEN(0) to PEN(9), PEN OFF", "SCREEN 12\n" "PEN ON\n" "DOEVENTS\n" "d1 = PEN(3): x1 = PEN(1): y1 = PEN(2): r1 = PEN(6): c1 = PEN(7)\n" "DOEVENTS\n" "p1 = PEN(0): p2 = PEN(0): d2 = PEN(3): x2 = PEN(4): y2 = PEN(5): r2 = PEN(8): c2 = PEN(9)\n" "PEN OFF\n" "ON ERROR GOTO h\n" "z = PEN(3)\n" "END\n" "h: e = ERR: RESUME NEXT\n", &cap, &keys); if (vm) { checkTrue("PEN: down at the press", globalNum(vm, "d1") == -1 && globalNum(vm, "x1") == TEST_PEN_X1 && globalNum(vm, "y1") == TEST_PEN_Y1); checkTrue("PEN: the press's text cell", globalNum(vm, "r1") == 4 && globalNum(vm, "c1") == 13); checkTrue("PEN(0) once per press", globalNum(vm, "p1") == -1 && globalNum(vm, "p2") == 0 && globalNum(vm, "d2") == 0); checkTrue("PEN: where it is now", globalNum(vm, "x2") == TEST_PEN_X2 && globalNum(vm, "y2") == TEST_PEN_Y2 && globalNum(vm, "r2") == 13 && globalNum(vm, "c2") == 38); checkTrue("PEN after PEN OFF is error 5", globalNum(vm, "e") == 5); screenRunFree(vm); } } // DoEvents stub of the screen tests: types the test's keys once. static bool testKeysDoEvents(void *ctx) { TestKeysT *k = (TestKeysT *)ctx; int32_t call = k->calls++; if (call == 0 && k->vm->screen) { for (int32_t i = 0; i < k->count; i++) { basScreenPushKey(k->vm->screen, k->keys[i]); } } if (call < k->mouseCount && k->vm->screen) { basScreenMouse(k->vm->screen, k->mouseX[call], k->mouseY[call], k->mouseDown[call]); } return true; } static void testKeywordApi(void) { printf("=== lexer keyword API ===\n"); int32_t n = basLexerKeywordCount(); bool ok = (n > 0); if (basLexerKeywordAt(-1) != NULL || basLexerKeywordAt(n) != NULL) { ok = false; } if (basLexerKeywordClass(-1) != BAS_KW_CLASS_OTHER || basLexerKeywordClass(n) != BAS_KW_CLASS_OTHER) { ok = false; } int32_t typeCount = 0; int32_t literalCount = 0; for (int32_t i = 0; i < n; i++) { if (basLexerKeywordAt(i) == NULL) { ok = false; } BasKeywordClassE cls = basLexerKeywordClass(i); if (cls == BAS_KW_CLASS_TYPE) { typeCount++; } else if (cls == BAS_KW_CLASS_LITERAL) { literalCount++; } } if (typeCount == 0 || literalCount == 0) { ok = false; } if (ok) { printf("OK (%d keywords)\n\n", (int)n); } else { printf("FAIL: keyword API\n\n"); gFailCount++; } } // Lexer limits needing generated sources: over-long string literal. static void testLexerLimits(void) { char src[TEST_LONG_STRING_SRC]; int32_t len = snprintf(src, sizeof(src), "A$ = \""); for (int32_t i = 0; i < TEST_LONG_STRING_LEN; i++) { src[len++] = 'x'; } snprintf(src + len, sizeof(src) - len, "\"\n"); expectCompileError("Over-long string literal rejected", src, "String literal too long"); } // Missing and skipped Optional arguments, ParamArray arguments by // reference, arrays copied into Variants, LSET of TYPE records and // Format$ without a format. static void testMissingAndValues(void) { runProgram("Optional: IsMissing, skipped arguments, Missing passed on", "SUB F(a AS INTEGER, OPTIONAL b AS VARIANT, OPTIONAL c AS INTEGER, OPTIONAL d AS VARIANT)\n" " PRINT a; IsMissing(b); c; IsMissing(d); VarType(b); TypeName(d);\n" " G b\n" "END SUB\n" "SUB G(OPTIONAL x AS VARIANT)\n" " PRINT \" G\"; IsMissing(x)\n" "END SUB\n" "FUNCTION H(OPTIONAL x AS VARIANT) AS STRING\n" " H = IIF(IsMissing(x), \"none\", \"some\")\n" "END FUNCTION\n" "F 1\n" "F 1, 2\n" "F 1, , 3\n" "F 1, , , \"d\"\n" "F(1, , 3, )\n" "PRINT H(); H(0); IsMissing(5)\n", "1 True 0 True 10 Error GTrue \n" "1 False 0 True 2 Error GFalse \n" "1 True 3 True 10 Error GTrue \n" "1 True 0 False 10 String GTrue \n" "1 True 3 True 10 Error GTrue \n" "nonesomeFalse \n" ); runProgram("Optional: using a Missing argument is error 448", "ON ERROR GOTO h\n" "SUB M(OPTIONAL x AS VARIANT)\n" " PRINT x + 1\n" " PRINT \"[\"; x; \"]\"\n" "END SUB\n" "M\n" "PRINT \"ok\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "err448 \n" "ok\n" ); runProgram("Optional: skipped method arguments, required ones, Missing through Object", "DIM kk AS NEW K\n" "DIM o AS OBJECT\n" "SET o = kk\n" "kk.M 1, , \"z\"\n" "o.M 2, , \"y\"\n" "ON ERROR GOTO h\n" "o.M , 5\n" "PRINT \"end\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "BEGINCLASS \"K\"\n" "Public Sub M(a AS INTEGER, OPTIONAL b AS VARIANT, OPTIONAL c AS STRING)\n" " PRINT a; IsMissing(b); c\n" "End Sub\n" "ENDCLASS\n", "1 True z\n" "2 True y\n" "err449 \n" "end\n" ); expectCompileError("Optional: a skipped argument must be Optional", "SUB S(a AS INTEGER, b AS INTEGER)\n" "END SUB\n" "S , 2\n", "Argument not optional" ); runProgram("ParamArray: variables are passed by reference", "SUB Bump(ParamArray v())\n" " FOR i = 0 TO UBOUND(v)\n" " v(i) = v(i) * 10\n" " NEXT\n" "END SUB\n" "FUNCTION Sum(ParamArray v()) AS INTEGER\n" " DIM t AS INTEGER\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " v(0) = 99\n" " Sum = t\n" "END FUNCTION\n" "SUB ShowArgs(ParamArray v())\n" " PRINT UBOUND(v); IsMissing(v(1))\n" "END SUB\n" "DIM a AS INTEGER, b AS DOUBLE\n" "a = 1\n" "b = 2.5\n" "Bump a, b, 7\n" "PRINT a; b\n" "PRINT Sum(a, b + 1); a\n" "ShowArgs 1, , 3\n", "10 25 \n" "36 99 \n" "2 True \n" ); runProgram("Variants: an array stored in a Variant is a copy", "DIM q(2) AS INTEGER\n" "DIM v AS VARIANT, w AS VARIANT\n" "q(0) = 1\n" "v = q\n" "q(0) = 5\n" "PRINT v(0); q(0)\n" "w = v\n" "w(0) = 7\n" "PRINT v(0); w(0)\n" "SUB Change(BYVAL x AS VARIANT)\n" " x(0) = 9\n" "END SUB\n" "Change q\n" "PRINT q(0)\n" "DIM c AS NEW Collection\n" "c.Add q\n" "q(0) = 6\n" "v = c(1)\n" "PRINT v(0)\n", "1 5 \n" "1 7 \n" "5 \n" "5 \n" ); runProgram("LSET: whole TYPE records, different TYPEs", "TYPE A\n" " n AS INTEGER\n" " s AS STRING * 4\n" "END TYPE\n" "TYPE B\n" " s AS STRING * 6\n" "END TYPE\n" "TYPE C\n" " s AS STRING * 2\n" "END TYPE\n" "DIM x AS A, y AS B, z AS C\n" "x.n = 16706\n" "x.s = \"wxyz\"\n" "LSET y = x\n" "PRINT \"[\"; y.s; \"]\"\n" "y.s = \"12\"\n" "LSET x = y\n" "PRINT x.n; \"[\"; x.s; \"]\"\n" "z.s = \"AB\"\n" "LSET y = z\n" "PRINT \"[\"; y.s; \"]\"\n", "[BAwxyz]\n" "12849 [ ]\n" "[AB ]\n" ); expectCompileError("LSET: a record needs a record", "TYPE A\n" " n AS INTEGER\n" "END TYPE\n" "DIM x AS A\n" "LSET x = \"abc\"\n", "LSET of a TYPE variable needs another TYPE variable" ); runProgram("Format$ without a format", "PRINT Format$(3.5); \"|\"; Format$(1000000); \"|\"; Format(-2); \"|\"; Format$(\"x\"); \"|\"; Format$(#1/2/2020#); \"|\"; Format$(True); \"|\"; Format$(2.5, \"\")\n", "3.5|1000000|-2|x|1/2/2020|True|2.5\n" ); } // Phase 5: Variants, class modules, Collection and FOR EACH. static void testObjectsAndVariants(void) { runProgram("Variant: Empty, VarType and TypeName", "DIM v AS VARIANT\n" "PRINT IsEmpty(v); VarType(v); TypeName(v); \"[\"; v; \"]\"\n" "PRINT v + 1; \"x\" & v & \"y\"; v = 0; v = \"\"\n" "v = 5\n" "PRINT VarType(v); TypeName(v)\n" "v = 2.5\n" "PRINT VarType(v); TypeName(v)\n" "v = \"12.5\"\n" "PRINT VarType(v); TypeName(v)\n" "v = #1/2/2000#\n" "PRINT VarType(v); TypeName(v); IsDate(v)\n" "v = TRUE\n" "PRINT VarType(v); TypeName(v)\n" "PRINT vbEmpty; vbNull; vbInteger; vbString; vbObject; vbVariant; vbArray\n", "True 0 Empty[]\n" "1 xyTrue True \n" "2 Integer\n" "5 Double\n" "8 String\n" "7 DateTrue \n" "11 Boolean\n" "0 1 2 8 9 12 8192 \n" ); runProgram("Variant: IsNumeric, IsObject, IsArray, CVar", "PRINT IsNumeric(\"12.5\"); IsNumeric(\"abc\"); IsNumeric(\" -1e3 \"); IsNumeric(\"&HFF\"); IsNumeric(\"\"); IsNumeric(7); IsNumeric(#1/1/2000#)\n" "DIM o AS OBJECT\n" "PRINT IsObject(o); IsObject(Nothing); IsObject(5); o Is Nothing\n" "DIM a(2) AS INTEGER\n" "DIM v AS VARIANT\n" "v = a\n" "PRINT IsArray(v); IsArray(a); IsArray(5); VarType(v); TypeName(v); UBOUND(v)\n" "DIM w(1) AS VARIANT\n" "PRINT VarType(w); TypeName(w); IsEmpty(w(0))\n" "PRINT CVar(3) + 1; TypeName(CVar(\"s\")); TypeName(Nothing); VarType(Nothing)\n", "True False True True False True False \n" "True True False True \n" "True True False 8194 Integer()2 \n" "8204 Variant()True \n" "4 StringNothing9 \n" ); runProgram("Variant: Null propagates", "DIM v AS VARIANT\n" "v = Null\n" "PRINT IsNull(v); VarType(v); TypeName(v); v\n" "PRINT IsNull(v + 1); IsNull(v * 2); IsNull(-v); IsNull(v = 1); IsNull(v & Null)\n" "PRINT \"a\" & v & \"b\"\n" "PRINT IsNull(v AND TRUE); v AND FALSE; v OR TRUE; IsNull(v OR FALSE); IsNull(NOT v); IsNull(v XOR 1)\n" "IF v THEN PRINT \"yes\" ELSE PRINT \"no\"\n" "PRINT IsNull(ABS(v)); IsNull(INT(v)); IsNull(FIX(v)); IsNull(SGN(v))\n" "PRINT IsNull(Choose(9, 1, 2))\n", "True 1 NullNull\n" "True True True True True \n" "ab\n" "True False True True True True \n" "no\n" "True True True True \n" "True \n" ); runProgram("Variant: Invalid use of Null", "ON ERROR GOTO h\n" "DIM i AS INTEGER\n" "i = Null\n" "PRINT LEN(CSTR(Null))\n" "PRINT Null + 1 > 0\n" "PRINT MID$(Null, 1)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "err94 \n" "err94 \n" "Null\n" "err94 \n" ); runProgram("Class: variables, properties and methods", "DIM p AS Person\n" "PRINT p Is Nothing; TypeName(p)\n" "SET p = NEW Person\n" "p.First = \"Ada\"\n" "p.Age = \"36\"\n" "PRINT p.First; p.Age; VarType(p.Age); p.Describe; \" \"; TypeName(p); VarType(p)\n" "p.Tag(2) = \"two\"\n" "PRINT p.Tag(2); \"|\"; p.Tag(1); \"|\"\n" "SET p.Friend = NEW Person\n" "p.Friend.First = \"Bob\"\n" "PRINT p.Friend.First; p.Friend.Friend Is Nothing\n" "PRINT p.Total(1, 2, 3); p.Total()\n" "SET p = Nothing\n" "PRINT \"end\"\n" "BEGINCLASS \"Person\"\n" "Public First As String\n" "Private mAge As Integer\n" "Private mFriend As Person\n" "Private tags(3) As String\n" "Private Sub Class_Initialize()\n" " PRINT \"[new]\";\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"[bye \"; First; \"]\"\n" "End Sub\n" "Property Get Age() As Integer\n" " Age = mAge\n" "End Property\n" "Property Let Age(v As Integer)\n" " mAge = v\n" "End Property\n" "Property Get Friend() As Person\n" " SET Friend = mFriend\n" "End Property\n" "Property Set Friend(f As Person)\n" " SET mFriend = f\n" "End Property\n" "Property Get Tag(i As Integer) As String\n" " Tag = tags(i)\n" "End Property\n" "Property Let Tag(i As Integer, s As String)\n" " tags(i) = s\n" "End Property\n" "Public Function Describe() As String\n" " Describe = First & \" is \" & Me.Age\n" "End Function\n" "Public Sub AddTo(n As Integer)\n" " n = n + mAge\n" "End Sub\n" "Public Function Total(ParamArray v()) As Integer\n" " DIM t AS INTEGER\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " Total = t + UBOUND(v) + 1\n" "End Function\n" "Private Sub Secret()\n" "End Sub\n" "ENDCLASS\n", "True Nothing\n" "[new]Ada36 2 Ada is 36 Person9 \n" "two||\n" "[new]BobTrue \n" "9 0 \n" "[bye Ada]\n" "[bye Bob]\n" "end\n" ); runProgram("Class: ByRef arguments of a known class's method and late bound (VB: by reference)", "DIM p AS NEW Person\n" "DIM x AS INTEGER\n" "p.Age = 36\n" "x = 1\n" "p.AddTo x\n" "PRINT x\n" "p.AddTo (x)\n" "PRINT x\n" "DIM o AS OBJECT\n" "SET o = p\n" "o.AddTo x\n" "PRINT x\n" "SET o = Nothing\n" "SET p = Nothing\n" "BEGINCLASS \"Person\"\n" "Public First As String\n" "Private mAge As Integer\n" "Private mFriend As Person\n" "Private tags(3) As String\n" "Private Sub Class_Initialize()\n" " PRINT \"[new]\";\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"[bye \"; First; \"]\"\n" "End Sub\n" "Property Get Age() As Integer\n" " Age = mAge\n" "End Property\n" "Property Let Age(v As Integer)\n" " mAge = v\n" "End Property\n" "Property Get Friend() As Person\n" " SET Friend = mFriend\n" "End Property\n" "Property Set Friend(f As Person)\n" " SET mFriend = f\n" "End Property\n" "Property Get Tag(i As Integer) As String\n" " Tag = tags(i)\n" "End Property\n" "Property Let Tag(i As Integer, s As String)\n" " tags(i) = s\n" "End Property\n" "Public Function Describe() As String\n" " Describe = First & \" is \" & Me.Age\n" "End Function\n" "Public Sub AddTo(n As Integer)\n" " n = n + mAge\n" "End Sub\n" "Public Function Total(ParamArray v()) As Integer\n" " DIM t AS INTEGER\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " Total = t + UBOUND(v) + 1\n" "End Function\n" "Private Sub Secret()\n" "End Sub\n" "ENDCLASS\n", "[new]37 \n" "37 \n" "73 \n" "[bye ]\n" ); runProgram("Class: references, Is and Class_Terminate", "DIM p AS Person\n" "DIM q AS Person\n" "SET p = NEW Person\n" "p.First = \"Ada\"\n" "SET p.Friend = NEW Person\n" "p.Friend.First = \"Bob\"\n" "SET q = p\n" "PRINT q Is p; q Is p.Friend; p Is Nothing\n" "SET p = Nothing\n" "PRINT \"p cleared\"\n" "SET q = Nothing\n" "PRINT \"q cleared\"\n" "Scoped\n" "PRINT \"after Scoped\"\n" "SUB Scoped\n" " DIM t AS NEW Person\n" " t.First = \"Tmp\"\n" "END SUB\n" "BEGINCLASS \"Person\"\n" "Public First As String\n" "Private mAge As Integer\n" "Private mFriend As Person\n" "Private tags(3) As String\n" "Private Sub Class_Initialize()\n" " PRINT \"[new]\";\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"[bye \"; First; \"]\"\n" "End Sub\n" "Property Get Age() As Integer\n" " Age = mAge\n" "End Property\n" "Property Let Age(v As Integer)\n" " mAge = v\n" "End Property\n" "Property Get Friend() As Person\n" " SET Friend = mFriend\n" "End Property\n" "Property Set Friend(f As Person)\n" " SET mFriend = f\n" "End Property\n" "Property Get Tag(i As Integer) As String\n" " Tag = tags(i)\n" "End Property\n" "Property Let Tag(i As Integer, s As String)\n" " tags(i) = s\n" "End Property\n" "Public Function Describe() As String\n" " Describe = First & \" is \" & Me.Age\n" "End Function\n" "Public Sub AddTo(n As Integer)\n" " n = n + mAge\n" "End Sub\n" "Public Function Total(ParamArray v()) As Integer\n" " DIM t AS INTEGER\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " Total = t + UBOUND(v) + 1\n" "End Function\n" "Private Sub Secret()\n" "End Sub\n" "ENDCLASS\n", "[new][new]True False False \n" "p cleared\n" "[bye Ada]\n" "[bye Bob]\n" "q cleared\n" "[new][bye Tmp]\n" "after Scoped\n" ); runProgram("Class: member errors (late bound: run time)", "ON ERROR GOTO h\n" "DIM r AS Person\n" "DIM o AS OBJECT\n" "SET r = NEW Person\n" "SET o = r\n" "o.Missing = 1\n" "o.Secret\n" "PRINT o.Age(1)\n" "SET r = NEW Collection\n" "SET r = 5\n" "o.Total\n" "PRINT \"end\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "BEGINCLASS \"Person\"\n" "Public First As String\n" "Private mAge As Integer\n" "Private mFriend As Person\n" "Private tags(3) As String\n" "Private Sub Class_Initialize()\n" " PRINT \"[new]\";\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"[bye \"; First; \"]\"\n" "End Sub\n" "Property Get Age() As Integer\n" " Age = mAge\n" "End Property\n" "Property Let Age(v As Integer)\n" " mAge = v\n" "End Property\n" "Property Get Friend() As Person\n" " SET Friend = mFriend\n" "End Property\n" "Property Set Friend(f As Person)\n" " SET mFriend = f\n" "End Property\n" "Property Get Tag(i As Integer) As String\n" " Tag = tags(i)\n" "End Property\n" "Property Let Tag(i As Integer, s As String)\n" " tags(i) = s\n" "End Property\n" "Public Function Describe() As String\n" " Describe = First & \" is \" & Me.Age\n" "End Function\n" "Public Sub AddTo(n As Integer)\n" " n = n + mAge\n" "End Sub\n" "Public Function Total(ParamArray v()) As Integer\n" " DIM t AS INTEGER\n" " FOR EACH e IN v\n" " t = t + e\n" " NEXT\n" " Total = t + UBOUND(v) + 1\n" "End Function\n" "Private Sub Secret()\n" "End Sub\n" "ENDCLASS\n", "[new]err438 \n" "err438 \n" "err450 \n" "err13 \n" "err424 \n" "end\n" ); runProgram("Class: a reference cycle is collected at the end of the program", "DIM a AS Node, b AS Node\n" "SET a = NEW Node\n" "SET b = NEW Node\n" "a.Id = 1\n" "b.Id = 2\n" "SET a.NextNode = b\n" "SET b.NextNode = a\n" "SET a = Nothing\n" "SET b = Nothing\n" "PRINT \"cycle dropped\"\n" "BEGINCLASS \"Node\"\n" "Public Id As Integer\n" "Public NextNode As Node\n" "Private Sub Class_Terminate()\n" " PRINT \"[term\"; Id; \"]\"\n" "End Sub\n" "ENDCLASS\n", "cycle dropped\n" "[term1 ]\n" "[term2 ]\n" ); runProgram("Collection: Add, Item, Remove, Count and keys", "DIM c AS NEW Collection\n" "FOR i = 1 TO 3\n" " DIM n AS Node\n" " SET n = NEW Node\n" " n.Id = i * 10\n" " c.Add n, \"k\" & i\n" "NEXT\n" "SET n = Nothing\n" "c.Add \"first\", , 1\n" "c.Add \"last\", , , c.Count\n" "c.Add \"mid\", \"m\", \"k2\"\n" "FOR EACH it IN c\n" " IF IsObject(it) THEN PRINT it.Id; ELSE PRINT it; \" \";\n" "NEXT\n" "PRINT\n" "PRINT c(\"K2\").Id; c(2).Id; c.Item(\"m\"); TypeName(c); VarType(c)\n" "c.Remove 1\n" "c.Remove \"k3\"\n" "PRINT c.Count\n" "ON ERROR GOTO h\n" "c.Add 1, \"m\"\n" "PRINT c(99)\n" "PRINT c(\"nope\")\n" "c.Add 1, 5\n" "c.Add 1, , 1, 2\n" "c(1) = 5\n" "PRINT \"end\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "BEGINCLASS \"Node\"\n" "Public Id As Integer\n" "Public NextNode As Node\n" "Private Sub Class_Terminate()\n" " PRINT \"[term\"; Id; \"]\"\n" "End Sub\n" "ENDCLASS\n", "first 10 mid 20 30 last \n" "20 10 midCollection9 \n" "[term30 ]\n" "4 \n" "err457 \n" "err9 \n" "err5 \n" "err13 \n" "err5 \n" "err438 \n" "end\n" ); runProgram("For Each over arrays, Variants, ParamArrays and Collections", "DIM a(3) AS INTEGER\n" "FOR i = 0 TO 3\n" " a(i) = i * i\n" "NEXT\n" "FOR EACH x IN a\n" " PRINT x;\n" "NEXT\n" "PRINT\n" "DIM tot AS INTEGER\n" "FOR EACH k IN Array3()\n" " tot = tot + k\n" " IF tot > 3 THEN EXIT FOR\n" "NEXT\n" "PRINT tot\n" "FOR EACH ch IN Split(\"a,b,c\", \",\")\n" " FOR EACH d IN Split(\"1,2\", \",\")\n" " PRINT ch; d; \" \";\n" " NEXT d\n" "NEXT ch\n" "PRINT\n" "DIM e AS NEW Collection\n" "FOR EACH z IN e\n" " PRINT \"never\"\n" "NEXT\n" "e.Add 1\n" "e.Add 2\n" "e.Add 3\n" "FOR EACH z IN e\n" " PRINT z;\n" " e.Remove 1\n" "NEXT\n" "PRINT e.Count\n" "ShowArgs 1, \"two\", 3.5\n" "ON ERROR GOTO h\n" "FOR EACH z IN 5\n" "NEXT\n" "PRINT \"end\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "FUNCTION Array3() AS VARIANT\n" " DIM t(2) AS INTEGER\n" " t(0) = 1\n" " t(1) = 2\n" " t(2) = 3\n" " Array3 = t\n" "END FUNCTION\n" "SUB ShowArgs(ParamArray args())\n" " PRINT VarType(args); TypeName(args);\n" " FOR EACH v IN args\n" " PRINT \" \"; TypeName(v);\n" " NEXT\n" " PRINT\n" "END SUB\n", "0 1 4 9 \n" "6 \n" "a1 a2 b1 b2 c1 c2 \n" "1 3 1 \n" "8204 Variant() Integer String Double\n" "err13 \n" "end\n" ); runProgram("Objects in arrays and TYPE fields", "DIM arr(2) AS Node\n" "SET arr(1) = NEW Node\n" "arr(1).Id = 77\n" "PRINT arr(1).Id; arr(0) Is Nothing; TypeName(arr)\n" "TYPE Holder\n" " obj AS Node\n" " v AS VARIANT\n" "END TYPE\n" "DIM hd AS Holder\n" "PRINT hd.obj Is Nothing; IsEmpty(hd.v)\n" "SET hd.obj = arr(1)\n" "hd.v = \"var\"\n" "hd.obj.Id = 78\n" "PRINT hd.obj.Id; arr(1).Id; hd.v\n" "SET arr(1) = Nothing\n" "SET hd.obj = Nothing\n" "PRINT \"gone\"\n" "BEGINCLASS \"Node\"\n" "Public Id As Integer\n" "Public NextNode As Node\n" "Private Sub Class_Terminate()\n" " PRINT \"[term\"; Id; \"]\"\n" "End Sub\n" "ENDCLASS\n", "77 True Object()\n" "True True \n" "78 78 var\n" "[term78 ]\n" "gone\n" ); runProgram("Class: default member, Me and its own procedures", "DIM l AS NEW List\n" "l.Add \"a\"\n" "l.Add \"b\"\n" "PRINT l(1); l.Item(2); l.Count; TypeOf l Is List; TypeOf l Is Object; TypeOf l Is Collection\n" "l(1) = \"z\"\n" "PRINT l(1); l.Self Is l; l.Self.Self.Count\n" "PRINT l.Joined(\", \")\n" "BEGINCLASS \"List\"\n" "Private items As New Collection\n" "Private sep As String\n" "Property Get Item(i As Integer) As Variant\n" "Attribute Item.VB_UserMemId = 0\n" " Item = items(i)\n" "End Property\n" "Property Let Item(i As Integer, v As Variant)\n" " items.Add v, , i\n" " items.Remove i + 1\n" "End Property\n" "Public Sub Add(v As Variant)\n" " items.Add v\n" "End Sub\n" "Public Function Count() As Long\n" " Count = items.Count\n" "End Function\n" "Public Function Self() As List\n" " SET Self = Me\n" "End Function\n" "Public Function Joined(s As String) As String\n" " sep = s\n" " Joined = JoinFrom(1)\n" "End Function\n" "Private Function JoinFrom(i As Integer) As String\n" " DIM r AS STRING\n" " IF i > Count THEN EXIT FUNCTION\n" " r = Item(i)\n" " IF i < Count THEN r = r & sep & JoinFrom(i + 1)\n" " JoinFrom = r\n" "End Function\n" "ENDCLASS\n", "ab2 True True False \n" "zTrue 2 \n" "z, b\n" ); runProgram("Class: member variables start typed; Class_Initialize runs after them", "DIM t AS NEW Typed\n" "t.Report\n" "DIM o AS OBJECT\n" "SET o = t\n" "o.Opt\n" "o.Opt 5\n" "o.Opt , \"x\"\n" "BEGINCLASS \"Typed\"\n" "Private i As Integer\n" "Private d As Double\n" "Private s As String\n" "Private v As Variant\n" "Private b As Boolean\n" "Private obj As Object\n" "Private Sub Class_Initialize()\n" " PRINT \"init\"; i; d; \"[\"; s; \"]\"; IsEmpty(v); b; obj Is Nothing\n" " i = 7\n" "End Sub\n" "Public Sub Report()\n" " PRINT \"i =\"; i\n" "End Sub\n" "Public Sub Opt(Optional a As Integer, Optional t As String)\n" " PRINT \"opt\"; a; \"[\"; t; \"]\"\n" "End Sub\n" "ENDCLASS\n", "init0 0 []True False True \n" "i =7 \n" "opt0 []\n" "opt5 []\n" "opt0 [x]\n" ); runProgram("PUBLIC and PRIVATE at module level", "PUBLIC shared1 AS INTEGER\n" "PRIVATE own1 AS INTEGER\n" "shared1 = 5\n" "own1 = 6\n" "Report\n" "PRIVATE SUB Report\n" " PRINT shared1\n" "END SUB\n", "5 \n" ); runProgram("Class: Terminate of a result released inside an expression", "PRINT Make(3).Id + 1\n" "PRINT \"after\"\n" "FUNCTION Make(n AS INTEGER) AS Node\n" " SET Make = NEW Node\n" " Make.Id = n\n" "END FUNCTION\n" "BEGINCLASS \"Node\"\n" "Public Id As Integer\n" "Public NextNode As Node\n" "Private Sub Class_Terminate()\n" " PRINT \"[term\"; Id; \"]\"\n" "End Sub\n" "ENDCLASS\n", "[term3 ]\n" "4 \n" "after\n" ); expectCompileError("Code outside procedures in a class rejected", "BEGINCLASS \"C\"\n" "PRINT 1\n" "ENDCLASS\n", "Only declarations are allowed outside procedures in a class module" ); expectCompileError("Duplicate class member rejected", "BEGINCLASS \"C\"\n" "PUBLIC x AS INTEGER\n" "PUBLIC SUB x\n" "END SUB\n" "ENDCLASS\n", "'x' already declared" ); expectCompileError("NEW of a non-class rejected", "x = NEW Foo\n", "class name, form name, or Collection after New" ); // New FormName: a copy of a form of the project (headless, the // missing form runtime raises error 1000 where the copy is made) runProgram("NEW and AS NEW of a form name", "BEGINFORM \"Form1\"\n" "ENDFORM\n" "DIM f AS Form1\n" "ON ERROR RESUME NEXT\n" "SET f = NEW Form1\n" "PRINT ERR\n" "ERR.CLEAR\n" "MakeCopy\n" "PRINT ERR\n" "SUB MakeCopy\n" " ON ERROR RESUME NEXT\n" " DIM g AS NEW Form1\n" " PRINT ERR;\n" "END SUB\n", "1000 \n1000 0 \n" ); expectCompileError("AS NEW of a form name in an array rejected", "BEGINFORM \"Form1\"\n" "ENDFORM\n" "DIM f(2) AS NEW Form1\n", "New cannot be used with an array" ); expectCompileError("AS NEW needs a class", "DIM x AS NEW INTEGER\n", "New needs a class name" ); expectCompileError("AS NEW array rejected", "DIM x(3) AS NEW Collection\n", "New cannot be used with an array" ); expectCompileError("EXIT PROPERTY outside PROPERTY rejected", "SUB S\n" "EXIT PROPERTY\n" "END SUB\n", "EXIT PROPERTY outside PROPERTY" ); expectCompileError("BEGINCLASS without ENDCLASS rejected", "BEGINCLASS \"C\"\n" "SUB S\n" "END SUB\n", "BEGINCLASS without ENDCLASS" ); expectCompileError("Class_Initialize with parameters rejected", "BEGINCLASS \"C\"\n" "SUB Class_Initialize(a)\n" "END SUB\n" "ENDCLASS\n", "Class_Initialize must be a Sub without parameters" ); expectCompileError("SHARED in a class rejected", "BEGINCLASS \"C\"\n" "SUB S\n" "SHARED q\n" "END SUB\n" "ENDCLASS\n", "SHARED is not allowed in a class module" ); expectCompileError("DIM SHARED in a class rejected", "BEGINCLASS \"C\"\n" "DIM SHARED q\n" "ENDCLASS\n", "DIM SHARED is not allowed in a class module" ); expectCompileError("Property Let without a value parameter rejected", "BEGINCLASS \"C\"\n" "PROPERTY LET P()\n" "END PROPERTY\n" "ENDCLASS\n", "Property Let and Property Set take the value" ); expectCompileError("Class defined twice rejected", "BEGINCLASS \"C\"\n" "ENDCLASS\n" "BEGINCLASS \"C\"\n" "ENDCLASS\n", "cannot be used as a class name" ); runProgram("Class: members named by reserved words", "DIM f AS NEW Doc\n" "f.Name = \"x\"\n" "f.Open\n" "PRINT f.Name; f.IsOpen; f.Close\n" "BEGINCLASS \"Doc\"\n" "Private mName As String\n" "Public IsOpen As Boolean\n" "Property Get Name() As String\n" " Name = \"<\" & mName & \">\"\n" "End Property\n" "Property Let Name(s As String)\n" " mName = s\n" "End Property\n" "Public Sub Open()\n" " IsOpen = True\n" "End Sub\n" "Public Function Close() As Boolean\n" " Close = IsOpen\n" " IsOpen = False\n" "End Function\n" "ENDCLASS\n", "True True \n" ); runProgram("Class: STATIC variables are per class (shared by its instances)", "DIM a AS NEW A1\n" "DIM b AS NEW B1\n" "a.Tick\n" "a.Tick\n" "b.Tick\n" "Tick\n" "BEGINCLASS \"A1\"\n" "Public Sub Tick()\n" " STATIC n AS INTEGER\n" " n = n + 1\n" " PRINT \"A\"; n\n" "End Sub\n" "ENDCLASS\n" "BEGINCLASS \"B1\"\n" "Public Sub Tick()\n" " STATIC n AS INTEGER\n" " n = n + 10\n" " PRINT \"B\"; n\n" "End Sub\n" "ENDCLASS\n" "SUB Tick\n" " STATIC n AS INTEGER\n" " n = n + 100\n" " PRINT \"M\"; n\n" "END SUB\n", "A1 \nA2 \nB10 \nM100 \n" ); } // ParamArray arguments by reference (variables, elements, fields, // members; procedures, class methods and late-bound calls) and the array // locks they take. static void testParamArrayByRef(void) { runProgram("ParamArray ByRef: array elements, TYPE fields, indexes evaluated once", "TYPE Inner\n" " q AS INTEGER\n" "END TYPE\n" "TYPE Rec\n" " f AS INTEGER\n" " s AS STRING * 4\n" " inn AS Inner\n" "END TYPE\n" "DIM SHARED calls AS INTEGER\n" "DIM a(5) AS INTEGER\n" "DIM m(2, 2) AS LONG\n" "DIM r AS Rec\n" "DIM rs(3) AS Rec\n" "a(2) = 1: m(1, 2) = 2: r.f = 3: rs(1).f = 4: r.inn.q = 5: r.s = \"ab\"\n" "Bump a(2), m(1, 2), r.f, rs(1).f, r.inn.q, a(Idx()), r.s\n" "PRINT a(2); m(1, 2); r.f; rs(1).f; r.inn.q; a(3); calls; \"[\"; r.s; \"]\"\n" "PRINT Total(a(2), a(2) + 1, (a(2)))\n" "PRINT a(2)\n" "FUNCTION Idx() AS INTEGER\n" " calls = calls + 1\n" " Idx = 3\n" "END FUNCTION\n" "SUB Bump(ParamArray v())\n" " FOR i = 0 TO UBOUND(v) - 1\n" " v(i) = v(i) * 10 + 7\n" " NEXT\n" " v(UBOUND(v)) = \"xyzzy\"\n" "END SUB\n" "FUNCTION Total(ParamArray v()) AS INTEGER\n" " Total = v(0) + v(1) + v(2)\n" " v(0) = 0: v(1) = 0: v(2) = 0\n" "END FUNCTION\n", "17 27 37 47 57 7 1 [xyzz]\n" "52 \n" "0 \n" ); runProgram("ParamArray / ByRef: REDIM or ERASE of an array whose element is given raises error 10", "DIM SHARED d() AS INTEGER\n" "REDIM d(4)\n" "d(1) = 1: d(4) = 4\n" "ON ERROR GOTO h\n" "Shrink d(1), d(4)\n" "PRINT UBOUND(d); d(1); d(4)\n" "Gone d(1)\n" "PRINT UBOUND(d); d(1)\n" "REDIM d(2)\n" "d(0) = 5: d(2) = 6\n" "Cut d(0), d(2)\n" "PRINT d(0); d(2)\n" "Plain d(0)\n" "PRINT d(0); UBOUND(d)\n" "REDIM d(3)\n" "PRINT UBOUND(d)\n" "Fine d(1)\n" "PRINT UBOUND(d)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "SUB Shrink(ParamArray v())\n" " v(0) = 10: v(1) = 40\n" " REDIM PRESERVE d(2)\n" " PRINT \"not here\"\n" "END SUB\n" "SUB Gone(ParamArray v())\n" " ERASE d\n" "END SUB\n" "SUB Cut(ParamArray v())\n" " v(0) = 50: v(1) = 60\n" " REDIM v(0)\n" " v(0) = 70\n" "END SUB\n" "SUB Plain(x AS INTEGER)\n" " x = 9\n" " REDIM d(1)\n" "END SUB\n" "SUB Fine(x AS INTEGER)\n" " DIM e() AS INTEGER\n" " REDIM e(2)\n" " ERASE e\n" " x = 1\n" "END SUB\n", "err10 \n" "4 10 40 \n" "err10 \n" "4 10 \n" "50 60 \n" "err10 \n" "9 2 \n" "3 \n" "3 \n" ); runProgram("ParamArray ByRef: member variables in a class, known class and late-bound calls", "DIM k AS NEW Keeper\n" "DIM x AS INTEGER\n" "DIM y AS STRING\n" "DIM arr(3) AS INTEGER\n" "x = 1: y = \"a\": arr(1) = 2\n" "k.Twice x, y, arr(1), x + 1\n" "PRINT x; y; arr(1)\n" "DIM o AS Object\n" "SET o = k\n" "o.Twice x, arr(1)\n" "PRINT x; arr(1)\n" "DIM v AS Variant\n" "SET v = k\n" "v.Twice x\n" "PRINT x\n" "o.Keep x\n" "PRINT x\n" "PRINT o.Sum(x, arr(1)); x; arr(1)\n" "k.Self\n" "BEGINCLASS \"Keeper\"\n" "Private cnt AS INTEGER\n" "Private vals(2) AS INTEGER\n" "Public Sub Twice(ParamArray v())\n" " FOR i = 0 TO UBOUND(v)\n" " v(i) = v(i) + v(i)\n" " NEXT\n" "End Sub\n" "Public Sub Keep(ByVal n AS INTEGER)\n" " n = 999\n" "End Sub\n" "Public Function Sum(ParamArray v()) AS INTEGER\n" " Sum = v(0) + v(1)\n" " v(0) = -1\n" "End Function\n" "Public Sub Self()\n" " cnt = 3: vals(1) = 4\n" " Twice cnt, vals(1)\n" " PRINT cnt; vals(1)\n" " Me.Twice cnt\n" " PRINT cnt\n" "End Sub\n" "ENDCLASS\n", "2 aa4 \n" "4 8 \n" "8 \n" "8 \n" "16 -1 8 \n" "6 8 \n" "12 \n" ); runProgram("ParamArray ByRef: late bound, REDIM of a given element's array raises error 10, writes made before an error stay", "DIM SHARED d() AS INTEGER\n" "REDIM d(3)\n" "d(3) = 3\n" "DIM o AS Object\n" "SET o = NEW Cutter\n" "ON ERROR GOTO h\n" "o.CutIt d(3), d(0)\n" "PRINT UBOUND(d); d(0)\n" "DIM z AS INTEGER\n" "z = 5\n" "Fail z\n" "PRINT z; ERR\n" "o.FailIt z\n" "PRINT z; ERR\n" "o.Solo d(2)\n" "PRINT UBOUND(d); d(2)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "SUB Fail(ParamArray v())\n" " v(0) = 50\n" " ERROR 5\n" "END SUB\n" "BEGINCLASS \"Cutter\"\n" "Public Sub CutIt(ParamArray v())\n" " v(0) = 30: v(1) = 7\n" " REDIM PRESERVE d(1)\n" "End Sub\n" "Public Sub FailIt(ParamArray v())\n" " v(0) = 60\n" " ERROR 6\n" "End Sub\n" "Public Sub Solo(x)\n" " x = 8\n" " ERASE d\n" "End Sub\n" "ENDCLASS\n", "err10 \n" "3 7 \n" "err5 \n" "50 0 \n" "err6 \n" "60 0 \n" "err10 \n" "3 8 \n" ); runProgram("Method calls: references convert to the caller's variable type (writes, also through the ParamArray)", "DIM n AS INTEGER\n" "DIM a(3) AS INTEGER\n" "DIM v AS VARIANT\n" "DIM o AS Object\n" "DIM k AS Cls\n" "SET k = NEW Cls\n" "SET o = k\n" "n = 1\n" "o.M n\n" "PRINT n; TypeName(n)\n" "o.P n, a(2)\n" "PRINT n; a(2); TypeName(n); TypeName(a(2))\n" "v = 1\n" "o.P v, v\n" "PRINT v; TypeName(v)\n" "k.M n\n" "PRINT n; TypeName(n)\n" "k.T n\n" "PRINT n\n" "k.P a(1), n\n" "PRINT a(1); n\n" "ON ERROR GOTO h\n" "o.Big n\n" "PRINT n\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "BEGINCLASS \"Cls\"\n" "Public Sub M(x)\n" " x = x + 2.5\n" "End Sub\n" "Public Sub T(x AS INTEGER)\n" " x = x * 2\n" "End Sub\n" "Public Sub P(ParamArray v())\n" " v(0) = 7.25\n" " v(1) = \"9\"\n" "End Sub\n" "Public Sub Big(ParamArray v())\n" " v(0) = 100000\n" "End Sub\n" "ENDCLASS\n", "4 Integer\n" "7 9 IntegerInteger\n" "9String\n" "10 Integer\n" "20 \n" "7 9 \n" "err6 \n" "9 \n" ); runProgram("Method calls: TYPE fields go by reference (converted; ByVal and host methods unchanged)", "TYPE Pt\n" " x AS INTEGER\n" " s AS STRING\n" "END TYPE\n" "DIM r AS Pt\n" "DIM pts(2) AS Pt\n" "DIM o AS Object\n" "DIM k AS Cls\n" "SET k = NEW Cls\n" "SET o = k\n" "r.x = 5\n" "o.M r.x\n" "PRINT r.x\n" "k.M r.x\n" "PRINT r.x\n" "r.s = \"a\"\n" "o.S r.s\n" "PRINT r.s\n" "pts(1).x = 3\n" "o.M pts(1).x\n" "PRINT pts(1).x\n" "k.V r.x\n" "PRINT r.x\n" "PRINT o.F(r.x); r.x\n" "k.Inner\n" "BEGINCLASS \"Cls\"\n" "Private q AS Pt\n" "Public Sub M(x)\n" " x = x + 2.5\n" "End Sub\n" "Public Sub S(t AS STRING)\n" " t = t + \"!\"\n" "End Sub\n" "Public Sub V(ByVal x AS INTEGER)\n" " x = 99\n" "End Sub\n" "Public Function F(x) AS INTEGER\n" " x = 1\n" " F = 2\n" "End Function\n" "Public Sub Inner()\n" " DIM other AS Object\n" " SET other = NEW Cls\n" " q.x = 1\n" " other.M q.x\n" " Me.M q.x\n" " PRINT q.x\n" "End Sub\n" "ENDCLASS\n", "8 \n" "10 \n" "a!\n" "6 \n" "10 \n" "2 1 \n" "6 \n" ); } static void testParamDefaults(void) { runProgram("Optional defaults: SUB / FUNCTION, skipped and trailing, forward calls, IsMissing", "CONST SIDE = 10\n" "PRINT Area(); Area(2); Area(, 3); Area(2, 3)\n" "Greet\n" "Greet \"Bob\"\n" "Greet , \"?\"\n" "ShowIt\n" "ShowIt 7\n" "PRINT Scale#(2); Stamp(); Pick$()\n" "FUNCTION Area(OPTIONAL w AS INTEGER = SIDE, OPTIONAL h AS INTEGER = SIDE * 2) AS LONG\n" " Area = w * h\n" "END FUNCTION\n" "SUB Greet(OPTIONAL who AS STRING = \"World\", OPTIONAL mark$ = \"!\")\n" " PRINT \"Hello \" + who + mark$\n" "END SUB\n" "SUB ShowIt(OPTIONAL v AS VARIANT = \"dflt\", OPTIONAL n AS VARIANT)\n" " PRINT v; IsMissing(v); IsMissing(n); TypeName(v)\n" "END SUB\n" "FUNCTION Scale#(x AS DOUBLE, OPTIONAL f AS DOUBLE = 1 / 4)\n" " Scale# = x * f\n" "END FUNCTION\n" "FUNCTION Stamp(OPTIONAL d AS DATE = #2000-01-02#) AS INTEGER\n" " Stamp = Day(d)\n" "END FUNCTION\n" "FUNCTION Pick$(OPTIONAL c AS STRING = CHR$(65) + \"B\")\n" " Pick$ = c\n" "END FUNCTION\n", "200 40 30 6 \n" "Hello World!\n" "Hello Bob!\n" "Hello World?\n" "dfltFalse True String\n" "7 False True Integer\n" "0.5 2 AB\n" ); runProgram("Optional defaults: typed conversion, ByRef parameter, DECLARE, recursion", "DECLARE SUB Bump(OPTIONAL n AS INTEGER = 3)\n" "DIM k AS INTEGER\n" "k = 1\n" "Bump k\n" "PRINT k\n" "Bump\n" "PRINT Fact(); Rnd1()\n" "SUB Bump(OPTIONAL n AS INTEGER = 3)\n" " n = n + 1\n" " PRINT \"n=\"; n\n" "END SUB\n" "FUNCTION Fact(OPTIONAL n AS LONG = 5) AS LONG\n" " IF n <= 1 THEN Fact = 1 ELSE Fact = n * Fact(n - 1)\n" "END FUNCTION\n" "FUNCTION Rnd1(OPTIONAL x AS INTEGER = 2.5) AS INTEGER\n" " Rnd1 = x\n" "END FUNCTION\n", "n=2 \n" "2 \n" "n=4 \n" "120 2 \n" ); runProgram("Optional defaults: class methods, Property procedures, late-bound calls", "DIM s AS Shape\n" "SET s = NEW Shape\n" "s.Move\n" "s.Move 5\n" "s.Move , 7\n" "DIM o AS Object\n" "SET o = s\n" "o.Move\n" "o.Move , 9\n" "PRINT s.Label; s.Label(\"x\"); o.Label()\n" "s.Tag = \"t\"\n" "PRINT s.Tag\n" "PRINT s.Tag(\"k\")\n" "s.Twice\n" "BEGINCLASS \"Shape\"\n" "CONST STEPSIZE = 2\n" "Private t AS STRING\n" "Public Sub Move(Optional dx AS INTEGER = STEPSIZE, Optional dy AS SINGLE = -1)\n" " PRINT \"move\"; dx; dy\n" "End Sub\n" "Public Function Label(Optional pre AS STRING = \"L\") AS STRING\n" " Label = pre + \":\"\n" "End Function\n" "Public Property Get Tag(Optional key AS STRING = \"none\") AS STRING\n" " Tag = key + \"=\" + t\n" "End Property\n" "Public Property Let Tag(v AS STRING)\n" " t = v\n" "End Property\n" "Public Sub Twice()\n" " Move\n" " Move 1\n" "End Sub\n" "ENDCLASS\n", "move2 -1 \n" "move5 -1 \n" "move2 7 \n" "move2 -1 \n" "move2 9 \n" "L:x:L:\n" "none=t\n" "k=t\n" "move2 -1 \n" "move1 -1 \n" ); expectCompileError("Optional defaults: only Optional parameters", "SUB F(a AS INTEGER = 1)\nEND SUB\n", "Only an Optional parameter"); expectCompileError("Optional defaults: constant expression required", "DIM v AS INTEGER\nSUB F(OPTIONAL a AS INTEGER = v)\nEND SUB\n", "Constant expression required"); expectCompileError("Optional defaults: type mismatch", "SUB F(OPTIONAL a AS INTEGER = \"x\")\nEND SUB\n", "Type mismatch in Optional default value"); expectCompileError("Optional defaults: overflow", "SUB F(OPTIONAL a AS INTEGER = 40000)\nEND SUB\n", "Overflow in Optional default value"); expectCompileError("Optional defaults: an object parameter's default is Nothing", "SUB F(OPTIONAL a AS OBJECT = 0)\nEND SUB\n", "can only be Nothing"); expectCompileError("Optional defaults: Nothing is not a number's default", "SUB F(OPTIONAL a AS INTEGER = Nothing)\nEND SUB\n", "Constant expression required"); runProgram("Optional defaults: = Nothing on Object, class and Variant parameters", "DIM s AS Shape\n" "SET s = NEW Shape\n" "Peek\n" "Peek s\n" "Kind\n" "Kind , 3\n" "PRINT Twin() IS Nothing\n" "s.Pair\n" "DIM o AS Object\n" "SET o = s\n" "o.Pair s\n" "SUB Peek(OPTIONAL x AS Object = Nothing)\n" " PRINT x IS Nothing\n" "END SUB\n" "SUB Kind(OPTIONAL v AS VARIANT = Nothing, OPTIONAL n AS INTEGER = 1)\n" " PRINT TypeName(v); IsMissing(v); IsObject(v); n\n" "END SUB\n" "FUNCTION Twin(OPTIONAL c AS Shape = Nothing) AS Shape\n" " SET Twin = c\n" "END FUNCTION\n" "BEGINCLASS \"Shape\"\n" "Public Sub Pair(Optional other AS Shape = Nothing)\n" " PRINT \"pair\"; other IS Nothing\n" "End Sub\n" "ENDCLASS\n", "True \n" "False \n" "NothingFalse True 1 \n" "NothingFalse True 3 \n" "True \n" "pairTrue \n" "pairFalse \n" ); expectCompileError("Optional defaults: not on an array parameter", "SUB F(OPTIONAL a() AS INTEGER = 0)\nEND SUB\n", "Only an Optional parameter"); expectCompileError("Optional defaults: not in DEF FN", "DEF FNa(OPTIONAL x = 1) = x\n", "not allowed here"); expectCompileError("Optional defaults: not in DECLARE LIBRARY", "DECLARE LIBRARY \"basrt\"\nDECLARE FUNCTION Foo(OPTIONAL x AS INTEGER = 1) AS INTEGER\nEND DECLARE\n", "not allowed here"); expectCompileError("Optional defaults: DECLARE must match the definition", "DECLARE SUB F(OPTIONAL a AS INTEGER)\nSUB F(OPTIONAL a AS INTEGER = 2)\nEND SUB\n", "does not match"); } // One reference value (redesign Phase 1): every kind of target a ByRef // argument can name -- variables, array elements, TYPE fields (nested, // in array elements, fixed length), class member variables, elements of // an array a Variant holds, ParamArray elements passed on -- and the // safety rules: array locks (error 10), records and objects kept alive by // the references to them, no reference escaping its frame. static void testReferences(void) { runProgram("References: TYPE fields ByRef to a SUB (variable, array element, nested, fixed length)", "TYPE Inner\n" " q AS INTEGER\n" "END TYPE\n" "TYPE Rec\n" " f AS LONG\n" " s AS STRING * 4\n" " inn AS Inner\n" "END TYPE\n" "DIM r AS Rec\n" "DIM rs(3) AS Rec\n" "DIM fx AS STRING * 3\n" "r.f = 1: rs(2).f = 2: r.inn.q = 3: rs(1).inn.q = 4: r.s = \"ab\": fx = \"z\"\n" "Bump r.f\n" "Bump rs(2).f\n" "Twice r.inn.q\n" "Twice rs(1).inn.q\n" "Grow r.s\n" "Grow rs(3).s\n" "Grow fx\n" "PRINT r.f; rs(2).f; r.inn.q; rs(1).inn.q; \"[\"; r.s; \"][\"; rs(3).s; \"][\"; fx; \"]\"\n" "SUB Bump(n AS LONG)\n" " n = n + 10\n" "END SUB\n" "SUB Twice(n AS INTEGER)\n" " n = n * 2\n" "END SUB\n" "SUB Grow(t AS STRING)\n" " t = t + \"xyz\"\n" " PRINT \"[\"; t; \"]\"\n" "END SUB\n", "[ab ]\n" "[ ]\n" "[z ]\n" "11 12 6 8 [ab ][ ][z ]\n" ); runProgram("References: a ByRef parameter is the variable (aliasing seen at once, as VB)", "DIM SHARED g AS INTEGER\n" "DIM SHARED a(2) AS INTEGER\n" "g = 1\n" "Pair g, g\n" "PRINT g\n" "a(1) = 5\n" "Peek a(1)\n" "PRINT a(1)\n" "SUB Pair(x AS INTEGER, y AS INTEGER)\n" " x = x + 1\n" " PRINT y;\n" " y = y * 10\n" " PRINT x\n" "END SUB\n" "SUB Peek(e AS INTEGER)\n" " a(1) = 9\n" " PRINT e;\n" " e = e + 1\n" "END SUB\n", "2 20 \n" "20 \n" "9 10 \n" ); runProgram("References: stores convert to the target's declared type; a reference passed on keeps it", "DIM n AS INTEGER\n" "DIM d AS DOUBLE\n" "DIM b(2) AS LONG\n" "SetHalf n\n" "SetHalf d\n" "SetHalf b(1)\n" "PRINT n; d; b(1); TypeName(n); TypeName(b(1))\n" "ON ERROR GOTO h\n" "SetBig n\n" "PRINT n\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "SUB SetHalf(v)\n" " Inner v\n" "END SUB\n" "SUB Inner(w)\n" " w = 2.5\n" "END SUB\n" "SUB SetBig(v)\n" " v = 40000\n" "END SUB\n", "2 2.5 2 IntegerLong\n" "err6 \n" "2 \n" ); runProgram("References: REDIM / ERASE while an element or an element's field is passed raise error 10; the lock ends with the call", "TYPE P\n" " x AS INTEGER\n" "END TYPE\n" "DIM SHARED d() AS INTEGER\n" "DIM SHARED ps() AS P\n" "REDIM d(3)\n" "REDIM ps(3)\n" "ON ERROR GOTO h\n" "d(2) = 1\n" "Grow d(2)\n" "PRINT UBOUND(d); d(2)\n" "ps(1).x = 4\n" "GrowP ps(1).x\n" "PRINT UBOUND(ps); ps(1).x\n" "Nest ps(2).x\n" "PRINT ps(2).x\n" "REDIM d(5)\n" "REDIM ps(5)\n" "PRINT UBOUND(d); UBOUND(ps)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n" "SUB Grow(v AS INTEGER)\n" " v = v + 1\n" " REDIM PRESERVE d(9)\n" "END SUB\n" "SUB GrowP(v AS INTEGER)\n" " v = v + 1\n" " ERASE ps\n" "END SUB\n" "SUB Nest(v AS INTEGER)\n" " Deeper v\n" "END SUB\n" "SUB Deeper(w AS INTEGER)\n" " w = 7\n" " REDIM ps(1)\n" "END SUB\n", "err10 \n" "3 2 \n" "err10 \n" "3 5 \n" "err10 \n" "7 \n" "5 5 \n" ); runProgram("References: the record and the object a reference names stay alive while it exists", "TYPE Rec\n" " f AS LONG\n" "END TYPE\n" "DIM SHARED r AS Rec\n" "DIM SHARED k AS Holder\n" "r.f = 1\n" "Change r.f\n" "PRINT r.f\n" "SET k = NEW Holder\n" "k.Run\n" "PRINT \"end\"\n" "SUB Change(v AS LONG)\n" " DIM t AS Rec\n" " t.f = 5\n" " r = t\n" " v = 7\n" " PRINT v; r.f\n" "END SUB\n" "SUB Drop(v AS INTEGER, w AS LONG)\n" " SET k = Nothing\n" " v = v + 5\n" " w = w + 1\n" " PRINT \"set\"; v; w\n" "END SUB\n" "BEGINCLASS \"Holder\"\n" "Public n AS INTEGER\n" "Private kept AS Rec\n" "Public Sub Run()\n" " n = 1\n" " kept.f = 2\n" " Drop n, kept.f\n" " PRINT \"run\"; n; kept.f\n" "End Sub\n" "Private Sub Class_Terminate()\n" " PRINT \"gone\"\n" "End Sub\n" "ENDCLASS\n", "7 7 \n" "7 \n" "set6 3 \n" "run6 3 \n" "gone\n" "end\n" ); runProgram("References: elements of an array a Variant holds, ParamArray elements passed on, no reference escapes its frame", "DIM SHARED keep AS Variant\n" "DIM a(2) AS INTEGER\n" "DIM v AS Variant\n" "DIM x AS INTEGER\n" "a(1) = 4\n" "v = a\n" "Bump v(1)\n" "PRINT v(1); a(1)\n" "x = 1\n" "Pass x, v(2)\n" "PRINT x; v(2)\n" "Outer\n" "PRINT keep(0); UBOUND(keep)\n" "SUB Bump(e AS INTEGER)\n" " e = e + 100\n" "END SUB\n" "SUB Pass(ParamArray p())\n" " Bump p(0)\n" " Bump p(1)\n" " PRINT JOIN(p, \",\");\n" " FOR EACH e IN p\n" " PRINT \" \"; e;\n" " NEXT\n" " PRINT\n" "END SUB\n" "SUB Outer\n" " DIM y AS INTEGER\n" " y = 3\n" " Stash y\n" " y = 4\n" "END SUB\n" "SUB Stash(ParamArray p())\n" " keep = p\n" " p(0) = 9\n" "END SUB\n", "104 4 \n" "101,100 101 100 \n" "101 100 \n" "3 0 \n" ); runProgram("References: late-bound and known methods write through TYPE fields and member variables at once", "TYPE Rec\n" " f AS INTEGER\n" "END TYPE\n" "DIM r AS Rec\n" "DIM rs(2) AS Rec\n" "DIM o AS Object\n" "DIM c AS Counter\n" "SET c = NEW Counter\n" "SET o = c\n" "r.f = 1: rs(1).f = 2\n" "o.Add r.f, rs(1).f\n" "PRINT r.f; rs(1).f\n" "c.Add r.f, rs(1).f\n" "PRINT r.f; rs(1).f\n" "c.Self\n" "BEGINCLASS \"Counter\"\n" "Private m AS INTEGER\n" "Private mr AS Rec\n" "Public Sub Add(a AS INTEGER, b AS INTEGER)\n" " a = a + 10\n" " PRINT b;\n" " b = b + a\n" "End Sub\n" "Public Sub Self()\n" " m = 1: mr.f = 2\n" " Add m, mr.f\n" " PRINT m; mr.f\n" "End Sub\n" "ENDCLASS\n", "2 11 13 \n" "13 21 34 \n" "2 11 13 \n" ); } // Deferred graphics round 2: the other SCREEN modes, WIDTH, pages and // PCOPY, VIEW PRINT, PMAP, blinking, PAINT tiles, DRAW X and "=". static void testScreenModesPages(void) { typedef struct { const char *source; int32_t width; int32_t height; int32_t pixelW; int32_t pixelH; int32_t colors; int32_t cols; int32_t rows; int32_t cellH; int32_t pages; } ModeCaseT; static const ModeCaseT modes[] = { { "SCREEN 1\n", 320, 200, 1, 1, 4, 40, 25, 8, 1 }, { "SCREEN 2\n", 640, 200, 1, 2, 2, 80, 25, 8, 1 }, { "SCREEN 7\n", 320, 200, 1, 1, 16, 40, 25, 8, 8 }, { "SCREEN 8\n", 640, 200, 1, 2, 16, 80, 25, 8, 4 }, { "SCREEN 9\n", 640, 350, 1, 1, 16, 80, 25, 14, 2 }, { "SCREEN 9\nWIDTH 80, 43\n", 640, 350, 1, 1, 16, 80, 43, 8, 2 }, { "SCREEN 10\n", 640, 350, 1, 1, 4, 80, 25, 14, 2 }, { "SCREEN 11\n", 640, 480, 1, 1, 2, 80, 30, 16, 1 }, { "SCREEN 11\nWIDTH , 60\n", 640, 480, 1, 1, 2, 80, 60, 8, 1 }, { "SCREEN 12\n", 640, 480, 1, 1, 16, 80, 30, 16, 1 }, { "SCREEN 13\n", 320, 200, 1, 1, 256, 40, 25, 8, 1 }, { "WIDTH 40\n", 320, 400, 2, 1, 16, 40, 25, 16, 8 }, { "WIDTH 80, 43\n", 640, 344, 1, 1, 16, 80, 43, 8, 4 }, { "WIDTH 40, 50\n", 320, 400, 2, 1, 16, 40, 50, 8, 8 } }; CaptureT cap; char row[TEST_ROW_TEXT_LEN]; BasVmT *vm = NULL; basGfxSetFont(font8x16); for (int32_t i = 0; i < (int32_t)(sizeof(modes) / sizeof(modes[0])); i++) { const ModeCaseT *m = &modes[i]; vm = screenRun(m->source, m->source, &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; bool ok = scr->width == m->width && scr->height == m->height && scr->pixelW == m->pixelW && scr->pixelH == m->pixelH; ok = ok && scr->colors == m->colors && scr->cols == m->cols && scr->rows == m->rows && scr->cellH == m->cellH && scr->pages == m->pages; checkTrue("mode geometry, colours, text and pages", ok); screenRunFree(vm); } } vm = screenRun("SCREEN 1 CGA palettes, SCREEN 9 background colour", "SCREEN 1\n" "c1 = 1\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("SCREEN 1 palette 1: cyan, magenta, white", scr->palette[3] == 0 && scr->palette[4] == 170 && scr->palette[5] == 170 && scr->palette[6] == 170 && scr->palette[9] == 255); checkTrue("SCREEN 1 foreground 3", scr->fore == 3); screenRunFree(vm); } vm = screenRun("SCREEN 1 COLOR background, palette 0", "SCREEN 1\n" "COLOR 1, 0\n" "PSET (1, 1), 3\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("COLOR 1: attribute 0 blue", scr->palette[0] == 0 && scr->palette[2] == 170); checkTrue("palette 0: green, red, brown", scr->palette[3] == 0 && scr->palette[4] == 170 && scr->palette[6] == 170 && scr->palette[9] == 170 && scr->palette[10] == 85); checkTrue("attribute 3 drawn", fbAt(scr, 1, 1) == 3); screenRunFree(vm); } vm = screenRun("SCREEN 9 COLOR fore, EGA background; SCREEN 2 white", "SCREEN 9\n" "COLOR 14, 1\n" "PSET (1, 1)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("background colour 1 on attribute 0", scr->palette[0] == 0 && scr->palette[1] == 0 && scr->palette[2] == 170); checkTrue("foreground 14", fbAt(scr, 1, 1) == 14); screenRunFree(vm); } // Graphics pages: draw on a hidden page, copy it, show another vm = screenRun("SCREEN 7 pages: active, visual, PCOPY", "SCREEN 7, , 1, 0\n" "PSET (5, 5), 4\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("page 1 active, page 0 shown", scr->activePage == 1 && scr->visualPage == 0); checkTrue("drawn on the active page only", fbAt(scr, 5, 5) == 4 && shownAt(scr, 5, 5) == 0); screenRunFree(vm); } vm = screenRun("SCREEN 7 PCOPY and showing page 1", "SCREEN 7, , 1, 0\n" "PSET (5, 5), 4\n" "PCOPY 1, 0\n" "SCREEN 7, , 0\n" "PSET (6, 6), 2\n" "SCREEN 7, 0, 1, 1\n" "p = POINT(6, 6)\n" "q = POINT(5, 5)\n" "SCREEN 7\n" "r = POINT(5, 5)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("page 1 shown", scr->visualPage == 1 && shownAt(scr, 5, 5) == 4 && shownAt(scr, 6, 6) == 0); checkTrue("PCOPY copied page 1 onto page 0", scr->fbAll[5 * 320 + 5] == 4 && scr->fbAll[6 * 320 + 6] == 2); checkTrue("POINT reads the active page", globalNum(vm, "p") == 0 && globalNum(vm, "q") == 4); checkTrue("SCREEN of the same mode keeps the picture", globalNum(vm, "r") == 4); screenRunFree(vm); } // SCREEN 0 pages hold text; only the visual page has pixels vm = screenRun("SCREEN 0 pages", "SCREEN 0, , 1, 0\n" "PRINT \"PAGE1\"\n" "a = SCREEN(1, 1)\n" "SCREEN 0, , 0, 0\n" "b = SCREEN(1, 1)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("text on page 1, page 0 blank", globalNum(vm, "a") == 'P' && globalNum(vm, "b") == ' '); checkTrue("the hidden page's text drew nothing", cellPixels(scr, 0, 0, 7) == 0); screenRunFree(vm); } vm = screenRun("SCREEN 0 PCOPY onto the visual page", "SCREEN 0, , 1, 0\n" "PRINT \"PAGE1\"\n" "SCREEN 0, , 0, 0\n" "PCOPY 1, 0\n" "c = SCREEN(1, 1)\n", &cap, NULL); if (vm) { checkTrue("copied text shown", globalNum(vm, "c") == 'P' && cellPixels(vm->screen, 0, 0, 7) > 0); screenRunFree(vm); } // VIEW PRINT: scrolling inside the text viewport vm = screenRun("VIEW PRINT scrolls its rows", "CLS\n" "PRINT \"TOP\"\n" "VIEW PRINT 3 TO 5\n" "r1 = CSRLIN\n" "FOR i = 1 TO 5\n" " PRINT \"L\"; i\n" "NEXT i\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("cursor to the viewport's top", globalNum(vm, "r1") == 3); rowText(scr, 0, row); checkTrue("row above the viewport kept", strcmp(row, "TOP") == 0); rowText(scr, 2, row); checkTrue("viewport scrolled (row 3)", strcmp(row, "L4") == 0); rowText(scr, 3, row); checkTrue("viewport scrolled (row 4)", strcmp(row, "L5") == 0); screenRunFree(vm); } vm = screenRun("CLS 2 and CLS under VIEW PRINT clear the viewport", "CLS\n" "PRINT \"TOP\"\n" "VIEW PRINT 3 TO 5\n" "PRINT \"MID\"\n" "CLS\n" "VIEW PRINT\n" "r2 = CSRLIN\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; rowText(scr, 0, row); checkTrue("CLS kept the row above", strcmp(row, "TOP") == 0); rowText(scr, 2, row); checkTrue("CLS cleared the viewport", row[0] == '\0'); checkTrue("VIEW PRINT alone: whole screen, cursor home", globalNum(vm, "r2") == 1 && scr->textTop == 0 && scr->textBottom == 24); screenRunFree(vm); } // PMAP with WINDOW and VIEW vm = screenRun("PMAP", "SCREEN 13\n" "WINDOW (0, 0)-(100, 100)\n" "a = PMAP(0, 0)\n" "b = PMAP(100, 0)\n" "c = PMAP(0, 1)\n" "d = PMAP(319, 2)\n" "e = PMAP(0, 3)\n" "VIEW (10, 10)-(109, 109)\n" "WINDOW SCREEN (0, 0)-(99, 99)\n" "f = PMAP(99, 0)\n" "g = PMAP(0, 2)\n", &cap, NULL); if (vm) { checkTrue("PMAP world -> physical", globalNum(vm, "a") == 0 && globalNum(vm, "b") == 319 && globalNum(vm, "c") == 199); checkTrue("PMAP physical -> world", globalNum(vm, "d") == 100 && globalNum(vm, "e") == 100); checkTrue("PMAP is view-relative", globalNum(vm, "f") == 99 && globalNum(vm, "g") == 0); screenRunFree(vm); } // Blinking text: COLOR 16..31, and backgrounds 8..15 as on a VGA vm = screenRun("SCREEN 0 blinking colours", "COLOR 20, 1\n" "PRINT \"B\";\n" "COLOR 7, 9\n" "PRINT \"C\";\n" "a = SCREEN(1, 1, 1)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; int32_t on = cellPixels(scr, 0, 0, 4); checkTrue("blink attribute", globalNum(vm, "a") == (4 | 1 << 4 | 0x80) && scr->blinkUsed); checkTrue("background 9 shows as 1", cellPixels(scr, 0, 1, 1) > 0 && cellPixels(scr, 0, 1, 9) == 0); checkTrue("blink phase hides the text", on > 0 && basScreenBlink(scr) && cellPixels(scr, 0, 0, 4) == 0 && cellPixels(scr, 0, 0, 1) == 128); checkTrue("and shows it again", basScreenBlink(scr) && cellPixels(scr, 0, 0, 4) == on); screenRunFree(vm); } vm = screenRun("SCREEN 10 blinking shades", "SCREEN 10\n" "PSET (1, 1), 2\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("attribute 2 on, then off", scr->palette[6] == 170 && basScreenBlink(scr) && scr->palette[6] == 0 && scr->paletteChanged); screenRunFree(vm); } vm = screenRun("SCREEN 10 without blinking shades; SCREEN 13 never blinks", "SCREEN 10\n" "PALETTE 2, 4\n", &cap, NULL); if (vm) { checkTrue("nothing blinks", !basScreenBlink(vm->screen) && vm->screen->palette[6] == 170); screenRunFree(vm); } // PAINT tiles: planes (SCREEN 12), bytes (13), two-bit pixels (1) vm = screenRun("PAINT tiles", "SCREEN 12\n" "LINE (0, 0)-(20, 20), 15, B\n" "PAINT (5, 5), CHR$(&HAA) + STRING$(3, 0), 15\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("plane tile: blue on even columns", fbAt(scr, 2, 5) == 1 && fbAt(scr, 3, 5) == 0 && fbAt(scr, 18, 19) == 1 && fbAt(scr, 1, 1) == 0); checkTrue("tile stays inside the border", fbAt(scr, 0, 5) == 15 && fbAt(scr, 20, 5) == 15 && fbAt(scr, 22, 5) == 0); screenRunFree(vm); } vm = screenRun("PAINT tiles in SCREEN 13 and SCREEN 1", "SCREEN 13\n" "LINE (30, 0)-(50, 20), 15, B\n" "PAINT (35, 5), CHR$(4) + CHR$(5), 15\n" "a = POINT(35, 4)\n" "b = POINT(40, 5)\n" "SCREEN 1\n" "LINE (0, 0)-(20, 20), 3, B\n" "PAINT (5, 5), CHR$(&H1B), 3\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("byte tile rows", globalNum(vm, "a") == 4 && globalNum(vm, "b") == 5); checkTrue("two-bit tile", fbAt(scr, 4, 5) == 0 && fbAt(scr, 5, 5) == 1 && fbAt(scr, 6, 5) == 2 && fbAt(scr, 7, 5) == 3 && fbAt(scr, 9, 9) == 1); screenRunFree(vm); } // DRAW X and "=" with VARPTR$ vm = screenRun("DRAW X and = with VARPTR$", "SCREEN 13\n" "s$ = \"R10\"\n" "DRAW \"C4 BM10,10 X\" + VARPTR$(s$) + \";\"\n" "n = 5\n" "DRAW \"BM50,50 C=\" + VARPTR$(n) + \"; R=\" + VARPTR$(n) + \";\"\n" "t$ = \"D3 X\" + VARPTR$(s$)\n" "DRAW \"C6 BM100,100 X\" + VARPTR$(t$)\n", &cap, NULL); if (vm) { BasScreenT *scr = vm->screen; checkTrue("X ran the string", fbAt(scr, 10, 10) == 4 && fbAt(scr, 20, 10) == 4 && fbAt(scr, 21, 10) == 0); checkTrue("= numbers", fbAt(scr, 55, 50) == 5 && fbAt(scr, 56, 50) == 0); checkTrue("nested X", fbAt(scr, 100, 103) == 6 && fbAt(scr, 110, 103) == 6); screenRunFree(vm); } vm = screenRun("Errors: pages, COLOR in SCREEN 2, WIDTH, PMAP, VIEW PRINT, tiles, DRAW X", "ON ERROR GOTO h\n" "SCREEN 7, , 8\n" "SCREEN 13, , 1\n" "PCOPY 0, 9\n" "SCREEN 2\n" "COLOR 1\n" "SCREEN 13\n" "WIDTH 40, 43\n" "x = PMAP(0, 4)\n" "DRAW \"XAB\"\n" "SCREEN 0\n" "x = PMAP(1, 0)\n" "VIEW PRINT 5 TO 3\n" "VIEW PRINT 0 TO 3\n" "WIDTH 60\n" "SCREEN 1\n" "PSET (1, 1), 4\n" "SCREEN 12\n" "PAINT (5, 5), STRING$(12, 0), 15, CHR$(0)\n" "PAINT (5, 5), STRING$(8, 0), 15, CHR$(0)\n" "END\n" "h:\n" "n = n + 1\n" "IF ERR <> 5 THEN bad = bad + 1\n" "RESUME NEXT\n", &cap, NULL); if (vm) { checkTrue("thirteen Illegal function calls", globalNum(vm, "n") == 13 && globalNum(vm, "bad") == 0); screenRunFree(vm); } vm = screenRun("Each page keeps its own text cursor", "SCREEN 7, , 1, 0\n" "LOCATE 5, 10\n" "PRINT \"x\";\n" "SCREEN 7, , 0, 0\n" "LOCATE 2, 3\n" "SCREEN 7, , 1, 0\n" "r1 = CSRLIN: c1 = POS(0)\n" "SCREEN 7, , 0, 0\n" "r0 = CSRLIN: c0 = POS(0)\n" "SCREEN 7, , 2, 0\n" "r2 = CSRLIN: c2 = POS(0)\n" "SCREEN 7, , 0, 0\n", &cap, NULL); if (vm) { checkTrue("page 1 cursor kept across page switches", globalNum(vm, "r1") == 5 && globalNum(vm, "c1") == 11); checkTrue("page 0 cursor kept across page switches", globalNum(vm, "r0") == 2 && globalNum(vm, "c0") == 3); checkTrue("an unused page's cursor is home", globalNum(vm, "r2") == 1 && globalNum(vm, "c2") == 1); screenRunFree(vm); } } // Phase 1 library functions: the string functions (REPLACE$, SPLIT, JOIN$, // INSTRREV, STRCOMP, STRREVERSE$, FILTER, LSET / RSET, IIF, CHOOSE) and // the DATE type with its functions, literals, arithmetic and Format$. static void testStringsAndDates(void) { runProgram("Replace$", "PRINT Replace$(\"aXbXc\", \"X\", \"-\")\n" "PRINT Replace(\"aXbXc\", \"X\", \"-\", 3)\n" "PRINT Replace(\"aXbXc\", \"X\", \"-\", 1, 1)\n" "PRINT Replace(\"aXbXc\", \"x\", \"-\", 1, -1, vbTextCompare)\n" "PRINT Replace(\"aXbXc\", \"x\", \"-\")\n" "PRINT \"[\" & Replace(\"abc\", \"\", \"-\") & \"]\"\n" "PRINT \"[\" & Replace(\"abc\", \"b\", \"\") & \"]\"\n" "PRINT \"[\" & Replace(\"abc\", \"b\", \"x\", 9) & \"]\"\n" "PRINT Replace(\"aaa\", \"a\", \"aa\")\n" "PRINT Replace(\"aXbXc\", \"X\", \"-\", 1, 0)\n", "a-b-c\nb-c\na-bXc\na-b-c\naXbXc\n[abc]\n[ac]\n[]\naaaaaa\naXbXc\n" ); runProgram("Split with delimiters, limits and empty input", "DIM p() AS STRING\n" "DIM i AS INTEGER\n" "p = Split(\"a,b,,c\", \",\")\n" "PRINT UBOUND(p); LBOUND(p)\n" "FOR i = 0 TO UBOUND(p): PRINT \"[\" & p(i) & \"]\";: NEXT: PRINT\n" "p = Split(\"a b c\")\n" "PRINT UBOUND(p)\n" "p = Split(\"a,b,c\", \",\", 2)\n" "FOR i = 0 TO UBOUND(p): PRINT \"[\" & p(i) & \"]\";: NEXT: PRINT\n" "p = Split(\"\", \",\")\n" "PRINT UBOUND(p); LBOUND(p)\n" "p = Split(\"abc\", \"\")\n" "PRINT UBOUND(p); p(0)\n" "p = Split(\"aXbxc\", \"x\", -1, vbTextCompare)\n" "FOR i = 0 TO UBOUND(p): PRINT \"[\" & p(i) & \"]\";: NEXT: PRINT\n" "p = Split(\"a,b\", \",\", 0)\n" "PRINT UBOUND(p)\n" "p = Split(\"a,b,\", \",\")\n" "PRINT UBOUND(p)\n" "p = Split(\"a::b\", \"::\")\n" "PRINT p(0); p(1)\n", "3 0 \n[a][b][][c]\n2 \n[a][b,c]\n-1 0 \n0 abc\n[a][b][c]\n-1 \n2 \nab\n" ); runProgram("Join$ and Filter", "DIM p() AS STRING\n" "DIM n(2) AS INTEGER\n" "DIM f() AS STRING\n" "p = Split(\"apple,banana,cherry\", \",\")\n" "PRINT Join$(p, \"-\")\n" "PRINT Join(p)\n" "PRINT Join(Split(\"x y z\"), \"\")\n" "n(0) = 1: n(1) = 22: n(2) = 333\n" "PRINT Join(n, \",\")\n" "PRINT \"[\" & Join(Split(\"\", \",\"), \",\") & \"]\"\n" "f = Filter(p, \"an\")\n" "PRINT UBOUND(f); f(0)\n" "f = Filter(p, \"an\", False)\n" "PRINT Join(f, \"+\")\n" "f = Filter(p, \"AN\", True, vbTextCompare)\n" "PRINT Join(f, \"+\")\n" "f = Filter(p, \"zz\")\n" "PRINT UBOUND(f)\n", "apple-banana-cherry\napple banana cherry\nxyz\n1,22,333\n[]\n0 banana\napple+cherry\nbanana\n-1 \n" ); runProgram("InStrRev, StrComp and StrReverse$", "PRINT InStrRev(\"abcabc\", \"bc\")\n" "PRINT InStrRev(\"abcabc\", \"bc\", 4)\n" "PRINT InStrRev(\"abc\", \"x\")\n" "PRINT InStrRev(\"abc\", \"\")\n" "PRINT InStrRev(\"ABC\", \"b\", -1, vbTextCompare)\n" "PRINT InStrRev(\"abc\", \"c\", 9)\n" "PRINT InStrRev(\"\", \"a\")\n" "PRINT StrComp(\"a\", \"b\"); StrComp(\"b\", \"a\"); StrComp(\"a\", \"a\")\n" "PRINT StrComp(\"A\", \"a\"); StrComp(\"A\", \"a\", vbTextCompare); StrComp(\"A\", \"a\", vbBinaryCompare)\n" "PRINT StrReverse$(\"abc\"); \"[\" & StrReverse(\"\") & \"]\"\n", "5 \n2 \n0 \n3 \n2 \n0 \n0 \n-1 1 0 \n-1 0 -1 \ncba[]\n" ); runProgram("Drag and clipboard constants; Control, Form and Object types", "PRINT vbManual; vbAutomatic; vbBeginDrag; vbEndDrag\n" "PRINT vbEnter; vbLeave; vbOver; vbCFText\n" "DIM c AS Control\n" "SET c = Nothing\n" "T Nothing, Nothing, c\n" "SUB T(s AS Control, f AS Form, o AS Object)\n" " PRINT \"objects\"\n" "END SUB\n", "0 1 1 2 \n0 1 2 1 \nobjects\n" ); runProgram("StrComp and Replace follow OPTION COMPARE TEXT", "OPTION COMPARE TEXT\n" "PRINT StrComp(\"A\", \"a\"); StrComp(\"A\", \"a\", vbBinaryCompare)\n" "PRINT Replace(\"aXbxc\", \"x\", \"-\")\n" "PRINT InStrRev(\"aXbx\", \"X\")\n", "0 -1 \na-b-c\n4 \n" ); runProgram("LSET and RSET", "DIM s AS STRING\n" "DIM f AS STRING * 4\n" "DIM a(1) AS STRING\n" "s = \"12345\"\n" "LSET s = \"ab\"\n" "PRINT \"[\" & s & \"]\"\n" "RSET s = \"xy\"\n" "PRINT \"[\" & s & \"]\"\n" "LSET s = \"toolongvalue\"\n" "PRINT \"[\" & s & \"]\"\n" "RSET s = \"toolongvalue\"\n" "PRINT \"[\" & s & \"]\"\n" "RSET f = \"7\"\n" "PRINT \"[\" & f & \"]\"\n" "a(1) = \"....\"\n" "LSET a(1) = \"x\"\n" "PRINT \"[\" & a(1) & \"]\"\n", "[ab ]\n[ xy]\n[toolo]\n[toolo]\n[ 7]\n[x ]\n" ); runProgram("IIf and Choose", "PRINT IIf(1 > 0, \"yes\", \"no\")\n" "PRINT IIf(0, 1, 2)\n" "PRINT Choose(2, \"a\", \"b\", \"c\")\n" "PRINT Choose(3.7, \"a\", \"b\", \"c\")\n" "PRINT Choose(4, \"a\", \"b\", \"c\")\n" "PRINT IsNull(Choose(0, \"a\"))\n", "yes\n2 \nb\nc\nNull\nTrue \n" ); runProgram("Library errors", "DIM s AS INTEGER\n" "ON ERROR GOTO h\n" "PRINT Join(5)\n" "PRINT Replace(\"a\", \"a\", \"b\", 0)\n" "PRINT Split(\"a\", \",\", -2)\n" "PRINT InStrRev(\"a\", \"a\", 0)\n" "PRINT StrComp(\"a\", \"b\", 7)\n" "LSET s = \"x\"\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "err13 \nerr5 \nerr5 \nerr5 \nerr5 \nerr13 \n" ); runProgram("New built-in names stay free for the program", "DIM day AS INTEGER\n" "day = 5\n" "PRINT day\n" "FUNCTION Replace(a AS STRING) AS STRING\n" " Replace = \"mine \" & a\n" "END FUNCTION\n" "PRINT Replace(\"x\")\n" "PRINT Month(#3/4/2005#)\n", "5 \nmine x\n3 \n" ); runProgram("DATE variables, literals and printing", "DIM d AS DATE\n" "PRINT d\n" "d = #1/15/2000#\n" "PRINT d\n" "PRINT Year(d); Month(d); Day(d); Weekday(d)\n" "d = #1/15/2000 3:04:05 PM#\n" "PRINT d\n" "PRINT Hour(d); Minute(d); Second(d)\n" "PRINT CDbl(#1/1/2000#)\n" "PRINT #12:00:00 PM#\n" "PRINT CDate(36526.5)\n" "PRINT \"[\" & STR$(d) & \"][\" & CSTR(d) & \"]\"\n" "PRINT \"Date: \" & #2000-02-29#\n" "PRINT #March 5, 2001#; \"|\"; #5 Mar 2001 16:30#\n" "PRINT #1/1/100#; \" \"; #12/31/9999 11:59:59 PM#\n", "12:00:00 AM\n1/15/2000\n2000 1 15 7 \n1/15/2000 3:04:05 PM\n15 4 5 \n36526 \n12:00:00 PM\n1/1/2000 12:00:00 PM\n" "[1/15/2000 3:04:05 PM][1/15/2000 3:04:05 PM]\nDate: 2/29/2000\n3/5/2001|3/5/2001 4:30:00 PM\n1/1/100 12/31/9999 11:59:59 PM\n" ); runProgram("DateSerial and TimeSerial rules", "PRINT DateSerial(2000, 2, 29)\n" "PRINT DateSerial(2001, 2, 29)\n" "PRINT DateSerial(2000, 13, 1)\n" "PRINT DateSerial(2000, 0, 1)\n" "PRINT DateSerial(2000, 3, 0)\n" "PRINT DateSerial(2000, -11, 1)\n" "PRINT DateSerial(99, 1, 1); \" \"; DateSerial(29, 1, 1); \" \"; DateSerial(30, 1, 1)\n" "PRINT DateSerial(1900, 2, 29)\n" "PRINT DateSerial(2000, 1, 366)\n" "PRINT TimeSerial(25, 0, 0)\n" "PRINT TimeSerial(-1, 0, 0)\n" "PRINT TimeSerial(1, 90, 0)\n" "PRINT CDbl(TimeSerial(-1, 0, 0))\n" "PRINT TimeSerial(0, 0, -1)\n" "ON ERROR GOTO h\n" "PRINT DateSerial(10000, 1, 1)\n" "PRINT DateSerial(100, 1, 0)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "2/29/2000\n3/1/2001\n1/1/2001\n12/1/1999\n2/29/2000\n1/1/1999\n1/1/1999 1/1/2029 1/1/1930\n3/1/1900\n12/31/2000\n" "12/31/1899 1:00:00 AM\n12/29/1899 11:00:00 PM\n2:30:00 AM\n-1.95833333333333 \n12/29/1899 11:59:59 PM\nerr5 \nerr5 \n" ); runProgram("DateValue, TimeValue and dates before 1900", "DIM d AS DATE\n" "PRINT DateValue(\"March 5, 2001 4:00 PM\")\n" "PRINT TimeValue(\"March 5, 2001 4:00 PM\")\n" "d = CDate(-1.25)\n" "PRINT d\n" "PRINT DateValue(d); \" \"; TimeValue(d)\n" "PRINT d + 1\n" "PRINT d - 1\n" "PRINT CDbl(d - 1)\n" "PRINT CDate(-1.25) > CDate(-1)\n" "PRINT Weekday(CDate(-1)); Year(d); Month(d); Day(d); Hour(d)\n" "PRINT #12/29/1899 6:00 AM# = d\n", "3/5/2001\n4:00:00 PM\n12/29/1899 6:00:00 AM\n12/29/1899 6:00:00 AM\n6:00:00 AM\n12/28/1899 6:00:00 AM\n-2.25 \nTrue \n6 1899 12 29 6 \nTrue \n" ); runProgram("DateAdd with month-end clamping and overflow", "PRINT DateAdd(\"m\", 1, #1/31/2000#)\n" "PRINT DateAdd(\"m\", 1, #1/31/2001#)\n" "PRINT DateAdd(\"yyyy\", 1, #2/29/2000#)\n" "PRINT DateAdd(\"q\", 1, #11/30/2000#)\n" "PRINT DateAdd(\"m\", -13, #1/31/2000#)\n" "PRINT DateAdd(\"d\", -1, #3/1/2000#)\n" "PRINT DateAdd(\"y\", 1, #12/31/2000#); \" \"; DateAdd(\"w\", 1, #12/31/2000#)\n" "PRINT DateAdd(\"ww\", 2, #1/1/2000#)\n" "PRINT DateAdd(\"h\", 25, #1/1/2000#)\n" "PRINT DateAdd(\"n\", -1, #1/1/2000#)\n" "PRINT DateAdd(\"s\", 86400, #1/1/2000#)\n" "PRINT DateAdd(\"M\", 2.9, #1/15/2000#)\n" "PRINT DateAdd(\"m\", 1, #1/31/2000 10:30#)\n" "ON ERROR GOTO h\n" "PRINT DateAdd(\"x\", 1, #1/1/2000#)\n" "PRINT DateAdd(\"yyyy\", 8000, #1/1/2000#)\n" "PRINT DateAdd(\"d\", -1, #1/1/100#)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "2/29/2000\n2/28/2001\n2/28/2001\n2/28/2001\n12/31/1998\n2/29/2000\n1/1/2001 1/1/2001\n1/15/2000\n1/2/2000 1:00:00 AM\n" "12/31/1999 11:59:00 PM\n1/2/2000\n3/15/2000\n2/29/2000 10:30:00 AM\nerr5 \nerr5 \nerr5 \n" ); runProgram("DateDiff intervals and week rules", "PRINT DateDiff(\"d\", #1/1/2000#, #3/1/2000#)\n" "PRINT DateDiff(\"d\", #3/1/2000#, #1/1/2000#)\n" "PRINT DateDiff(\"d\", #1/1/2000 11:00 PM#, #1/2/2000 1:00 AM#)\n" "PRINT DateDiff(\"yyyy\", #12/31/1999#, #1/1/2000#)\n" "PRINT DateDiff(\"m\", #1/31/2000#, #2/1/2000#)\n" "PRINT DateDiff(\"q\", #3/31/2000#, #4/1/2000#)\n" "PRINT DateDiff(\"w\", #1/3/2000#, #1/16/2000#); DateDiff(\"w\", #1/3/2000#, #1/17/2000#)\n" "PRINT DateDiff(\"ww\", #1/1/2000#, #1/2/2000#); DateDiff(\"ww\", #1/2/2000#, #1/8/2000#)\n" "PRINT DateDiff(\"ww\", #1/1/2000#, #1/2/2000#, vbMonday); DateDiff(\"ww\", #1/1/2000#, #12/31/2000#)\n" "PRINT DateDiff(\"h\", #1/1/2000 10:59 AM#, #1/1/2000 11:00 AM#)\n" "PRINT DateDiff(\"n\", #1/1/2000 10:59:59 AM#, #1/1/2000 11:00 AM#)\n" "PRINT DateDiff(\"s\", #1/1/2000#, #1/2/2000#)\n" "PRINT DateDiff(\"d\", CDate(-1.25), CDate(0.5))\n" "ON ERROR GOTO h\n" "PRINT DateDiff(\"s\", #1/1/100#, #12/31/9999#)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "60 \n-60 \n1 \n1 \n1 \n1 \n1 2 \n1 0 \n0 53 \n1 \n1 \n86400 \n1 \nerr6 \n" ); runProgram("DatePart, Weekday and week-of-year rules", "PRINT DatePart(\"yyyy\", #5/15/2000#); DatePart(\"q\", #5/15/2000#); DatePart(\"m\", #5/15/2000#)\n" "PRINT DatePart(\"y\", #3/1/2000#); DatePart(\"y\", #3/1/2001#); DatePart(\"d\", #3/1/2001#)\n" "PRINT DatePart(\"w\", #1/1/2000#); DatePart(\"w\", #1/1/2000#, vbMonday)\n" "PRINT DatePart(\"ww\", #1/1/2000#); DatePart(\"ww\", #1/1/2000#, vbSunday, vbFirstFourDays); DatePart(\"ww\", #1/1/2000#, vbSunday, vbFirstFullWeek)\n" "PRINT DatePart(\"ww\", #12/31/2000#); DatePart(\"ww\", #1/2/2000#, vbSunday, vbFirstFullWeek)\n" "PRINT DatePart(\"h\", #1/1/2000 1:02:03 PM#); DatePart(\"n\", #1/1/2000 1:02:03 PM#); DatePart(\"s\", #1/1/2000 1:02:03 PM#)\n" "PRINT Weekday(#1/1/2000#, vbMonday); Weekday(#1/2/2000#); Weekday(#1/2/2000#, vbUseSystemDayOfWeek)\n" "ON ERROR GOTO h\n" "PRINT Weekday(#1/1/2000#, 9)\n" "PRINT DatePart(\"ww\", #1/1/2000#, vbSunday, 4)\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "2000 2 5 \n61 60 1 \n7 6 \n1 52 52 \n54 1 \n13 2 3 \n6 1 1 \nerr5 \nerr5 \n" ); runProgram("IsDate, CDate, MonthName and WeekdayName", "DIM d AS DATE\n" "PRINT IsDate(\"1/1/2000\"); IsDate(\"hello\"); IsDate(#1/1/2000#); IsDate(5); IsDate(\"2/30/2000\"); IsDate(\"13:00\"); IsDate(\"25:00\")\n" "PRINT MonthName(1); \" \"; MonthName(12, True)\n" "PRINT WeekdayName(1); \" \"; WeekdayName(1, True); \" \"; WeekdayName(1, False, vbMonday); \" \"; WeekdayName(7, False, vbMonday)\n" "d = \"2/3/2004\"\n" "PRINT d\n" "d = \"13/1/2000\"\n" "PRINT d\n" "ON ERROR GOTO h\n" "PRINT MonthName(13)\n" "d = \"garbage\"\n" "d = 1E10\n" "PRINT CDate(\"2/30/2000\")\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "True False True False False True False \nJanuary Dec\nSunday Sun Monday Sunday\n2/3/2004\n1/13/2000\nerr5 \nerr13 \nerr6 \nerr13 \n" ); runProgram("Format$ with date patterns", "DIM d AS DATE\n" "d = #1/5/2000 3:04:05 PM#\n" "PRINT Format$(d, \"yyyy-mm-dd hh:nn:ss\")\n" "PRINT Format$(d, \"m/d/yy\")\n" "PRINT Format$(d, \"dddd, mmmm d, yyyy\")\n" "PRINT Format$(d, \"ddd mmm\")\n" "PRINT Format$(d, \"h:mm AM/PM\"); \"|\"; Format$(d, \"hh:mm am/pm\"); \"|\"; Format$(d, \"h A/P\")\n" "PRINT Format$(d, \"Long Date\"); \"|\"; Format$(d, \"Short Date\"); \"|\"; Format$(d, \"Medium Date\")\n" "PRINT Format$(d, \"Long Time\"); \"|\"; Format$(d, \"Medium Time\"); \"|\"; Format$(d, \"Short Time\")\n" "PRINT Format$(d, \"q\"); \"|\"; Format$(d, \"\\d\\a\\y d\"); \"|\"; Format$(d, CHR$(34) & \"Year\" & CHR$(34) & \" yyyy\")\n" "PRINT Format$(d, \"c\"); \"|\"; Format$(d, \"\"); \"|\"; Format$(d, \"General Date\")\n" "PRINT Format$(d, \"ddddd\"); \"|\"; Format$(d, \"ttttt\"); \"|\"; Format$(d, \"y w ww\")\n" "PRINT Format(36526, \"mm/dd/yyyy\"); \"|\"; Format$(\"1/2/2000\", \"yyyy\")\n" "PRINT Format$(1234.5, \"#,##0.00\"); \"|\"; Format$(0.5, \"Percent\")\n" "PRINT Format$(#1/1/2000 12:05 AM#, \"h:nn AM/PM\"); \"|\"; Format$(#1/1/2000 12:05 PM#, \"hh:nn\")\n" "ON ERROR GOTO h\n" "PRINT Format$(\"xyz\", \"yyyy\")\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "2000-01-05 15:04:05\n1/5/00\nWednesday, January 5, 2000\nWed Jan\n3:04 PM|03:04 pm|3 P\n" "Wednesday, January 5, 2000|1/5/2000|05-Jan-00\n3:04:05 PM|03:04 PM|15:04\n1|day 5|Year 2000\n" "1/5/2000 3:04:05 PM|1/5/2000 3:04:05 PM|1/5/2000 3:04:05 PM\n1/5/2000|3:04:05 PM|5 4 2\n01/01/2000|2000\n1,234.50|50%\n12:05 AM|12:05\nerr13 \n" ); runProgram("Date arithmetic and comparison", "DIM a AS DATE\n" "DIM b AS DATE\n" "a = #1/1/2000#\n" "b = #1/2/2000 12:00 PM#\n" "PRINT b > a; a = #1/1/2000#; a < \"1/2/2000\"; a = \"1/1/2000\"\n" "PRINT b - a\n" "PRINT a + 1.5\n" "PRINT 2 + a\n" "PRINT a - 366\n" "a = a + 1\n" "PRINT a\n" "ON ERROR GOTO h\n" "a = #12/31/9999# + 1\n" "END\n" "h:\n" "PRINT \"err\"; ERR\n" "RESUME NEXT\n", "True True True True \n1.5 \n1/2/2000 12:00:00 PM\n1/3/2000\n12/31/1998\n1/2/2000\nerr6 \n" ); runProgram("DATE constants, arrays, TYPE fields and functions", "CONST Y2K = #1/1/2000#\n" "CONST NOON AS DATE = 0.5\n" "TYPE Rec\n" " stamp AS DATE\n" "END TYPE\n" "DIM a(2) AS DATE\n" "DIM r AS Rec\n" "FUNCTION NextDay(x AS DATE) AS DATE\n" " NextDay = x + 1\n" "END FUNCTION\n" "PRINT Y2K; \"|\"; NOON; \"|\"; Year(Y2K)\n" "PRINT a(0)\n" "a(1) = \"1/1/2000\"\n" "PRINT a(1)\n" "r.stamp = #2/2/2002#\n" "PRINT r.stamp\n" "PRINT NextDay(#2/28/2000#)\n" "PRINT NextDay(CDate(\"12/31/1999\"))\n", "1/1/2000|12:00:00 PM|2000 \n12:00:00 AM\n1/1/2000\n2/2/2002\n2/29/2000\n1/1/2000\n" ); runProgram("Now, Date and Time", "DIM d AS DATE\n" "d = Now\n" "PRINT Year(d) >= 2024; Int(CDbl(Date)) = CDbl(Date); CDbl(Time) < 1; DateValue(Now) = Date; Now() >= Date()\n", "True True True True True \n" ); runProgram("WRITE # and INPUT # round-trip a date", "DIM d AS DATE\n" "OPEN \"datert.txt\" FOR OUTPUT AS #1\n" "WRITE #1, #1/2/2000 3:04 PM#, 5\n" "CLOSE #1\n" "OPEN \"datert.txt\" FOR INPUT AS #1\n" "INPUT #1, d\n" "CLOSE #1\n" "KILL \"datert.txt\"\n" "PRINT d\n", "1/2/2000 3:04:00 PM\n" ); compileOnly("File numbers are not date literals", "PRINT #1, 5: PRINT #2, 6\n" "WRITE #1, a, b: CLOSE #1\n" ); expectCompileError("Built-in argument count is checked", "x = Replace(\"a\")\n", "Built-in 'REPLACE' expects 3-6 arguments, got 1" ); expectCompileError("Zero-argument built-in rejects arguments", "x = Now(1)\n", "Built-in 'NOW' expects 0-0 arguments, got 1" ); } // Every token type must map to a printable name (unknowns report "?"). static void testTokenNames(void) { printf("=== token names ===\n"); bool ok = true; for (int32_t i = 0; i < TEST_TOKEN_NAME_SWEEP; i++) { if (basTokenName((BasTokenTypeE)i) == NULL) { ok = false; } } if (ok) { printf("OK\n\n"); } else { printf("FAIL: basTokenName returned NULL\n\n"); gFailCount++; } } // A UserControl class (BEGINCLASS "Name" USERCONTROL): the module keeps // its flag, the slot of its UserControl object, its UserControl_ // procedures and its events with their parameters; the host makes // objects, reads, writes and calls members and runs the event procedures // with Me; RaiseEvent reaches the event host, which writes ByRef // arguments back. static void testUserControl(void) { static const char *source = "BEGINCLASS \"Gauge\" USERCONTROL\n" "Public Event ItemOpen(ByVal Index AS INTEGER, Title AS STRING)\n" "Public Event Ping()\n" "Private mLevel AS DOUBLE\n" "Public Caption AS STRING\n" "Public Property Get Level() AS DOUBLE\n" " Level = mLevel\n" "End Property\n" "Public Property Let Level(v AS DOUBLE)\n" " mLevel = v\n" "End Property\n" "Public Function Open(i AS INTEGER) AS STRING\n" " DIM n AS STRING\n" " n = \"item\"\n" " RaiseEvent ItemOpen(i, n)\n" " Open = n\n" "End Function\n" "Private Sub UserControl_Initialize()\n" " mLevel = 1.25\n" " PRINT \"init\"; TypeName(UserControl)\n" "End Sub\n" "Private Sub UserControl_MouseDown(Button AS INTEGER, Shift AS INTEGER, X AS SINGLE, Y AS SINGLE)\n" " PRINT \"down\"; Button; X\n" "End Sub\n" "ENDCLASS\n"; printf("=== UserControl: module, host calls, events ===\n"); BasCompilerT *compiler = basCompilerCreate(source, (int32_t)strlen(source)); bool ok = basCompile(compiler); BasModuleT *mod = ok ? basCompilerBuildModule(compiler) : NULL; if (!ok) { printf("FAIL: compile: %s\n", basCompilerError(compiler)); } basCompilerDestroy(compiler); checkTrue("UserControl compiles", mod != NULL); if (mod == NULL) { gFailCount++; return; } const BasClassInfoT *cls = &mod->classes[0]; checkTrue("class flag", cls->flags == BAS_CLASS_USERCONTROL); checkTrue("UserControl slot is the first member variable", cls->ucSlot == 0); checkTrue("Initialize and MouseDown handlers found", cls->ucProcs[BAS_UC_EVT_INITIALIZE] >= 0 && cls->ucProcs[BAS_UC_EVT_MOUSEDOWN] >= 0); checkTrue("no Paint handler", cls->ucProcs[BAS_UC_EVT_PAINT] == -1); checkTrue("two events", cls->eventCount == 2); checkTrue("event parameters", cls->eventCount == 2 && strcmp(cls->events[0].name, "ItemOpen") == 0 && cls->events[0].paramCount == 2 && cls->events[0].paramTypes[0] == BAS_TYPE_INTEGER && cls->events[0].paramTypes[1] == BAS_TYPE_STRING && cls->events[0].byValParams == 1u && cls->events[0].paramNames && strcmp(cls->events[0].paramNames, "Index,Title") == 0); checkTrue("event without parameters", cls->eventCount == 2 && cls->events[1].paramCount == 0 && cls->events[1].paramNames == NULL); // The module format keeps all of it int32_t len = 0; uint8_t *data = basModuleSerialize(mod, &len); BasModuleT *back = data ? basModuleDeserialize(data, len) : NULL; free(data); checkTrue("round trip", back != NULL && back->classes[0].flags == BAS_CLASS_USERCONTROL && back->classes[0].ucSlot == 0 && memcmp(back->classes[0].ucProcs, cls->ucProcs, sizeof(cls->ucProcs)) == 0 && back->classes[0].eventCount == 2 && strcmp(back->classes[0].events[0].paramNames, "Index,Title") == 0 && back->classes[0].events[0].byValParams == 1u); if (back) { basModuleFree(back); } // The host's side CaptureT cap; int32_t hostCalls = 0; BasVmT *vm = basVmCreate(); captureReset(&cap); basVmSetPrintCallback(vm, capturePrint, &cap); basVmLoadModule(vm, mod); basVmSetEventHost(vm, ucEventHost, &hostCalls); basVmRun(vm); BasObjectT *obj = basVmNewObject(vm, 0); BasValueT ctl = basValObject(&hostCalls); BasValueT res; checkTrue("object made", obj != NULL); if (obj) { basValRelease(&obj->fields[cls->ucSlot]); obj->fields[cls->ucSlot] = ctl; checkTrue("UserControl_Initialize runs with Me", basVmCallProc(vm, obj, cls->ucProcs[BAS_UC_EVT_INITIALIZE], NULL, 0, NULL, 0) && strcmp(cap.buf, "initObject\n") == 0); checkTrue("Property Get", basVmCallMember(vm, obj, "Level", BAS_MEMBER_OP_GET, NULL, 0, &res) && res.type == BAS_TYPE_DOUBLE && res.dblVal == 1.25); basValRelease(&res); BasValueT v = basValDouble(0.1); checkTrue("Property Let", basVmCallMember(vm, obj, "Level", BAS_MEMBER_OP_LET, &v, 1, NULL)); checkTrue("Double kept", basVmCallMember(vm, obj, "Level", BAS_MEMBER_OP_GET, NULL, 0, &res) && res.dblVal == 0.1); basValRelease(&res); BasValueT txt = basValStringFromC("hello"); checkTrue("public variable", basVmCallMember(vm, obj, "Caption", BAS_MEMBER_OP_LET, &txt, 1, NULL) && basVmCallMember(vm, obj, "Caption", BAS_MEMBER_OP_GET, NULL, 0, &res) && res.type == BAS_TYPE_STRING && strcmp(res.strVal->data, "hello") == 0); basValRelease(&res); basValRelease(&txt); BasValueT idx = basValInteger(3); checkTrue("method raising an event: the host writes back the ByRef argument", basVmCallMember(vm, obj, "Open", BAS_MEMBER_OP_GET, &idx, 1, &res) && hostCalls == 1 && res.type == BAS_TYPE_STRING && strcmp(res.strVal->data, "item3") == 0); basValRelease(&res); checkTrue("unknown member fails", !basVmCallMember(vm, obj, "Nope", BAS_MEMBER_OP_GET, NULL, 0, &res)); vm->errorNumber = 0; vm->errorMsg[0] = '\0'; BasValueT mouse[4]; mouse[0] = basValInteger(1); mouse[1] = basValInteger(0); mouse[2] = basValSingle(7.0f); mouse[3] = basValSingle(9.0f); captureReset(&cap); checkTrue("MouseDown handler", basVmCallProc(vm, obj, cls->ucProcs[BAS_UC_EVT_MOUSEDOWN], mouse, 4, NULL, 0) && strcmp(cap.buf, "down1 7 \n") == 0); basObjectUnref(obj); } basVmDestroy(vm); basModuleFree(mod); expectCompileError("UserControl: a handler with the wrong parameters", "BEGINCLASS \"C\" USERCONTROL\n" "Private Sub UserControl_KeyDown(KeyCode AS INTEGER)\n" "End Sub\n" "ENDCLASS\n", "UserControl_KeyDown must be a Sub with 2 parameter(s)"); // Enum-typed properties (the module's Enum table; also a fuzz seed) runProgram("UserControl: Enum properties", "Enum ShapeE\n" " Square\n" " Circle\n" "End Enum\n" "BEGINCLASS \"Shaped\" USERCONTROL\n" "Public Look AS ShapeE\n" "Public Property Get Kind() AS ShapeE\n" " Kind = Look\n" "End Property\n" "Public Property Let Kind(v AS ShapeE)\n" " Look = v\n" "End Property\n" "ENDCLASS\n" "PRINT Circle; ShapeE.Square\n", "1 0 \n"); } // The test's event host: counts the calls and answers ItemOpen by // appending the index to the ByRef name. static void ucEventHost(void *ctx, const BasObjectT *obj, int32_t eventIdx, BasValueT *args, int32_t argc) { (void)obj; (*(int32_t *)ctx)++; if (eventIdx == 0 && argc == 2 && args[1].type == BAS_TYPE_STRING) { char text[TEST_ROW_TEXT_LEN]; snprintf(text, sizeof(text), "%s%" PRId32, args[1].strVal->data, basValToInt32(args[0])); basValRelease(&args[1]); args[1] = basValStringFromC(text); } } int main(void) { printf("DVX BASIC Compiler Tests\n"); printf("========================\n\n"); // Test 1: Hello World runProgram("Hello World", "PRINT \"Hello, World!\"\n", "Hello, World!\n" ); // Test 2: Arithmetic runProgram("Arithmetic", "PRINT 2 + 3 * 4\n" "PRINT 10 \\ 3\n" "PRINT 10 MOD 3\n" "PRINT 2 ^ 8\n", "14 \n3 \n1 \n256 \n" ); // Test 3: String operations runProgram("String Ops", "DIM s AS STRING\n" "s = \"Hello, BASIC!\"\n" "PRINT s\n" "PRINT LEN(s)\n" "PRINT LEFT$(s, 5)\n" "PRINT RIGHT$(s, 6)\n" "PRINT MID$(s, 8, 5)\n" "PRINT UCASE$(s)\n", "Hello, BASIC!\n13 \nHello\nBASIC!\nBASIC\nHELLO, BASIC!\n" ); // Test 4: IF/THEN/ELSE runProgram("IF/THEN/ELSE", "DIM x AS INTEGER\n" "x = 42\n" "IF x > 100 THEN\n" " PRINT \"big\"\n" "ELSEIF x > 10 THEN\n" " PRINT \"medium\"\n" "ELSE\n" " PRINT \"small\"\n" "END IF\n", "medium\n" ); // Test 5: FOR loop runProgram("FOR Loop", "DIM i AS INTEGER\n" "FOR i = 1 TO 10\n" " PRINT i;\n" "NEXT i\n" "PRINT\n", "1 2 3 4 5 6 7 8 9 10 \n" ); // Test 6: DO/WHILE loop runProgram("DO/WHILE Loop", "DIM n AS INTEGER\n" "n = 1\n" "DO WHILE n <= 5\n" " PRINT n;\n" " n = n + 1\n" "LOOP\n" "PRINT\n", "1 2 3 4 5 \n" ); // Test 7: SUB and FUNCTION runProgram("SUB and FUNCTION", "DECLARE SUB Greet(who AS STRING)\n" "DECLARE FUNCTION Square(x AS INTEGER) AS INTEGER\n" "\n" "CALL Greet(\"World\")\n" "PRINT Square(7)\n" "\n" "SUB Greet(who AS STRING)\n" " PRINT \"Hello, \" & who & \"!\"\n" "END SUB\n" "\n" "FUNCTION Square(x AS INTEGER) AS INTEGER\n" " Square = x * x\n" "END FUNCTION\n", "Hello, World!\n49 \n" ); // Test 8: SELECT CASE runProgram("SELECT CASE", "DIM grade AS STRING\n" "grade = \"B\"\n" "SELECT CASE grade\n" " CASE \"A\"\n" " PRINT \"Excellent\"\n" " CASE \"B\", \"C\"\n" " PRINT \"Good\"\n" " CASE ELSE\n" " PRINT \"Other\"\n" "END SELECT\n", "Good\n" ); // Test 9: Fibonacci runProgram("Fibonacci", "DIM a AS INTEGER\n" "DIM b AS INTEGER\n" "DIM temp AS INTEGER\n" "DIM i AS INTEGER\n" "a = 0\n" "b = 1\n" "FOR i = 1 TO 10\n" " PRINT a;\n" " temp = a + b\n" " a = b\n" " b = temp\n" "NEXT i\n" "PRINT\n", "0 1 1 2 3 5 8 13 21 34 \n" ); // Test 10: Math functions runProgram("Math Functions", "PRINT ABS(-42)\n" "PRINT SQR(144)\n" "PRINT INT(3.7)\n", "42 \n12 \n3 \n" ); // Test 11: File I/O runProgram("File I/O", "OPEN \"/tmp/dvxbasic_test.txt\" FOR OUTPUT AS #1\n" "PRINT #1, \"Hello from BASIC!\"\n" "PRINT #1, \"Line two\"\n" "PRINT #1, \"42\"\n" "CLOSE #1\n" "\n" "DIM line$ AS STRING\n" "DIM count AS INTEGER\n" "count = 0\n" "OPEN \"/tmp/dvxbasic_test.txt\" FOR INPUT AS #1\n" "DO WHILE NOT EOF(#1)\n" " INPUT #1, line$\n" " PRINT line$\n" " count = count + 1\n" "LOOP\n" "CLOSE #1\n" "PRINT count;\n" "PRINT \"lines read\"\n", "Hello from BASIC!\nLine two\n42\n3 lines read\n" ); // Test 12: LINE INPUT# and APPEND runProgram("LINE INPUT and APPEND", "OPEN \"/tmp/dvxbasic_test2.txt\" FOR OUTPUT AS #2\n" "PRINT #2, \"First line\"\n" "CLOSE #2\n" "\n" "OPEN \"/tmp/dvxbasic_test2.txt\" FOR APPEND AS #2\n" "PRINT #2, \"Appended line\"\n" "CLOSE #2\n" "\n" "DIM s$ AS STRING\n" "OPEN \"/tmp/dvxbasic_test2.txt\" FOR INPUT AS #2\n" "LINE INPUT #2, s$\n" "PRINT s$\n" "LINE INPUT #2, s$\n" "PRINT s$\n" "CLOSE #2\n", "First line\nAppended line\n" ); // Test 13: Array -- 1D with default lbound=0 runProgram("1D Array", "DIM arr(5) AS INTEGER\n" "DIM i AS INTEGER\n" "FOR i = 1 TO 5\n" " arr(i) = i * i\n" "NEXT i\n" "FOR i = 1 TO 5\n" " PRINT arr(i);\n" "NEXT i\n" "PRINT\n", "1 4 9 16 25 \n" ); // Expected: 1 4 9 16 25 // Test 14: Multi-dimensional array runProgram("Multi-dim Array", "DIM m(2, 2) AS INTEGER\n" "m(1, 1) = 11\n" "m(1, 2) = 12\n" "m(2, 1) = 21\n" "m(2, 2) = 22\n" "PRINT m(1, 1); m(1, 2); m(2, 1); m(2, 2)\n", "11 12 21 22 \n" ); // Expected: 11 12 21 22 // Test 15: Array with explicit bounds (TO syntax) runProgram("Array with TO bounds", "DIM a(1 TO 3) AS INTEGER\n" "a(1) = 10\n" "a(2) = 20\n" "a(3) = 30\n" "PRINT a(1); a(2); a(3)\n", "10 20 30 \n" ); // Expected: 10 20 30 // Test 16: LBOUND and UBOUND runProgram("LBOUND/UBOUND", "DIM a(5 TO 10) AS INTEGER\n" "PRINT LBOUND(a); UBOUND(a)\n", "5 10 \n" ); // Expected: 5 10 // Test 17: User-defined TYPE runProgram("TYPE", "TYPE Point\n" " x AS INTEGER\n" " y AS INTEGER\n" "END TYPE\n" "DIM p AS Point\n" "p.x = 10\n" "p.y = 20\n" "PRINT p.x; p.y\n", "10 20 \n" ); // Expected: 10 20 // Test 18: String array runProgram("String Array", "DIM names(3) AS STRING\n" "names(0) = \"Alice\"\n" "names(1) = \"Bob\"\n" "names(2) = \"Charlie\"\n" "DIM i AS INTEGER\n" "FOR i = 0 TO 2\n" " PRINT names(i)\n" "NEXT i\n", "Alice\nBob\nCharlie\n" ); // Expected: Alice / Bob / Charlie // Test 19: REDIM with PRESERVE runProgram("REDIM PRESERVE", "DIM a(3) AS INTEGER\n" "a(0) = 100\n" "a(1) = 200\n" "a(2) = 300\n" "REDIM PRESERVE a(5) AS INTEGER\n" "a(4) = 500\n" "PRINT a(0); a(1); a(2); a(4)\n", "100 200 300 500 \n" ); // Expected: 100 200 300 500 // Test 20: ERASE runProgram("ERASE", "DIM a(3) AS INTEGER\n" "a(1) = 42\n" "ERASE a\n" "DIM b(2) AS INTEGER\n" "b(1) = 99\n" "PRINT b(1)\n", "99 \n" ); // Expected: 99 // Test 21: Array in FOR loop accumulation runProgram("Array Accumulation", "DIM sums(5) AS INTEGER\n" "DIM i AS INTEGER\n" "DIM j AS INTEGER\n" "FOR i = 1 TO 5\n" " sums(i) = 0\n" " FOR j = 1 TO i\n" " sums(i) = sums(i) + j\n" " NEXT j\n" "NEXT i\n" "FOR i = 1 TO 5\n" " PRINT sums(i);\n" "NEXT i\n" "PRINT\n", "1 3 6 10 15 \n" ); // Expected: 1 3 6 10 15 // ============================================================ // Batch 1: Control Flow // ============================================================ // Test: GOTO with forward jump runProgram("GOTO Forward", "PRINT \"before\"\n" "GOTO skip\n" "PRINT \"skipped\"\n" "skip:\n" "PRINT \"after\"\n", "before\nafter\n" ); // Expected: before / after // Test: GOTO with backward jump runProgram("GOTO Backward", "DIM n AS INTEGER\n" "n = 0\n" "top:\n" "n = n + 1\n" "IF n < 5 THEN GOTO top\n" "PRINT n\n", "5 \n" ); // Expected: 5 // Test: GOSUB/RETURN runProgram("GOSUB/RETURN", "DIM x AS INTEGER\n" "x = 10\n" "GOSUB dbl\n" "PRINT x\n" "END\n" "dbl:\n" "x = x * 2\n" "RETURN\n", "20 \n" ); // Expected: 20 // Test: ON ERROR GOTO -- verify error handler catches errors // and ERR returns the error number runProgram("ON ERROR GOTO", "ON ERROR GOTO handler\n" "PRINT 10 / 0\n" "END\n" "handler:\n" "PRINT \"caught\"\n" "PRINT ERR\n", "caught\n11 \n" ); // Expected: caught / 11 // Test: Single-line IF runProgram("Single-line IF", "DIM x AS INTEGER\n" "x = 42\n" "IF x > 10 THEN PRINT \"big\"\n" "IF x < 10 THEN PRINT \"small\"\n" "IF x = 42 THEN PRINT \"exact\" ELSE PRINT \"nope\"\n", "big\nexact\n" ); // Expected: big / exact // Test: Multi-statement line with : runProgram("Multi-statement :", "DIM x AS INTEGER\n" "DIM y AS INTEGER\n" "x = 1 : y = 2 : PRINT x + y\n", "3 \n" ); // Expected: 3 // ============================================================ // Batch 2: Misc Features // ============================================================ // Test: SWAP runProgram("SWAP", "DIM a AS INTEGER\n" "DIM b AS INTEGER\n" "a = 10\n" "b = 20\n" "SWAP a, b\n" "PRINT a;\n" "PRINT b\n", "20 10 \n" ); // Expected: 20 10 // Test: TIMER (returns number > 0) runProgram("TIMER", "DIM t AS DOUBLE\n" "t = TIMER\n" "IF t > 0 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // Test: DATE$ (returns non-empty string) runProgram("DATE$", "DIM d$ AS STRING\n" "d$ = DATE$\n" "IF LEN(d$) > 0 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // Test: TIME$ (returns non-empty string) runProgram("TIME$", "DIM t$ AS STRING\n" "t$ = TIME$\n" "IF LEN(t$) > 0 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // Test: ENVIRON$ runProgram("ENVIRON$", "DIM p$ AS STRING\n" "p$ = ENVIRON$(\"HOME\")\n" "IF LEN(p$) > 0 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // ============================================================ // Batch 3: New features (DATA/READ/RESTORE, DIM SHARED, // STATIC, DEF FN, OPTION BASE) // ============================================================ // Test: DATA/READ/RESTORE runProgram("DATA/READ/RESTORE", "DATA 10, 20, \"hello\"\n" "DIM a AS INTEGER\n" "DIM b AS INTEGER\n" "DIM c AS STRING\n" "READ a, b, c\n" "PRINT a; b;\n" "PRINT c\n" "RESTORE\n" "READ a\n" "PRINT a\n", "10 20 hello\n10 \n" ); // Expected: 10 20 hello / 10 // Test: DIM SHARED runProgram("DIM SHARED", "DIM SHARED count AS INTEGER\n" "count = 0\n" "CALL Increment\n" "CALL Increment\n" "CALL Increment\n" "PRINT count\n" "SUB Increment\n" " count = count + 1\n" "END SUB\n", "3 \n" ); // Expected: 3 // Test: STATIC runProgram("STATIC", "CALL Counter\n" "CALL Counter\n" "CALL Counter\n" "SUB Counter\n" " STATIC n AS INTEGER\n" " n = n + 1\n" " PRINT n;\n" "END SUB\n" "PRINT\n", "1 2 3 \n" ); // Expected: 1 2 3 // Test: DEF FN runProgram("DEF FN", "DEF FNdouble(x AS INTEGER) = x * 2\n" "PRINT FNdouble(5)\n" "PRINT FNdouble(21)\n", "10 \n42 \n" ); // Expected: 10 / 42 // Test: OPTION BASE runProgram("OPTION BASE", "OPTION BASE 1\n" "DIM arr(3) AS INTEGER\n" "arr(1) = 10\n" "arr(3) = 30\n" "PRINT arr(1); arr(3)\n", "10 30 \n" ); // Expected: 10 30 // Test: DATA with mixed types runProgram("DATA mixed types", "DATA 100, 3.14, \"world\"\n" "DIM x AS INTEGER\n" "DIM y AS DOUBLE\n" "DIM z AS STRING\n" "READ x, y, z\n" "PRINT x\n" "PRINT z\n", "100 \nworld\n" ); // Expected: 100 / world // Test: Multiple DATA statements scattered runProgram("DATA scattered", "DIM a AS INTEGER\n" "DIM b AS INTEGER\n" "DIM c AS INTEGER\n" "DATA 1, 2\n" "READ a, b\n" "DATA 3\n" "READ c\n" "PRINT a; b; c\n", "1 2 3 \n" ); // Expected: 1 2 3 // Test: DIM SHARED with SUB modifying shared variable runProgram("DIM SHARED multi", "DIM SHARED total AS INTEGER\n" "DIM SHARED msg AS STRING\n" "total = 100\n" "msg = \"start\"\n" "CALL Modify\n" "PRINT total\n" "PRINT msg\n" "SUB Modify\n" " total = total + 50\n" " msg = \"done\"\n" "END SUB\n", "150 \ndone\n" ); // Expected: 150 / done // ============================================================ // Batch 4: New I/O and string features // ============================================================ // Test: WRITE # runProgram("WRITE #", "OPEN \"/tmp/dvxbasic_write.txt\" FOR OUTPUT AS #1\n" "WRITE #1, 10, \"hello\", 3.14\n" "CLOSE #1\n" "OPEN \"/tmp/dvxbasic_write.txt\" FOR INPUT AS #1\n" "DIM s AS STRING\n" "LINE INPUT #1, s\n" "PRINT s\n" "CLOSE #1\n", "10,\"hello\",3.14\n" ); // Expected: 10,"hello",3.14 // Test: FREEFILE runProgram("FREEFILE", "DIM f AS INTEGER\n" "f = FREEFILE\n" "PRINT f\n", "1 \n" ); // Expected: 1 // Test: PRINT USING numeric runProgram("PRINT USING numeric", "PRINT USING \"###.##\"; 3.14159\n", " 3.14\n" ); // Expected: 3.14 // Test: PRINT USING string runProgram("PRINT USING string", "PRINT USING \"!\"; \"Hello\"\n", "H\n" ); // Expected: H // Test: SPC and TAB in PRINT runProgram("SPC/TAB", "PRINT SPC(3); \"hi\"\n", " hi\n" ); // Expected: hi // Test: Fixed-length string runProgram("STRING * n", "DIM s AS STRING * 5\n" "s = \"Hi\"\n" "PRINT \"[\" & s & \"]\"\n" "PRINT LEN(s)\n", "[Hi ]\n5 \n" ); // Expected: [Hi ] / 5 // Test: MID$ statement runProgram("MID$ statement", "DIM s AS STRING\n" "s = \"Hello World\"\n" "MID$(s, 7, 5) = \"BASIC\"\n" "PRINT s\n", "Hello BASIC\n" ); // Expected: Hello BASIC // Test: OPEN FOR BINARY / GET / PUT runProgram("BINARY GET/PUT", "DIM v AS INTEGER\n" "OPEN \"/tmp/dvxbasic_bin.tmp\" FOR BINARY AS #1\n" "v = 12345\n" "PUT #1, , v\n" "SEEK #1, 1\n" "DIM r AS INTEGER\n" "GET #1, , r\n" "PRINT r\n" "CLOSE #1\n", "12345 \n" ); // Expected: 12345 // Test: LOF and LOC runProgram("LOF/LOC", "OPEN \"/tmp/dvxbasic_lof.txt\" FOR OUTPUT AS #1\n" "PRINT #1, \"test\"\n" "CLOSE #1\n" "OPEN \"/tmp/dvxbasic_lof.txt\" FOR INPUT AS #1\n" "DIM sz AS LONG\n" "sz = LOF(1)\n" "IF sz > 0 THEN PRINT \"ok\"\n" "CLOSE #1\n", "ok\n" ); // Expected: ok // Test: INPUT$(n, #channel) runProgram("INPUT$", "OPEN \"/tmp/dvxbasic_inp.txt\" FOR OUTPUT AS #1\n" "PRINT #1, \"ABCDEF\"\n" "CLOSE #1\n" "OPEN \"/tmp/dvxbasic_inp.txt\" FOR INPUT AS #1\n" "DIM s AS STRING\n" "s = INPUT$(3, #1)\n" "PRINT s\n" "CLOSE #1\n", "ABC\n" ); // Expected: ABC // Test: SEEK function form runProgram("SEEK function", "OPEN \"/tmp/dvxbasic_seek.txt\" FOR OUTPUT AS #1\n" "PRINT #1, \"test\"\n" "CLOSE #1\n" "OPEN \"/tmp/dvxbasic_seek.txt\" FOR BINARY AS #1\n" "DIM p AS LONG\n" "p = SEEK(1)\n" "IF p = 1 THEN PRINT \"ok\"\n" "CLOSE #1\n", "ok\n" ); // Expected: ok // Test: ON n GOTO runProgram("ON n GOTO", "DIM n AS INTEGER\n" "n = 2\n" "ON n GOTO ten, twenty, thirty\n" "PRINT \"none\"\n" "GOTO done\n" "ten:\n" "PRINT \"ten\"\n" "GOTO done\n" "twenty:\n" "PRINT \"twenty\"\n" "GOTO done\n" "thirty:\n" "PRINT \"thirty\"\n" "done:\n", "twenty\n" ); // Expected: twenty // Test: ON n GOTO (no match) runProgram("ON n GOTO no match", "DIM n AS INTEGER\n" "n = 5\n" "ON n GOTO aa, bb\n" "PRINT \"fallthrough\"\n" "GOTO done2\n" "aa:\n" "PRINT \"aa\"\n" "GOTO done2\n" "bb:\n" "PRINT \"bb\"\n" "done2:\n", "fallthrough\n" ); // Expected: fallthrough // Test: ON n GOSUB runProgram("ON n GOSUB", "DIM n AS INTEGER\n" "DIM result AS INTEGER\n" "result = 0\n" "n = 2\n" "ON n GOSUB addTen, addTwenty, addThirty\n" "PRINT result\n" "GOTO endProg\n" "addTen:\n" "result = result + 10\n" "RETURN\n" "addTwenty:\n" "result = result + 20\n" "RETURN\n" "addThirty:\n" "result = result + 30\n" "RETURN\n" "endProg:\n", "20 \n" ); // Expected: 20 // Test: FORMAT$ runProgram("FORMAT$", "PRINT FORMAT$(1234.5, \"#,##0.00\")\n" "PRINT FORMAT$(0.5, \"0.00\")\n" "PRINT FORMAT$(-42, \"+#0\")\n" "PRINT FORMAT$(0.75, \"percent\")\n", "1,234.50\n0.50\n-42\n75%\n" ); // Expected: 1,234.50\n0.50\n-42\n75% // Test: SHELL as function expression runProgram("SHELL function", "DIM r AS INTEGER\n" "r = SHELL(\"echo hello > /dev/null\")\n" "IF r = 0 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // Test: SHELL as statement runProgram("SHELL statement", "SHELL \"echo hello > /dev/null\"\n" "PRINT \"done\"\n", "done\n" ); // Expected: done // Test: OPTION COMPARE TEXT runProgram("OPTION COMPARE TEXT", "OPTION COMPARE TEXT\n" "IF \"hello\" = \"HELLO\" THEN\n" " PRINT \"equal\"\n" "ELSE\n" " PRINT \"not equal\"\n" "END IF\n" "IF \"abc\" < \"XYZ\" THEN\n" " PRINT \"less\"\n" "END IF\n", "equal\nless\n" ); // Expected: equal\nless // Test: OPTION COMPARE BINARY (default) runProgram("OPTION COMPARE BINARY", "OPTION COMPARE BINARY\n" "IF \"hello\" = \"HELLO\" THEN\n" " PRINT \"equal\"\n" "ELSE\n" " PRINT \"not equal\"\n" "END IF\n", "not equal\n" ); // Expected: not equal // Test: EQV operator runProgram("EQV operator", "PRINT -1 EQV -1\n" "PRINT 0 EQV 0\n" "PRINT -1 EQV 0\n" "PRINT 0 EQV -1\n", "-1 \n-1 \n0 \n0 \n" ); // Expected: -1\n-1\n0\n0 // Test: IMP operator runProgram("IMP operator", "PRINT 0 IMP -1\n" "PRINT -1 IMP 0\n" "PRINT -1 IMP -1\n" "PRINT 0 IMP 0\n", "-1 \n0 \n-1 \n-1 \n" ); // Expected: -1\n0\n-1\n-1 // Test: PRINT USING advanced patterns runProgram("PRINT USING advanced", "PRINT USING \"**#,##0.00\"; 1234.5\n" "PRINT USING \"$$#,##0.00\"; 42.5\n" "PRINT USING \"+###.##\"; 42.5\n" "PRINT USING \"+###.##\"; -42.5\n" "PRINT USING \"###.##-\"; -42.5\n" "PRINT USING \"###.##-\"; 42.5\n" "PRINT USING \"#.##^^^^\"; 1234.5\n", "**1,234.50\n $42.50\n +42.50\n -42.50\n 42.50-\n 42.50 \n1.23E+03\n" ); // Test: DEFINT -- every A-Z variable is INTEGER, so 3.7 rounds on store runProgram("DEFINT", "DEFINT A-Z\n" "a = 42\n" "b = 3.7\n" "PRINT a; b\n", "42 4 \n" ); // Test: DEFSTR runProgram("DEFSTR", "DEFSTR S\n" "s = \"hello\"\n" "PRINT s\n", "hello\n" ); // Test: DEFINT range runProgram("DEFINT range", "DEFINT I-N\n" "i = 10\n" "j = 20\n" "x = 3.14\n" "PRINT i; j; x\n", "10 20 3.14 \n" ); // Test: OPTION EXPLICIT success runProgram("OPTION EXPLICIT ok", "OPTION EXPLICIT\n" "DIM x AS INTEGER\n" "x = 42\n" "PRINT x\n", "42 \n" ); // Test: OPTION EXPLICIT failure (should error) expectCompileError("OPTION EXPLICIT error", "OPTION EXPLICIT\n" "x = 42\n", "Variable not declared: x" ); // Test: DECLARE LIBRARY compilation (verify it compiles without error) { printf("=== DECLARE LIBRARY ===\n"); const char *src = "DECLARE LIBRARY \"serial\"\n" " DECLARE FUNCTION rs232Open(com AS INTEGER, bps AS LONG) AS INTEGER\n" " DECLARE SUB rs232Close(com AS INTEGER)\n" "END DECLARE\n" "\n" "PRINT \"Library declared\"\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); bool ok = basCompile(compiler); if (!ok) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { BasModuleT *mod = basCompilerBuildModule(compiler); if (mod) { BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); basVmRun(vm); basVmDestroy(vm); basModuleFree(mod); } } basCompilerDestroy(compiler); printf("\n"); } // Test: DECLARE LIBRARY with extern call (uses mock callback) { printf("=== DECLARE LIBRARY call ===\n"); const char *src = "DECLARE LIBRARY \"math\"\n" " DECLARE FUNCTION mathAdd(a AS INTEGER, b AS INTEGER) AS INTEGER\n" "END DECLARE\n" "\n" "DIM result AS INTEGER\n" "result = mathAdd(10, 20)\n" "PRINT result\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); bool ok = basCompile(compiler); if (!ok) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("Compiled OK (extern call test needs host callbacks to run)\n"); } basCompilerDestroy(compiler); printf("\n"); } // Regression test: App.Data must parse even though Data is a BASIC keyword runProgram("App.Data parses", "DIM p AS STRING\n" "p = App.Data\n" "PRINT p\n", "\n" ); // Regression test: RGB(r,g,b) packs into 0x00RRGGBB runProgram("RGB packing", "PRINT RGB(255, 128, 0)\n" "PRINT RGB(0, 255, 0)\n" "PRINT RGB(0, 0, 255)\n", "33023 \n65280 \n16711680 \n" ); // Expected (VB's &HBBGGRR): 33023 (&H80FF), 65280 (&HFF00), 16711680 (&HFF0000) // Regression test: GetRed/Green/Blue round-trip runProgram("RGB round-trip", "DIM c AS LONG\n" "c = RGB(17, 99, 200)\n" "PRINT GetRed(c); GetGreen(c); GetBlue(c)\n", "17 99 200 \n" ); // Expected: 17 99 200 // Regression test: MsgBox function accepts optional title (3rd arg) // The test harness's default msgBox callback returns 1; we just verify // the program compiles and runs. runProgram("MsgBox 3-arg compile", "DIM r AS INTEGER\n" "r = MsgBox(\"hi\", 0, \"My Title\")\n" "PRINT \"ok\"\n", "ok\n" ); // Regression test: CONST accepts AS type runProgram("CONST AS type", "CONST PI AS DOUBLE = 3.14159\n" "CONST N AS INTEGER = 42\n" "PRINT PI\n" "PRINT N\n", "3.14159 \n42 \n" ); // Regression test: PRINT #ch with ; separator runProgram("PRINT # with semicolon", "OPEN \"/tmp/dvxbasic_psemi.txt\" FOR OUTPUT AS #1\n" "PRINT #1, \"Line one\"\n" "PRINT #1, \"ans = \"; 42\n" "PRINT #1, \"x\"; \"y\"; \"z\"\n" "CLOSE #1\n" "DIM s AS STRING\n" "OPEN \"/tmp/dvxbasic_psemi.txt\" FOR INPUT AS #1\n" "DO WHILE NOT EOF(1)\n" " LINE INPUT #1, s\n" " PRINT s\n" "LOOP\n" "CLOSE #1\n", "Line one\nans = 42 \nxyz\n" ); // Expected: Line one / ans = 42 (numbers carry QB's trailing space) / xyz // Regression test: IniRead$ with $ suffix must tokenize as keyword runProgram("IniRead$ tokenizes", "DIM v AS STRING\n" "v = IniRead$(\"/tmp/nofile.ini\", \"S\", \"K\", \"default\")\n" "PRINT v\n", "default\n" ); // Expected: default (file doesn't exist) // Regression test: SUB extern call without parens must emit OP_CALL_EXTERN // (previously emitted OP_CALL which called nothing, because no internal // proc at address 0 existed for the extern.) { printf("=== DECLARE LIBRARY SUB no-parens ===\n"); const char *src = "DECLARE LIBRARY \"basrt\"\n" " DECLARE SUB DoIt(BYVAL s AS STRING)\n" "END DECLARE\n" "DoIt \"hello\"\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); bool ok = basCompile(compiler); if (!ok) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { BasModuleT *mod = basCompilerBuildModule(compiler); if (mod) { bool found = false; for (int32_t i = 0; i < mod->codeLen; i++) { if (mod->code[i] == OP_CALL_EXTERN) { found = true; break; } } printf(found ? "PASS: OP_CALL_EXTERN emitted\n" : "FAIL: OP_CALL_EXTERN not emitted\n"); if (!found) { gFailCount++; } basModuleFree(mod); } else { printf("MODULE BUILD FAILED\n"); gFailCount++; } } basCompilerDestroy(compiler); printf("\n"); } // Test: Procedure table populated for SUBs and FUNCTIONs { printf("=== Procedure table ===\n"); const char *src = "SUB Command1_Click\n" " PRINT \"Clicked!\"\n" "END SUB\n" "\n" "SUB Form1_Load\n" " PRINT \"Loaded\"\n" "END SUB\n" "\n" "FUNCTION AddNums(a AS INTEGER, b AS INTEGER) AS INTEGER\n" " AddNums = a + b\n" "END FUNCTION\n" "\n" "PRINT \"main\"\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); bool ok = basCompile(compiler); if (!ok) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { BasModuleT *mod = basCompilerBuildModule(compiler); printf("procCount = %d\n", mod->procCount); for (int32_t i = 0; i < mod->procCount; i++) { printf(" [%d] %s addr=%d params=%d func=%d\n", i, mod->procs[i].name, mod->procs[i].codeAddr, mod->procs[i].paramCount, mod->procs[i].isFunction); } // Test lookup const BasProcEntryT *p = basModuleFindProc(mod, "command1_click"); if (p) { printf("Found Command1_Click at addr %d\n", p->codeAddr); } else { printf("FAIL: Command1_Click not found!\n"); gFailCount++; } p = basModuleFindProc(mod, "FORM1_LOAD"); if (p) { printf("Found Form1_Load at addr %d\n", p->codeAddr); } else { printf("FAIL: Form1_Load not found!\n"); gFailCount++; } // Test basVmCallSub BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); p = basModuleFindProc(mod, "Command1_Click"); if (p) { printf("Calling Command1_Click via basVmCallSub: "); bool callOk = basVmCallSub(vm, p->codeAddr); printf("result=%s\n", callOk ? "ok" : "FAIL"); if (!callOk) { gFailCount++; } } basVmDestroy(vm); basModuleFree(mod); } basCompilerDestroy(compiler); printf("\n"); } // ByRef parameters runProgram("ByRef parameters", "DECLARE SUB AddTen(n AS INTEGER)\n" "DECLARE SUB ChangeStr(s AS STRING)\n" "DECLARE SUB NoChange(BYVAL n AS INTEGER)\n" "\n" "DIM x AS INTEGER\n" "x = 10\n" "PRINT \"Before: x =\"; x\n" "AddTen x\n" "PRINT \"After AddTen: x =\"; x\n" "\n" "DIM a AS STRING\n" "a = \"hello\"\n" "PRINT \"Before: a = \"; a\n" "ChangeStr a\n" "PRINT \"After ChangeStr: a = \"; a\n" "\n" "' ByVal should NOT modify caller\n" "DIM y AS INTEGER\n" "y = 100\n" "PRINT \"Before: y =\"; y\n" "NoChange y\n" "PRINT \"After NoChange: y =\"; y\n" "\n" "' Expression arg to ByRef param: effectively ByVal\n" "DIM z AS INTEGER\n" "z = 5\n" "AddTen(z + 0)\n" "PRINT \"After AddTen(z+0): z =\"; z\n" "\n" "SUB AddTen(n AS INTEGER)\n" " n = n + 10\n" "END SUB\n" "\n" "SUB ChangeStr(s AS STRING)\n" " s = s + \" world\"\n" "END SUB\n" "\n" "SUB NoChange(BYVAL n AS INTEGER)\n" " n = n + 999\n" "END SUB\n", "Before: x =10 \nAfter AddTen: x =20 \nBefore: a = hello\nAfter ChangeStr: a = hello world\nBefore: y =100 \nAfter NoChange: y =100 \nAfter AddTen(z+0): z =5 \n" ); // ============================================================ // Coverage: String functions // ============================================================ runProgram("LCASE$", "PRINT LCASE$(\"HELLO WORLD\")\n", "hello world\n" ); // Expected: hello world runProgram("TRIM$ LTRIM$ RTRIM$", "PRINT \"[\" & TRIM$(\" hi \") & \"]\"\n" "PRINT \"[\" & LTRIM$(\" hi \") & \"]\"\n" "PRINT \"[\" & RTRIM$(\" hi \") & \"]\"\n", "[hi]\n[hi ]\n[ hi]\n" ); // Expected: [hi] / [hi ] / [ hi] runProgram("INSTR 2-arg", "PRINT INSTR(\"hello world\", \"world\")\n" "PRINT INSTR(\"hello world\", \"xyz\")\n", "7 \n0 \n" ); // Expected: 7 / 0 runProgram("INSTR 3-arg", "PRINT INSTR(5, \"abcabc\", \"bc\")\n" "PRINT INSTR(1, \"abcabc\", \"bc\")\n", "5 \n2 \n" ); // Expected: 5 / 2 runProgram("CHR$ and ASC", "PRINT CHR$(65)\n" "PRINT ASC(\"Z\")\n", "A\n90 \n" ); // Expected: A / 90 runProgram("SPACE$", "PRINT \"[\" & SPACE$(5) & \"]\"\n", "[ ]\n" ); // Expected: [ ] runProgram("STRING$", "PRINT STRING$(5, \"*\")\n", "*****\n" ); // Expected: ***** runProgram("HEX$", "PRINT HEX$(255)\n" "PRINT HEX$(16)\n", "FF\n10\n" ); // Expected: FF / 10 runProgram("VAL", "PRINT VAL(\"3.14\")\n" "PRINT VAL(\"42\")\n" "PRINT VAL(\"abc\")\n", "3.14 \n42 \n0 \n" ); // Expected: 3.14 / 42 / 0 runProgram("STR$", "PRINT \"[\" & STR$(42) & \"]\"\n" "PRINT \"[\" & STR$(-7) & \"]\"\n", "[ 42]\n[-7]\n" ); // Expected: [ 42] / [-7] runProgram("MID$ 2-arg", "PRINT MID$(\"hello world\", 7)\n", "world\n" ); // Expected: world runProgram("String concat with +", "DIM a AS STRING\n" "DIM b AS STRING\n" "a = \"hello\"\n" "b = \" world\"\n" "PRINT a + b\n", "hello world\n" ); // Expected: hello world // ============================================================ // Coverage: Math functions // ============================================================ runProgram("Trig functions", "DIM pi AS DOUBLE\n" "pi = ATN(1) * 4\n" "PRINT INT(SIN(pi / 2) * 1000)\n" "PRINT INT(COS(0) * 1000)\n" "PRINT INT(TAN(pi / 4) * 1000)\n", "1000 \n1000 \n999 \n" ); // Expected: 1000 / 1000 / 999 (TAN(pi/4)*1000 is 999.99..., INT truncates) runProgram("LOG and EXP", "PRINT INT(LOG(1))\n" "PRINT INT(EXP(0))\n" "PRINT INT(EXP(1) * 100)\n", "0 \n1 \n271 \n" ); // Expected: 0 / 1 / 271 runProgram("FIX and SGN", "PRINT FIX(3.7)\n" "PRINT FIX(-3.7)\n" "PRINT SGN(42)\n" "PRINT SGN(-5)\n" "PRINT SGN(0)\n", "3 \n-3 \n1 \n-1 \n0 \n" ); // Expected: 3 / -3 / 1 / -1 / 0 runProgram("RND and RANDOMIZE", "RANDOMIZE 12345\n" "DIM r AS DOUBLE\n" "r = RND\n" "IF r >= 0 AND r < 1 THEN PRINT \"ok\"\n", "ok\n" ); // Expected: ok // ============================================================ // Coverage: Loop variants // ============================================================ runProgram("DO UNTIL pre-test", "DIM n AS INTEGER\n" "n = 1\n" "DO UNTIL n > 5\n" " PRINT n;\n" " n = n + 1\n" "LOOP\n" "PRINT\n", "1 2 3 4 5 \n" ); // Expected: 1 2 3 4 5 runProgram("DO LOOP WHILE post-test", "DIM n AS INTEGER\n" "n = 1\n" "DO\n" " PRINT n;\n" " n = n + 1\n" "LOOP WHILE n <= 5\n" "PRINT\n", "1 2 3 4 5 \n" ); // Expected: 1 2 3 4 5 runProgram("DO LOOP UNTIL post-test", "DIM n AS INTEGER\n" "n = 1\n" "DO\n" " PRINT n;\n" " n = n + 1\n" "LOOP UNTIL n > 5\n" "PRINT\n", "1 2 3 4 5 \n" ); // Expected: 1 2 3 4 5 runProgram("WHILE WEND", "DIM n AS INTEGER\n" "n = 1\n" "WHILE n <= 5\n" " PRINT n;\n" " n = n + 1\n" "WEND\n" "PRINT\n", "1 2 3 4 5 \n" ); // Expected: 1 2 3 4 5 runProgram("FOR with negative STEP", "DIM i AS INTEGER\n" "FOR i = 5 TO 1 STEP -1\n" " PRINT i;\n" "NEXT i\n" "PRINT\n", "5 4 3 2 1 \n" ); // Expected: 5 4 3 2 1 runProgram("FOR with STEP 2", "DIM i AS INTEGER\n" "FOR i = 0 TO 10 STEP 2\n" " PRINT i;\n" "NEXT i\n" "PRINT\n", "0 2 4 6 8 10 \n" ); // Expected: 0 2 4 6 8 10 // ============================================================ // Coverage: EXIT statements // ============================================================ runProgram("EXIT FOR", "DIM i AS INTEGER\n" "FOR i = 1 TO 100\n" " IF i = 3 THEN EXIT FOR\n" " PRINT i;\n" "NEXT i\n" "PRINT\n" "PRINT \"after\"\n", "1 2 \nafter\n" ); // Expected: 1 2 / after // Regression test: FOR loop inside a SUB with local loop variable runProgram("FOR inside SUB with local", "CALL MySub\n" "SUB MySub\n" " DIM i AS LONG\n" " FOR i = 0 TO 3\n" " PRINT i;\n" " NEXT i\n" " PRINT\n" "END SUB\n", "0 1 2 3 \n" ); // Expected: 0 1 2 3 // Regression test: resedit pattern -- FOR in SUB with n = FUNC(...) runProgram("FOR with func-returned limit", "CALL DoIt\n" "SUB DoIt\n" " DIM n AS LONG\n" " n = GetCount()\n" " DIM i AS LONG\n" " FOR i = 0 TO n - 1\n" " PRINT i;\n" " NEXT i\n" " PRINT\n" "END SUB\n" "FUNCTION GetCount() AS LONG\n" " GetCount = 4\n" "END FUNCTION\n", "0 1 2 3 \n" ); // Expected: 0 1 2 3 // Regression test: resedit pattern -- FOR in SUB inside a FORM runProgram("FOR in SUB inside FORM", "BEGINFORM \"Form1\"\n" "DIM formVar AS LONG\n" "formVar = 42\n" "CALL DoIt\n" "SUB DoIt\n" " DIM n AS LONG\n" " n = 4\n" " DIM ix AS LONG\n" " FOR ix = 0 TO n - 1\n" " PRINT ix;\n" " NEXT ix\n" " PRINT\n" "END SUB\n" "ENDFORM\n", "" ); // Expected: nothing -- form init code (including the CALL) only runs when // the form is loaded, which this harness never does. runProgram("EXIT DO", "DIM n AS INTEGER\n" "n = 0\n" "DO\n" " n = n + 1\n" " IF n = 4 THEN EXIT DO\n" " PRINT n;\n" "LOOP\n" "PRINT\n" "PRINT \"after\"\n", "1 2 3 \nafter\n" ); // Expected: 1 2 3 / after runProgram("EXIT SUB", "DECLARE SUB EarlyReturn(n AS INTEGER)\n" "EarlyReturn 1\n" "EarlyReturn 5\n" "EarlyReturn 2\n" "SUB EarlyReturn(n AS INTEGER)\n" " IF n > 3 THEN EXIT SUB\n" " PRINT n;\n" "END SUB\n" "PRINT\n", "1 2 \n" ); // Expected: 1 2 runProgram("EXIT FUNCTION", "DECLARE FUNCTION Clamp(n AS INTEGER) AS INTEGER\n" "PRINT Clamp(5)\n" "PRINT Clamp(200)\n" "FUNCTION Clamp(n AS INTEGER) AS INTEGER\n" " IF n > 100 THEN\n" " Clamp = 100\n" " EXIT FUNCTION\n" " END IF\n" " Clamp = n\n" "END FUNCTION\n", "5 \n100 \n" ); // Expected: 5 / 100 // ============================================================ // Coverage: CONST // ============================================================ runProgram("CONST", "CONST PI = 3.14159\n" "CONST MAX_SIZE = 100\n" "CONST GREETING = \"hello\"\n" "PRINT INT(PI * 100)\n" "PRINT MAX_SIZE\n" "PRINT GREETING\n", "314 \n100 \nhello\n" ); // Expected: 314 / 100 / hello // ============================================================ // Coverage: END statement // ============================================================ runProgram("END statement", "PRINT \"before\"\n" "END\n" "PRINT \"after\"\n", "before\n" ); // Expected: before // ============================================================ // Coverage: Boolean literals // ============================================================ runProgram("True and False", "DIM b AS BOOLEAN\n" "b = True\n" "IF b THEN PRINT \"yes\"\n" "b = False\n" "IF NOT b THEN PRINT \"no\"\n" "PRINT True\n" "PRINT False\n", "yes\nno\nTrue \nFalse \n" ); // Expected: yes / no / True / False // ============================================================ // Coverage: NOT operator // ============================================================ runProgram("NOT operator", "PRINT NOT 0\n" "PRINT NOT -1\n" "DIM x AS INTEGER\n" "x = 5\n" "IF NOT (x > 10) THEN PRINT \"small\"\n", "-1 \n0 \nsmall\n" ); // Expected: -1 / 0 / small // ============================================================ // Coverage: AND OR XOR bitwise // ============================================================ runProgram("Bitwise AND OR XOR", "PRINT 15 AND 9\n" "PRINT 12 OR 3\n" "PRINT 15 XOR 9\n", "9 \n15 \n6 \n" ); // Expected: 9 / 15 / 6 // ============================================================ // Coverage: SLEEP // ============================================================ runProgram("SLEEP", "SLEEP 0\n" "PRINT \"ok\"\n", "ok\n" ); // Expected: ok // ============================================================ // Coverage: Error recovery // ============================================================ runProgram("RESUME NEXT", "ON ERROR GOTO handler\n" "DIM x AS INTEGER\n" "x = 10 / 0\n" "PRINT \"resumed\"\n" "END\n" "handler:\n" "RESUME NEXT\n", "resumed\n" ); // Expected: resumed runProgram("RAISE ERROR", "ON ERROR GOTO handler\n" "ERROR 999\n" "PRINT \"should not print\"\n" "END\n" "handler:\n" "PRINT \"caught error\"; ERR\n", "caught error999 \n" ); // Expected: caught error999 // ============================================================ // Coverage: Type suffixes and hex literals // ============================================================ runProgram("Type suffixes", "DIM x%\n" "DIM s$\n" "x% = 42\n" "s$ = \"hello\"\n" "PRINT x%\n" "PRINT s$\n", "42 \nhello\n" ); // Expected: 42 / hello runProgram("Hex literals", "PRINT &HFF\n" "PRINT &H10\n" "DIM x AS INTEGER\n" "x = &H0A\n" "PRINT x\n", "255 \n16 \n10 \n" ); // Expected: 255 / 16 / 10 // ============================================================ // Coverage: Long integer type // ============================================================ runProgram("Long integer", "DIM x AS LONG\n" "x = 100000\n" "x = x * 2\n" "PRINT x\n", "200000 \n" ); // Expected: 200000 // ============================================================ // Coverage: REDIM without PRESERVE // ============================================================ runProgram("REDIM no PRESERVE", "DIM a(3) AS INTEGER\n" "a(1) = 99\n" "REDIM a(5) AS INTEGER\n" "PRINT a(1)\n", "0 \n" ); // Expected: 0 (data cleared) // ============================================================ // Coverage: PRINT variants // ============================================================ runProgram("PRINT comma separator", "PRINT 1, 2, 3\n", "1 2 3 \n" ); // Expected: 1 and 2 and 3 at the start of 14-column print zones runProgram("PRINT bare newline", "PRINT \"a\"\n" "PRINT\n" "PRINT \"b\"\n", "a\n\nb\n" ); // Expected: a / (blank) / b // ============================================================ // Coverage: LET keyword // ============================================================ runProgram("LET keyword", "DIM x AS INTEGER\n" "LET x = 42\n" "PRINT x\n", "42 \n" ); // Expected: 42 // ============================================================ // Coverage: Line continuation // ============================================================ runProgram("Line continuation", "DIM x AS INTEGER\n" "x = 1 + _\n" " 2 + _\n" " 3\n" "PRINT x\n", "6 \n" ); // Expected: 6 // ============================================================ // Coverage: REM comment // ============================================================ runProgram("REM comment", "REM This is a comment\n" "PRINT \"ok\"\n" "PRINT \"hi\" REM inline comment\n", "ok\nhi\n" ); // Expected: ok / hi // ============================================================ // Coverage: SELECT CASE with numeric ranges and IS // ============================================================ runProgram("SELECT CASE numeric", "DIM x AS INTEGER\n" "x = 15\n" "SELECT CASE x\n" " CASE 10\n" " PRINT \"ten\"\n" " CASE 15, 20\n" " PRINT \"fifteen or twenty\"\n" " CASE ELSE\n" " PRINT \"other\"\n" "END SELECT\n", "fifteen or twenty\n" ); // Expected: fifteen or twenty runProgram("CASE TO range", "DIM x AS INTEGER\n" "x = 15\n" "SELECT CASE x\n" " CASE 1 TO 10\n" " PRINT \"1-10\"\n" " CASE 11 TO 20\n" " PRINT \"11-20\"\n" " CASE ELSE\n" " PRINT \"other\"\n" "END SELECT\n", "11-20\n" ); // Expected: 11-20 runProgram("CASE IS comparison", "DIM x AS INTEGER\n" "x = 50\n" "SELECT CASE x\n" " CASE IS < 10\n" " PRINT \"small\"\n" " CASE IS >= 100\n" " PRINT \"big\"\n" " CASE ELSE\n" " PRINT \"medium\"\n" "END SELECT\n", "medium\n" ); // Expected: medium runProgram("CASE mixed forms", "DIM x AS INTEGER\n" "x = 5\n" "SELECT CASE x\n" " CASE 1, 2, 3\n" " PRINT \"low\"\n" " CASE 4 TO 6\n" " PRINT \"mid\"\n" " CASE IS > 6\n" " PRINT \"high\"\n" "END SELECT\n", "mid\n" ); // Expected: mid // ============================================================ // Coverage: Nested FOR EXIT // ============================================================ runProgram("Nested FOR EXIT", "DIM i AS INTEGER\n" "DIM j AS INTEGER\n" "FOR i = 1 TO 3\n" " FOR j = 1 TO 100\n" " IF j > 2 THEN EXIT FOR\n" " PRINT i * 10 + j;\n" " NEXT j\n" "NEXT i\n" "PRINT\n", "11 12 21 22 31 32 \n" ); // Expected: 11 12 21 22 31 32 // ============================================================ // Coverage: Mixed type arithmetic coercion // ============================================================ runProgram("Type coercion", "DIM d AS DOUBLE\n" "d = 2.5\n" "PRINT 7 + d\n" "PRINT 7 * d\n" "DIM i AS INTEGER\n" "DIM f AS SINGLE\n" "i = 10\n" "f = 3.0\n" "PRINT i / f\n", "9.5 \n17.5 \n3.33333333333333 \n" ); // Expected: 9.5 / 17.5 / 3.333... // ============================================================ // Coverage: Multiple FUNCTION return paths // ============================================================ runProgram("FUNCTION return", "DECLARE FUNCTION Max(a AS INTEGER, b AS INTEGER) AS INTEGER\n" "PRINT Max(10, 20)\n" "PRINT Max(30, 5)\n" "FUNCTION Max(a AS INTEGER, b AS INTEGER) AS INTEGER\n" " IF a > b THEN\n" " Max = a\n" " ELSE\n" " Max = b\n" " END IF\n" "END FUNCTION\n", "20 \n30 \n" ); // Expected: 20 / 30 // ============================================================ // Coverage: Recursive FUNCTION // ============================================================ runProgram("Recursive FUNCTION", "DECLARE FUNCTION Fact(n AS INTEGER) AS LONG\n" "PRINT Fact(1)\n" "PRINT Fact(5)\n" "PRINT Fact(10)\n" "FUNCTION Fact(n AS INTEGER) AS LONG\n" " IF n <= 1 THEN\n" " Fact = 1\n" " ELSE\n" " Fact = n * Fact(n - 1)\n" " END IF\n" "END FUNCTION\n", "1 \n120 \n3628800 \n" ); // Expected: 1 / 120 / 3628800 // ============================================================ // Coverage: String comparison operators // ============================================================ runProgram("String comparison", "IF \"abc\" < \"def\" THEN PRINT \"less\"\n" "IF \"xyz\" > \"abc\" THEN PRINT \"greater\"\n" "IF \"abc\" = \"abc\" THEN PRINT \"equal\"\n" "IF \"abc\" <> \"xyz\" THEN PRINT \"notequal\"\n", "less\ngreater\nequal\nnotequal\n" ); // Expected: less / greater / equal / notequal // ============================================================ // Coverage: Apostrophe comment // ============================================================ runProgram("Apostrophe comment", "PRINT \"before\" ' this is a comment\n" "' full line comment\n" "PRINT \"after\"\n", "before\nafter\n" ); // Expected: before / after // ============================================================ // Coverage: SINGLE data type // ============================================================ runProgram("SINGLE data type", "DIM s AS SINGLE\n" "s = 3.14\n" "PRINT INT(s * 100)\n", "314 \n" ); // Expected: 314 // ============================================================ // Coverage: Conversion functions // ============================================================ runProgram("CINT CLNG CDBL CSNG CSTR", "PRINT CINT(3.7)\n" "PRINT CLNG(42)\n" "PRINT CDBL(3)\n" "PRINT CSNG(3)\n" "PRINT \"[\" & CSTR(42) & \"]\"\n", "4 \n42 \n3 \n3 \n[42]\n" ); // Expected: 4 / 42 / 3 / 3 / [42] // ============================================================ // Coverage: Me.Show / Me.Hide as statements // ============================================================ { printf("=== Me.Show / Me.Hide statements ===\n"); // These compile -- runtime needs a form context to actually show/hide const char *src = "Sub Form1_Load ()\n" " Me.Show\n" " Me.Hide\n" " PRINT \"me ok\"\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { printf("Compiled OK, proc=%s\n", mod->procs[0].name); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Me keyword with form context // ============================================================ { printf("=== Me keyword with form context ===\n"); const char *src = "Sub Form1_Load ()\n" " PRINT \"load fired\"\n" "End Sub\n" "\n" "Sub Command1_Click ()\n" " PRINT \"click fired\"\n" "End Sub\n" "\n" "Sub Text1_KeyPress (KeyAscii As Integer)\n" " PRINT \"key:\"; KeyAscii\n" "End Sub\n" "\n" "Sub Picture1_MouseDown (Button As Integer, X As Integer, Y As Integer)\n" " PRINT \"mouse:\"; Button; X; Y\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (!mod) { printf("MODULE BUILD FAILED\n\n"); gFailCount++; } else { BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); // Test: find and call Form1_Load (no args) const BasProcEntryT *loadProc = basModuleFindProc(mod, "Form1_Load"); if (loadProc) { basVmCallSub(vm, loadProc->codeAddr); } else { printf("Form1_Load not found!\n"); gFailCount++; } // Test: find and call Command1_Click (no args) const BasProcEntryT *clickProc = basModuleFindProc(mod, "Command1_Click"); if (clickProc) { basVmCallSub(vm, clickProc->codeAddr); } else { printf("Command1_Click not found!\n"); gFailCount++; } // Test: find and call Text1_KeyPress with parameter const BasProcEntryT *keyProc = basModuleFindProc(mod, "Text1_KeyPress"); if (keyProc) { BasValueT args[1]; args[0] = basValLong(65); // 'A' basVmCallSubWithArgs(vm, keyProc->codeAddr, args, 1); } else { printf("Text1_KeyPress not found!\n"); } // Test: find and call Picture1_MouseDown with 3 parameters const BasProcEntryT *mouseProc = basModuleFindProc(mod, "Picture1_MouseDown"); if (mouseProc) { BasValueT args[3]; args[0] = basValLong(1); // left button args[1] = basValLong(50); // X args[2] = basValLong(100); // Y basVmCallSubWithArgs(vm, mouseProc->codeAddr, args, 3); } else { printf("Picture1_MouseDown not found!\n"); } // Test: verify proc table printf("Proc count: %d\n", (int)mod->procCount); for (int32_t i = 0; i < mod->procCount; i++) { printf(" [%d] %s (params=%d)\n", (int)i, mod->procs[i].name, (int)mod->procs[i].paramCount); } basVmDestroy(vm); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Event parameter mismatch // ============================================================ { printf("=== Event parameter mismatch ===\n"); const char *src = "Sub NoParams ()\n" " PRINT \"no params ok\"\n" "End Sub\n" "\n" "Sub OneParam (X As Integer)\n" " PRINT \"X =\"; X\n" "End Sub\n" "\n" "Sub TwoParams (A As Integer, B As Integer)\n" " PRINT \"A =\"; A; \"B =\"; B\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); // Call NoParams with no args const BasProcEntryT *p = basModuleFindProc(mod, "NoParams"); if (p) { basVmCallSub(vm, p->codeAddr); } // Call OneParam with 1 arg p = basModuleFindProc(mod, "OneParam"); if (p) { BasValueT args[1]; args[0] = basValLong(42); basVmCallSubWithArgs(vm, p->codeAddr, args, 1); } // Call TwoParams with 2 args p = basModuleFindProc(mod, "TwoParams"); if (p) { BasValueT args[2]; args[0] = basValLong(10); args[1] = basValLong(20); basVmCallSubWithArgs(vm, p->codeAddr, args, 2); } basVmDestroy(vm); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Procedure extraction from source // ============================================================ runProgram("Mixed module-level and procedures", "DIM x As Integer\n" "x = 10\n" "PRINT \"module:\"; x\n" "\n" "Sub Helper ()\n" " PRINT \"helper called\"\n" "End Sub\n" "\n" "Function Add (a As Integer, b As Integer) As Integer\n" " Add = a + b\n" "End Function\n" "\n" "CALL Helper\n" "PRINT \"sum:\"; Add(3, 4)\n", "module:10 \nhelper called\nsum:7 \n" ); // ============================================================ // Coverage: ? shortcut for PRINT // ============================================================ runProgram("? shortcut for PRINT", "? \"hello\"\n" "? 1 + 2\n", "hello\n3 \n" ); // ============================================================ // Coverage: Code in .frm format (Sub after form definition) // ============================================================ { printf("=== FRM code extraction ===\n"); // Simulate what the IDE does: code section from a .frm const char *frmCode = "Sub Form1_Load ()\n" " PRINT \"form loaded\"\n" "End Sub\n" "\n" "Sub Command1_Click ()\n" " PRINT \"button clicked\"\n" "End Sub\n"; int32_t len = (int32_t)strlen(frmCode); BasCompilerT *compiler = basCompilerCreate(frmCode, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n\n", basCompilerError(compiler)); basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { BasVmT *vm = basVmCreate(); basVmLoadModule(vm, mod); // Fire both events const BasProcEntryT *p1 = basModuleFindProc(mod, "Form1_Load"); const BasProcEntryT *p2 = basModuleFindProc(mod, "Command1_Click"); if (p1) { basVmCallSub(vm, p1->codeAddr); } else { printf("Form1_Load NOT FOUND\n"); } if (p2) { basVmCallSub(vm, p2->codeAddr); } else { printf("Command1_Click NOT FOUND\n"); } basVmDestroy(vm); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: RANDOMIZE TIMER // ============================================================ runProgram("RANDOMIZE TIMER", "RANDOMIZE TIMER\n" "DIM x AS SINGLE\n" "x = RND\n" "PRINT \"rnd ok\"\n", "rnd ok\n" ); // ============================================================ // Coverage: Forward GOSUB // ============================================================ runProgram("Forward GOSUB", "GOSUB doWork\n" "PRINT \"back\"\n" "END\n" "doWork:\n" "PRINT \"working\"\n" "RETURN\n", "working\nback\n" ); // ============================================================ // Coverage: Forward GOTO // ============================================================ runProgram("Forward GOTO to label", "GOTO skip\n" "PRINT \"should not print\"\n" "skip:\n" "PRINT \"jumped\"\n", "jumped\n" ); // ============================================================ // Coverage: Array of UDT // ============================================================ runProgram("Array of UDT", "TYPE PointT\n" " x AS INTEGER\n" " y AS INTEGER\n" "END TYPE\n" "\n" "DIM pts(3) AS PointT\n" "pts(1).x = 10\n" "pts(1).y = 20\n" "pts(2).x = 30\n" "pts(2).y = 40\n" "PRINT pts(1).x; pts(1).y\n" "PRINT pts(2).x; pts(2).y\n", "10 20 \n30 40 \n" ); // ============================================================ // Coverage: Nested UDTs // ============================================================ runProgram("Nested UDT", "TYPE AddressT\n" " city AS STRING\n" " zip AS INTEGER\n" "END TYPE\n" "\n" "TYPE PersonT\n" " fullName AS STRING\n" " addr AS AddressT\n" "END TYPE\n" "\n" "DIM p AS PersonT\n" "p.fullName = \"Alice\"\n" "p.addr.city = \"NYC\"\n" "p.addr.zip = 10001\n" "PRINT p.fullName\n" "PRINT p.addr.city\n" "PRINT p.addr.zip\n", "Alice\nNYC\n10001 \n" ); // ============================================================ // Coverage: Operator precedence stress // ============================================================ runProgram("Operator precedence", "' NOT has highest unary, then AND, OR, XOR, EQV, IMP\n" "PRINT NOT 0 AND -1\n" // NOT 0 = -1, -1 AND -1 = -1 "PRINT (1 > 0) AND (2 > 1)\n" // True AND True = True (two Booleans, VB4+) "PRINT (1 > 0) OR (2 < 1)\n" // True OR False = True "PRINT 5 AND 3\n" // bitwise: 1 "PRINT 5 OR 3\n" // bitwise: 7 "PRINT 5 XOR 3\n" // bitwise: 6 "PRINT 2 + 3 * 4 - 1\n" // 2 + 12 - 1 = 13 "PRINT (2 + 3) * (4 - 1)\n" // 5 * 3 = 15 "PRINT -2 ^ 2\n", // -(2^2) = -4 (VB precedence) "-1 \nTrue \nTrue \n1 \n7 \n6 \n13 \n15 \n-4 \n" ); // Logical operators on Booleans give Booleans, as in VB4+ (NOT too); // with a number they give the number's type, and with Null the known // operand's runProgram("Logical operators: Booleans give Booleans", "DIM a AS BOOLEAN\n" "DIM b AS BOOLEAN\n" "DIM v AS VARIANT\n" "a = TRUE\n" "PRINT a AND b; a OR b; a XOR b; a EQV b; a IMP b; NOT a\n" "PRINT TypeName(a AND b); TypeName(NOT b); TypeName(a EQV b)\n" "PRINT TypeName(a AND 1); TypeName(a OR 70000); TypeName(NOT 1)\n" "PRINT a AND 3; NOT FALSE\n" "v = a\n" "PRINT TypeName(v OR b); TypeName(Null AND FALSE); TypeName(0 AND Null)\n" "CONST C = TRUE AND NOT FALSE\n" "PRINT C; TypeName(C)\n", "False True True False False False \n" "BooleanBooleanBoolean\n" "IntegerLongInteger\n" "3 True \n" "BooleanBooleanInteger\n" "True Boolean\n" ); // ============================================================ // Coverage: Nested FOR with EXIT // ============================================================ runProgram("Nested FOR with EXIT FOR", "DIM i AS INTEGER\n" "DIM j AS INTEGER\n" "FOR i = 1 TO 3\n" " FOR j = 1 TO 3\n" " IF j = 2 THEN EXIT FOR\n" " PRINT i; j\n" " NEXT j\n" "NEXT i\n", "1 1 \n2 1 \n3 1 \n" ); // ============================================================ // Coverage: Forward reference CALL (sub defined after use) // ============================================================ runProgram("Forward CALL reference", "CALL doWork\n" "PRINT \"after call\"\n" "\n" "Sub doWork ()\n" " PRINT \"in sub\"\n" "End Sub\n", "in sub\nafter call\n" ); // ============================================================ // Coverage: Multiple CONST declarations // ============================================================ runProgram("Multiple CONST", "CONST PI = 3.14159\n" "CONST E = 2.71828\n" "CONST APPNAME = \"DVX\"\n" "PRINT INT(PI * 100)\n" "PRINT INT(E * 100)\n" "PRINT APPNAME\n", "314 \n271 \nDVX\n" ); // ============================================================ // Coverage: SELECT CASE with strings // ============================================================ runProgram("SELECT CASE strings", "DIM s AS STRING\n" "s = \"hello\"\n" "SELECT CASE s\n" " CASE \"world\"\n" " PRINT \"wrong\"\n" " CASE \"hello\"\n" " PRINT \"right\"\n" " CASE ELSE\n" " PRINT \"default\"\n" "END SELECT\n", "right\n" ); // ============================================================ // Coverage: Nested IF/ELSEIF chains // ============================================================ runProgram("Nested IF chains", "DIM x AS INTEGER\n" "x = 50\n" "IF x > 90 THEN\n" " PRINT \"A\"\n" "ELSEIF x > 80 THEN\n" " PRINT \"B\"\n" "ELSEIF x > 70 THEN\n" " PRINT \"C\"\n" "ELSEIF x > 60 THEN\n" " PRINT \"D\"\n" "ELSE\n" " PRINT \"F\"\n" "END IF\n", "F\n" ); // ============================================================ // Coverage: DO WHILE with EXIT DO // ============================================================ runProgram("DO WHILE with EXIT DO", "DIM i AS INTEGER\n" "i = 0\n" "DO WHILE i < 100\n" " i = i + 1\n" " IF i = 5 THEN EXIT DO\n" "LOOP\n" "PRINT i\n", "5 \n" ); // ============================================================ // Coverage: Recursive Fibonacci // ============================================================ runProgram("Recursive Fibonacci", "Function Fib (n As Integer) As Integer\n" " IF n <= 1 THEN\n" " Fib = n\n" " ELSE\n" " Fib = Fib(n - 1) + Fib(n - 2)\n" " END IF\n" "End Function\n" "\n" "PRINT Fib(0); Fib(1); Fib(5); Fib(10)\n", "0 1 5 55 \n" ); // ============================================================ // Coverage: String comparison operators // ============================================================ runProgram("String comparison ops", "IF \"abc\" < \"def\" THEN PRINT \"lt ok\"\n" "IF \"abc\" <= \"abc\" THEN PRINT \"le ok\"\n" "IF \"def\" > \"abc\" THEN PRINT \"gt ok\"\n" "IF \"abc\" >= \"abc\" THEN PRINT \"ge ok\"\n" "IF \"abc\" <> \"def\" THEN PRINT \"ne ok\"\n" "IF \"abc\" = \"abc\" THEN PRINT \"eq ok\"\n", "lt ok\nle ok\ngt ok\nge ok\nne ok\neq ok\n" ); // ============================================================ // Coverage: LOAD/UNLOAD/Me statements compile // ============================================================ { printf("=== Form statements compile ===\n"); const char *src = "Sub Form1_Load ()\n" " Me.Show\n" " Me.Hide\n" " Load frmOther\n" " Unload frmOther\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { printf("OK: %d procs, %d bytes\n", (int)mod->procCount, (int)mod->codeLen); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Me.Property assignment compiles // ============================================================ { printf("=== Me.Property assignment ===\n"); const char *src = "Sub Form1_Load ()\n" " Me.Caption = \"Hello\"\n" " Me.Visible = 1\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { printf("OK\n"); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Me.Control.Property compiles // ============================================================ { printf("=== Me.Control.Property ===\n"); const char *src = "Sub Form1_Load ()\n" " Me.Text1.Text = \"hello\"\n" " Me.Label1.Caption = \"world\"\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { printf("OK\n"); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: DOEVENTS compiles // ============================================================ { printf("=== DOEVENTS compiles ===\n"); const char *src = "Sub Form1_Load ()\n" " DoEvents\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; basCompilerDestroy(compiler); } else { BasModuleT *mod = basCompilerBuildModule(compiler); basCompilerDestroy(compiler); if (mod) { printf("OK\n"); basModuleFree(mod); } } printf("\n"); } // ============================================================ // Coverage: Bare sub call (no CALL keyword, no parens) // ============================================================ runProgram("Bare sub call", "Sub Greet ()\n" " PRINT \"hello\"\n" "End Sub\n" "\n" "Greet\n", "hello\n" ); // ============================================================ // Coverage: Bare sub call with forward reference // ============================================================ runProgram("Bare sub call forward ref", "DoWork\n" "\n" "Sub DoWork ()\n" " PRINT \"worked\"\n" "End Sub\n", "worked\n" ); // ============================================================ // Coverage: Unresolved forward reference error // ============================================================ expectCompileError("Unresolved forward reference", "NeverDefined\n", "Undefined Sub: NeverDefined" ); // ============================================================ // Coverage: Nested UDT field store // ============================================================ runProgram("Nested UDT store and load", "TYPE InnerT\n" " val AS INTEGER\n" "END TYPE\n" "\n" "TYPE OuterT\n" " child AS InnerT\n" " label AS STRING\n" "END TYPE\n" "\n" "DIM o AS OuterT\n" "o.label = \"test\"\n" "o.child.val = 42\n" "PRINT o.label\n" "PRINT o.child.val\n", "test\n42 \n" ); // ============================================================ // Coverage: Array of UDT field store // ============================================================ runProgram("Array of UDT field store", "TYPE PointT\n" " x AS INTEGER\n" " y AS INTEGER\n" "END TYPE\n" "\n" "DIM pts(5) AS PointT\n" "pts(1).x = 10\n" "pts(1).y = 20\n" "pts(3).x = 30\n" "pts(3).y = 40\n" "PRINT pts(1).x; pts(1).y\n" "PRINT pts(3).x; pts(3).y\n", "10 20 \n30 40 \n" ); // ============================================================ // Coverage: VB operator precedence (^ binds tighter than unary -) // ============================================================ runProgram("Exponent precedence", "PRINT -2 ^ 2\n" // -(2^2) = -4 "PRINT (-2) ^ 2\n" // (-2)^2 = 4 "PRINT 3 ^ 2 + 1\n", // 9 + 1 = 10 "-4 \n4 \n10 \n" ); // ============================================================ // Coverage: Me.Show compiles in a Sub // ============================================================ { printf("=== Me.Show in Sub ===\n"); const char *src = "Sub Form1_Load ()\n" " Me.Show\n" " Me.Caption = \"Hello\"\n" " Me.Hide\n" "End Sub\n"; int32_t len = (int32_t)strlen(src); BasCompilerT *compiler = basCompilerCreate(src, len); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: OPTION EXPLICIT with valid declaration // ============================================================ runProgram("OPTION EXPLICIT valid", "OPTION EXPLICIT\n" "DIM x AS INTEGER\n" "x = 42\n" "PRINT x\n", "42 \n" ); // ============================================================ // Coverage: STATIC variable retains value // ============================================================ runProgram("STATIC in sub", "Sub Counter ()\n" " STATIC n AS INTEGER\n" " n = n + 1\n" " PRINT n\n" "End Sub\n" "\n" "Counter\n" "Counter\n" "Counter\n", "1 \n2 \n3 \n" ); // ============================================================ // Coverage: MsgBox statement form (no return value) // ============================================================ runProgram("MsgBox statement", "MsgBox \"Hello\"\n", "" ); // ============================================================ // Coverage: MsgBox statement with flags // ============================================================ runProgram("MsgBox statement with flags", "MsgBox \"Save?\", vbYesNo + vbQuestion\n", "" ); // ============================================================ // Coverage: MsgBox function form (returns value) // ============================================================ runProgram("MsgBox function", "DIM result AS INTEGER\n" "result = MsgBox(\"Continue?\", vbYesNo)\n" "PRINT result\n", "1 \n" ); // ============================================================ // Coverage: MsgBox function with default flags // ============================================================ runProgram("MsgBox function default flags", "DIM r AS INTEGER\n" "r = MsgBox(\"OK\")\n" "PRINT r\n", "1 \n" ); // ============================================================ // Coverage: VB3 predefined constants // ============================================================ runProgram("VB3 predefined constants", "PRINT vbOKOnly\n" "PRINT vbOKCancel\n" "PRINT vbYesNo\n" "PRINT vbYesNoCancel\n" "PRINT vbRetryCancel\n" "PRINT vbInformation\n" "PRINT vbExclamation\n" "PRINT vbCritical\n" "PRINT vbQuestion\n" "PRINT vbOK\n" "PRINT vbCancel\n" "PRINT vbYes\n" "PRINT vbNo\n" "PRINT vbRetry\n", "0 \n1 \n2 \n3 \n4 \n16 \n32 \n48 \n64 \n1 \n2 \n3 \n4 \n5 \n" ); // ============================================================ // Coverage: MsgBox result used in If // ============================================================ runProgram("MsgBox in If condition", "If MsgBox(\"Exit?\", vbYesNo) = vbYes Then\n" " PRINT \"yes\"\n" "End If\n", "" ); // ============================================================ // Coverage: Control array read -- Name(0).Caption // ============================================================ { printf("=== Control array read ===\n"); BasCompilerT *compiler = basCompilerCreate("DIM x AS STRING\n" "x = Command1(0).Caption\n" "PRINT x\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Control array write -- Name(idx).Caption = "text" // ============================================================ { printf("=== Control array write ===\n"); BasCompilerT *compiler = basCompilerCreate("DIM idx AS INTEGER\n" "idx = 1\n" "Command1(idx).Caption = \"Hello\"\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Control array complex index -- Name(X + 1).Caption // ============================================================ { printf("=== Control array complex index ===\n"); BasCompilerT *compiler = basCompilerCreate("DIM i AS INTEGER\n" "DIM s AS STRING\n" "i = 2\n" "s = Btn(i + 1).Text\n" "PRINT s\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Forward-ref function still works (no dot after paren) // ============================================================ runProgram("Forward-ref function still works", "Function GetValue () As Integer\n" " GetValue = 42\n" "End Function\n" "\n" "PRINT GetValue()\n", "42 \n" ); // ============================================================ // Coverage: Control array in event handler // ============================================================ { printf("=== Control array event handler ===\n"); BasCompilerT *compiler = basCompilerCreate("Sub Cmd_Click (Index As Integer)\n" " Cmd(Index).Caption = \"Clicked\"\n" "End Sub\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Me.Control(idx).Property // ============================================================ { printf("=== Me.Control(idx).Property ===\n"); BasCompilerT *compiler = basCompilerCreate("Sub Cmd_Click (Index As Integer)\n" " Me.Cmd(Index).Caption = \"OK\"\n" "End Sub\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: BEGINFORM/ENDFORM with form-level DIM // ============================================================ { printf("=== Form-level variables ===\n"); BasCompilerT *compiler = basCompilerCreate("BEGINFORM \"Form1\"\n" "Dim Shared counter As Integer\n" "Dim Shared msg As String\n" "\n" "Sub Form1_Load ()\n" " counter = 0\n" " msg = \"hello\"\n" "End Sub\n" "\n" "Sub Timer1_Timer ()\n" " counter = counter + 1\n" "End Sub\n" "ENDFORM\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Form-scope arrays compile (init deferred to load) // ============================================================ { printf("=== Form-scope array ===\n"); BasCompilerT *compiler = basCompilerCreate("BEGINFORM \"Form1\"\n" "Dim Shared arr(10) As Integer\n" "\n" "Sub Form1_Load ()\n" " arr(0) = 42\n" "End Sub\n" "ENDFORM\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Two forms with same-named form vars (independent) // ============================================================ { printf("=== Two forms same var name ===\n"); BasCompilerT *compiler = basCompilerCreate("BEGINFORM \"Form1\"\n" "Dim Shared counter As Integer\n" "Sub Form1_Load ()\n" " counter = 1\n" "End Sub\n" "ENDFORM\n" "\n" "BEGINFORM \"Form2\"\n" "Dim Shared counter As Integer\n" "Sub Form2_Load ()\n" " counter = 2\n" "End Sub\n" "ENDFORM\n", -1); if (!basCompile(compiler)) { printf("COMPILE ERROR: %s\n", basCompilerError(compiler)); gFailCount++; } else { printf("OK\n"); } basCompilerDestroy(compiler); printf("\n"); } // ============================================================ // Coverage: Nested BEGINFORM rejected // ============================================================ expectCompileError("Nested BEGINFORM rejected", "BEGINFORM \"Form1\"\n" "BEGINFORM \"Form2\"\n" "ENDFORM\n" "ENDFORM\n", "Nested BEGINFORM is not allowed" ); // ============================================================ // Regression: compiler bugs found by the aab9fac review // ============================================================ expectCompileError("Self-referential TYPE rejected", "TYPE T\n" " x AS INTEGER\n" " y AS T\n" "END TYPE\n" "DIM v AS T\n", "cannot contain a field of its own type" ); expectCompileError("DEF FN inside SUB rejected", "SUB S\n" " DIM x AS INTEGER\n" " DEF FNd(y) = y * 2\n" "END SUB\n", "DEF FN is not allowed inside SUB or FUNCTION" ); // RETURN inside a SELECT CASE must discard the live test value before // OP_GOSUB_RET pops the return address. runProgram("RETURN inside SELECT CASE", "DIM x AS INTEGER\n" "x = 1\n" "GOSUB Handler\n" "PRINT \"back\"\n" "END\n" "Handler:\n" "SELECT CASE x\n" " CASE 1\n" " PRINT \"one\"\n" " RETURN\n" "END SELECT\n" "RETURN\n", "one\nback\n" ); expectCompileError("Long identifier rejected", "DIM abcdefghijabcdefghijabcdefghijabcdefghijabcdefghijabcdefghijabcdefghij AS INTEGER\n", "Identifier too long" ); // A variable first used inside a SUB is local to it: the module-level // y is a different (zero) variable, and the implicit string local is // "" on every call rather than accumulating. runProgram("Implicit variable in SUB is local", "SUB S\n" " y = 4\n" " s$ = s$ & \"a\"\n" " PRINT y; s$\n" "END SUB\n" "S\n" "S\n" "PRINT y\n", "4 a\n4 a\n0 \n" ); runProgram("Implicit locals are per call in recursion", "FUNCTION fact(n)\n" " IF n <= 1 THEN\n" " fact = 1\n" " ELSE\n" " t = n\n" " fact = t * fact(n - 1)\n" " END IF\n" "END FUNCTION\n" "PRINT fact(5)\n", "120 \n" ); expectCompileError("Assignment to another FUNCTION name rejected", "FUNCTION F\n" " F = 1\n" "END FUNCTION\n" "SUB S(a)\n" " F = 99\n" "END SUB\n", "Cannot assign to function 'F'" ); expectCompileError("Assignment to SUB name rejected", "SUB S\n" "END SUB\n" "S = 5\n", "Cannot assign to 'S'" ); // Labels have a namespace of their own (QB): a variable may share // a label's name. runProgram("Label and variable share a name", "Lbl:\n" "Lbl = 5\n" "PRINT Lbl\n", "5 \n" ); expectCompileError("SUB name as operand rejected", "SUB S\n" "END SUB\n" "PRINT S + 1\n", "'S' is not a variable" ); runProgram("DATA hex literal keeps 32 bits", "DATA &HFFFF, &H12345\n" "READ a&, b&\n" "PRINT a&; b&\n", "65535 74565 \n" ); expectCompileError("EXIT FOR in SUB without loop rejected", "SUB S\n" " EXIT FOR\n" "END SUB\n" "FOR i = 1 TO 3\n" " S\n" "NEXT i\n", "EXIT FOR outside FOR loop" ); expectCompileError("EXIT DO outside loop rejected", "EXIT DO\n", "EXIT DO outside DO or WHILE loop" ); expectCompileError("EXIT SUB at module level rejected", "EXIT SUB\n", "EXIT SUB outside SUB" ); expectCompileError("EXIT SUB inside FUNCTION rejected", "FUNCTION F\n" " EXIT SUB\n" "END FUNCTION\n", "EXIT SUB outside SUB" ); runProgram("EXIT FOR out of SELECT CASE", "FOR i = 1 TO 3\n" " SELECT CASE i\n" " CASE 2\n" " EXIT FOR\n" " END SELECT\n" " PRINT i\n" "NEXT i\n" "PRINT \"done\"\n", "1 \ndone\n" ); { // Nesting limits: deep parentheses, unary operators and blocks must // be compile errors, not stack overflows. static char deepSrc[8192]; int32_t pos = 0; pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "x = "); for (int32_t i = 0; i < BAS_MAX_EXPR_DEPTH + 8; i++) { pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "("); } pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "1"); for (int32_t i = 0; i < BAS_MAX_EXPR_DEPTH + 8; i++) { pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, ")"); } snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "\n"); expectCompileError("Deep expression nesting rejected", deepSrc, "Expression nested too deeply"); pos = 0; pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "x = "); for (int32_t i = 0; i < BAS_MAX_EXPR_DEPTH + 8; i++) { pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "-"); } snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "1\n"); expectCompileError("Deep unary nesting rejected", deepSrc, "Expression nested too deeply"); pos = 0; for (int32_t i = 0; i < BAS_MAX_BLOCK_DEPTH + 8; i++) { pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "IF 1 THEN\n"); } pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "PRINT 1\n"); for (int32_t i = 0; i < BAS_MAX_BLOCK_DEPTH + 8; i++) { pos += snprintf(deepSrc + pos, sizeof(deepSrc) - pos, "END IF\n"); } expectCompileError("Deep block nesting rejected", deepSrc, "Statements nested too deeply"); } // The signature prescan runs before TYPE statements are parsed; a // parameter typed AS a user TYPE must still count towards the arity. runProgram("Prescan handles UDT parameters", "DIM r AS INTEGER\n" "r = foo(1, 2)\n" "PRINT r\n" "TYPE Pt\n" " x AS INTEGER\n" "END TYPE\n" "FUNCTION foo(a AS INTEGER, b AS INTEGER) AS INTEGER\n" " foo = a + b\n" "END FUNCTION\n" "SUB bar(q AS Pt)\n" " PRINT q.x\n" "END SUB\n", "3 \n" ); expectCompileError("Duplicate label rejected", "L1:\n" "PRINT 1\n" "L1:\n" "PRINT 2\n", "Duplicate label 'L1'" ); expectCompileError("Duplicate SUB rejected", "SUB S\n" " PRINT \"first\"\n" "END SUB\n" "SUB S\n" " PRINT \"second\"\n" "END SUB\n", "Sub 'S' is already defined" ); expectCompileError("Nested SUB rejected", "SUB A\n" " SUB B\n" " END SUB\n" "END SUB\n", "SUB cannot be defined inside SUB or FUNCTION" ); // A procedure inside a block statement is an error (QA bug 1: its // scope outlived the block's unit arena -- a use-after-free on the // next name lookup; the first source is the fuzzer's reproducer) { static const char *const procInBlock[] = { "FOR i=0TO 3\nSUB L\nEND SUB\nNEXT\nP", "IF 1 THEN\nSUB A\nEND SUB\nEND IF\nA\n", "IF 1 THEN SUB A\nA\n", "DO\nFUNCTION F\nF = 1\nEND FUNCTION\nLOOP\nPRINT F\n", "WHILE 0\nPUBLIC SUB A\nEND SUB\nWEND\nA\n", "SELECT CASE 1\nCASE 1\nSUB A\nEND SUB\nEND SELECT\nA\n", "DIM o AS Object\nWITH o\nSUB A\nEND SUB\nEND WITH\nA\n", "FOR i = 1 TO 2\nIF i THEN\nDO\nPROPERTY GET P\nEND PROPERTY\nLOOP\nEND IF\nNEXT\nPRINT P\n", "FOR i = 1 TO 2\nSUB A\n" }; for (int32_t i = 0; i < (int32_t)(sizeof(procInBlock) / sizeof(procInBlock[0])); i++) { char name[64]; snprintf(name, sizeof(name), "Procedure inside a block rejected %d", (int)i); expectCompileError(name, procInBlock[i], "cannot be defined inside IF, FOR, DO, WHILE, SELECT CASE, or WITH"); } } // Named arguments of a late-bound call: the most the VM takes, each // with the longest name, fit the names buffer; more are an error found // before any name is copied (clang-tidy strcat triage: 17+ long names // overflowed the buffer in an expression call) { static const struct { const char *head; const char *tail; const char *fitName; const char *overName; } forms[] = { { "x = o.M(", ")", "Most named arguments (expression)", "Too many named arguments (expression)" }, { "o.M ", "", "Most named arguments (statement)", "Too many named arguments (statement)" } }; char src[TEST_NAMED_SRC_LEN]; for (int32_t f = 0; f < (int32_t)(sizeof(forms) / sizeof(forms[0])); f++) { for (int32_t total = BAS_VM_MAX_CALL_ARGS; total <= BAS_VM_MAX_CALL_ARGS + TEST_NAMED_EXTRA; total += TEST_NAMED_EXTRA) { int32_t len = snprintf(src, sizeof(src), "DIM o AS Object\n%s", forms[f].head); for (int32_t i = 0; i < total; i++) { len += snprintf(src + len, sizeof(src) - len, "%sN%02d%0*d:=1", i > 0 ? ", " : "", (int)i, TEST_NAMED_PAD, 0); } snprintf(src + len, sizeof(src) - len, "%s\n", forms[f].tail); if (total > BAS_VM_MAX_CALL_ARGS) { expectCompileError(forms[f].overName, src, "Too many arguments"); } else { compileOnly(forms[f].fitName, src); } } } } // A DEF FN that stops at an error leaves no procedure scope behind expectCompileError("DEF FN error closes its scope", "x = 1\n" "DEF FNa(ParamArray v()) = 1\n" "PRINT x\n", "ParamArray is not allowed in DEF FN" ); // PRINT#1 / CLOSE#1 / LINE INPUT#1 with no space before '#' runProgram("PRINT# without a space", "OPEN \"test_hash.txt\" FOR OUTPUT AS #1\n" "PRINT#1, \"hi\"\n" "CLOSE#1\n" "OPEN \"test_hash.txt\" FOR INPUT AS #1\n" "LINE INPUT#1, a$\n" "CLOSE#1\n" "PRINT a$\n" "KILL \"test_hash.txt\"\n", "hi\n" ); expectCompileError("Integer literal wider than 32 bits rejected", "x = 4294967297\n", "Integer literal out of range" ); expectCompileError("INTEGER suffix literal out of range rejected", "x = 70000%\n", "INTEGER literal out of range" ); expectCompileError("Method arguments require commas", "ctl.Method 1 2\n", "Expected end of statement" ); expectCompileError("Show modal flag must be a constant", "DIM m AS INTEGER\n" "frm.Show m\n", "Show modal flag must be a literal or numeric CONST" ); expectCompileError("DECLARE mismatch rejected", "DECLARE SUB S(a AS INTEGER)\n" "SUB S(a AS INTEGER, b AS INTEGER)\n" "END SUB\n", "DECLARE for 'S' does not match its definition" ); runProgram("DECLARE matching the definition", "DECLARE SUB S(a AS INTEGER, b AS INTEGER)\n" "S 1, 2\n" "SUB S(a AS INTEGER, b AS INTEGER)\n" " PRINT a + b\n" "END SUB\n", "3 \n" ); expectCompileError("STRING * n out of range rejected", "DIM s AS STRING * &H10005\n", "STRING * length must be 1 to 65535" ); expectCompileError("NEXT variable mismatch rejected", "FOR i = 1 TO 2\n" "FOR j = 1 TO 2\n" "NEXT i\n" "NEXT j\n", "NEXT i does not match FOR j" ); expectCompileError("CALL of a variable rejected", "DIM v AS INTEGER\n" "CALL v\n", "'v' is not a SUB or FUNCTION" ); expectCompileError("CALL without required arguments rejected", "SUB S(a)\n" "END SUB\n" "CALL S\n", "Sub 'S' expects 1 arguments, got 0" ); runProgram("OPTIONAL padding on every call form", "SUB S(a, OPTIONAL b$)\n" " PRINT a; \"[\"; b$; \"]\"\n" "END SUB\n" "CALL S(1)\n" "S 2, \"x\"\n" "CALL S(3, \"y\")\n", "1 []\n2 [x]\n3 [y]\n" ); expectCompileError("Duplicate TYPE field rejected", "TYPE T\n" " x AS INTEGER\n" " x AS STRING\n" "END TYPE\n", "Duplicate field 'x' in TYPE 'T'" ); expectCompileError("DEFINT reversed range rejected", "DEFINT Z-A\n", "Letter range must be in ascending order" ); expectCompileError("CR-only line endings are counted", "PRINT 1\rPRINT 2\rPRINT )\r", "Line 3, Col 7:" ); expectCompileError("STATIC mangled name too long rejected", "SUB abcdefghijabcdefghijabcdefghijabcdefghijabcdefghij\n" " STATIC abcdefghijabcdefghijabcdefghij AS INTEGER\n" "END SUB\n", "STATIC name" ); // ---- Coverage completion: lexer edges ---- expectCompileError("Unexpected character rejected", "PRINT 1 ~\n", "Unexpected character" ); expectCompileError("Empty hex literal rejected", "A = &H\n", "Empty hexadecimal" ); expectCompileError("Wide hex literal rejected", "A = &H1FFFFFFFF\n", "exceeds 32 bits" ); runProgram("Hex, octal, binary literal forms", "PRINT &hff\n" "PRINT &O17\n" "PRINT &B101\n" "PRINT &HAB&\n", "255 \n15 \n5 \n171 \n" ); expectCompileError("Unterminated string literal rejected", "A$ = \"abc\n", "Unterminated string literal" ); runProgram("CRLF line endings", "PRINT 1\r\nPRINT 2\r\n", "1 \n2 \n" ); runProgram("Line continuation with CRLF", "A = 1 + _\r\n2\r\nPRINT A\r\n", "3 \n" ); expectCompileError("Underscore without newline is not a continuation", "A = 5 _ x\n", "end of statement" ); expectCompileError("Dangling exponent marker", "B = 1E\n", "end of statement" ); runProgram("D exponent marker", "PRINT 1D2\n", "100 \n" ); runProgram("All comparison operators", "PRINT 1 < 2\n" "PRINT 2 <= 2\n" "PRINT 3 > 2\n" "PRINT 3 >= 4\n" "PRINT 1 = 1\n" "PRINT 1 <> 1\n", "True \nTrue \nTrue \nFalse \nTrue \nFalse \n" ); // Sound, joystick and frame statements: with no host they are silent // and read 0; argument counts are checked when compiling. runProgram("Sound statements run silently without a host", "BEEP\n" "SOUND 440, 18.2\n" "Play \"T120 L8 CDE\"\n" "PRINT PLAY(0); STICK(0); Strig(1)\n", "0 0 0 \n" ); runProgramPlay("PLAY X and = with VARPTR$ (nested, spaces, numbers)", "a$ = \"CDE\"\n" "b$ = \"O2 X\" + VARPTR$(a$) + \" G\"\n" "n = 180\n" "PLAY \"T=\" + VARPTR$(n) + \"L8 X \" + VARPTR$(b$) + \"x\" + VARPTR$(a$)\n" "PLAY \"O=\" + VARPTR$(3 + 1) + \"N=\" + VARPTR$(-2)\n" "PLAY \"MB\"\n", "[PLAY T180L8 O2 CDE GCDE]\n" "[PLAY O4N-2]\n" "[PLAY MB]\n", true); runProgram("PLAY X and = mistakes are Illegal function call", "ON ERROR GOTO h\n" "PLAY \"T=\" + \"12\"\n" "PLAY \"X\" + VARPTR$(5)\n" "PLAY \"C\" + CHR$(0) + \"D\"\n" "PLAY \"=\" + LEFT$(VARPTR$(1), 3)\n" "s$ = \"C\"\n" "FOR i = 1 TO 20\n" " s$ = \"X\" + VARPTR$(s$)\n" "NEXT\n" "PLAY s$\n" "PRINT n\n" "END\n" "h:\n" "IF ERR = 5 THEN n = n + 1\n" "RESUME NEXT\n", "5 \n"); compileOnly("FRAMEWAIT in a game loop", "DO\n FRAMEWAIT 60\n IF STRIG(1) THEN EXIT DO\nLOOP\n"); expectCompileError("SOUND needs a duration", "SOUND 440\n", "Expected ','"); expectCompileError("PLAY as a function needs parentheses", "x = PLAY\n", "Expected '('"); expectCompileError("STICK takes one argument", "PRINT STICK(1, 2)\n", "Built-in 'STICK' expects 1-1 arguments"); expectCompileError("PLAY is a keyword", "SUB Play\nEND SUB\n", ""); testKeywordApi(); testTokenNames(); testLexerLimits(); // ---- Coverage completion: statements and declarations ---- expectCompileError("BEGINFORM without name string rejected", "BEGINFORM 1\n", "form name string" ); expectCompileError("Over-long form name rejected", "BEGINFORM \"A234567890123456789012345678901234567890123456789012345678901234567890\"\n", "Form name too long" ); expectCompileError("ENDFORM without BEGINFORM rejected", "ENDFORM\n", "ENDFORM without BEGINFORM" ); compileOnly("Form scope ended then global lookup", "BEGINFORM \"F1\"\n" "DIM fv AS INTEGER\n" "ENDFORM\n" "FUNCTION G\n" "G = 1\n" "END FUNCTION\n" "PRINT G\n" ); compileOnly("DIM with bounds inside form init block", "BEGINFORM \"F1\"\n" "DIM fa(3) AS INTEGER\n" "ENDFORM\n" ); expectCompileError("CONST without name rejected", "CONST 1 = 2\n", "constant name" ); expectCompileError("CONST of a variable rejected", "DIM b AS INTEGER\n" "CONST A = b\n", "Constant expression required: 'b' is not a constant" ); expectCompileError("Duplicate CONST rejected", "CONST A = 1\n" "CONST A = 2\n", "Duplicate constant or symbol table full" ); runProgram("CONST literal forms", "CONST A = -5\n" "CONST B = -2.5\n" "CONST C = TRUE\n" "CONST D = FALSE\n" "CONST S$ = \"hi\"\n" "PRINT A\n" "PRINT B\n" "PRINT C\n" "PRINT D\n" "PRINT S$\n", "-5 \n-2.5 \nTrue \nFalse \nhi\n" ); runProgram("DATA negatives and bare values", "DATA -5, -2.5, -, hello, 70000, -70000\n" "DIM a AS INTEGER\n" "DIM b AS DOUBLE\n" "DIM s1$\n" "DIM s2$\n" "DIM l1 AS LONG\n" "DIM l2 AS LONG\n" "READ a, b, s1$, s2$, l1, l2\n" "PRINT a\n" "PRINT s1$\n" "PRINT s2$\n" "PRINT l1\n", "-5 \n-\nhello\n70000 \n" ); expectCompileError("Bad DATA value rejected", "DATA 1,\n", "Expected DATA value" ); expectCompileError("READ into CONST rejected", "CONST K = 1\n" "DATA 2\n" "READ K\n", "Cannot assign to a constant" ); expectCompileError("FOR over a SUB name rejected", "SUB S\n" "END SUB\n" "FOR S = 1 TO 2\n" "NEXT\n", "Cannot assign to 'S'" ); expectCompileError("DECLARE of something else rejected", "DECLARE PRINT\n", "Expected SUB, FUNCTION, or LIBRARY after DECLARE" ); expectCompileError("DECLARE without name rejected", "DECLARE SUB 1\n", "subroutine/function name" ); expectCompileError("DECLARE clashing with a variable rejected", "DIM X AS INTEGER\n" "DECLARE SUB X ()\n", "already declared" ); expectCompileError("DECLARE LIBRARY without name string rejected", "DECLARE LIBRARY 1\n", "library name string" ); expectCompileError("Statement inside DECLARE LIBRARY rejected", "DECLARE LIBRARY \"foo\"\n" "PRINT 1\n" "END DECLARE\n", "Expected DECLARE or END DECLARE" ); expectCompileError("DECLARE of non-proc inside LIBRARY block rejected", "DECLARE LIBRARY \"foo\"\n" "DECLARE PRINT\n" "END DECLARE\n", "Expected SUB or FUNCTION in DECLARE LIBRARY block" ); expectCompileError("Library DECLARE without name rejected", "DECLARE LIBRARY \"foo\"\n" "DECLARE SUB 1\n" "END DECLARE\n", "function name" ); expectCompileError("END of wrong block inside DECLARE LIBRARY rejected", "DECLARE LIBRARY \"foo\"\n" "END IF\n", "Expected DECLARE after END in DECLARE LIBRARY block" ); expectCompileError("Library function clashing with a variable rejected", "DIM Q AS INTEGER\n" "DECLARE LIBRARY \"foo\"\n" "DECLARE SUB Q ()\n" "END DECLARE\n", "already declared" ); compileOnly("DECLARE LIBRARY block", "DECLARE LIBRARY \"dvx\"\n" "DECLARE SUB DoBeep ()\n" "DECLARE FUNCTION AddUp% (a AS INTEGER, b AS INTEGER)\n" "END DECLARE\n" ); expectCompileError("DEF without FN name rejected", "DEF 1\n", "function name (FNname)" ); expectCompileError("DEF name without FN prefix rejected", "DEF Foo(x) = x\n", "DEF function name must start with FN" ); expectCompileError("DEF clashing with a variable rejected", "DIM FNA AS INTEGER\n" "DEF FNA(x) = x\n", "already in use" ); runProgram("DEF FN definition and call", "DEF FNDouble(x) = x * 2\n" "PRINT FNDouble(4)\n", "8 \n" ); expectCompileError("DEFINT without letter rejected", "DEFINT 1\n", "letter or letter range" ); expectCompileError("DEFINT multi-letter token rejected", "DEFINT _x\n", "Expected letter A-Z" ); expectCompileError("DEFINT dangling dash rejected", "DEFINT A-\n", "letter after '-'" ); expectCompileError("DEFINT bad range end rejected", "DEFINT A-_y\n", "Expected letter A-Z" ); expectCompileError("Duplicate DIM rejected", "DIM X AS INTEGER\n" "DIM X AS INTEGER\n", "already declared" ); expectCompileError("DIM clashing with a SUB rejected", "SUB S\n" "END SUB\n" "DIM S AS INTEGER\n", "already declared" ); expectCompileError("ERASE of a non-identifier rejected", "ERASE 1\n", "array variable name" ); expectCompileError("ERASE of a scalar rejected", "DIM x AS INTEGER\n" "ERASE x\n", "ERASE requires an array variable" ); runProgram("ERASE static and dynamic arrays", "DIM a(3) AS INTEGER\n" "a(1) = 5\n" "ERASE a\n" "PRINT a(1)\n" "DIM d() AS INTEGER\n" "REDIM d(5)\n" "ERASE d\n" "PRINT \"ok\"\n", "0 \nok\n" ); expectCompileError("EXIT FUNCTION inside SUB rejected", "SUB S\n" "EXIT FUNCTION\n" "END SUB\n", "EXIT FUNCTION outside FUNCTION" ); expectCompileError("EXIT of a non-loop rejected", "EXIT PRINT\n", "Expected FOR, DO, SUB, FUNCTION, or PROPERTY after EXIT" ); compileOnly("GET and PUT of a whole UDT record", "TYPE T\n" "x AS INTEGER\n" "s AS STRING * 8\n" "END TYPE\n" "DIM v AS T\n" "GET #1, , v\n" "PUT #1, , v\n" ); expectCompileError("UDT store of unknown field rejected", "TYPE T\n" "x AS INTEGER\n" "END TYPE\n" "DIM v AS T\n" "v.zz = 1\n", "Unknown field 'zz' in TYPE 'T'" ); expectCompileError("UDT field without assignment rejected", "TYPE T\n" "x AS INTEGER\n" "END TYPE\n" "DIM v AS T\n" "v.x 5\n", "Expected '='" ); expectCompileError("Nested UDT field without assignment rejected", "TYPE Inner\n" "x AS INTEGER\n" "END TYPE\n" "TYPE Outer\n" "i AS Inner\n" "END TYPE\n" "DIM v AS Outer\n" "v.i.x 5\n", "Expected '='" ); expectCompileError("STRING * with non-integer rejected", "DIM A AS STRING * X\n", "Expected integer after STRING *" ); expectCompileError("FOR without loop variable rejected", "FOR 1 = 1 TO 2\n" "NEXT\n", "loop variable" ); expectCompileError("FUNCTION without name rejected", "FUNCTION 1\n", "function name" ); expectCompileError("FUNCTION inside SUB rejected", "SUB S\n" "FUNCTION F\n" "END FUNCTION\n" "END SUB\n", "FUNCTION cannot be defined inside SUB or FUNCTION" ); expectCompileError("FUNCTION with bad parameter rejected", "FUNCTION F(1)\n" "END FUNCTION\n", "parameter name" ); expectCompileError("Duplicate FUNCTION body rejected", "FUNCTION F\n" "F = 1\n" "END FUNCTION\n" "FUNCTION F\n" "END FUNCTION\n", "Function 'F' is already defined" ); compileOnly("END statement inside FUNCTION body", "DECLARE FUNCTION F ()\n" "PRINT F\n" "FUNCTION F\n" "IF 1 = 2 THEN\n" "END\n" "END IF\n" "F = 3\n" "END FUNCTION\n" ); expectCompileError("GOSUB to a missing line number rejected", "GOSUB 1\n", "Label not defined: 1" ); expectCompileError("GOTO to a missing line number rejected", "GOTO 1\n", "Label not defined: 1" ); expectCompileError("IF without END IF rejected", "IF 1 = 1 THEN\n" "PRINT 1\n", "Expected END IF" ); expectCompileError("ELSEIF chain without END IF rejected", "IF 1 = 1 THEN\n" "PRINT 1\n" "ELSEIF 2 = 2 THEN\n" "PRINT 2\n", "Expected END IF" ); compileOnly("IF branches containing END", "DIM a AS INTEGER\n" "IF a = 1 THEN\n" "END\n" "ELSEIF a = 2 THEN\n" "END\n" "ELSE\n" "END\n" "END IF\n" ); expectCompileError("INPUT into a non-variable rejected", "INPUT 1\n", "variable name" ); expectCompileError("INPUT # into a non-variable rejected", "INPUT #1, 1\n", "variable name" ); compileOnly("INPUT prompt and file forms", "DIM v$\n" "DIM w$\n" "INPUT \"prompt\"; v$\n" "INPUT \"prompt\", v$\n" "INPUT v$\n" "INPUT #1, v$, w$\n" ); expectCompileError("LINE without INPUT or a point rejected", "LINE PRINT\n", "Expected '-'" ); compileOnly("LINE INPUT without a channel reads the console", "DIM v$\n" "LINE INPUT v$\n" ); expectCompileError("LINE INPUT into a non-variable rejected", "LINE INPUT #1, 1\n", "variable name" ); expectCompileError("ON expression without GOTO or GOSUB rejected", "DIM x AS INTEGER\n" "ON x PRINT\n", "Expected GOTO or GOSUB after ON expression" ); expectCompileError("ON GOTO with bad label rejected", "DIM x AS INTEGER\n" "ON x GOTO 1\n", "Label not defined: 1" ); expectCompileError("ON GOSUB with bad second label rejected", "DIM x AS INTEGER\n" "ON x GOSUB a, 1\n" "a:\n" "RETURN\n", "Label not defined: 1" ); runProgram("ON GOTO dispatch", "DIM x AS INTEGER\n" "x = 2\n" "ON x GOTO a, b\n" "a:\n" "PRINT \"a\"\n" "END\n" "b:\n" "PRINT \"b\"\n" "END\n", "b\n" ); expectCompileError("ON ERROR without GOTO rejected", "ON ERROR PRINT\n", "Expected GOTO or RESUME NEXT after ON ERROR" ); expectCompileError("ON ERROR GOTO of non-label rejected", "ON ERROR GOTO \"x\"\n", "label name or line number" ); compileOnly("ON ERROR GOTO 0", "ON ERROR GOTO 0\n" ); runProgram("ON ERROR GOTO backward label", "GOTO start\n" "h:\n" "PRINT \"handled\"\n" "RESUME NEXT\n" "start:\n" "ON ERROR GOTO h\n" "DIM a AS INTEGER\n" "a = 1 \\ 0\n" "PRINT \"end\"\n", "handled\nend\n" ); compileOnly("OPEN mode variants", "OPEN \"f\" FOR OUTPUT AS #1\n" "OPEN \"g\" FOR APPEND AS #2\n" "OPEN \"h\" FOR RANDOM AS #3 LEN = 32\n" "OPEN \"i\" FOR BINARY AS #4\n" "OPEN \"j\" FOR INPUT AS #5\n" ); expectCompileError("OPEN with bad mode rejected", "OPEN \"f\" FOR PRINT AS #1\n", "Expected INPUT, OUTPUT, APPEND, RANDOM, or BINARY after FOR" ); expectCompileError("OPTION BASE without literal rejected", "DIM x AS INTEGER\n" "OPTION BASE x\n", "Expected 0 or 1 after OPTION BASE" ); expectCompileError("OPTION BASE out of range rejected", "OPTION BASE 2\n", "OPTION BASE must be 0 or 1" ); expectCompileError("OPTION COMPARE with bad mode rejected", "OPTION COMPARE FOO\n", "Expected BINARY or TEXT after OPTION COMPARE" ); expectCompileError("OPTION with bad selector rejected", "OPTION FOO\n", "Expected BASE, COMPARE, or EXPLICIT after OPTION" ); runProgram("OPTION COMPARE BINARY is case sensitive", "OPTION COMPARE BINARY\n" "PRINT \"a\" = \"A\"\n", "False \n" ); expectCompileError("Required parameter after OPTIONAL rejected", "SUB S(OPTIONAL a, b)\n" "END SUB\n", "Required parameter cannot follow Optional parameter" ); expectCompileError("Non-identifier parameter rejected", "SUB S(1)\n" "END SUB\n", "parameter name" ); expectCompileError("Duplicate parameter rejected", "SUB S(a, a)\n" "END SUB\n", "Duplicate parameter name 'a'" ); expectCompileError("Unknown App member rejected", "PRINT App.Foo\n", "Expected 'Path', 'User', or 'Data' after 'App.'" ); compileOnly("App path members", "DIM p$\n" "p$ = App.Path\n" "p$ = App.User\n" "p$ = App.Data\n" ); expectCompileError("SEEK function without parentheses rejected", "DIM x AS LONG\n" "x = SEEK\n", "SEEK requires parentheses when used as a function" ); compileOnly("Dir function forms", "DIM s$\n" "s$ = Dir$(\"*.x\")\n" "s$ = Dir$()\n" "s$ = Dir$\n" ); compileOnly("InputBox expression defaults", "DIM s$\n" "s$ = InputBox$(\"p\")\n" "s$ = InputBox$(\"p\", \"t\")\n" "s$ = InputBox$(\"p\", \"t\", \"d\")\n" ); expectCompileError("LBOUND with non-constant dimension rejected", "DIM a(5) AS INTEGER\n" "DIM d AS INTEGER\n" "PRINT LBOUND(a, d)\n", "LBOUND dimension must be a constant integer" ); expectCompileError("UBOUND with non-constant dimension rejected", "DIM a(5) AS INTEGER\n" "DIM d AS INTEGER\n" "PRINT UBOUND(a, d)\n", "UBOUND dimension must be a constant integer" ); expectCompileError("Builtin arity rejected", "DIM s$\n" "s$ = LEFT$(\"x\")\n", "arguments, got 1" ); compileOnly("Control array expression read", "X = Text1(2).Caption\n" ); runProgram("Forward function call resolved later", "X = Sq(3)\n" "PRINT X\n" "DIM A(5)\n" "A(1) = X\n" "PRINT A(1)\n" "FUNCTION Sq(n AS INTEGER) AS INTEGER\n" "Sq = n * n\n" "END FUNCTION\n", "9 \n9 \n" ); runProgram("EXIT FOR pending across DIM with bounds", "DIM i AS INTEGER\n" "FOR i = 1 TO 3\n" "IF i = 2 THEN EXIT FOR\n" "DIM B(4)\n" "B(0) = i\n" "NEXT i\n" "PRINT i\n", "2 \n" ); expectCompileError("Member of expression variable rejected", "DIM v AS INTEGER\n" "X = v.(\n", "property or method name" ); compileOnly("Variable object property read", "DIM v AS INTEGER\n" "X = v.Caption\n" ); compileOnly("PRINT # trailing separators", "PRINT #1, \"a\";\n" "PRINT #1, \"b\",\n" "PRINT #1, \"c\"\n" ); compileOnly("PUT with expression payload", "PUT #1, , 1 + 2\n" ); expectCompileError("GET into a non-variable rejected", "GET #1, , 1\n", "variable name" ); expectCompileError("REDIM of a non-identifier rejected", "REDIM 1\n", "array variable name" ); expectCompileError("REDIM of a SUB rejected", "SUB S\n" "END SUB\n" "REDIM S(5)\n", "'S' is not a variable" ); expectCompileError("SELECT body without CASE rejected", "DIM x AS INTEGER\n" "SELECT CASE x\n" "PRINT 1\n" "END SELECT\n", "Expected CASE or END SELECT" ); runProgram("CASE IS operator forms", "DIM x AS INTEGER\n" "x = 5\n" "SELECT CASE x\n" "CASE IS > 4\n" "PRINT \"gt\"\n" "END SELECT\n" "SELECT CASE x\n" "CASE IS <= 5\n" "PRINT \"le\"\n" "END SELECT\n" "SELECT CASE x\n" "CASE IS >= 5\n" "PRINT \"ge\"\n" "END SELECT\n" "SELECT CASE x\n" "CASE IS = 5\n" "PRINT \"eq\"\n" "END SELECT\n" "SELECT CASE x\n" "CASE IS <> 4\n" "PRINT \"ne\"\n" "END SELECT\n", "gt\nle\nge\neq\nne\n" ); expectCompileError("CASE IS without operator rejected", "DIM x AS INTEGER\n" "SELECT CASE x\n" "CASE IS PRINT\n" "END SELECT\n", "Expected comparison operator after IS" ); compileOnly("SELECT bodies containing END", "DIM x AS INTEGER\n" "SELECT CASE x\n" "CASE 1\n" "END\n" "CASE ELSE\n" "END\n" "END SELECT\n" ); expectCompileError("SELECT without END SELECT rejected", "DIM x AS INTEGER\n" "SELECT CASE x\n" "CASE 1\n" "PRINT 1\n", "Expected END SELECT" ); runProgram("GOTO out of SELECT CASE", "DIM x AS INTEGER\n" "x = 1\n" "SELECT CASE x\n" "CASE 1\n" "GOTO done\n" "CASE 2\n" "PRINT \"no\"\n" "END SELECT\n" "PRINT \"skipped\"\n" "done:\n" "PRINT \"d\"\n", "d\n" ); compileOnly("Show modal variants", "CONST M = 1\n" "Form1.Show\n" "Form1.Show 1\n" "Form1.Show TRUE\n" "Form1.Show FALSE\n" "Form1.Show M\n" ); runProgram("RANDOMIZE forms", "RANDOMIZE TIMER\n" "RANDOMIZE 42\n" "PRINT \"ok\"\n", "ok\n" ); compileOnly("CreateForm statement", "CREATEFORM(\"F\", 100, 100)\n" ); compileOnly("Object statement forms", "DIM v AS INTEGER\n" "SET v = Nothing\n" "Load Form1\n" "Unload Form1\n" "Unload Me\n" "InputBox$ \"p\"\n" "InputBox$ \"p\", \"t\"\n" "InputBox$ \"p\", \"t\", \"d\"\n" ); expectCompileError("SET of a non-variable rejected", "SET 1 = 2\n", "variable name" ); expectCompileError("Load of a non-identifier rejected", "Load 1\n", "form name" ); expectCompileError("Unload of a non-identifier rejected", "Unload 1\n", "form name" ); compileOnly("Me statement forms", "Me.Show\n" "Me.Show 1\n" "Me.Hide\n" "Me.Caption = \"x\"\n" "Me.Text1.Text = \"y\"\n" "Me.Text1(1).Text = \"z\"\n" "Me.Refresh\n" ); expectCompileError("Me without dot rejected", "Me PRINT\n", "'.' after Me" ); expectCompileError("Me without dot after Me rejected", "Me.5\n", "'.' after Me" ); expectCompileError("Me with bad member rejected", "Me.(\n", "property or method name" ); expectCompileError("Me control array with bad property rejected", "Me.C1(1).( = 1\n", "property or method name" ); runProgram("LET assignment", "LET X = 5\n" "PRINT X\n", "5 \n" ); expectCompileError("LET of a non-variable rejected", "LET 1 = 2\n", "variable name after LET" ); expectCompileError("Label reusing a SUB name rejected", "SUB foo\n" "END SUB\n" "foo:\n" "PRINT 1\n", "cannot be used as a label" ); runProgram("REM statement", "REM this is a comment\n" "PRINT 2\n", "2 \n" ); expectCompileError("Stray token rejected", "PRINT 1\n" ")\n", "Unexpected token" ); expectCompileError("STATIC at module level rejected", "STATIC x AS INTEGER\n", "STATIC is only valid inside SUB or FUNCTION" ); expectCompileError("STATIC without name rejected", "SUB S\n" "STATIC 1\n" "END SUB\n", "variable name" ); expectCompileError("STATIC New rejected", "TYPE T\n" "x AS INTEGER\n" "END TYPE\n" "SUB S\n" "STATIC v AS New Collection\n" "END SUB\n", "STATIC 'v': New and WithEvents are not supported" ); expectCompileError("Duplicate STATIC rejected", "SUB S\n" "STATIC x AS INTEGER\n" "STATIC x AS INTEGER\n" "END SUB\n", "Symbol table full or duplicate STATIC variable" ); expectCompileError("STATIC shadowing a local rejected", "SUB S\n" "DIM x AS INTEGER\n" "STATIC x AS INTEGER\n" "END SUB\n", "Symbol table full or duplicate variable name" ); expectCompileError("SUB without name rejected", "SUB 1\n", "subroutine name" ); expectCompileError("SUB clashing with a variable rejected", "DIM S AS INTEGER\n" "SUB S\n" "END SUB\n", "already declared" ); expectCompileError("SWAP of a non-variable rejected", "DIM x AS INTEGER\n" "SWAP 1 + (2), x\n", "variable name" ); expectCompileError("SWAP indexing a scalar rejected", "DIM x AS INTEGER\n" "DIM y AS INTEGER\n" "SWAP x(1), y\n", "not an array" ); runProgram("SWAP of array elements", "DIM a(3) AS INTEGER\n" "DIM b(3) AS INTEGER\n" "a(1) = 5\n" "b(2) = 9\n" "SWAP a(1), b(2)\n" "PRINT a(1)\n" "PRINT b(2)\n", "9 \n5 \n" ); expectCompileError("TYPE without name rejected", "TYPE 1\n", "type name" ); expectCompileError("Duplicate TYPE rejected", "TYPE T\n" "x AS INTEGER\n" "END TYPE\n" "TYPE T\n" "y AS INTEGER\n" "END TYPE\n", "Symbol table full or duplicate TYPE name" ); expectCompileError("TYPE with bad field line rejected", "TYPE T\n" "1\n" "END TYPE\n", "field name or END TYPE" ); expectCompileError("Error inside WHILE body surfaces", "WHILE 1\n" "PRINT )\n" "WEND\n", "Line" ); expectCompileError("WRITE without channel rejected", "WRITE 1\n", "Expected # after WRITE" ); runProgram("BOOLEAN variable", "DIM b AS BOOLEAN\n" "b = TRUE\n" "PRINT b\n", "True \n" ); expectCompileError("Unknown type name rejected", "DIM q AS Bogus\n", "Expected type name" ); expectCompileError("Assignment to variable without operator rejected", "DIM X AS INTEGER\n" "X 5\n", "'=' or '('" ); expectCompileError("Two statements without separator rejected", "A = 1 B = 2\n", "end of statement" ); expectCompileError("MID$ statement on a non-variable rejected", "MID$(1, 1) = \"x\"\n", "string variable name" ); runProgram("MID$ statement default length", "DIM s$\n" "s$ = \"hello\"\n" "MID$(s$, 2) = \"EL\"\n" "PRINT s$\n", "hELlo\n" ); expectCompileError("Member store with bad name rejected", "Abc.( = 1\n", "property or method name" ); expectCompileError("Three-part member store with bad name rejected", "F1.C1.( = 1\n", "property or method name" ); compileOnly("Var-held form control property store", "DIM v AS INTEGER\n" "v.C1.Text = \"x\"\n" ); compileOnly("Method statement forms", "DIM v AS INTEGER\n" "v.DoThing\n" "F1.C1.AddItem \"x\"\n" "C1(2).Text = \"x\"\n" "C1(3).DoIt\n" ); // ---- Coverage completion: control validator hooks ---- expectValidatorParse("Validator accepts known property", "Text1.Text = \"x\"\n", NULL ); expectValidatorParse("Validator rejects property store", "Text1.BadProp = 1\n", "Unknown property 'Text1.BadProp'" ); expectValidatorParse("Validator rejects method statement", "Text1.BadMethod\n", "Unknown method 'Text1.BadMethod'" ); expectValidatorParse("Validator rejects property read", "X = Text1.BadProp\n", "Unknown property 'Text1.BadProp'" ); expectValidatorParse("Validator rejects method call expression", "X = Text1.BadMethod(1)\n", "Unknown method 'Text1.BadMethod'" ); expectValidatorParse("Validator checks a control on its own form", "BEGINFORM \"F1\"\nSUB S\n Lbl2.BadProp = 1\nEND SUB\nENDFORM\n", "Unknown property 'Lbl2.BadProp'" ); expectValidatorParse("Validator skips a control of another form", "BEGINFORM \"F2\"\nSUB S\n Lbl2.BadProp = 1\nEND SUB\nENDFORM\n", NULL ); testCompilerFixes(); testCompilerLimits(); testFrontEnd(); testGapClosure(); testConsoleGraphics(); testConstEnumParamArray(); testEarlyBinding(); testEventsAndInterfaces(); testFastLoop(); testFollowUp(); testClassWithEvents(); testMissingAndValues(); testParamArrayByRef(); testParamDefaults(); testReferences(); testObjectsAndVariants(); testScreenModesPages(); testStringsAndDates(); testUserControl(); printf("All tests complete. Failures: %d\n", (int)gFailCount); return gFailCount > 0 ? 1 : 0; }