initial commit

pcomp/.vscode/tasks.json

@@ -0,0 +1,17 @@
+{
+    // See https://go.microsoft.com/fwlink/?LinkId=733558
+    // for the documentation about the tasks.json format
+    "version": "2.0.0",
+    "tasks": [
+        {
+            "label": "pcomp",
+            "type": "shell",
+            "command": "fpc -Mobjfpc -gl pcomp.pas",
+            "problemMatcher": [],
+            "group": {
+                "kind": "build",
+                "isDefault": true
+            }
+        }
+    ]
+}

pcomp/float32+.pas

@@ -0,0 +1,95 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+function encodefloat32(r:real):integer;
+var	intpart:real;
+	fract: real;
+	exponent:integer;
+	sign:integer;
+	i:integer;
+	digit, bitpos:integer;
+	intlength,fractlength:integer;
+	intbin:integer;
+	fractbin:integer;
+	floatbin:integer;
+begin
+	intbin := 0; fractbin := 0; floatbin := 0;
+
+	if r<0 then
+	begin
+		r := abs(r);
+		sign := 1;
+	end
+	else
+		sign := 0;
+
+	if r = 0.0 then
+	begin
+		intpart := 0.0;
+		fract := 0.0;
+		intlength := 0;
+		fractlength := 0;
+		intbin := 0;
+		fractbin := 0;
+		floatbin := 0;
+	end
+	else
+	begin
+		intpart := r;
+		fract := frac(r);
+		exponent := floor(log2(intpart));
+
+		intlength := exponent+1;
+		fractlength :=  wordbits - intlength - Float32ExpBits - 1;
+	end;
+		(* FIXME: log2 gives division by zero on zero arg *)
+
+
+	(* process bits before the point *)
+	for i := 1 to intlength do
+	begin
+		(* digit := round(intpart mod 2.0); *)
+		(* calculate real remainder in a portable way *)
+		digit := floor(intpart - 2 * Int(intpart / 2));
+
+		(* if we used up all the bits in the fraction part of
+			the float32 encoding, shift everything right
+			and put bit at the top *)
+		if i > Float32FractBits then
+		begin
+			bitpos := Float32FractBits-1;
+			intbin := intbin shr 1;
+		end
+		else
+			bitpos := i - 1;
+
+		if digit > 0 then intbin := intbin  + (1 << bitpos);
+
+		intpart := intpart / 2.0;
+	end;
+
+    (* limit the integer bits *)
+	if intlength > Float32FractBits then intlength := Float32FractBits;
+
+	(* process bits after the point, if we have any bits left *)
+	if fractlength > 0 then
+	begin	
+		for i := 1 to fractlength do
+		begin
+			fract := fract * 2;
+			digit := trunc(fract) and 1;
+			fractbin := (fractbin shl 1) + digit;
+		end;
+
+	end;
+
+	floatbin := (intbin << (Float32FractBits - intlength)) + fractbin;
+
+	if floatbin = 0 then (* if mantissa is zero, return a clean zero value *)
+		encodefloat32 := 0
+	else
+	begin
+		exponent := exponent + Float32ExpBias;
+		if (exponent > Float32ExpMax) or (exponent < 0) then
+			errorExit2('float exponent overflow','');
+		encodefloat32 := (sign shl (wordBits-1)) + (floatbin << Float32ExpBits) + exponent;
+	end;
+end;

pcomp/float32+tdr.pas

@@ -0,0 +1,2 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+function encodefloat32(r:real):integer; external;

pcomp/libgen.pas

@@ -0,0 +1,304 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+program libgen;
+
+const	shortcutChar = '`';
+	firstShCChar = 'A';
+	lastShCChar = 'i';
+
+	OutfileSuffix = '.lib';
+
+{$I 'platfile-types+.pas'}
+
+type
+	InsString = string[24];
+
+var shortcuts:array [firstShCChar..lastShCChar] of InsString;
+    infile:TextFile;
+    outfile:TextFile;
+    infileName:string;
+    outfileName:string;
+    lineCount:integer;
+
+procedure errorExit2(reason:string;arg:string); forward;
+
+{$I 'platfile+.pas'}
+
+procedure errorExit2(reason:string;arg:string);
+begin
+	writeln;
+	writeln('Error: ', reason, ' ', arg);
+	halt;
+end;
+
+procedure addShortcut(ch:char; dest:InsString);
+begin
+	shortcuts[ch] := dest;
+end;
+
+function findShortcut(ins:InsString):char;
+var ch:char;
+begin
+	findShortCut := #0;
+
+	for ch := firstShCChar to lastShCChar do
+	begin
+		if shortcuts[ch] = ins then
+		begin
+			findShortcut := ch;
+			break;
+		end;
+	end;
+	{ if findShortCut = #0 then writeln('findShortcut:#0'); }
+end;
+
+procedure initShortcuts;
+begin
+	addShortcut('A', 'ADD');
+	addShortcut('B', 'BRANCH');
+	addShortcut('C', 'CALL');
+	addShortcut('D', 'DUP');
+	addShortcut('E', 'LOADREL');
+	addShortcut('F', 'LOAD');
+	addShortcut('G', 'LOADREG');
+	addShortcut('H', 'SHL');
+	addShortcut('I', 'LOADI');
+	addShortcut('J', 'JUMP');
+	addShortcut('K', 'LOADC');
+	addShortcut('L', 'LOADCP');
+	addShortcut('M', 'STORE');
+	addShortcut('N', 'NIP');
+	addShortcut('O', 'OR');
+	addShortcut('P', 'DROP');
+	(* Q is unused *)
+	addShortcut('R', 'RET');
+	addShortcut('S', 'STOREI');
+	addShortcut('T', 'NOT');
+	addShortcut('U', 'CMPU');
+	addShortcut('V', 'OVER');
+	addShortcut('W', 'SWAP');
+	addShortcut('X', 'XOR');
+	(* Y is ununsed *)
+	addShortcut('Z', 'SUB');
+	addShortcut('a', 'AND');
+	addShortcut('b', 'CBRANCH');
+	addShortcut('c', 'CMP');
+	addShortcut('d', 'DEC');
+	(* e is unused *)
+	addShortcut('f', 'FPADJ');
+	addShortcut('g', 'STOREREG');
+	addShortcut('h', 'SHR');
+	addShortcut('i', 'INC');
+end;
+
+procedure processLine(var linebuf:string);
+var labelEnd:integer;
+    dotPos:integer;
+    endPos:integer;
+    insStart:integer;
+    insEnd:integer;
+    labelBuf:string;
+    insBuf:string;
+    restBuf:string;
+    short:char;
+
+procedure scanLine;
+var c:char;
+    i:integer;
+begin
+	labelEnd := 0;
+	dotPos := 0;
+	endPos := 0;
+	insStart := 0;
+	insEnd := 0;
+
+	i := 1;
+	for c in linebuf do
+	begin
+		if (labelEnd = 0) and (c = ':') then
+		begin
+			insStart := 0;
+			insEnd := 0;
+			labelEnd := i;
+		end
+		else
+		if (dotPos = 0) and (c = '.') then
+		begin
+			insEnd := i - 1;
+			dotPos := i;
+		end
+		else
+		if c = ';' then break
+		else
+		if c in [ ' ', #9 ] then
+		begin
+			if (insStart <> 0 ) and (insEnd = 0) then
+				insEnd := i - 1;
+		end
+		else
+		if c in [ '''', '"' ] then
+		begin
+			(* we do not want to deal with string quoting,
+				so if we encounter some quotes,
+				just do nothing *)
+			insStart := 0;
+			insEnd := 0;
+			labelEnd := 0;
+			endPos := length(linebuf);
+			break;
+		end
+		else
+		begin
+			if insStart = 0 then
+				insStart := i;
+			endPos := i;
+			{ writeln('c:', c, ' i:', i, ' insStart:', insStart); }
+		end;
+
+		i := i + 1;
+	end;
+	if insEnd = 0 then insEnd := endPos;
+end;
+
+begin
+	if length(linebuf) > 0 then
+		if linebuf[1] <> '%' then
+	begin
+		scanLine;
+		if labelEnd > 0 then
+			labelBuf := copy(linebuf,1,labelEnd)
+		else
+			labelBuf := '';
+
+		if insStart > 0 then
+			insBuf := copy(linebuf, insStart, insEnd - insStart + 1)
+		else
+			insBuf := '';
+
+		if endPos <> insEnd then
+			restBuf := copy(linebuf, insEnd + 1, endPos - insEnd + 1)
+		else
+			restBuf := '';
+	{
+		writeln('ins ', insBuf);
+		writeln('label ', labelBuf);
+		writeln('rest ', restBuf);
+		writeln('insStart ', insStart);
+		writeln('insEnd ', insEnd);
+		writeln('dotPos ', dotPos);
+		writeln('endPos ', endPos);
+	}
+		short := #0;
+		if length(insBuf) > 0 then
+		begin
+			(* if we found an instruction, try to find a shortcut *)
+			short := findShortcut(insBuf);
+
+			if short <> #0 then
+				writeln(outfile, labelBuf, '`', short, restBuf)
+			else
+				(* if no shortcut, we still remove comments and whitespace *)
+				writeln(outfile, labelBuf, ' ', insBuf, restBuf);
+		end
+		else
+			(* no instruction found, probably a directive, so
+				no change *)
+			writeln(outfile, linebuf);
+	end
+	else
+		writeln(outfile, linebuf);
+end;
+
+procedure processAllLines;
+var linebuf:string;
+begin
+	while not eof(infile) do
+	begin
+		readln(infile, linebuf);
+		lineCount := lineCount + 1;
+		if (lineCount and 255) = 1 then
+			write(lineCount, ' lines', #13);
+		processLine(linebuf);
+	end;
+	writeln(lineCount, ' lines');
+end;
+
+procedure test;
+var buf:string;
+begin
+	outfile := output;
+
+	buf := 'LABEL: SOMEINS.MOD1.MOD2 ARG ; a comment';
+	processLine(buf);
+	buf := '  SOMEINS.MOD1.MOD2 ARG ; a comment';
+	processLine(buf);
+	buf := '	LOADCP 1';
+	processLine(buf);
+	buf := '	JUMP';
+	processLine(buf);
+	buf := 'LABEL:   FPADJ -20';
+	processLine(buf);
+	buf := 'LABEL:   .BYTE ":;123"';
+	processLine(buf);
+	buf := 'LABEL:   .LCBRANCH SOMEWHERE';
+	processLine(buf);
+	buf := 'LABEL:   LOADC '';''';
+	processLine(buf);
+end;
+
+function changeSuffix(var fname:string):string;
+var dotPos:integer;
+    found:boolean;
+begin
+	found := false;
+
+	for dotPos := length(fname) downto 1 do
+		if fname[dotPos] = '.' then
+		begin
+			found := true;
+			break;
+		end;
+
+	if found then
+		changeSuffix := copy(fname,1, dotPos - 1) + OutfileSuffix
+	else
+		changeSuffix := fname + OutfileSuffix;
+end;
+
+begin
+	initShortcuts;
+
+	{ test;
+	halt; }
+
+	outfileName := '';
+
+	case ParamCount of
+	0:	begin
+			write('Source file: ');
+			readln(infileName);
+		end;
+	1:	infileName := ParamStr(1);
+	2:	begin
+			infileName := ParamStr(1);
+			outfileName := ParamStr(2);
+		end
+	else
+		begin
+			writeln('Invalid arguments.');
+			halt;
+		end;
+	end;
+
+	if length(outfileName) = 0 then
+		outfileName := changeSuffix(infileName);
+
+	writeln('Output file: ', outfileName);
+
+	openTextFile(infile, infileName);
+	overwriteTextFile(outfile, outfileName);
+
+	processAllLines;
+
+	close(infile);
+	close(outfile);
+end.

pcomp/lsymgen.pas

@@ -0,0 +1,111 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+program lsymgen;
+
+const OutfileSuffix = '.lsym';
+
+{$I 'platfile-types+.pas'}
+
+var
+    outfile:TextFile;
+    infile:TextFile;
+    lineno:integer;
+
+procedure errorExit2(reason:string;arg:string); forward;
+
+{$I 'platfile+.pas'}
+
+procedure errorExit2(reason:string;arg:string);
+begin
+	writeln;
+	writeln('Error: ', reason, ' ', arg);
+	writeln('at ', lineno);
+	halt;
+end;
+
+function rpos(c:char; var s:string):integer;
+var i:integer;
+begin
+	for i := length(s) downto 1 do
+		if s[i] = '.' then break;
+	if i = 1 then
+		rpos := 0
+	else
+		rpos := i;
+end;
+
+function strcontains(var s:string; c:char):boolean;
+begin
+	strcontains := pos(c, s) > 0;
+end;
+
+function getOutfileName(infileName:string):string;
+var p:integer;
+begin
+	p := rpos('.', infileName);
+	if p > 1 then
+		getOutfileName := copy(infileName, 1, p - 1)
+	else
+		getOutfileName := infileName;
+
+	getOutfileName := getOutfileName + OutfileSuffix;
+end;
+
+procedure splitLine(var line:string; var addr:string; var name:string;
+		var clean:boolean);
+var n,l:integer;
+begin
+	n := pos(' ', line);
+
+	if n <= 1 then
+		errorExit2('invalid syntax:', line);
+
+	addr := copy(line, 1, n - 1);
+
+	l := length(line);
+	while (n < l) and (line[n] = ' ') do
+		n := n + 1;
+
+	name := copy(line, n, l - n + 1);
+
+
+	(* symbols starting with '!' are explicitly exported *)
+	if name[1] = '!' then
+	begin
+		clean := true;
+		name := copy(name, 2, length(name) - 1);
+	end
+	else
+		clean := (not strcontains( name, '_')) and (name[1] <> '=');
+end;
+
+procedure processFile(inpath,outpath:string);
+var line:string;
+    addr,name:string;
+    clean:boolean;
+begin
+	lineno := 0;
+	writeln('writing file ', outpath);
+
+	openTextFile(infile, inpath);
+
+	overwriteTextFile(outfile, outpath);
+
+	while not eof(infile) do
+	begin
+		readln(infile, line);
+		splitLine(line, addr, name, clean);
+		if clean then
+			writeln(outfile, #9, '.EQU ', name, ' $', addr);
+	end;
+	close(infile);
+	close(outfile);
+end;
+
+begin
+	if ParamCount > 0 then
+	begin
+		processFile(ParamStr(1), getOutfileName(ParamStr(1)));
+	end
+	else
+		writeln('No file name given.');
+end.

pcomp/make.bat

@@ -0,0 +1,38 @@
+del *.s
+del ..\lib\*.lib
+del ..\lib\stdlib.s
+
+fpc -Mobjfpc -gl pcomp.pas
+fpc -gl sasm.pas
+fpc -gl lsymgen.pas
+
+sasm ..\lib\coreloader.s
+lsymgen ..\lib\coreloader.sym
+py pcomp.py -n ..\lib\stdlib.pas
+libgen ..\lib\stdlib.s
+libgen ..\lib\runtime.s
+libgen ..\lib\float32.s
+
+py pcomp.py sasm.pas
+py pcomp.py pcomp.pas
+py pcomp.py lsymgen.pas
+py pcomp.py libgen.pas
+
+rem exit /b
+
+py pcomp.py ..\progs\shell.pas
+py pcomp.py ..\progs\editor.pas
+py pcomp.py ..\progs\reclaim.pas
+py pcomp.py ..\progs\dumpdir.pas
+py pcomp.py ..\progs\partmgr.pas
+py pcomp.py ..\progs\xfer.pas
+
+rem exit /b
+
+py pcomp.py ..\tests\readtest.pas
+py pcomp.py ..\tests\readchartest.pas
+py pcomp.py ..\tests\timetest.pas
+py pcomp.py ..\tests\test133.pas
+py pcomp.py ..\examples\chase.pas
+py pcomp.py ..\tests\cchangetest.pas
+py pcomp.py ..\tests\tree.pas

pcomp/pcomp.py

@@ -0,0 +1,102 @@
+#!/usr/bin/python3
+# vim: tabstop=8 expandtab shiftwidth=4 softtabstop=4
+# Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details 
+
+import sys
+import subprocess
+import os
+
+suffixes = [ '.teeny', '.pas' ]
+compiler = 'pcomp'
+#assembler = '..\sasm\sasm.py'
+assembler = 'sasm'
+emulator = 's4emu.py'
+
+asm_include_path = '../lib'
+
+def run_compiler(filename, opts):
+    print("compiling {}...".format(filename))
+    args = [compiler]
+    args.extend(opts)
+    args.append(filename)
+    #print("args:",args)
+    status = subprocess.call(args)
+    if status != 0:
+        sys.exit(2)
+
+
+def run_assembler(filename):
+    print("assembling {}...".format(filename))
+    args = [assembler]
+    # args.extend([ '-I', asm_include_path])
+    args.append(filename)
+    status = subprocess.call(args)
+    if status != 0:
+        sys.exit(3)
+
+
+def run_emulator(filename, extra_args):
+    args = ['py', emulator, '-a', '24576', filename ]
+    args.extend(extra_args)
+    status = subprocess.call(args)
+    if status != 0:
+        sys.exit(4)
+
+
+def get_compiler_options():
+    comp_options = [ "-n", "-s", "-e", "-R", "-S", "-H" ]
+    result = []
+    while len(sys.argv) > 1 and sys.argv[1] in comp_options:
+        result.append(sys.argv[1])
+       	if sys.argv[1] == "-H":
+       	    sys.argv.pop(1)
+            result.append(sys.argv[1])
+        sys.argv.pop(1)
+    # print("Compiler options:",result, sys.argv[1])
+    return result
+
+
+def main():
+    do_compile = True
+    do_assemble = True
+    do_emulator = False
+    if len(sys.argv) < 2:
+        print("Usage: {} <input file>".format(sys.argv[0]))
+        sys.exit(1)
+
+    compiler_options = get_compiler_options()
+    infilename = sys.argv[1]
+    basename = infilename
+
+    if infilename.endswith('.s'):
+        do_compile = False
+        basename = infilename[:-2]
+    elif infilename.endswith('.bin') or infilename.endswith('.prog'):
+        do_compile = False
+        do_assemble = False
+        do_emulator = True
+        basename = infilename[:-4]
+    else:
+        fname, suffix = os.path.splitext(infilename)
+        if suffix in suffixes:
+            print("#############",fname, "####",suffix)
+            basename = fname
+
+    asmfilename = basename + '.s'
+    #binfilename = basename + '.bin'
+    binfilename = basename + '.prog'
+
+    if "-n" in compiler_options:
+        # Assembling stdlib won't work
+        do_assemble = False
+        do_emulator = False
+
+    if do_compile:
+        run_compiler(infilename, compiler_options)
+    if do_assemble:
+        run_assembler(asmfilename)
+    if do_emulator:
+        run_emulator(binfilename, sys.argv[2:])
+
+if __name__ == '__main__':
+    main()

pcomp/platfile+.pas

@@ -0,0 +1,17 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+procedure openTextFile(var f:TextFile; filename:string);
+begin
+{$I-}
+	assign(f, filename);
+	reset(f);
+
+	if IOResult <> 0 then
+		errorExit2('cannot open file', filename);
+{$I+}
+end;
+
+procedure overwriteTextFile(var f:TextFile; filename:string);
+begin
+	assign(f, filename);
+	rewrite(f);
+end;

pcomp/platfile+tdr.pas

@@ -0,0 +1,12 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+procedure openTextFile(var f:TextFile; filename:string);
+begin
+	open(f, filename, ModeReadOnly);
+	if IOResult(f) <> 0 then
+		errorExit2('cannot open file', filename);
+end;
+
+procedure overwriteTextFile(var f:TextFile; filename:string);
+begin
+	open(f, filename, ModeOverwrite);
+end;

pcomp/platfile-types+.pas

@@ -0,0 +1,2 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+type TextFile = text;

pcomp/platfile-types+tdr.pas

@@ -0,0 +1,2 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+type	TextFile = file;

pcomp/platform+.pas

@@ -0,0 +1,53 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+procedure initPlatform;
+begin
+	outputPrefix := '';
+	includePrefix := '..\lib\';
+end;
+
+procedure newString(var s:StringRef;len:integer);
+begin
+	new(s);
+end;
+
+procedure openFileWithDefault(var f:InputFileType; filename:string);
+begin
+{$I-}
+	assign(f, filename);
+	reset(f);
+
+	if IOResult <> 0 then
+	begin
+		assign(f, includePrefix + '/' + filename);
+		reset(f);
+		if IOResult <> 0 then
+			errorExit2('cannot open file', filename);
+	end;
+{$I+}
+end;
+
+procedure overwriteFile(var f:OutputFileType; filename:string);
+begin
+	assign(f, outputPrefix + filename);
+	rewrite(f);
+end;
+
+function isdigit(aChar:char):boolean;
+begin
+	isdigit := (ord(aChar) >= ord('0')) and (ord(aChar) <= ord('9'));
+end;
+
+procedure ExecEditor(var filename:string; lineno:integer; errormsg:string);
+begin
+	halt;
+end;
+
+procedure ExecAssembler(var filename:string; doRun:boolean; editOnError:boolean);
+begin
+	halt;
+end;
+
+procedure ExecProgram(var filename:string);
+begin
+	halt;
+end;

pcomp/platform+tdr.pas

@@ -0,0 +1,76 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+procedure initPlatform;
+begin
+	outputPrefix := '';
+	includePrefix := '#SYSTEM:';
+end;
+
+procedure newString(var s:StringRef;len:integer);
+begin
+	new(s,len);
+end;
+
+procedure openFileWithDefault(var f:InputFileType; filename:string);
+begin
+	open(f, filename, ModeReadOnly);
+	if IOResult(f) <> 0 then
+	begin
+		open(f, includePrefix + filename, ModeReadOnly);
+		if IOResult(f) <> 0 then
+			errorExit2('cannot open file', filename);
+	end;
+end;
+
+procedure overwriteFile(var f:OutputFileType; filename:string);
+begin
+	open(f, outputPrefix + filename, ModeOverwrite);
+end;
+
+procedure printExecErr(filename:string; error:integer);
+begin
+	writeln('PExec failed for ', filename, ': ', ErrorStr(error));
+end;
+
+procedure ExecEditor(var filename:string; lineno:integer; errormsg:string);
+var args:PArgVec;
+    error:integer;
+    digits:string[12];
+begin
+	str(lineno, digits);
+	args[0] := '-l'; args[1] := digits;
+	args[2] := '-E'; args[3] := errormsg;
+	args[4] := filename;
+	PExec('#SYSTEM:editor.prog', args, 5, error);
+	printExecErr('#SYSTEM:editor.prog', error);
+end;
+
+procedure ExecAssembler(var filename:string; doRun:boolean; editOnError:boolean);
+var args:PArgVec;
+    argPos:integer;
+    error:integer;
+begin
+	if doRun then
+	begin
+		args[0] := '-R';
+		argPos := 1;
+	end
+	else
+		argPos := 0;
+	if editOnError then
+	begin
+		args[argPos] := '-e';
+		argPos := argPos + 1;
+	end;
+	args[argPos] := filename;
+	PExec('#SYSTEM:sasm.prog', args, argPos + 1, error);
+	printExecErr('#SYSTEM:editor.prog', error);
+end;
+
+procedure ExecProgram(var filename:string);
+var args:PArgVec;
+	error:integer;
+begin
+	writeln('Running ', filename, '...');
+	PExec(filename, args, 0, error);
+	printExecErr(filename, error);
+end;

pcomp/platform-types+.pas

@@ -0,0 +1,7 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+type
+	OutputFileType = text;
+	InputFileType = file of char;
+	SymFileType = text;
+
+	ExecAction = (Edit, Assemble, Run);

pcomp/platform-types+tdr.pas

@@ -0,0 +1,6 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+	OutputFileType = file;
+	InputFileType = file;
+	SymFileType = file;
+
+	ExecAction = (Edit, Assemble, Run);

pcomp/sdis.pas

@@ -0,0 +1,884 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+program sdis;
+{$R+}
+{$MODE objfpc}
+type
+	InputFileType = file of char;
+	OutputFileType = text;
+
+	KeywordString = string[128];
+	IdentString = string[80];
+
+	SymbolType = (ConstSymbol, LabelSymbol, SpecialSymbol);
+
+
+	Symbol = record
+		name:KeywordString;
+		value:integer;
+		typ:SymbolType;
+	end;
+
+	HashEntry = record
+		key:integer;
+		data:IdentString;
+		next:^HashEntry;
+	end;
+
+	HashRef = ^HashEntry;
+	HashBucket = ^HashEntry;
+	HashTable = array [0..255] of HashBucket;
+
+var infile:InputfileType;
+    filename:string;
+    pc:integer;
+    symbolTable: HashTable;
+
+procedure errorExit;
+begin
+	close(infile);
+	halt;
+end;
+
+procedure errorExit2(message1, message2: string);
+begin
+	writeln;
+	writeln('Error: ', message1, ' ', message2);
+	errorExit;
+end;
+
+procedure openFile(var f:InputFileType;var filename:string);
+begin
+{$I-}
+	assign(f, filename);
+	reset(f);
+
+	if IOResult <> 0 then
+		errorExit2('cannot open file ', filename);
+{$I+}
+end;
+
+function readChar:char;
+var c:char;
+begin
+	read(infile,c);
+	readChar := c;
+end;
+
+procedure readEol;
+var c:char;
+begin
+	c := readChar;
+	if c = #13 then
+	begin
+		c := readChar;
+	end;
+end;
+
+
+function readBin(len:integer):integer;
+var i,v:integer;
+    c:char;
+begin
+	v := 0;
+	for i := 1 to len do
+	begin
+		c := readChar;
+		v := v shl 8;
+		v := v or ord(c);
+	end;
+	readBin := v;
+end;
+
+function readAsciiBin(len:integer):integer;
+var i:integer;
+    w:integer;
+    c:char;
+    bits:integer;
+begin
+	bits := len * 8;
+	w := 0;
+	for i := 1 to bits do
+	begin
+		w := w shl 1;
+		c := readChar;
+		if c = '1' then
+			w := w or 1
+		else
+		if c = '0' then begin end;
+	end;
+	readAsciiBin := w;
+
+	(* read end of line *)
+	if (pc and 3) = 2 then
+		readEol;
+end;
+
+function readBytes(len:integer):integer;
+var w:integer;
+    c:char;
+    i:integer;
+begin
+	w := 0;
+	for i := 1 to len do
+	begin
+		read(infile, c);
+		w := (w shl 8) or ord(c);
+	end;
+
+	readBytes := w;
+	writeln('readBytes ',len, ': ', w);
+end;
+
+function readInstruction:integer;
+begin
+	(* readInstruction := readBytes(2); *)
+	readInstruction := readBin(2);
+end;
+
+function readWord:integer;
+begin
+	readWord := readBin(4);
+end;
+
+function convertHex(var digits:KeywordString):integer;
+var i,v,len:integer;
+    c:char;
+begin
+	len := length(digits);
+
+	i := 1;
+	convertHex := 0;
+
+	while i <= len do
+	begin
+		convertHex := convertHex shl 4;
+		c := UpCase(digits[i]);
+		if (c >= 'A') and (c <= 'F') then
+			v := ord(c) - ord('A') + 10
+		else
+		if (c >= '0') and (c <= '9') then
+			v := ord(c) - ord('0')
+		else
+			errorExit2('invalid number',digits);
+		convertHex := convertHex + v;
+		i := i + 1;
+	end;
+end;
+
+procedure hexstr(value:integer;var output:string);
+var i:integer;
+    nibble:integer;
+    c:char;
+begin
+	output := '00000000';
+
+	for i := 8 downto 1 do
+	begin
+		nibble := value and $F;
+		if nibble > 9 then
+			c := chr( ord('A') + nibble - 10)
+		else
+			c := chr( ord('0') + nibble);
+
+		output[i] := c;
+		value := value shr 4;
+		if value = 0 then break;
+	end;
+end;
+
+procedure writeHex(value:integer);
+var s:string;
+begin
+	hexstr(value,s);
+	write('$',s);
+end;
+
+procedure printAsciiWord(w:integer);
+var i:integer;
+    c:char;
+begin
+	write('"');
+	for i := 1 to 4 do
+	begin
+		c := chr(((w shr 24) and $FF));
+		w := w shl 8;
+		if (c < ' ') or (c > '~') then
+			c := '.';
+		write(c);
+	end;
+	write('"');
+end;
+
+
+{$R-}
+(* disable range checks for 32-bit hash functions *)
+
+(* hash a 32-bit integer into an 8-bit integer *)
+function hashint(value:integer):integer;
+var i:integer;
+begin
+	hashint := 0;
+	value := value xor $B298AB49; (* some random 32-bit constant *)
+	for i := 1 to 4 do
+	begin
+		hashint := hashint xor (value and $FF);
+		value := value shr 8;
+	end;
+end;
+
+{$R+}
+
+procedure putHashed(var t:HashTable;key:integer;var data:KeywordString);
+var i:integer;
+    newEntry:^HashEntry;
+    bucket:HashBucket;
+begin
+	new(newEntry);
+	newEntry^.data := data;
+	newEntry^.key := key;
+
+	i := hashint(key);
+	bucket := t[i];
+	newEntry^.next := bucket;
+	t[i] := newEntry;
+end;
+
+function getHashed(var t:HashTable;key:integer):HashRef;
+var bucket:HashBucket;
+    current:^HashEntry;
+    found:boolean;
+begin
+	getHashed := nil;
+	bucket := t[hashint(key)];
+	current := bucket;
+	found := false;
+
+	while (current <> nil) and not found do
+	begin
+		if current^.key = key then
+		begin
+			getHashed := current;
+			found := true;
+		end;
+		current := current^.next;
+	end;
+end;
+
+function getHashBucket(var t:HashTable;key:integer):HashRef;
+begin
+	getHashBucket := t[hashint(key)];
+end;
+
+procedure dumpHash(var t:HashTable);
+var i:integer;
+    bucket:HashBucket;
+    current:HashRef;
+begin
+	for i := 0 to 255 do
+	begin
+		write('bucket ',i:4, ' ');
+		bucket := t[i];
+		current := bucket;
+		while current <> nil do
+		begin
+			write(current^.key, ':', current^.data, ' ');
+			current := current^.next;
+		end;
+		writeln;
+	end;
+end;
+
+procedure printEol;
+begin
+	writeln;
+end;
+
+procedure printHex(value:integer);
+var s:string[8];
+begin
+	write('$');
+	hexstr(value, s);
+	write(s);
+end;
+
+procedure printOperand(operand:integer);
+var sym:HashRef;
+begin
+	sym := getHashed(symbolTable, operand);
+	if sym <> nil then
+	begin
+		write(sym^.data);
+		write('  ; ');
+	end;
+
+	printHex(operand);
+end;
+
+procedure printSpacedOperand(operand:integer);
+begin
+	write(' ');
+	printOperand(operand);
+end;
+
+(* operates on numbers with less than 32 bits, signmask indicates the
+	highest bit which is the sign *)
+function makepositive(operand, signmask:integer):integer;
+begin
+	if (operand and signmask) <> 0 then
+		makepositive := signmask - (operand and (not signmask))
+	else
+		makepositive := operand;
+end;
+
+function signExtend(operand, signmask:integer):integer;
+begin
+	if (operand and signmask) <> 0 then
+		signExtend := -(signmask - (operand and (not signmask)))
+	else
+		signExtend := operand;
+end;
+
+procedure printSignedOperand(operand, signmask:integer);
+var sym:HashRef;
+begin
+	write(' ');
+	sym := getHashed(symbolTable, operand);
+	if sym <> nil then
+		write(sym^.data)
+	else
+	begin
+		if operand and signmask <> 0 then
+		begin
+			write('-');
+			operand := makepositive(operand, signmask);
+		end;
+		printHex(operand);
+	end;
+end;
+
+procedure decodeBranch(operand:integer);
+begin
+	write('BRANCH');
+	printSpacedOperand(pc + signExtend(operand, $1000));
+end;
+
+procedure decodeCbranch(operand:integer);
+begin
+	write('CBRANCH');
+	if (operand and 1) = 1 then
+		write('.NZ')
+	else
+		write('.Z');
+
+	printSpacedOperand(pc + signExtend((operand and $FFFE), $100));
+end;
+
+
+procedure decodeLoadc(operand:integer);
+begin
+	write('LOADC');
+	printSignedOperand(operand, $1000);
+end;
+
+procedure decodeLoadStore(name:string; operand:integer);
+begin
+	write(name);
+	if (operand and 1) = 1 then
+		write('.B');
+
+	printSpacedOperand(operand and $FFFE);
+end;
+
+procedure decodeModifier(name:string;value, mask:integer; operand:integer; visible:boolean);
+begin
+	if (operand and mask) = value then
+		if visible then
+			write('.',name);
+end;
+
+procedure decodeXfer(operand:integer);
+begin
+	write('XFER');
+	decodeModifier('RSM1', $0300, $0300, operand, true);
+	decodeModifier('RS0',  $0000, $0300, operand, false);
+	decodeModifier('RS1',  $0100, $0300, operand, true);
+	decodeModifier('R2P',  $0080, $0080, operand, true);
+	decodeModifier('P2R',  $0040, $0040, operand, true);
+	decodeModifier('SM1',  $0030, $0030, operand, true);
+	decodeModifier('S0',   $0000, $0030, operand, false);
+	decodeModifier('S1',   $0010, $0030, operand, true);
+	decodeModifier('X2P',  $0001, $0001, operand, true);
+end;
+
+procedure printCmpOperand(operand:integer);
+begin
+	case operand of
+		2: write('EQ');
+		6: write('NE');
+		1: write('LT');
+		3: write('LE');
+		5: write('GE');
+		7: write('GT');
+		else write('<unknown:',operand,'>');
+	end;
+end;
+
+procedure decodeAlu(operand:integer);
+var aluop:integer;
+begin
+	write('ALU');
+	decodeModifier('ADD',  $0000, $1e00, operand, true);
+	decodeModifier('SUB',  $0200, $1e00, operand, true);
+	decodeModifier('NOT',  $0400, $1e00, operand, true);
+	decodeModifier('AND',  $0600, $1e00, operand, true);
+	decodeModifier('OR',   $0800, $1e00, operand, true);
+	decodeModifier('XOR',  $0a00, $1e00, operand, true);
+	decodeModifier('CMP',  $0c00, $1e00, operand, true);
+	decodeModifier('Y',    $0e00, $1e00, operand, true);
+	decodeModifier('SHR',  $1000, $1e00, operand, true);
+	decodeModifier('SHL',  $1200, $1e00, operand, true);
+	decodeModifier('INC',  $1400, $1e00, operand, true);
+	decodeModifier('DEC',  $1600, $1e00, operand, true);
+	decodeModifier('BPLC', $1a00, $1e00, operand, true);
+	decodeModifier('BROT', $1c00, $1e00, operand, true);
+	decodeModifier('BSEL', $1e00, $1e00, operand, true);
+	decodeModifier('CMPU', $1800, $1e00, operand, true);
+
+	decodeModifier('SM1',  $0030, $0030, operand, true);
+	decodeModifier('S0',   $0000, $0030, operand, false);
+	decodeModifier('S1',   $0010, $0030, operand, true);
+	decodeModifier('X2Y',  $0040, $0040, operand, true);
+	decodeModifier('NX2Y', $0000, $0040, operand, false);
+	decodeModifier('XT',   $0080, $0080, operand, true);
+
+	aluop := operand and $1e00;
+	operand := operand and 15;
+
+	if (aluop = $1800) or (aluop = $0c00) then
+	begin
+		write(' ');
+		printCmpOperand(operand);
+	end
+	else
+	if operand > 0 then
+		printSpacedOperand(operand);
+end;
+
+procedure decodeLoadrel(offset:integer);
+begin
+	write('LOADREL');
+	printSpacedOperand(pc + offset);
+end;
+
+procedure decodeMem(operand:integer);
+begin
+	if (operand and $0200) <> 0 then
+	begin
+		write('STOREI');
+		decodeModifier('SM1',  $0030, $0030, operand, false);
+		decodeModifier('S0',   $0000, $0030, operand, true);
+		decodeModifier('S1',   $0010, $0030, operand, true);
+		decodeModifier('X2Y',  $0040, $0040, operand, true);
+		decodeModifier('NX2Y', $0000, $0040, operand, false);
+		decodeModifier('XT',   $0080, $0080, operand, true);
+	end
+	else
+	begin
+		write('LOADI');
+		decodeModifier('SM1',  $0030, $0030, operand, true);
+		decodeModifier('S0',   $0000, $0030, operand, false);
+		decodeModifier('S1',   $0010, $0030, operand, true);
+		decodeModifier('X2Y',  $0040, $0040, operand, true);
+		decodeModifier('NX2Y', $0000, $0040, operand, false);
+		decodeModifier('XT',   $0080, $0080, operand, true);
+	end;
+	operand := operand and 15;
+	if operand > 0 then
+		printSpacedOperand(operand);
+end;
+
+procedure printRegOperand(operand:integer);
+begin
+	case operand of
+		0: write('FP');
+		1: write('BP');
+		2: write('RP');
+		3: write('IV');
+		4: write('IR');
+		5: write('ESP');
+		else write('<unknown:',operand,'>');
+	end;
+end;
+
+procedure decodeReg(operand:integer);
+begin
+	if (operand and $0200) <> 0 then
+		write('STOREREG ')
+	else
+		write('LOADREG ');
+
+	operand := operand and 15;
+	printRegOperand(operand);
+end;
+
+procedure decodeExt(operand:integer);
+var extop:integer;
+begin
+	extop := (operand and $1C00) shr 10;
+
+	if extop = 0 then
+		decodeReg(operand)
+	else
+	if extop = 1 then
+		decodeMem(operand)
+	(*
+	else
+	if extop = 2 then
+	begin
+		{ unused }
+	end *)
+	else
+	if extop = 3 then
+	begin
+		write('FPADJ ');
+		printSignedOperand(operand and $03FF, $200);
+	end
+	else
+	if extop = 5 then
+		decodeLoadrel(operand and $03FF)
+	else
+		write('<EXT unknown:', extop,'>');
+end;
+
+procedure decodeInstruction(w:integer);
+var baseIns:integer;
+    baseOperand:integer;
+begin
+	baseIns := (w and $E000) shr 13;
+	baseOperand := (w and $1FFF);
+
+	(* writeln(baseIns, ' ', baseOperand); *)
+
+	if baseIns = 0 then
+		decodeBranch(baseOperand)
+	else
+	if baseIns = 1 then
+		decodeAlu(baseOperand)
+	else
+	if baseIns = 2 then
+		decodeLoadStore('STORE', baseOperand)
+	else
+	if baseIns = 3 then
+		decodeXfer(baseOperand)
+	else
+	if baseIns = 4 then
+		decodeLoadStore('LOAD', baseOperand)
+	else
+	if baseIns = 5 then
+		decodeCbranch(baseOperand)
+	else
+	if baseIns = 6 then
+		decodeLoadc(baseOperand)
+	else
+	if baseIns = 7 then
+		decodeExt(baseOperand)
+	else
+		write('???');
+
+	pc := pc + 2;
+
+	(* write(' (', baseIns, ')');
+	writeHex(w); *)
+
+	printEol;
+end;
+
+function isConstantPool(sym:HashRef):boolean;
+begin
+	isConstantPool := false;
+
+	if sym <> nil then
+	begin
+		if length(sym^.data) >= 4 then
+			isConstantPool :=
+				(sym^.data[1] = '_') and
+				(sym^.data[2] = 'C') and
+				(sym^.data[3] = 'P') and
+				(sym^.data[4] = '_');
+	end;
+end;
+
+function isStringConstant(sym:HashRef):boolean;
+begin
+	isStringConstant := false;
+
+	if sym <> nil then
+	begin
+		if length(sym^.data) >= 5 then
+			isStringConstant :=
+				(sym^.data[1] = '_') and
+				(sym^.data[2] = 'C') and
+				(sym^.data[3] = '_') and
+				(sym^.data[4] = 'S') and
+				(sym^.data[5] = '_');
+	end;
+end;
+
+procedure decodeIntConstant(upperHalf:integer);
+var lowerHalf:integer;
+    w:integer;
+begin
+{$R-}
+	pc := pc + 2;
+	(* need to increment pc in two steps
+		because readBin uses the pc to detect line endings
+		(which is probably a bad idea *)
+
+	lowerHalf := readInstruction;
+	w := (upperHalf shl 16) or lowerHalf;
+
+	pc := pc + 2;
+
+	write('.WORD ');
+	printOperand(w);
+	writeln;
+
+{$R+}
+end;
+
+procedure printPaddedLabel(sym:HashRef); forward;
+procedure printPc; forward;
+
+procedure printLeadin;
+begin
+	printPc;
+	printPaddedLabel(nil);
+end;
+
+procedure decodeString(upperHalf:integer);
+var lowerHalf:integer;
+    curLength,maxLength:integer;
+    i,wordCount:integer;
+    w:integer;
+begin
+	pc := pc + 2;
+	lowerHalf := readInstruction;
+	pc := pc + 2;
+	curLength := (upperHalf shl 16) or lowerHalf;
+	maxLength := readWord;
+
+	write('.WORD ');
+	printHex(curLength);
+	writeln;
+
+	printLeadin;
+	write('.WORD ');
+	printHex(maxLength);
+	writeln;
+	pc := pc + 4;
+
+	wordCount := curLength;
+	if maxLength > curLength then
+		wordCount := maxLength;
+
+	wordCount := (wordCount + 3) shr 2;
+
+	for i := 1 to wordCount do
+	begin
+		w := readWord;
+		printLeadin;
+		write('.BYTE ');
+		printAsciiWord(w);
+		writeln;
+		pc := pc + 4;
+	end;
+end;
+
+procedure printPaddedLabel(sym:HashRef);
+var pad:integer;
+begin
+	pad := 24;
+	if sym <> nil then
+	begin
+		write(sym^.data);
+		write(':');
+
+		pad := pad - length(sym^.data) - 1;
+	end;
+
+	while pad > 0 do
+	begin
+		write(' ');
+		pad := pad - 1;
+	end;
+	write('  ');
+end;
+
+procedure printPc;
+var hexaddr:string[8];
+begin
+	hexstr(pc, hexaddr);
+	write(hexaddr, ' ');
+end;
+
+procedure printLabels(adr:integer);
+var bucket:HashBucket;
+    current:HashRef;
+    first:boolean;
+begin
+	(* there can be multiple labels
+	   at an instruction address,
+	   so go through all elements
+	   in the corresponding hash bucket *)
+	first := true;
+	bucket := getHashBucket(symbolTable, adr);
+	current := bucket;
+	while current <> nil do
+	begin
+		if current^.key = adr then
+		begin
+			if not first then
+			begin
+				writeln;
+				(* printPc; *)
+				write('         ');
+			end
+			else
+				first := false;
+
+			printPaddedLabel(current);
+		end;
+		current := current^.next;
+	end;
+
+	if first then
+		printPaddedLabel(nil);
+end;
+
+procedure decodeFile;
+var w:integer;
+    sym:HashRef;
+begin
+	while not eof(infile) do
+	begin
+		printPc;
+		printLabels(pc);
+
+		w := readInstruction;
+
+		sym := getHashed(symbolTable, pc);
+		if isConstantPool(sym) then
+			decodeIntConstant(w)
+		else
+		if isStringConstant(sym) then
+			decodeString(w)
+		else
+			decodeInstruction(w);
+	end;
+end;
+
+procedure testHash;
+var s:string;
+    result:HashRef;
+    i:integer;
+begin
+	s := 'einszweidrei';
+	putHashed(symbolTable, 123, s);
+	s := 'vierfuenf';
+	putHashed(symbolTable, 45, s);
+	s := 'null';
+	putHashed(symbolTable, 0, s);
+	s := '0x7FFF1234';
+	putHashed(symbolTable, $7FFF1234, s);
+
+	result := getHashed(symbolTable, 123);
+	writeln('getHashed 123:', result^.data);
+
+	result := getHashed(symbolTable, 45);
+	writeln('getHashed 45:', result^.data);
+
+	result := getHashed(symbolTable, 0);
+	writeln('getHashed 0:', result^.data);
+
+	result := getHashed(symbolTable, $7FFF1234);
+	writeln('getHashed $7FFF1234:', result^.data);
+
+	for i := 1 to 5000 do
+	begin
+		str(i,s);
+		putHashed(symbolTable,i,s);
+	end;
+end;
+
+procedure readKeyword(var fil:InputFileType; var wordBuf:string);
+var c:char;
+    skipWhite:boolean;
+    done:boolean;
+begin
+	wordBuf := '';
+	done := false;
+	skipWhite := true;
+
+	repeat
+		read(fil,c);
+		if c in [ ' ', #9, #13, #10, #0 ] then
+		begin
+			if not skipWhite then
+				done := true;
+		end
+		else
+		begin
+			wordBuf := wordBuf + c;
+			skipWhite := false;
+		end;
+	until done or eof(fil);
+	if c = #13 then (* skip over CR/LF *)
+		read(fil,c);
+end;
+
+procedure readSymbolTable(var filename:string);
+var buf:string;
+    fil:InputFileType;
+    symStr:string;
+    num:integer;
+begin
+	openFile(fil, filename);
+	while not eof(fil) do
+	begin
+		readKeyword(fil,buf);
+		readKeyword(fil,symStr);
+		num := convertHex(buf);
+		putHashed(symbolTable, num, symStr);
+	end;
+
+	close(fil);
+end;
+
+function parseOrigin(s:string):integer;
+var i,c:integer;
+begin
+	val(s,i,c);
+	if c > 0 then
+		errorExit2('invalid number',s);
+	parseOrigin := i;
+end;
+
+begin
+	if paramCount < 1 then halt;
+
+	if paramCount >= 2 then
+	begin
+		filename := paramStr(2);
+		readSymbolTable(filename);
+	end;
+
+	if paramCount >= 3 then
+		pc := parseOrigin(paramStr(3));
+
+	filename := paramStr(1);
+	openFile(infile, filename);
+	decodeFile;
+	close(infile);
+
+	(* dumpHash(symbolTable); *)
+end.

pcomp/treeimpl.pas

@@ -0,0 +1,289 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+function makeTreeNode(var d:TreeData;var key:string;nparent:TreeRef):TreeRef;
+var newNode:TreeRef;
+    newKey:^string;
+begin
+	new(newNode);
+        { new(newKey,length(key)); }
+	newString(newKey, length(key));
+	new(newNode^.data);
+	newKey^ := key;
+	with newNode^ do
+	begin
+		key := newKey;
+		parent := nparent;
+		left := nil;
+		right := nil;
+		height := 1;
+		data^ := d;
+	end;
+	makeTreeNode := newNode;
+end;
+
+function MeasureTree(root:TreeRef):integer;
+var leftHeight, rightHeight:integer;
+begin
+	if root = nil then
+		MeasureTree := 0
+	else
+	begin
+		if root^.left <> nil then
+			leftHeight := root^.left^.height
+		else
+			leftHeight := 0;
+		if root^.right <> nil then
+			rightHeight := root^.right^.height
+		else
+			rightHeight := 0;
+		if rightHeight > leftHeight then
+			MeasureTree := rightHeight + 1
+		else
+			MeasureTree := leftHeight + 1;
+	end;
+end;
+
+function GetTreeBalance(root:TreeRef):integer;
+begin
+	if root = nil then
+		GetTreeBalance := 0
+	else
+		GetTreeBalance := MeasureTree(root^.left) - MeasureTree(root^.right);
+end;
+
+function RotateTreeRight(x:TreeRef):TreeRef;
+var z,tmp:TreeRef;
+begin
+	(* writeln('RotateTreeRight at ', x^.key^); *)
+	z := x^.left;
+	tmp := z^.right;
+	z^.right := x;
+	z^.parent := x^.parent;
+	x^.parent := z;
+	x^.left := tmp;
+	if tmp <> nil then
+		tmp^.parent := x;
+	x^.height := MeasureTree(x);
+	z^.height := MeasureTree(z);
+	RotateTreeRight := z;
+end;
+
+function RotateTreeLeft(x:TreeRef):TreeRef;
+var z,tmp:TreeRef;
+begin
+	(* writeln('RotateTreeLeft at ', x^.key^); *)
+	z := x^.right;
+	tmp := z^.left;
+	z^.left := x;
+	z^.parent := x^.parent;
+	x^.parent := z;
+	x^.right := tmp;
+	if tmp <> nil then
+		tmp^.parent := x;
+	x^.height := MeasureTree(x);
+	z^.height := MeasureTree(z);
+	RotateTreeLeft := z;
+end;
+
+function TreeInsert4(root:TreeRef;var key:string;var data:TreeData;
+	parent:TreeRef):TreeRef;
+var balance:integer;
+begin
+	if root = nil then
+		root := makeTreeNode(data, key, parent)
+	else
+	if key < root^.key^ then
+		root^.left := TreeInsert4(root^.left, key, data, root)
+	else
+		root^.right := TreeInsert4(root^.right, key, data, root);
+
+	root^.height := MeasureTree(root);
+
+	balance := GetTreeBalance(root);
+	if balance > 1 then
+	begin
+		if key < root^.left^.key^ then
+			root := RotateTreeRight(root)
+		else
+		begin
+			root^.left := RotateTreeLeft(root^.left);
+			root := RotateTreeRight(root);
+		end;
+	end
+	else
+	if balance < -1 then
+	begin
+		if key > root^.right^.key^ then
+			root := RotateTreeLeft(root)
+		else
+		begin
+			root^.right := RotateTreeRight(root^.right);
+			root := RotateTreeLeft(root);
+		end;
+	end;
+
+	TreeInsert4 := root;
+end;
+
+procedure TreeInsert(var root:TreeRef;var key:string;var data:TreeData);
+begin
+	root := TreeInsert4(root,key,data,nil);
+end;
+
+procedure DisposeTreeNode(node:TreeRef);
+begin
+	dispose(node^.key);
+	dispose(node^.data);
+	dispose(node);
+end;
+
+function TreeLeftmost(node:TreeRef):TreeRef;
+begin
+	TreeLeftmost := nil;
+	if node <> nil then
+	begin
+		repeat
+			TreeLeftmost := node;
+			node := node^.left;
+		until node = nil;
+	end;
+end;
+
+function TreeDeleteFn(root:TreeRef;var key:string):TreeRef;
+var tmp,oldParent:TreeRef;
+    balance:integer;
+begin
+	if root <> nil then
+	begin
+		if key < root^.key^ then
+			root^.left := TreeDeleteFn(root^.left, key)
+		else
+		if key > root^.key^ then
+			root^.right := TreeDeleteFn(root^.right, key)
+		else
+		begin
+			if root^.left = nil then
+			begin
+				tmp := root;
+				oldParent := root^.parent;
+				root := root^.right;
+				if root <> nil then
+					root^.parent := oldParent;
+				DisposeTreeNode(tmp);
+			end
+			else
+			if root^.right = nil then
+			begin
+				tmp := root;
+				oldParent := root^.parent;
+				root := root^.left;
+				if root <> nil then
+					root^.parent := oldParent;
+				DisposeTreeNode(tmp);
+			end
+			else
+			begin
+				tmp := TreeLeftmost(root^.right);
+				root^.key^ := tmp^.key^;
+				root^.data^ := tmp^.data^;
+				oldParent := tmp^.parent;
+				if oldParent^.left = tmp then
+					oldParent^.left := TreeDeleteFn(oldParent^.left, tmp^.key^)
+				else
+				if oldParent^.right = tmp then
+					oldParent^.right := TreeDeleteFn(oldParent^.right, tmp^.key^)
+				else
+				begin
+					writeln('TreeDelete internal error at', root^.key^);
+				end;
+			end;
+
+			if root <> nil then
+			begin
+				root^.height := MeasureTree(root);
+				balance := GetTreeBalance(root);
+				if balance > 1 then
+				begin
+					if GetTreeBalance(root^.left) >=0 then
+						root := RotateTreeRight(root)
+					else
+					begin
+						root^.left := RotateTreeLeft(root^.left);
+						root := RotateTreeRight(root);
+					end;
+				end
+				else
+				if balance < -1 then
+				begin
+					if GetTreeBalance(root^.right) <= 0 then
+						root := RotateTreeLeft(root)
+					else
+					begin
+						root^.right := RotateTreeRight(root^.right);
+						root := RotateTreeLeft(root);
+					end;
+				end;
+			end;
+		end;
+	end;
+	TreeDeleteFn := root;
+end;
+
+procedure TreeDelete(var root:TreeRef;var key:string);
+begin
+	root := TreeDeleteFn(root,key);
+end;
+
+function TreeSearch(root:TreeRef;var key:string):TreeDataRef;
+begin
+	if root <> nil then
+	begin
+		if key = root^.key^ then
+			TreeSearch := root^.data
+		else
+		if key < root^.key^ then
+			TreeSearch := TreeSearch(root^.left, key)
+		else
+			TreeSearch := TreeSearch(root^.right, key);
+	end
+	else
+		TreeSearch := nil;
+end;
+
+procedure TreeWalkStart(t:TreeRef; var state:TreeWalkState);
+begin
+	(* start at leftmost node of the tree *)
+	state.currentNode := TreeLeftmost(t);
+end;
+
+procedure TreeWalkNext(var state:TreeWalkState;var res:TreeRef);
+var last,current,right:TreeRef;
+begin
+	current := state.currentNode;
+
+	res := current;
+
+	if current <> nil then
+	begin
+			(* descending right *)
+		if current^.right <> nil then
+		begin
+			state.currentNode := TreeLeftmost(current^.right);
+		end
+		else	(* ascending *)
+		begin
+			repeat
+				last := current;
+				current := current^.parent;
+				if current <> nil then
+					right := current^.right;
+			until (right <> last) or (current = nil); (* ascend left edges *)
+			state.currentNode := current;
+		end;
+	end;
+end;
+
+procedure TreeWalkFirst(t:TreeRef; var state:TreeWalkState; var first:TreeRef);
+begin
+	TreeWalkStart(t, state);
+	TreeWalkNext(state, first);
+end;

pcomp/treetypes.pas

@@ -0,0 +1,26 @@
+(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
+{
+type TreedataType = (TDString, TDInteger);
+
+type Treedata = record
+        case typ:Treedatatype of 
+        TDString:(stringdata:string);
+        TDInteger:(intdata:integer);
+    end;
+}
+type StringRef = ^string;
+
+type TreeNode = record
+        parent: ^TreeNode;
+        left,right: ^TreeNode;
+        height: integer;
+	key: StringRef;
+	data: ^Treedata;
+    end;
+
+type TreeRef = ^TreeNode;
+     TreeDataRef = ^Treedata;
+
+type TreeWalkState = record
+		currentNode:TreeRef;
+	end;