AI_Slop/DVX_GUI
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

All new BASIC compiler and VM.

Browse source
This commit is contained in:
Scott Duensing 2026-10-05 20:01:04 -05:00
parent 52d13717ce
commit e1e48c7619
270 changed files with 42380 additions and 14737 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
Makefile
View file

@ -39,7 +39,7 @@
LIBS = $(sort $(notdir $(patsubst %/Makefile,%,$(wildcard src/libs/kpunch/*/Makefile))))
CORE_LIBS = libdvx libtasks
.PHONY: all clean $(LIBS) loader widgets apps tools installer dist deploy-helpsrc compile-help deploy-sdk test test-quick test-asan test-host test-samples coverage
.PHONY: all clean $(LIBS) loader widgets apps tools installer dist deploy-helpsrc compile-help deploy-sdk test test-quick test-asan test-host test-modules test-samples coverage bench bench-compare
# Every build ends by making the release media in dist/ (a second or
# two), so dist/ always holds the latest DVX.
@ -85,8 +85,9 @@ deploy-helpsrc: $(LIBS) widgets apps tools
# Host-side tests. Every suite is native gcc; the GUI suites build
# obj/host/libdvx.a, the widget .so files and libdvxtest.a themselves
# (sanitizers on by default, SAN=1).
# make test -- everything: BASIC harnesses + fuzz, sample goldens,
# proxy build, all host suites, tools goldens, lint gate
# make test -- everything: DOS module symbol check, BASIC
# harnesses + fuzz, sample goldens, proxy build, all
# host suites, tools goldens, lint gate
# make test-quick -- same minus the fuzzers, static analyzer and tools
# make test-asan -- BASIC harnesses rebuilt under ASan/UBSan plus the
# host suites (which are already sanitized)
@ -96,6 +97,7 @@ DVXBASIC_DIR = src/apps/kpunch/dvxbasic
include src/test/suites.mk
test: apps
$(MAKE) test-modules
$(MAKE) -C $(DVXBASIC_DIR) tests
$(MAKE) -C src/tools/proxy
$(MAKE) test-samples
@ -104,12 +106,14 @@ test: apps
$(MAKE) -C src/test/lint
test-quick: apps
$(MAKE) test-modules
$(MAKE) -C $(DVXBASIC_DIR) tests FUZZ_N=0
$(MAKE) test-samples
$(MAKE) test-host
$(MAKE) -C src/test/lint style ascii
test-asan: apps
$(MAKE) test-modules
$(MAKE) -C $(DVXBASIC_DIR) tests TESTSAN=1
$(MAKE) test-host
@ -121,6 +125,28 @@ test-host:
test-samples:
src/test/samples/runSamples.sh
# Every unresolved symbol of every built DOS module (bin/ .lib .wgt .drv
# .app .dxe, plus the BASIC stub that compiled programs are made from) must
# be exported by dvx.exe or by a module loaded before it, or dlopen() fails
# on DOS (src/test/shell/checkDxeExports.sh, src/test/tools/checkModules.py).
# Builds every module first so the check sees the current binaries.
BASIC_STUB = obj/dvxbasic/basstub.app
test-modules: $(LIBS) loader widgets apps
src/test/shell/checkDxeExports.sh . $(BASIC_STUB)
# BASIC compiler / VM benchmarks (src/test/basic/basBench.c, programs in
# src/test/basic/bench): results in obj/test/bench/results.txt;
# bench-compare shows the change from BENCH_OLD (default the Phase 0
# baseline, src/test/basic/bench/baseline.txt) to BENCH_NEW (default the
# last make bench). BENCH_ARGS passes basBench options (-runs N, -profile,
# -filter NAME).
bench:
$(MAKE) -C src/test/basic bench
bench-compare:
$(MAKE) -C src/test/basic bench-compare $(if $(BENCH_OLD),BENCH_OLD=$(abspath $(BENCH_OLD))) $(if $(BENCH_NEW),BENCH_NEW=$(abspath $(BENCH_NEW)))
# The real DOS build in an emulator (src/test/dos/runDos.sh; not part of
# make test). EMULATOR=86box (default) or dosbox; SCRIPTS= a subset.
test-dos: all

791
docs/dvx_basic_reference.html
View file

File diff suppressed because it is too large Load diff

51
docs/dvx_system_reference.html
View file

@ -404,6 +404,7 @@ img { max-width: 100%; }
<li><a href="#api.cursor">Cursor Shapes</a></li>
<li><a href="#api.cursor">CURSOR_ARROW</a></li>
<li><a href="#api.cursor">CURSOR_BUSY</a></li>
<li><a href="#api.cursor">CURSOR_NO_DROP</a></li>
<li><a href="#api.types">CursorT</a></li>
<li><a href="#api.dialog">Custom Dialogs</a></li>
<li><a href="#user.settings">Customizing</a></li>
@ -523,6 +524,7 @@ img { max-width: 100%; }
<li><a href="#api.dialog">dvxDialogEnd</a></li>
<li><a href="#api.dialog">dvxDialogRun</a></li>
<li><a href="#api.dialog">dvxDlg.h</a></li>
<li><a href="#api.app">dvxDragCursorSet</a></li>
<li><a href="#api.app">dvxDragFeedbackHide</a></li>
<li><a href="#api.app">dvxDragImageShow</a></li>
<li><a href="#api.app">dvxDragOutlineShow</a></li>
@ -1271,6 +1273,7 @@ img { max-width: 100%; }
<li><a href="#widget.ansiterm">wgtAnsiTermWrite</a></li>
<li><a href="#api.widget">WgtApiHeaderT</a></li>
<li><a href="#api.widget">WgtApiPrefixT</a></li>
<li><a href="#api.widget">wgtBasicColor</a></li>
<li><a href="#widget.button">wgtButton</a></li>
<li><a href="#widget.canvas">wgtCanvas</a></li>
<li><a href="#widget.canvas">wgtCanvasClear</a></li>
@ -2962,7 +2965,8 @@ DVX_ABI_STAMP(mylib);</code></pre>
CURSOR_RESIZE_DIAG_NESW 4 NE-SW diagonal resize
CURSOR_BUSY 5 Hourglass (wait)
CURSOR_CROSSHAIR 6 Crosshair for placement
CURSOR_COUNT 7 Total number of cursor shapes</pre>
CURSOR_NO_DROP 7 Circle with a slash: a drag cannot drop here (see dvxDragCursorSet)
CURSOR_COUNT 8 Total number of cursor shapes</pre>
<h2>Data</h2>
<h3>dvxCursors[CURSOR_COUNT]</h3>
<p>Static const array of CursorT structs, indexed by CURSOR_xxx constants. Each entry includes the AND mask, XOR data (both as 16-element uint16_t arrays), dimensions (16x16), and hot spot coordinates.</p>
@ -4409,7 +4413,10 @@ bool dvxAppIsHung(const AppContextT *ctx, int32_t appId);</code></pre>
<p>Show a picture centered on the mouse pointer. pixels are in the display's native format, as dvxLoadImage or dvxLoadImageAlpha return them, and must stay valid until the feedback is hidden or replaced. With hasKey, pixels of keyColor are transparent (pass dvxLoadImageAlpha's outputs).</p>
<h3>dvxDragFeedbackHide</h3>
<pre><code>void dvxDragFeedbackHide(AppContextT *ctx);</code></pre>
<p>Remove the outline or picture.</p>
<p>Remove the outline or picture. The usual cursor shapes come back (see dvxDragCursorSet).</p>
<h3>dvxDragCursorSet</h3>
<pre><code>void dvxDragCursorSet(AppContextT *ctx, int32_t cursorId);</code></pre>
<p>Choose the mouse cursor shown while the outline or picture is up: CURSOR_NO_DROP where a drop cannot land, CURSOR_ARROW (the default) where it can. The program calls it as the mouse moves, since only it knows its drop targets. While drag feedback is shown this cursor replaces the usual shapes (resize arrows, a widget's own cursor); hiding the feedback puts them back and resets the choice to CURSOR_ARROW. Values outside the cursor table are ignored.</p>
<h2>Resource Loading</h2>
<h3>dvxResLoadIcon</h3>
<pre><code>uint8_t *dvxResLoadIcon(AppContextT *ctx, const char *dxePath, const char *resName, int32_t *outW, int32_t *outH, int32_t *outPitch);</code></pre>
@ -4744,6 +4751,13 @@ static const ButtonApiT sApi = {
minSize sizeof the API type the caller will use: sizeof(ButtonApiT) for a typed accessor, sizeof(WgtApiPrefixT) when only create is called</pre>
<p>Returns: Pointer to the API struct, or NULL if not found or refused. Per-widget headers wrap the call in a typed accessor (dvxButtonApi() and friends).</p>
<h2>Widget Interface Descriptors</h2>
<h3>wgtBasicColor</h3>
<pre><code>static inline uint32_t wgtBasicColor(uint32_t color);</code></pre>
<p>Converts a colour between DVX's 0x00RRGGBB layout (WidgetT fgColor / bgColor, packColor's channels, the colour dialog) and DVX BASIC's Visual Basic layout &amp;HBBGGRR (RGB(), QBColor, ForeColor / BackColor, drawing-method colour arguments) by swapping the red and blue bytes; the top byte is kept, so the function is its own inverse. A widget's BASIC methods call it once where a BASIC colour comes in and once where one goes back out.</p>
<pre> Parameter Description
--------- -----------
color A colour in either layout</pre>
<p>Returns: The colour in the other layout.</p>
<h3>wgtRegisterIface</h3>
<pre><code>void wgtRegisterIface(const char *name, const WgtIfaceT *iface);</code></pre>
<p>Register an interface descriptor for a widget type. Used by the BASIC form runtime and IDE for generic property/method dispatch.</p>
@ -5109,7 +5123,7 @@ int32_t pick = dvxButtonBox(ctx, &quot;Copy&quot;, &quot;The disk is full.&quot;
--------- -----------
ctx Application context
title Window title (NULL: &quot;Color&quot;)
rgbInOut In: the starting color; out: the chosen color. Both 0x00RRGGBB, the layout of DVX BASIC's RGB()</pre>
rgbInOut In: the starting color; out: the chosen color. Both 0x00RRGGBB (DVX BASIC's colours are &amp;HBBGGRR; wgtBasicColor converts between the two)</pre>
<p>Returns: true if OK was chosen, false if cancelled or closed (then *rgbInOut is unchanged).</p>
<p>Macros for the 0x00RRGGBB layout: DVX_RGB(r, g, b) builds a color from three 0-255 channels, and DVX_RGB_RED(rgb), DVX_RGB_GREEN(rgb) and DVX_RGB_BLUE(rgb) take one apart.</p>
<pre><code>uint32_t rgb = DVX_RGB(r, g, b);
@ -6047,11 +6061,15 @@ audioFmFree(audio, v); // key off, back to everyone</co
BAS_TYPE_ARRAY 6 arrVal Reference-counted array.
BAS_TYPE_UDT 7 udtVal Reference-counted user-defined type.
BAS_TYPE_OBJECT 8 objVal Opaque host pointer (form, control).
BAS_TYPE_REF 9 refVal ByRef pointer to a BasValueT slot.</pre>
BAS_TYPE_REF 9 ref Reference (ByRef argument): ref.target is the variable, element or field it names; ref.owner keeps that storage alive.</pre>
<p>A reference only ever lives in a call's parameters (a ByRef parameter, a ParamArray element). Read through it with basValDeref, which returns the value a reference names (or the value itself). refKind says what ref.owner is: BAS_REF_SLOT (none: a global, local or form variable), BAS_REF_ARRAY (the array, counted and locked so REDIM / ERASE raise error 10), BAS_REF_UDT (the TYPE instance holding the field), BAS_REF_OBJECT (the class instance holding the member variable) or BAS_REF_CELL (a BasRefCellT holding both the locked array and the TYPE instance, for a field of an array element). refType is the target's declared type (stores convert to it) and refLen the length of a STRING * n target. basValCopy and basValRelease count the owner.</p>
<h2>BasValueT</h2>
<p>Tagged union holding any BASIC value.</p>
<pre><code>struct BasValueTag {
uint8_t type; // BAS_TYPE_*
uint8_t refType : 5; // BAS_TYPE_REF: the target's declared type
uint8_t refKind : 3; // BAS_TYPE_REF: BasRefKindE
uint16_t refLen; // BAS_TYPE_REF: STRING * n length (0 = none)
union {
int16_t intVal;
int32_t longVal;
@ -6062,9 +6080,15 @@ audioFmFree(audio, v); // key off, back to everyone</co
BasArrayT *arrVal;
BasUdtT *udtVal;
void *objVal;
BasValueT *refVal;
BasObjectT *instVal;
struct {
void *owner;
BasValueT *target;
} ref;
};
};</code></pre>
};
BasValueT *basValDeref(const BasValueT *v); // inline: what a reference names, else v</code></pre>
<h2>Value Constructors</h2>
<pre><code>BasValueT basValInteger(int16_t v);
BasValueT basValLong(int32_t v);
@ -6296,7 +6320,7 @@ bool basVmCallSubWithArgsOut(BasVmT *vm, int32_t codeAddr,
-------- -----------
basVmCallSub Call a SUB with no arguments.
basVmCallSubWithArgs Call a SUB with arguments pushed onto the stack frame.
basVmCallSubWithArgsOut Call a SUB and read back modified argument values after it returns.</pre>
basVmCallSubWithArgsOut Call a SUB whose first outCount parameters are references to outArgs (set to the arguments first; each must hold a valid value): what the SUB stores in them is there when it returns, also after an error.</pre>
<p>All three push a call frame, execute until the SUB returns, then restore the previous execution state. Return true on normal completion, false on error or if the VM is not idle.</p>
<h2>Debugger API</h2>
<pre><code>void basVmSetBreakpoints(BasVmT *vm,
@ -7336,6 +7360,7 @@ win-&gt;onRawKey = gameRawKey; // each key going down and up</code></pre>
Ctrl+Esc Open the Task Manager
Alt+F4 Close the window (its onClose)</pre>
<p>Every other key, F1, F10, Alt+letter and the accelerators included, goes to onKey instead of opening help or menus. The game decides what F1 does (the template opens its help with shellOpenHelp); its menus still work with the mouse. onRawKey gets a RawKeyEventT for every key going down or up: the set-1 scancode with an extended flag for the grey keys, down or up, whether it is a typematic repeat, and the modifiers. Shift, Ctrl and Alt are keys of their own there, left and right apart.</p>
<p>The key that completes one of the three (Esc with Ctrl held, Tab or F4 with Alt held) never reaches the game: not in onRawKey, not in the held-key table, not its repeats and not its release. The modifier itself does, because when Ctrl or Alt goes down nobody can tell yet what will follow. A game that treats any key as &quot;go on&quot; therefore still sees the Ctrl or Alt of Ctrl+Esc or Alt+Tab.</p>
<h2>Held Keys</h2>
<p>For &quot;is it held right now&quot; use gameKeyIsDown(win, rawCode) with a raw key code (KEY_RAW_UP, KEY_RAW_LCTRL, or KEY_RAW_CODE(scan, extended) for any key); it is true only while win has the focus. platformKeyIsDown and platformKeyStateGet read the table itself. When the focus moves away, the game gets a release for every key still held and the table starts over, so no key stays stuck down. A key already held when the window gets the focus is seen once it repeats.</p>
<h2>Typed Characters and the Mouse</h2>
@ -8139,7 +8164,7 @@ musicMmlPlay(tune, &quot;MB T140 O3 L8 CDEC CDEC EFG4 EFG4&quot;);</code></pre>
<p>Every music plays through one audio context of the library's own; audio.lib mixes all streams, so modules and software MIDI of any number of programs play together. FM voices are shared with every program's tones and FM music; the MPU-401 port serves one music. When a program ends, its musics stop and are freed and their FM voices and the port are given back; the others go on.</p>
<h2>BASIC</h2>
<p>src/include/basic/music.bas (DECLARE LIBRARY &quot;music&quot;): MusicLoad(fileName) and MusicMidiOpen() return a music number (0 on failure: MusicError$ says why); MusicPlay(music, loopIt), MusicStop, MusicPause, MusicResume, MusicPlaying, MusicVolume(music, percent), MusicPosition, MusicLength, MusicSeek(music, ms), MusicFree; live MIDI MusicNoteOn(music, channel, note, velocity), MusicNoteOff, MusicProgram, MusicControl, MusicPitchBend with channels 1 to 16 (10 for drums). A number only works for the program that got it.</p>
<p>The BASIC runtime itself calls musicBasBeep, musicBasSound(hz, ticks), musicBasPlay(macro), musicBasPlayCount and musicBasBusy for the statements BEEP, SOUND, PLAY and the PLAY(n) function; each BASIC program has its own macro queue. SOUND's duration is in clock ticks (18.2 a second) and 0 stops the queue; BEEP is 800 Hz for a quarter second.</p>
<p>The BASIC runtime itself calls musicBasBeep, musicBasSound(hz, ticks), musicBasPlay(macro), musicBasPlayCount and musicBasBusy for the statements BEEP, SOUND, PLAY and the PLAY(n) function; each BASIC program has its own macro queue. QBasic's X command and &quot;=&quot; numbers (given with VARPTR$) are filled in by the BASIC runtime before musicBasPlay is called, so the macro language itself has neither. SOUND's duration is in clock ticks (18.2 a second) and 0 stops the queue; BEEP is 800 Hz for a quarter second.</p>
<h2>Licences</h2>
<p>libxmp-lite (Extended Module Player Lite), (C) 1996-2026 Claudio Matsuoka and Hipolito Carraro Jr, MIT licence:</p>
<p>Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the &quot;Software&quot;), 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 &quot;AS IS&quot;, 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.</p>
@ -9360,17 +9385,17 @@ btn-&gt;onClick = onOkClicked;</code></pre>
<h3>Methods (BASIC Interface)</h3>
<pre> Method Description
------ -----------
Clear color% Fill the entire canvas with a 0x00RRGGBB color.
Clear color% Fill the entire canvas with a color (&amp;HBBGGRR, as RGB() makes it).
DrawLine x0%, y0%, x1%, y1%, color% Draw a line between two points.
DrawRect x%, y%, w%, h%, color% Draw a rectangle outline.
DrawText x%, y%, text$ Draw text at the given position.
FillCircle cx%, cy%, radius%, color% Fill a circle.
FillRect x%, y%, w%, h%, color% Fill a rectangle.
GetPixel(x%, y%) Returns the 0x00RRGGBB color at a pixel.
GetPixel(x%, y%) Returns the color at a pixel (&amp;HBBGGRR).
Load(path$) Load a BMP, PNG, JPEG or GIF image (the canvas takes its size). Returns 0 on success, -1 on error (WGT_SIG_RET_INT_STR).
Resize w%, h% Resize the canvas (the drawing is cleared to white).
Save(path$) Save the canvas: BMP when path$ ends in .bmp, PNG otherwise. Returns 0 on success, -1 on error (WGT_SIG_RET_INT_STR).
SetPenColor color% Set the drawing color (0x00RRGGBB).
SetPenColor color% Set the drawing color (&amp;HBBGGRR).
SetPenSize size% Set the pen size in pixels (1 to 255).
SetPixel x%, y%, color% Set a single pixel.</pre>
<h3>Events</h3>
@ -9683,7 +9708,7 @@ btn-&gt;onClick = onSaveClicked;</code></pre>
<h3>Properties (BASIC Interface)</h3>
<pre> Property Type Access Description
-------- ---- ------ -----------
Picture String Read/Write Setting writes a file path (loads image). Reading returns the path of the loaded file (also set by wgtImageButtonFromFile); wgtImageButtonSetData clears it. Setting &quot;&quot; clears the image and the path; a file that cannot be loaded leaves both unchanged.
Picture String Read/Write Setting writes a file path (loads image). Reading returns the path of the loaded file (also set by wgtImageButtonFromFile); in BASIC the path comes as a Picture object, which stands for the path where a value is needed (see LOADPICTURE); wgtImageButtonSetData clears it. Setting &quot;&quot; clears the image and the path; a file that cannot be loaded leaves both unchanged.
ImageWidth Integer Read-only Width of the currently loaded image in pixels.
ImageHeight Integer Read-only Height of the currently loaded image in pixels.</pre>
<h3>Methods</h3>
@ -9723,7 +9748,7 @@ btn-&gt;onClick = onSaveClicked;</code></pre>
<h3>Properties (BASIC Interface)</h3>
<pre> Property Type Access Description
-------- ---- ------ -----------
Picture String Read/Write Setting writes a file path (loads image). Reading returns the path of the loaded file (also set by wgtImageFromFile); wgtImageSetData clears it. Setting &quot;&quot; clears the image and the path; a file that cannot be loaded leaves both unchanged.
Picture String Read/Write Setting writes a file path (loads image). Reading returns the path of the loaded file (also set by wgtImageFromFile); in BASIC the path comes as a Picture object, which stands for the path where a value is needed (see LOADPICTURE); wgtImageSetData clears it. Setting &quot;&quot; clears the image and the path; a file that cannot be loaded leaves both unchanged.
Stretch Boolean Read/Write When true, an image larger than the widget is scaled down to fit (aspect preserved, nearest neighbour); a smaller image stays at natural size. When false, shown at natural size. Changing it relayouts the widget.
ImageWidth Integer Read-only Width of the currently loaded image in pixels.
ImageHeight Integer Read-only Height of the currently loaded image in pixels.</pre>

BIN
screenshots/86box/hang-ended.png (Stored with Git LFS)
View file

Binary file not shown.

BIN
screenshots/86box/hang-taskmgr.png (Stored with Git LFS)
View file

Binary file not shown.

BIN
screenshots/86box/install-su-copy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/install-su-done.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/install-su-fold.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/install-su-lic.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/install-su-unin.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-cga1.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-cga2.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-full2.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-page0.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-pcopy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/scrpage-text40.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-copy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-done.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-fold.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-lic.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-unin.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/86box/upgrade-su-upgr.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/hang-ended.png (Stored with Git LFS)
View file

Binary file not shown.

BIN
screenshots/dosbox/hang-taskmgr.png (Stored with Git LFS)
View file

Binary file not shown.

BIN
screenshots/dosbox/install-in-desk.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-in-welc.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-copy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-disk.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-done.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-fold.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-lic.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-unin.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/install-su-wrong.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-cga1.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-cga2.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-full2.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-page0.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-pcopy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/scrpage-text40.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-copy.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-done.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-fold.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-lic.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-unin.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

BIN
screenshots/dosbox/upgrade-su-upgr.png (Stored with Git LFS) Normal file
View file

Binary file not shown.

2
screenshots/masks/install-su-disk.mask Normal file
View file

@ -0,0 +1,2 @@
# Status line and progress bar behind the prompt: the file being unpacked when the part ran out and how far it got (both change with the package)
72 106 496 48

4
screenshots/masks/install-su-fold.mask Normal file
View file

@ -0,0 +1,4 @@
# Setup's "DVX needs about N MB" figure (grows with the package) and the rest of that line
202 83 176 16
# Blinking text caret after C:\DVX in the folder box
123 131 3 18

2
screenshots/masks/install-su-wrong.mask Normal file
View file

@ -0,0 +1,2 @@
# Status line and progress bar behind the prompt: the file being unpacked when the part ran out and how far it got (both change with the package)
72 106 496 48

4
screenshots/masks/upgrade-su-fold.mask Normal file
View file

@ -0,0 +1,4 @@
# Setup's "DVX needs about N MB" figure (grows with the package) and the rest of that line
202 83 176 16
# Blinking text caret after C:\DVX in the folder box
123 131 3 18

2
src/apps/kpunch/dvxbasic/Makefile
View file

@ -58,7 +58,7 @@ SYSTEMDIR = ../../../../bin/system
# Sources every command-line build (bascomp, basrun, test_suite) links:
# the build pipeline, the full compiler and the runtime without forms.
COMP_SRCS = compiler/lexer.c compiler/parser.c compiler/codegen.c compiler/symtab.c compiler/strip.c compiler/obfuscate.c compiler/compact.c
COMP_SRCS = compiler/lexer.c compiler/ast.c compiler/scope.c compiler/parse.c compiler/parseExpr.c compiler/parseStmt.c compiler/parseDecl.c compiler/resolve.c compiler/resolveExpr.c compiler/typecheck.c compiler/fold.c compiler/gen.c compiler/genExpr.c compiler/genStmt.c compiler/compiler.c compiler/codegen.c compiler/strip.c compiler/obfuscate.c compiler/compact.c
VM_SRCS = runtime/vm.c runtime/values.c runtime/dates.c runtime/serialize.c runtime/gfx.c runtime/screen.c
# Standalone programs that link the VM also need what libdvx provides it
# at run time on the target (INI access through dvxPrefs).

58
src/apps/kpunch/dvxbasic/basBuild.c
View file

@ -47,6 +47,7 @@
#include "basBuild.h"
#include "basRes.h"
#include "compiler/compiler.h"
#include "compiler/compact.h"
#include "compiler/obfuscate.h"
#include "compiler/strip.h"
@ -77,8 +78,9 @@
// Growth unit of the project source buffer.
#define BAS_BUILD_SOURCE_CHUNK 8192
// Room for a BEGINFORM "name" / BEGINCLASS "name" line.
#define BAS_BUILD_WRAP_SLACK (BAS_MAX_IDENT + 32)
// Room a wrapper line needs besides its directive, name and control
// list: the space, the quotes, the newline and the NUL.
#define BAS_BUILD_WRAP_SLACK 8
// Longest [Modules]/[Forms] key, "File" plus a decimal index.
#define BAS_BUILD_KEY_LEN 32
@ -94,21 +96,23 @@ typedef enum {
BAS_BUILD_PASS_COUNT
} BasBuildPassE;
// The directives around a form's and a class module's code.
// The directives around a module's, a form's and a class module's code.
static const char *const sWrapBegin[] = {
[BAS_BUILD_WRAP_FORM] = "BEGINFORM",
[BAS_BUILD_WRAP_CLASS] = "BEGINCLASS"
[BAS_BUILD_WRAP_MODULE] = BAS_WRAP_BEGINMODULE,
[BAS_BUILD_WRAP_FORM] = BAS_WRAP_BEGINFORM,
[BAS_BUILD_WRAP_CLASS] = BAS_WRAP_BEGINCLASS
};
static const char *const sWrapEnd[] = {
[BAS_BUILD_WRAP_FORM] = "ENDFORM\n",
[BAS_BUILD_WRAP_CLASS] = "ENDCLASS\n"
[BAS_BUILD_WRAP_MODULE] = BAS_WRAP_ENDMODULE "\n",
[BAS_BUILD_WRAP_FORM] = BAS_WRAP_ENDFORM "\n",
[BAS_BUILD_WRAP_CLASS] = BAS_WRAP_ENDCLASS "\n"
};
// Function prototypes (alphabetical)
static bool appendSource(BasProjectSourceT *ps, const char *text, int32_t len);
static int32_t appendText(const char *path, const char *name, const char *value);
const char *basBuildApp(const char *outPath, const BasBuildSpecT *spec);
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, int32_t *textLine, int32_t *textLines);
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, const char *ctrlList, int32_t *textLine, int32_t *textLines);
bool basBuildConcatProject(PrefsHandleT *prefs, const char *projectDir, BasProjectSourceT *out);
void basBuildDirOf(const char *path, char *out, int32_t outSize);
void basBuildFreeProject(BasProjectSourceT *out);
@ -240,17 +244,24 @@ const char *basBuildApp(const char *outPath, const BasBuildSpecT *spec) {
}
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, int32_t *textLine, int32_t *textLines) {
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, const char *ctrlList, int32_t *textLine, int32_t *textLines) {
if (wrap != BAS_BUILD_WRAP_NONE) {
char line[BAS_BUILD_WRAP_SLACK];
int32_t n = snprintf(line, sizeof(line), "%s \"%s\"\n", sWrapBegin[wrap], name);
// One line: the directive, the name and a form's controls
const char *ctrls = (ctrlList != NULL) ? ctrlList : "";
size_t cap = strlen(sWrapBegin[wrap]) + strlen(name) + strlen(ctrls) + BAS_BUILD_WRAP_SLACK;
char *line = (char *)malloc(cap);
if (n < 0 || n >= (int32_t)sizeof(line)) {
snprintf(ps->error, sizeof(ps->error), "Name too long: %s", name);
if (!line) {
snprintf(ps->error, sizeof(ps->error), "Out of memory.");
return false;
}
if (!appendSource(ps, line, n)) {
int32_t n = snprintf(line, cap, "%s \"%s\"%s\n", sWrapBegin[wrap], name, ctrls);
bool ok = appendSource(ps, line, n);
free(line);
if (!ok) {
return false;
}
}
@ -315,7 +326,7 @@ bool basBuildConcatProject(PrefsHandleT *prefs, const char *projectDir, BasProje
const char *code = src;
char formName[BAS_MAX_IDENT] = "";
BasBuildWrapE wrap = BAS_BUILD_WRAP_NONE;
BasBuildWrapE wrap = BAS_BUILD_WRAP_MODULE;
entry.firstFileLine = 1;
@ -351,7 +362,22 @@ bool basBuildConcatProject(PrefsHandleT *prefs, const char *projectDir, BasProje
wrap = BAS_BUILD_WRAP_FORM;
}
if (!basBuildAppendFile(out, code, (int32_t)strlen(code), wrap, formName, &entry.startLine, &entry.lineCount)) {
// A form's BEGINFORM line lists its controls (never longer than
// the .frm text that declares them)
char *ctrlList = isForm ? (char *)malloc((size_t)srcLen + 1) : NULL;
if (isForm && (!ctrlList || basFrmControlList(src, srcLen, ctrlList, srcLen + 1) < 0)) {
snprintf(out->error, sizeof(out->error), "Out of memory.");
free(ctrlList);
free(src);
return false;
}
bool appended = basBuildAppendFile(out, code, (int32_t)strlen(code), wrap, formName, ctrlList, &entry.startLine, &entry.lineCount);
free(ctrlList);
if (!appended) {
free(src);
return false;
}

11
src/apps/kpunch/dvxbasic/basBuild.h
View file

@ -99,7 +99,7 @@ typedef struct {
} BasSourceMapT;
// A project's BASIC source as the compiler consumes it: every [Modules]
// file in order, then the code of every [Classes] file wrapped in
// file in order wrapped in BEGINMODULE "name" / ENDMODULE, then the code of every [Classes] file wrapped in
// BEGINCLASS "name" / ENDCLASS, then the code section of every [Forms]
// file wrapped in BEGINFORM "name" / ENDFORM, each file ending on a
// newline. frmPaths
@ -120,18 +120,21 @@ typedef struct {
// What basBuildAppendFile wraps a file's text in.
typedef enum {
BAS_BUILD_WRAP_NONE, // a module: the text as it is
BAS_BUILD_WRAP_NONE, // the text as it is (a lone program)
BAS_BUILD_WRAP_MODULE, // a project's module: BEGINMODULE "name" / ENDMODULE (its Private CONST / ENUM stay in it)
BAS_BUILD_WRAP_FORM, // a form's code: BEGINFORM "name" / ENDFORM
BAS_BUILD_WRAP_CLASS // a class module's code: BEGINCLASS "name" / ENDCLASS
} BasBuildWrapE;
// Appends one file's text to *ps (a zeroed struct is a valid empty
// project) and makes sure it ends on a newline, wrapped as wrap says in
// the directives naming name. textLine and textLines (either may be
// the directives naming name; a form's BEGINFORM line also lists its
// controls, ctrlList (basFrmControlList's text; NULL or "" for none).
// textLine and textLines (either may be
// NULL) receive the 1-based line the text starts on and the number of
// lines it occupies, wrapper lines excluded -- what an IDE source map
// needs. Returns false with ps->error set on failure.
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, int32_t *textLine, int32_t *textLines);
bool basBuildAppendFile(BasProjectSourceT *ps, const char *text, int32_t len, BasBuildWrapE wrap, const char *name, const char *ctrlList, int32_t *textLine, int32_t *textLines);
// Reads the source files named by an open .dbp (paths relative to
// projectDir) into *out. Returns false with out->error set on failure;

164
src/apps/kpunch/dvxbasic/basRes.h
View file

@ -136,11 +136,19 @@ const char *dvxSkipWs(const char *s);
// .frm scanners (shared by bascomp, basstub, basBuild and the obfuscator)
// ------------------------------------------------------------
// basFrmControlList entries: ' "Name"' -- a space and a quote before the
// name, a quote after it.
#define BAS_FRM_LIST_ENTRY_LEAD 2
#define BAS_FRM_LIST_ENTRY_EXTRA 3
static inline int32_t basClassCodePos(const char *text, int32_t len);
static inline bool basClassHeaderLine(const char *s, int32_t len);
static inline bool basClassNameAttr(const char *text, int32_t len, int32_t *outStart, int32_t *outLen);
static inline bool basExtractClassName(const char *text, int32_t len, const char *path, char *nameBuf, int32_t nameBufSize);
static inline bool basExtractFormName(const char *frmText, char *nameBuf, int32_t nameBufSize);
static inline int32_t basFindFormEndPos(const char *text, int32_t len);
static inline int32_t basFrmControlList(const char *frmText, int32_t frmLen, char *out, int32_t outSize);
static inline bool basFrmListHas(const char *list, int32_t listLen, const char *name, int32_t nameLen);
static inline bool basLineIsWord(const char *s, int32_t len, const char *word);
static inline int32_t basMatchBeginForm(const char *s, int32_t len);
static inline int32_t basMatchKeywordWs(const char *s, int32_t len, const char *kw, int32_t kwLen);
@ -202,33 +210,53 @@ static inline bool basClassHeaderLine(const char *s, int32_t len) {
}
// The class name of a .cls text: its Attribute VB_Name = "name" when the
// header has one, else the base name of path (without directory and
// extension). Returns false when neither gives a name.
static inline bool basExtractClassName(const char *text, int32_t len, const char *path, char *nameBuf, int32_t nameBufSize) {
// Where the name in a .cls header's Attribute VB_Name = "name" is: its
// offset and length in text (the length may be 0). False when the header
// has no such attribute.
static inline bool basClassNameAttr(const char *text, int32_t len, int32_t *outStart, int32_t *outLen) {
int32_t codePos = basClassCodePos(text, len);
int32_t attrLen = (int32_t)sizeof(BAS_CLS_ATTR_NAME) - 1;
nameBuf[0] = '\0';
for (int32_t pos = 0; pos < codePos; pos++) {
if ((pos == 0 || text[pos - 1] == ' ' || text[pos - 1] == '\t') && codePos - pos > attrLen && strncasecmp(text + pos, BAS_CLS_ATTR_NAME, attrLen) == 0) {
const char *q = memchr(text + pos, '"', codePos - pos);
if (q) {
int32_t ni = 0;
for (q++; q < text + codePos && *q != '"' && *q != '\n' && ni < nameBufSize - 1; q++) {
nameBuf[ni++] = *q;
if (!q) {
return false;
}
nameBuf[ni] = '\0';
const char *end = ++q;
while (end < text + codePos && *end != '"' && *end != '\n') {
end++;
}
break;
*outStart = (int32_t)(q - text);
*outLen = (int32_t)(end - q);
return true;
}
}
return false;
}
// The class name of a .cls text: its Attribute VB_Name = "name" when the
// header has one, else the base name of path (without directory and
// extension). Returns false when neither gives a name.
static inline bool basExtractClassName(const char *text, int32_t len, const char *path, char *nameBuf, int32_t nameBufSize) {
int32_t start = 0;
int32_t nameLen = 0;
nameBuf[0] = '\0';
if (basClassNameAttr(text, len, &start, &nameLen)) {
int32_t n = (nameLen < nameBufSize - 1) ? nameLen : nameBufSize - 1;
memcpy(nameBuf, text + start, (size_t)n);
nameBuf[n] = '\0';
}
if (nameBuf[0] == '\0' && path) {
const char *base = path;
@ -365,6 +393,116 @@ static inline int32_t basFindFormEndPos(const char *text, int32_t len) {
}
// The controls a .frm declares, for the BEGINFORM line of the form's code
// (the compiler then knows a bare control name: Text1 = "x", col.Add
// Text1): every "Begin Type Name" line of its Begin Form block but the
// form's own, each name (a control array's included) once, written to out
// as quoted words with a space before each (' "Text1" "Label1"').
// Returns the length written (0 for none), or -1 when out (outSize bytes)
// is too small.
static inline int32_t basFrmControlList(const char *frmText, int32_t frmLen, char *out, int32_t outSize) {
int32_t end = basFindFormEndPos(frmText, frmLen);
int32_t outLen = 0;
int32_t pos = 0;
bool first = true;
if (outSize <= 0) {
return -1;
}
out[0] = '\0';
while (pos < end) {
int32_t l = pos;
while (pos < end && frmText[pos] != '\n' && frmText[pos] != '\r') {
pos++;
}
int32_t lineEnd = pos;
while (pos < end && (frmText[pos] == '\n' || frmText[pos] == '\r')) {
pos++;
}
while (l < lineEnd && (frmText[l] == ' ' || frmText[l] == '\t')) {
l++;
}
int32_t b = basMatchKeywordWs(frmText + l, lineEnd - l, FRM_KW_BEGIN, FRM_KW_BEGIN_LEN);
if (b < 0) {
continue;
}
// Skip the type; the name follows it
int32_t n = l + b;
while (n < lineEnd && frmText[n] != ' ' && frmText[n] != '\t') {
n++;
}
while (n < lineEnd && (frmText[n] == ' ' || frmText[n] == '\t')) {
n++;
}
int32_t nameLen = 0;
while (n + nameLen < lineEnd && frmText[n + nameLen] != ' ' && frmText[n + nameLen] != '\t') {
nameLen++;
}
// The form itself, or a line without a name
if (first || nameLen == 0) {
first = false;
continue;
}
// A control array declares its name on several lines
if (basFrmListHas(out, outLen, frmText + n, nameLen)) {
continue;
}
if (outLen + nameLen + BAS_FRM_LIST_ENTRY_EXTRA >= outSize) {
return -1;
}
out[outLen++] = ' ';
out[outLen++] = '"';
memcpy(out + outLen, frmText + n, (size_t)nameLen);
outLen += nameLen;
out[outLen++] = '"';
out[outLen] = '\0';
}
return outLen;
}
// True when list (listLen bytes, basFrmControlList's ' "Name"' entries)
// holds name (nameLen bytes), compared without case.
static inline bool basFrmListHas(const char *list, int32_t listLen, const char *name, int32_t nameLen) {
int32_t i = 0;
while (i < listLen) {
int32_t start = i + BAS_FRM_LIST_ENTRY_LEAD;
int32_t stop = start;
while (stop < listLen && list[stop] != '"') {
stop++;
}
if (stop - start == nameLen && strncasecmp(list + start, name, (size_t)nameLen) == 0) {
return true;
}
i = stop + 1;
}
return false;
}
// True when s[0..len) (left-trimmed) starts with word followed by the end
// of the line or a space or tab.
static inline bool basLineIsWord(const char *s, int32_t len, const char *word) {

17
src/apps/kpunch/dvxbasic/basrt.dhs
View file

@ -72,9 +72,11 @@ Header: apps/dvxbasic/runtime/values.h
BAS_TYPE_ARRAY 6 arrVal Reference-counted array.
BAS_TYPE_UDT 7 udtVal Reference-counted user-defined type.
BAS_TYPE_OBJECT 8 objVal Opaque host pointer (form, control).
BAS_TYPE_REF 9 refVal ByRef pointer to a BasValueT slot.
BAS_TYPE_REF 9 ref Reference (ByRef argument): ref.target is the variable, element or field it names; ref.owner keeps that storage alive.
.endtable
A reference only ever lives in a call's parameters (a ByRef parameter, a ParamArray element). Read through it with basValDeref, which returns the value a reference names (or the value itself). refKind says what ref.owner is: BAS_REF_SLOT (none: a global, local or form variable), BAS_REF_ARRAY (the array, counted and locked so REDIM / ERASE raise error 10), BAS_REF_UDT (the TYPE instance holding the field), BAS_REF_OBJECT (the class instance holding the member variable) or BAS_REF_CELL (a BasRefCellT holding both the locked array and the TYPE instance, for a field of an array element). refType is the target's declared type (stores convert to it) and refLen the length of a STRING * n target. basValCopy and basValRelease count the owner.
.h2 BasValueT
Tagged union holding any BASIC value.
@ -82,6 +84,9 @@ Tagged union holding any BASIC value.
.code
struct BasValueTag {
uint8_t type; // BAS_TYPE_*
uint8_t refType : 5; // BAS_TYPE_REF: the target's declared type
uint8_t refKind : 3; // BAS_TYPE_REF: BasRefKindE
uint16_t refLen; // BAS_TYPE_REF: STRING * n length (0 = none)
union {
int16_t intVal;
int32_t longVal;
@ -92,9 +97,15 @@ struct BasValueTag {
BasArrayT *arrVal;
BasUdtT *udtVal;
void *objVal;
BasValueT *refVal;
BasObjectT *instVal;
struct {
void *owner;
BasValueT *target;
} ref;
};
};
BasValueT *basValDeref(const BasValueT *v); // inline: what a reference names, else v
.endcode
.h2 Value Constructors
@ -475,7 +486,7 @@ bool basVmCallSubWithArgsOut(BasVmT *vm, int32_t codeAddr,
-------- -----------
basVmCallSub Call a SUB with no arguments.
basVmCallSubWithArgs Call a SUB with arguments pushed onto the stack frame.
basVmCallSubWithArgsOut Call a SUB and read back modified argument values after it returns.
basVmCallSubWithArgsOut Call a SUB whose first outCount parameters are references to outArgs (set to the arguments first; each must hold a valid value): what the SUB stores in them is there when it returns, also after an error.
.endtable
All three push a call frame, execute until the SUB returns, then restore the previous execution state. Return true on normal completion, false on error or if the VM is not idle.

156
src/apps/kpunch/dvxbasic/compiler/ast.c Normal file
View file

@ -0,0 +1,156 @@
// 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.
// ast.c -- DVX BASIC syntax tree arena
#include "ast.h"
#include <stdlib.h>
#include <string.h>
// Function prototypes (alphabetical)
void *basArenaAlloc(BasArenaT *a, int32_t size);
void basArenaFree(BasArenaT *a);
void basArenaInit(BasArenaT *a);
BasArenaMarkT basArenaMark(const BasArenaT *a);
void basArenaRelease(BasArenaT *a, BasArenaMarkT mark);
char *basArenaStrDup(BasArenaT *a, const char *text, int32_t len);
int32_t basNodeCount(const BasNodeT *list);
BasNodeT *basNodeNew(BasArenaT *a, int32_t size, uint8_t kind, int32_t line, int32_t col);
static BasArenaBlockT *blockNew(BasArenaT *a, int32_t cap);
// Zeroed, aligned memory from the arena (NULL when memory runs out).
void *basArenaAlloc(BasArenaT *a, int32_t size) {
int32_t need = (size + BAS_ARENA_ALIGN - 1) & ~(BAS_ARENA_ALIGN - 1);
if (a->head == NULL || a->head->used + need > a->head->cap) {
if (blockNew(a, need > BAS_ARENA_BLOCK_SIZE ? need : BAS_ARENA_BLOCK_SIZE) == NULL) {
return NULL;
}
}
void *p = a->head->data + a->head->used;
a->head->used += need;
memset(p, 0, (size_t)size);
return p;
}
void basArenaFree(BasArenaT *a) {
while (a->head != NULL) {
BasArenaBlockT *next = a->head->next;
free(a->head);
a->head = next;
}
a->bytes = 0;
}
void basArenaInit(BasArenaT *a) {
memset(a, 0, sizeof(*a));
}
BasArenaMarkT basArenaMark(const BasArenaT *a) {
BasArenaMarkT m;
m.block = a->head;
m.used = (a->head != NULL) ? a->head->used : 0;
return m;
}
// Frees every block allocated after the mark and rewinds the mark's block.
void basArenaRelease(BasArenaT *a, BasArenaMarkT mark) {
while (a->head != NULL && a->head != mark.block) {
BasArenaBlockT *next = a->head->next;
a->bytes -= a->head->cap;
free(a->head);
a->head = next;
}
if (a->head != NULL) {
a->head->used = mark.used;
}
}
char *basArenaStrDup(BasArenaT *a, const char *text, int32_t len) {
char *s = (char *)basArenaAlloc(a, len + 1);
if (s != NULL) {
memcpy(s, text, (size_t)len);
s[len] = '\0';
}
return s;
}
int32_t basNodeCount(const BasNodeT *list) {
int32_t n = 0;
for (; list != NULL; list = list->next) {
n++;
}
return n;
}
BasNodeT *basNodeNew(BasArenaT *a, int32_t size, uint8_t kind, int32_t line, int32_t col) {
BasNodeT *n = (BasNodeT *)basArenaAlloc(a, size);
if (n != NULL) {
n->kind = kind;
n->line = line;
n->col = (uint16_t)((col > UINT16_MAX) ? UINT16_MAX : col);
n->type = BAS_NODE_TYPE_UNKNOWN;
}
return n;
}
// A new block of cap usable bytes, made the head.
static BasArenaBlockT *blockNew(BasArenaT *a, int32_t cap) {
BasArenaBlockT *b = (BasArenaBlockT *)malloc(sizeof(BasArenaBlockT) + (size_t)cap);
if (b == NULL) {
return NULL;
}
b->next = a->head;
b->used = 0;
b->cap = cap;
b->data = (uint8_t *)(b + 1);
a->head = b;
a->bytes += cap;
return b;
}

491
src/apps/kpunch/dvxbasic/compiler/ast.h Normal file
View file

@ -0,0 +1,491 @@
// 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.
// ast.h -- DVX BASIC syntax tree and arena allocator
//
// The parser builds one top-level unit at a time (a module-level
// statement, a procedure, a TYPE ...) as a tree in the unit arena; the
// passes (resolve, typecheck, fold) annotate and rewrite it in place and
// the generator turns it into p-code, after which the arena is released
// to its mark. Module-lifetime data (symbols, names) lives in a second
// arena.
//
// Every node starts with BasNodeT. Expression nodes come in five shapes
// (literal, name, call, member, operator) and change their kind in place
// when the resolver decides what they are (an NK_CALL becomes NK_ELEM,
// NK_FCALL, NK_BUILTIN ...); statements have one struct per family.
// Lists (statements, arguments, parameters ...) are linked through
// BasNodeT.next.
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_AST_H
#define DVXBASIC_AST_H
#include "opcodes.h"
#include <stdbool.h>
#include <stdint.h>
// ============================================================
// Arena
// ============================================================
// Bytes per arena block (an allocation larger than this gets a block of
// its own). Small enough that a short program costs little on DOS.
#define BAS_ARENA_BLOCK_SIZE 8192
// Allocation alignment (doubles in literal nodes).
#define BAS_ARENA_ALIGN 8
typedef struct BasArenaBlockS {
struct BasArenaBlockS *next; // the block allocated before this one
int32_t used; // bytes handed out
int32_t cap; // bytes in data
uint8_t *data; // follows the header in the same allocation
} BasArenaBlockT;
typedef struct {
BasArenaBlockT *head; // newest block
int32_t bytes; // bytes allocated from the system (blocks)
} BasArenaT;
// A point to release back to (basArenaRelease).
typedef struct {
BasArenaBlockT *block;
int32_t used;
} BasArenaMarkT;
// ============================================================
// Node kinds
// ============================================================
typedef enum {
// Literals (BasLitT)
NK_INT, // ival; type INTEGER (fits 16 bits, from an INTEGER literal) or LONG
NK_DBL, // dval; type DOUBLE, or SINGLE / DATE / CURRENCY (cval) for a folded value of that type
NK_STR, // str, slen
NK_BOOL, // ival (-1 / 0)
NK_SPECIAL, // ival = BasSpecialValE (Empty, Null, Nothing, Missing)
// Names (BasNameT)
NK_NAME, // an identifier not resolved yet
NK_VAR, // sym: a variable (or a whole array)
NK_RESULT, // the result slot of the FUNCTION being compiled (its name inside it)
NK_ME, // Me: the form, or the instance in a class module
NK_LOADFORM, // name: the form of that name (OP_LOAD_FORM)
NK_NEW, // name: New ClassName / New Collection; aux = class number after resolve
NK_OMIT, // an argument left out (f(a, , b)); the resolver replaces it
NK_WITHREF, // BasMemberT: the object a leading '.' names inside WITH ... END WITH; target = the BasWithT
NK_NAMEDARG, // BasMemberT: an argument given by name (Name:=value): name, base = the value; the resolver puts it in its parameter's place
// Calls and indexing (BasCallT)
NK_CALL, // callee(args) not resolved yet
NK_ELEM, // callee (NK_VAR) indexed by args: an array element, or what a Variant / Object holds
NK_FCALL, // target = the SUB / FUNCTION symbol; args bound to its parameters
NK_BUILTIN, // target = the BasBuiltinT; args
NK_INTRINSIC, // aux = opcode, aux2 = operand byte (when > BAS_NO_OPERAND); args pushed in order (keyword functions)
NK_METHOD, // callee = NK_MEMBER (object, method name); args: OP_CALL_METHOD
NK_FINDCTRLIDX, // callee = NK_MEMBER (form or NULL, control name); args = the index: OP_FIND_CTRL_IDX
NK_PARAMARRAY, // aux = element type; args packed into the ParamArray (BAS_FN_PARAMARRAY)
NK_INDEX, // callee = a value (a call's result: c(1)(0), Split(s)(1)) indexed by args: an element of the array it gives, or its default member
NK_OBJMEMBER, // early bound: callee = the object, args bound to the member; aux = class operand (class number, BAS_NEW_COLLECTION), aux2 = Collection member, target = the member's BasSymT (NULL for a Collection); NF_STATEMENT: called as a statement
// Member access (BasMemberT)
NK_MEMBER, // base.name not resolved yet
NK_FIELD, // base is a TYPE value; aux = field index, target = the BasFieldT
NK_PROP, // base is an object; name (member name as pushed): OP_LOAD_PROP
NK_FINDCTRL, // base = the form (NULL: the current form), name = control: OP_FIND_CTRL
NK_TYPEOF, // TypeOf base Is name
// Operators (BasOpT)
NK_UNARY, // op (TOK_MINUS, TOK_NOT), a
NK_BINARY, // op (the token), a, b
NK_CONV, // a converted by op (an OP_CONV_* opcode, OP_STR_FIXLEN with aux = length); op OP_POP: a is evaluated and dropped
NK_REF, // a reference to a (NK_VAR, NK_ELEM, NK_FIELD chain) for a ByRef parameter; aux = declared store type
// Statements
ST_ASSIGN, // BasStmtT: a = target, b = value, ival = BAS_ASSIGN_SET for SET
ST_CALL, // BasStmtT: a = callee chain, b = arguments, ival = BasArgFormE, ival2 = argc
ST_EXPR, // BasStmtT: a = an expression whose value is dropped (MsgBox, CreateForm ...)
ST_SIMPLE, // BasStmtT: ival = opcode, b = arguments pushed in order (KILL, MKDIR ...)
ST_PRINT, // BasPrintT
ST_IF, // BasIfT
ST_ELSEIF, // BasIfT (cond, thenBody) inside an ST_IF's elseIfs
ST_FOR, // BasLoopT
ST_FOREACH, // BasLoopT
ST_DO, // BasLoopT
ST_WHILE, // BasLoopT
ST_SELECT, // BasSelectT
ST_CASE, // BasCaseT
ST_CASEITEM, // BasCaseItemT
ST_EXIT, // BasStmtT: ival = TOK_FOR / TOK_DO / TOK_SUB / TOK_FUNCTION / TOK_PROPERTY
ST_GOTO, // BasStmtT: name
ST_GOSUB, // BasStmtT: name
ST_RETURN, // BasStmtT
ST_ONGOTO, // BasStmtT: a = selector, b = labels (NK_NAME list), ival = 1 for GOSUB
ST_ONERROR, // BasStmtT: name (NULL: ON ERROR GOTO 0); ival BAS_ON_ERROR_RESUME_NEXT: ON ERROR RESUME NEXT
ST_RESUME, // BasStmtT: ival = 1 for RESUME NEXT; name: RESUME label
ST_LABEL, // BasStmtT: name; ival BAS_LABEL_LINE_NUMBER: a line number (ival2 its value)
ST_END, // BasStmtT
ST_DIM, // BasStmtT: a = BasDeclT list, ival = BasDimFlagsE
ST_REDIM, // BasStmtT: name, a = bounds (BasBoundT), b = type (BasTypeSpecT or NULL), ival = BasDimFlagsE
ST_ERASE, // BasStmtT: a = the arrays (NK_NAME list; NK_VAR after resolve)
ST_STATIC, // BasStmtT: a = BasDeclT list
ST_SHARED, // BasStmtT: a = BasDeclT list
ST_CONST, // BasStmtT: a = BasConstT list, ival = BasDimFlagsE (Public / Private)
ST_TYPEDEF, // BasStmtT: name, a = fields (BasDeclT list)
ST_ENUM, // BasStmtT: name, a = members (BasConstT list, expr may be NULL), ival = BasDimFlagsE (Public / Private)
ST_PROC, // BasProcT: SUB / FUNCTION / Property definition
ST_DECLARE, // BasProcT (no body): DECLARE SUB / FUNCTION
ST_DECLARELIB, // BasStmtT: name = library, a = BasProcT list
ST_DEFFN, // BasProcT: body = the expression
ST_DEFTYPE, // BasStmtT: ival = type, ival2 = letter mask (bit 0 = A)
ST_OPTION, // BasStmtT: ival = BasOptionE, ival2 = value
ST_BEGINFORM, // BasStmtT: name, a = the form's controls (NK_STR list)
ST_ENDFORM, // BasStmtT
ST_BEGINCLASS, // BasStmtT: name
ST_ENDCLASS, // BasStmtT
ST_BEGINMODULE, // BasStmtT: name (a project's module; its Private CONST / ENUM stay in it)
ST_ENDMODULE, // BasStmtT
ST_ATTRIBUTE, // BasStmtT: name = member, ival = 1 when it makes the default member
ST_EVENT, // BasProcT (no body): Event Name(params)
ST_IMPLEMENTS, // BasStmtT: name
ST_RAISEEVENT, // BasStmtT: name, b = arguments, ival2 = argc
ST_MIDASSIGN, // BasStmtT: name, a = start, b = length (NULL: omitted), c = value
ST_LSET, // BasStmtT: a = target, c = value, ival = 1 for RSET
ST_SWAP, // BasStmtT: a, b
ST_READ, // BasStmtT: a = targets
ST_DATA, // BasStmtT: a = items (literals)
ST_RESTORE, // BasStmtT: name (NULL: the first DATA)
ST_INPUT, // BasStmtT: a = channel (NULL: console), b = prompt (NK_STR or NULL), c = targets
ST_LINEINPUT, // BasStmtT: a = channel (NULL: console), b = prompt (NK_STR or NULL), c = target
ST_OPEN, // BasStmtT: a = file, b = channel, c = record length (NULL: default), ival = mode
ST_GET, // BasStmtT: a = channel, b = record (NULL: current), c = target
ST_PUT, // BasStmtT: a = channel, b = record (NULL: current), c = value
ST_WRITE, // BasStmtT: a = channel, b = values
ST_SCREEN, // BasStmtT: ival = BasBuiltinFnE, b = arguments (NULL entries push 0), ival2 = argc
ST_LOAD, // BasStmtT: name (Load FormName)
ST_UNLOAD, // BasStmtT: name (NULL: Unload Me)
ST_WITH, // BasWithT: WITH object ... END WITH
// Declaration parts
NK_DECL, // BasDeclT: one DIM / SHARED declarator or TYPE field
NK_BOUND, // BasBoundT: one dimension's bounds
NK_TYPESPEC, // BasTypeSpecT: the type after AS
NK_PARAM, // BasParamT: one parameter
NK_CONSTDECL, // BasConstT: one CONST declarator or ENUM member
NK_PRINTITEM, // BasPrintItemT
NK_COUNT
} BasNodeKindE;
// BasNodeT.flags
#define NF_PAREN 0x0001 // the expression was written in parentheses (a value, never a reference)
#define NF_MEMBERBASE 0x0002 // the expression is the base of a member access (name.member)
#define NF_OBJECTARG 0x0004 // an object is expected here: a bare undeclared name is a control or form
#define NF_STATEMENT 0x0008 // a call or member access that is a whole statement
#define NF_NEG 0x0010 // NK_INT / NK_DBL: written with a leading minus folded in (CONST, DATA)
#define NF_SET 0x0020 // ST_ASSIGN: SET
#define NF_HOSTOBJ 0x0040 // NK_METHOD / NK_PROP: the object is a control or form the source names (host methods take values)
#define NF_DEFERRED 0x0080 // ST_CALL: drawing method arguments read later (see BasStmtT.ival2)
#define NF_INCONST 0x0100 // resolved inside a constant expression
#define NF_SHAREDARG 0x0200 // a RaiseEvent value for a ByRef parameter: passed as a reference to one temporary every handler shares
// No operand byte for an NK_INTRINSIC.
#define BAS_NO_OPERAND (-1)
// BasNodeT.type of an expression whose run-time type is not known
// statically (BAS_TYPE_VARIANT: it may hold anything).
#define BAS_NODE_TYPE_UNKNOWN BAS_TYPE_VARIANT
// How a call statement wrote its arguments.
typedef enum {
BAS_ARGS_NONE, // name alone
BAS_ARGS_PARENS, // name(args)
BAS_ARGS_BARE, // name args (no parentheses)
BAS_ARGS_CALLKW, // CALL name or CALL name(args)
BAS_ARGS_DRAWING // a drawing method's QBasic syntax read: b = its argument block (Print: BasPrintItemT list)
} BasArgFormE;
// ST_DIM / ST_REDIM flags.
typedef enum {
BAS_DIM_SHARED = 0x01, // DIM SHARED / REDIM SHARED
BAS_DIM_PUBLIC = 0x02, // Public: a module variable visible in procedures; a public class member
BAS_DIM_PRIVATE = 0x04, // Private
BAS_DIM_PRESERVE = 0x08 // REDIM PRESERVE
} BasDimFlagsE;
// ST_OPTION kinds.
typedef enum {
BAS_OPTION_BASE,
BAS_OPTION_COMPARE,
BAS_OPTION_EXPLICIT
} BasOptionE;
// BasParamT.flags
#define PF_OPTIONAL 0x01
#define PF_BYVAL 0x02 // ByVal written (or forced: DEF FN)
#define PF_BYREF 0x04 // ByRef written
#define PF_PARAMARRAY 0x08
#define PF_ARRAY 0x10 // name()
#define PF_TYPED 0x20 // AS clause, suffix or DEFxxx gave a type
// BasPrintT.mode
typedef enum {
BAS_PRINT_CONSOLE,
BAS_PRINT_USING
} BasPrintModeE;
// BasPrintItemT.kind
typedef enum {
BAS_ITEM_EXPR,
BAS_ITEM_SEMI,
BAS_ITEM_COMMA,
BAS_ITEM_SPC,
BAS_ITEM_TAB
} BasItemKindE;
// BasCaseItemT.kind
typedef enum {
BAS_CASE_VALUE,
BAS_CASE_RANGE,
BAS_CASE_IS
} BasCaseKindE;
// ============================================================
// Nodes
// ============================================================
typedef struct BasNodeS BasNodeT;
struct BasNodeS {
BasNodeT *next; // next node in a list
int32_t line; // source line (1-based)
uint16_t col; // source column (1-based; 0 = unknown)
uint8_t kind; // BasNodeKindE
uint8_t type; // static type after typecheck (BAS_TYPE_*; BAS_TYPE_VARIANT: not known)
uint16_t flags; // NF_*
};
typedef struct {
BasNodeT h;
int32_t ival;
double dval;
int64_t cval; // NK_DBL of type CURRENCY: the exact amount times BAS_CURRENCY_SCALE (dval holds the amount)
const char *str; // NK_STR (may hold NULs)
int32_t slen;
} BasLitT;
typedef struct {
BasNodeT h;
const char *name;
struct BasSymS *sym;
int32_t aux;
} BasNameT;
typedef struct {
BasNodeT h;
BasNodeT *callee;
BasNodeT *args; // list; NK_OMIT for an argument left out
int16_t argc;
int16_t aux2;
int32_t aux;
const void *target; // resolved symbol / built-in
} BasCallT;
typedef struct {
BasNodeT h;
BasNodeT *base;
const char *name;
int32_t aux;
const void *target;
} BasMemberT;
typedef struct {
BasNodeT h;
BasNodeT *a;
BasNodeT *b;
int32_t aux;
uint8_t op;
} BasOpT;
typedef struct {
BasNodeT h;
BasNodeT *a;
BasNodeT *b;
BasNodeT *c;
const char *name;
int32_t ival;
int32_t ival2;
struct BasSymS *sym; // resolved symbol (label, variable ...)
} BasStmtT;
typedef struct {
BasNodeT h;
BasNodeT *cond;
BasNodeT *thenBody;
BasNodeT *elseIfs; // ST_ELSEIF list
BasNodeT *elseBody;
bool singleLine;
bool hasElse;
} BasIfT;
typedef struct {
BasNodeT h;
BasNodeT *var; // FOR / FOR EACH counter or item (NK_NAME)
BasNodeT *from; // FOR start; FOR EACH group
BasNodeT *to;
BasNodeT *step; // NULL: 1
BasNodeT *preCond; // DO WHILE / UNTIL, WHILE
BasNodeT *postCond;
BasNodeT *body;
const char *nextName; // the name after NEXT (NULL: none)
int32_t nextLine;
int32_t nextCol; // the name after NEXT: its position
struct BasSymS *hidden[2]; // FOR EACH group and position variables
bool preUntil;
bool postUntil;
} BasLoopT;
typedef struct {
BasNodeT h;
BasNodeT *expr;
BasNodeT *cases; // ST_CASE list
} BasSelectT;
typedef struct BasWithS {
BasNodeT h;
BasNodeT *expr; // the object or TYPE record ".name" refers to
BasNodeT *body;
struct BasWithS *outer; // the WITH block around this one (parser)
struct BasSymS *hidden; // the variable holding the object, evaluated once (NULL: expr itself is used at each '.')
} BasWithT;
typedef struct {
BasNodeT h;
BasNodeT *items; // ST_CASEITEM list (empty for CASE ELSE)
BasNodeT *body;
bool isElse;
} BasCaseT;
typedef struct {
BasNodeT h;
BasNodeT *a;
BasNodeT *b; // BAS_CASE_RANGE upper bound
uint8_t kind; // BasCaseKindE
uint8_t cmpOp; // BAS_CASE_IS: the comparison opcode
} BasCaseItemT;
typedef struct {
BasNodeT h;
const char *name; // NULL: a keyword type (tok)
int32_t tok; // TOK_INTEGER ... (a keyword type), else TOK_IDENT
int32_t fixedLen;// STRING * n
bool isNew; // AS NEW
} BasTypeSpecT;
typedef struct {
BasNodeT h;
BasNodeT *lower; // NULL: OPTION BASE
BasNodeT *upper;
} BasBoundT;
typedef struct {
BasNodeT h;
const char *name;
BasNodeT *bounds; // BasBoundT list
BasTypeSpecT *spec; // NULL: no AS clause
struct BasSymS *sym;
int32_t aux; // WithEvents: the binding number
bool isArray;
bool isDynamic; // name()
bool withEvents;
} BasDeclT;
typedef struct {
BasNodeT h;
const char *name;
BasTypeSpecT *spec; // NULL: no AS clause
BasNodeT *defExpr; // "= default" (NULL: none)
struct BasSymS *sym; // the parameter's local (definitions)
uint8_t flags; // PF_*
} BasParamT;
typedef struct {
BasNodeT h;
const char *name;
BasTypeSpecT *spec; // NULL: no AS clause
BasNodeT *expr; // NULL: ENUM member numbered from the one before
} BasConstT;
typedef struct {
BasNodeT h;
const char *name;
BasNodeT *params; // BasParamT list
BasTypeSpecT *retSpec; // NULL: no AS clause
BasNodeT *body; // statements (ST_DEFFN: the expression)
struct BasSymS *sym;
int32_t endLine;
uint8_t memberKind;// BasMemberKindE: SUB, FUNCTION, GET, LET, SET
bool isPrivate;
bool isFriend; // Friend: callable by the program's own code, not through late binding
bool hasParens; // the parameter list was written (DECLARE checks)
bool isStatic; // SUB / FUNCTION ... STATIC: every local keeps its value between calls (QBasic)
} BasProcT;
typedef struct {
BasNodeT h;
BasNodeT *channel; // PRINT #channel (NULL: the screen or printer)
BasNodeT *format; // BAS_PRINT_USING
BasNodeT *items; // BasPrintItemT list
uint8_t mode; // BasPrintModeE
bool isLprint;
} BasPrintT;
typedef struct {
BasNodeT h;
BasNodeT *expr;
uint8_t kind; // BasItemKindE
} BasPrintItemT;
// ============================================================
// API
// ============================================================
void *basArenaAlloc(BasArenaT *a, int32_t size);
void basArenaFree(BasArenaT *a);
void basArenaInit(BasArenaT *a);
BasArenaMarkT basArenaMark(const BasArenaT *a);
void basArenaRelease(BasArenaT *a, BasArenaMarkT mark);
// Copy of len bytes of text, NUL-terminated, in the arena.
char *basArenaStrDup(BasArenaT *a, const char *text, int32_t len);
// A zeroed node of size bytes with its kind and position set (NULL when
// memory runs out).
BasNodeT *basNodeNew(BasArenaT *a, int32_t size, uint8_t kind, int32_t line, int32_t col);
// Number of nodes in a list.
int32_t basNodeCount(const BasNodeT *list);
#endif // DVXBASIC_AST_H

75
src/apps/kpunch/dvxbasic/compiler/basDateLit.h Normal file
View file

@ -0,0 +1,75 @@
// 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.
// basDateLit.h -- the shape of a BASIC date literal (#1/2/2026#,
// #Jan 2, 2026 10:30 PM#): one rule for the lexer and every syntax
// colorizer
//
// Header only (no link dependency), so code that cannot link the compiler
// or the date parser (the TextArea widget's built-in BASIC colorizer) can
// include it too. The lexer (basLexerDateLiteralLen) adds the last step:
// the text must also parse as a date (basDateParse).
#ifndef DVXBASIC_BAS_DATE_LIT_H
#define DVXBASIC_BAS_DATE_LIT_H
#include <ctype.h>
#include <stdbool.h>
#include <stdint.h>
#include <string.h>
// The characters allowed between the '#'s besides letters and digits,
// those that mark the text as a date or time, and the longest text.
#define BAS_DATE_LITERAL_CHARS " /-:,"
#define BAS_DATE_SEPARATORS "/-:"
#define BAS_DATE_DELIMITERS 2 // the opening and closing '#'
#define BAS_DATE_TEXT_MAX 255
static inline int32_t basDateLiteralShapeLen(const char *s, int32_t len);
// The length of the date-literal candidate at s (s[0] is '#', len bytes
// readable), both '#'s counted, or 0 when there is none: up to the
// closing '#' on the same line only letters, digits and
// BAS_DATE_LITERAL_CHARS, at most BAS_DATE_TEXT_MAX of them, including a
// date or time separator or a word, so file numbers such as CLOSE #1, 2,
// #3 never read as one.
static inline int32_t basDateLiteralShapeLen(const char *s, int32_t len) {
int32_t end = 1;
bool hasSeparator = false;
while (end < len && s[end] != '#') {
char c = s[end];
if (c == '\0' || end > BAS_DATE_TEXT_MAX || !(isalnum((unsigned char)c) || strchr(BAS_DATE_LITERAL_CHARS, c) != NULL)) {
return 0;
}
hasSeparator = hasSeparator || isalpha((unsigned char)c) || strchr(BAS_DATE_SEPARATORS, c) != NULL;
end++;
}
return (end < len && hasSeparator) ? end + 1 : 0;
}
#endif // DVXBASIC_BAS_DATE_LIT_H

45
src/apps/kpunch/dvxbasic/compiler/basEvents.h
View file

@ -46,7 +46,8 @@
typedef enum {
BAS_EVT_SCOPE_CTRL = 1 << 0, // fired on controls (widgets, Timer)
BAS_EVT_SCOPE_FORM = 1 << 1 // fired on the form itself
BAS_EVT_SCOPE_FORM = 1 << 1, // fired on the form itself
BAS_EVT_SCOPE_DRAW = 1 << 2 // fired on the controls the drawing methods draw on (PictureBox)
} BasEventScopeE;
#define BAS_EVT_SCOPE_BOTH (BAS_EVT_SCOPE_CTRL | BAS_EVT_SCOPE_FORM)
@ -76,6 +77,7 @@ typedef enum {
#define BAS_EVT_VALIDATE "Validate"
#define BAS_EVT_DRAGDROP "DragDrop"
#define BAS_EVT_DRAGOVER "DragOver"
#define BAS_EVT_PAINT "Paint"
#define BAS_EVENT_LIST(X) \
X(BAS_EVT_LOAD, BAS_EVT_SCOPE_FORM, "") \
@ -100,7 +102,8 @@ typedef enum {
X(BAS_EVT_REPOSITION, BAS_EVT_SCOPE_CTRL, "") \
X(BAS_EVT_VALIDATE, BAS_EVT_SCOPE_CTRL, "Cancel As Integer") \
X(BAS_EVT_DRAGDROP, BAS_EVT_SCOPE_BOTH, "Source As Control, X As Integer, Y As Integer") \
X(BAS_EVT_DRAGOVER, BAS_EVT_SCOPE_BOTH, "Source As Control, X As Integer, Y As Integer, State As Integer")
X(BAS_EVT_DRAGOVER, BAS_EVT_SCOPE_BOTH, "Source As Control, X As Integer, Y As Integer, State As Integer") \
X(BAS_EVT_PAINT, BAS_EVT_SCOPE_FORM | BAS_EVT_SCOPE_DRAW, "")
// Drag and drop values, shared by the compiler's predefined vb*
// constants and the form runtime: the DragMode property, the Drag
@ -118,6 +121,44 @@ typedef enum {
// clipboard holds text.
#define BAS_CF_TEXT 1 // vbCFText
// Scale units, shared by the compiler's predefined vb* constants and the
// form runtime: the ScaleMode values (vbUser to vbCentimeters) and
// ScaleX / ScaleY's vbHimetric (0.01 mm, the unit of a Picture's Width
// and Height), which is not a ScaleMode.
#define BAS_SCALE_USER 0 // vbUser: the object's own scale
#define BAS_SCALE_TWIPS 1 // vbTwips
#define BAS_SCALE_POINTS 2 // vbPoints
#define BAS_SCALE_PIXELS 3 // vbPixels (DVX's default ScaleMode)
#define BAS_SCALE_CHARACTERS 4 // vbCharacters (120 x 240 twips)
#define BAS_SCALE_INCHES 5 // vbInches
#define BAS_SCALE_MM 6 // vbMillimeters
#define BAS_SCALE_CM 7 // vbCentimeters (the last ScaleMode)
#define BAS_SCALE_HIMETRIC 8 // vbHimetric
#define BAS_SCALE_COUNT 9
// PaintPicture's raster operations (VB's vb* opcode constants, Windows
// ternary raster ops): bits 16..23 hold the operation's truth table over
// the pattern (FillColor), the source and the destination pixels.
#define BAS_ROP_SRCCOPY 0x00CC0020 // vbSrcCopy (the default)
#define BAS_ROP_SRCPAINT 0x00EE0086 // vbSrcPaint: source OR destination
#define BAS_ROP_SRCAND 0x008800C6 // vbSrcAnd
#define BAS_ROP_SRCINVERT 0x00660046 // vbSrcInvert: XOR
#define BAS_ROP_SRCERASE 0x00440328 // vbSrcErase: source AND NOT destination
#define BAS_ROP_NOTSRCCOPY 0x00330008 // vbNotSrcCopy
#define BAS_ROP_NOTSRCERASE 0x001100A6 // vbNotSrcErase: NOT (source OR destination)
#define BAS_ROP_MERGECOPY 0x00C000CA // vbMergeCopy: source AND pattern
#define BAS_ROP_MERGEPAINT 0x00BB0226 // vbMergePaint: NOT source OR destination
#define BAS_ROP_PATCOPY 0x00F00021 // vbPatCopy
#define BAS_ROP_PATPAINT 0x00FB0A09 // vbPatPaint
#define BAS_ROP_PATINVERT 0x005A0049 // vbPatInvert
#define BAS_ROP_DSTINVERT 0x00550009 // vbDstInvert
#define BAS_ROP_TABLE_SHIFT 16 // the truth table's place in an opcode
#define BAS_ROP_TABLE_MASK 0xFF
// Picture.Type: a LoadPicture object is a bitmap, LoadPicture() none.
#define BAS_PIC_TYPE_NONE 0 // vbPicTypeNone
#define BAS_PIC_TYPE_BITMAP 1 // vbPicTypeBitmap
// One row of BAS_EVENT_LIST, for consumers that want a runtime table
// (e.g. `static const BasEventInfoT sEvents[] = { BAS_EVENT_LIST(BAS_EVENT_ROW) };`).
typedef struct {

38
src/apps/kpunch/dvxbasic/compiler/basKeywords.h
View file

@ -31,15 +31,16 @@
// strcmp order, so an expanded table can be searched with bsearch. An
// entry whose token is TOK_IDENT is not reserved -- the lexer returns it
// as an identifier and a program may use the name for its own things --
// but colorizers still show it (built-in type names, Empty, Null, EACH).
// but colorizers still show it (built-in type names, Empty, Null, EACH,
// the console and graphics statements).
#ifndef DVXBASIC_BAS_KEYWORDS_H
#define DVXBASIC_BAS_KEYWORDS_H
typedef enum {
BAS_KW_CLASS_OTHER = 0, // control-flow / statement / operator keyword
BAS_KW_CLASS_TYPE = 1, // INTEGER, LONG, SINGLE, DOUBLE, STRING, BOOLEAN, DATE, VARIANT, OBJECT, COLLECTION
BAS_KW_CLASS_LITERAL = 2 // TRUE, FALSE, NOTHING, EMPTY, NULL, EMPTY, NULL
BAS_KW_CLASS_TYPE = 1, // INTEGER, LONG, SINGLE, DOUBLE, STRING, BOOLEAN, DATE, BYTE, CURRENCY, VARIANT, OBJECT, COLLECTION
BAS_KW_CLASS_LITERAL = 2 // TRUE, FALSE, NOTHING, EMPTY, NULL
} BasKeywordClassE;
#endif // DVXBASIC_BAS_KEYWORDS_H
@ -54,22 +55,30 @@ BAS_KEYWORD("BEEP", TOK_BEEP, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("BINARY", TOK_BINARY, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("BOOLEAN", TOK_BOOLEAN, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("BYREF", TOK_BYREF, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("BYTE", TOK_IDENT, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("BYVAL", TOK_BYVAL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CALL", TOK_CALL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CASE", TOK_CASE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CHDIR", TOK_CHDIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CHDRIVE", TOK_CHDRIVE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CIRCLE", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CLOSE", TOK_CLOSE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CLS", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("COLLECTION", TOK_IDENT, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("COLOR", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CONST", TOK_CONST, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CREATECONTROL", TOK_CREATECONTROL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CREATEFORM", TOK_CREATEFORM, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CSRLIN", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CURDIR", TOK_CURDIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CURDIR$", TOK_CURDIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("CURRENCY", TOK_IDENT, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("DATA", TOK_DATA, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DATE", TOK_IDENT, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("DECLARE", TOK_DECLARE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEF", TOK_DEF, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEFBYTE", TOK_DEFBYTE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEFCUR", TOK_DEFCUR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEFDBL", TOK_DEFDBL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEFINT", TOK_DEFINT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DEFLNG", TOK_DEFLNG, BAS_KW_CLASS_OTHER)
@ -81,6 +90,7 @@ BAS_KEYWORD("DIR$", TOK_DIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DO", TOK_DO, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DOEVENTS", TOK_DOEVENTS, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("DOUBLE", TOK_DOUBLE, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("DRAW", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("EACH", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ELSE", TOK_ELSE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ELSEIF", TOK_ELSEIF, BAS_KW_CLASS_OTHER)
@ -93,6 +103,7 @@ BAS_KEYWORD("ERASE", TOK_ERASE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ERL", TOK_ERL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ERR", TOK_ERR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ERROR", TOK_ERROR_KW, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("EVENT", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("EXIT", TOK_EXIT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("EXPLICIT", TOK_EXPLICIT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FALSE", TOK_FALSE_KW, BAS_KW_CLASS_LITERAL)
@ -100,6 +111,7 @@ BAS_KEYWORD("FILECOPY", TOK_FILECOPY, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FILELEN", TOK_FILELEN, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FOR", TOK_FOR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FRAMEWAIT", TOK_FRAMEWAIT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FULLSCREEN", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("FUNCTION", TOK_FUNCTION, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("GET", TOK_GET, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("GETATTR", TOK_GETATTR, BAS_KW_CLASS_OTHER)
@ -108,9 +120,11 @@ BAS_KEYWORD("GOTO", TOK_GOTO, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("HIDE", TOK_HIDE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("IF", TOK_IF, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("IMP", TOK_IMP, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("IMPLEMENTS", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INIREAD", TOK_INIREAD, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INIREAD$", TOK_INIREAD, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INIWRITE", TOK_INIWRITE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INKEY", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INPUT", TOK_INPUT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INPUTBOX", TOK_INPUTBOX, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("INPUTBOX$", TOK_INPUTBOX, BAS_KW_CLASS_OTHER)
@ -120,11 +134,14 @@ BAS_KEYWORD("KILL", TOK_KILL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LBOUND", TOK_LBOUND, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LET", TOK_LET, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LIBRARY", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LIKE", TOK_LIKE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LINE", TOK_LINE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LOAD", TOK_LOAD, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LOCATE", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LONG", TOK_LONG, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("LOOP", TOK_LOOP, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LPRINT", TOK_LPRINT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("LSET", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("ME", TOK_ME, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("MKDIR", TOK_MKDIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("MOD", TOK_MOD, BAS_KW_CLASS_OTHER)
@ -142,14 +159,22 @@ BAS_KEYWORD("OPTION", TOK_OPTION, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("OPTIONAL", TOK_OPTIONAL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("OR", TOK_OR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("OUTPUT", TOK_OUTPUT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PAINT", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PALETTE", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PARAMARRAY", TOK_PARAMARRAY, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PCOPY", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PLAY", TOK_PLAY, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PMAP", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("POINT", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PRESERVE", TOK_PRESERVE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PRESET", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PRINT", TOK_PRINT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PRIVATE", TOK_PRIVATE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PROPERTY", TOK_PROPERTY, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PSET", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PUBLIC", TOK_PUBLIC, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("PUT", TOK_PUT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RAISEEVENT", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RANDOM", TOK_RANDOM, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RANDOMIZE", TOK_RANDOMIZE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("READ", TOK_READ, BAS_KW_CLASS_OTHER)
@ -160,6 +185,8 @@ BAS_KEYWORD("RESTORE", TOK_RESTORE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RESUME", TOK_RESUME, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RETURN", TOK_RETURN, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RMDIR", TOK_RMDIR, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("RSET", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("SCREEN", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("SEEK", TOK_SEEK, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("SELECT", TOK_SELECT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("SET", TOK_SET, BAS_KW_CLASS_OTHER)
@ -186,10 +213,15 @@ BAS_KEYWORD("TYPEOF", TOK_TYPEOF, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("UBOUND", TOK_UBOUND, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("UNLOAD", TOK_UNLOAD, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("UNTIL", TOK_UNTIL, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("USING", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("VARIANT", TOK_IDENT, BAS_KW_CLASS_TYPE)
BAS_KEYWORD("VIEW", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WEND", TOK_WEND, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WHILE", TOK_WHILE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WIDTH", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WINDOW", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WITH", TOK_WITH, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WITHEVENTS", TOK_IDENT, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("WRITE", TOK_WRITE, BAS_KW_CLASS_OTHER)
BAS_KEYWORD("XOR", TOK_XOR, BAS_KW_CLASS_OTHER)
#endif // BAS_KEYWORD

254
src/apps/kpunch/dvxbasic/compiler/codegen.c
View file

@ -23,14 +23,12 @@
// codegen.c -- DVX BASIC p-code emitter implementation
#include "codegen.h"
#include "symtab.h"
#include "opcodes.h"
#include "thirdparty/stb_ds_wrap.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <strings.h>
// Function prototypes (alphabetical)
@ -40,10 +38,8 @@ void basCodeGenAddDebugVar(BasCodeGenT *cg, const char *name, uint8_t scope, uin
void basCodeGenAddFormVarInfo(BasCodeGenT *cg, const BasFormVarInfoT *info);
void basCodeGenAddUdtDef(BasCodeGenT *cg, const BasDebugUdtDefT *def);
BasModuleT *basCodeGenBuildModule(BasCodeGenT *cg);
BasModuleT *basCodeGenBuildModuleWithProcs(BasCodeGenT *cg, void *symtab);
void basCodeGenFree(BasCodeGenT *cg);
void basCodeGenInit(BasCodeGenT *cg);
void basCodeGenInsert(BasCodeGenT *cg, int32_t pos, const uint8_t *bytes, int32_t len);
void basCodeGenTruncate(BasCodeGenT *cg, int32_t codeLen, int32_t constCount);
int32_t basCodePos(const BasCodeGenT *cg);
void basEmit16(BasCodeGenT *cg, int16_t v);
@ -51,14 +47,11 @@ void basEmit32(BasCodeGenT *cg, int32_t v);
void basEmit8(BasCodeGenT *cg, uint8_t b);
static void basEmitBytes(BasCodeGenT *cg, const void *data, int32_t len);
void basEmitDouble(BasCodeGenT *cg, double v);
void basEmitI64(BasCodeGenT *cg, int64_t v);
void basEmitU16(BasCodeGenT *cg, uint16_t v);
void basPatch16(BasCodeGenT *cg, int32_t pos, int16_t val);
static bool buildClasses(BasModuleT *mod, const BasSymTabT *tab);
void basPatch32(BasCodeGenT *cg, int32_t pos, int32_t val);
static uint32_t constantHash(const char *text, int32_t len);
static bool copyDebugInfo(BasModuleT *mod, const BasCodeGenT *cg);
static bool isEmittableProc(const BasSymbolT *s);
static bool needsGlobalInit(const BasSymbolT *s);
static int32_t procIndexAt(const BasModuleT *mod, int32_t codeAddr);
uint16_t basAddConstant(BasCodeGenT *cg, const char *text, int32_t len) {
@ -131,7 +124,7 @@ void basCodeGenAddUdtDef(BasCodeGenT *cg, const BasDebugUdtDefT *def) {
BasModuleT *basCodeGenBuildModule(BasCodeGenT *cg) {
// basVmLoadModule refuses a module with more globals than it has
// slots; never build one (the parser reports the error with a
// slots; never build one (the compiler reports the error with a
// message, this is the last line of defence for other front ends).
if (cg->globalCount > BAS_VM_MAX_GLOBALS) {
return NULL;
@ -192,6 +185,21 @@ BasModuleT *basCodeGenBuildModule(BasCodeGenT *cg) {
mod->dataCount = cg->dataCount;
}
// The line numbers ERL reports (they survive stripping)
int32_t lineNumbers = (int32_t)arrlen(cg->lineNumbers);
if (lineNumbers > 0) {
mod->lineNumbers = (BasLineNumberT *)malloc((size_t)lineNumbers * sizeof(BasLineNumberT));
if (!mod->lineNumbers) {
basModuleFree(mod);
return NULL;
}
memcpy(mod->lineNumbers, cg->lineNumbers, (size_t)lineNumbers * sizeof(BasLineNumberT));
mod->lineNumberCount = lineNumbers;
}
if (!copyDebugInfo(mod, cg)) {
basModuleFree(mod);
return NULL;
@ -201,113 +209,6 @@ BasModuleT *basCodeGenBuildModule(BasCodeGenT *cg) {
}
BasModuleT *basCodeGenBuildModuleWithProcs(BasCodeGenT *cg, void *symtab) {
BasModuleT *mod = basCodeGenBuildModule(cg);
if (!mod || !symtab) {
return mod;
}
BasSymTabT *tab = (BasSymTabT *)symtab;
// Count SUB/FUNCTION entries
int32_t procCount = 0;
// Count globals that need runtime type init (currently: STRING).
// This list survives stripping, unlike debugVars.
int32_t globalInitCount = 0;
for (int32_t i = 0; i < tab->count; i++) {
BasSymbolT *s = tab->symbols[i];
if (isEmittableProc(s)) {
procCount++;
}
if (needsGlobalInit(s)) {
globalInitCount++;
}
}
// Without either table the module is silently broken (STRING globals
// start as numeric 0, event handlers cannot be found), so an
// allocation failure fails the build.
if (globalInitCount > 0) {
mod->globalInits = (BasGlobalInitT *)malloc(globalInitCount * sizeof(BasGlobalInitT));
if (!mod->globalInits) {
basModuleFree(mod);
return NULL;
}
int32_t gi = 0;
for (int32_t i = 0; i < tab->count; i++) {
BasSymbolT *s = tab->symbols[i];
if (needsGlobalInit(s)) {
mod->globalInits[gi].index = s->index;
mod->globalInits[gi].dataType = s->dataType;
gi++;
}
}
mod->globalInitCount = gi;
}
if (procCount == 0) {
return buildClasses(mod, tab) ? mod : NULL;
}
mod->procs = (BasProcEntryT *)malloc(procCount * sizeof(BasProcEntryT));
if (!mod->procs) {
basModuleFree(mod);
return NULL;
}
int32_t idx = 0;
for (int32_t i = 0; i < tab->count; i++) {
BasSymbolT *s = tab->symbols[i];
if (isEmittableProc(s)) {
BasProcEntryT *p = &mod->procs[idx++];
strncpy(p->name, s->name, BAS_MAX_IDENT - 1);
p->name[BAS_MAX_IDENT - 1] = '\0';
strncpy(p->formName, s->formName, BAS_MAX_IDENT - 1);
p->formName[BAS_MAX_IDENT - 1] = '\0';
p->codeAddr = s->codeAddr;
p->paramCount = s->paramCount;
p->localCount = s->localCount;
p->returnType = s->dataType;
p->isFunction = (s->kind == SYM_FUNCTION);
}
}
// Debug local variables carry a procIndex assigned in source-definition
// (code emission) order, while the symbol table lists procs in
// first-mention order (DECLARE lines included). Sort the table by code
// address so its indices match those procIndex values and the debugger
// attributes locals to the right procedure. Insertion sort: the table
// is small and usually already in order.
for (int32_t i = 1; i < idx; i++) {
BasProcEntryT key = mod->procs[i];
int32_t j = i - 1;
while (j >= 0 && mod->procs[j].codeAddr > key.codeAddr) {
mod->procs[j + 1] = mod->procs[j];
j--;
}
mod->procs[j + 1] = key;
}
mod->procCount = idx;
return buildClasses(mod, tab) ? mod : NULL;
}
void basCodeGenFree(BasCodeGenT *cg) {
for (int32_t i = 0; i < cg->constCount; i++) {
basStringUnref(cg->constants[i]);
@ -322,6 +223,7 @@ void basCodeGenFree(BasCodeGenT *cg) {
arrfree(cg->constHashes);
arrfree(cg->constNext);
arrfree(cg->dataPool);
arrfree(cg->lineNumbers);
arrfree(cg->formVarInfo);
arrfree(cg->debugVars);
@ -342,13 +244,6 @@ void basCodeGenInit(BasCodeGenT *cg) {
}
void basCodeGenInsert(BasCodeGenT *cg, int32_t pos, const uint8_t *bytes, int32_t len) {
arrinsn(cg->code, pos, len);
memcpy(&cg->code[pos], bytes, len);
cg->codeLen = (int32_t)arrlen(cg->code);
}
void basCodeGenTruncate(BasCodeGenT *cg, int32_t codeLen, int32_t constCount) {
arrsetlen(cg->code, codeLen);
cg->codeLen = codeLen;
@ -405,6 +300,11 @@ void basEmitDouble(BasCodeGenT *cg, double v) {
}
void basEmitI64(BasCodeGenT *cg, int64_t v) {
basEmitBytes(cg, &v, (int32_t)sizeof(v));
}
void basEmitU16(BasCodeGenT *cg, uint16_t v) {
uint8_t buf[sizeof(v)];
@ -413,81 +313,13 @@ void basEmitU16(BasCodeGenT *cg, uint16_t v) {
}
void basPatch16(BasCodeGenT *cg, int32_t pos, int16_t val) {
void basPatch32(BasCodeGenT *cg, int32_t pos, int32_t val) {
if (pos >= 0 && pos + (int32_t)sizeof(val) <= cg->codeLen) {
basWriteI16LE(&cg->code[pos], val);
basWriteI32LE(&cg->code[pos], val);
}
}
// Copies the class modules into mod->classes: each class's size, set-up
// code and public members, procedures by their index in the (sorted)
// procedure table. Frees mod and returns false when memory runs out.
static bool buildClasses(BasModuleT *mod, const BasSymTabT *tab) {
int32_t count = (int32_t)arrlen(tab->classes);
if (count == 0) {
return true;
}
mod->classes = (BasClassInfoT *)calloc(count, sizeof(BasClassInfoT));
if (!mod->classes) {
basModuleFree(mod);
return false;
}
mod->classCount = count;
for (int32_t c = 0; c < count; c++) {
const BasClassDefT *def = &tab->classes[c];
BasClassInfoT *info = &mod->classes[c];
int32_t n = (int32_t)arrlen(def->members);
snprintf(info->name, sizeof(info->name), "%s", def->name);
info->varCount = def->varCount;
info->initCodeAddr = def->initCodeAddr;
info->terminateProc = def->terminateSym ? procIndexAt(mod, def->terminateSym->codeAddr) : -1;
if (n == 0) {
continue;
}
info->members = (BasClassMemberT *)calloc(n, sizeof(BasClassMemberT));
if (!info->members) {
basModuleFree(mod);
return false;
}
info->memberCount = n;
for (int32_t i = 0; i < n; i++) {
const BasClassMemberDefT *md = &def->members[i];
const BasSymbolT *sym = md->sym;
BasClassMemberT *m = &info->members[i];
snprintf(m->name, sizeof(m->name), "%s", md->name);
m->kind = md->kind;
m->dataType = sym->dataType;
m->requiredParams = (uint8_t)sym->requiredParams;
m->index = (md->kind == BAS_MEMBER_VAR) ? sym->index : procIndexAt(mod, sym->codeAddr);
memcpy(m->paramTypes, sym->paramTypes, DVX_MIN(sizeof(m->paramTypes), sizeof(sym->paramTypes)));
if (strcasecmp(md->name, def->defaultMember) == 0) {
m->flags |= BAS_MEMBER_DEFAULT;
}
if (sym->hasParamArray) {
m->flags |= BAS_MEMBER_PARAMARRAY;
}
}
}
return true;
}
// FNV-1a over the constant's bytes (case-sensitive: constants are exact).
static uint32_t constantHash(const char *text, int32_t len) {
uint32_t h = BAS_FNV1A_OFFSET;
@ -561,37 +393,3 @@ static bool copyDebugInfo(BasModuleT *mod, const BasCodeGenT *cg) {
}
// A SUB/FUNCTION that has a body in this module (not a forward stub or
// a DECLARE LIBRARY extern) and therefore gets a proc-table entry.
static bool isEmittableProc(const BasSymbolT *s) {
return (s->kind == SYM_SUB || s->kind == SYM_FUNCTION) && s->isDefined && !s->isExtern;
}
// Global scalars that must start as a typed value rather than numeric 0
// (currently STRING); recorded in the module's globalInits table.
static bool needsGlobalInit(const BasSymbolT *s) {
return s->scope == SCOPE_GLOBAL && s->kind == SYM_VARIABLE && s->dataType == BAS_TYPE_STRING && !s->isArray;
}
// Index into mod->procs (sorted by code address) of the procedure at
// codeAddr, or -1.
static int32_t procIndexAt(const BasModuleT *mod, int32_t codeAddr) {
int32_t lo = 0;
int32_t hi = mod->procCount - 1;
while (lo <= hi) {
int32_t mid = lo + (hi - lo) / 2;
if (mod->procs[mid].codeAddr < codeAddr) {
lo = mid + 1;
} else if (mod->procs[mid].codeAddr > codeAddr) {
hi = mid - 1;
} else {
return mid;
}
}
return -1;
}

17
src/apps/kpunch/dvxbasic/compiler/codegen.h
View file

@ -23,7 +23,7 @@
// codegen.h -- DVX BASIC p-code emitter
//
// Builds a p-code byte stream and string constant pool from
// calls made by the parser. Provides helpers for backpatching
// calls made by the generator. Provides helpers for backpatching
// forward jumps.
//
// Embeddable: no DVX dependencies, pure C.
@ -63,6 +63,7 @@ typedef struct {
int32_t globalCount;
BasValueT *dataPool; // stb_ds dynamic array
int32_t dataCount;
BasLineNumberT *lineNumbers; // stb_ds dynamic array: the program's line numbers in source order
BasFormVarInfoT *formVarInfo; // stb_ds dynamic array
int32_t formVarInfoCount;
BasDebugVarT *debugVars; // stb_ds dynamic array
@ -95,14 +96,15 @@ void basEmit32(BasCodeGenT *cg, int32_t v);
// Emit 64-bit double
void basEmitDouble(BasCodeGenT *cg, double v);
// Emit 64-bit integer (a Currency's scaled amount)
void basEmitI64(BasCodeGenT *cg, int64_t v);
// Get current code position (for jump targets)
int32_t basCodePos(const BasCodeGenT *cg);
// Patch a 16-bit value at a previous position (for backpatching jumps)
void basPatch16(BasCodeGenT *cg, int32_t pos, int16_t val);
// Insert len bytes at pos, moving the code after it up.
void basCodeGenInsert(BasCodeGenT *cg, int32_t pos, const uint8_t *bytes, int32_t len);
// Patch a 32-bit value at a previous position (backpatching jumps and
// call addresses)
void basPatch32(BasCodeGenT *cg, int32_t pos, int32_t val);
// Drop the code emitted after codeLen and the constants added after
// constCount (both from an earlier basCodePos / constCount), e.g. the
@ -125,9 +127,6 @@ void basCodeGenAddUdtDef(BasCodeGenT *cg, const BasDebugUdtDefT *def);
// ownership of the module and must free it with basModuleFree().
BasModuleT *basCodeGenBuildModule(BasCodeGenT *cg);
// Build a module with procedure table from parser symbol table.
// symtab is a BasSymTabT* (cast to void* to avoid circular include).
BasModuleT *basCodeGenBuildModuleWithProcs(BasCodeGenT *cg, void *symtab);
// Add a debug variable entry (for debugger variable display).
// formName is only used for SCOPE_FORM vars (NULL or "" for others).

79
src/apps/kpunch/dvxbasic/compiler/compact.c
View file

@ -35,13 +35,14 @@
// - BasProcEntryT::codeAddr (absolute)
// - BasFormVarInfoT::initCodeAddr (absolute, negative = no init)
// - BasClassInfoT::initCodeAddr (absolute, negative = none)
// - OP_CALL / OP_CALL_ME operand (absolute uint16)
// - OP_JMP / OP_JMP_TRUE / OP_JMP_FALSE / OP_GOSUB operand (relative int16)
// - OP_FOR_INIT / OP_FOR_NEXT offset operand (relative int16)
// - OP_ON_ERROR handler operand (relative int16; 0 = disable, not remapped)
// - OP_CALL / OP_CALL_ME operand (absolute int32)
// - OP_JMP / OP_JMP_TRUE / OP_JMP_FALSE / OP_GOSUB operand (relative int32)
// - OP_FOR_INIT / OP_FOR_NEXT offset operand (relative int32)
// - OP_ON_ERROR handler operand (relative int32; 0 = disable, not remapped)
//
// Safety: if any opcode cannot be sized, any jump overflows int16, or
// the walk doesn't reach codeLen exactly, the module is left untouched.
// Safety: if any opcode cannot be sized, any address lands outside the
// code, or the walk doesn't reach codeLen exactly, the module is left
// untouched.
#include "compact.h"
#include "opcodes.h"
@ -50,23 +51,20 @@
#include <stdlib.h>
#include <string.h>
#define BAS_OPERAND_U16_MAX 0xFFFF // max absolute address encodable in a uint16 operand
// Instruction sizes of the two statement-boundary encodings.
#define BAS_LINE_INST_SIZE (1 + BAS_OPERAND_U16) // OP_LINE [uint16 lineNum]
#define BAS_STMT_INST_SIZE 1 // OP_STMT
#define BAS_STMT_INST_SIZE 1 // OP_STMT (OP_LINE: BAS_LINE_INST_SIZE)
// Operand position and size of the address-carrying instructions.
#define BAS_ADDR_OPERAND_OFFSET 1 // operand directly after the opcode
#define BAS_JUMP_INST_SIZE (1 + BAS_OPERAND_U16) // OP_JMP* / OP_GOSUB / OP_ON_ERROR [int16 offset]
#define BAS_JUMP_INST_SIZE (1 + BAS_CODE_ADDR_SIZE) // OP_JMP* / OP_GOSUB / OP_ON_ERROR [int32 offset]
#define BAS_FOR_INST_SIZE (1 + BAS_OPERAND_FOR) // OP_FOR_INIT / OP_FOR_NEXT
// Function prototypes (alphabetical)
int32_t basCompactBytecode(BasModuleT *mod);
static int32_t *buildRemap(const uint8_t *code, int32_t codeLen, bool keepStmt, int32_t *outNewLen);
static bool remapAbsU16(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, uint16_t oldAddr, const int32_t *remap, int32_t codeLen);
static bool remapRelI16(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int16_t oldOffset, int32_t oldPcAfter, int32_t newPcAfter, const int32_t *remap, int32_t codeLen, bool allowZero);
static bool remapAbs(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int32_t oldAddr, const int32_t *remap, int32_t codeLen);
static bool remapRel(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int32_t oldOffset, int32_t oldPcAfter, int32_t newPcAfter, const int32_t *remap, int32_t codeLen, bool allowZero);
int32_t basCompactBytecode(BasModuleT *mod) {
@ -96,7 +94,7 @@ int32_t basCompactBytecode(BasModuleT *mod) {
lineCount++;
}
if (op == OP_ON_ERROR || op == OP_RESUME || op == OP_RESUME_NEXT) {
if (op == OP_ON_ERROR || op == OP_ON_ERROR_NEXT || op == OP_RESUME || op == OP_RESUME_NEXT || op == OP_RESUME_LABEL) {
keepStmt = true;
}
@ -159,9 +157,9 @@ int32_t basCompactBytecode(BasModuleT *mod) {
switch (op) {
case OP_CALL:
case OP_CALL_ME: {
uint16_t oldAddr = basReadU16LE(oldCode + oldPc + BAS_ADDR_OPERAND_OFFSET);
int32_t oldAddr = basReadI32LE(oldCode + oldPc + BAS_ADDR_OPERAND_OFFSET);
ok = remapAbsU16(newCode, newPc, BAS_ADDR_OPERAND_OFFSET, oldAddr, remap, oldCodeLen);
ok = remapAbs(newCode, newPc, BAS_ADDR_OPERAND_OFFSET, oldAddr, remap, oldCodeLen);
break;
}
@ -171,19 +169,19 @@ int32_t basCompactBytecode(BasModuleT *mod) {
case OP_GOSUB:
case OP_ON_ERROR: {
// ON ERROR's offset 0 means "disable" and is kept as is.
int16_t oldOff = basReadI16LE(oldCode + oldPc + BAS_ADDR_OPERAND_OFFSET);
int32_t oldOff = basReadI32LE(oldCode + oldPc + BAS_ADDR_OPERAND_OFFSET);
ok = remapRelI16(newCode, newPc, BAS_ADDR_OPERAND_OFFSET, oldOff, oldPc + BAS_JUMP_INST_SIZE, newPc + BAS_JUMP_INST_SIZE, remap, oldCodeLen, op == OP_ON_ERROR);
ok = remapRel(newCode, newPc, BAS_ADDR_OPERAND_OFFSET, oldOff, oldPc + BAS_JUMP_INST_SIZE, newPc + BAS_JUMP_INST_SIZE, remap, oldCodeLen, op == OP_ON_ERROR);
break;
}
case OP_FOR_INIT:
case OP_FOR_NEXT: {
// [uint16 varIdx] [uint8 scope] [int16 offset]: FOR_INIT's
// [uint16 varIdx] [uint8 scope] [int32 offset]: FOR_INIT's
// offset skips an empty loop, FOR_NEXT's jumps back to the body.
int16_t oldOff = basReadI16LE(oldCode + oldPc + BAS_FOR_OFFSET_OPERAND);
int32_t oldOff = basReadI32LE(oldCode + oldPc + BAS_FOR_OFFSET_OPERAND);
ok = remapRelI16(newCode, newPc, BAS_FOR_OFFSET_OPERAND, oldOff, oldPc + BAS_FOR_INST_SIZE, newPc + BAS_FOR_INST_SIZE, remap, oldCodeLen, false);
ok = remapRel(newCode, newPc, BAS_FOR_OFFSET_OPERAND, oldOff, oldPc + BAS_FOR_INST_SIZE, newPc + BAS_FOR_INST_SIZE, remap, oldCodeLen, false);
break;
}
@ -341,41 +339,36 @@ static int32_t *buildRemap(const uint8_t *code, int32_t codeLen, bool keepStmt,
// Apply remap to a single instruction's operand
// ============================================================
//
// Returns true on success, false if an offset overflows int16 or a
// target doesn't land on a valid instruction in the old code.
static bool remapAbsU16(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, uint16_t oldAddr, const int32_t *remap, int32_t codeLen) {
// oldAddr is an arbitrary uint16 operand; remap[] only has codeLen+1
// Returns true on success, false if a target doesn't land inside the
// old code.
static bool remapAbs(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int32_t oldAddr, const int32_t *remap, int32_t codeLen) {
// oldAddr is an arbitrary int32 operand; remap[] only has codeLen+1
// entries, so a corrupt CALL address would index out of bounds.
if (oldAddr > codeLen) {
if (oldAddr < 0 || oldAddr > codeLen) {
return false;
}
int32_t newAddr = remap[oldAddr];
if (newAddr > BAS_OPERAND_U16_MAX) {
return false;
}
basWriteU16LE(newCode + newOpPos + operandOffset, (uint16_t)newAddr);
basWriteI32LE(newCode + newOpPos + operandOffset, remap[oldAddr]);
return true;
}
// Rewrite a relative int16 offset.
// oldOpPos, oldPcAfter: position of opcode and PC after reading offset
// newOpPos, newPcAfter: same in the new code
// operandOffset: byte offset from opcode to the int16 operand
// Rewrite a relative int32 offset.
// oldPcAfter, newPcAfter: PC after the instruction in the old and new code
// newOpPos: position of the opcode in the new code
// operandOffset: byte offset from opcode to the int32 operand
// oldOffset: the offset as stored in the old code
//
// Handles ON_ERROR's special case (offset == 0 means "disable").
// For ON_ERROR the caller passes allowZero=true; the zero is preserved as-is.
static bool remapRelI16(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int16_t oldOffset, int32_t oldPcAfter, int32_t newPcAfter, const int32_t *remap, int32_t codeLen, bool allowZero) {
static bool remapRel(uint8_t *newCode, int32_t newOpPos, int32_t operandOffset, int32_t oldOffset, int32_t oldPcAfter, int32_t newPcAfter, const int32_t *remap, int32_t codeLen, bool allowZero) {
if (allowZero && oldOffset == 0) {
basWriteI16LE(newCode + newOpPos + operandOffset, 0);
basWriteI32LE(newCode + newOpPos + operandOffset, 0);
return true;
}
int32_t oldTarget = oldPcAfter + oldOffset;
// Widened: a corrupt offset must not overflow the addition.
int64_t oldTarget = (int64_t)oldPcAfter + oldOffset;
if (oldTarget < 0 || oldTarget > codeLen) {
return false;
@ -392,10 +385,6 @@ static bool remapRelI16(uint8_t *newCode, int32_t newOpPos, int32_t operandOffse
return false;
}
if (newOffset < INT16_MIN || newOffset > INT16_MAX) {
return false;
}
basWriteI16LE(newCode + newOpPos + operandOffset, (int16_t)newOffset);
basWriteI32LE(newCode + newOpPos + operandOffset, newOffset);
return true;
}

953
src/apps/kpunch/dvxbasic/compiler/compiler.c Normal file
View file

@ -0,0 +1,953 @@
// 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.
// compiler.c -- DVX BASIC compiler driver
//
// basCompile runs the declaration pass, then compiles one top-level unit
// at a time: parse it into the unit arena, resolve its names, type and
// fold it, generate its code, then release the arena. Peak memory is
// the module's symbols and code plus the largest unit's tree.
// basCompilerBuildModule turns the result into a BasModuleT.
#include "front.h"
#include "basEvents.h"
#include "../runtime/dates.h"
#include "thirdparty/stb_ds_wrap.h"
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
// vbObjectError: the base of the error numbers a class raises.
#define BAS_VB_OBJECT_ERROR (-2147221504)
// A predefined LONG constant.
typedef struct {
const char *name;
int32_t value;
} PredefConstT;
static const PredefConstT sPredefConsts[] = {
// MsgBox buttons, icons and results (VB3)
{ "vbOKOnly", BAS_MSGBOX_OK_ONLY },
{ "vbOKCancel", 0x0001 },
{ "vbYesNo", 0x0002 },
{ "vbYesNoCancel", 0x0003 },
{ "vbRetryCancel", 0x0004 },
{ "vbInformation", 0x0010 },
{ "vbExclamation", 0x0020 },
{ "vbCritical", 0x0030 },
{ "vbQuestion", 0x0040 },
{ "vbOK", 1 },
{ "vbCancel", 2 },
{ "vbYes", 3 },
{ "vbNo", 4 },
{ "vbRetry", 5 },
// Show mode
{ "vbModal", 1 },
// File attributes
{ "vbNormal", 0 },
{ "vbReadOnly", 1 },
{ "vbHidden", 2 },
{ "vbSystem", 4 },
{ "vbDirectory", 16 },
{ "vbArchive", 32 },
// Compare arguments of the string functions
{ "vbUseCompareOption", BAS_COMPARE_USE_OPTION },
{ "vbBinaryCompare", BAS_COMPARE_MODE_BINARY },
{ "vbTextCompare", BAS_COMPARE_MODE_TEXT },
// Days of the week and first weeks of the year (date functions)
{ "vbUseSystemDayOfWeek", BAS_DATE_USE_SYSTEM_DAY },
{ "vbSunday", BAS_DATE_SUNDAY },
{ "vbMonday", BAS_DATE_SUNDAY + 1 },
{ "vbTuesday", BAS_DATE_SUNDAY + 2 },
{ "vbWednesday", BAS_DATE_SUNDAY + 3 },
{ "vbThursday", BAS_DATE_SUNDAY + 4 },
{ "vbFriday", BAS_DATE_SUNDAY + 5 },
{ "vbSaturday", BAS_DATE_SATURDAY },
{ "vbUseSystem", BAS_DATE_USE_SYSTEM_WEEK },
{ "vbFirstJan1", BAS_DATE_FIRST_JAN1 },
{ "vbFirstFourDays", BAS_DATE_FIRST_FOUR_DAYS },
{ "vbFirstFullWeek", BAS_DATE_FIRST_FULL_WEEK },
// Drag and drop: DragMode, the Drag method's action, DragOver's State
// (Drag 0 cancels; vbCancel is the MsgBox value)
{ "vbManual", BAS_DRAGMODE_MANUAL },
{ "vbAutomatic", BAS_DRAGMODE_AUTOMATIC },
{ "vbBeginDrag", BAS_DRAG_BEGIN },
{ "vbEndDrag", BAS_DRAG_END },
{ "vbEnter", BAS_DRAG_ENTER },
{ "vbLeave", BAS_DRAG_LEAVE },
{ "vbOver", BAS_DRAG_OVER },
// Clipboard formats
{ "vbCFText", BAS_CF_TEXT },
// Colours: RGB values (&HBBGGRR, as RGB() makes them)
{ "vbBlack", 0x000000 },
{ "vbRed", 0x0000FF },
{ "vbGreen", 0x00FF00 },
{ "vbYellow", 0x00FFFF },
{ "vbBlue", 0xFF0000 },
{ "vbMagenta", 0xFF00FF },
{ "vbCyan", 0xFFFF00 },
{ "vbWhite", 0xFFFFFF },
// Scale units (ScaleMode, ScaleX / ScaleY) and Picture.Type
{ "vbUser", BAS_SCALE_USER },
{ "vbTwips", BAS_SCALE_TWIPS },
{ "vbPoints", BAS_SCALE_POINTS },
{ "vbPixels", BAS_SCALE_PIXELS },
{ "vbCharacters", BAS_SCALE_CHARACTERS },
{ "vbInches", BAS_SCALE_INCHES },
{ "vbMillimeters", BAS_SCALE_MM },
{ "vbCentimeters", BAS_SCALE_CM },
{ "vbHimetric", BAS_SCALE_HIMETRIC },
{ "vbPicTypeNone", BAS_PIC_TYPE_NONE },
{ "vbPicTypeBitmap", BAS_PIC_TYPE_BITMAP },
{ "vbSrcCopy", BAS_ROP_SRCCOPY },
{ "vbSrcPaint", BAS_ROP_SRCPAINT },
{ "vbSrcAnd", BAS_ROP_SRCAND },
{ "vbSrcInvert", BAS_ROP_SRCINVERT },
{ "vbSrcErase", BAS_ROP_SRCERASE },
{ "vbNotSrcCopy", BAS_ROP_NOTSRCCOPY },
{ "vbNotSrcErase", BAS_ROP_NOTSRCERASE },
{ "vbMergeCopy", BAS_ROP_MERGECOPY },
{ "vbMergePaint", BAS_ROP_MERGEPAINT },
{ "vbPatCopy", BAS_ROP_PATCOPY },
{ "vbPatPaint", BAS_ROP_PATPAINT },
{ "vbPatInvert", BAS_ROP_PATINVERT },
{ "vbDstInvert", BAS_ROP_DSTINVERT },
{ "vbLPSmall", BAS_LP_SMALL },
{ "vbLPLarge", BAS_LP_LARGE },
{ "vbLPSmallShell", BAS_LP_SMALL_SHELL },
{ "vbLPLargeShell", BAS_LP_LARGE_SHELL },
{ "vbLPCustom", BAS_LP_CUSTOM },
{ "vbLPDefault", BAS_LP_DEFAULT },
{ "vbLPMonochrome", BAS_LP_MONOCHROME },
{ "vbLPVGAColor", BAS_LP_VGA_COLOR },
{ "vbLPColor", BAS_LP_COLOR },
// VARTYPE results, and the base of the error numbers a class raises
{ "vbEmpty", BAS_VT_EMPTY },
{ "vbNull", BAS_VT_NULL },
{ "vbInteger", BAS_VT_INTEGER },
{ "vbLong", BAS_VT_LONG },
{ "vbSingle", BAS_VT_SINGLE },
{ "vbDouble", BAS_VT_DOUBLE },
{ "vbCurrency", BAS_VT_CURRENCY },
{ "vbByte", BAS_VT_BYTE },
{ "vbDate", BAS_VT_DATE },
{ "vbString", BAS_VT_STRING },
{ "vbObject", BAS_VT_OBJECT },
{ "vbError", BAS_VT_ERROR },
{ "vbBoolean", BAS_VT_BOOLEAN },
{ "vbVariant", BAS_VT_VARIANT },
{ "vbDataObject", BAS_VT_DATAOBJECT },
{ "vbUserDefinedType", BAS_VT_USERTYPE },
{ "vbArray", BAS_VT_ARRAY },
{ "vbObjectError", BAS_VB_OBJECT_ERROR }
};
#define BAS_PREDEF_CONST_COUNT ((int32_t)(sizeof(sPredefConsts) / sizeof(sPredefConsts[0])))
// Function prototypes (alphabetical)
static bool addPredefConsts(BasCompilerT *c);
static void applyMemberPatches(BasCompilerT *c);
bool basCompile(BasCompilerT *c);
BasModuleT *basCompilerBuildModule(BasCompilerT *c);
BasCompilerT *basCompilerCreate(const char *source, int32_t sourceLen);
bool basCompilerDeclareGlobal(BasCompilerT *c, const char *name, uint8_t dataType);
void basCompilerDestroy(BasCompilerT *c);
const char *basCompilerError(const BasCompilerT *c);
int32_t basCompilerErrorCol(const BasCompilerT *c);
int32_t basCompilerErrorLine(const BasCompilerT *c);
const char *basCompilerFormScope(const BasCompilerT *c);
int32_t basCompilerGlobalSlot(const BasCompilerT *c, const char *name);
void basCompilerSetOptionExplicit(BasCompilerT *c, bool on);
void basCompilerSetValidator(BasCompilerT *c, const BasCtrlValidatorT *v);
void basErrorAt(BasCompilerT *c, int32_t line, int32_t col, const char *fmt, ...);
void basErrorNode(BasCompilerT *c, const BasNodeT *n, const char *fmt, ...);
static bool buildClasses(const BasCompilerT *c, BasModuleT *mod);
static bool buildGlobalInits(const BasCompilerT *c, BasModuleT *mod);
static bool buildInterfaceMap(const BasCompilerT *c, int32_t classIdx, int32_t iface, BasImplementsT *impl);
static bool buildProcs(const BasCompilerT *c, BasModuleT *mod);
static bool buildWithEvents(const BasCompilerT *c, BasModuleT *mod);
static int32_t classMemberNamed(const BasClassDefT *cls, const char *name, uint8_t kind);
static void collectDebugGlobals(BasCompilerT *c);
static bool emittableProc(const BasSymT *s);
static void errorV(BasCompilerT *c, int32_t line, int32_t col, const char *fmt, va_list ap);
static bool globalStartsTyped(const BasSymT *s);
static bool joinParamNames(const BasProcInfoT *pi, char **out);
static int32_t procIndexAt(const BasModuleT *mod, int32_t codeAddr);
// The vb* constants every program sees (module scope: a procedure may
// declare its own of a name, module code may not).
static bool addPredefConsts(BasCompilerT *c) {
for (int32_t i = 0; i < BAS_PREDEF_CONST_COUNT; i++) {
BasSymT *sym = basScopeAdd(&c->moduleTab, &c->modArena, sPredefConsts[i].name, SK_CONST, BAS_TYPE_LONG);
BasConstValT *v = (BasConstValT *)basArenaAlloc(&c->modArena, (int32_t)sizeof(BasConstValT));
if (sym == NULL || v == NULL) {
return false;
}
v->dataType = BAS_TYPE_LONG;
v->intVal = sPredefConsts[i].value;
v->dblVal = sPredefConsts[i].value;
sym->u.cval = v;
}
return true;
}
// Fills in the member operands of the early-bound instructions: the
// member's index in its class's public member table, complete now that
// every class is compiled.
static void applyMemberPatches(BasCompilerT *c) {
for (int32_t i = 0; i < (int32_t)arrlen(c->memberPatches) && !c->hasError; i++) {
const BasMemberPatchT *p = &c->memberPatches[i];
const BasClassDefT *cls = &c->classes[p->classIdx];
int32_t idx = BAS_MEMBER_NONE;
for (int32_t m = 0; m < (int32_t)arrlen(cls->members) && idx == BAS_MEMBER_NONE; m++) {
idx = (cls->members[m].sym == p->sym) ? m : BAS_MEMBER_NONE;
}
if (idx == BAS_MEMBER_NONE) {
basErrorAt(c, 0, 0, "Internal error: member '%s' missing from class '%s'", p->sym->name, cls->name);
return;
}
basWriteU16LE(&c->cg.code[p->pos], (uint16_t)idx);
}
}
bool basCompile(BasCompilerT *c) {
basParseDeclarations(c);
while (!c->hasError) {
BasArenaMarkT mark = basArenaMark(&c->unitArena);
BasNodeT *unit = basParseUnit(c);
// A syntax error leaves a partial tree: nothing more to do
if (unit == NULL || c->hasError) {
basArenaRelease(&c->unitArena, mark);
break;
}
basResolveUnit(c, unit);
if (!c->hasError) {
basTypeUnit(c, unit);
}
// The code is generated with the symbols as each statement sees them
if (!c->hasError) {
basSymChangesUndo(c);
basGenStatement(c, unit);
}
arrsetlen(c->symChanges, 0);
basResolveUnitEnd(c, unit);
basArenaRelease(&c->unitArena, mark);
}
if (!c->hasError) {
basResolveModuleEnd(c);
}
if (!c->hasError) {
applyMemberPatches(c);
}
basGenFlushProcSkip(c);
basEmit8(&c->cg, OP_HALT);
// The pool's indices are 16-bit
if (c->cg.overflow) {
basErrorAt(c, c->lex.token.line, 0, "Too many string constants (constant pool index exceeds 16 bits)");
}
// The VM's global slot table is fixed-size
if (c->nextGlobalSlot > BAS_VM_MAX_GLOBALS) {
basErrorAt(c, c->lex.token.line, 0, "Too many module-level variables (%d, limit is %d)", (int)c->nextGlobalSlot, (int)BAS_VM_MAX_GLOBALS);
}
return !c->hasError;
}
BasModuleT *basCompilerBuildModule(BasCompilerT *c) {
if (c->hasError) {
return NULL;
}
collectDebugGlobals(c);
c->cg.globalCount = c->nextGlobalSlot;
BasModuleT *mod = basCodeGenBuildModule(&c->cg);
// Each build step frees mod when it fails
if (mod == NULL || !buildGlobalInits(c, mod) || !buildProcs(c, mod) || !buildClasses(c, mod) || !buildWithEvents(c, mod)) {
return NULL;
}
return mod;
}
BasCompilerT *basCompilerCreate(const char *source, int32_t sourceLen) {
BasCompilerT *c = (BasCompilerT *)calloc(1, sizeof(BasCompilerT));
if (c == NULL) {
return NULL;
}
c->source = source;
c->sourceLen = sourceLen;
c->formName = "";
c->classIdx = BAS_CLASS_NONE;
c->initJmpAddr = -1;
c->initCodeStart = -1;
c->procSkipJump = -1;
memset(c->defType, BAS_DEFTYPE_NONE, sizeof(c->defType));
basArenaInit(&c->modArena);
basArenaInit(&c->unitArena);
basCodeGenInit(&c->cg);
basLexerInit(&c->lex, source, sourceLen);
if (!basScopeInit(&c->moduleTab, &c->modArena, BAS_MODULE_BUCKETS) || !basScopeInit(&c->moduleLabels, &c->modArena, BAS_LOCAL_BUCKETS) || !addPredefConsts(c)) {
basCompilerDestroy(c);
return NULL;
}
return c;
}
bool basCompilerDeclareGlobal(BasCompilerT *c, const char *name, uint8_t dataType) {
return basAddGlobalVar(c, name, dataType) != NULL;
}
void basCompilerDestroy(BasCompilerT *c) {
if (c == NULL) {
return;
}
// stb_ds arrays hang off module-lifetime records
for (const BasSymT *s = c->moduleTab.first; s != NULL; s = s->orderNext) {
if ((s->kind == SK_SUB || s->kind == SK_FUNCTION) && s->u.proc != NULL) {
arrfree(s->u.proc->patches);
}
}
for (const BasSymT *s = c->moduleLabels.first; s != NULL; s = s->orderNext) {
arrfree(s->u.label->patches);
arrfree(s->u.label->patchDepths);
arrfree(s->u.label->dataPatches);
}
for (int32_t i = 0; i < (int32_t)arrlen(c->typeDefs); i++) {
arrfree(c->typeDefs[i]->fields);
}
for (int32_t i = 0; i < (int32_t)arrlen(c->classes); i++) {
arrfree(c->classes[i].members);
arrfree(c->classes[i].events);
arrfree(c->classes[i].implements);
}
for (int32_t i = 0; i < (int32_t)arrlen(c->withEvents); i++) {
arrfree(c->withEvents[i].handlers);
}
// A procedure left open by an error still owns its labels' lists
if (c->inProc) {
for (const BasSymT *l = c->localLabels.first; l != NULL; l = l->orderNext) {
arrfree(l->u.label->patches);
arrfree(l->u.label->patchDepths);
arrfree(l->u.label->dataPatches);
}
}
for (int32_t i = 0; i < (int32_t)arrlen(c->loops); i++) {
arrfree(c->loops[i].exitPatches);
}
arrfree(c->typeDefs);
arrfree(c->classes);
arrfree(c->withEvents);
arrfree(c->formNames);
arrfree(c->moduleVars);
arrfree(c->memberVarDecls);
arrfree(c->memberPatches);
arrfree(c->tempSlots);
arrfree(c->procTempSlots);
arrfree(c->loops);
arrfree(c->exitProcPatches);
arrfree(c->symChanges);
basVmDestroy(c->constVm);
basCodeGenFree(&c->cg);
basArenaFree(&c->unitArena);
basArenaFree(&c->modArena);
free(c);
}
const char *basCompilerError(const BasCompilerT *c) {
return c->error;
}
int32_t basCompilerErrorCol(const BasCompilerT *c) {
return c->errorCol;
}
int32_t basCompilerErrorLine(const BasCompilerT *c) {
return c->errorLine;
}
const char *basCompilerFormScope(const BasCompilerT *c) {
return c->formName;
}
int32_t basCompilerGlobalSlot(const BasCompilerT *c, const char *name) {
const BasSymT *sym = basScopeFindKind(&c->moduleTab, name, SK_VAR);
return (sym != NULL && sym->scope == SCOPE_GLOBAL) ? sym->index : -1;
}
void basCompilerSetOptionExplicit(BasCompilerT *c, bool on) {
c->optionExplicit = on;
}
void basCompilerSetValidator(BasCompilerT *c, const BasCtrlValidatorT *v) {
c->validator = v;
}
void basErrorAt(BasCompilerT *c, int32_t line, int32_t col, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
errorV(c, line, col, fmt, ap);
va_end(ap);
}
void basErrorNode(BasCompilerT *c, const BasNodeT *n, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
errorV(c, n->line, n->col, fmt, ap);
va_end(ap);
}
// The class modules' tables: members (procedures by their index in
// mod->procs), interfaces, Class_Terminate. Frees mod and returns false
// when memory runs out.
static bool buildClasses(const BasCompilerT *c, BasModuleT *mod) {
int32_t count = (int32_t)arrlen(c->classes);
if (count == 0) {
return true;
}
mod->classes = (BasClassInfoT *)calloc(count, sizeof(BasClassInfoT));
if (mod->classes == NULL) {
basModuleFree(mod);
return false;
}
mod->classCount = count;
for (int32_t k = 0; k < count; k++) {
const BasClassDefT *def = &c->classes[k];
BasClassInfoT *info = &mod->classes[k];
int32_t n = (int32_t)arrlen(def->members);
int32_t ni = (int32_t)arrlen(def->implements);
snprintf(info->name, sizeof(info->name), "%s", def->name);
info->varCount = def->varCount;
info->initCodeAddr = def->initCodeAddr;
info->terminateProc = (def->terminateSym != NULL) ? procIndexAt(mod, def->terminateSym->u.proc->codeAddr) : -1;
if (ni > 0) {
info->implements = (BasImplementsT *)calloc(ni, sizeof(BasImplementsT));
if (info->implements == NULL) {
basModuleFree(mod);
return false;
}
info->implementsCount = ni;
}
for (int32_t i = 0; i < ni; i++) {
if (!buildInterfaceMap(c, k, def->implements[i], &info->implements[i])) {
basModuleFree(mod);
return false;
}
}
if (n == 0) {
continue;
}
info->members = (BasClassMemberT *)calloc(n, sizeof(BasClassMemberT));
if (info->members == NULL) {
basModuleFree(mod);
return false;
}
info->memberCount = n;
for (int32_t i = 0; i < n; i++) {
const BasClassMemberDefT *md = &def->members[i];
const BasSymT *sym = md->sym;
BasClassMemberT *m = &info->members[i];
snprintf(m->name, sizeof(m->name), "%s", md->name);
m->kind = md->kind;
m->dataType = sym->dataType;
if (def->defaultMember != NULL && strcasecmp(md->name, def->defaultMember) == 0) {
m->flags |= BAS_MEMBER_DEFAULT;
}
if (sym->flags & SF_FRIEND) {
m->flags |= BAS_MEMBER_FRIEND;
}
if (md->kind == BAS_MEMBER_VAR) {
m->index = sym->index;
continue;
}
const BasProcInfoT *pi = sym->u.proc;
m->index = procIndexAt(mod, pi->codeAddr);
m->requiredParams = (uint8_t)pi->requiredParams;
memcpy(m->paramTypes, pi->paramTypes, DVX_MIN(sizeof(m->paramTypes), sizeof(pi->paramTypes)));
for (int32_t p = 0; p < pi->paramCount && p < BAS_VM_MAX_CALL_ARGS; p++) {
m->defaultParams |= (pi->paramFlags[p] & PARAM_DEFAULT) ? (1u << p) : 0u;
m->byValParams |= (pi->paramFlags[p] & PARAM_BYVAL) ? (1u << p) : 0u;
m->typedParams |= basConvertsArg(pi->paramTypes[p], pi->paramFlags[p]) ? (1u << p) : 0u;
}
if (pi->paramCount > 0 && !joinParamNames(pi, &m->paramNames)) {
basModuleFree(mod);
return false;
}
if (sym->flags & SF_PARAMARRAY) {
m->flags |= BAS_MEMBER_PARAMARRAY;
}
}
}
return true;
}
// Global scalars that start as their type's zero rather than a cleared
// slot's INTEGER 0 (STRING, and the other typed scalars), a table that
// survives stripping unlike the debug variables. Frees mod and returns
// false when memory runs out.
static bool buildGlobalInits(const BasCompilerT *c, BasModuleT *mod) {
int32_t count = 0;
for (int32_t i = 0; i < (int32_t)arrlen(c->moduleVars); i++) {
count += globalStartsTyped(c->moduleVars[i]) ? 1 : 0;
}
if (count == 0) {
return true;
}
mod->globalInits = (BasSlotInitT *)malloc((size_t)count * sizeof(BasSlotInitT));
if (mod->globalInits == NULL) {
basModuleFree(mod);
return false;
}
for (int32_t i = 0; i < (int32_t)arrlen(c->moduleVars); i++) {
const BasSymT *s = c->moduleVars[i];
if (globalStartsTyped(s)) {
mod->globalInits[mod->globalInitCount].index = s->index;
mod->globalInits[mod->globalInitCount].dataType = s->dataType;
mod->globalInitCount++;
}
}
return true;
}
// Where class classIdx has the members of interface iface: for each
// member of iface, the member a read or call reaches (the implementation
// of the same kind; Property Get for a variable) and the one a store
// reaches (Property Let or Set of a variable). False when memory runs
// out.
static bool buildInterfaceMap(const BasCompilerT *c, int32_t classIdx, int32_t iface, BasImplementsT *impl) {
const BasClassDefT *cls = &c->classes[classIdx];
const BasClassDefT *ifc = &c->classes[iface];
int32_t members = (int32_t)arrlen(ifc->members);
impl->iface = iface;
if (members == 0) {
return true;
}
impl->map = (int32_t *)malloc((size_t)members * BAS_IMPL_WAYS * sizeof(int32_t));
if (impl->map == NULL) {
return false;
}
impl->mapLen = members * BAS_IMPL_WAYS;
for (int32_t j = 0; j < members; j++) {
const BasClassMemberDefT *md = &ifc->members[j];
int32_t *ways = &impl->map[j * BAS_IMPL_WAYS];
bool isVar = (md->kind == BAS_MEMBER_VAR);
char qualified[BAS_MAX_IDENT];
int n = snprintf(qualified, sizeof(qualified), "%s" BAS_CLASS_SEP "%s", ifc->name, md->name);
ways[BAS_IMPL_READ] = BAS_MEMBER_NONE;
ways[BAS_IMPL_STORE] = BAS_MEMBER_NONE;
// The interface's own implementations of other interfaces
if (n < 0 || n >= (int)sizeof(qualified) || strchr(md->name, BAS_MEMBER_QUALIFIER[0]) != NULL) {
continue;
}
ways[BAS_IMPL_READ] = classMemberNamed(cls, qualified, isVar ? BAS_MEMBER_GET : md->kind);
if (isVar) {
int32_t let = classMemberNamed(cls, qualified, BAS_MEMBER_LET);
ways[BAS_IMPL_STORE] = (let != BAS_MEMBER_NONE) ? let : classMemberNamed(cls, qualified, BAS_MEMBER_SET);
}
}
return true;
}
// The procedure table, in code order (the debugger's procedure indices).
// Frees mod and returns false when memory runs out.
static bool buildProcs(const BasCompilerT *c, BasModuleT *mod) {
int32_t count = 0;
int32_t inits = 0;
for (const BasSymT *s = c->moduleTab.first; s != NULL; s = s->orderNext) {
count += emittableProc(s) ? 1 : 0;
}
if (count == 0) {
return true;
}
mod->procs = (BasProcEntryT *)malloc((size_t)count * sizeof(BasProcEntryT));
if (mod->procs == NULL) {
basModuleFree(mod);
return false;
}
for (const BasSymT *s = c->moduleTab.first; s != NULL; s = s->orderNext) {
if (!emittableProc(s)) {
continue;
}
// Insertion by code address (definitions usually come in order)
int32_t j = mod->procCount - 1;
while (j >= 0 && mod->procs[j].codeAddr > s->u.proc->codeAddr) {
mod->procs[j + 1] = mod->procs[j];
j--;
}
BasProcEntryT *p = &mod->procs[j + 1];
memset(p, 0, sizeof(*p));
snprintf(p->name, sizeof(p->name), "%s", s->name);
snprintf(p->formName, sizeof(p->formName), "%s", (s->formName != NULL) ? s->formName : "");
p->codeAddr = s->u.proc->codeAddr;
p->paramCount = s->u.proc->paramCount;
p->localCount = s->u.proc->localCount;
p->initCount = s->u.proc->localInitCount;
p->returnType = s->dataType;
p->isFunction = (s->kind == SK_FUNCTION);
mod->procCount++;
inits += p->initCount;
}
// The procedures' local inits, one table in procedure order
if (inits == 0) {
return true;
}
mod->localInits = (BasSlotInitT *)malloc((size_t)inits * sizeof(BasSlotInitT));
if (mod->localInits == NULL) {
basModuleFree(mod);
return false;
}
for (const BasSymT *s = c->moduleTab.first; s != NULL; s = s->orderNext) {
if (emittableProc(s) && s->u.proc->localInitCount > 0) {
BasProcEntryT *p = &mod->procs[procIndexAt(mod, s->u.proc->codeAddr)];
p->initFirst = mod->localInitCount;
memcpy(&mod->localInits[p->initFirst], s->u.proc->localInits, (size_t)p->initCount * sizeof(BasSlotInitT));
mod->localInitCount += p->initCount;
}
}
return true;
}
// The WithEvents variables, handlers by their index in mod->procs. Frees
// mod and returns false when memory runs out.
static bool buildWithEvents(const BasCompilerT *c, BasModuleT *mod) {
int32_t count = (int32_t)arrlen(c->withEvents);
if (count == 0) {
return true;
}
mod->withEvents = (BasWithEventsT *)calloc(count, sizeof(BasWithEventsT));
if (mod->withEvents == NULL) {
basModuleFree(mod);
return false;
}
mod->withEventsCount = count;
for (int32_t w = 0; w < count; w++) {
const BasWithEventsDefT *def = &c->withEvents[w];
BasWithEventsT *we = &mod->withEvents[w];
int32_t n = (int32_t)arrlen(def->handlers);
we->slot = def->var->index;
we->classIdx = def->classIdx;
we->ownerClass = def->ownerClass;
we->scope = def->var->scope;
if (n == 0) {
continue;
}
we->handlers = (BasEventHandlerT *)calloc(n, sizeof(BasEventHandlerT));
if (we->handlers == NULL) {
basModuleFree(mod);
return false;
}
we->handlerCount = n;
for (int32_t i = 0; i < n; i++) {
we->handlers[i].eventIdx = def->handlers[i].eventIdx;
we->handlers[i].procIdx = procIndexAt(mod, def->handlers[i].proc->u.proc->codeAddr);
}
}
return true;
}
// The index of class cls's public member called name of kind, or
// BAS_MEMBER_NONE.
static int32_t classMemberNamed(const BasClassDefT *cls, const char *name, uint8_t kind) {
for (int32_t i = 0; i < (int32_t)arrlen(cls->members); i++) {
if (cls->members[i].kind == kind && strcasecmp(cls->members[i].name, name) == 0) {
return i;
}
}
return BAS_MEMBER_NONE;
}
// The module, form and class member variables and the TYPEs for the
// debugger.
static void collectDebugGlobals(BasCompilerT *c) {
for (int32_t i = 0; i < (int32_t)arrlen(c->moduleVars); i++) {
const BasSymT *s = c->moduleVars[i];
if (s->flags & SF_HIDDEN) {
continue;
}
if (s->scope == SCOPE_MEMBER) {
// Its bare name, with the class as the scope name
const BasClassDefT *cls = &c->classes[s->ownerClass];
basCodeGenAddDebugVar(&c->cg, s->name + strlen(cls->name) + strlen(BAS_CLASS_SEP), SCOPE_MEMBER, s->dataType, s->index, -1, cls->name, false);
} else {
basCodeGenAddDebugVar(&c->cg, s->name, s->scope, s->dataType, s->index, -1, s->formName, (s->flags & SF_SHARED) != 0);
}
}
for (int32_t t = 0; t < (int32_t)arrlen(c->typeDefs); t++) {
const BasTypeDefT *td = c->typeDefs[t];
BasDebugUdtDefT def;
memset(&def, 0, sizeof(def));
snprintf(def.name, sizeof(def.name), "%s", td->sym->name);
def.typeId = t;
// No fields (or no memory): the type name alone, so the debugger
// never walks a missing field array
def.fields = (td->fieldCount > 0) ? (BasDebugFieldT *)malloc((size_t)td->fieldCount * sizeof(BasDebugFieldT)) : NULL;
if (def.fields != NULL) {
def.fieldCount = td->fieldCount;
for (int32_t f = 0; f < td->fieldCount; f++) {
snprintf(def.fields[f].name, sizeof(def.fields[f].name), "%s", td->fields[f].name);
def.fields[f].dataType = td->fields[f].dataType;
}
}
basCodeGenAddUdtDef(&c->cg, &def);
}
}
// A SUB / FUNCTION with a body in this module (not a DECLARE LIBRARY
// function): it gets a procedure-table entry.
static bool emittableProc(const BasSymT *s) {
return (s->kind == SK_SUB || s->kind == SK_FUNCTION) && !(s->flags & SF_EXTERN) && s->u.proc != NULL && s->u.proc->hasCode;
}
// Records the first error: "Line N, Col M: text" ("Line N: text" when the
// column is not known).
static void errorV(BasCompilerT *c, int32_t line, int32_t col, const char *fmt, va_list ap) {
if (c->hasError) {
return;
}
char text[BAS_ERROR_TEXT_LEN];
vsnprintf(text, sizeof(text), fmt, ap);
c->hasError = true;
c->errorLine = line;
c->errorCol = col;
if (col > 0) {
snprintf(c->error, sizeof(c->error), "Line %d, Col %d: %s", (int)line, (int)col, text);
} else {
snprintf(c->error, sizeof(c->error), "Line %d: %s", (int)line, text);
}
}
// A module variable that starts as its type's zero (BasSlotInitT): a
// global scalar declared STRING or with another type basStartsTyped
// names (Variant and Object variables get theirs from their DIM).
static bool globalStartsTyped(const BasSymT *s) {
bool typed = s->dataType == BAS_TYPE_STRING || ((s->flags & SF_TYPED) && s->dataType != BAS_TYPE_VARIANT && s->dataType != BAS_TYPE_OBJECT);
return s->scope == SCOPE_GLOBAL && !(s->flags & SF_ARRAY) && s->objClass == BAS_CLASS_NONE && typed && basStartsTyped(s->dataType);
}
// A procedure's parameter names, comma-separated, into a new string
// (*out): what a late-bound call with named arguments reads. False when
// memory runs out.
static bool joinParamNames(const BasProcInfoT *pi, char **out) {
size_t len = 0;
for (int32_t p = 0; p < pi->paramCount; p++) {
len += strlen(pi->paramNames[p]) + 1;
}
*out = (char *)malloc(len);
if (*out == NULL) {
return false;
}
(*out)[0] = '\0';
for (int32_t p = 0; p < pi->paramCount; p++) {
if (p > 0) {
strcat(*out, BAS_PARAM_NAME_SEP);
}
strcat(*out, pi->paramNames[p]);
}
return true;
}
// Index into mod->procs (sorted by code address) of the procedure at
// codeAddr, or -1.
static int32_t procIndexAt(const BasModuleT *mod, int32_t codeAddr) {
int32_t lo = 0;
int32_t hi = mod->procCount - 1;
while (lo <= hi) {
int32_t mid = lo + (hi - lo) / 2;
if (mod->procs[mid].codeAddr < codeAddr) {
lo = mid + 1;
} else if (mod->procs[mid].codeAddr > codeAddr) {
hi = mid - 1;
} else {
return mid;
}
}
return -1;
}

124
src/apps/kpunch/dvxbasic/compiler/compiler.h Normal file
View file

@ -0,0 +1,124 @@
// 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.
// compiler.h -- DVX BASIC compiler (public interface)
//
// Source text in, BasModuleT out. The compiler reads the source one
// top-level unit at a time (a module-level statement, a procedure, a TYPE
// ...): the parser builds the unit's syntax tree, the passes resolve its
// names, type it and fold its constants, the generator emits its p-code,
// and the unit's memory is released before the next one. A declaration
// pass over the whole source first collects the procedures, classes,
// forms, TYPE and ENUM names so code can use them before their
// definitions.
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_COMPILER_H
#define DVXBASIC_COMPILER_H
#include "../runtime/vm.h"
#include "../runtime/serialize.h"
#include <stdbool.h>
#include <stdint.h>
// Event declarations and WithEvents variables are read by their words
// (identifiers, not reserved); a WithEvents variable's handlers are named
// variable_EventName. Shared with the IDE's Object / Event dropdowns.
#define BAS_KW_EVENT "EVENT"
#define BAS_KW_WITHEVENTS "WITHEVENTS"
#define BAS_EVENT_HANDLER_SEP "_"
// The directives a project's source is built with (basBuild.c writes them
// around each file, the compiler reads them): a module, a class module's
// code and a form's code, each followed by its name as a string.
#define BAS_WRAP_BEGINMODULE "BEGINMODULE"
#define BAS_WRAP_ENDMODULE "ENDMODULE"
#define BAS_WRAP_BEGINCLASS "BEGINCLASS"
#define BAS_WRAP_ENDCLASS "ENDCLASS"
#define BAS_WRAP_BEGINFORM "BEGINFORM"
#define BAS_WRAP_ENDFORM "ENDFORM"
// Optional compile-time validator for CtrlName.Member references. The
// IDE fills it from the project's .frm files and the widget metadata so
// typos fail at compile time; bascomp leaves it unset and the runtime
// reports them. Controls the validator does not know (created at run
// time) are not checked.
typedef struct {
// The widget type name of a control declared in a .frm, or NULL when
// the control is not statically known.
const char *(*lookupCtrlType)(void *ctx, const char *ctrlName);
// True when methodName is valid for widget type wgtType (common
// methods such as Refresh / SetFocus included).
bool (*isMethodValid)(void *ctx, const char *wgtType, const char *methodName);
// True when propName is a property of wgtType.
bool (*isPropValid)(void *ctx, const char *wgtType, const char *propName);
void *ctx;
} BasCtrlValidatorT;
typedef struct BasCompilerS BasCompilerT;
// Compiles the source (prepared by basCompilerCreate). True on success;
// on failure basCompilerError has the message.
bool basCompile(BasCompilerT *c);
// The module compiled by basCompile (NULL after an error or when memory
// runs out). The caller owns it (basModuleFree).
BasModuleT *basCompilerBuildModule(BasCompilerT *c);
// A compiler for source (sourceLen bytes; the text must stay valid until
// basCompilerDestroy). NULL when memory runs out.
BasCompilerT *basCompilerCreate(const char *source, int32_t sourceLen);
// Makes name a module variable (global slot in declaration order) before
// basCompile: the IDE's Immediate window passes the paused program's
// variables this way. False when it cannot be added.
bool basCompilerDeclareGlobal(BasCompilerT *c, const char *name, uint8_t dataType);
void basCompilerDestroy(BasCompilerT *c);
// The first error: "Line N, Col M: message" ("Line N: message" when the
// column is not known).
const char *basCompilerError(const BasCompilerT *c);
// Source column of the first error (0: not known).
int32_t basCompilerErrorCol(const BasCompilerT *c);
// Source line of the first error (0: none).
int32_t basCompilerErrorLine(const BasCompilerT *c);
// BEGINFORM name of the code being compiled right now ("" outside every
// form). A validator's lookupCtrlType can call it to resolve a control
// on the form it belongs to.
const char *basCompilerFormScope(const BasCompilerT *c);
// The global slot of module variable name after basCompile, or -1.
int32_t basCompilerGlobalSlot(const BasCompilerT *c, const char *name);
// OPTION EXPLICIT for the whole program (the project setting).
void basCompilerSetOptionExplicit(BasCompilerT *c, bool on);
// Attaches the validator (borrowed: it must outlive basCompile).
void basCompilerSetValidator(BasCompilerT *c, const BasCtrlValidatorT *v);
#endif // DVXBASIC_COMPILER_H

565
src/apps/kpunch/dvxbasic/compiler/fold.c Normal file
View file

@ -0,0 +1,565 @@
// 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.
// fold.c -- DVX BASIC constant folding on the syntax tree
//
// Values are computed by the VM's own operations (basVmEvalPure), so a
// folded result is exactly what the program would compute. Two modes:
// - constant expressions (CONST values, ENUM members, Optional
// defaults): every pure operator, conversion and built-in is
// evaluated; anything else, or an error (division by zero, overflow),
// is a compile error;
// - ordinary code: integer and string literals are folded where the
// result cannot depend on the machine (no floating point, no
// OPTION COMPARE, no locale) and evaluation succeeds; everything
// else is left for run time, errors included.
#include "front.h"
#include <string.h>
// Operands of a binary operator.
#define BAS_BINARY_OPERANDS 2
// Function prototypes (alphabetical)
bool basConstConvert(BasCompilerT *c, BasConstValT *v, uint8_t asType, const char *what, const BasNodeT *at);
bool basFoldConstExpr(BasCompilerT *c, BasNodeT *expr, BasConstValT *out);
BasNodeT *basFoldConv(BasCompilerT *c, BasNodeT *value, uint8_t op);
BasNodeT *basFoldExpr(BasCompilerT *c, BasNodeT *n);
static bool constFromValue(BasCompilerT *c, BasValueT v, BasConstValT *out, const BasNodeT *at);
static bool evalConst(BasCompilerT *c, const BasNodeT *n, BasValueT *out);
static bool evalOp(BasCompilerT *c, uint8_t op, uint8_t fn, BasValueT *args, int32_t argc, BasValueT *out, const BasNodeT *at, bool report);
static bool integerLiteral(const BasNodeT *n);
static bool literalValue(const BasNodeT *n, BasValueT *out);
static BasNodeT *valueNode(BasCompilerT *c, BasValueT v, const BasNodeT *at);
// Converts constant v to asType the way assignment would: numbers round
// to INTEGER / LONG (overflow is an error), become SINGLE / DOUBLE / DATE
// or TRUE / FALSE; a string never mixes with a number. what names the
// statement in the errors.
bool basConstConvert(BasCompilerT *c, BasConstValT *v, uint8_t asType, const char *what, const BasNodeT *at) {
bool fromString = (v->dataType == BAS_TYPE_STRING);
bool toString = (asType == BAS_TYPE_STRING);
if (fromString != toString || asType == BAS_TYPE_UDT || asType == BAS_TYPE_OBJECT) {
basErrorNode(c, at, "Type mismatch in %s", what);
return false;
}
if (asType == BAS_TYPE_CURRENCY) {
BasValueT amount = (v->dataType == BAS_TYPE_CURRENCY) ? basValCurrency(v->curVal) : basValDouble(v->dblVal);
if (!basValToCurrency(amount, &v->curVal)) {
basErrorNode(c, at, "Overflow in %s", what);
return false;
}
v->dblVal = (double)v->curVal / BAS_CURRENCY_SCALE;
v->dataType = asType;
return true;
}
if (asType == BAS_TYPE_INTEGER || asType == BAS_TYPE_LONG || asType == BAS_TYPE_BYTE) {
int64_t rounded = 0;
int64_t minVal = (asType == BAS_TYPE_INTEGER) ? INT16_MIN : ((asType == BAS_TYPE_BYTE) ? 0 : INT32_MIN);
int64_t maxVal = (asType == BAS_TYPE_INTEGER) ? INT16_MAX : ((asType == BAS_TYPE_BYTE) ? UINT8_MAX : INT32_MAX);
if (!basRoundHalfEven(v->dblVal, &rounded) || rounded < minVal || rounded > maxVal) {
basErrorNode(c, at, "Overflow in %s", what);
return false;
}
v->intVal = (int32_t)rounded;
v->dblVal = v->intVal;
} else if (asType == BAS_TYPE_SINGLE) {
v->dblVal = (float)v->dblVal;
} else if (asType == BAS_TYPE_BOOLEAN) {
v->intVal = (v->dblVal != 0.0) ? BAS_TRUE_INT : 0;
v->dblVal = v->intVal;
}
v->dataType = asType;
return true;
}
// A constant expression (CONST, ENUM member, Optional default): resolved
// with only constants nameable, then computed. False after the error.
bool basFoldConstExpr(BasCompilerT *c, BasNodeT *expr, BasConstValT *out) {
bool saved = c->inConstExpr;
c->inConstExpr = true;
BasNodeT *r = basResolveExpr(c, expr, BAS_USE_VALUE);
c->inConstExpr = saved;
if (r == NULL) {
return false;
}
BasValueT v;
if (!evalConst(c, r, &v)) {
return false;
}
bool ok = constFromValue(c, v, out, r);
// A string constant points into the unit arena until it is stored
if (ok && out->dataType == BAS_TYPE_STRING) {
out->str = basArenaStrDup(&c->unitArena, v.strVal->data, v.strVal->len);
}
basValRelease(&v);
return ok && (out->dataType != BAS_TYPE_STRING || out->str != NULL);
}
// A store conversion (op) of a literal value folded into the literal when
// the result is the same on every machine (an integer), else NULL.
BasNodeT *basFoldConv(BasCompilerT *c, BasNodeT *value, uint8_t op) {
BasValueT v;
BasValueT r;
if (!integerLiteral(value) || (op != OP_CONV_FLT_INT && op != OP_CONV_INT_LONG && op != OP_CONV_BOOL) || !literalValue(value, &v)) {
return NULL;
}
if (!evalOp(c, op, 0, &v, 1, &r, value, false)) {
return NULL;
}
BasNodeT *n = valueNode(c, r, value);
basValRelease(&r);
return n;
}
// Folds the literal subexpressions of n that are the same on every
// machine (see the file comment); returns the node that replaces n.
BasNodeT *basFoldExpr(BasCompilerT *c, BasNodeT *n) {
if (n == NULL || c->hasError) {
return n;
}
switch (n->kind) {
case NK_UNARY: {
BasOpT *op = (BasOpT *)n;
op->a = basFoldExpr(c, op->a);
BasValueT v;
BasValueT r;
// -literal (negation is exact for doubles too), NOT integer
bool foldable = (op->op == TOK_MINUS && (integerLiteral(op->a) || (op->a->kind == NK_DBL && (op->a->type == BAS_TYPE_DOUBLE || op->a->type == BAS_TYPE_CURRENCY)))) || (op->op == TOK_NOT && integerLiteral(op->a));
if (!foldable || !literalValue(op->a, &v) || !evalOp(c, (op->op == TOK_MINUS) ? OP_NEG_INT : OP_NOT, 0, &v, 1, &r, n, false)) {
return n;
}
BasNodeT *lit = valueNode(c, r, n);
basValRelease(&r);
if (lit != NULL) {
lit->next = n->next;
lit->flags = n->flags;
}
return (lit != NULL) ? lit : n;
}
case NK_BINARY: {
BasOpT *op = (BasOpT *)n;
op->a = basFoldExpr(c, op->a);
op->b = basFoldExpr(c, op->b);
uint8_t opcode = basBinaryOpcode(op->op);
bool ints = integerLiteral(op->a) && integerLiteral(op->b) && opcode != OP_DIV_FLT && opcode != OP_POW && opcode != OP_STR_CONCAT && opcode != OP_IS;
bool strs = opcode == OP_STR_CONCAT && op->a->kind == NK_STR && op->b->kind == NK_STR;
BasValueT args[BAS_BINARY_OPERANDS];
BasValueT r;
if ((!ints && !strs) || !literalValue(op->a, &args[0])) {
return n;
}
if (!literalValue(op->b, &args[1])) {
basValRelease(&args[0]);
return n;
}
if (!evalOp(c, opcode, 0, args, BAS_BINARY_OPERANDS, &r, n, false)) {
return n;
}
// An integer result that left the integer range is a double:
// run time computes that, not the folder
if (ints && r.type != BAS_TYPE_INTEGER && r.type != BAS_TYPE_LONG && r.type != BAS_TYPE_BOOLEAN) {
basValRelease(&r);
return n;
}
BasNodeT *lit = valueNode(c, r, n);
basValRelease(&r);
if (lit != NULL) {
lit->next = n->next;
lit->flags = n->flags;
}
return (lit != NULL) ? lit : n;
}
case NK_CALL:
case NK_ELEM:
case NK_INDEX:
case NK_FCALL:
case NK_INTRINSIC:
case NK_METHOD:
case NK_OBJMEMBER:
case NK_FINDCTRLIDX:
case NK_PARAMARRAY:
case NK_BUILTIN: {
BasCallT *call = (BasCallT *)n;
BasNodeT *prev = NULL;
for (BasNodeT *a = call->args; a != NULL;) {
BasNodeT *next = a->next;
BasNodeT *f = basFoldExpr(c, a);
f->next = next;
if (prev != NULL) {
prev->next = f;
} else {
call->args = f;
}
prev = f;
a = next;
}
if (n->kind == NK_ELEM || n->kind == NK_INDEX || n->kind == NK_METHOD || n->kind == NK_OBJMEMBER) {
call->callee = basFoldExpr(c, call->callee);
}
return n;
}
case NK_CONV:
case NK_REF: {
BasOpT *op = (BasOpT *)n;
op->a = basFoldExpr(c, op->a);
return n;
}
case NK_FIELD:
case NK_PROP:
case NK_FINDCTRL:
case NK_TYPEOF: {
BasMemberT *m = (BasMemberT *)n;
m->base = basFoldExpr(c, m->base);
return n;
}
default:
return n;
}
}
// The folded constant a constant expression's value gives: integers are
// LONG, others keep their type; a string holds at most
// BAS_MAX_CONST_STR - 1 characters.
static bool constFromValue(BasCompilerT *c, BasValueT v, BasConstValT *out, const BasNodeT *at) {
memset(out, 0, sizeof(*out));
switch (v.type) {
case BAS_TYPE_INTEGER:
case BAS_TYPE_LONG:
case BAS_TYPE_BOOLEAN:
out->dataType = (v.type == BAS_TYPE_BOOLEAN) ? BAS_TYPE_BOOLEAN : BAS_TYPE_LONG;
out->dblVal = basValToNumber(v);
out->intVal = (int32_t)out->dblVal;
return true;
case BAS_TYPE_SINGLE:
case BAS_TYPE_DOUBLE:
case BAS_TYPE_DATE:
out->dataType = v.type;
out->dblVal = basValToNumber(v);
return true;
case BAS_TYPE_BYTE:
out->dataType = BAS_TYPE_BYTE;
out->intVal = v.intVal;
out->dblVal = v.intVal;
return true;
case BAS_TYPE_CURRENCY:
out->dataType = BAS_TYPE_CURRENCY;
out->curVal = v.curVal;
out->dblVal = basValToNumber(v);
return true;
case BAS_TYPE_STRING:
if (v.strVal->len >= BAS_MAX_CONST_STR) {
basErrorNode(c, at, "Constant string longer than %d characters", (int)(BAS_MAX_CONST_STR - 1));
return false;
}
out->dataType = BAS_TYPE_STRING;
out->strLen = v.strVal->len;
return true;
default:
basErrorNode(c, at, "Constant expression required");
return false;
}
}
// The value of a resolved constant expression (every node must be a
// literal, an operator, a conversion or a pure built-in).
static bool evalConst(BasCompilerT *c, const BasNodeT *n, BasValueT *out) {
if (literalValue(n, out)) {
return true;
}
switch (n->kind) {
case NK_UNARY: {
const BasOpT *op = (const BasOpT *)n;
BasValueT v;
return evalConst(c, op->a, &v) && evalOp(c, (op->op == TOK_MINUS) ? OP_NEG_INT : OP_NOT, 0, &v, 1, out, n, true);
}
case NK_BINARY: {
const BasOpT *op = (const BasOpT *)n;
uint8_t opcode = basBinaryOpcode(op->op);
BasValueT args[BAS_BINARY_OPERANDS];
if (opcode == OP_IS) {
break;
}
if (!evalConst(c, op->a, &args[0])) {
return false;
}
if (!evalConst(c, op->b, &args[1])) {
basValRelease(&args[0]);
return false;
}
return evalOp(c, opcode, 0, args, BAS_BINARY_OPERANDS, out, n, true);
}
case NK_CONV: {
const BasOpT *op = (const BasOpT *)n;
BasValueT v;
return evalConst(c, op->a, &v) && evalOp(c, op->op, 0, &v, 1, out, n, true);
}
case NK_BUILTIN: {
const BasCallT *call = (const BasCallT *)n;
const BasBuiltinT *b = (const BasBuiltinT *)call->target;
BasValueT args[BAS_BUILTIN_MAX_ARGS];
int32_t argc = 0;
if (!(b->flags & BI_PURE)) {
break;
}
for (const BasNodeT *a = call->args; a != NULL; a = a->next) {
if (argc >= BAS_BUILTIN_MAX_ARGS || !evalConst(c, a, &args[argc])) {
for (int32_t i = 0; i < argc; i++) {
basValRelease(&args[i]);
}
return false;
}
argc++;
}
return evalOp(c, (uint8_t)call->aux, b->func, args, argc, out, n, true);
}
default:
break;
}
if (!c->hasError) {
basErrorNode(c, n, "Constant expression required");
}
return false;
}
// Runs one pure operation through the VM's own implementation. report:
// an error is a compile error ("Error in constant expression: ...");
// otherwise a failure just leaves the expression for run time.
static bool evalOp(BasCompilerT *c, uint8_t op, uint8_t fn, BasValueT *args, int32_t argc, BasValueT *out, const BasNodeT *at, bool report) {
if (c->constVm == NULL) {
c->constVm = basVmCreate();
if (c->constVm == NULL) {
for (int32_t i = 0; i < argc; i++) {
basValRelease(&args[i]);
}
basErrorNode(c, at, "Out of memory evaluating a constant expression");
return false;
}
}
c->constVm->compareTextMode = c->compareText;
if (basVmEvalPure(c->constVm, op, fn, args, argc, out) == BAS_VM_OK) {
return true;
}
if (report) {
// The message reads "Runtime error N at PC n: text"; only the text
// means anything here
const char *msg = basVmGetError(c->constVm);
const char *text = strstr(msg, BAS_VM_ERROR_TEXT_SEP);
basErrorNode(c, at, "Error in constant expression: %s", (text != NULL) ? text + strlen(BAS_VM_ERROR_TEXT_SEP) : msg);
}
return false;
}
// True for a literal whose value is the same everywhere: an integer or a
// BOOLEAN.
static bool integerLiteral(const BasNodeT *n) {
return n->kind == NK_INT || n->kind == NK_BOOL;
}
// The value of a literal node (false for anything else).
static bool literalValue(const BasNodeT *n, BasValueT *out) {
const BasLitT *lit = (const BasLitT *)n;
switch (n->kind) {
case NK_INT:
if (n->type == BAS_TYPE_BYTE) {
*out = basValByte((uint8_t)lit->ival);
} else {
*out = (n->type == BAS_TYPE_INTEGER) ? basValInteger((int16_t)lit->ival) : basValLong(lit->ival);
}
return true;
case NK_DBL:
if (n->type == BAS_TYPE_SINGLE) {
*out = basValSingle((float)lit->dval);
} else if (n->type == BAS_TYPE_DATE) {
*out = basValDate(lit->dval);
} else if (n->type == BAS_TYPE_CURRENCY) {
*out = basValCurrency(lit->cval);
} else {
*out = basValDouble(lit->dval);
}
return true;
case NK_STR:
// A fresh string: the value takes it over
*out = basValEmpty();
out->type = BAS_TYPE_STRING;
out->strVal = basStringNew(lit->str, lit->slen);
return true;
case NK_BOOL:
*out = basValBool(lit->ival != 0);
return true;
default:
return false;
}
}
// A literal node holding v (NULL for a value no literal holds).
static BasNodeT *valueNode(BasCompilerT *c, BasValueT v, const BasNodeT *at) {
switch (v.type) {
case BAS_TYPE_INTEGER:
return basNodeInt(c, v.intVal, BAS_TYPE_INTEGER, at);
case BAS_TYPE_LONG:
return basNodeInt(c, v.longVal, BAS_TYPE_LONG, at);
case BAS_TYPE_BYTE:
return basNodeInt(c, v.intVal, BAS_TYPE_BYTE, at);
case BAS_TYPE_CURRENCY:
return basNodeCur(c, v.curVal, at);
case BAS_TYPE_BOOLEAN: {
BasLitT *lit = (BasLitT *)basNodeNew(&c->unitArena, (int32_t)sizeof(BasLitT), NK_BOOL, at->line, at->col);
if (lit != NULL) {
lit->ival = v.boolVal ? BAS_TRUE_INT : 0;
lit->h.type = BAS_TYPE_BOOLEAN;
}
return (BasNodeT *)lit;
}
case BAS_TYPE_DOUBLE: {
BasLitT *lit = (BasLitT *)basNodeNew(&c->unitArena, (int32_t)sizeof(BasLitT), NK_DBL, at->line, at->col);
if (lit != NULL) {
lit->dval = v.dblVal;
lit->h.type = BAS_TYPE_DOUBLE;
}
return (BasNodeT *)lit;
}
case BAS_TYPE_STRING: {
const char *text = basArenaStrDup(&c->unitArena, v.strVal->data, v.strVal->len);
return (text != NULL) ? basNodeStr(c, text, v.strVal->len, at) : NULL;
}
default:
return NULL;
}
}

493
src/apps/kpunch/dvxbasic/compiler/front.h Normal file
View file

@ -0,0 +1,493 @@
// 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.
// front.h -- DVX BASIC compiler internals shared by the front-end passes
//
// parse*.c tokens -> syntax tree of one unit (and the declaration pass)
// resolve*.c names -> symbols, built-ins, controls; semantic checks
// typecheck.c static types and implicit conversions
// fold.c constant folding (CONST values, literal subexpressions)
// gen*.c tree -> p-code
// compiler.c the driver: declaration pass, unit loop, module tables
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_FRONT_H
#define DVXBASIC_FRONT_H
#include "compiler.h"
#include "ast.h"
#include "scope.h"
#include "lexer.h"
#include "codegen.h"
#include "opcodes.h"
#include "../runtime/vm.h"
#include <stdbool.h>
#include <stdint.h>
// Error message sizes: the stored message ("Line N, Col M: text") and
// the text before the prefix is added.
#define BAS_COMPILE_ERROR_LEN 1024
#define BAS_ERROR_TEXT_LEN 512
// Letters DEFINT .. DEFSTR cover (A-Z), and a letter with no DEFxxx.
#define BAS_DEFTYPE_LETTERS ('Z' - 'A' + 1)
#define BAS_DEFTYPE_NONE 0xFF
// Recursion guards: nested expressions and blocks each cost a dozen C
// stack frames, and the DOS stack is small.
#define BAS_MAX_EXPR_DEPTH 64
#define BAS_MAX_BLOCK_DEPTH 32
// Longest TYPE field chain in a store target (a.b.c ...).
#define BAS_MAX_FIELD_CHAIN BAS_LAYOUT_MAX_DEPTH
// The member class of an object the source names directly (a control or
// a form, not an object variable): its methods take their arguments by
// value.
#define BAS_CLASS_HOST (-3)
// BASIC's TRUE as an integer.
#define BAS_TRUE_INT (-1)
// DEF FN function names start with FN.
#define BAS_DEFFN_PREFIX "FN"
// Form / PictureBox drawing methods with QBasic statement syntax, and
// the form methods a two-part name.Show / name.Hide statement means.
#define BAS_METHOD_CIRCLE "Circle"
#define BAS_METHOD_LINE "Line"
#define BAS_METHOD_PRINT "Print"
#define BAS_METHOD_PSET "PSet"
#define BAS_METHOD_SCALE "Scale"
#define BAS_METHOD_SHOW "Show"
#define BAS_METHOD_HIDE "Hide"
// A file-private name (Private CONST / ENUM outside class modules) is the
// name, this separator (no identifier holds it) and the file's number.
#define BAS_FILE_PRIVATE_SEP "|"
// basDeclareEnumName's file for a name every file sees.
#define BAS_FILE_PUBLIC (-1)
// Words the parser reads by their text (identifiers, not reserved).
#define BAS_KW_COMPARE "COMPARE"
#define BAS_KW_FRIEND "FRIEND"
#define BAS_KW_IMPLEMENTS "IMPLEMENTS"
#define BAS_KW_TEXT "TEXT"
// Built-ins the parser calls by these names (BasBuiltinT.name), which no
// identifier can spell: LIKE and ERROR are reserved words, a name holds
// no '.'.
#define BAS_BUILTIN_LIKE "LIKE"
#define BAS_BUILTIN_ERROR "ERROR"
#define BAS_BUILTIN_ERR_DESCRIPTION "ERR.DESCRIPTION"
#define BAS_BUILTIN_ERR_SOURCE "ERR.SOURCE"
// ARRAY(...), which the resolver builds itself (a program's own Array
// procedure or variable comes first).
#define BAS_ARRAY_FUNC "ARRAY"
// Err's members the parser reads by their text.
#define BAS_ERR_MEMBER_CLEAR "CLEAR"
#define BAS_ERR_MEMBER_DESCRIPTION "DESCRIPTION"
#define BAS_ERR_MEMBER_NUMBER "NUMBER"
#define BAS_ERR_MEMBER_RAISE "RAISE"
#define BAS_ERR_MEMBER_SOURCE "SOURCE"
// Arguments of the two-argument statements and built-ins (FILECOPY,
// NAME, SETATTR, SEEK, LIKE ...).
#define BAS_PAIR_ARGS 2
// ST_ONERROR's ival: ON ERROR RESUME NEXT (0: ON ERROR GOTO).
#define BAS_ON_ERROR_RESUME_NEXT 1
// ST_LABEL ival: a QBasic line number (its value in ival2), which ERL reports
#define BAS_LABEL_LINE_NUMBER 1
// MsgBox: the OK button only (vbOKOnly, the default flags).
#define BAS_MSGBOX_OK_ONLY 0x0000
// The error for a name after AS that is no type.
#define BAS_TYPE_EXPECTED "Expected type name (Integer, Long, Single, Double, String, Boolean, Date, Variant, Control, Form, Object, Collection, TYPE, ENUM or class name)"
// Types named by identifiers rather than reserved words.
#define BAS_DATE_TYPE_NAME "DATE"
#define BAS_BYTE_TYPE_NAME "BYTE"
#define BAS_CURRENCY_TYPE_NAME "CURRENCY"
#define BAS_VARIANT_TYPE_NAME "VARIANT"
#define BAS_COLLECTION_TYPE_NAME "COLLECTION"
// The Collection class as messages name it.
#define BAS_COLLECTION_DISPLAY_NAME "Collection"
// Built-in function flags.
#define BI_PURE 0x01 // result depends on the arguments alone: allowed in constant expressions
#define BI_FOLD 0x02 // folded in ordinary code when its arguments are literals
// A built-in function (BasBuiltinT table in resolveExpr.c). An
// OP_BUILTIN entry names its BasBuiltinFnE in func and takes its argument
// counts from basBuiltinArity.
typedef struct {
const char *name;
uint8_t opcode;
uint8_t func;
uint8_t minArgs;
uint8_t maxArgs;
uint8_t resultType; // BAS_TYPE_* the result always has (BAS_NODE_TYPE_UNKNOWN: depends)
uint8_t flags; // BI_*
uint8_t nullMask; // arguments (BAS_NULL_ARG_*) whose Null makes the result Null: VB's Variant forms (Left, Mid ...); 0: none
const char *const *argNames; // VB's names of its arguments (Name:=value), NULL-terminated; NULL: none given by name
} BasBuiltinT;
// How an early-bound member is used (basBindMember).
typedef enum {
BAS_ACCESS_READ, // obj.name: its value (no argument list)
BAS_ACCESS_VALUE, // obj.name(args) in an expression
BAS_ACCESS_STATEMENT, // obj.name args / obj.name(args) as a statement
BAS_ACCESS_LET, // obj.name(args) = value
BAS_ACCESS_SET // Set obj.name(args) = value
} BasAccessE;
// How an unresolved name is being used (resolver).
typedef enum {
BAS_USE_VALUE, // its value
BAS_USE_OBJECT, // an object is expected (SET value, IS / TypeOf operand, object parameter)
BAS_USE_MEMBERBASE // name.member
} BasUseE;
// Deferred argument forms of the drawing methods (obj.Line ...), read
// once the resolver knows whether obj is a class instance.
typedef enum {
BAS_DEFER_ARGS, // comma-separated method arguments
BAS_DEFER_DRAWING // the method's QBasic statement syntax (Print items, Line / Circle / PSet blocks, Scale rectangle)
} BasDeferModeE;
// How an assignment stores (BasStmtT.ival2 of ST_ASSIGN).
typedef enum {
BAS_STORE_PLAIN, // the value replaces what the target holds
BAS_STORE_APPEND, // s = s + x / s = s & x on a STRING variable: x appended in place (OP_STR_APPEND); ival = the operator
BAS_STORE_RECORD // a TYPE value copied into the record the target holds (BAS_FN_RECORD_ASSIGN)
} BasStoreE;
// A change the resolver made to a symbol in the middle of a unit (see
// basSymChange): what it was before and after statement at.
typedef struct {
const BasNodeT *at;
BasSymT *sym;
uint32_t beforeFlags;
uint32_t afterFlags;
int32_t beforeUdtTypeId;
int32_t afterUdtTypeId;
uint8_t beforeType;
uint8_t afterType;
} BasSymChangeT;
// A loop or SELECT the generator is inside.
typedef struct {
int32_t *exitPatches; // stb_ds: EXIT jumps to land after the loop
int32_t selectBase; // SELECT depth at the loop's start (EXIT pops the ones opened since)
bool isFor; // FOR / FOR EACH (else DO / WHILE)
bool isForEach; // no VM FOR frame to drop on EXIT FOR
} BasGenLoopT;
struct BasCompilerS {
// Source and tokens
const char *source;
int32_t sourceLen;
BasLexerT lex;
int32_t prevLine; // line of the previous token (errors at the end of a line)
// First error
char error[BAS_COMPILE_ERROR_LEN];
bool hasError;
int32_t errorLine;
int32_t errorCol;
// Memory: module-lifetime data and the unit being compiled
BasArenaT modArena;
BasArenaT unitArena;
// Parser context (syntax only)
int32_t exprDepth;
int32_t blockDepth;
bool parseInClass; // between BEGINCLASS and ENDCLASS
bool parseInProc; // inside a SUB / FUNCTION / Property body
bool parseProcIsFunction; // ... a FUNCTION or Property Get (its name sets its result)
bool parseProcIsStatic; // ... declared STATIC (its DIMs declare STATIC variables)
const char *parseProcName; // the procedure being parsed (its own name sets its result)
const char *parseClassName; // the class module being parsed (module arena; parseInClass)
BasWithT *parseWith; // the innermost WITH block being parsed (its '.name's)
// Symbols
BasScopeTabT moduleTab; // globals, procedures, constants, TYPE / ENUM / class names
BasScopeTabT moduleLabels;
BasScopeTabT formTab; // the current form's variables (inForm)
BasScopeTabT localTab; // the current procedure's parameters and locals (inProc)
BasScopeTabT localLabels;
BasTypeDefT **typeDefs; // stb_ds, indexed by TYPE id
BasClassDefT *classes; // stb_ds, indexed by class number
BasWithEventsDefT *withEvents; // stb_ds, binding number order
const char **formNames; // stb_ds, every BEGINFORM name (declaration pass)
BasSymT **moduleVars; // stb_ds, module / form / member variables in creation order (debug info)
BasMemberVarDeclT *memberVarDecls; // stb_ds, class member variables the declaration pass read (registered at its end)
BasMemberPatchT *memberPatches; // stb_ds, early-bound member operands to fill in at the end
// Scope state (resolver, in source order)
bool inForm;
bool inClass;
bool inProc;
bool inDefFn; // a DEF FN body: undeclared names are module variables
bool inConstExpr; // a constant expression: only constants may be named
const char *formName; // current form ("" outside)
int32_t fileIdx; // the project file being compiled (BEGINMODULE / BEGINFORM / BEGINCLASS block; 0 outside them): where a Private CONST / ENUM is seen
int32_t outerFileIdx; // fileIdx around the BEGINFORM / BEGINCLASS block being compiled (a class inside a project's module goes back to the module's)
int32_t fileCount; // file numbers given out so far
int32_t filePrivates; // file-private names declared (lookups try the file's own first while there are any)
int32_t classIdx; // current class (inClass)
BasSymT *curProc; // procedure being compiled (inProc)
const char *curProcName; // its name as written (its result is set by it)
uint8_t curProcKind; // its BasMemberKindE
bool curProcStatic; // it was declared STATIC: its implicit variables are STATIC
int32_t nextGlobalSlot;
int32_t nextFormSlot;
int32_t nextMemberSlot;
int32_t nextLocalSlot;
int32_t hiddenCount; // names of compiler variables
uint8_t defType[BAS_DEFTYPE_LETTERS];
int32_t optionBase;
bool optionExplicit;
bool compareText; // OPTION COMPARE TEXT (constant expressions)
// Resolver bookkeeping inside a procedure (or the module body)
int32_t forDepth;
int32_t doDepth;
int32_t selectDepth;
int32_t lastLabelDepth; // SELECT depth at the label defined last (RETURN pops the ones opened since)
int32_t savedForDepth; // the module body's bookkeeping while a procedure is compiled
int32_t savedDoDepth;
int32_t savedSelectDepth;
int32_t savedLabelDepth;
BasSymChangeT *symChanges; // stb_ds: the current unit's symbol changes, in source order
// Code generation
BasCodeGenT cg;
int32_t initJmpAddr; // JMP over a form / class set-up block (-1: none)
int32_t initCodeStart; // first byte of that block
int32_t procSkipJump; // JMP over the procedures defined since the last module code (-1: none)
int32_t *tempSlots; // stb_ds: compiler temporaries of the module code (global / form slots)
int32_t *procTempSlots; // stb_ds: compiler temporaries of the procedure being generated (local slots)
int32_t tempUsed; // temporaries the current statement holds
BasGenLoopT *loops; // stb_ds: open loops, innermost last
int32_t genSelectDepth; // SELECT test values on the eval stack
int32_t *exitProcPatches; // stb_ds: EXIT SUB / FUNCTION / PROPERTY jumps
int32_t debugProcCount; // procedures emitted (debugger procIndex)
BasVmT *constVm; // evaluates constant expressions (made on first use)
const BasCtrlValidatorT *validator;
};
// ============================================================
// Errors (compiler.c)
// ============================================================
// Records the first error at line / col (col 0: not known).
void basErrorAt(BasCompilerT *c, int32_t line, int32_t col, const char *fmt, ...);
// Records the first error at a node.
void basErrorNode(BasCompilerT *c, const BasNodeT *n, const char *fmt, ...);
// ============================================================
// Parser (parse.c, parseExpr.c, parseStmt.c, parseDecl.c)
// ============================================================
void basParseAdvance(BasCompilerT *c);
BasTokenTypeE basParseAfterParens(BasLexerT *lex);
BasNodeT *basParseArgList(BasCompilerT *c, int32_t *outArgc);
bool basParseAtEnd(BasCompilerT *c);
BasNodeT *basParseAttribute(BasCompilerT *c);
BasNodeT *basParseBareArgs(BasCompilerT *c, int32_t *outArgc);
BasNodeT *basParseBuiltinCall(BasCompilerT *c, const char *name, BasNodeT *args, int32_t argc, int32_t line, int32_t col);
BasNodeT *basParseChain(BasCompilerT *c, BasNodeT *base, bool statement);
bool basParseCheck(const BasCompilerT *c, BasTokenTypeE type);
bool basParseCheckWord(const BasCompilerT *c, const char *word);
BasNodeT *basParseCurLit(BasCompilerT *c, int64_t scaled);
void basParseDeclarations(BasCompilerT *c);
BasNodeT *basParseDeclStatement(BasCompilerT *c);
BasNodeT *basParseDeferredArgs(BasCompilerT *c, BasStmtT *call, BasDeferModeE mode, int32_t *outArgc);
void basParseError(BasCompilerT *c, const char *fmt, ...);
void basParseErrorExpected(BasCompilerT *c, const char *what);
BasNodeT *basParseEvent(BasCompilerT *c);
void basParseExpect(BasCompilerT *c, BasTokenTypeE type);
void basParseExpectEnd(BasCompilerT *c);
BasNodeT *basParseExpr(BasCompilerT *c);
bool basParseFriendAhead(const BasCompilerT *c);
BasNodeT *basParseFriendProc(BasCompilerT *c);
BasNodeT *basParseInputBoxArgs(BasCompilerT *c, int32_t *outArgc);
BasNodeT *basParseIntLit(BasCompilerT *c, int32_t value);
BasNodeT *basParseIntrinsic(BasCompilerT *c, uint8_t opcode, BasNodeT *args, int32_t argc, int32_t operand);
BasNodeT *basParseLValue(BasCompilerT *c, bool allowFields);
bool basParseMatch(BasCompilerT *c, BasTokenTypeE type);
bool basParseMatchEnd(BasCompilerT *c, BasTokenTypeE kw);
BasNodeT *basParseMsgBoxArgs(BasCompilerT *c, int32_t *outArgc);
bool basParseNameFollows(BasCompilerT *c, bool anyWord);
BasNodeT *basParseNode(BasCompilerT *c, int32_t size, uint8_t kind);
BasNodeT *basParseObjectOperand(BasCompilerT *c, BasNodeT *operand);
BasTokenTypeE basParsePeekAfterParens(const BasCompilerT *c);
BasProcT *basParseProcHeader(BasCompilerT *c, uint8_t memberKind, bool memberName);
void basParseSkipNewlines(BasCompilerT *c);
BasNodeT *basParseStatement(BasCompilerT *c);
BasNodeT *basParseStrLit(BasCompilerT *c, const char *text, int32_t len);
char *basParseTokenName(BasCompilerT *c);
BasNodeT *basParseUnit(BasCompilerT *c);
BasNodeT *basParseWithRef(BasCompilerT *c);
// ============================================================
// Resolver (resolve.c, resolveExpr.c)
// ============================================================
BasSymT *basAddGlobalVar(BasCompilerT *c, const char *name, uint8_t dataType);
BasSymT *basAddLocal(BasCompilerT *c, const char *name, uint8_t kind, uint8_t dataType);
BasSymT *basAddLocalVar(BasCompilerT *c, const char *name, uint8_t dataType);
BasSymT *basAddModuleVar(BasCompilerT *c, const char *name, uint8_t dataType);
BasNodeT *basBindMember(BasCompilerT *c, BasNodeT *obj, int32_t cls, const char *name, BasNodeT *args, int32_t argc, uint8_t access, const BasNodeT *at);
const BasBuiltinT *basBuiltinFind(const char *name);
int32_t basClassFind(BasCompilerT *c, const char *name);
bool basClassKnown(int32_t cls);
void basCloseProcScope(BasCompilerT *c);
BasNodeT *basControlNode(BasCompilerT *c, const char *name, const BasNodeT *at);
bool basConvertsArg(uint8_t dataType, uint8_t paramFlags);
void basDeclareClass(BasCompilerT *c, const char *name);
uint8_t basDeclaredStoreType(const BasSymT *sym);
void basDeclareEnumName(BasCompilerT *c, const char *name, int32_t privateFile);
void basDeclareForm(BasCompilerT *c, const char *name);
void basDeclareLibrary(BasCompilerT *c, const BasStmtT *s);
void basDeclareMemberVars(BasCompilerT *c, const BasStmtT *dim, int32_t classIdx);
void basDeclareMemberVarsEnd(BasCompilerT *c);
void basDeclareProc(BasCompilerT *c, BasProcT *proc, int32_t classIdx);
void basDeclareTypeName(BasCompilerT *c, const char *name);
BasSymT *basEnsureVariable(BasCompilerT *c, const char *name, const BasNodeT *at);
int32_t basExprClass(const BasCompilerT *c, const BasNodeT *n);
int32_t basExprUdtType(const BasCompilerT *c, const BasNodeT *n);
int32_t basFieldIndex(const BasTypeDefT *td, const char *name);
bool basFilePrivateName(const BasCompilerT *c, const char *name, int32_t fileIdx, char *out, int32_t outSize);
uint8_t basImplicitType(const BasCompilerT *c, const char *name, bool *outTyped);
bool basIsDefFnName(const char *name);
bool basIsFormName(const BasCompilerT *c, const char *name);
bool basLateArgs(BasCompilerT *c, BasCallT *call, BasNodeT *args, int32_t argc, bool byRef);
BasNodeT *basLoadFormNode(BasCompilerT *c, const char *name, const BasNodeT *at);
BasSymT *basLookup(BasCompilerT *c, const char *name);
BasSymT *basLookupModuleVar(BasCompilerT *c, const char *name);
BasSymT *basLookupProc(BasCompilerT *c, const char *name);
BasSymT *basModuleFind(const BasCompilerT *c, const char *name);
BasNodeT *basNamedArgs(BasCompilerT *c, const char *const *names, int32_t count, BasNodeT *args, const BasNodeT *at);
BasNodeT *basNodeConst(BasCompilerT *c, const BasConstValT *v, const BasNodeT *at);
BasNodeT *basNodeConv(BasCompilerT *c, BasNodeT *a, uint8_t op, int32_t aux);
BasNodeT *basNodeCur(BasCompilerT *c, int64_t scaled, const BasNodeT *at);
BasNodeT *basNodeInt(BasCompilerT *c, int32_t value, uint8_t type, const BasNodeT *at);
BasNodeT *basNodeIntrinsic(BasCompilerT *c, uint8_t opcode, BasNodeT *args, int32_t argc, int32_t operand, int32_t line, int32_t col);
BasNodeT *basNodeSpecial(BasCompilerT *c, int32_t kind, const BasNodeT *at);
BasNodeT *basNodeStr(BasCompilerT *c, const char *text, int32_t len, const BasNodeT *at);
BasNodeT *basNodeVar(BasCompilerT *c, BasSymT *sym, const BasNodeT *at);
BasNodeT *basNodeZero(BasCompilerT *c, uint8_t dataType, const BasNodeT *at);
BasSymT *basPropertyProc(BasCompilerT *c, const char *name, bool isSet);
bool basQualify(const BasCompilerT *c, int32_t classIdx, const char *name, char *out, int32_t outSize);
bool basRejectHiddenModuleVar(BasCompilerT *c, const char *name, const BasNodeT *at);
BasNodeT *basResolveArg(BasCompilerT *c, BasNodeT *arg, bool byRef, uint8_t *outRefType);
void basResolveBody(BasCompilerT *c, BasNodeT *list);
BasNodeT *basResolveCallee(BasCompilerT *c, BasCallT *call, bool statement);
void basResolveDefType(BasCompilerT *c, const BasStmtT *s);
BasNodeT *basResolveExpr(BasCompilerT *c, BasNodeT *n, uint8_t use);
BasNodeT *basResolveLValue(BasCompilerT *c, BasNodeT *n, bool allowFields);
BasNodeT *basResolveMemberParts(BasCompilerT *c, BasMemberT *m, bool isProp, BasNodeT **outObj, int32_t *outClass);
BasNodeT *basResolveMethodArgs(BasCompilerT *c, BasNodeT *args, int32_t argc, bool byRef);
void basResolveModuleEnd(BasCompilerT *c);
BasNodeT *basResolveObjectMember(BasCompilerT *c, BasNodeT *obj, const char *name, int32_t memberClass, uint16_t flags, const BasNodeT *at);
BasNodeT *basResolveProcArgs(BasCompilerT *c, const BasSymT *sym, BasNodeT *args, int32_t valueParams, const BasNodeT *at, int32_t *outArgc);
void basResolveStatement(BasCompilerT *c, BasNodeT *s);
bool basResolveTypeSpec(BasCompilerT *c, const BasTypeSpecT *t, bool prescan, uint8_t *outType, int32_t *outUdt, int32_t *outClass);
void basResolveUnit(BasCompilerT *c, BasNodeT *unit);
void basResolveUnitEnd(BasCompilerT *c, BasNodeT *unit);
BasSymT *basStaticVariable(BasCompilerT *c, const char *name, uint8_t dataType, bool isTyped, int32_t objClass, int32_t fixedLen, const BasNodeT *at, BasSymT **outSlot);
BasScopeE basStorageScope(const BasSymT *sym);
void basSymChange(BasCompilerT *c, BasSymT *sym, const BasNodeT *at, uint8_t dataType, int32_t udtTypeId, uint32_t flags);
void basSymChangesUndo(BasCompilerT *c);
BasNodeT *basTypedArg(BasCompilerT *c, const char *procName, int32_t idx, uint8_t dataType, bool byVal, BasNodeT *arg);
bool basValidateCtrlMember(BasCompilerT *c, const char *ctrlName, const char *member, bool isProp, const BasNodeT *at);
BasNodeT *basWithObject(BasCompilerT *c, const BasNodeT *ref);
// ============================================================
// Types and folding (typecheck.c, fold.c)
// ============================================================
bool basConstConvert(BasCompilerT *c, BasConstValT *v, uint8_t asType, const char *what, const BasNodeT *at);
bool basFoldConstExpr(BasCompilerT *c, BasNodeT *expr, BasConstValT *out);
BasNodeT *basFoldConv(BasCompilerT *c, BasNodeT *value, uint8_t op);
BasNodeT *basFoldExpr(BasCompilerT *c, BasNodeT *n);
bool basStartsTyped(uint8_t dataType);
uint8_t basStaticType(const BasNodeT *n);
void basTypeUnit(BasCompilerT *c, BasNodeT *unit);
// ============================================================
// Generator (gen.c, genExpr.c, genStmt.c)
// ============================================================
uint8_t basBinaryOpcode(uint8_t tok);
void basGenAddrOf(BasCompilerT *c, const BasSymT *sym);
void basGenArgs(BasCompilerT *c, const BasNodeT *list);
void basGenBody(BasCompilerT *c, const BasNodeT *list);
void basGenCall(BasCompilerT *c, BasSymT *sym, int32_t argc);
void basGenDeclaration(BasCompilerT *c, const BasNodeT *s);
void basGenExpr(BasCompilerT *c, const BasNodeT *n);
void basGenFlushProcSkip(BasCompilerT *c);
int32_t basGenJump(BasCompilerT *c, uint8_t op);
void basGenJumpTo(BasCompilerT *c, uint8_t op, int32_t target);
void basGenLine(BasCompilerT *c, const BasNodeT *s);
void basGenLoadTemp(BasCompilerT *c, int32_t slot);
void basGenLoadVar(BasCompilerT *c, const BasSymT *sym);
void basGenObjMember(BasCompilerT *c, uint8_t op, const BasCallT *call);
void basGenPatchHere(BasCompilerT *c, int32_t operandPos);
void basGenPushCStr(BasCompilerT *c, const char *text);
void basGenPushInt16(BasCompilerT *c, int16_t v);
void basGenPushSpecial(BasCompilerT *c, uint8_t kind);
void basGenPushStr(BasCompilerT *c, const char *text, int32_t len);
void basGenRef(BasCompilerT *c, const BasNodeT *n);
void basGenSlotRef(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t storeType);
void basGenStatement(BasCompilerT *c, const BasNodeT *s);
void basGenStore(BasCompilerT *c, const BasSymT *sym);
void basGenStoreConv(BasCompilerT *c, uint8_t dataType);
void basGenStoreFrom(BasCompilerT *c, const BasSymT *sym, uint8_t valueType);
void basGenStoreRaw(BasCompilerT *c, const BasSymT *sym);
void basGenStoreSlot(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t conv);
void basGenStoreTemp(BasCompilerT *c, int32_t slot);
uint8_t basGenStoreValue(BasCompilerT *c, const BasNodeT *value, uint8_t convType, int32_t fixedLen, int32_t objClass, bool isSet, bool deferConv);
void basGenSymChanges(BasCompilerT *c, const BasNodeT *at);
int32_t basGenTemp(BasCompilerT *c);
void basGenTempRef(BasCompilerT *c);
void basGenTempReset(BasCompilerT *c);
bool basGenUdtLayout(BasCompilerT *c, int32_t typeId);
bool basGenUdtSpec(BasCompilerT *c, int32_t typeId);
#endif // DVXBASIC_FRONT_H

887
src/apps/kpunch/dvxbasic/compiler/gen.c Normal file
View file

@ -0,0 +1,887 @@
// 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.
// gen.c -- DVX BASIC generator: emit helpers, stores, calls,
// declarations and procedures
//
// Turns a resolved unit into p-code. Statement boundaries (OP_LINE),
// conditional-jump shapes and the SELECT test value on the eval stack are
// what the VM's error recovery (RESUME NEXT) walks, so every construct
// keeps the layout the VM expects (see vm.c nextStatementPc). A
// procedure's body follows its entry directly: implicit STRING locals and
// an Object / Variant result are initialised first, then the parameters'
// default values.
#include "front.h"
#include "thirdparty/stb_ds_wrap.h"
#include <stdio.h>
#include <string.h>
// Function prototypes (alphabetical)
void basGenAddrOf(BasCompilerT *c, const BasSymT *sym);
void basGenCall(BasCompilerT *c, BasSymT *sym, int32_t argc);
void basGenDeclaration(BasCompilerT *c, const BasNodeT *s);
int32_t basGenJump(BasCompilerT *c, uint8_t op);
void basGenJumpTo(BasCompilerT *c, uint8_t op, int32_t target);
void basGenLoadTemp(BasCompilerT *c, int32_t slot);
void basGenLoadVar(BasCompilerT *c, const BasSymT *sym);
void basGenPatchHere(BasCompilerT *c, int32_t operandPos);
void basGenPushCStr(BasCompilerT *c, const char *text);
void basGenPushInt16(BasCompilerT *c, int16_t v);
void basGenPushSpecial(BasCompilerT *c, uint8_t kind);
void basGenPushStr(BasCompilerT *c, const char *text, int32_t len);
void basGenSlotRef(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t storeType);
void basGenStore(BasCompilerT *c, const BasSymT *sym);
void basGenStoreConv(BasCompilerT *c, uint8_t dataType);
void basGenStoreFrom(BasCompilerT *c, const BasSymT *sym, uint8_t valueType);
void basGenStoreRaw(BasCompilerT *c, const BasSymT *sym);
void basGenStoreSlot(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t conv);
void basGenStoreTemp(BasCompilerT *c, int32_t slot);
uint8_t basGenStoreValue(BasCompilerT *c, const BasNodeT *value, uint8_t convType, int32_t fixedLen, int32_t objClass, bool isSet, bool deferConv);
int32_t basGenTemp(BasCompilerT *c);
void basGenTempRef(BasCompilerT *c);
void basGenTempReset(BasCompilerT *c);
bool basGenUdtLayout(BasCompilerT *c, int32_t typeId);
bool basGenUdtSpec(BasCompilerT *c, int32_t typeId);
static bool buildLayout(BasCompilerT *c, int32_t typeId, uint8_t *buf, int32_t *len, int32_t depth);
static uint16_t classOperand(int32_t objClass);
static void closeInitBlock(BasCompilerT *c);
static void genDeclarator(BasCompilerT *c, const BasDeclT *d);
static void genDefFn(BasCompilerT *c, const BasProcT *fn);
static void genDim(BasCompilerT *c, const BasStmtT *s);
static void genProc(BasCompilerT *c, const BasProcT *proc);
static void genProcInits(BasCompilerT *c, const BasSymT *sym);
static void genStaticAlloc(BasCompilerT *c, const BasSymT *sym);
static void genStaticAllocs(BasCompilerT *c);
static uint16_t objCheckOperand(int32_t objClass);
static void openInitBlock(BasCompilerT *c);
static void startProc(BasCompilerT *c, BasSymT *sym);
static uint8_t tempScope(const BasCompilerT *c);
// Pushes a reference to variable sym (or a whole array): stores through
// it convert to the variable's declared type and keep a STRING * n's
// length, as a store into the variable would.
void basGenAddrOf(BasCompilerT *c, const BasSymT *sym) {
if (sym->flags & SF_ARRAY) {
basGenSlotRef(c, basStorageScope(sym), sym->index, BAS_TYPE_VARIANT);
return;
}
basGenSlotRef(c, basStorageScope(sym), sym->index, basDeclaredStoreType(sym));
if (sym->fixedLen > 0) {
basEmit8(&c->cg, OP_REF_FIXLEN);
basEmitU16(&c->cg, (uint16_t)sym->fixedLen);
}
}
// The call of procedure sym whose argc arguments are on the stack: a
// native function's OP_CALL_EXTERN, else OP_CALL (OP_CALL_ME when a
// class calls one of its own procedures, keeping its Me), its address
// patched in once the body is generated.
void basGenCall(BasCompilerT *c, BasSymT *sym, int32_t argc) {
BasProcInfoT *pi = sym->u.proc;
if (sym->flags & SF_EXTERN) {
basEmit8(&c->cg, OP_CALL_EXTERN);
basEmitU16(&c->cg, pi->externLibIdx);
basEmitU16(&c->cg, pi->externFuncIdx);
basEmit8(&c->cg, (uint8_t)argc);
basEmit8(&c->cg, sym->dataType);
return;
}
basEmit8(&c->cg, (sym->ownerClass != BAS_CLASS_NONE) ? OP_CALL_ME : OP_CALL);
int32_t addrPos = basCodePos(&c->cg);
basEmit32(&c->cg, pi->hasCode ? pi->codeAddr : 0);
basEmit8(&c->cg, (uint8_t)argc);
basEmit8(&c->cg, (uint8_t)((sym->kind == SK_FUNCTION) ? 1 : 0));
if (!pi->hasCode) {
arrput(pi->patches, addrPos);
}
}
// A declaration or a statement that opens or closes something (gen of
// the statements in genStmt.c hands these over).
void basGenDeclaration(BasCompilerT *c, const BasNodeT *s) {
const BasStmtT *st = (const BasStmtT *)s;
switch (s->kind) {
case ST_DIM:
genDim(c, st);
break;
case ST_PROC:
genProc(c, (const BasProcT *)s);
break;
case ST_DEFFN:
genDefFn(c, (const BasProcT *)s);
break;
case ST_BEGINFORM:
case ST_BEGINCLASS:
openInitBlock(c);
break;
case ST_ENDFORM: {
BasFormVarInfoT info;
closeInitBlock(c);
memset(&info, 0, sizeof(info));
snprintf(info.formName, sizeof(info.formName), "%s", c->formName);
info.varCount = st->ival;
info.initCodeAddr = c->initCodeStart;
info.initCodeLen = basCodePos(&c->cg) - c->initCodeStart;
basCodeGenAddFormVarInfo(&c->cg, &info);
break;
}
case ST_ENDCLASS: {
BasClassDefT *cls = &c->classes[c->classIdx];
basGenFlushProcSkip(c);
// Each object's copies of the class procedures' STATIC variables
// (an array or TYPE allocated, a dynamic array left for REDIM)
for (const BasSymT *v = c->moduleTab.first; v != NULL; v = v->orderNext) {
if (!(v->flags & SF_STATIC) || v->ownerClass != c->classIdx || ((v->flags & SF_ARRAY) && v->u.alloc == NULL)) {
continue;
}
if (v->u.alloc != NULL) {
genStaticAlloc(c, v);
basGenStoreRaw(c, v);
} else {
BasNodeT *zero = basNodeZero(c, v->dataType, s);
basGenExpr(c, zero);
basGenStoreFrom(c, v, basStaticType(zero));
}
}
// The instance set-up ends by running Class_Initialize
if (st->sym != NULL) {
basGenCall(c, st->sym, 0);
}
closeInitBlock(c);
cls->initCodeAddr = c->initCodeStart;
cls->varCount = st->ival;
break;
}
case ST_OPTION:
// OPTION COMPARE sets the mode where the program runs past it
if (st->ival == BAS_OPTION_COMPARE) {
basGenLine(c, s);
basEmit8(&c->cg, OP_COMPARE_MODE);
basEmit8(&c->cg, (uint8_t)st->ival2);
}
break;
default:
// CONST, TYPE, ENUM, DECLARE, SHARED, STATIC ...: no code
break;
}
}
// A forward jump: the opcode and a placeholder offset, whose position is
// returned for basGenPatchHere.
int32_t basGenJump(BasCompilerT *c, uint8_t op) {
basEmit8(&c->cg, op);
int32_t pos = basCodePos(&c->cg);
basEmit32(&c->cg, 0);
return pos;
}
// A jump to a known address (a loop's top).
void basGenJumpTo(BasCompilerT *c, uint8_t op, int32_t target) {
basEmit8(&c->cg, op);
basEmit32(&c->cg, target - (basCodePos(&c->cg) + BAS_CODE_ADDR_SIZE));
}
void basGenLoadTemp(BasCompilerT *c, int32_t slot) {
static const uint8_t ops[] = { OP_LOAD_GLOBAL, OP_LOAD_LOCAL, OP_LOAD_FORM_VAR, OP_LOAD_MEMBER };
basEmit8(&c->cg, ops[tempScope(c)]);
basEmitU16(&c->cg, (uint16_t)slot);
}
void basGenLoadVar(BasCompilerT *c, const BasSymT *sym) {
static const uint8_t ops[] = { OP_LOAD_GLOBAL, OP_LOAD_LOCAL, OP_LOAD_FORM_VAR, OP_LOAD_MEMBER };
basEmit8(&c->cg, ops[basStorageScope(sym)]);
basEmitU16(&c->cg, (uint16_t)sym->index);
}
// Lands the forward jump whose operand is at operandPos here.
void basGenPatchHere(BasCompilerT *c, int32_t operandPos) {
basPatch32(&c->cg, operandPos, basCodePos(&c->cg) - (operandPos + BAS_CODE_ADDR_SIZE));
}
void basGenPushCStr(BasCompilerT *c, const char *text) {
basGenPushStr(c, text, (int32_t)strlen(text));
}
void basGenPushInt16(BasCompilerT *c, int16_t v) {
basEmit8(&c->cg, OP_PUSH_INT16);
basEmit16(&c->cg, v);
}
// Empty, Null, Nothing or Missing (BasSpecialValE).
void basGenPushSpecial(BasCompilerT *c, uint8_t kind) {
basEmit8(&c->cg, OP_PUSH_SPECIAL);
basEmit8(&c->cg, kind);
}
void basGenPushStr(BasCompilerT *c, const char *text, int32_t len) {
uint16_t idx = basAddConstant(&c->cg, text, len);
basEmit8(&c->cg, OP_PUSH_STR);
basEmitU16(&c->cg, idx);
}
// Pushes a reference to slot of scope (BasScopeE); storeType is the
// type stores through it convert to (BAS_TYPE_VARIANT: none).
void basGenSlotRef(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t storeType) {
static const uint8_t ops[] = { OP_PUSH_GLOBAL_ADDR, OP_PUSH_LOCAL_ADDR, OP_PUSH_FORM_ADDR, OP_PUSH_MEMBER_ADDR };
basEmit8(&c->cg, ops[scope]);
basEmitU16(&c->cg, (uint16_t)slot);
basEmit8(&c->cg, storeType);
}
// Stores the value on the stack into variable sym as a store into it
// converts: a STRING * n padded or cut, a typed scalar converted, a
// variable declared As a class checked. An array takes the array as it
// is (DIM / REDIM).
void basGenStore(BasCompilerT *c, const BasSymT *sym) {
basGenStoreFrom(c, sym, BAS_NODE_TYPE_UNKNOWN);
}
// The conversion a value goes through when stored where dataType is
// declared (none for OBJECT, VARIANT, TYPE).
void basGenStoreConv(BasCompilerT *c, uint8_t dataType) {
uint8_t op = basConvOpForStore(dataType);
if (op != OP_NOP) {
basEmit8(&c->cg, op);
}
}
// basGenStore for a value known to be of type valueType
// (BAS_NODE_TYPE_UNKNOWN: any): a value of the variable's type is not
// converted again.
void basGenStoreFrom(BasCompilerT *c, const BasSymT *sym, uint8_t valueType) {
bool scalar = !(sym->flags & SF_ARRAY);
uint8_t conv = (scalar && (sym->flags & SF_TYPED) && valueType != sym->dataType) ? basConvOpForStore(sym->dataType) : OP_NOP;
if (scalar && sym->fixedLen > 0) {
basEmit8(&c->cg, OP_STR_FIXLEN);
basEmitU16(&c->cg, (uint16_t)sym->fixedLen);
}
if (scalar && sym->objClass != BAS_CLASS_NONE) {
if (conv != OP_NOP) {
basEmit8(&c->cg, conv);
conv = OP_NOP;
}
basEmit8(&c->cg, OP_OBJ_CHECK);
basEmitU16(&c->cg, objCheckOperand(sym->objClass));
}
basGenStoreSlot(c, basStorageScope(sym), sym->index, conv);
}
void basGenStoreRaw(BasCompilerT *c, const BasSymT *sym) {
basGenStoreSlot(c, basStorageScope(sym), sym->index, OP_NOP);
}
// Stores the value on the stack into slot of scope (BasScopeE) after
// conversion opcode conv (OP_NOP: none). A local or global takes both as
// one instruction (OP_STORE_LOCAL_CONV / OP_STORE_GLOBAL_CONV).
void basGenStoreSlot(BasCompilerT *c, int32_t scope, int32_t slot, uint8_t conv) {
static const uint8_t ops[] = { OP_STORE_GLOBAL, OP_STORE_LOCAL, OP_STORE_FORM_VAR, OP_STORE_MEMBER };
static const uint8_t convOps[] = { OP_STORE_GLOBAL_CONV, OP_STORE_LOCAL_CONV, OP_NOP, OP_NOP };
if (conv != OP_NOP && convOps[scope] != OP_NOP) {
basEmit8(&c->cg, convOps[scope]);
basEmitU16(&c->cg, (uint16_t)slot);
basEmit8(&c->cg, conv);
return;
}
if (conv != OP_NOP) {
basEmit8(&c->cg, conv);
}
basEmit8(&c->cg, ops[scope]);
basEmitU16(&c->cg, (uint16_t)slot);
}
void basGenStoreTemp(BasCompilerT *c, int32_t slot) {
basGenStoreSlot(c, tempScope(c), slot, OP_NOP);
}
// Pushes value for a store where convType is declared (BAS_TYPE_VARIANT:
// none), fixedLen a STRING * n length (0: none) and objClass the class
// the target takes (BAS_CLASS_NONE: any): SET checks it is an object. A
// conversion the value does not need (it has the type already) is left
// out; one of a literal is folded into it. With deferConv the last
// conversion, when nothing follows it, is not emitted but returned for
// the store to take (basGenStoreSlot); otherwise, or when there is none,
// OP_NOP is returned.
uint8_t basGenStoreValue(BasCompilerT *c, const BasNodeT *value, uint8_t convType, int32_t fixedLen, int32_t objClass, bool isSet, bool deferConv) {
uint8_t op = basConvOpForStore(convType);
BasNodeT *folded = (op != OP_NOP && !isSet) ? basFoldConv(c, (BasNodeT *)value, op) : NULL;
if (folded != NULL) {
basGenExpr(c, folded);
op = OP_NOP;
} else {
basGenExpr(c, value);
}
if (isSet) {
basEmit8(&c->cg, OP_OBJ_CHECK);
basEmitU16(&c->cg, BAS_OBJ_CHECK_ANY);
}
if (fixedLen > 0) {
basEmit8(&c->cg, OP_STR_FIXLEN);
basEmitU16(&c->cg, (uint16_t)fixedLen);
}
uint8_t deferred = OP_NOP;
// STRING * n has made the value a string already
if (op != OP_NOP && (basStaticType(value) != convType || isSet) && fixedLen == 0) {
if (deferConv && objClass == BAS_CLASS_NONE) {
deferred = op;
} else {
basEmit8(&c->cg, op);
}
}
if (objClass != BAS_CLASS_NONE) {
basEmit8(&c->cg, OP_OBJ_CHECK);
basEmitU16(&c->cg, objCheckOperand(objClass));
}
return deferred;
}
// A compiler temporary of the current scope: it lives for the statement
// that takes it, so the pool is handed out again from its start by every
// statement.
int32_t basGenTemp(BasCompilerT *c) {
int32_t **pool = c->inProc ? &c->procTempSlots : &c->tempSlots;
if (c->tempUsed < (int32_t)arrlen(*pool)) {
return (*pool)[c->tempUsed++];
}
int32_t slot;
switch (tempScope(c)) {
case SCOPE_LOCAL:
slot = c->nextLocalSlot++;
break;
case SCOPE_MEMBER:
slot = c->nextMemberSlot++;
break;
case SCOPE_FORM:
slot = c->nextFormSlot++;
break;
default:
slot = c->nextGlobalSlot++;
break;
}
arrput(*pool, slot);
c->tempUsed++;
return slot;
}
// Stores the value on the stack in a compiler temporary and pushes a
// reference to it: one value that every procedure given the reference
// shares.
void basGenTempRef(BasCompilerT *c) {
int32_t slot = basGenTemp(c);
basGenStoreTemp(c, slot);
basGenSlotRef(c, tempScope(c), slot, BAS_TYPE_VARIANT);
}
// The module's temporaries change scope (a form or class starts or ends).
void basGenTempReset(BasCompilerT *c) {
arrsetlen(c->tempSlots, 0);
c->tempUsed = 0;
}
// Pushes the layout string of TYPE typeId (BAS_LAYOUT_* in opcodes.h).
bool basGenUdtLayout(BasCompilerT *c, int32_t typeId) {
uint8_t layout[BAS_LAYOUT_MAX_LEN];
int32_t len = 0;
if (!buildLayout(c, typeId, layout, &len, 0)) {
return false;
}
basGenPushStr(c, (const char *)layout, len);
return true;
}
// Pushes what OP_DIM_ARRAY / OP_REDIM need to build TYPE instances: the
// layout, the TYPE id and its field count.
bool basGenUdtSpec(BasCompilerT *c, int32_t typeId) {
if (typeId < 0 || typeId >= (int32_t)arrlen(c->typeDefs)) {
basErrorAt(c, c->lex.token.line, 0, "Unknown TYPE definition");
return false;
}
if (!basGenUdtLayout(c, typeId)) {
return false;
}
basGenPushInt16(c, (int16_t)typeId);
basGenPushInt16(c, (int16_t)c->typeDefs[typeId]->fieldCount);
return true;
}
// The layout of a TYPE: one entry per field in declaration order, nested
// TYPEs inline.
static bool buildLayout(BasCompilerT *c, int32_t typeId, uint8_t *buf, int32_t *len, int32_t depth) {
const BasTypeDefT *td = (typeId >= 0 && typeId < (int32_t)arrlen(c->typeDefs)) ? c->typeDefs[typeId] : NULL;
if (td == NULL) {
basErrorAt(c, c->lex.token.line, 0, "Unknown TYPE definition");
return false;
}
if (depth >= BAS_LAYOUT_MAX_DEPTH) {
basErrorAt(c, c->lex.token.line, 0, "TYPE nesting too deep for GET/PUT");
return false;
}
for (int32_t i = 0; i < td->fieldCount; i++) {
const BasFieldT *f = &td->fields[i];
if (*len + BAS_LAYOUT_MAX_ENTRY_LEN > BAS_LAYOUT_MAX_LEN) {
basErrorAt(c, c->lex.token.line, 0, "TYPE has too many fields");
return false;
}
buf[(*len)++] = f->dataType;
if (f->dataType == BAS_TYPE_STRING) {
basWriteU16LE(&buf[*len], (uint16_t)f->fixedLen);
*len += (int32_t)sizeof(uint16_t);
} else if (f->dataType == BAS_TYPE_UDT) {
const BasTypeDefT *child = (f->udtTypeId >= 0 && f->udtTypeId < (int32_t)arrlen(c->typeDefs)) ? c->typeDefs[f->udtTypeId] : NULL;
if (child == NULL) {
basErrorAt(c, c->lex.token.line, 0, "Unknown TYPE definition");
return false;
}
basWriteU16LE(&buf[*len], (uint16_t)f->udtTypeId);
*len += (int32_t)sizeof(uint16_t);
basWriteU16LE(&buf[*len], (uint16_t)child->fieldCount);
*len += (int32_t)sizeof(uint16_t);
if (!buildLayout(c, f->udtTypeId, buf, len, depth + 1)) {
return false;
}
}
}
return true;
}
// The operand of OP_NEW_OBJ / OP_OBJ_CHECK naming class objClass (a class
// number or BAS_CLASS_COLLECTION).
static uint16_t classOperand(int32_t objClass) {
return (objClass == BAS_CLASS_COLLECTION) ? BAS_NEW_COLLECTION : (uint16_t)objClass;
}
// ENDFORM / ENDCLASS: the set-up block returns, and module code jumps
// over it.
static void closeInitBlock(BasCompilerT *c) {
basGenFlushProcSkip(c);
basEmit8(&c->cg, OP_RET);
basGenPatchHere(c, c->initJmpAddr);
basGenTempReset(c);
c->initJmpAddr = -1;
}
// One DIM / Public / Private / member declarator: what the variable
// starts as. A dynamic array waits for REDIM; integer and floating
// variables start as the slot's 0 (a class member's are set, since a new
// instance's members start Empty).
static void genDeclarator(BasCompilerT *c, const BasDeclT *d) {
const BasSymT *sym = d->sym;
uint8_t dt = sym->dataType;
if (d->withEvents) {
// A form's copy is bound through the form's set-up code (each
// loaded form has its own)
basGenExpr(c, basNodeZero(c, dt, &d->h));
basGenStore(c, sym);
if (c->inForm) {
basEmit8(&c->cg, OP_BIND_EVENTS);
basEmitU16(&c->cg, (uint16_t)d->aux);
}
return;
}
if (d->isDynamic) {
return;
}
if (d->spec != NULL && d->spec->isNew) {
basEmit8(&c->cg, OP_NEW_OBJ);
basEmitU16(&c->cg, classOperand(sym->objClass));
basGenStore(c, sym);
return;
}
if (d->isArray) {
for (const BasNodeT *bn = d->bounds; bn != NULL; bn = bn->next) {
basGenExpr(c, ((const BasBoundT *)bn)->lower);
basGenExpr(c, ((const BasBoundT *)bn)->upper);
}
if (dt == BAS_TYPE_UDT && !basGenUdtSpec(c, sym->udtTypeId)) {
return;
}
basEmit8(&c->cg, OP_DIM_ARRAY);
basEmit8(&c->cg, (uint8_t)basNodeCount(d->bounds));
basEmit8(&c->cg, dt);
basGenStore(c, sym);
return;
}
if (dt == BAS_TYPE_UDT) {
// A TYPE instance: OP_DIM_ARRAY without dimensions
if (!basGenUdtSpec(c, sym->udtTypeId)) {
return;
}
basEmit8(&c->cg, OP_DIM_ARRAY);
basEmit8(&c->cg, 0);
basEmit8(&c->cg, BAS_TYPE_UDT);
basGenStore(c, sym);
return;
}
if (dt == BAS_TYPE_STRING || dt == BAS_TYPE_DATE || dt == BAS_TYPE_VARIANT || dt == BAS_TYPE_OBJECT || sym->scope == SCOPE_MEMBER) {
BasNodeT *zero = basNodeZero(c, dt, &d->h);
basGenExpr(c, zero);
basGenStoreFrom(c, sym, basStaticType(zero));
}
}
// DEF FNname(params) = expression: a FUNCTION of module code.
static void genDefFn(BasCompilerT *c, const BasProcT *fn) {
startProc(c, fn->sym);
basGenExpr(c, fn->body);
basEmit8(&c->cg, OP_RET_VAL);
// A procedure-table entry (in code order) without debug locals
c->debugProcCount++;
}
// DIM: one OP_LINE for the statement, dropped when its declarators need
// no code.
static void genDim(BasCompilerT *c, const BasStmtT *s) {
int32_t start = basCodePos(&c->cg);
basGenLine(c, &s->h);
for (const BasNodeT *d = s->a; d != NULL && !c->hasError; d = d->next) {
genDeclarator(c, (const BasDeclT *)d);
}
if (basCodePos(&c->cg) == start + BAS_LINE_INST_SIZE) {
basCodeGenTruncate(&c->cg, start, c->cg.constCount);
}
}
// SUB / FUNCTION / Property: entry code, body, the return EXITs land on.
static void genProc(BasCompilerT *c, const BasProcT *proc) {
BasSymT *sym = proc->sym;
BasProcInfoT *pi = sym->u.proc;
bool isFunction = (sym->kind == SK_FUNCTION);
startProc(c, sym);
arrsetlen(c->procTempSlots, 0);
c->genSelectDepth = 0;
genProcInits(c, sym);
genStaticAllocs(c);
// Parameters with a default: an omitted argument arrives Missing
int32_t i = 0;
for (const BasNodeT *pn = proc->params; pn != NULL && !c->hasError; pn = pn->next, i++) {
const BasParamT *p = (const BasParamT *)pn;
if (!(pi->paramFlags[i] & PARAM_DEFAULT)) {
continue;
}
basGenLoadVar(c, p->sym);
basEmit8(&c->cg, OP_BUILTIN);
basEmit8(&c->cg, BAS_FN_ISMISSING);
basEmit8(&c->cg, 1);
int32_t skip = basGenJump(c, OP_JMP_FALSE);
basGenExpr(c, basNodeConst(c, &pi->defaults[i], pn));
basGenStore(c, p->sym);
basGenPatchHere(c, skip);
}
basGenBody(c, proc->body);
for (int32_t k = 0; k < (int32_t)arrlen(c->exitProcPatches); k++) {
basGenPatchHere(c, c->exitProcPatches[k]);
}
arrfree(c->exitProcPatches);
c->exitProcPatches = NULL;
if (isFunction) {
basEmit8(&c->cg, OP_LOAD_LOCAL);
basEmitU16(&c->cg, BAS_FUNC_RESULT_SLOT);
basEmit8(&c->cg, OP_RET_VAL);
} else {
basEmit8(&c->cg, OP_RET);
}
// Parameters, locals and the temporaries share the frame
pi->localCount = c->nextLocalSlot;
c->debugProcCount++;
// A label's patch lists live in the heap, its record in the unit arena
for (BasSymT *l = c->localLabels.first; l != NULL; l = l->orderNext) {
arrfree(l->u.label->patches);
arrfree(l->u.label->patchDepths);
arrfree(l->u.label->dataPatches);
}
}
// The locals sym's frame starts with set to their type's zero
// (BasProcInfoT localInits, set by the VM at entry, no code): the
// FUNCTION result (Nothing for an Object, Empty for a Variant), typed
// scalars and implicit STRING locals. A cleared slot is the INTEGER 0.
static void genProcInits(BasCompilerT *c, const BasSymT *sym) {
BasProcInfoT *pi = sym->u.proc;
int32_t count = 0;
BasSlotInitT inits[BAS_VM_MAX_LOCALS];
if (sym->kind == SK_FUNCTION && basStartsTyped(sym->dataType)) {
inits[count].index = BAS_FUNC_RESULT_SLOT;
inits[count].dataType = sym->dataType;
count++;
}
for (const BasSymT *l = c->localTab.first; l != NULL && count < BAS_VM_MAX_LOCALS; l = l->orderNext) {
bool scalar = l->kind == SK_VAR && !(l->flags & (SF_ALIAS | SF_ARRAY | SF_PARAM | SF_HIDDEN)) && l->scope == SCOPE_LOCAL && l->objClass == BAS_CLASS_NONE;
bool typed = (l->flags & SF_TYPED) && l->dataType != BAS_TYPE_STRING && l->dataType != BAS_TYPE_VARIANT && l->dataType != BAS_TYPE_OBJECT;
bool text = (l->flags & SF_IMPLICIT) && l->dataType == BAS_TYPE_STRING;
if (scalar && basStartsTyped(l->dataType) && (typed || text)) {
inits[count].index = l->index;
inits[count].dataType = l->dataType;
count++;
}
}
pi->localInitCount = count;
pi->localInits = NULL;
if (count > 0) {
pi->localInits = (BasSlotInitT *)basArenaAlloc(&c->modArena, (int32_t)(count * (int32_t)sizeof(BasSlotInitT)));
if (pi->localInits == NULL) {
basErrorAt(c, 0, 0, "Out of memory");
return;
}
memcpy(pi->localInits, inits, (size_t)count * sizeof(BasSlotInitT));
}
}
// Pushes what STATIC array or TYPE sym is allocated as: an array of its
// constant bounds (BasStaticAllocT), or a TYPE instance.
static void genStaticAlloc(BasCompilerT *c, const BasSymT *sym) {
const BasStaticAllocT *alloc = sym->u.alloc;
int32_t dims = alloc->dims;
for (int32_t i = 0; i < dims; i++) {
basEmit8(&c->cg, OP_PUSH_INT32);
basEmit32(&c->cg, alloc->lower[i]);
basEmit8(&c->cg, OP_PUSH_INT32);
basEmit32(&c->cg, alloc->upper[i]);
}
if (sym->dataType == BAS_TYPE_UDT && !basGenUdtSpec(c, sym->udtTypeId)) {
return;
}
basEmit8(&c->cg, OP_DIM_ARRAY);
basEmit8(&c->cg, (uint8_t)dims);
basEmit8(&c->cg, sym->dataType);
}
// A procedure's first code: its STATIC arrays and TYPEs (a module or form
// slot) are allocated at the first call -- while the slot still holds a
// cleared slot's INTEGER 0. A class procedure's are allocated with each
// object (ST_ENDCLASS).
static void genStaticAllocs(BasCompilerT *c) {
for (const BasSymT *l = c->localTab.first; l != NULL && !c->hasError; l = l->orderNext) {
if (l->kind != SK_VAR || !(l->flags & SF_ALIAS) || l->aliasScope == SCOPE_MEMBER || l->u.alloc == NULL) {
continue;
}
basGenLoadVar(c, l);
basEmit8(&c->cg, OP_BUILTIN);
basEmit8(&c->cg, BAS_FN_VARTYPE);
basEmit8(&c->cg, 1);
basGenPushInt16(c, BAS_VT_INTEGER);
basEmit8(&c->cg, OP_CMP_EQ);
int32_t skip = basGenJump(c, OP_JMP_FALSE);
genStaticAlloc(c, l);
basGenStoreRaw(c, l);
basGenPatchHere(c, skip);
}
}
// The operand of OP_OBJ_CHECK for a store where objClass is declared
// (BAS_CLASS_NONE: any object).
static uint16_t objCheckOperand(int32_t objClass) {
return (objClass == BAS_CLASS_NONE) ? BAS_OBJ_CHECK_ANY : classOperand(objClass);
}
// BEGINFORM / BEGINCLASS: module code inside a form (a class) runs when
// the form loads (an instance is made), so it goes into a block module
// code jumps over.
static void openInitBlock(BasCompilerT *c) {
basGenFlushProcSkip(c);
basGenTempReset(c);
c->initJmpAddr = basGenJump(c, OP_JMP);
c->initCodeStart = basCodePos(&c->cg);
}
// A procedure's code starts here: module code jumps over procedures (one
// jump for a run of them), and the calls made before the body exist get
// its address.
static void startProc(BasCompilerT *c, BasSymT *sym) {
BasProcInfoT *pi = sym->u.proc;
if (c->procSkipJump < 0) {
c->procSkipJump = basGenJump(c, OP_JMP);
}
pi->codeAddr = basCodePos(&c->cg);
pi->hasCode = true;
for (int32_t i = 0; i < (int32_t)arrlen(pi->patches); i++) {
basWriteI32LE(&c->cg.code[pi->patches[i]], pi->codeAddr);
}
arrfree(pi->patches);
pi->patches = NULL;
}
// Scope of the slots compiler temporaries take.
static uint8_t tempScope(const BasCompilerT *c) {
if (c->inProc) {
return SCOPE_LOCAL;
}
if (c->inClass) {
return SCOPE_MEMBER;
}
return c->inForm ? SCOPE_FORM : SCOPE_GLOBAL;
}

448
src/apps/kpunch/dvxbasic/compiler/genExpr.c Normal file
View file

@ -0,0 +1,448 @@
// 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.
// genExpr.c -- DVX BASIC generator: expressions and references
#include "front.h"
#include "thirdparty/stb_ds_wrap.h"
// Function prototypes (alphabetical)
uint8_t basBinaryOpcode(uint8_t tok);
void basGenArgs(BasCompilerT *c, const BasNodeT *list);
void basGenExpr(BasCompilerT *c, const BasNodeT *n);
void basGenObjMember(BasCompilerT *c, uint8_t op, const BasCallT *call);
void basGenRef(BasCompilerT *c, const BasNodeT *n);
static uint8_t nullGuardMask(const BasNodeT *args, uint8_t mask);
// The VM opcode of a binary operator token.
uint8_t basBinaryOpcode(uint8_t tok) {
switch (tok) {
case TOK_PLUS: return OP_ADD_INT;
case TOK_MINUS: return OP_SUB_INT;
case TOK_STAR: return OP_MUL_INT;
case TOK_SLASH: return OP_DIV_FLT;
case TOK_BACKSLASH: return OP_IDIV_INT;
case TOK_MOD: return OP_MOD_INT;
case TOK_CARET: return OP_POW;
case TOK_AMPERSAND: return OP_STR_CONCAT;
case TOK_EQ: return OP_CMP_EQ;
case TOK_NE: return OP_CMP_NE;
case TOK_LT: return OP_CMP_LT;
case TOK_GT: return OP_CMP_GT;
case TOK_LE: return OP_CMP_LE;
case TOK_GE: return OP_CMP_GE;
case TOK_IS: return OP_IS;
case TOK_AND: return OP_AND;
case TOK_OR: return OP_OR;
case TOK_XOR: return OP_XOR;
case TOK_EQV: return OP_EQV;
default: return OP_IMP;
}
}
// Pushes call arguments in order (a reference for an NK_REF).
void basGenArgs(BasCompilerT *c, const BasNodeT *list) {
for (const BasNodeT *a = list; a != NULL; a = a->next) {
basGenExpr(c, a);
}
}
// Pushes the value of expression n.
void basGenExpr(BasCompilerT *c, const BasNodeT *n) {
if (n == NULL || c->hasError) {
return;
}
switch (n->kind) {
case NK_INT: {
const BasLitT *lit = (const BasLitT *)n;
if (n->type == BAS_TYPE_LONG) {
basEmit8(&c->cg, OP_PUSH_INT32);
basEmit32(&c->cg, lit->ival);
} else {
basGenPushInt16(c, (int16_t)lit->ival);
}
// A BYTE literal (a folded value or constant) is the INTEGER
// made a BYTE
if (n->type == BAS_TYPE_BYTE) {
basEmit8(&c->cg, OP_CONV_BYTE);
}
break;
}
case NK_DBL: {
const BasLitT *lit = (const BasLitT *)n;
if (n->type == BAS_TYPE_CURRENCY) {
basEmit8(&c->cg, OP_PUSH_CUR);
basEmitI64(&c->cg, lit->cval);
break;
}
basEmit8(&c->cg, OP_PUSH_FLT64);
basEmitDouble(&c->cg, lit->dval);
if (n->type == BAS_TYPE_SINGLE) {
basEmit8(&c->cg, OP_CONV_INT_FLT);
} else if (n->type == BAS_TYPE_DATE) {
basEmit8(&c->cg, OP_CONV_DATE);
}
break;
}
case NK_STR: {
const BasLitT *lit = (const BasLitT *)n;
basGenPushStr(c, lit->str, lit->slen);
break;
}
case NK_BOOL:
basEmit8(&c->cg, ((const BasLitT *)n)->ival ? OP_PUSH_TRUE : OP_PUSH_FALSE);
break;
case NK_SPECIAL:
basGenPushSpecial(c, (uint8_t)((const BasLitT *)n)->ival);
break;
case NK_VAR:
basGenLoadVar(c, ((const BasNameT *)n)->sym);
break;
case NK_RESULT:
basEmit8(&c->cg, OP_LOAD_LOCAL);
basEmitU16(&c->cg, BAS_FUNC_RESULT_SLOT);
break;
case NK_ME:
basEmit8(&c->cg, (uint8_t)((const BasNameT *)n)->aux);
break;
case NK_LOADFORM:
basGenPushCStr(c, ((const BasNameT *)n)->name);
basEmit8(&c->cg, OP_LOAD_FORM);
break;
case NK_NEW:
basEmit8(&c->cg, OP_NEW_OBJ);
basEmitU16(&c->cg, (uint16_t)((const BasNameT *)n)->aux);
break;
case NK_ELEM:
case NK_INDEX: {
const BasCallT *call = (const BasCallT *)n;
basGenExpr(c, call->callee);
basGenArgs(c, call->args);
basEmit8(&c->cg, OP_LOAD_ARRAY);
basEmit8(&c->cg, (uint8_t)call->argc);
break;
}
case NK_FIELD: {
const BasMemberT *m = (const BasMemberT *)n;
basGenExpr(c, m->base);
basEmit8(&c->cg, OP_LOAD_FIELD);
basEmitU16(&c->cg, (uint16_t)m->aux);
break;
}
case NK_FCALL: {
const BasCallT *call = (const BasCallT *)n;
basGenArgs(c, call->args);
basGenCall(c, (BasSymT *)call->target, call->argc);
break;
}
case NK_BUILTIN: {
const BasCallT *call = (const BasCallT *)n;
const BasBuiltinT *b = (const BasBuiltinT *)call->target;
basGenArgs(c, call->args);
// A Variant form given something that may be Null: OP_NULL_PROP
// gives Null and skips the function
uint8_t guard = nullGuardMask(call->args, b->nullMask);
if (guard != 0) {
basEmit8(&c->cg, OP_NULL_PROP);
basEmit8(&c->cg, (uint8_t)call->argc);
basEmit8(&c->cg, guard);
}
basEmit8(&c->cg, (uint8_t)call->aux);
if (call->aux == OP_BUILTIN) {
basEmit8(&c->cg, b->func);
basEmit8(&c->cg, (uint8_t)call->argc);
}
break;
}
case NK_INTRINSIC: {
const BasCallT *call = (const BasCallT *)n;
basGenArgs(c, call->args);
basEmit8(&c->cg, (uint8_t)call->aux);
if (call->aux2 != BAS_NO_OPERAND) {
basEmit8(&c->cg, (uint8_t)call->aux2);
}
break;
}
case NK_METHOD: {
const BasCallT *call = (const BasCallT *)n;
// The names of arguments given by name follow them (basLateArgs)
basGenExpr(c, call->callee);
basGenPushCStr(c, (const char *)call->target);
basGenArgs(c, call->args);
basEmit8(&c->cg, (call->aux2 > 0) ? OP_CALL_NAMED : OP_CALL_METHOD);
basEmit8(&c->cg, (uint8_t)call->argc);
if (call->aux2 > 0) {
basEmit8(&c->cg, (uint8_t)call->aux2);
}
break;
}
case NK_PROP: {
const BasMemberT *m = (const BasMemberT *)n;
basGenExpr(c, m->base);
basGenPushCStr(c, m->name);
basEmit8(&c->cg, OP_LOAD_PROP);
break;
}
case NK_OBJMEMBER: {
const BasCallT *call = (const BasCallT *)n;
basGenExpr(c, call->callee);
basGenArgs(c, call->args);
basGenObjMember(c, (n->flags & NF_STATEMENT) ? OP_OBJ_CALL : OP_OBJ_GET, call);
break;
}
case NK_FINDCTRL: {
const BasMemberT *m = (const BasMemberT *)n;
if (m->base != NULL) {
basGenExpr(c, m->base);
} else {
// NULL form reference: the current form
basGenPushInt16(c, 0);
}
basGenPushCStr(c, m->name);
basEmit8(&c->cg, OP_FIND_CTRL);
break;
}
case NK_FINDCTRLIDX: {
const BasCallT *call = (const BasCallT *)n;
if (call->callee != NULL) {
basGenExpr(c, call->callee);
} else {
basGenPushInt16(c, 0);
}
basGenPushCStr(c, (const char *)call->target);
basGenExpr(c, call->args);
basEmit8(&c->cg, OP_FIND_CTRL_IDX);
break;
}
case NK_TYPEOF: {
const BasMemberT *t = (const BasMemberT *)n;
basGenExpr(c, t->base);
basGenPushCStr(c, t->name);
basEmit8(&c->cg, OP_BUILTIN);
basEmit8(&c->cg, BAS_FN_TYPEOF);
basEmit8(&c->cg, BAS_TYPEOF_ARGS);
break;
}
case NK_UNARY: {
const BasOpT *op = (const BasOpT *)n;
basGenExpr(c, op->a);
basEmit8(&c->cg, (op->op == TOK_MINUS) ? OP_NEG_INT : OP_NOT);
break;
}
case NK_BINARY: {
const BasOpT *op = (const BasOpT *)n;
uint8_t opcode = basBinaryOpcode(op->op);
uint8_t k16 = basK16Pair(opcode, true);
basGenExpr(c, op->a);
// An INTEGER literal right operand goes into the instruction
if (k16 != OP_NOP && op->b->kind == NK_INT && op->b->type == BAS_TYPE_INTEGER) {
basEmit8(&c->cg, k16);
basEmit16(&c->cg, (int16_t)((const BasLitT *)op->b)->ival);
break;
}
basGenExpr(c, op->b);
basEmit8(&c->cg, opcode);
break;
}
case NK_CONV: {
const BasOpT *op = (const BasOpT *)n;
basGenExpr(c, op->a);
basEmit8(&c->cg, op->op);
if (op->op == OP_STR_FIXLEN || op->op == OP_OBJ_CHECK) {
basEmitU16(&c->cg, (uint16_t)op->aux);
}
break;
}
case NK_REF:
basGenRef(c, ((const BasOpT *)n)->a);
break;
case NK_PARAMARRAY: {
const BasCallT *pack = (const BasCallT *)n;
basGenPushInt16(c, (int16_t)pack->aux);
basGenArgs(c, pack->args);
basEmit8(&c->cg, OP_BUILTIN);
basEmit8(&c->cg, BAS_FN_PARAMARRAY);
basEmit8(&c->cg, (uint8_t)(pack->argc + 1));
break;
}
default:
basErrorNode(c, n, "Internal error: expression kind %d", (int)n->kind);
break;
}
}
// An early-bound member instruction op for call (its object, arguments
// and, a put, the value pushed): the class and member operands (a class
// member's index is filled in when every class is compiled) and the
// argument count.
void basGenObjMember(BasCompilerT *c, uint8_t op, const BasCallT *call) {
basEmit8(&c->cg, op);
basEmitU16(&c->cg, (uint16_t)call->aux);
if (call->target != NULL) {
BasMemberPatchT patch;
patch.pos = basCodePos(&c->cg);
patch.classIdx = call->aux;
patch.sym = (const BasSymT *)call->target;
arrput(c->memberPatches, patch);
}
basEmitU16(&c->cg, (uint16_t)call->aux2);
basEmit8(&c->cg, (uint8_t)call->argc);
}
// Pushes a reference to what n names (a ByRef argument): a variable or
// whole array, an element (of an array, or of what a Variant holds; an
// object's default member gives its value), a TYPE field (one
// OP_PUSH_FIELD_ADDR per field of the chain). Stores through it convert
// to the target's declared type and keep a STRING * n's length.
void basGenRef(BasCompilerT *c, const BasNodeT *n) {
switch (n->kind) {
case NK_VAR:
basGenAddrOf(c, ((const BasNameT *)n)->sym);
break;
case NK_ELEM: {
const BasCallT *call = (const BasCallT *)n;
const BasSymT *sym = ((const BasNameT *)call->callee)->sym;
basGenLoadVar(c, sym);
basGenArgs(c, call->args);
basEmit8(&c->cg, OP_PUSH_ARR_ADDR);
basEmit8(&c->cg, (uint8_t)call->argc);
basEmit8(&c->cg, (sym->flags & SF_ARRAY) ? basDeclaredStoreType(sym) : BAS_TYPE_VARIANT);
break;
}
case NK_FIELD: {
const BasMemberT *m = (const BasMemberT *)n;
const BasFieldT *f = (const BasFieldT *)m->target;
basGenRef(c, m->base);
basEmit8(&c->cg, OP_PUSH_FIELD_ADDR);
basEmitU16(&c->cg, (uint16_t)m->aux);
basEmit8(&c->cg, f->dataType);
if (f->fixedLen > 0) {
basEmit8(&c->cg, OP_REF_FIXLEN);
basEmitU16(&c->cg, (uint16_t)f->fixedLen);
}
break;
}
default:
basErrorNode(c, n, "Internal error: reference kind %d", (int)n->kind);
break;
}
}
// The arguments of mask (a built-in's nullMask) that may be Null when the
// program runs: those whose type is not known statically.
static uint8_t nullGuardMask(const BasNodeT *args, uint8_t mask) {
uint8_t guard = 0;
uint8_t bit = BAS_NULL_ARG_1;
for (const BasNodeT *a = args; a != NULL && bit != 0; a = a->next) {
if ((mask & bit) && basStaticType(a) == BAS_NODE_TYPE_UNKNOWN) {
guard |= bit;
}
bit = (uint8_t)(bit << 1);
}
return guard;
}

1652
src/apps/kpunch/dvxbasic/compiler/genStmt.c Normal file
View file

File diff suppressed because it is too large Load diff

168
src/apps/kpunch/dvxbasic/compiler/lexer.c
View file

@ -28,9 +28,11 @@
// are handled transparently.
#include "lexer.h"
#include "basDateLit.h"
#include "opcodes.h"
#include "dvxTypes.h"
#include "../runtime/dates.h"
#include "../runtime/values.h"
#include <ctype.h>
#include <errno.h>
@ -63,11 +65,6 @@ static const KeywordEntryT sKeywords[] = {
#define LEX_BIN_BITS 1
#define LEX_HEX_BITS 4
// Date literals: the characters allowed between the '#'s besides letters
// and digits, and those that mark the text as a date or time.
#define LEX_DATE_LITERAL_CHARS " /-:,"
#define LEX_DATE_SEPARATORS "/-:"
// First value of the hex letter digits A-F.
#define LEX_HEX_LETTER_BASE 10
@ -95,6 +92,7 @@ static const TypeSuffixEntryT sTypeSuffixes[] = {
{ '!', BAS_TYPE_SINGLE },
{ '#', BAS_TYPE_DOUBLE },
{ '$', BAS_TYPE_STRING },
{ '@', BAS_TYPE_CURRENCY },
};
#define TYPE_SUFFIX_COUNT DVX_ARRAY_LEN(sTypeSuffixes)
@ -108,11 +106,15 @@ char basAsciiUpper(char c);
bool basIsIdentChar(char c);
bool basIsTypeSuffixChar(char c);
bool basIsValidIdent(const char *name);
int32_t basLexerDateLiteralLen(const char *s, int32_t len, double *outSerial);
void basLexerInit(BasLexerT *lex, const char *source, int32_t sourceLen);
const char *basLexerKeywordAt(int32_t i);
BasKeywordClassE basLexerKeywordClass(int32_t i);
int32_t basLexerKeywordCount(void);
bool basLexerKeywordReserved(int32_t i);
BasTokenTypeE basLexerNext(BasLexerT *lex);
BasTokenTypeE basLexerSeek(BasLexerT *lex, int32_t pos, int32_t line, int32_t col);
void basLexerSkipStatement(BasLexerT *lex);
bool basRoundHalfEven(double v, int64_t *out);
bool basTokenIsWord(const BasTokenT *tok);
const char *basTokenName(BasTokenTypeE type);
@ -204,6 +206,22 @@ bool basIsValidIdent(const char *name) {
}
int32_t basLexerDateLiteralLen(const char *s, int32_t len, double *outSerial) {
int32_t litLen = basDateLiteralShapeLen(s, len);
if (litLen == 0) {
return 0;
}
int32_t textLen = litLen - BAS_DATE_DELIMITERS;
char text[BAS_DATE_TEXT_MAX + 1];
memcpy(text, s + 1, textLen);
text[textLen] = '\0';
return basDateParse(text, outSerial) ? litLen : 0;
}
void basLexerInit(BasLexerT *lex, const char *source, int32_t sourceLen) {
memset(lex, 0, sizeof(*lex));
lex->source = source;
@ -240,6 +258,11 @@ int32_t basLexerKeywordCount(void) {
}
bool basLexerKeywordReserved(int32_t i) {
return i >= 0 && i < KEYWORD_COUNT && sKeywords[i].type != TOK_IDENT;
}
BasTokenTypeE basLexerNext(BasLexerT *lex) {
skipWhitespace(lex);
@ -364,7 +387,14 @@ BasTokenTypeE basLexerNext(BasLexerT *lex) {
break;
case ':':
// := names the parameter an argument is for (f a, Name:=v)
if (!atEnd(lex) && peek(lex) == '=') {
advance(lex);
lex->token.type = TOK_COLONEQ;
} else {
lex->token.type = TOK_COLON;
}
break;
case '.':
@ -427,6 +457,59 @@ BasTokenTypeE basLexerNext(BasLexerT *lex) {
}
BasTokenTypeE basLexerSeek(BasLexerT *lex, int32_t pos, int32_t line, int32_t col) {
lex->pos = pos;
lex->line = line;
lex->col = col;
return basLexerNext(lex);
}
void basLexerSkipStatement(BasLexerT *lex) {
const char *src = lex->source;
while (!atEnd(lex)) {
char c = src[lex->pos];
if (c == '\n' || c == '\r' || c == ':') {
return;
}
// A comment runs to the end of the line
if (c == '\'') {
skipLineComment(lex);
return;
}
// A line continuation joins the next line
if (c == '_') {
int32_t before = lex->pos;
skipWhitespace(lex);
if (lex->pos != before) {
continue;
}
}
// A string literal ends at its closing quote (or the line)
bool inString = (c == '"');
int32_t pos = lex->pos + 1;
while (inString && pos < lex->sourceLen && src[pos] != '"' && src[pos] != '\n' && src[pos] != '\r') {
pos++;
}
if (inString && pos < lex->sourceLen && src[pos] == '"') {
pos++;
}
lex->col += pos - lex->pos;
lex->pos = pos;
}
}
bool basRoundHalfEven(double v, int64_t *out) {
if (!(v > -LEX_ROUND_LIMIT && v < LEX_ROUND_LIMIT)) {
return false;
@ -655,10 +738,17 @@ static void setError(BasLexerT *lex, const char *msg) {
}
// Moves to the end of the line (the newline is left for the next token):
// no line ends in between, so the column just moves on.
static void skipLineComment(BasLexerT *lex) {
while (!atEnd(lex) && peek(lex) != '\n' && peek(lex) != '\r') {
advance(lex);
int32_t pos = lex->pos;
while (pos < lex->sourceLen && lex->source[pos] != '\n' && lex->source[pos] != '\r') {
pos++;
}
lex->col += pos - lex->pos;
lex->pos = pos;
}
@ -710,49 +800,28 @@ static void skipWhitespace(BasLexerT *lex) {
}
// A date literal at the current '#': the text up to the closing '#' on
// the same line must read as a date (see basDateParse) and hold a date
// or time separator or a word, so file numbers such as CLOSE #1, 2, #3
// never read as one. On success the literal is consumed, the token text
// holds what was between the '#'s and dblVal the serial; otherwise
// nothing is consumed.
// A date literal at the current '#' (basLexerDateLiteralLen): consumed,
// the token text holding what was between the '#'s and dblVal the serial.
// Otherwise nothing is consumed.
static bool tokenizeDateLiteral(BasLexerT *lex) {
int32_t end = lex->pos + 1;
bool hasSeparator = false;
while (end < lex->sourceLen && lex->source[end] != '#') {
char c = lex->source[end];
if (c == '\0' || end - lex->pos > BAS_MAX_STRING_LEN || !(isalnum((unsigned char)c) || strchr(LEX_DATE_LITERAL_CHARS, c) != NULL)) {
return false;
}
hasSeparator = hasSeparator || isalpha((unsigned char)c) || strchr(LEX_DATE_SEPARATORS, c) != NULL;
end++;
}
int32_t len = end - lex->pos - 1;
char text[BAS_MAX_TOKEN_LEN];
double serial;
int32_t litLen = basLexerDateLiteralLen(lex->source + lex->pos, lex->sourceLen - lex->pos, &serial);
if (end >= lex->sourceLen || !hasSeparator) {
if (litLen == 0) {
return false;
}
memcpy(text, lex->source + lex->pos + 1, len);
text[len] = '\0';
int32_t textLen = litLen - BAS_DATE_DELIMITERS;
if (!basDateParse(text, &serial)) {
return false;
}
memcpy(lex->token.text, lex->source + lex->pos + 1, textLen);
lex->token.text[textLen] = '\0';
lex->token.textLen = textLen;
lex->token.dblVal = serial;
while (lex->pos <= end) {
for (int32_t i = 0; i < litLen; i++) {
advance(lex);
}
memcpy(lex->token.text, text, len + 1);
lex->token.textLen = len;
lex->token.dblVal = serial;
return true;
}
@ -987,6 +1056,27 @@ static BasTokenTypeE tokenizeNumber(BasLexerT *lex) {
lex->token.dblVal = atof(lex->token.text);
return TOK_FLOAT_LIT;
}
if (c == '@') {
advance(lex);
// The digits exactly; an exponent goes through a DOUBLE
bool fits = true;
if (!basParseCurrency(lex->token.text, &val, &fits)) {
BasValueT d = basValDouble(atof(lex->token.text));
fits = basValToCurrency(d, &val);
}
if (!fits) {
setError(lex, "Overflow: CURRENCY literal out of range");
return TOK_ERROR;
}
lex->token.longVal = val;
return TOK_CUR_LIT;
}
}
// No suffix: determine type from content

29
src/apps/kpunch/dvxbasic/compiler/lexer.h
View file

@ -47,6 +47,7 @@ typedef enum {
TOK_FLOAT_LIT, // float literal (3.14, 1.5E10)
TOK_STRING_LIT, // "string literal"
TOK_DATE_LIT, // #1/2/2000# date literal (dblVal holds the serial)
TOK_CUR_LIT, // currency literal (1.5@; longVal holds the amount times BAS_CURRENCY_SCALE)
// Identifiers and symbols
TOK_IDENT, // variable/function name
@ -54,6 +55,7 @@ typedef enum {
TOK_COMMA, // ,
TOK_SEMICOLON, // ;
TOK_COLON, // :
TOK_COLONEQ, // := (a named argument)
TOK_LPAREN, // (
TOK_RPAREN, // )
TOK_HASH, // # (file channel)
@ -91,6 +93,8 @@ typedef enum {
TOK_DATA,
TOK_DECLARE,
TOK_DEF,
TOK_DEFBYTE,
TOK_DEFCUR,
TOK_DEFDBL,
TOK_DEFINT,
TOK_DEFLNG,
@ -127,6 +131,7 @@ typedef enum {
TOK_IS,
TOK_LBOUND,
TOK_LET,
TOK_LIKE,
TOK_LINE,
TOK_LOAD,
TOK_LONG,
@ -275,6 +280,16 @@ typedef struct {
// API
// ============================================================
// The length of the date literal at s (s[0] is '#', len bytes readable),
// both '#'s counted, or 0 when there is none: text of a date literal's
// shape (basDateLiteralShapeLen in basDateLit.h: a date or time separator
// or a word, so file numbers such as CLOSE #1, 2, #3 never read as one)
// that also reads as a date (see basDateParse). *outSerial gets the
// date. The lexer's rule, shared with the IDE's syntax colouring; the
// TextArea widget's colorizer, which cannot link the date parser, uses
// the shape alone.
int32_t basLexerDateLiteralLen(const char *s, int32_t len, double *outSerial);
// Initialize lexer with source text. The source must remain valid
// for the lifetime of the lexer.
void basLexerInit(BasLexerT *lex, const char *source, int32_t sourceLen);
@ -283,6 +298,15 @@ void basLexerInit(BasLexerT *lex, const char *source, int32_t sourceLen);
// The token is available in lex->token.
BasTokenTypeE basLexerNext(BasLexerT *lex);
// Continue lexing at source offset pos (line / col its position, as an
// earlier token recorded them) and read the token there.
BasTokenTypeE basLexerSeek(BasLexerT *lex, int32_t pos, int32_t line, int32_t col);
// Skims the rest of the current statement without making tokens: up to
// the next newline or ':' outside string literals and comments (line
// continuations followed). The next basLexerNext reads that separator.
void basLexerSkipStatement(BasLexerT *lex);
// Return human-readable name for a token type.
const char *basTokenName(BasTokenTypeE type);
@ -334,4 +358,9 @@ const char *basLexerKeywordAt(int32_t i);
// Classify the keyword at index i.
BasKeywordClassE basLexerKeywordClass(int32_t i);
// True when keyword i is reserved; false for the color-only entries
// (TOK_IDENT: built-in type names, Empty, the graphics statements ...),
// which a program may also use as its own names.
bool basLexerKeywordReserved(int32_t i);
#endif // DVXBASIC_LEXER_H

447
src/apps/kpunch/dvxbasic/compiler/opcodes.h
View file

@ -29,7 +29,9 @@
#define DVXBASIC_OPCODES_H
#include <stdbool.h>
#include <stddef.h>
#include <stdint.h>
#include <strings.h>
// ============================================================
// Variable scope tags
@ -73,13 +75,22 @@ typedef enum {
#define BAS_TYPE_ARRAY 6 // ref-counted array
#define BAS_TYPE_UDT 7 // ref-counted user-defined type
#define BAS_TYPE_OBJECT 8 // opaque host object (form, control, etc.)
#define BAS_TYPE_REF 9 // ByRef pointer to a BasValueT slot
#define BAS_TYPE_ELEM_REF 10 // ByRef array element: counted BasArrayT* + flat index
#define BAS_TYPE_REF 9 // a reference (ByRef argument): the variable, element or field it names (values.h)
#define BAS_TYPE_BYTE 10 // 8-bit unsigned (0 .. 255), held in intVal
#define BAS_TYPE_DATE 11 // Double serial date (dates.h), held in dblVal
#define BAS_TYPE_EMPTY 12 // Variant that holds nothing yet (Empty)
#define BAS_TYPE_NULL 13 // Variant Null (no valid data)
#define BAS_TYPE_INSTANCE 14 // ref-counted class instance or Collection (BasObjectT)
#define BAS_TYPE_VARIANT 15 // declared type only (AS VARIANT, array element type): holds any value, never a value's tag
#define BAS_TYPE_MISSING 16 // an omitted Optional Variant argument (IsMissing is True; any other use raises error 448)
#define BAS_TYPE_CURRENCY 17 // 64-bit integer scaled by BAS_CURRENCY_SCALE (4 decimal places), held in curVal
#define BAS_TYPE_LAST BAS_TYPE_CURRENCY
// A Currency value is its amount times this (VB: four decimal places)
#define BAS_CURRENCY_SCALE 10000
// The highest QBasic line number (a label 0 .. this; ERL reports it)
#define BAS_LINE_NUMBER_MAX 65529
// ============================================================
// Stack operations
@ -96,6 +107,10 @@ typedef enum {
#define OP_POP 0x08 // discard top of stack
#define OP_DUP 0x09 // duplicate top of stack
#define OP_STMT 0x0A // statement boundary without a line number (release builds that keep ON ERROR/RESUME semantics)
#define OP_PUSH_CUR 0x0E // [int64] push a Currency (the amount times BAS_CURRENCY_SCALE)
#define OP_STORE_LOCAL_CONV 0x0B // [uint16 idx] [uint8 conv] the conversion opcode conv (OP_CONV_*) on the value, then OP_STORE_LOCAL idx
#define OP_STORE_GLOBAL_CONV 0x0C // [uint16 idx] [uint8 conv] the conversion opcode conv on the value, then OP_STORE_GLOBAL idx
#define OP_NULL_PROP 0x0D // [uint8 argc] [uint8 mask] when one of the top argc values whose bit is set in mask (bit 0: the first argument) is Null, they are all dropped, Null is pushed and the next instruction (the function) is skipped: VB's Variant string functions (Left, Mid, UCase ...)
// ============================================================
// Variable access
@ -109,12 +124,14 @@ typedef enum {
#define OP_STORE_ARRAY 0x17 // [uint8 dims] value, indices, array ref on stack
#define OP_LOAD_FIELD 0x18 // [uint16 fieldIdx] load UDT field
#define OP_STORE_FIELD 0x19 // [uint16 fieldIdx] store UDT field
#define OP_PUSH_LOCAL_ADDR 0x1A // [uint16 idx] push address of local (for ByRef)
#define OP_PUSH_GLOBAL_ADDR 0x1B // [uint16 idx] push address of global (for ByRef)
#define OP_PUSH_LOCAL_ADDR 0x1A // [uint16 idx] [uint8 type] push a reference to local idx (a local holding a reference passes it on); type = the declared type stores through it convert to (BAS_TYPE_VARIANT: none)
#define OP_PUSH_GLOBAL_ADDR 0x1B // [uint16 idx] [uint8 type] push a reference to global idx
#define OP_STORE_ARRAY_FIELD 0x1C // [uint8 dims, uint16 fieldIdx] value, indices, array on stack
#define OP_LOAD_MEMBER 0x14 // [uint16 idx] push member variable idx of the running procedure's Me
#define OP_STORE_MEMBER 0x15 // [uint16 idx] pop to member variable idx of Me
#define OP_PUSH_MEMBER_ADDR 0x1D // [uint16 idx] push address of member variable idx of Me (for ByRef)
#define OP_PUSH_MEMBER_ADDR 0x1D // [uint16 idx] [uint8 type] push a reference to member variable idx of Me
#define OP_PUSH_FIELD_ADDR 0x1E // [uint16 fieldIdx] [uint8 type] pop a TYPE instance or a reference to one, push a reference to its field
#define OP_REF_FIXLEN 0x1F // [uint16 len] the reference on top of the stack names a STRING * len: stores through it are padded / cut to len
// ============================================================
// Arithmetic (integer)
@ -127,6 +144,14 @@ typedef enum {
#define OP_MOD_INT 0x24
#define OP_NEG_INT 0x25
// The operator with an INTEGER literal as its right operand: [int16 k]
// does what OP_PUSH_INT16 k followed by the operator does.
#define OP_ADD_K16 0x26
#define OP_SUB_K16 0x27
#define OP_MUL_K16 0x28
#define OP_IDIV_K16 0x2A
#define OP_MOD_K16 0x2C
// ============================================================
// Arithmetic (float)
// ============================================================
@ -183,18 +208,43 @@ typedef enum {
// Control flow
// ============================================================
#define OP_JMP 0x50 // [int16 offset] unconditional jump
#define OP_JMP_TRUE 0x51 // [int16 offset] jump if TOS is true
#define OP_JMP_FALSE 0x52 // [int16 offset] jump if TOS is false
#define OP_CALL 0x53 // [uint16 addr] [uint8 argc] [uint8 baseSlot]
#define OP_JMP 0x50 // [int32 offset] unconditional jump (offset from the end of the instruction)
#define OP_JMP_TRUE 0x51 // [int32 offset] jump if TOS is true
#define OP_JMP_FALSE 0x52 // [int32 offset] jump if TOS is false
#define OP_CALL 0x53 // [int32 addr] [uint8 argc] [uint8 baseSlot]
#define OP_GOSUB_RET 0x54 // pop the current frame's latest GOSUB return address and jump there (error 3 if none)
#define OP_RET 0x55 // return from subroutine
#define OP_RET_VAL 0x56 // return from function (value on stack)
#define OP_FOR_INIT 0x57 // [uint16 varIdx] [uint8 scope] [int16 skipOffset] init FOR, skip body if range empty
#define OP_FOR_NEXT 0x58 // [uint16 varIdx] [uint8 scope] [int16 loopTop]
#define OP_FOR_INIT 0x57 // [uint16 varIdx] [uint8 scope] [int32 skipOffset] init FOR, skip body if range empty
#define OP_FOR_NEXT 0x58 // [uint16 varIdx] [uint8 scope] [int32 loopTop]
#define OP_FOR_POP 0x59 // pop top FOR stack entry (for EXIT FOR)
#define OP_GOSUB 0x5A // [int16 offset] push the next instruction's address on the GOSUB stack, jump
#define OP_CALL_ME 0x5B // [uint16 addr] [uint8 argc] [uint8 baseSlot] OP_CALL whose callee keeps the caller's Me (a class calling its own procedure)
#define OP_GOSUB 0x5A // [int32 offset] push the next instruction's address on the GOSUB stack, jump
#define OP_CALL_ME 0x5B // [int32 addr] [uint8 argc] [uint8 baseSlot] OP_CALL whose callee keeps the caller's Me (a class calling its own procedure)
#define OP_RAISE_EVENT 0x5C // [uint16 event] [uint8 argc] args on stack: call the handlers of event (index in Me's class) of every WithEvents variable holding Me
#define OP_BIND_EVENTS 0x5D // [uint16 binding] a form's WithEvents variable (module withEvents table) is in the current form's variables: remember them
// ============================================================
// Early-bound object members
// ============================================================
//
// A member of an object whose class the compiler knew (a variable,
// parameter, result or member declared As a class or As Collection, New,
// Me): [uint16 class] [uint16 member] [uint8 argc], class a class number
// (member: an index into its public members) or BAS_NEW_COLLECTION
// (member: a BasCollMemberE). The arguments were bound to the member's
// parameters by the compiler as for a SUB / FUNCTION call. An object of
// that class takes the member at once; one of a class that Implements it
// the member its interface map names; anything else (an object that got
// into a variable of the class some other way, a form or control) is
// reached by the member's name, as late binding would.
//
// OP_OBJ_GET: ... object [args] -> ... value a variable (args index it), Function or Property Get
// OP_OBJ_PUT: ... object [args] value -> ... a variable (args index it), Property Let or Set
// OP_OBJ_CALL: ... object [args] -> ... a Sub or Function called as a statement (a result is dropped)
#define OP_OBJ_CALL 0x4E
#define OP_OBJ_GET 0x5E
#define OP_OBJ_PUT 0x5F
// ============================================================
// Type conversion
@ -203,7 +253,8 @@ typedef enum {
#define OP_CONV_INT_FLT 0x60 // int -> float
#define OP_CONV_FLT_INT 0x61 // float -> int (banker's rounding)
#define OP_CONV_INT_STR 0x62 // int -> string
#define OP_CONV_STR_INT 0x63 // string -> int (VAL)
#define OP_CONV_BYTE 0x63 // any -> BYTE (CBYTE; rounded, 0 .. 255 or Overflow)
#define OP_CONV_CUR 0x64 // any -> CURRENCY (CCUR; rounded to 4 decimal places, Overflow past the range)
#define OP_CONV_STR_FLT 0x65 // any -> double (VAL, CDBL)
#define OP_CONV_INT_LONG 0x66 // int16 -> int32
#define OP_CONV_DATE 0x67 // any -> DATE (CDATE; a string is parsed as a date)
@ -219,7 +270,7 @@ typedef enum {
#define OP_INPUT 0x74 // read line into string on stack
#define OP_FILE_OPEN 0x75 // [uint8 mode] filename, channel#, record length on stack
#define OP_FILE_CLOSE 0x76 // channel# on stack
#define OP_FILE_PRINT 0x77 // channel#, value on stack
#define OP_ON_ERROR_NEXT 0x77 // ON ERROR RESUME NEXT: an error in this procedure (or in one it calls that has no handler) goes on at the next statement
#define OP_FILE_INPUT 0x78 // channel# on stack, push string
#define OP_FILE_EOF 0x79 // channel# on stack, push boolean
#define OP_FILE_LINE_INPUT 0x7A // channel# on stack, push string
@ -243,6 +294,7 @@ typedef enum {
#define OP_LOAD_PROP 0x80 // pop propName, pop ctrlRef, push property value
#define OP_STORE_PROP 0x81 // pop value, pop propName, pop ctrlRef, set property
#define OP_CALL_METHOD 0x82 // [uint8 argc] pop methodName, pop ctrlRef, pop args, push result
#define OP_CALL_NAMED 0x2D // [uint8 argc] [uint8 named] OP_CALL_METHOD whose last named arguments are given by name: pop the names (a string, BAS_PARAM_NAME_SEP-separated), then as OP_CALL_METHOD
#define OP_LOAD_FORM 0x83 // pop formName string, push form reference
#define OP_UNLOAD_FORM 0x84 // pop formRef, unload it
#define OP_SHOW_FORM 0x85 // [uint8 modal] pop formRef, show it
@ -266,14 +318,15 @@ typedef enum {
#define OP_ERASE 0x92 // [uint8 mode] pop array ref, push replacement (BAS_ERASE_ZERO keeps the shape, BAS_ERASE_FREE undimensions)
#define OP_LBOUND 0x93 // [uint8 dim] array ref on stack
#define OP_UBOUND 0x94 // [uint8 dim] array ref on stack
#define OP_ON_ERROR 0x95 // [int16 handler] set error handler (0 = disable)
#define OP_ON_ERROR 0x95 // [int32 handler] set error handler: offset from the end of the instruction (0 = disable)
#define OP_RESUME 0x96 // resume after error
#define OP_RESUME_NEXT 0x97 // resume at next statement
#define OP_RESUME_LABEL 0x2E // RESUME label: the error handler ends here (as RESUME ends it); the OP_JMP after it goes to the label
#define OP_RAISE_ERR 0x98 // error number on stack
#define OP_ERR_NUM 0x99 // push current error number
#define OP_ERL 0x9A // push the source line of the current error (0 when none)
#define OP_STORE_FORM_VAR 0x9B // [uint16 idx] pop, store to currentFormVars[idx]
#define OP_PUSH_FORM_ADDR 0x9C // [uint16 idx] push &currentFormVars[idx] (ByRef)
#define OP_PUSH_FORM_ADDR 0x9C // [uint16 idx] [uint8 type] push a reference to currentFormVars[idx]
#define OP_CREATE_CTRL_EX 0x9D // pop parentRef, pop name, pop type, pop formRef, push ctrlRef
#define OP_NEW_OBJ 0x9E // [uint16 class] push a new instance of class (BAS_NEW_COLLECTION: a Collection), running its initialisation
#define OP_PROP_ASSIGN 0x9F // [uint8 argc] [uint8 flags] pop value, args, memberName, objRef; assign obj.member(args) = value (BAS_ASSIGN_SET: Set)
@ -295,8 +348,8 @@ typedef enum {
#define OP_MATH_EXP 0xAA
#define OP_MATH_RND 0xAB
#define OP_MATH_RANDOMIZE 0xAC // seed on stack (BAS_RANDOMIZE_TIMER_SEED = seed from the clock)
#define OP_RGB 0xAD // pop b, g, r; push LONG = (r<<16)|(g<<8)|b
#define OP_GET_RED 0xAE // pop LONG color; push (color>>16) & 0xFF
#define OP_RGB 0xAD // pop b, g, r; push LONG = r | (g<<8) | (b<<16) (VB's &HBBGGRR)
#define OP_GET_RED 0xAE // pop LONG color; push color & 0xFF
#define OP_GET_GREEN 0xAF // pop LONG color; push (color>>8) & 0xFF
// ============================================================
@ -309,7 +362,7 @@ typedef enum {
#define OP_STR_STRING 0xB3 // STRING$(n, char) -> string
#define OP_STR_OCT 0xF3 // OCT$(n) -> string
#define OP_CONV_BOOL 0xF4 // CBOOL(n) -> -1 (true) or 0 (false)
#define OP_PUSH_ARR_ADDR 0xF5 // [uint8 dims] pop dims indices, pop array ref, push REF to element
#define OP_PUSH_ARR_ADDR 0xF5 // [uint8 dims] [uint8 type] pop dims indices and the array, push a reference to the element (an element holding a reference passes it on; an object's default member gives its value)
// ============================================================
// Extended built-ins
@ -327,7 +380,7 @@ typedef enum {
// ============================================================
#define OP_READ_DATA 0xB9 // push next value from data pool
#define OP_RESTORE 0xBA // reset data pointer to 0
#define OP_RESTORE 0xBA // [int32 index] the data pointer to DATA item index (RESTORE: 0; RESTORE label: the first DATA after the label)
// ============================================================
// WRITE # (comma-delimited with quoted strings)
@ -398,7 +451,7 @@ typedef enum {
#define OP_CALL_EXTERN 0xCD // [uint16 libNameIdx] [uint16 funcNameIdx] [uint8 argc] [uint8 retType]
#define OP_GET_BLUE 0xD0 // pop LONG color; push color & 0xFF
#define OP_GET_BLUE 0xD0 // pop LONG color; push (color>>16) & 0xFF
// App object
#define OP_APP_PATH 0xDD // push App.Path string
@ -458,6 +511,10 @@ typedef enum {
// Most arguments one OP_BUILTIN call takes (CHOOSE: index + 31 choices).
#define BAS_BUILTIN_MAX_ARGS 32
// Most arguments a ParamArray takes: OP_BUILTIN's limit less the element
// type argument.
#define BAS_PARAMARRAY_MAX_ARGS (BAS_BUILTIN_MAX_ARGS - 1)
// OP_BUILTIN function numbers. Part of the bytecode ABI -- append only.
typedef enum {
BAS_FN_REPLACE = 0, // REPLACE$(s, find, repl [, start [, count [, compare]]])
@ -491,19 +548,19 @@ typedef enum {
BAS_FN_ISDATE = 28, // ISDATE(v)
BAS_FN_MONTHNAME = 29, // MONTHNAME(m [, abbrev])
BAS_FN_WEEKDAYNAME = 30, // WEEKDAYNAME(w [, abbrev [, firstDayOfWeek]])
BAS_FN_PARAMARRAY = 31, // (elementType, v0, v1, ...) -> 0-based array of the values: a ParamArray argument (compiler-generated, no BASIC name)
BAS_FN_PARAMARRAY = 31, // (elementType [| BAS_PARAMARRAY_BASE_ONE], v0, v1, ...) -> 0-based (1-based) array of the values: a ParamArray argument, ARRAY(...)
// The program screen (runtime/screen.c): statements return 0, which
// the compiler pops. Omitted arguments are pushed as 0 and flagged in
// a BAS_GIVEN_* / BAS_GFX_* mask pushed last.
BAS_FN_CLS = 32, // CLS [n]: (n, -1 when omitted)
BAS_FN_LOCATE = 33, // LOCATE [row] [, [col] [, cursor]]: (row, col, cursor, given)
BAS_FN_COLOR = 34, // COLOR [fore] [, back]: (fore, back, given)
BAS_FN_SCREEN = 35, // SCREEN mode
BAS_FN_SCREEN = 35, // SCREEN mode [, [colorswitch] [, [apage] [, vpage]]]: (mode, colorswitch, apage, vpage, given)
BAS_FN_WIDTH = 36, // WIDTH [cols] [, rows]: (cols, rows, given)
BAS_FN_PSET = 37, // PSET / PRESET [STEP](x, y) [, color]: (x, y, color, flags)
BAS_FN_LINE = 38, // LINE [[STEP](x1, y1)]-[STEP](x2, y2) [, color] [, B|BF] [, style]: (x1, y1, x2, y2, color, style, flags)
BAS_FN_CIRCLE = 39, // CIRCLE [STEP](x, y), r [, color [, start [, end [, aspect]]]]: (x, y, r, color, start, end, aspect, flags)
BAS_FN_PAINT = 40, // PAINT [STEP](x, y) [, paint [, border]]: (x, y, paint, border, flags)
BAS_FN_PAINT = 40, // PAINT [STEP](x, y) [, paint | tile$ [, border [, background$]]]: (x, y, paint, border, background, flags)
BAS_FN_DRAW = 41, // DRAW macro$
BAS_FN_PALETTE = 42, // PALETTE [attr, color]: (attr, color, given)
BAS_FN_PALETTE_USING = 43, // PALETTE USING array[(first)]: (array, first, given)
@ -527,19 +584,61 @@ typedef enum {
BAS_FN_CVAR = 60, // CVAR(v) -> v as it is
BAS_FN_TYPEOF = 61, // TYPEOF obj IS name: (obj, name) -> the object is of that type
BAS_FN_EACH_COUNT = 62, // FOR EACH (compiler-generated): (group) -> items in the array or Collection
BAS_FN_EACH_ITEM = 63 // FOR EACH (compiler-generated): (group, i) -> item i (0-based)
BAS_FN_EACH_ITEM = 63, // FOR EACH (compiler-generated): (group, i) -> item i (0-based)
BAS_FN_ISMISSING = 64, // ISMISSING(v)
BAS_FN_LSET_TYPE = 65, // LSET rec1 = rec2 (compiler-generated): (rec1, rec2, rec1 layout, rec2 layout) -> rec1 holding rec2's bytes
BAS_FN_PCOPY = 66, // PCOPY source, destination (screen pages)
BAS_FN_VIEW_PRINT = 67, // VIEW PRINT [top TO bottom]: (top, bottom, given)
BAS_FN_PMAP = 68, // PMAP(coordinate, fn) -> world <-> physical
BAS_FN_VARPTR_STR = 69, // VARPTR$(v) -> v packed for DRAW's X and "=" (BAS_VARPTR_*)
BAS_FN_LOADPICTURE = 70, // LOADPICTURE([file]) -> a Picture object for picture properties (DragIcon, Picture); no file: an empty picture
BAS_FN_RECORD_ASSIGN = 71, // rec = value (compiler-generated): (reference to the target, TYPE value) -> Empty; the value's fields are copied into the record the target holds (VB)
BAS_FN_CLOSE = 72, // CLOSE [#n [, #n ...]] with no channel or several, RESET: (channels...) -> 0; none closes every channel
BAS_FN_FILE_PRINT = 73, // PRINT #n, ... (compiler-generated): (n) -> 0 sends the statement's PRINT output to channel n; () -> 0 ends it
BAS_FN_FILE_WIDTH = 74, // WIDTH #n, w / WIDTH "device", w / WIDTH LPRINT w: (n | device$ | BAS_WIDTH_LPRINT, w) -> 0
BAS_FN_PEN = 75, // PEN(n) -> the light pen's (the mouse's) state on the program screen (BAS_PEN_*)
BAS_FN_PEN_SET = 76, // PEN ON | OFF | STOP: (BAS_PEN_ON / OFF / STOP) -> 0
// The Err object and Error$
BAS_FN_ERR_DESCRIPTION = 77, // Err.Description -> the current error's text ("" when none)
BAS_FN_ERR_SOURCE = 78, // Err.Source -> the source Err.Raise gave ("" otherwise)
BAS_FN_ERR_SET = 79, // Err.Clear: () -> 0 clears the error; Err.Number = n: (n) -> 0 sets it (its text the number's)
BAS_FN_ERR_RAISE = 80, // Err.Raise number [, source [, description]] -> raises the error
BAS_FN_ERROR_TEXT = 81, // ERROR$([n]) / ERROR([n]) -> the text of error n (none: the current error's)
BAS_FN_LIKE = 82, // a LIKE pattern: (a, pattern) -> a matches the pattern (Option Compare decides case)
BAS_FN_FILEATTR = 83, // FILEATTR(n, attribute) -> the open mode of file n (BAS_FILEATTR_MODE) or its system handle (BAS_FILEATTR_HANDLE)
BAS_FN_QBCOLOR = 84 // QBCOLOR(n) -> QBasic colour n (0..15) as an RGB value
} BasBuiltinFnE;
// BAS_FN_PARAMARRAY's first argument: the element type (low byte) and
// this flag for an array that starts at 1 (ARRAY under OPTION BASE 1).
#define BAS_PARAMARRAY_TYPE_MASK 0xFF
#define BAS_PARAMARRAY_BASE_ONE 0x100
// The Err object's functions are numbered BAS_FN_ERR_DESCRIPTION through
// BAS_FN_ERROR_TEXT.
#define BAS_FN_ERR_FIRST BAS_FN_ERR_DESCRIPTION
#define BAS_FN_ERR_LAST BAS_FN_ERROR_TEXT
// FILEATTR's attribute argument and the open modes it gives (QBasic's).
#define BAS_FILEATTR_MODE 1
#define BAS_FILEATTR_HANDLE 2
#define BAS_FILEATTR_INPUT 1
#define BAS_FILEATTR_OUTPUT 2
#define BAS_FILEATTR_RANDOM 4
#define BAS_FILEATTR_APPEND 8
#define BAS_FILEATTR_BINARY 32
// The Variant and object functions are numbered BAS_FN_VARTYPE through
// BAS_FN_EACH_ITEM.
// BAS_FN_ISMISSING.
#define BAS_FN_OBJECT_FIRST BAS_FN_VARTYPE
#define BAS_FN_OBJECT_LAST BAS_FN_EACH_ITEM
#define BAS_FN_OBJECT_LAST BAS_FN_ISMISSING
// OP_PUSH_SPECIAL operand. Part of the bytecode ABI.
typedef enum {
BAS_SPECIAL_EMPTY = 0,
BAS_SPECIAL_NULL = 1,
BAS_SPECIAL_NOTHING = 2
BAS_SPECIAL_NOTHING = 2,
BAS_SPECIAL_MISSING = 3 // an omitted Optional Variant argument
} BasSpecialValE;
// OP_NEW_OBJ / OP_OBJ_CHECK class operand values besides a class index.
@ -549,6 +648,19 @@ typedef enum {
// OP_PROP_ASSIGN flags.
#define BAS_ASSIGN_SET 0x01 // Set obj.member = value (Property Set)
// The members of a Collection: the member operand of the early-bound
// opcodes on a Collection. Part of the bytecode ABI.
typedef enum {
BAS_COLL_MEMBER_ADD = 0, // Add item [, key] [, before] [, after]
BAS_COLL_MEMBER_COUNT = 1, // Count
BAS_COLL_MEMBER_ITEM = 2, // Item index-or-key (the default member)
BAS_COLL_MEMBER_REMOVE = 3, // Remove index-or-key
BAS_COLL_MEMBERS = 4
} BasCollMemberE;
// The most arguments Collection.Add takes (item, key, before, after).
#define BAS_COLL_ADD_ARGS 4
// VARTYPE results (VB's vbEmpty .. vbArray).
#define BAS_VT_EMPTY 0
#define BAS_VT_NULL 1
@ -564,13 +676,43 @@ typedef enum {
#define BAS_VT_BOOLEAN 11
#define BAS_VT_VARIANT 12
#define BAS_VT_DATAOBJECT 13
#define BAS_VT_BYTE 17
#define BAS_VT_USERTYPE 36
#define BAS_VT_ARRAY 8192
// The program-screen functions are numbered BAS_FN_CLS through
// BAS_FN_LINE_INPUT (the VM hands them to runtime/screen.c).
// BAS_FN_LINE_INPUT and BAS_FN_PCOPY through BAS_FN_PMAP (the VM hands
// them to runtime/screen.c; see basBuiltinIsScreen).
#define BAS_FN_SCREEN_FIRST BAS_FN_CLS
#define BAS_FN_SCREEN_LAST BAS_FN_LINE_INPUT
#define BAS_FN_SCREEN2_FIRST BAS_FN_PCOPY
#define BAS_FN_SCREEN2_LAST BAS_FN_PMAP
#define BAS_FN_SCREEN3_FIRST BAS_FN_PEN
#define BAS_FN_SCREEN3_LAST BAS_FN_PEN_SET
// PEN(n) (QBasic's light pen; the mouse on the program screen) and the
// PEN statement's argument.
#define BAS_PEN_PRESSED 0 // down since the last PEN(0)
#define BAS_PEN_PRESS_X 1 // where it last went down
#define BAS_PEN_PRESS_Y 2
#define BAS_PEN_DOWN 3 // down now
#define BAS_PEN_X 4 // where it last was
#define BAS_PEN_Y 5
#define BAS_PEN_PRESS_ROW 6 // text row / column of PRESS_X / PRESS_Y
#define BAS_PEN_PRESS_COL 7
#define BAS_PEN_ROW 8 // of X / Y
#define BAS_PEN_COL 9
#define BAS_PEN_OFF 0
#define BAS_PEN_ON 1
#define BAS_PEN_STOP 2
// VARPTR$ results: a type byte, then a string's uint16 length and bytes
// or a number's int32 (both little-endian). DRAW takes them after X (a
// string to run) and after "=" (a number). The type bytes are QBasic's.
#define BAS_VARPTR_STRING 3
#define BAS_VARPTR_NUMBER 20
#define BAS_VARPTR_STR_HEAD 3 // type byte + uint16 length
#define BAS_VARPTR_NUM_LEN 5 // type byte + int32
// Given-argument masks of LOCATE, COLOR, WIDTH and PALETTE (bit n: the
// n-th argument was written).
@ -593,12 +735,13 @@ typedef enum {
#define BAS_GFX_ARC_END 0x10 // CIRCLE: an end angle was given
#define BAS_GFX_ASPECT 0x20 // CIRCLE: an aspect was given
#define BAS_GFX_BORDER 0x08 // PAINT: a border colour was given
#define BAS_GFX_BACKGROUND 0x10 // PAINT: a background tile row was given
// Argument counts of the drawing blocks.
#define BAS_GFX_PSET_ARGS 4
#define BAS_GFX_LINE_ARGS 7
#define BAS_GFX_CIRCLE_ARGS 8
#define BAS_GFX_PAINT_ARGS 5
#define BAS_GFX_PAINT_ARGS 6
// Argument counts of the other screen statements with optional parts.
#define BAS_LOCATE_ARGS 4
@ -606,7 +749,9 @@ typedef enum {
#define BAS_WIDTH_ARGS 3
#define BAS_PALETTE_ARGS 3
#define BAS_VIEW_ARGS 7
#define BAS_WINDOW_ARGS 5
#define BAS_WINDOW_ARGS 5 // also the Form / PictureBox Scale method's arguments
#define BAS_SCREEN_ARGS 5
#define BAS_VIEW_PRINT_ARGS 3
// VIEW / WINDOW flags.
#define BAS_VIEW_COORDS 0x01 // a rectangle was given (none: reset)
@ -614,6 +759,34 @@ typedef enum {
#define BAS_VIEW_FILL 0x04 // VIEW: a fill colour was given
#define BAS_VIEW_BORDER 0x08 // VIEW: a border colour was given
// LSET of a whole TYPE record: OP_BUILTIN BAS_FN_LSET_TYPE's arguments.
#define BAS_LSET_TYPE_ARGS 4
// LOADPICTURE([file [, size [, colordepth [, x [, y]]]]]): the arguments.
#define BAS_LOADPICTURE_MAX_ARGS 5
#define BAS_LOADPICTURE_ARG_SIZE 1
#define BAS_LOADPICTURE_ARG_DEPTH 2
#define BAS_LOADPICTURE_ARG_X 3
// LoadPicture's size and colour-depth arguments (VB's vbLP* constants):
// they choose among the images of an icon or cursor file, so a bitmap --
// every DVX picture is one -- ignores them, as VB does.
#define BAS_LP_SMALL 0 // vbLPSmall
#define BAS_LP_LARGE 1 // vbLPLarge
#define BAS_LP_SMALL_SHELL 2 // vbLPSmallShell
#define BAS_LP_LARGE_SHELL 3 // vbLPLargeShell
#define BAS_LP_CUSTOM 4 // vbLPCustom: x and y give the size
#define BAS_LP_DEFAULT 0 // vbLPDefault
#define BAS_LP_MONOCHROME 1 // vbLPMonochrome
#define BAS_LP_VGA_COLOR 2 // vbLPVGAColor
#define BAS_LP_COLOR 3 // vbLPColor
// Arguments of the other compiler-generated built-ins.
#define BAS_RECORD_ASSIGN_ARGS 2 // BAS_FN_RECORD_ASSIGN: (reference, value)
#define BAS_EACH_ITEM_ARGS 2 // BAS_FN_EACH_ITEM: (group, i)
#define BAS_TYPEOF_ARGS 2 // BAS_FN_TYPEOF: (object, type name)
// Object Print (Form / PictureBox .Print): one method call per item with
// (value, mode).
#define BAS_OBJ_PRINT_TEXT 0 // the value's text
@ -627,6 +800,17 @@ typedef enum {
// it is omitted (vbUseCompareOption).
#define BAS_COMPARE_USE_OPTION (-1)
// INSTR's argument counts: (string, find) and (start, string, find), the
// form with its own opcode.
#define BAS_INSTR_ARGS 2
#define BAS_INSTR3_ARGS 3
// OP_NULL_PROP masks and the VM's Null pass-through masks: bit n-1 is
// argument n.
#define BAS_NULL_ARG_1 0x01
#define BAS_NULL_ARG_2 0x02
#define BAS_NULL_ARG_3 0x04
// ============================================================
// Halt
// ============================================================
@ -640,6 +824,11 @@ typedef enum {
#define BAS_USING_FIRST 0x01
#define BAS_USING_LAST 0x02
// BAS_FN_FILE_WIDTH's first argument for WIDTH LPRINT (file channels
// are 1 and up), and the width that means no limit (QBasic's 255).
#define BAS_WIDTH_LPRINT 0
#define BAS_WIDTH_UNLIMITED 255
// OP_LPRINT operand: BEGIN sends the PRINT opcodes that follow to the
// printer, END sends the statement's output and goes back to the screen.
#define BAS_LPRINT_END 0
@ -679,7 +868,7 @@ typedef enum {
// The BAS_OPERAND_* names give the operand SIZE in bytes, not its layout:
// OP_DIM_ARRAY's two uint8 operands are BAS_OPERAND_U16 (2 bytes), OP_REDIM's
// three uint8 operands BAS_OPERAND_U8_U16 (3 bytes), and OP_CALL's
// [uint16 addr][uint8 argc][uint8 baseSlot] BAS_OPERAND_I32 (4 bytes). The
// [int32 addr][uint8 argc][uint8 baseSlot] BAS_OPERAND_CALL (6 bytes). The
// per-opcode comments above describe the real layout.
// Operand widths (bytes after the 1-byte opcode).
@ -688,16 +877,31 @@ typedef enum {
#define BAS_OPERAND_U16 2
#define BAS_OPERAND_U8_U16 3
#define BAS_OPERAND_I32 4
#define BAS_OPERAND_FOR 5 // [uint16 varIdx] [uint8 scope] [int16 offset]
#define BAS_OPERAND_MEMBER 5 // [uint16 class] [uint16 member] [uint8 argc]
#define BAS_OPERAND_CALL 6 // [int32 addr] [uint8 argc] [uint8 baseSlot]
#define BAS_OPERAND_CALL_EXTERN 6 // [uint16 lib] [uint16 func] [uint8 argc] [uint8 retType]
#define BAS_OPERAND_FOR 7 // [uint16 varIdx] [uint8 scope] [int32 offset]
#define BAS_OPERAND_F64 8
#define BAS_OPERAND_UNKNOWN (-1)
// Code addresses (OP_CALL / OP_CALL_ME targets, procedure and set-up
// entries) and jump offsets (OP_JMP*, OP_GOSUB, OP_ON_ERROR, the FOR
// opcodes; relative to the end of the instruction) are 32-bit, so a
// module's code has no 64 KB limit.
#define BAS_CODE_ADDR_SIZE BAS_OPERAND_I32
// Size of an OP_LINE instruction: opcode and [uint16 lineNum].
#define BAS_LINE_INST_SIZE (1 + BAS_OPERAND_U16)
// Byte offsets inside the FOR opcodes' BAS_OPERAND_FOR operand.
#define BAS_FOR_OFFSET_OPERAND (1 + BAS_OPERAND_U16 + BAS_OPERAND_U8) // opcode-relative position of the int16 jump offset
#define BAS_FOR_OFFSET_OPERAND (1 + BAS_OPERAND_U16 + BAS_OPERAND_U8) // opcode-relative position of the int32 jump offset
static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArgs);
static inline bool basBuiltinIsScreen(uint8_t fn);
static inline int32_t basCollMemberFind(const char *name);
static inline const char *basCollMemberName(int32_t member);
static inline uint8_t basConvOpForStore(uint8_t dataType);
static inline uint8_t basK16Pair(uint8_t op, bool toK16);
static inline int32_t basOpcodeOperandSize(uint8_t op);
static inline int16_t basReadI16LE(const uint8_t *p);
static inline int32_t basReadI32LE(const uint8_t *p);
@ -713,20 +917,23 @@ static inline void basWriteU16LE(uint8_t *p, uint16_t v);
static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArgs) {
switch (fn) {
case BAS_FN_NOW: case BAS_FN_DATE: case BAS_FN_TIME:
case BAS_FN_INKEY: case BAS_FN_CSRLIN:
case BAS_FN_INKEY: case BAS_FN_CSRLIN: case BAS_FN_ERR_DESCRIPTION:
case BAS_FN_ERR_SOURCE:
*minArgs = 0;
*maxArgs = 0;
return true;
case BAS_FN_QBCOLOR:
case BAS_FN_STRREVERSE: case BAS_FN_DATEVALUE: case BAS_FN_TIMEVALUE:
case BAS_FN_YEAR: case BAS_FN_MONTH: case BAS_FN_DAY:
case BAS_FN_HOUR: case BAS_FN_MINUTE: case BAS_FN_SECOND:
case BAS_FN_ISDATE: case BAS_FN_CLS: case BAS_FN_SCREEN:
case BAS_FN_ISDATE: case BAS_FN_CLS:
case BAS_FN_DRAW: case BAS_FN_FULLSCREEN: case BAS_FN_POS:
case BAS_FN_LINE_INPUT: case BAS_FN_VARTYPE: case BAS_FN_TYPENAME:
case BAS_FN_ISEMPTY: case BAS_FN_ISNULL: case BAS_FN_ISNUMERIC:
case BAS_FN_ISOBJECT: case BAS_FN_ISARRAY: case BAS_FN_CVAR:
case BAS_FN_EACH_COUNT:
case BAS_FN_EACH_COUNT: case BAS_FN_ISMISSING: case BAS_FN_VARPTR_STR:
case BAS_FN_PEN: case BAS_FN_PEN_SET:
*minArgs = 1;
*maxArgs = 1;
return true;
@ -761,6 +968,16 @@ static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArg
*maxArgs = BAS_LOCATE_ARGS;
return true;
case BAS_FN_SCREEN:
*minArgs = BAS_SCREEN_ARGS;
*maxArgs = BAS_SCREEN_ARGS;
return true;
case BAS_FN_VIEW_PRINT:
*minArgs = BAS_VIEW_PRINT_ARGS;
*maxArgs = BAS_VIEW_PRINT_ARGS;
return true;
case BAS_FN_WINDOW:
*minArgs = BAS_WINDOW_ARGS;
*maxArgs = BAS_WINDOW_ARGS;
@ -796,6 +1013,11 @@ static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArg
*maxArgs = 2;
return true;
case BAS_FN_LOADPICTURE:
*minArgs = 0;
*maxArgs = BAS_LOADPICTURE_MAX_ARGS;
return true;
case BAS_FN_WEEKDAYNAME:
*minArgs = 1;
*maxArgs = 3;
@ -807,7 +1029,8 @@ static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArg
return true;
case BAS_FN_LSET: case BAS_FN_RSET: case BAS_FN_TYPEOF:
case BAS_FN_EACH_ITEM:
case BAS_FN_EACH_ITEM: case BAS_FN_PCOPY: case BAS_FN_PMAP:
case BAS_FN_RECORD_ASSIGN: case BAS_FN_LIKE: case BAS_FN_FILEATTR:
*minArgs = 2;
*maxArgs = 2;
return true;
@ -832,12 +1055,37 @@ static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArg
*maxArgs = BAS_BUILTIN_MAX_ARGS;
return true;
case BAS_FN_CLOSE:
*minArgs = 0;
*maxArgs = BAS_BUILTIN_MAX_ARGS;
return true;
case BAS_FN_FILE_PRINT: case BAS_FN_ERR_SET: case BAS_FN_ERROR_TEXT:
*minArgs = 0;
*maxArgs = 1;
return true;
case BAS_FN_ERR_RAISE:
*minArgs = 1;
*maxArgs = 3;
return true;
case BAS_FN_FILE_WIDTH:
*minArgs = 2;
*maxArgs = 2;
return true;
case BAS_FN_IIF: case BAS_FN_DATESERIAL: case BAS_FN_TIMESERIAL:
case BAS_FN_DATEADD:
*minArgs = 3;
*maxArgs = 3;
return true;
case BAS_FN_LSET_TYPE:
*minArgs = BAS_LSET_TYPE_ARGS;
*maxArgs = BAS_LSET_TYPE_ARGS;
return true;
case BAS_FN_DATEDIFF:
*minArgs = 3;
*maxArgs = 5;
@ -854,16 +1102,63 @@ static inline bool basBuiltinArity(uint8_t fn, int32_t *minArgs, int32_t *maxArg
}
// True for the program-screen functions (runtime/screen.c).
static inline bool basBuiltinIsScreen(uint8_t fn) {
return (fn >= BAS_FN_SCREEN_FIRST && fn <= BAS_FN_SCREEN_LAST) || (fn >= BAS_FN_SCREEN2_FIRST && fn <= BAS_FN_SCREEN2_LAST) || (fn >= BAS_FN_SCREEN3_FIRST && fn <= BAS_FN_SCREEN3_LAST);
}
// The Collection member called name (case ignored), or -1.
static inline int32_t basCollMemberFind(const char *name) {
for (int32_t m = 0; m < BAS_COLL_MEMBERS; m++) {
if (strcasecmp(name, basCollMemberName(m)) == 0) {
return m;
}
}
return -1;
}
// The name programs write for Collection member (a BasCollMemberE; ""
// for none).
static inline const char *basCollMemberName(int32_t member) {
switch (member) {
case BAS_COLL_MEMBER_ADD:
return "Add";
case BAS_COLL_MEMBER_COUNT:
return "Count";
case BAS_COLL_MEMBER_ITEM:
return "Item";
case BAS_COLL_MEMBER_REMOVE:
return "Remove";
default:
return "";
}
}
// The conversion a value goes through when it is stored where dataType
// is declared: a numeric, BOOLEAN or DATE type is converted to it, every
// other type (STRING, OBJECT, VARIANT, TYPE) stores the value as it is
// (OP_NOP). One source for the compiler's typed stores and the VM's
// stores into class member variables.
// is declared, or passed for a parameter declared so (QBasic / VB): a
// number, STRING, BOOLEAN or DATE type is converted to it, the other
// types (OBJECT, VARIANT, TYPE) take the value as it is (OP_NOP). One
// source for the compiler's typed stores and arguments and the VM's
// stores into class member variables and through references.
static inline uint8_t basConvOpForStore(uint8_t dataType) {
switch (dataType) {
case BAS_TYPE_INTEGER:
return OP_CONV_FLT_INT;
case BAS_TYPE_STRING:
return OP_CONV_INT_STR;
case BAS_TYPE_DOUBLE:
return OP_CONV_STR_FLT;
case BAS_TYPE_LONG:
return OP_CONV_INT_LONG;
@ -876,12 +1171,40 @@ static inline uint8_t basConvOpForStore(uint8_t dataType) {
case BAS_TYPE_DATE:
return OP_CONV_DATE;
case BAS_TYPE_BYTE:
return OP_CONV_BYTE;
case BAS_TYPE_CURRENCY:
return OP_CONV_CUR;
default:
return OP_NOP;
}
}
// The other half of an operator's OP_*_K16 pair: the K16 form of binary
// operator op (toK16), or the operator a K16 opcode applies (!toK16);
// OP_NOP when op has none.
static inline uint8_t basK16Pair(uint8_t op, bool toK16) {
static const uint8_t pairs[][2] = {
{ OP_ADD_INT, OP_ADD_K16 },
{ OP_SUB_INT, OP_SUB_K16 },
{ OP_MUL_INT, OP_MUL_K16 },
{ OP_IDIV_INT, OP_IDIV_K16 },
{ OP_MOD_INT, OP_MOD_K16 }
};
for (size_t i = 0; i < sizeof(pairs) / sizeof(pairs[0]); i++) {
if (pairs[i][toK16 ? 0 : 1] == op) {
return pairs[i][toK16 ? 1 : 0];
}
}
return OP_NOP;
}
// Returns operand byte count for op, or BAS_OPERAND_UNKNOWN.
static inline int32_t basOpcodeOperandSize(uint8_t op) {
switch (op) {
@ -905,12 +1228,12 @@ static inline int32_t basOpcodeOperandSize(uint8_t op) {
case OP_GOSUB_RET: case OP_RET: case OP_RET_VAL:
case OP_FOR_POP:
case OP_CONV_INT_FLT: case OP_CONV_FLT_INT:
case OP_CONV_INT_STR: case OP_CONV_STR_INT:
case OP_CONV_INT_STR: case OP_CONV_BYTE:
case OP_CONV_STR_FLT: case OP_CONV_INT_LONG:
case OP_CONV_DATE:
case OP_CONV_DATE: case OP_CONV_CUR:
case OP_PRINT: case OP_PRINT_NL: case OP_PRINT_TAB:
case OP_INPUT:
case OP_FILE_CLOSE: case OP_FILE_PRINT: case OP_FILE_INPUT:
case OP_FILE_CLOSE: case OP_FILE_INPUT: case OP_ON_ERROR_NEXT:
case OP_FILE_EOF: case OP_FILE_LINE_INPUT:
case OP_LOAD_PROP: case OP_STORE_PROP:
case OP_LOAD_FORM: case OP_UNLOAD_FORM:
@ -931,7 +1254,7 @@ static inline int32_t basOpcodeOperandSize(uint8_t op) {
case OP_STR_STRING: case OP_STR_OCT: case OP_CONV_BOOL:
case OP_MATH_TIMER: case OP_DATE_STR: case OP_TIME_STR:
case OP_SLEEP: case OP_ENVIRON: case OP_COMMAND:
case OP_READ_DATA: case OP_RESTORE:
case OP_READ_DATA: case OP_RESUME_LABEL:
case OP_FILE_WRITE: case OP_FILE_WRITE_SEP: case OP_FILE_WRITE_NL:
case OP_FILE_GET: case OP_FILE_PUT: case OP_FILE_SEEK:
case OP_FILE_LOF: case OP_FILE_LOC: case OP_FILE_FREEFILE:
@ -955,7 +1278,6 @@ static inline int32_t basOpcodeOperandSize(uint8_t op) {
return BAS_OPERAND_NONE;
case OP_LOAD_ARRAY: case OP_STORE_ARRAY:
case OP_PUSH_ARR_ADDR:
case OP_FILE_OPEN:
case OP_CALL_METHOD: case OP_SHOW_FORM:
case OP_LBOUND: case OP_UBOUND:
@ -965,34 +1287,45 @@ static inline int32_t basOpcodeOperandSize(uint8_t op) {
return BAS_OPERAND_U8;
case OP_PUSH_INT16: case OP_PUSH_STR:
case OP_ADD_K16: case OP_SUB_K16: case OP_MUL_K16:
case OP_IDIV_K16: case OP_MOD_K16:
case OP_LOAD_LOCAL: case OP_STORE_LOCAL:
case OP_LOAD_GLOBAL: case OP_STORE_GLOBAL:
case OP_LOAD_FIELD: case OP_STORE_FIELD:
case OP_PUSH_LOCAL_ADDR: case OP_PUSH_GLOBAL_ADDR:
case OP_JMP: case OP_JMP_TRUE: case OP_JMP_FALSE:
case OP_GOSUB:
case OP_PUSH_ARR_ADDR: case OP_REF_FIXLEN:
case OP_LOAD_FORM_VAR: case OP_STORE_FORM_VAR:
case OP_PUSH_FORM_ADDR:
case OP_DIM_ARRAY:
case OP_ON_ERROR:
case OP_STR_FIXLEN:
case OP_LINE:
case OP_BUILTIN:
case OP_LOAD_MEMBER: case OP_STORE_MEMBER:
case OP_PUSH_MEMBER_ADDR:
case OP_OBJ_CHECK: case OP_NEW_OBJ:
case OP_PROP_ASSIGN:
case OP_PROP_ASSIGN: case OP_BIND_EVENTS:
case OP_NULL_PROP: case OP_CALL_NAMED:
return BAS_OPERAND_U16;
case OP_STORE_ARRAY_FIELD:
case OP_STORE_LOCAL_CONV: case OP_STORE_GLOBAL_CONV:
case OP_REDIM:
case OP_RAISE_EVENT:
case OP_PUSH_LOCAL_ADDR: case OP_PUSH_GLOBAL_ADDR:
case OP_PUSH_FORM_ADDR: case OP_PUSH_MEMBER_ADDR:
case OP_PUSH_FIELD_ADDR:
return BAS_OPERAND_U8_U16;
case OP_PUSH_INT32:
case OP_CALL: case OP_CALL_ME:
case OP_JMP: case OP_JMP_TRUE: case OP_JMP_FALSE:
case OP_GOSUB: case OP_ON_ERROR:
case OP_RESTORE:
case OP_STR_APPEND:
return BAS_OPERAND_I32;
case OP_OBJ_GET: case OP_OBJ_PUT: case OP_OBJ_CALL:
return BAS_OPERAND_MEMBER;
case OP_CALL: case OP_CALL_ME:
return BAS_OPERAND_CALL;
case OP_FOR_INIT:
case OP_FOR_NEXT:
return BAS_OPERAND_FOR;
@ -1000,7 +1333,7 @@ static inline int32_t basOpcodeOperandSize(uint8_t op) {
case OP_CALL_EXTERN:
return BAS_OPERAND_CALL_EXTERN;
case OP_PUSH_FLT64:
case OP_PUSH_FLT64: case OP_PUSH_CUR:
return BAS_OPERAND_F64;
default:

251
src/apps/kpunch/dvxbasic/compiler/parse.c Normal file
View file

@ -0,0 +1,251 @@
// 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.
// parse.c -- DVX BASIC parser: tokens, errors and units
//
// Recursive descent over the lexer's tokens. basParseUnit returns the
// next top-level statement (a procedure, TYPE and block statements
// included) as a tree in the unit arena. The parser decides syntax only;
// what names mean is the resolver's business, with two exceptions the
// grammar itself needs, both taken from the declaration pass: whether a
// console / graphics statement word or LSET / RSET names a procedure of
// the program, and the class names New takes.
#include "front.h"
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
// Function prototypes (alphabetical)
void basParseAdvance(BasCompilerT *c);
bool basParseAtEnd(BasCompilerT *c);
bool basParseCheck(const BasCompilerT *c, BasTokenTypeE type);
bool basParseCheckWord(const BasCompilerT *c, const char *word);
void basParseError(BasCompilerT *c, const char *fmt, ...);
void basParseErrorExpected(BasCompilerT *c, const char *what);
void basParseExpect(BasCompilerT *c, BasTokenTypeE type);
void basParseExpectEnd(BasCompilerT *c);
bool basParseMatch(BasCompilerT *c, BasTokenTypeE type);
bool basParseMatchEnd(BasCompilerT *c, BasTokenTypeE kw);
bool basParseNameFollows(BasCompilerT *c, bool anyWord);
BasNodeT *basParseNode(BasCompilerT *c, int32_t size, uint8_t kind);
void basParseSkipNewlines(BasCompilerT *c);
char *basParseTokenName(BasCompilerT *c);
BasNodeT *basParseUnit(BasCompilerT *c);
static void checkIdentLength(BasCompilerT *c);
static void lexError(BasCompilerT *c);
void basParseAdvance(BasCompilerT *c) {
if (c->hasError) {
return;
}
c->prevLine = c->lex.token.line;
basLexerNext(&c->lex);
if (c->lex.token.type == TOK_ERROR) {
lexError(c);
return;
}
checkIdentLength(c);
}
// True at a token that ends the current statement.
bool basParseAtEnd(BasCompilerT *c) {
BasTokenTypeE t = c->lex.token.type;
return t == TOK_NEWLINE || t == TOK_EOF || t == TOK_COLON || t == TOK_ELSE;
}
bool basParseCheck(const BasCompilerT *c, BasTokenTypeE type) {
return c->lex.token.type == type;
}
// True at an identifier spelled word (a word the parser reads by its
// text: BEGINFORM, EACH, IN, USING ...).
bool basParseCheckWord(const BasCompilerT *c, const char *word) {
return c->lex.token.type == TOK_IDENT && strcasecmp(c->lex.token.text, word) == 0;
}
// Reports an error at the current token; at the first token of a later
// line the error is about the end of the line before (a missing token).
void basParseError(BasCompilerT *c, const char *fmt, ...) {
char text[BAS_ERROR_TEXT_LEN];
va_list ap;
va_start(ap, fmt);
vsnprintf(text, sizeof(text), fmt, ap);
va_end(ap);
int32_t line = c->lex.token.line;
int32_t col = c->lex.token.col;
if (c->prevLine > 0 && line > c->prevLine) {
line = c->prevLine;
col = 0;
}
basErrorAt(c, line, col, "%s", text);
}
void basParseErrorExpected(BasCompilerT *c, const char *what) {
basParseError(c, "Expected %s, got %s", what, basTokenName(c->lex.token.type));
}
void basParseExpect(BasCompilerT *c, BasTokenTypeE type) {
if (c->hasError) {
return;
}
if (c->lex.token.type != type) {
basParseError(c, "Expected %s, got %s", basTokenName(type), basTokenName(c->lex.token.type));
return;
}
basParseAdvance(c);
}
// A statement ends with a newline, the end of the source, ELSE (single
// line IF) or a colon (consumed).
void basParseExpectEnd(BasCompilerT *c) {
if (c->hasError || basParseCheck(c, TOK_NEWLINE) || basParseCheck(c, TOK_EOF) || basParseCheck(c, TOK_ELSE)) {
return;
}
if (!basParseMatch(c, TOK_COLON)) {
basParseErrorExpected(c, "end of statement");
}
}
// Once an error is set the token never moves, so a match would spin any
// "while (match(...))" loop: report no match instead.
bool basParseMatch(BasCompilerT *c, BasTokenTypeE type) {
if (c->hasError || c->lex.token.type != type) {
return false;
}
basParseAdvance(c);
return true;
}
// Consumes "END <kw>" when it is next; a bare END or END with another
// keyword is left for the statement parser.
bool basParseMatchEnd(BasCompilerT *c, BasTokenTypeE kw) {
if (!basParseCheck(c, TOK_END)) {
return false;
}
BasLexerT peek = c->lex;
basLexerNext(&peek);
if (peek.token.type != kw) {
return false;
}
basParseAdvance(c);
basParseAdvance(c);
return true;
}
// True when the token after the current one is a name: an identifier, or
// with anyWord a keyword too.
bool basParseNameFollows(BasCompilerT *c, bool anyWord) {
BasLexerT peek = c->lex;
basLexerNext(&peek);
return peek.token.type == TOK_IDENT || (anyWord && basTokenIsWord(&peek.token));
}
// A unit-arena node at the current token's position.
BasNodeT *basParseNode(BasCompilerT *c, int32_t size, uint8_t kind) {
BasNodeT *n = basNodeNew(&c->unitArena, size, kind, c->lex.token.line, c->lex.token.col);
if (n == NULL) {
basParseError(c, "Out of memory");
}
return n;
}
void basParseSkipNewlines(BasCompilerT *c) {
while (!c->hasError && basParseCheck(c, TOK_NEWLINE)) {
basParseAdvance(c);
}
}
// The current token's text in the unit arena.
char *basParseTokenName(BasCompilerT *c) {
char *s = basArenaStrDup(&c->unitArena, c->lex.token.text, c->lex.token.textLen);
if (s == NULL) {
basParseError(c, "Out of memory");
}
return s;
}
// The next top-level unit, or NULL at the end of the source (or after an
// error).
BasNodeT *basParseUnit(BasCompilerT *c) {
basParseSkipNewlines(c);
if (c->hasError || basParseCheck(c, TOK_EOF)) {
return NULL;
}
return basParseStatement(c);
}
// Identifiers must fit a symbol name (BAS_MAX_IDENT, the size of every
// name buffer they are copied into); the lexer accepts longer tokens.
static void checkIdentLength(BasCompilerT *c) {
if (c->lex.token.type == TOK_IDENT && c->lex.token.textLen >= BAS_MAX_IDENT) {
basParseError(c, "Identifier too long (maximum is %d characters)", (int)(BAS_MAX_IDENT - 1));
}
}
// The lexer's error, at the token that raised it.
static void lexError(BasCompilerT *c) {
basErrorAt(c, c->lex.errLine, c->lex.errCol, "%s", c->lex.error);
}

1761
src/apps/kpunch/dvxbasic/compiler/parseDecl.c Normal file
View file

File diff suppressed because it is too large Load diff

1389
src/apps/kpunch/dvxbasic/compiler/parseExpr.c Normal file
View file

File diff suppressed because it is too large Load diff

3097
src/apps/kpunch/dvxbasic/compiler/parseStmt.c Normal file
View file

File diff suppressed because it is too large Load diff

10296
src/apps/kpunch/dvxbasic/compiler/parser.c
View file

File diff suppressed because it is too large Load diff

181
src/apps/kpunch/dvxbasic/compiler/parser.h
View file

@ -1,181 +0,0 @@
// 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.
// parser.h -- DVX BASIC parser (recursive descent)
//
// Single-pass compiler: reads tokens from the lexer and emits
// p-code directly via the code generator. No AST. Forward
// references to SUBs/FUNCTIONs are resolved via backpatching.
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_PARSER_H
#define DVXBASIC_PARSER_H
#include "lexer.h"
#include "codegen.h"
#include "symtab.h"
#include "../runtime/vm.h"
#include <stdint.h>
#include <stdbool.h>
// ============================================================
// Parser state
// ============================================================
// Parse-error string sizes. PARSE_ERROR_LEN is the final message stored
// on the parser; PARSE_ERR_SCRATCH is used for temporary formatting before
// copying into it (with a "Line N: " prefix).
#define BAS_PARSE_ERROR_LEN 1024
#define BAS_PARSE_ERR_SCRATCH 512
// Number of letters covered by DEFINT/DEFLNG/DEFSNG/DEFDBL/DEFSTR (A-Z).
#define BAS_DEFTYPE_LETTERS ('Z' - 'A' + 1)
#define BAS_DEFTYPE_NONE 0xFF // defType[] entry with no DEFxxx in effect (BAS_TYPE_INTEGER is 0, so 0 cannot mean unset)
// Recursion guards for the recursive-descent parser. Each nested
// expression or block costs a dozen or more C stack frames, so an
// unbounded nesting depth would overflow the (small) DOS stack long
// before the source became unreadable. These limits keep a
// pathological input a compile error instead of a crash.
#define BAS_MAX_EXPR_DEPTH 64
#define BAS_MAX_BLOCK_DEPTH 32
// Optional compile-time validator for CtrlName.Member references.
// The IDE populates this from the project's .frm files + widget DXE
// metadata so typos die at compile time instead of at event-click
// time. bascomp leaves it NULL (runs on the host, no widget DXEs)
// and falls back to the runtime error net. Dynamically-created
// controls aren't in the map, so lookupCtrlType returns NULL and
// validation is skipped for those -- no false positives.
typedef struct {
// Return the widget type name for a control declared in a .frm,
// or NULL if the control isn't statically known.
const char *(*lookupCtrlType)(void *ctx, const char *ctrlName);
// Return true if `methodName` is valid for widget type `wgtType`
// (or a common method like Refresh/SetFocus). Called with the
// type string returned by lookupCtrlType.
bool (*isMethodValid)(void *ctx, const char *wgtType, const char *methodName);
// Return true if `propName` is a valid property on wgtType.
bool (*isPropValid)(void *ctx, const char *wgtType, const char *propName);
void *ctx;
} BasCtrlValidatorT;
// Forward jump list (for EXIT FOR / EXIT DO backpatching)
typedef struct {
int32_t *patchAddr; // stb_ds dynamic array of code positions to backpatch
} ExitListT;
typedef struct {
BasLexerT lex;
BasCodeGenT cg;
BasSymTabT sym;
char error[BAS_PARSE_ERROR_LEN];
bool hasError;
int32_t errorLine;
int32_t prevLine; // line of the previous token (for error reporting)
int32_t lastUdtTypeId; // index of last resolved UDT type from resolveTypeName
int32_t lastObjClass; // class of the last object type resolveTypeName read (BAS_CLASS_NONE for Object / Control / Form)
int32_t tempCount; // compiler temporaries created so far (names them uniquely)
BasSymbolT **tempPool; // stb_ds: temporaries of the current scope, reused from the start of every statement
int32_t tempPoolUsed; // temporaries of tempPool taken by the current statement
BasSymbolT **typeDefs; // stb_ds: TYPE definitions, indexed by typeId
bool inDefFn; // parsing a DEF FN body: undeclared names are module variables
int32_t optionBase; // default array lower bound (0 or 1)
bool optionExplicit; // true = variables must be declared with DIM
bool currentProcIsFunction; // true while parsing a FUNCTION body (EXIT FUNCTION / return-value assignment)
bool currentProcIsProperty; // true while parsing a Property Get / Let / Set body (EXIT PROPERTY)
int32_t currentProcAddr; // code address of the SUB / FUNCTION being parsed
bool forIsEach; // the innermost FOR loop is a FOR EACH (no VM FOR frame for EXIT FOR to drop)
bool setAssign; // parsing a SET statement: the target takes an object
int32_t memberClass; // class of the object the member access being parsed starts from (BAS_CLASS_NONE: unknown)
char **formNames; // stb_ds: every BEGINFORM name (the prescan collects them), malloc'd
uint8_t defType[BAS_DEFTYPE_LETTERS]; // default type per letter (A-Z), set by DEFINT etc.
char currentProc[BAS_MAX_TOKEN_LEN]; // name of current SUB/FUNCTION
// Per-form init block tracking
int32_t formInitJmpAddr; // code position of JMP to patch (-1 = none)
int32_t formInitCodeStart; // code position where init block starts (-1 = none)
// EXIT FOR/DO/SUB/FUNCTION forward-jump backpatch lists
ExitListT exitForList;
ExitListT exitDoList;
ExitListT exitSubList;
ExitListT exitFuncList;
// SELECT CASE keeps its test value on the eval stack for the whole
// construct. selectDepth counts how many are currently live; the
// nearest FOR/DO loop records the depth at its start so EXIT and
// GOTO can emit one OP_POP per SELECT they jump out of.
int32_t selectDepth;
int32_t forSelectBase;
int32_t doSelectBase;
// Number of FOR / DO-WHILE loops currently open in the procedure (or
// module body) being parsed, so EXIT FOR / EXIT DO outside a loop is a
// compile error rather than a jump patched against an outer scope.
int32_t forDepth;
int32_t doDepth;
// SELECT depth at the most recently defined label. RETURN discards
// the test values of every SELECT opened since that label so the
// eval stack is balanced after the GOSUB returns.
int32_t lastLabelSelectDepth;
// Recursion guards (see BAS_MAX_EXPR_DEPTH / BAS_MAX_BLOCK_DEPTH).
int32_t exprDepth;
int32_t blockDepth;
// Optional compile-time CtrlName.Member validator (IDE-only).
const BasCtrlValidatorT *validator;
// Constant expressions (CONST, ENUM values) are compiled like any
// expression and run on this private VM, created on first use.
BasVmT *constVm;
bool inConstExpr; // parsing a constant expression: only constants may be named
bool compareText; // OPTION COMPARE TEXT in effect (string comparisons in constant expressions)
} BasParserT;
// ============================================================
// API
// ============================================================
// Initialize parser with source text.
void basParserInit(BasParserT *p, const char *source, int32_t sourceLen);
// Attach an optional compile-time validator for CtrlName.Member
// references. The parser borrows the pointer -- caller owns the
// underlying struct and must keep it alive until basParserFree.
void basParserSetValidator(BasParserT *p, const BasCtrlValidatorT *v);
// Parse the entire source and generate p-code.
// Returns true on success, false on error (check p->error).
bool basParse(BasParserT *p);
// Build a module from the parsed code. Returns NULL on error.
// Caller owns the module and must free with basModuleFree().
BasModuleT *basParserBuildModule(BasParserT *p);
// BEGINFORM name of the code being parsed right now ("" outside every
// form). A validator's lookupCtrlType can call it (keep the parser in
// the validator ctx) to resolve a control name on the form it belongs to.
const char *basParserFormScope(const BasParserT *p);
// Free parser resources.
void basParserFree(BasParserT *p);
#endif // DVXBASIC_PARSER_H

3895
src/apps/kpunch/dvxbasic/compiler/resolve.c Normal file
View file

File diff suppressed because it is too large Load diff

2861
src/apps/kpunch/dvxbasic/compiler/resolveExpr.c Normal file
View file

File diff suppressed because it is too large Load diff

133
src/apps/kpunch/dvxbasic/compiler/scope.c Normal file
View file

@ -0,0 +1,133 @@
// 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.
// scope.c -- DVX BASIC compiler symbols and scopes
#include "scope.h"
#include "lexer.h"
#include <string.h>
// Function prototypes (alphabetical)
BasSymT *basScopeAdd(BasScopeTabT *tab, BasArenaT *arena, const char *name, uint8_t kind, uint8_t dataType);
BasSymT *basScopeFind(const BasScopeTabT *tab, const char *name);
BasSymT *basScopeFindKind(const BasScopeTabT *tab, const char *name, uint8_t kind);
uint32_t basScopeHash(const char *name);
bool basScopeInit(BasScopeTabT *tab, BasArenaT *arena, uint32_t buckets);
bool basScopeNamesEqual(const char *a, const char *b);
BasSymT *basScopeAdd(BasScopeTabT *tab, BasArenaT *arena, const char *name, uint8_t kind, uint8_t dataType) {
BasSymT *sym = (BasSymT *)basArenaAlloc(arena, (int32_t)sizeof(BasSymT));
if (sym == NULL) {
return NULL;
}
sym->name = basArenaStrDup(arena, name, (int32_t)strlen(name));
if (sym->name == NULL) {
return NULL;
}
sym->hash = basScopeHash(name);
sym->kind = kind;
sym->dataType = dataType;
sym->scope = SCOPE_GLOBAL;
sym->udtTypeId = -1;
sym->objClass = BAS_CLASS_NONE;
sym->ownerClass = BAS_CLASS_NONE;
BasSymT **bucket = &tab->buckets[sym->hash & tab->mask];
sym->hashNext = *bucket;
*bucket = sym;
if (tab->last != NULL) {
tab->last->orderNext = sym;
} else {
tab->first = sym;
}
tab->last = sym;
tab->count++;
return sym;
}
BasSymT *basScopeFind(const BasScopeTabT *tab, const char *name) {
uint32_t h = basScopeHash(name);
for (BasSymT *s = tab->buckets[h & tab->mask]; s != NULL; s = s->hashNext) {
if (s->hash == h && basScopeNamesEqual(s->name, name)) {
return s;
}
}
return NULL;
}
BasSymT *basScopeFindKind(const BasScopeTabT *tab, const char *name, uint8_t kind) {
uint32_t h = basScopeHash(name);
for (BasSymT *s = tab->buckets[h & tab->mask]; s != NULL; s = s->hashNext) {
if (s->hash == h && s->kind == kind && basScopeNamesEqual(s->name, name)) {
return s;
}
}
return NULL;
}
uint32_t basScopeHash(const char *name) {
uint32_t h = BAS_FNV1A_OFFSET;
for (; *name != '\0'; name++) {
h ^= (uint32_t)(uint8_t)basAsciiUpper(*name);
h *= BAS_FNV1A_PRIME;
}
return h;
}
bool basScopeInit(BasScopeTabT *tab, BasArenaT *arena, uint32_t buckets) {
memset(tab, 0, sizeof(*tab));
tab->buckets = (BasSymT **)basArenaAlloc(arena, (int32_t)(buckets * sizeof(BasSymT *)));
tab->mask = buckets - 1;
return tab->buckets != NULL;
}
bool basScopeNamesEqual(const char *a, const char *b) {
for (; *a != '\0' && *b != '\0'; a++, b++) {
if (basAsciiUpper(*a) != basAsciiUpper(*b)) {
return false;
}
}
return *a == *b;
}

308
src/apps/kpunch/dvxbasic/compiler/scope.h Normal file
View file

@ -0,0 +1,308 @@
// 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.
// scope.h -- DVX BASIC compiler symbols and scopes
//
// A scope is a hash table of symbols plus their creation order. The
// compiler keeps one module scope (globals, procedures, constants, TYPEs,
// ENUMs, class modules and their members as "Class.name", the predefined
// constants), one form scope while a form's code is compiled (its form
// variables), one procedure scope while a procedure is compiled (its
// parameters and locals), and label tables for the module and for the
// procedure. Symbols are allocated from an arena: module symbols live
// as long as the compilation, procedure symbols as long as the
// procedure's unit.
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_SCOPE_H
#define DVXBASIC_SCOPE_H
#include "ast.h"
#include "codegen.h"
#include "opcodes.h"
#include "../runtime/vm.h"
#include <stdbool.h>
#include <stdint.h>
// Most parameters a SUB / FUNCTION declares.
#define BAS_MAX_PARAMS 16
// Longest string a CONST may hold.
#define BAS_MAX_CONST_STR 256
// Hash buckets per scope (powers of two).
#define BAS_MODULE_BUCKETS 256
#define BAS_LOCAL_BUCKETS 64
// objClass of an object declared As Collection (a class module has its
// number there; BAS_CLASS_NONE (vm.h): no class, e.g. As Object).
#define BAS_CLASS_COLLECTION (-2)
// Qualified names of class module symbols: "Class.Member", and the
// Property Let / Set procedures "Class.Member.Let" / "Class.Member.Set"
// (Property Get takes the plain qualified name).
#define BAS_CLASS_SEP BAS_MEMBER_QUALIFIER
#define BAS_PROP_LET_SUFFIX ".Let"
#define BAS_PROP_SET_SUFFIX ".Set"
typedef enum {
SK_VAR,
SK_CONST,
SK_SUB,
SK_FUNCTION,
SK_LABEL,
SK_TYPE,
SK_ENUM,
SK_CLASS,
SK_CONTROL // a control of the form being compiled (its BEGINFORM list)
} BasSymKindE;
// BasSymT.flags
#define SF_DEFINED 0x00000001u // procedure body / label / ENUM / class seen (else forward or declared only)
#define SF_ARRAY 0x00000002u
#define SF_DYNAMIC 0x00000004u // array declared without bounds: ERASE frees it
#define SF_SHARED 0x00000008u // module variable visible inside procedures
#define SF_TYPED 0x00000010u // declared with a type (AS, suffix or DEFxxx): stores convert to it
#define SF_IMPLICIT 0x00000020u // created by first use (a STRING local needs its "" at entry)
#define SF_ALIAS 0x00000040u // procedure name for a module slot (STATIC, SHARED): aliasScope / index
#define SF_EXTERN 0x00000080u // DECLARE LIBRARY function
#define SF_HASSIG 0x00000100u // signature known (prescan, DECLARE or definition)
#define SF_PRIVATE 0x00000200u // class member declared Private
#define SF_PROPERTY 0x00000400u // Property Get / Let / Set
#define SF_PARAMARRAY 0x00000800u // the last parameter is a ParamArray
#define SF_PARAMARRAYTYPED 0x00001000u // ... with a declared element type
#define SF_ENUMMEMBER 0x00002000u // CONST that is the bare name of an ENUM member
#define SF_AMBIGUOUS 0x00004000u // ENUM member name of two ENUMs: only usable qualified
#define SF_HIDDEN 0x00008000u // compiler variable (FOR EACH): no debug entry
#define SF_PARAM 0x00010000u // a procedure parameter
#define SF_DEFFN 0x00020000u // a DEF FN function
#define SF_PREDECLARED 0x00040000u // class member variable the declaration pass made: its DIM is not compiled yet
#define SF_STATIC 0x00080000u // hidden member variable holding a class procedure's STATIC variable (one per object)
#define SF_FRIEND 0x00100000u // class procedure declared Friend: bound by the compiler, not found by late binding
#define SF_BYREF 0x00200000u // a parameter passed by reference: it may name a Variant variable, so its type is not known statically
// BasProcInfoT.paramFlags
#define PARAM_BYVAL 0x01
#define PARAM_OPTIONAL 0x02
#define PARAM_DEFAULT 0x04 // Optional with "= default": an omitted argument is Missing, the procedure stores the default
#define PARAM_TYPED 0x08 // a scalar declared with a type (AS, suffix or DEFxxx): arguments are converted to it
// A folded constant: a CONST's value, an ENUM member, an Optional
// default. Integer results are LONG.
typedef struct {
double dblVal; // every numeric type and DATE
int64_t curVal; // CURRENCY: the exact amount times BAS_CURRENCY_SCALE
int32_t intVal; // INTEGER / LONG / BOOLEAN / BYTE
int32_t strLen; // STRING (may hold NULs)
const char *str; // STRING text (arena)
uint8_t dataType; // BAS_TYPE_* (BAS_TYPE_OBJECT: Nothing)
} BasConstValT;
// BasConstValT.dataType of an Optional default not evaluated yet (the
// declaration pass takes only literals; the definition evaluates every
// one). No folded constant is a Variant.
#define BAS_DEFAULT_PENDING BAS_TYPE_VARIANT
// A SUB / FUNCTION's signature and code.
typedef struct {
int32_t codeAddr;
int32_t *patches; // stb_ds: OP_CALL operands waiting for codeAddr
bool hasCode; // codeAddr is known (the body was generated)
int32_t localCount;
int32_t refLine; // first call made before the definition (Undefined Sub errors)
int16_t paramCount;
int16_t requiredParams; // up to the last non-Optional parameter
uint16_t externLibIdx; // DECLARE LIBRARY: constant pool indices
uint16_t externFuncIdx;
uint8_t paramTypes[BAS_MAX_PARAMS];
uint8_t paramFlags[BAS_MAX_PARAMS]; // PARAM_*
BasConstValT *defaults; // arena: per parameter (only PARAM_DEFAULT ones used, BAS_DEFAULT_PENDING until evaluated); NULL when none
int16_t *paramClasses; // arena: per parameter, an object parameter's class (BAS_CLASS_COLLECTION; BAS_CLASS_NONE: any object); NULL when no parameter is declared As a class or Collection
const char **paramNames; // module arena: per parameter, its name (arguments given by name: Name:=value)
BasSlotInitT *localInits; // module arena: the locals that start as their type's zero (the result, typed scalars), set when it is entered
int32_t localInitCount;
} BasProcInfoT;
// A label's code position and the jumps waiting for it.
typedef struct {
int32_t codeAddr;
int32_t dataIndex; // the DATA items before it (RESTORE label), once hasCode
int32_t *dataPatches; // stb_ds: RESTORE operands waiting for dataIndex
int32_t *patches; // stb_ds: jump operands waiting for codeAddr
int32_t *patchDepths; // stb_ds, parallel to patches: SELECT depth at a GOTO whose pops wait for the label (NOP placeholders); -1 for other jumps
int32_t selectDepth; // SELECT CASE blocks open at the label
int32_t refLine; // first reference (Label not defined errors)
bool hasCode; // codeAddr is known
} BasLabelInfoT;
// What a STATIC array or TYPE is allocated as, once (a procedure's
// variable: at its first call; a class procedure's: with each object):
// an array of dims dimensions with constant bounds, or for dims 0 a TYPE
// instance. A STATIC array declared without bounds is REDIM'd by the
// procedure and has none (u.alloc NULL).
typedef struct {
int32_t dims;
int32_t lower[BAS_ARRAY_MAX_DIMS];
int32_t upper[BAS_ARRAY_MAX_DIMS];
} BasStaticAllocT;
typedef struct BasSymS {
struct BasSymS *hashNext; // hash chain, newest first
struct BasSymS *orderNext; // creation order in its scope
const char *name; // as declared ("Class.name" for class members)
const char *formName; // form owning a form variable or procedure (NULL: none)
uint32_t hash;
uint32_t flags; // SF_*
int32_t index; // variable slot; TYPE id; class number
int32_t udtTypeId; // BAS_TYPE_UDT variables, FUNCTION results
int32_t fixedLen; // STRING * n
int32_t objClass; // declared As a class: its number, BAS_CLASS_COLLECTION, else BAS_CLASS_NONE
int32_t ownerClass; // class module a procedure or member variable belongs to (BAS_CLASS_NONE)
int32_t line; // declaration line
union {
BasProcInfoT *proc; // SK_SUB / SK_FUNCTION
BasConstValT *cval; // SK_CONST
BasLabelInfoT *label; // SK_LABEL
BasStaticAllocT *alloc; // SK_VAR: a STATIC array with bounds or TYPE (the slot and its alias)
} u;
uint8_t kind; // BasSymKindE
uint8_t scope; // BasScopeE of the storage (SK_VAR); SCOPE_GLOBAL otherwise
uint8_t dataType; // BAS_TYPE_*
uint8_t aliasScope; // SF_ALIAS: BasScopeE of the slot it names
} BasSymT;
typedef struct {
BasSymT **buckets; // hash chains
BasSymT *first; // creation order
BasSymT *last;
uint32_t mask; // bucket count - 1
int32_t count;
} BasScopeTabT;
// A field of a TYPE.
typedef struct {
const char *name;
int32_t udtTypeId; // BAS_TYPE_UDT field: its TYPE
int32_t fixedLen; // STRING * n (0: variable length)
uint8_t dataType;
} BasFieldT;
typedef struct {
BasSymT *sym;
BasFieldT *fields; // stb_ds
int32_t fieldCount;
bool defined; // its TYPE ... END TYPE was compiled
} BasTypeDefT;
// A public member of a class module.
typedef struct {
const char *name; // as programs write it (obj.name), or "Iface.name"
BasSymT *sym; // procedure or member variable
uint8_t kind; // BasMemberKindE
} BasClassMemberDefT;
// An Event a class module declares.
typedef struct {
const char *name;
int32_t paramCount;
uint8_t paramTypes[BAS_MAX_PARAMS];
uint8_t paramFlags[BAS_MAX_PARAMS]; // PARAM_BYVAL, PARAM_TYPED
} BasEventDefT;
typedef struct {
const char *name;
const char *defaultMember; // Attribute Name.VB_UserMemId = 0 (NULL: none)
BasClassMemberDefT *members; // stb_ds, public members in declaration order
BasEventDefT *events; // stb_ds
int32_t *implements; // stb_ds, class numbers
BasSymT *terminateSym; // Class_Terminate (NULL: none)
int32_t varCount;
int32_t declaredVars; // member variables the declaration pass gave slots (the first slots)
int32_t initCodeAddr;
int32_t implementsLine;
bool defined;
bool isInterface; // some class Implements it
} BasClassDefT;
// A class member variable the declaration pass read (registered once
// every procedure header is known, so a name taken by a procedure stays
// the procedure's).
typedef struct {
const char *name; // module arena
int32_t classIdx;
int32_t udtTypeId;
int32_t objClass;
int32_t fixedLen;
uint32_t flags; // SF_ARRAY, SF_DYNAMIC, SF_TYPED, SF_PRIVATE
uint8_t dataType;
} BasMemberVarDeclT;
// An early-bound member operand waiting for the member's index in its
// class's public member table (known once every class is compiled).
typedef struct {
int32_t pos; // code position of the uint16 member operand
int32_t classIdx;
const BasSymT *sym; // the member: a variable or procedure of the class
} BasMemberPatchT;
typedef struct {
int32_t eventIdx;
BasSymT *proc;
} BasEventHandlerDefT;
// A variable declared WithEvents.
typedef struct {
BasSymT *var;
const char *formName; // NULL: not a form variable
BasEventHandlerDefT *handlers; // stb_ds, found at the end of the compilation
int32_t classIdx;
int32_t ownerClass; // BAS_CLASS_NONE unless a class member variable
int32_t line;
} BasWithEventsDefT;
// ============================================================
// API
// ============================================================
// A symbol named name (copied into arena) of kind added to tab, or NULL
// when memory runs out. Duplicates are the caller's business.
BasSymT *basScopeAdd(BasScopeTabT *tab, BasArenaT *arena, const char *name, uint8_t kind, uint8_t dataType);
// Case-insensitive lookup: the newest symbol named name, or NULL.
BasSymT *basScopeFind(const BasScopeTabT *tab, const char *name);
// The newest symbol named name of kind (labels share no names with the rest), or NULL.
BasSymT *basScopeFindKind(const BasScopeTabT *tab, const char *name, uint8_t kind);
// Empty table with buckets (a power of two) bucket chains; false when
// memory runs out.
bool basScopeInit(BasScopeTabT *tab, BasArenaT *arena, uint32_t buckets);
// Case-insensitive FNV-1a hash of name.
uint32_t basScopeHash(const char *name);
// Case-insensitive name comparison.
bool basScopeNamesEqual(const char *a, const char *b);
#endif // DVXBASIC_SCOPE_H

472
src/apps/kpunch/dvxbasic/compiler/symtab.c
View file

@ -1,472 +0,0 @@
// 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.
// symtab.c -- DVX BASIC symbol table implementation
#include "symtab.h"
#include "thirdparty/stb_ds_wrap.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
// Function prototypes (alphabetical)
static void basSymbolFree(BasSymbolT *sym);
BasSymbolT *basSymTabAdd(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType);
int32_t basSymTabAddClass(BasSymTabT *tab, const char *name);
BasSymbolT *basSymTabAddGlobal(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType);
BasSymbolT *basSymTabAddModuleVar(BasSymTabT *tab, const char *name, uint8_t dataType);
int32_t basSymTabAllocGlobalSlot(BasSymTabT *tab);
int32_t basSymTabAllocSlot(BasSymTabT *tab);
BasScopeE basSymTabCurrentScope(const BasSymTabT *tab, BasSymKindE kind);
void basSymTabEnterClassScope(BasSymTabT *tab, int32_t classIdx);
void basSymTabEnterFormScope(BasSymTabT *tab, const char *formName);
void basSymTabEnterLocal(BasSymTabT *tab);
BasSymbolT *basSymTabFind(BasSymTabT *tab, const char *name);
BasClassDefT *basSymTabFindClass(BasSymTabT *tab, const char *name, int32_t *outIdx);
BasSymbolT *basSymTabFindGlobal(BasSymTabT *tab, const char *name);
BasSymbolT *basSymTabFindLabel(BasSymTabT *tab, const char *name);
BasSymbolT *basSymTabFindModuleVar(BasSymTabT *tab, const char *name);
void basSymTabFree(BasSymTabT *tab);
void basSymTabInit(BasSymTabT *tab);
int32_t basSymTabLeaveClassScope(BasSymTabT *tab);
int32_t basSymTabLeaveFormScope(BasSymTabT *tab);
void basSymTabLeaveLocal(BasSymTabT *tab);
bool basSymTabQualify(const BasSymTabT *tab, int32_t classIdx, const char *name, char *out, int32_t outSize);
static BasSymbolT **bucketFor(BasSymTabT *tab, uint32_t hash);
static BasSymbolT *findInScope(BasSymTabT *tab, const char *name, BasScopeE scope, bool isLabel);
static BasSymbolT *findModuleSymbol(BasSymTabT *tab, const char *name, bool includeHidden);
static BasSymbolT *findSymbol(BasSymTabT *tab, const char *name, bool includeHidden);
static uint32_t nameHashCI(const char *name);
static bool namesEqual(const char *a, const char *b);
static BasSymbolT *symTabAddScoped(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType, BasScopeE scope);
static void unlinkSymbol(BasSymTabT *tab, BasSymbolT *sym);
// ============================================================
// Free a single symbol: its dynamic arrays and the struct itself.
// ============================================================
static void basSymbolFree(BasSymbolT *sym) {
arrfree(sym->patchAddrs);
arrfree(sym->fields);
free(sym);
}
BasSymbolT *basSymTabAdd(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType) {
return symTabAddScoped(tab, name, kind, dataType, basSymTabCurrentScope(tab, kind));
}
int32_t basSymTabAddClass(BasSymTabT *tab, const char *name) {
BasSymbolT *sym = symTabAddScoped(tab, name, SYM_CLASS, BAS_TYPE_OBJECT, SCOPE_GLOBAL);
if (sym == NULL) {
return -1;
}
BasClassDefT def;
memset(&def, 0, sizeof(def));
snprintf(def.name, sizeof(def.name), "%s", name);
def.initCodeAddr = -1;
sym->index = (int32_t)arrlen(tab->classes);
arrput(tab->classes, def);
return sym->index;
}
BasSymbolT *basSymTabAddGlobal(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType) {
return symTabAddScoped(tab, name, kind, dataType, SCOPE_GLOBAL);
}
BasSymbolT *basSymTabAddModuleVar(BasSymTabT *tab, const char *name, uint8_t dataType) {
BasScopeE scope = tab->inFormScope ? SCOPE_FORM : SCOPE_GLOBAL;
BasSymbolT *sym = symTabAddScoped(tab, name, SYM_VARIABLE, dataType, scope);
if (sym != NULL) {
sym->index = tab->inFormScope ? tab->nextFormVarIdx++ : tab->nextGlobalIdx++;
}
return sym;
}
int32_t basSymTabAllocGlobalSlot(BasSymTabT *tab) {
return tab->nextGlobalIdx++;
}
int32_t basSymTabAllocSlot(BasSymTabT *tab) {
if (tab->inLocalScope) {
return tab->nextLocalIdx++;
}
if (tab->inClassScope) {
return tab->nextMemberIdx++;
}
if (tab->inFormScope) {
return tab->nextFormVarIdx++;
}
return tab->nextGlobalIdx++;
}
// Local > member > form > global. Only variables get SCOPE_MEMBER or
// SCOPE_FORM; SUBs, FUNCTIONs, CONSTs and labels declared in a class or
// form scope remain global.
BasScopeE basSymTabCurrentScope(const BasSymTabT *tab, BasSymKindE kind) {
if (tab->inLocalScope) {
return SCOPE_LOCAL;
}
if (tab->inClassScope && kind == SYM_VARIABLE) {
return SCOPE_MEMBER;
}
if (tab->inFormScope && kind == SYM_VARIABLE) {
return SCOPE_FORM;
}
return SCOPE_GLOBAL;
}
void basSymTabEnterClassScope(BasSymTabT *tab, int32_t classIdx) {
tab->inClassScope = true;
tab->classIdx = classIdx;
tab->nextMemberIdx = 0;
}
void basSymTabEnterFormScope(BasSymTabT *tab, const char *formName) {
tab->inFormScope = true;
strncpy(tab->formScopeName, formName, BAS_MAX_IDENT - 1);
tab->formScopeName[BAS_MAX_IDENT - 1] = '\0';
tab->nextFormVarIdx = 0;
tab->formScopeSymStart = tab->count;
}
void basSymTabEnterLocal(BasSymTabT *tab) {
tab->inLocalScope = true;
tab->hideUnshared = true;
tab->nextLocalIdx = 0;
}
BasSymbolT *basSymTabFind(BasSymTabT *tab, const char *name) {
return findSymbol(tab, name, false);
}
BasClassDefT *basSymTabFindClass(BasSymTabT *tab, const char *name, int32_t *outIdx) {
BasSymbolT *sym = findInScope(tab, name, SCOPE_GLOBAL, false);
if (sym == NULL || sym->kind != SYM_CLASS) {
return NULL;
}
if (outIdx != NULL) {
*outIdx = sym->index;
}
return &tab->classes[sym->index];
}
BasSymbolT *basSymTabFindGlobal(BasSymTabT *tab, const char *name) {
return findInScope(tab, name, SCOPE_GLOBAL, false);
}
BasSymbolT *basSymTabFindLabel(BasSymTabT *tab, const char *name) {
return findInScope(tab, name, tab->inLocalScope ? SCOPE_LOCAL : SCOPE_GLOBAL, true);
}
BasSymbolT *basSymTabFindModuleVar(BasSymTabT *tab, const char *name) {
BasSymbolT *sym = findSymbol(tab, name, true);
return (sym != NULL && sym->kind == SYM_VARIABLE && sym->scope != SCOPE_LOCAL) ? sym : NULL;
}
void basSymTabFree(BasSymTabT *tab) {
// Free every remaining symbol's dynamic arrays and the struct, then
// release the symbol-pointer array itself.
for (int32_t i = 0; i < tab->count; i++) {
basSymbolFree(tab->symbols[i]);
}
arrfree(tab->symbols);
tab->symbols = NULL;
tab->count = 0;
memset(tab->buckets, 0, sizeof(tab->buckets));
for (int32_t i = 0; i < (int32_t)arrlen(tab->classes); i++) {
arrfree(tab->classes[i].members);
}
arrfree(tab->classes);
tab->classes = NULL;
}
void basSymTabInit(BasSymTabT *tab) {
memset(tab, 0, sizeof(*tab));
}
int32_t basSymTabLeaveClassScope(BasSymTabT *tab) {
int32_t varCount = tab->nextMemberIdx;
tab->inClassScope = false;
tab->classIdx = 0;
tab->nextMemberIdx = 0;
return varCount;
}
int32_t basSymTabLeaveFormScope(BasSymTabT *tab) {
int32_t varCount = tab->nextFormVarIdx;
// Mark all form-scope symbols added since BEGINFORM as ended
for (int32_t i = tab->formScopeSymStart; i < tab->count; i++) {
if (tab->symbols[i]->scope == SCOPE_FORM) {
tab->symbols[i]->formScopeEnded = true;
}
}
tab->inFormScope = false;
tab->formScopeName[0] = '\0';
tab->nextFormVarIdx = 0;
tab->formScopeSymStart = 0;
return varCount;
}
void basSymTabLeaveLocal(BasSymTabT *tab) {
// Remove all local symbols, freeing their dynamic arrays and the
// symbol struct itself.
int32_t newCount = 0;
for (int32_t i = 0; i < tab->count; i++) {
if (tab->symbols[i]->scope == SCOPE_LOCAL) {
unlinkSymbol(tab, tab->symbols[i]);
basSymbolFree(tab->symbols[i]);
} else {
tab->symbols[newCount] = tab->symbols[i];
newCount++;
}
}
arrsetlen(tab->symbols, newCount);
tab->count = newCount;
tab->inLocalScope = false;
tab->hideUnshared = false;
tab->nextLocalIdx = 0;
}
bool basSymTabQualify(const BasSymTabT *tab, int32_t classIdx, const char *name, char *out, int32_t outSize) {
int n = snprintf(out, outSize, "%s" BAS_CLASS_SEP "%s", tab->classes[classIdx].name, name);
return n > 0 && n < outSize;
}
static BasSymbolT **bucketFor(BasSymTabT *tab, uint32_t hash) {
return &tab->buckets[hash & (BAS_SYMTAB_BUCKETS - 1)];
}
// The live symbol named name in exactly one scope and namespace (labels
// or everything else), or NULL.
static BasSymbolT *findInScope(BasSymTabT *tab, const char *name, BasScopeE scope, bool isLabel) {
uint32_t h = nameHashCI(name);
for (BasSymbolT *s = *bucketFor(tab, h); s != NULL; s = s->hashNext) {
if (s->nameHash == h && !s->formScopeEnded && s->scope == scope && (s->kind == SYM_LABEL) == isLabel && namesEqual(s->name, name)) {
return s;
}
}
return NULL;
}
// Module-level (non-local, non-label) lookup of exactly name. A module
// variable that is not SHARED is skipped inside a procedure unless
// includeHidden; a class's member variables are always visible to it.
static BasSymbolT *findModuleSymbol(BasSymTabT *tab, const char *name, bool includeHidden) {
uint32_t h = nameHashCI(name);
bool hide = tab->hideUnshared && !includeHidden;
for (BasSymbolT *s = *bucketFor(tab, h); s != NULL; s = s->hashNext) {
if (s->nameHash != h || s->formScopeEnded || s->kind == SYM_LABEL || s->scope == SCOPE_LOCAL || !namesEqual(s->name, name)) {
continue;
}
if (hide && s->kind == SYM_VARIABLE && !s->isShared && s->scope != SCOPE_MEMBER) {
continue;
}
return s;
}
return NULL;
}
// Non-label lookup: local scope first, then (in a class module) the
// class's own "Class.name", then form and global. Chains run newest
// first, so the most recent declaration wins.
static BasSymbolT *findSymbol(BasSymTabT *tab, const char *name, bool includeHidden) {
if (tab->inLocalScope) {
uint32_t h = nameHashCI(name);
for (BasSymbolT *s = *bucketFor(tab, h); s != NULL; s = s->hashNext) {
if (s->nameHash == h && s->scope == SCOPE_LOCAL && s->kind != SYM_LABEL && namesEqual(s->name, name)) {
return s;
}
}
}
char qualified[BAS_MAX_IDENT];
if (tab->inClassScope && basSymTabQualify(tab, tab->classIdx, name, qualified, (int32_t)sizeof(qualified))) {
BasSymbolT *member = findModuleSymbol(tab, qualified, includeHidden);
if (member != NULL) {
return member;
}
}
return findModuleSymbol(tab, name, includeHidden);
}
// ============================================================
// Case-insensitive FNV-1a hash used to accelerate symbol-table lookups.
// Caller computes hash of search-name once; each entry stores its own
// precomputed hash, so per-entry comparison is a fast uint32 compare
// that nearly always rejects non-matches without calling namesEqual.
// ============================================================
static uint32_t nameHashCI(const char *name) {
uint32_t h = BAS_FNV1A_OFFSET;
while (*name) {
char c = basAsciiUpper(*name);
h ^= (uint32_t)(uint8_t)c;
h *= BAS_FNV1A_PRIME;
name++;
}
return h;
}
// ============================================================
// Case-insensitive name comparison
// ============================================================
static bool namesEqual(const char *a, const char *b) {
while (*a && *b) {
char ca = basAsciiUpper(*a);
char cb = basAsciiUpper(*b);
if (ca != cb) {
return false;
}
a++;
b++;
}
return *a == *b;
}
static BasSymbolT *symTabAddScoped(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType, BasScopeE scope) {
// Never truncate: a clipped name would hash and compare differently
// from every later reference, silently splitting one variable in two.
if (strlen(name) >= BAS_MAX_IDENT) {
return NULL;
}
if (findInScope(tab, name, scope, kind == SYM_LABEL) != NULL) {
return NULL; // duplicate
}
BasSymbolT *sym = (BasSymbolT *)calloc(1, sizeof(BasSymbolT));
if (!sym) {
return NULL;
}
strcpy(sym->name, name);
sym->nameHash = nameHashCI(name);
sym->kind = kind;
sym->scope = scope;
sym->dataType = dataType;
sym->isDefined = true;
sym->ownerClass = BAS_CLASS_NONE;
sym->objClass = BAS_CLASS_NONE;
// Record owning form for both SCOPE_FORM vars AND SUBs/FUNCTIONs
// declared inside BEGINFORM...ENDFORM. SUBs stay at SCOPE_GLOBAL
// (callable from anywhere) but carry the owning form so the VM can
// bind form-scope vars correctly when the SUB is dispatched as an
// event handler for a different form's control.
if (tab->inFormScope && tab->formScopeName[0] && (scope == SCOPE_FORM || kind == SYM_SUB || kind == SYM_FUNCTION)) {
strncpy(sym->formName, tab->formScopeName, BAS_MAX_IDENT - 1);
sym->formName[BAS_MAX_IDENT - 1] = '\0';
}
BasSymbolT **bucket = bucketFor(tab, sym->nameHash);
sym->hashNext = *bucket;
*bucket = sym;
arrput(tab->symbols, sym);
tab->count = (int32_t)arrlen(tab->symbols);
return sym;
}
// Remove sym from its hash chain (before it is freed).
static void unlinkSymbol(BasSymTabT *tab, BasSymbolT *sym) {
BasSymbolT **link = bucketFor(tab, sym->nameHash);
while (*link != NULL && *link != sym) {
link = &(*link)->hashNext;
}
if (*link == sym) {
*link = sym->hashNext;
}
}

307
src/apps/kpunch/dvxbasic/compiler/symtab.h
View file

@ -1,307 +0,0 @@
// 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.
// symtab.h -- DVX BASIC symbol table
//
// Tracks variables, constants, subroutines, functions, and labels
// during compilation. Supports nested scopes (global + one local
// scope per SUB/FUNCTION).
//
// Embeddable: no DVX dependencies, pure C.
#ifndef DVXBASIC_SYMTAB_H
#define DVXBASIC_SYMTAB_H
#include "../compiler/opcodes.h"
#include "../compiler/lexer.h"
#include "../runtime/vm.h"
#include <stdint.h>
#include <stdbool.h>
// ============================================================
// Symbol kinds
// ============================================================
typedef enum {
SYM_VARIABLE,
SYM_CONST,
SYM_SUB,
SYM_FUNCTION,
SYM_LABEL,
SYM_TYPE_DEF, // user-defined TYPE
SYM_ENUM, // ENUM name (a LONG type); members are SYM_CONSTs
SYM_CLASS // class module name (index = class number)
} BasSymKindE;
// objClass of an object variable declared As Collection (a class module
// has its index there; BAS_CLASS_NONE: no class, e.g. As Object).
#define BAS_CLASS_NONE (-1)
#define BAS_CLASS_COLLECTION (-2)
// Qualified names of class module symbols: "Class.Member", and the
// Property Let / Set procedures of a property "Class.Member.Let" /
// "Class.Member.Set" (Property Get takes the plain qualified name).
#define BAS_CLASS_SEP "."
#define BAS_PROP_LET_SUFFIX ".Let"
#define BAS_PROP_SET_SUFFIX ".Set"
// BasScopeE moved to opcodes.h (shared with runtime).
// ============================================================
// Symbol entry
// ============================================================
// Symbol names share BAS_MAX_IDENT (vm.h) with every name buffer they are
// copied into; CONST strings are copied straight from a token, so that
// limit is defined in terms of the token buffer.
#define BAS_MAX_PARAMS 16
#define BAS_MAX_CONST_STR BAS_MAX_TOKEN_LEN // max CONST string-literal length
// FNV-1a parameters shared by the case-insensitive symbol hash (symtab.c)
// and the constant-pool interning hash (codegen.c).
#define BAS_FNV1A_OFFSET 0x811C9DC5u
#define BAS_FNV1A_PRIME 0x01000193u
// Hash buckets of the symbol table (power of two; the name hash is masked
// with BAS_SYMTAB_BUCKETS - 1).
#define BAS_SYMTAB_BUCKETS 256
// UDT field definition
typedef struct {
char name[BAS_MAX_IDENT];
uint8_t dataType; // BAS_TYPE_*
int32_t udtTypeId; // if dataType == BAS_TYPE_UDT, index of the TYPE_DEF symbol
int32_t fixedLen; // for STRING * n fields: fixed length (0 = variable-length)
} BasFieldDefT;
typedef struct BasSymbolS {
// Fields are ordered by alignment (4-byte, then 2-byte, then 1-byte) to
// minimize struct padding on the 32-bit target.
uint32_t nameHash; // FNV-1a over uppercase(name); fast-reject during lookup
struct BasSymbolS *hashNext; // next (older) symbol in the same hash bucket
BasSymKindE kind;
BasScopeE scope;
int32_t index; // slot index (local or global)
int32_t codeAddr; // PC address for SUB/FUNCTION/LABEL
int32_t localCount; // SUB/FUNCTION: local variable count (set on leave); LABEL: SELECT depth at the definition
int32_t udtTypeId; // for variables of BAS_TYPE_UDT: index of TYPE_DEF symbol
int32_t fixedLen; // for STRING * n: fixed length (0 = variable-length)
int32_t refLine; // LABEL/SUB/FUNCTION: source line of the first reference made before the definition
int32_t ownerClass; // class module a procedure or member variable belongs to (BAS_CLASS_NONE: none)
int32_t objClass; // object variable / FUNCTION / Property Get declared As a class: its index, BAS_CLASS_COLLECTION, else BAS_CLASS_NONE
// For SUB/FUNCTION: parameter info
int32_t paramCount;
int32_t requiredParams; // count of non-optional params
// Forward-reference backpatch list (code addresses to patch when
// defined); emptied once the patches are applied.
int32_t *patchAddrs; // stb_ds dynamic array
// For CONST: the constant value
union {
int32_t constInt;
double constDbl;
};
int32_t constStrLen; // STRING CONST: length of constStr (it may hold NULs)
// For TYPE_DEF: field definitions
BasFieldDefT *fields; // stb_ds dynamic array
int32_t fieldCount;
uint16_t externLibIdx; // constant pool index for library name (if isExtern)
uint16_t externFuncIdx; // constant pool index for function name (if isExtern)
uint8_t dataType; // BAS_TYPE_* for variables/functions
bool isDefined; // false = forward-declared
bool isArray;
bool isDynamic; // array declared without bounds (DIM a(), array parameter, or created by REDIM): ERASE frees it
bool isShared;
bool isExtern; // true = external library function (DECLARE LIBRARY)
bool formScopeEnded; // true = form scope ended, invisible to lookups
bool hasSignature; // true once paramCount/paramTypes describe the real declaration (false for a call-site stub)
bool isImplicit; // variable created by first use (no DIM); STRING locals need a prologue init
bool isTyped; // variable declared with an explicit numeric type (suffix, AS clause or DEFxxx); stores convert to it
bool isAlias; // procedure-local name for a module slot (STATIC backing variable or SHARED statement): lives in aliasScope slot 'index'
uint8_t aliasScope; // BasScopeE of the slot an alias addresses (SCOPE_GLOBAL or SCOPE_FORM)
bool hasParamArray; // SUB/FUNCTION: the last parameter is a ParamArray (paramTypes[paramCount - 1] is its element type)
bool paramArrayTyped; // the ParamArray has a declared type: each argument is converted to it (else it keeps its own type)
bool isEnumMember; // CONST that is the unqualified name of an ENUM member
bool isAmbiguous; // ENUM member name shared by two ENUMs: usable only qualified (EnumName.Member)
bool isPrivate; // class module member declared Private (not reachable through an object)
bool isProperty; // Property Get / Let / Set procedure
char name[BAS_MAX_IDENT];
char formName[BAS_MAX_IDENT]; // form name for SCOPE_FORM vars
uint8_t paramTypes[BAS_MAX_PARAMS];
bool paramByVal[BAS_MAX_PARAMS];
bool paramOptional[BAS_MAX_PARAMS]; // true = OPTIONAL parameter
char constStr[BAS_MAX_CONST_STR];
} BasSymbolT;
// ============================================================
// Class modules
// ============================================================
// A public member of a class module, recorded as it is declared.
typedef struct {
char name[BAS_MAX_IDENT]; // as the program uses it (obj.name)
BasSymbolT *sym; // the procedure or member variable
uint8_t kind; // BasMemberKindE
} BasClassMemberDefT;
// A class module (BEGINCLASS "name" ... ENDCLASS). The prescan registers
// every class so code before the class can use its name as a type.
typedef struct {
char name[BAS_MAX_IDENT];
char defaultMember[BAS_MAX_IDENT]; // Attribute Name.VB_UserMemId = 0 ("" = none)
BasClassMemberDefT *members; // stb_ds array, public members in declaration order
int32_t varCount; // member variables per instance (set at ENDCLASS)
int32_t initCodeAddr; // instance set-up code (member variables, then Class_Initialize)
BasSymbolT *terminateSym; // Class_Terminate, NULL = none
bool defined; // its BEGINCLASS was compiled (a second one is a duplicate)
} BasClassDefT;
// ============================================================
// Symbol table
// ============================================================
typedef struct {
// Array of POINTERS to heap-allocated symbols (stb_ds array of pointers).
// Pointers-of-pointers rather than array-of-structs because callers
// routinely hold a BasSymbolT * across parsing operations that may
// trigger basSymTabAdd (which grows this array). An array of structs
// would be reallocated on growth, invalidating any held pointer.
// Indirection via a stable heap pointer per symbol avoids that.
BasSymbolT **symbols;
BasSymbolT *buckets[BAS_SYMTAB_BUCKETS]; // hash chains, newest symbol first
int32_t count;
int32_t nextGlobalIdx; // next global variable slot
int32_t nextLocalIdx; // next local variable slot (reset per SUB/FUNCTION)
bool inLocalScope; // true when inside SUB/FUNCTION
bool hideUnshared; // inside a SUB/FUNCTION: module variables are visible only when SHARED (off for a DEF FN body)
bool inFormScope; // true inside BEGINFORM...ENDFORM
char formScopeName[BAS_MAX_IDENT]; // current form name
int32_t nextFormVarIdx; // next form-level variable slot
int32_t formScopeSymStart; // symbol count at BEGINFORM (for marking ended)
bool inClassScope; // true inside BEGINCLASS...ENDCLASS
int32_t classIdx; // the class being compiled (valid while inClassScope)
int32_t nextMemberIdx; // next member variable slot of that class
BasClassDefT *classes; // stb_ds array, indexed by class number
} BasSymTabT;
// ============================================================
// API
// ============================================================
void basSymTabInit(BasSymTabT *tab);
// Free all symbols and the symbol array (called at parser teardown).
void basSymTabFree(BasSymTabT *tab);
// Add a symbol in the current scope (local > form > global, see
// basSymTabCurrentScope). Returns the symbol pointer, or NULL if the name
// already exists in that scope, is too long for BasSymbolT.name, or memory
// allocation fails. Names are never truncated: a truncated name would
// hash and compare differently from the source spelling. Labels live in a
// namespace of their own: a label never collides with a variable, CONST,
// SUB or TYPE of the same name.
BasSymbolT *basSymTabAdd(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType);
// Add a symbol in the global scope regardless of the current local/form
// scope (SUB/FUNCTION/TYPE names, STATIC backing variables). The
// duplicate check is made against the global scope.
BasSymbolT *basSymTabAddGlobal(BasSymTabT *tab, const char *name, BasSymKindE kind, uint8_t dataType);
// Add a variable at module level from any scope: a form variable
// (SCOPE_FORM) inside BEGINFORM...ENDFORM, otherwise a global, with its
// slot allocated. Used by SHARED to create a module variable from inside
// a SUB/FUNCTION. NULL as for basSymTabAdd.
BasSymbolT *basSymTabAddModuleVar(BasSymTabT *tab, const char *name, uint8_t dataType);
// Scope a symbol of the given kind would get from basSymTabAdd right now.
BasScopeE basSymTabCurrentScope(const BasSymTabT *tab, BasSymKindE kind);
// Look up a non-label symbol by name. Searches local scope first, then
// form and global. Case-insensitive. Inside a SUB/FUNCTION a module
// (global or form) variable is found only when it was declared SHARED;
// CONSTs, procedures and TYPEs are always visible.
BasSymbolT *basSymTabFind(BasSymTabT *tab, const char *name);
// Like basSymTabFind, but also finds a module variable that the current
// procedure cannot see (not SHARED). For diagnostics and the SHARED
// statement.
BasSymbolT *basSymTabFindModuleVar(BasSymTabT *tab, const char *name);
// Look up a non-label symbol in the global scope only.
BasSymbolT *basSymTabFindGlobal(BasSymTabT *tab, const char *name);
// Look up a label of the current procedure: a local label inside a
// SUB/FUNCTION, a global one at module level. Labels are never visible
// across that boundary.
BasSymbolT *basSymTabFindLabel(BasSymTabT *tab, const char *name);
// Enter local scope (called at SUB/FUNCTION start). Module variables
// that are not SHARED become invisible until basSymTabLeaveLocal.
void basSymTabEnterLocal(BasSymTabT *tab);
// Leave local scope (called at END SUB/FUNCTION). Removes local symbols.
void basSymTabLeaveLocal(BasSymTabT *tab);
// Allocate the next variable slot (global, local, or form depending on scope).
int32_t basSymTabAllocSlot(BasSymTabT *tab);
// Allocate the next global variable slot unconditionally, ignoring the
// current local/form scope flags. Used when a symbol's final scope is
// SCOPE_GLOBAL but the table is currently inside a SUB/FUNCTION or form.
int32_t basSymTabAllocGlobalSlot(BasSymTabT *tab);
// Register class module name (the prescan does, for every BEGINCLASS).
// Returns its class number, or -1 (the name is taken, too long, or out
// of memory).
int32_t basSymTabAddClass(BasSymTabT *tab, const char *name);
// Enter class scope (called at BEGINCLASS): module-level declarations
// create member variables (SCOPE_MEMBER), and names are looked up as
// "Class.name" first.
void basSymTabEnterClassScope(BasSymTabT *tab, int32_t classIdx);
// The class module named name, or NULL.
BasClassDefT *basSymTabFindClass(BasSymTabT *tab, const char *name, int32_t *outIdx);
// Leave class scope (called at ENDCLASS). Returns the number of member
// variables allocated.
int32_t basSymTabLeaveClassScope(BasSymTabT *tab);
// Write "Class.name" for class classIdx into out (outSize bytes); false
// when it does not fit.
bool basSymTabQualify(const BasSymTabT *tab, int32_t classIdx, const char *name, char *out, int32_t outSize);
// Enter form scope (called at BEGINFORM). Form-level DIMs create SCOPE_FORM variables.
void basSymTabEnterFormScope(BasSymTabT *tab, const char *formName);
// Leave form scope (called at ENDFORM). Marks form-scope symbols as ended.
// Returns the number of form variables allocated.
int32_t basSymTabLeaveFormScope(BasSymTabT *tab);
#endif // DVXBASIC_SYMTAB_H

494
src/apps/kpunch/dvxbasic/compiler/typecheck.c Normal file
View file

@ -0,0 +1,494 @@
// 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.
// typecheck.c -- DVX BASIC static types
//
// The VM is dynamically typed: a value's tag decides what an operator
// does, and stores into typed variables convert. This pass records, for
// every expression, the type its value is known to have whatever runs
// (BAS_NODE_TYPE_UNKNOWN when that depends on run time) and folds the
// literal subexpressions (fold.c). The generator then leaves out a
// store's conversion when the value already has the target's type, and
// folds a conversion of a literal into the literal.
//
// Only types that are certain are recorded: a variable's declared type is
// not (a typed variable starts as INTEGER 0 until its first store, and a
// typed parameter holds what the caller passed), so loads stay unknown.
#include "front.h"
// Function prototypes (alphabetical)
bool basStartsTyped(uint8_t dataType);
uint8_t basStaticType(const BasNodeT *n);
void basTypeUnit(BasCompilerT *c, BasNodeT *unit);
static uint8_t binaryType(uint8_t tok, uint8_t a, uint8_t b);
static uint8_t convResultType(uint8_t op, uint8_t operandType);
static uint8_t declaredType(const BasSymT *sym);
static bool isStmtKind(uint8_t kind);
static bool numberType(uint8_t type);
static uint8_t scalarType(uint8_t dataType);
static void typeBounds(BasCompilerT *c, BasNodeT *bounds);
static BasNodeT *typeExpr(BasCompilerT *c, BasNodeT *n);
static void typeList(BasCompilerT *c, BasNodeT **list);
static void typeStatement(BasCompilerT *c, BasNodeT *s);
static void typeStatements(BasCompilerT *c, BasNodeT *list);
static bool wholeType(uint8_t type);
// True for a declared type whose variables start as something other than
// a cleared slot's INTEGER 0 (BasSlotInitT): the other numbers, Boolean,
// Date and String, and Variant (Empty) / Object (Nothing) results.
bool basStartsTyped(uint8_t dataType) {
switch (dataType) {
case BAS_TYPE_LONG:
case BAS_TYPE_SINGLE:
case BAS_TYPE_DOUBLE:
case BAS_TYPE_BOOLEAN:
case BAS_TYPE_DATE:
case BAS_TYPE_STRING:
case BAS_TYPE_VARIANT:
case BAS_TYPE_OBJECT:
case BAS_TYPE_BYTE:
case BAS_TYPE_CURRENCY:
return true;
default:
return false;
}
}
// The type expression n is known to have whatever runs
// (BAS_NODE_TYPE_UNKNOWN when that depends on run time): its recorded
// type (literals, built-ins, conversions), a typed scalar variable,
// element, TYPE field or FUNCTION result (every store into one converts
// to its type and it starts as its type's zero), or an operator on
// operands of known types whose result type the VM fixes (arithmeticType).
// A ByRef parameter may name a Variant variable: not known.
uint8_t basStaticType(const BasNodeT *n) {
if (n == NULL || n->type != BAS_NODE_TYPE_UNKNOWN) {
return (n != NULL) ? n->type : BAS_NODE_TYPE_UNKNOWN;
}
switch (n->kind) {
case NK_VAR: {
const BasSymT *sym = ((const BasNameT *)n)->sym;
return (sym->kind == SK_VAR && !(sym->flags & (SF_ARRAY | SF_BYREF))) ? declaredType(sym) : BAS_NODE_TYPE_UNKNOWN;
}
case NK_RESULT:
return declaredType(((const BasNameT *)n)->sym);
case NK_ELEM: {
const BasNodeT *holder = ((const BasCallT *)n)->callee;
const BasSymT *sym = (holder->kind == NK_VAR) ? ((const BasNameT *)holder)->sym : NULL;
return (sym != NULL && (sym->flags & SF_ARRAY)) ? declaredType(sym) : BAS_NODE_TYPE_UNKNOWN;
}
case NK_FIELD: {
const BasFieldT *field = (const BasFieldT *)((const BasMemberT *)n)->target;
return (field != NULL) ? scalarType(field->dataType) : BAS_NODE_TYPE_UNKNOWN;
}
case NK_FCALL: {
const BasSymT *sym = (const BasSymT *)((const BasCallT *)n)->target;
return (sym != NULL && sym->kind == SK_FUNCTION && !(sym->flags & (SF_EXTERN | SF_DEFFN))) ? declaredType(sym) : BAS_NODE_TYPE_UNKNOWN;
}
case NK_CONV:
return convResultType(((const BasOpT *)n)->op, basStaticType(((const BasOpT *)n)->a));
case NK_BINARY: {
const BasOpT *op = (const BasOpT *)n;
return binaryType(op->op, basStaticType(op->a), basStaticType(op->b));
}
case NK_UNARY: {
const BasOpT *op = (const BasOpT *)n;
uint8_t t = basStaticType(op->a);
// -LONG is a LONG (or an Overflow); -INTEGER may widen
return (op->op == TOK_MINUS && (t == BAS_TYPE_LONG || t == BAS_TYPE_DOUBLE)) ? t : BAS_NODE_TYPE_UNKNOWN;
}
default:
return BAS_NODE_TYPE_UNKNOWN;
}
}
// Types and folds the expressions of a unit (statements in place).
void basTypeUnit(BasCompilerT *c, BasNodeT *unit) {
typeStatement(c, unit);
}
// The type the VM gives binary operator tok on operands of static types a
// and b, or BAS_NODE_TYPE_UNKNOWN: + - * \ MOD on a LONG and an INTEGER /
// LONG / BYTE give a LONG (or an Overflow); + - * on a CURRENCY and a
// CURRENCY or whole number a CURRENCY (or an Overflow), on other numbers
// with a SINGLE / DOUBLE a DOUBLE; / and ^ on numbers a DOUBLE; & and + of
// two strings a string; a comparison of known values a Boolean (no Null).
// Two INTEGERs or BYTEs may widen, so their result type is not known.
static uint8_t binaryType(uint8_t tok, uint8_t a, uint8_t b) {
bool ints = wholeType(a) && wholeType(b);
bool numbers = numberType(a) && numberType(b);
bool isLong = ints && (a == BAS_TYPE_LONG || b == BAS_TYPE_LONG);
bool currency = (a == BAS_TYPE_CURRENCY || b == BAS_TYPE_CURRENCY) && (wholeType(a) || a == BAS_TYPE_CURRENCY) && (wholeType(b) || b == BAS_TYPE_CURRENCY);
switch (tok) {
case TOK_PLUS:
if (a == BAS_TYPE_STRING && b == BAS_TYPE_STRING) {
return BAS_TYPE_STRING;
}
// fall through
case TOK_MINUS:
case TOK_STAR:
if (isLong || currency) {
return isLong ? BAS_TYPE_LONG : BAS_TYPE_CURRENCY;
}
return (numbers && !ints) ? BAS_TYPE_DOUBLE : BAS_NODE_TYPE_UNKNOWN;
case TOK_BACKSLASH:
case TOK_MOD:
return isLong ? BAS_TYPE_LONG : BAS_NODE_TYPE_UNKNOWN;
case TOK_SLASH:
case TOK_CARET:
return numbers ? BAS_TYPE_DOUBLE : BAS_NODE_TYPE_UNKNOWN;
case TOK_AMPERSAND:
return BAS_TYPE_STRING;
case TOK_EQ:
case TOK_NE:
case TOK_LT:
case TOK_GT:
case TOK_LE:
case TOK_GE:
return (a != BAS_NODE_TYPE_UNKNOWN && b != BAS_NODE_TYPE_UNKNOWN) ? BAS_TYPE_BOOLEAN : BAS_NODE_TYPE_UNKNOWN;
default:
return BAS_NODE_TYPE_UNKNOWN;
}
}
// The type an NK_CONV yields.
static uint8_t convResultType(uint8_t op, uint8_t operandType) {
switch (op) {
case OP_CONV_FLT_INT:
return BAS_TYPE_INTEGER;
case OP_CONV_BYTE:
return BAS_TYPE_BYTE;
case OP_CONV_CUR:
return BAS_TYPE_CURRENCY;
case OP_CONV_INT_LONG:
return BAS_TYPE_LONG;
case OP_CONV_INT_FLT:
return BAS_TYPE_SINGLE;
case OP_CONV_STR_FLT:
return BAS_TYPE_DOUBLE;
case OP_CONV_INT_STR:
case OP_STR_FIXLEN:
return BAS_TYPE_STRING;
case OP_CONV_BOOL:
return BAS_TYPE_BOOLEAN;
case OP_CONV_DATE:
return BAS_TYPE_DATE;
case OP_OBJ_CHECK:
return operandType;
default:
return BAS_NODE_TYPE_UNKNOWN;
}
}
// The type a value read from typed variable / FUNCTION sym always has
// (a store into it converts): its declared scalar type.
static uint8_t declaredType(const BasSymT *sym) {
return ((sym->flags & SF_TYPED) && sym->objClass == BAS_CLASS_NONE) ? scalarType(sym->dataType) : BAS_NODE_TYPE_UNKNOWN;
}
// True for the statement kinds that are a BasStmtT.
static bool isStmtKind(uint8_t kind) {
switch (kind) {
case ST_ASSIGN: case ST_CALL: case ST_EXPR: case ST_SIMPLE:
case ST_EXIT: case ST_GOTO: case ST_GOSUB: case ST_RETURN:
case ST_ONGOTO: case ST_ONERROR: case ST_RESUME: case ST_LABEL:
case ST_END: case ST_ERASE: case ST_STATIC: case ST_SHARED:
case ST_CONST: case ST_TYPEDEF: case ST_ENUM: case ST_DECLARELIB:
case ST_DEFTYPE: case ST_OPTION: case ST_BEGINFORM: case ST_ENDFORM:
case ST_BEGINCLASS: case ST_ENDCLASS: case ST_ATTRIBUTE: case ST_IMPLEMENTS:
case ST_BEGINMODULE: case ST_ENDMODULE:
case ST_RAISEEVENT: case ST_MIDASSIGN: case ST_LSET: case ST_SWAP:
case ST_READ: case ST_DATA: case ST_RESTORE: case ST_INPUT:
case ST_LINEINPUT: case ST_OPEN: case ST_GET: case ST_PUT:
case ST_WRITE: case ST_SCREEN: case ST_LOAD: case ST_UNLOAD:
return true;
default:
return false;
}
}
// A number's type: INTEGER, LONG, SINGLE, DOUBLE, BYTE or CURRENCY.
static bool numberType(uint8_t type) {
return type <= BAS_TYPE_DOUBLE || type == BAS_TYPE_BYTE || type == BAS_TYPE_CURRENCY;
}
// dataType when it is a number, string, Boolean or Date (what a slot
// declared so always holds), else BAS_NODE_TYPE_UNKNOWN.
static uint8_t scalarType(uint8_t dataType) {
switch (dataType) {
case BAS_TYPE_INTEGER:
case BAS_TYPE_LONG:
case BAS_TYPE_SINGLE:
case BAS_TYPE_DOUBLE:
case BAS_TYPE_STRING:
case BAS_TYPE_BOOLEAN:
case BAS_TYPE_DATE:
case BAS_TYPE_BYTE:
case BAS_TYPE_CURRENCY:
return dataType;
default:
return BAS_NODE_TYPE_UNKNOWN;
}
}
// Types and folds the bounds of DIM / REDIM.
static void typeBounds(BasCompilerT *c, BasNodeT *bounds) {
for (BasNodeT *b = bounds; b != NULL; b = b->next) {
((BasBoundT *)b)->lower = typeExpr(c, ((BasBoundT *)b)->lower);
((BasBoundT *)b)->upper = typeExpr(c, ((BasBoundT *)b)->upper);
}
}
// The static type of n (set on the node), its literal subexpressions
// folded; returns the node that replaces n.
static BasNodeT *typeExpr(BasCompilerT *c, BasNodeT *n) {
if (n == NULL) {
return NULL;
}
n = basFoldExpr(c, n);
switch (n->kind) {
case NK_INT:
case NK_DBL:
case NK_STR:
case NK_BOOL:
break;
case NK_BUILTIN:
n->type = ((const BasBuiltinT *)((const BasCallT *)n)->target)->resultType;
break;
default:
n->type = basStaticType(n);
break;
}
return n;
}
// Types and folds every expression of a list in place.
static void typeList(BasCompilerT *c, BasNodeT **list) {
BasNodeT *prev = NULL;
for (BasNodeT *a = *list; a != NULL;) {
BasNodeT *next = a->next;
BasNodeT *t = typeExpr(c, a);
t->next = next;
if (prev != NULL) {
prev->next = t;
} else {
*list = t;
}
prev = t;
a = next;
}
}
static void typeStatement(BasCompilerT *c, BasNodeT *s) {
if (s == NULL || c->hasError) {
return;
}
switch (s->kind) {
case ST_IF:
case ST_ELSEIF: {
BasIfT *n = (BasIfT *)s;
n->cond = typeExpr(c, n->cond);
typeStatements(c, n->thenBody);
typeStatements(c, n->elseIfs);
typeStatements(c, n->elseBody);
break;
}
case ST_FOR:
case ST_FOREACH:
case ST_DO:
case ST_WHILE: {
BasLoopT *loop = (BasLoopT *)s;
loop->from = typeExpr(c, loop->from);
loop->to = typeExpr(c, loop->to);
loop->step = typeExpr(c, loop->step);
loop->preCond = typeExpr(c, loop->preCond);
loop->postCond = typeExpr(c, loop->postCond);
typeStatements(c, loop->body);
break;
}
case ST_SELECT: {
BasSelectT *sel = (BasSelectT *)s;
sel->expr = typeExpr(c, sel->expr);
for (BasNodeT *cn = sel->cases; cn != NULL; cn = cn->next) {
BasCaseT *cs = (BasCaseT *)cn;
for (BasNodeT *in = cs->items; in != NULL; in = in->next) {
BasCaseItemT *item = (BasCaseItemT *)in;
item->a = typeExpr(c, item->a);
item->b = typeExpr(c, item->b);
}
typeStatements(c, cs->body);
}
break;
}
case ST_PROC:
typeStatements(c, ((BasProcT *)s)->body);
break;
case ST_WITH: {
BasWithT *w = (BasWithT *)s;
w->expr = typeExpr(c, w->expr);
typeStatements(c, w->body);
break;
}
case ST_DEFFN:
((BasProcT *)s)->body = typeExpr(c, ((BasProcT *)s)->body);
break;
case ST_PRINT: {
BasPrintT *pr = (BasPrintT *)s;
pr->channel = typeExpr(c, pr->channel);
pr->format = typeExpr(c, pr->format);
for (BasNodeT *it = pr->items; it != NULL; it = it->next) {
((BasPrintItemT *)it)->expr = typeExpr(c, ((BasPrintItemT *)it)->expr);
}
break;
}
case ST_DIM:
for (BasNodeT *d = ((BasStmtT *)s)->a; d != NULL; d = d->next) {
typeBounds(c, ((BasDeclT *)d)->bounds);
}
break;
case ST_REDIM:
typeBounds(c, ((BasStmtT *)s)->a);
break;
case ST_CALL:
if (((BasStmtT *)s)->ival == BAS_ARGS_DRAWING) {
for (BasNodeT *it = ((BasStmtT *)s)->b; it != NULL; it = it->next) {
((BasPrintItemT *)it)->expr = typeExpr(c, ((BasPrintItemT *)it)->expr);
}
}
((BasStmtT *)s)->a = typeExpr(c, ((BasStmtT *)s)->a);
break;
default: {
// The simple statements: a, b and c are expressions or lists of
// them (arguments, store targets, labels); folding keeps a store
// target's shape and only folds its subscripts
if (!isStmtKind(s->kind)) {
break;
}
BasStmtT *st = (BasStmtT *)s;
typeList(c, &st->a);
typeList(c, &st->b);
typeList(c, &st->c);
break;
}
}
}
static void typeStatements(BasCompilerT *c, BasNodeT *list) {
for (BasNodeT *s = list; s != NULL; s = s->next) {
typeStatement(c, s);
}
}
// A whole number's type: INTEGER, LONG or BYTE.
static bool wholeType(uint8_t type) {
return type == BAS_TYPE_INTEGER || type == BAS_TYPE_LONG || type == BAS_TYPE_BYTE;
}

119
src/apps/kpunch/dvxbasic/ctrlover.dhs
View file

@ -36,6 +36,8 @@
.index DragDrop
.index DragOver
.index Drag and Drop
.index Default Property
.index Default Properties
.h1 Common Properties, Events, and Methods
@ -64,11 +66,28 @@ Every control in DVX BASIC inherits a set of common properties, events, and meth
ToolTipText String R/W Tooltip text shown after the mouse hovers over the control. Empty string or unset = no tooltip.
HelpTopic String R/W Help topic opened by F1 while the control has the focus. Empty = the form's HelpTopic. F1 uses the project's help file.
DragMode Integer R/W vbManual (0, the default): the program starts a drag with the Drag method. vbAutomatic (1): pressing the left mouse button on the control starts a drag. See Drag and Drop below.
DragIcon String R/W Picture file (BMP, PNG, JPEG or GIF) shown under the mouse while the control is dragged. Empty = a dotted outline the size of the control.
DragIcon Picture R/W Picture shown under the mouse while the control is dragged: a picture file name (BMP, PNG, JPEG or GIF) or a Picture object from LOADPICTURE (Set works too). Reading it gives a Picture object, which stands for the file name where a value is needed. Empty = a dotted outline the size of the control.
.endtable
Size properties (Width, Height and the Min/Max sizes) are limited to 0..32767.
.h2 Default Properties
As in Visual Basic, a control's name used where a value is needed means its default property: Text1 = "hi" sets Text1.Text, Print Label1 prints Label1.Caption, and If Check1 Then reads Check1.Value. Where an object is expected -- SET, Is, an object parameter, Collection.Add, TypeOf -- the name still means the control itself.
.table
Control Default property
------- ----------------
TextBox, TextArea, ComboBox, DropDown, ListBox, DBGrid Text
Label, Frame, Data Caption
CheckBox, OptionButton, CommandButton Value
HScrollBar, SpinButton, ProgressBar Value
Image, ImageButton, PictureBox Picture
Timer Enabled
.endtable
Other controls, forms and menu items have no default property: using one as a value raises error 13.
.h2 Common Events
These events are wired on every control loaded from a .frm file. Controls created dynamically at runtime via code only receive Click, DblClick, Change, GotFocus, and LostFocus; the keyboard, mouse, and scroll events below require the control to be defined in the .frm file.
@ -106,12 +125,16 @@ These events are wired on every control loaded from a .frm file. Controls create
Any control can be dragged onto another control or onto a form, as in Visual Basic. While a control is dragged, a dotted outline of it (or its DragIcon picture) follows the mouse, and the controls and forms it passes over get DragOver events. Releasing the mouse button drops it: the control or form under the mouse gets a DragDrop event, with the dragged control as Source. Pressing Esc cancels the drag.
The mouse pointer shows where a drop can land: over a control or form that has a DragDrop event procedure it is the usual arrow; over one without, and outside the program's forms, it is the "no drop" sign (a circle with a line through it). The outline or DragIcon picture still follows the mouse either way.
With DragMode set to vbAutomatic, pressing the left mouse button on the control starts the drag, and the control gets no Click, MouseDown or MouseUp from the left button. With DragMode vbManual, start the drag yourself, usually in MouseDown. A drag started while the mouse button is up ends at the next click. During a drag no mouse events other than DragOver and DragDrop are raised.
Drop targets only react: nothing is moved or copied for you. Use Source in DragDrop to decide what to do, for example read its Name or Caption, or check what kind of control it is with TypeOf Source Is TextBox (see Operators).
Note that vbCancel is the MsgBox Cancel value (2), which as a Drag action means vbEndDrag; cancel a drag with Drag 0.
DragIcon takes a file name or a picture loaded with LOADPICTURE: Set Label1.DragIcon = LoadPicture("drag.bmp"). A missing file or one that is not a picture raises its error at LOADPICTURE; a file name that cannot be read when the drag starts shows the outline instead.
.code
' Label1 has DragMode = 1 (vbAutomatic) in the form designer.
Sub List1_DragOver(Source As Control, X As Integer, Y As Integer, State As Integer)
@ -144,6 +167,8 @@ End Sub
.index Point method
.index Print method
.index PaintPicture
.index Raster Operations
.index vbSrcCopy
.index TextWidth
.index TextHeight
.index CurrentX
@ -152,14 +177,22 @@ End Sub
.index FillColor
.index FillStyle
.index AutoRedraw
.index Paint event
.index Scale
.index ScaleMode
.index ScaleX
.index ScaleY
.index vbHimetric
.index ScaleLeft
.index ScaleTop
.index ScaleWidth
.index ScaleHeight
.h1 Drawing on Forms and PictureBoxes
Forms and PictureBoxes have Visual Basic's drawing methods. They draw with the same code as the QBasic graphics statements (see Console and Graphics in the language reference), in pixels, with colours as RGB values (RGB(255, 0, 0) or &HFF0000 is red). A PictureBox draws on its picture; a form gets a drawing area the size of its window the first time it draws, placed with its controls like a PictureBox (so draw on a form that has no controls, or use a PictureBox beside them).
Forms and PictureBoxes have Visual Basic's drawing methods. They draw with the same code as the QBasic graphics statements (see Console and Graphics in the language reference), in pixels unless ScaleMode or Scale says otherwise, with colours as Visual Basic RGB values, &HBBGGRR (RGB(255, 0, 0) or &HFF is red). A PictureBox draws on its picture; a form gets a drawing area the size of its window the first time it draws, placed with its controls like a PictureBox (so draw on a form that has no controls, or use a PictureBox beside them).
Drawings stay until they are drawn over or cleared: AutoRedraw is accepted, but a drawing always behaves as with AutoRedraw = True. In a form's own code, write Me.Line, Me.Circle and so on: Line, Circle and PSet without an object are the QBasic graphics statements (they draw on the program's screen), and Print without an object is the PRINT statement.
Drawings stay until they are drawn over or cleared. In a form's own code, write Me.Line, Me.Circle and so on: Line, Circle and PSet without an object are the QBasic graphics statements (they draw on the program's screen), and Print without an object is the PRINT statement.
.h2 Drawing Methods
@ -172,12 +205,73 @@ Drawings stay until they are drawn over or cleared: AutoRedraw is accepted, but
Circle [Step](x, y), radius [, color [, start [, end [, aspect]]]] Draws a circle, ellipse or arc, filled with FillColor when FillStyle is 0 (full circles).
Point(x, y) The colour of a pixel, -1 outside the picture.
Print items Writes text at CurrentX, CurrentY in ForeColor, with PRINT's ; , SPC and TAB; ends by moving to the next line unless the last item is followed by ; or ,.
PaintPicture picture, x, y [, width, height [, srcX, srcY, srcWidth, srcHeight]] Copies a picture, stretched to width x height: an image file (BMP, PNG, JPEG or GIF), or a PictureBox given by its name as a string or by a Control variable.
TextWidth(text) Width of the text in pixels.
TextHeight(text) Height of a line of text in pixels.
PaintPicture picture, x, y [, width, height [, srcX, srcY, srcWidth, srcHeight [, opcode]]] Copies a picture, stretched to width x height: an image file (BMP, PNG, JPEG or GIF), a picture from LOADPICTURE, or a PictureBox given by its name as a string or by a Control variable. opcode combines each pixel with the one already there (see Raster Operations).
Scale [(x1, y1)-(x2, y2)] Gives the drawing coordinates of its own: (x1, y1) is the top-left corner and (x2, y2) the bottom-right one (y2 below y1 makes y go up). Scale alone goes back to pixels.
ScaleX(width [, fromScale [, toScale]]) A width in fromScale converted to toScale (see Scales).
ScaleY(height [, fromScale [, toScale]]) A height in fromScale converted to toScale.
TextWidth(text) Width of the text in the scale's units.
TextHeight(text) Height of a line of text in the scale's units.
.endtable
Without a colour, drawing uses ForeColor. Step makes a point relative to CurrentX, CurrentY, which every drawing method leaves at its last point. A colour or angle out of range stops the program with an error.
Without a colour, drawing uses ForeColor. Step makes a point relative to CurrentX, CurrentY, which every drawing method leaves at its last point. Coordinates, radii, CurrentX and CurrentY and PaintPicture's rectangles are in the scale's units (a radius in its horizontal units); DrawWidth is always in pixels. A colour or angle out of range stops the program with an error.
.h2 Raster Operations
PaintPicture's opcode says how each copied pixel is combined with the pixel already there (the destination) and with the FillColor (the pattern), as in Visual Basic. Leaving it out copies the picture (vbSrcCopy).
.table
Constant Value Result
-------- ----- ------
vbSrcCopy &HCC0020 The picture
vbSrcPaint &HEE0086 Picture OR destination
vbSrcAnd &H8800C6 Picture AND destination
vbSrcInvert &H660046 Picture XOR destination
vbSrcErase &H440328 Picture AND NOT destination
vbNotSrcCopy &H330008 NOT picture
vbNotSrcErase &H1100A6 NOT (picture OR destination)
vbMergeCopy &HC000CA Picture AND pattern
vbMergePaint &HBB0226 NOT picture OR destination
vbPatCopy &HF00021 The pattern
vbPatPaint &HFB0A09 Pattern OR NOT picture OR destination
vbPatInvert &H5A0049 Pattern XOR destination
vbDstInvert &H550009 NOT destination
.endtable
Any of the 256 raster operations of Windows can be given by its number; the bits work on the pixel values, so with fewer than 32 bits a pixel the results follow the display's colour format.
.code
Picture1.PaintPicture Picture2, 0, 0, 32, 32, 0, 0, 32, 32, vbSrcInvert ' XOR the picture in
Picture1.PaintPicture Picture2, 0, 0, 32, 32, 0, 0, 32, 32, vbSrcInvert ' and out again
.endcode
.h2 Scales
ScaleMode picks the units: 0 user (set by Scale or the Scale properties), 1 twips (1440 an inch, 15 a pixel), 2 points (72 an inch), 3 pixels, 4 characters (120 twips across, 240 down), 5 inches, 6 millimetres, 7 centimetres. Unlike Visual Basic, whose default is twips, DVX starts every form and PictureBox in pixels (ScaleMode 3), and Scale without arguments goes back to pixels. Setting ScaleLeft, ScaleTop, ScaleWidth or ScaleHeight makes a user scale from the current one; ScaleWidth and ScaleHeight may not be 0. With a user scale the units stay fixed to the picture's edges when it is resized; other scale modes keep their unit size.
The constants vbUser (0), vbTwips (1), vbPoints (2), vbPixels (3), vbCharacters (4), vbInches (5), vbMillimeters (6) and vbCentimeters (7) name the scale modes. The units assume a standard display of 96 pixels an inch (15 twips a pixel), whatever the screen really is, so an inch is always 96 pixels.
ScaleX and ScaleY convert a width or a height from one scale to another, as in Visual Basic: fromScale is the scale the value is in, vbHimetric (8, hundredths of a millimetre, the unit of a Picture's Width and Height) when it is left out; toScale the scale wanted, the object's ScaleMode when left out. vbUser means the object's current scale. Visual Basic's vbContainerPosition and vbContainerSize are not available; any other scale number stops the program with an error.
.code
Picture1.Scale (0, 100)-(100, 0) ' 0..100 across, y going up
Picture1.Line (0, 0)-(100, 100), RGB(255, 0, 0)
Picture1.ScaleMode = 7 ' centimetres
Picture1.Circle (2, 2), 1
Dim pic As Object
Set pic = LoadPicture("logo.bmp")
w = Me.ScaleX(pic.Width, vbHimetric, vbPixels) ' the picture's width in pixels
.endcode
.h2 AutoRedraw and the Paint Event
A form or PictureBox fires its Paint event when it is shown, when the form is resized, when a PictureBox changes size (its Width or Height set to a new value, or its Resize method) while its form is showing, and when the program calls its Refresh method, so a program can draw everything in Paint as in Visual Basic. Unlike Visual Basic, DVX keeps what was drawn even with AutoRedraw False (the default), so drawing outside Paint also stays on the screen. With AutoRedraw = True, Paint does not fire. A program that sets AutoRedraw = False itself gets Visual Basic's behaviour exactly: the drawing is cleared to BackColor before each Paint.
.code
Sub Picture1_Paint ()
Picture1.Circle (50, 50), 40, RGB(0, 128, 0)
End Sub
.endcode
.h2 Drawing Properties
@ -189,11 +283,14 @@ Without a colour, drawing uses ForeColor. Step makes a point relative to Current
CurrentX Single 0 Where the next drawing or printing starts.
CurrentY Single 0
DrawWidth Integer 1 Pen width in pixels.
FillStyle Integer 1 0 fills boxes and circles with FillColor; 1 (the default) leaves them empty. Other VB fill patterns draw as 1.
FillStyle Integer 1 How boxes (B) and circles are filled with FillColor: 0 solid, 1 (the default) not at all, 2 horizontal lines, 3 vertical lines, 4 upward diagonals, 5 downward diagonals, 6 a cross hatch, 7 a diagonal cross hatch (the lines 8 pixels apart, the gaps left as they are). Other values are an error. BF fills solid in the line's colour.
FillColor Long &H000000 Colour boxes and circles are filled with.
AutoRedraw Boolean False Accepted; drawings always persist.
ScaleWidth Long (size) Width of the drawing in pixels (read-only).
ScaleHeight Long (size) Height of the drawing in pixels (read-only).
AutoRedraw Boolean False True: no Paint events (see above).
ScaleMode Integer 3 Units of the coordinates (see Scales).
ScaleLeft Single 0 Coordinate of the left edge.
ScaleTop Single 0 Coordinate of the top edge.
ScaleWidth Single (size) Width of the drawing in the scale's units.
ScaleHeight Single (size) Height of the drawing in the scale's units.
.endtable
.h2 Example

5
src/apps/kpunch/dvxbasic/form.dhs
View file

@ -70,11 +70,12 @@ The Form is the top-level container representing a DVX window. It is declared in
Resize (none) Fires when the window is resized by the user.
Activate (none) Fires when the window gains focus.
Deactivate (none) Fires when the window loses focus.
Paint (none) Fires when the form is shown or resized and on Refresh, unless AutoRedraw is True (see Drawing on Forms and PictureBoxes).
DragDrop Source As Control, X As Integer, Y As Integer Fires when a dragged control is dropped on an empty part of the form. X and Y are where, in the form.
DragOver Source As Control, X As Integer, Y As Integer, State As Integer Fires while a dragged control moves over an empty part of the form. State is vbEnter, vbLeave or vbOver.
.endtable
See Drag and Drop under Common Properties, Events, and Methods.
See Drag and Drop under Common Properties, Events, and Methods. While a control is dragged over a form with no DragDrop event procedure, the mouse pointer shows the "no drop" sign.
.h2 Form Methods
@ -90,7 +91,7 @@ See Drag and Drop under Common Properties, Events, and Methods.
.h2 Drawing
Forms have Visual Basic's drawing methods and properties (Cls, PSet, Line, Circle, Point, Print, PaintPicture, CurrentX, CurrentY, ForeColor, BackColor, DrawWidth, FillColor, FillStyle): see Drawing on Forms and PictureBoxes. In the form's own code use Me.Line, Me.Circle and so on.
Forms have Visual Basic's drawing methods and properties (Cls, PSet, Line, Circle, Point, Print, PaintPicture, Scale, CurrentX, CurrentY, ForeColor, BackColor, DrawWidth, FillColor, FillStyle, AutoRedraw, ScaleMode, ScaleLeft, ScaleTop, ScaleWidth, ScaleHeight): see Drawing on Forms and PictureBoxes. In the form's own code use Me.Line, Me.Circle and so on.
.h2 Example

639
src/apps/kpunch/dvxbasic/formrt/formGfx.c
View file

File diff suppressed because it is too large Load diff

786
src/apps/kpunch/dvxbasic/formrt/formrt.c
View file

File diff suppressed because it is too large Load diff

38
src/apps/kpunch/dvxbasic/formrt/formrt.h
View file

@ -103,6 +103,7 @@ typedef struct BasScreenWinT BasScreenWinT; // the program screen's window (f
#define BAS_PROP_MINHEIGHT "MinHeight"
#define BAS_PROP_MINWIDTH "MinWidth"
#define BAS_PROP_NAME "Name"
#define BAS_PROP_PICTURE "Picture"
#define BAS_PROP_RADIOCHECK "RadioCheck"
#define BAS_PROP_READONLY "ReadOnly"
#define BAS_PROP_RECORDSOURCE "RecordSource"
@ -111,6 +112,7 @@ typedef struct BasScreenWinT BasScreenWinT; // the program screen's window (f
#define BAS_PROP_TEXT "Text"
#define BAS_PROP_TOOLTIPTEXT "ToolTipText"
#define BAS_PROP_TOP "Top"
#define BAS_PROP_VALUE "Value"
#define BAS_PROP_VISIBLE "Visible"
#define BAS_PROP_WEIGHT "Weight"
#define BAS_PROP_WIDTH "Width"
@ -315,6 +317,14 @@ typedef struct {
int32_t frmSourceLen;
} BasFrmCacheT;
// A LoadPicture Picture object: the picture's size in pixels (0 x 0 for
// the empty picture) and its file name ("" for the empty picture).
typedef struct {
int32_t width;
int32_t height;
char path[];
} BasPictureT;
typedef struct {
AppContextT *ctx; // DVX app context
BasVmT *vm; // shared VM instance
@ -374,6 +384,10 @@ typedef struct {
// statement) and its caption: hosts set title to the program's name.
BasScreenWinT *screenWin;
char title[BAS_MAX_IDENT];
// LoadPicture's Picture objects: one for each file name loaded
// (stb_ds array of heap objects; the object is that pointer), kept
// until the runtime is destroyed.
BasPictureT **pictures;
} BasFormRtT;
// ============================================================
@ -407,9 +421,10 @@ bool basFormRtKeepsRunning(const BasFormRtT *rt);
WindowT *basFormRtScreenWindow(const BasFormRtT *rt);
// True when name is a Form / PictureBox drawing method (Cls, PSet, Line,
// Circle, Point, Print, PaintPicture, TextWidth, TextHeight) or, with
// isProp, a drawing property (CurrentX, CurrentY, DrawWidth, FillColor,
// FillStyle, ForeColor, BackColor, AutoRedraw, ScaleWidth, ScaleHeight).
// Circle, Point, Print, PaintPicture, Scale, ScaleX, ScaleY, TextWidth,
// TextHeight) or, with isProp, a drawing property (CurrentX, CurrentY,
// DrawWidth, FillColor, FillStyle, ForeColor, BackColor, AutoRedraw,
// ScaleMode, ScaleLeft, ScaleTop, ScaleWidth, ScaleHeight).
bool basFormRtIsDrawMember(const char *name, bool isProp);
// Close all serial/secLink resources and unregister the idle pollers.
@ -441,6 +456,7 @@ void basFormRtRuntimeError(BasFormRtT *rt, const char *summary, const char *deta
BasValueT basFormRtCallMethod(void *ctx, void *ctrlRef, const char *methodName, BasValueT *args, int32_t argc);
void *basFormRtCreateCtrl(void *ctx, void *formRef, const char *typeName, const char *ctrlName);
const char *basFormRtDefaultProp(void *ctx, void *objRef);
void *basFormRtFindCtrl(void *ctx, void *formRef, const char *ctrlName);
void *basFormRtFindCtrlIdx(void *ctx, void *formRef, const char *ctrlName, int32_t index);
BasValueT basFormRtGetProp(void *ctx, void *ctrlRef, const char *propName);
@ -534,9 +550,25 @@ bool basFormRtDrawGetProp(BasFormRtT *rt, BasControlT *ctrl, const char *name, B
bool basFormRtDrawMethod(BasFormRtT *rt, BasControlT *ctrl, const char *name, BasValueT *args, int32_t argc, BasValueT *result);
bool basFormRtDrawSetProp(BasFormRtT *rt, BasControlT *ctrl, const char *name, BasValueT value);
// A length of pixels across or down as units of a fixed-size scale
// (BAS_SCALE_TWIPS to BAS_SCALE_HIMETRIC, not vbUser): the ScaleMode
// conversions (VB's 15 twips a pixel), shared with Picture.Width / Height.
double basFormRtDrawPixelsToUnits(double pixels, int32_t scale, bool across);
// Free a control's drawing state.
void basFormRtDrawFree(BasControlT *ctrl);
// The object is about to be repainted (shown, resized, Refresh): true
// when its Paint event should fire -- a form or PictureBox whose
// AutoRedraw is not True. One whose program set AutoRedraw = False is
// cleared to its BackColor first (VB); by default drawings are kept.
bool basFormRtDrawWantsPaint(BasControlT *ctrl);
// The file name of a Picture object LOADPICTURE made ("" for an empty
// picture), NULL when v is not one. Picture properties and PaintPicture
// take either a file name or such an object.
const char *basFormRtPicturePath(const BasFormRtT *rt, BasValueT v);
// The live control an object reference names, or NULL.
BasControlT *basFormRtResolveCtrl(BasFormRtT *rt, void *ref);

1
src/apps/kpunch/dvxbasic/gapc1.txt Normal file
View file

@ -0,0 +1 @@
one

1
src/apps/kpunch/dvxbasic/gapc2.txt Normal file
View file

@ -0,0 +1 @@
two

1
src/apps/kpunch/dvxbasic/gapc3.txt Normal file
View file

@ -0,0 +1 @@
three

0
src/apps/kpunch/dvxbasic/gapf1.txt Normal file
View file

0
src/apps/kpunch/dvxbasic/gapf2.txt Normal file
View file

9
src/apps/kpunch/dvxbasic/gapw.txt Normal file
View file

@ -0,0 +1,9 @@
abcde
fghij
kl
ab
cdef
a b c d
3.1 2.5
1 2

0
src/apps/kpunch/dvxbasic/gapx.txt Normal file
View file

742
src/apps/kpunch/dvxbasic/ide/ideMain.c
View file

File diff suppressed because it is too large Load diff

96
src/apps/kpunch/dvxbasic/ide/ideProject.c
View file

@ -154,6 +154,7 @@ static void ppdOnOk(WidgetT *w);
static void ppdReadInput(WidgetT *input, char *dst, int32_t dstSize);
static void prjDeriveDir(PrjStateT *prj, const char *dbpPath);
static int32_t prjFileIndexByPath(const PrjStateT *prj, const char *path);
static const char *prjKindExt(PrjFileKindE kind);
static void prjLoadFileSection(PrjStateT *prj, PrefsHandleT *h, PrjFileKindE kind);
static void prjLoadString(PrefsHandleT *h, const char *section, const char *key, char *dst, int32_t dstSize);
static const char *prjMakeRelative(const PrjStateT *prj, const char *path);
@ -473,7 +474,7 @@ int32_t prjFileCount(const PrjStateT *prj) {
// Index of the project file whose relative path is path, or -1.
static int32_t prjFileIndexByPath(const PrjStateT *prj, const char *path) {
for (int32_t i = 0; i < prjFileCount(prj); i++) {
if (strcmp(prj->files[i].path, path) == 0) {
if (strcasecmp(prj->files[i].path, path) == 0) {
return i;
}
}
@ -513,6 +514,16 @@ void prjInit(PrjStateT *prj) {
}
// The file extension of a kind of project file.
static const char *prjKindExt(PrjFileKindE kind) {
if (kind == PrjKindFormE) {
return PRJ_FRM_EXT;
}
return (kind == PrjKindClassE) ? BAS_CLS_EXT : PRJ_BAS_EXT;
}
PrjFileKindE prjKindForPath(const char *path) {
const char *base = platformPathBaseName(path);
@ -1056,6 +1067,89 @@ void prjRemoveFile(PrjStateT *prj, int32_t idx) {
}
bool prjRenameFile(PrjStateT *prj, int32_t idx, const char *newName, char *err, int32_t errSize) {
PrjFileT *file = &prj->files[idx];
const char *ext = prjKindExt((PrjFileKindE)file->kind);
const char *dot = strrchr(newName, '.');
char name[DVX_MAX_PATH];
if (strpbrk(newName, "/\\:") != NULL) {
snprintf(err, errSize, "Give a file name only; the file stays in the project's directory.");
return false;
}
if (dot && strcasecmp(dot, ext) != 0) {
snprintf(err, errSize, "%s must keep the %s extension.", file->path, ext);
return false;
}
if (snprintf(name, sizeof(name), "%s%s", newName, dot ? "" : ext) >= (int32_t)sizeof(name)) {
snprintf(err, errSize, "The name is too long.");
return false;
}
const char *invalid = platformValidateFilename(name);
if (invalid) {
snprintf(err, errSize, "%s", invalid);
return false;
}
if (strcasecmp(name, file->path) == 0) {
return true;
}
if (prjFileIndexByPath(prj, name) >= 0) {
snprintf(err, errSize, "%s is already in the project.", name);
return false;
}
char oldPath[DVX_MAX_PATH];
char oldFull[DVX_MAX_PATH];
char newFull[DVX_MAX_PATH * 2];
snprintf(oldPath, sizeof(oldPath), "%s", file->path);
prjFullPath(prj, idx, oldFull, sizeof(oldFull));
snprintf(newFull, sizeof(newFull), "%s" DVX_PATH_SEP "%s", prj->projectDir, name);
if (prjPathExists(newFull)) {
snprintf(err, errSize, "%s already exists.", name);
return false;
}
// A file never saved exists only in memory: nothing to rename on disk
bool onDisk = prjPathExists(oldFull);
if (onDisk && rename(oldFull, newFull) != 0) {
snprintf(err, errSize, "Could not rename %s to %s.", oldPath, name);
return false;
}
snprintf(file->path, sizeof(file->path), "%s", name);
if (!prjSave(prj)) {
snprintf(file->path, sizeof(file->path), "%s", oldPath);
if (onDisk) {
rename(newFull, oldFull);
}
snprintf(err, errSize, "Could not write the project file; %s keeps its name.", oldPath);
return false;
}
// The source map is keyed by path
for (int32_t i = 0; i < (int32_t)arrlen(prj->sourceMap); i++) {
if (strcmp(prj->sourceMap[i].path, oldPath) == 0) {
snprintf(prj->sourceMap[i].path, sizeof(prj->sourceMap[i].path), "%s", name);
}
}
prj->dirty = false;
return true;
}
bool prjSave(const PrjStateT *prj) {
if (prj->projectPath[0] == '\0') {
return false;

14
src/apps/kpunch/dvxbasic/ide/ideProject.h
View file

@ -59,9 +59,10 @@
#define IDE_PREF_SECTION_EDITOR "editor"
#define IDE_PREF_KEY_OPTION_EXPLICIT "optionExplicit"
// Form file extension; a class module's is BAS_CLS_EXT (basRes.h). A
// file's kind follows its extension (see prjKindForPath).
// Form and module file extensions; a class module's is BAS_CLS_EXT
// (basRes.h). A file's kind follows its extension (see prjKindForPath).
#define PRJ_FRM_EXT ".frm"
#define PRJ_BAS_EXT ".bas"
// ============================================================
// Project file kinds
@ -151,6 +152,15 @@ bool prjPathExists(const char *path);
// whether it simply does not exist.
char *prjReadFileText(const PrjStateT *prj, int32_t fileIdx, bool *outMissing);
void prjRemoveFile(PrjStateT *prj, int32_t idx);
// Rename project file idx to newName, a file name in the project's
// directory whose extension, when given, is the one of the file's kind
// (none: it is added). The file on disk (when it has been saved) is
// renamed and the project file (.dbp) written at once so the two agree;
// on any failure both are put back. An existing file is never
// overwritten. A name that differs only in case changes nothing (DOS
// names ignore case). False with a message in err (errSize bytes).
bool prjRenameFile(PrjStateT *prj, int32_t idx, const char *newName, char *err, int32_t errSize);
bool prjSave(const PrjStateT *prj);
// Copy src into dst (dstSize bytes) with every CR and LF replaced by a

Some files were not shown because too many files have changed in this diff Show more