From 028b1b969122d3a2a219ac935b71211a5d7027cf Mon Sep 17 00:00:00 2001
From: Sudipto Mallick <smlckz@disroot.org>
Date: Thu, 20 Jun 2024 00:19:16 +0000
Subject: First commit

---
 Makefile |   4 +
 pp.awk   |  98 +++++++++++++++
 vor.S    | 433 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 535 insertions(+)
 create mode 100644 Makefile
 create mode 100644 pp.awk
 create mode 100644 vor.S

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..e292a15
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,4 @@
+vor: vor.S pp.awk
+	awk -f pp.awk < $< | clang --target=armv6m-linux-eabi -mthumb -fuse-ld=lld -static -nostdlib -o $@ -x assembler -
+
+# clang --target=armv6m-linux-eabi -mthumb -fuse-ld=lld -static -nostdlib -o $@ $<
diff --git a/pp.awk b/pp.awk
new file mode 100644
index 0000000..3c13872
--- /dev/null
+++ b/pp.awk
@@ -0,0 +1,98 @@
+BEGIN {
+	last_word = 0
+}
+
+$1 == ".defword" {
+	define_word($2, "vor_" $2, $3, $4)
+	next
+}
+
+$1 == ".defvar" {
+	define_word($2, "vor_get_variable_address", $3)
+	print("\t.balign\t4")
+	print("\t.4byte\t" $2 "\n")
+	next
+}
+
+$1 == ".defwort" {
+	wortname = "vor_" $2
+	define_word($2, wortname, $3, $4)
+	print("\t.section\t.text.vor")
+	print("\t.thumb_func")
+	print(wortname ":")
+	print("\tpush\t{lr}")
+	next
+}
+
+$1 == ".dkw" {
+	define_word($2, "vor_" $2)
+	kurzwort_body($2, 3)
+	next
+}
+
+$1 == ".dkws" {
+	define_word($3, "vor_" $3, $2)
+	kurzwort_body($3, 4)
+	next
+}
+
+$1 == ".worte" {
+	for (i = 2; i <= NF; i++)
+		print("\tbl\tvor_" $i)
+	next
+}
+
+$1 == ".wortende" {
+	print("\tpop\t{pc}")
+	print("\t.fnsize\t" wortname)
+	next
+}
+
+$1 == ".literal" {
+	print("\tbl\tvor_lit")
+	print("\t.4byte\t" $2)
+	next
+}
+
+{ print }
+
+END {
+	if (last_word)
+		printf("\t.set\tvor_last_word, %s\n", last_word)
+}
+
+function kurzwort_body(name, i) {
+	print("\t.section\t.text.vor")
+	print("\t.thumb_func")
+	print("vor_" name ":")
+	print("\tpush\t{lr}")
+	for (; i <= NF; i++) {
+		if ($i ~ /^#/) {
+			print("\tbl\tvor_lit")
+			print("\t.4byte\t" substr($i, 2))
+		} else {
+			print("\tbl\tvor_" $i)
+		}
+	}
+	print("\tpop\t{pc}")
+	print("\t.fnsize\tvor_" name "\n")
+}
+
+function define_word(name, to_call, str, flags) {
+	if (!flags) flags = 0
+	if (!str) {
+		str = "\"" name "\""
+		gsub(/_/, "-", str)
+	}
+	printf("\t.rodata\n")
+	printf("vor_word_%s:\n", name)
+	printf("\t.4byte\t%s\n", last_word)
+	last_word = "vor_word_" name
+	printf("\t.4byte\t%s\n", to_call)
+	printf("\t.2byte\t%s\n", flags)
+	printf("\t.2byte\tvor_wordstrsize_%s\n", name)
+	printf("vor_wordstr_%s:\n", name)
+	printf("\t.ascii\t%s\n", str)
+	printf("\t.set\tvor_wordstrsize_%s, . - vor_wordstr_%s\n\n", name, name)
+}
+
diff --git a/vor.S b/vor.S
new file mode 100644
index 0000000..7525cf1
--- /dev/null
+++ b/vor.S
@@ -0,0 +1,433 @@
+	.arch	armv6m
+	.syntax	unified
+	.text
+	.global	_start
+	.thumb_func
+_start:
+	/* Preserve call stack pointer. */
+	ldr	r1, =sp_initial_value
+	mov	r0, sp
+	str	r0, [r1]
+	/* Perform memory allocations. */
+	ldr	r0, =input_buffer_size
+	ldr	r1, [r0]
+	movs	r0, #0		/* NULL */
+	movs	r2, #3		/* R|W */
+	movs	r3, #0x22	/* private (0x2) anonymous (0x20) mapping */
+	movs	r4, #1
+	negs	r4, r4		/* fd = -1 */
+	movs	r5, #0		/* offset = 0 */
+	movs	r7, #0xC0	/* sys_mmap2 */
+	svc	#0
+	bl	check_error
+	/* Assign input buffer. */
+	ldr	r1, =input_buffer
+	ldr	r2, =input_buffer_ptr
+	str	r0, [r1]
+	str	r0, [r2]
+	/* Allocate data stack. */
+	ldr	r0, =data_stack_size
+	ldr	r1, [r0]
+	movs	r0, #0
+	movs	r2, #3
+	svc	#0
+	bl	check_error
+	ldr	r2, =data_stack_start
+	str	r0, [r2]
+	/* Data stack grows downwards to take advantage of ldm/sdm instructions. */
+	add	r0, r0, r1
+	ldr	r2, =data_stack_ptr
+	str	r0, [r2]
+	/* Allocate expanse. */
+	ldr	r0, =expanse_size
+	ldr	r1, [r0]
+	movs	r0, #0
+	movs	r2, #7		/* R|W|X */
+	svc	#0
+	bl	check_error
+	ldr	r1, =expanse_start
+	ldr	r2, =expanse_ptr
+	str	r0, [r1]
+	str	r0, [r2]
+	/* Setup. */
+	ldr	r1, =data_stack_ptr
+	ldr	r0, [r1]
+	bl	vor_start
+	/* Exit with success. */
+	movs	r0, #0
+_exit:
+	movs	r7, #1
+	svc	#0
+	.size	_start, . - _start
+
+	.macro	.fnsize name
+	.size	\name , . - \name
+	.endm
+
+	.thumb_func
+check_error:
+	push	{r0-r2, lr}
+	movs	r1, #0
+	mvns	r1, r1
+	movs	r2, #12
+	lsls	r1, r2
+	cmp	r0, r1
+	bhi	.L_got_error
+	pop	{r0-r2, pc}
+.L_got_error:
+	negs	r0, r0
+	b	_exit
+	.fnsize	check_error
+
+	.thumb_func
+fill_input_buffer:
+	/* Read from the standard input to fill the input buffer. */
+	ldr	r1, =input_buffer
+	ldr	r2, =input_buffer_size
+	ldr	r1, [r1]
+	ldr	r2, [r2]
+	movs	r0, #0		/* stdin */
+	movs	r7, #3		/* sys_read */
+	svc	#0
+	bl	check_error
+	/* Negative return value from the system call indicates read error. */
+	ldr	r2, =input_buffer_length
+	ldr	r3, =input_buffer_ptr
+	ldr	r4, =input_buffer_end
+	str	r0, [r2]
+	str	r1, [r3]
+	add	r1, r1, r0
+	str	r1, [r4]
+	bx	lr
+.L_read_error:
+	movs	r0, #2
+	b	_exit
+	.fnsize	fill_input_buffer
+
+	.thumb_func
+read_byte:
+	/* Read a byte from the input buffer filled from the standard input. -1 is returned when no input is available to read. */
+	push	{lr}
+	bl	input_available
+	cmp	r0, #0
+	beq	.L_not_at_end
+	bx	lr
+.L_not_at_end:
+	ldr	r2, =input_buffer_ptr
+	ldr	r1, [r2]
+	ldrb	r0, [r1]
+	adds	r1, r1, #1 
+	str	r1, [r2]
+	pop	{pc}
+	.fnsize	read_byte
+
+	.thumb_func
+input_available:
+	/* Returns 0 if there is input left to be read from the input buffer or from the standard input, -1 otherwise. */
+	ldr	r0, =input_buffer_ptr
+	ldr	r1, =input_buffer_end
+	ldr	r0, [r0]
+	ldr	r1, [r1]
+	cmp	r0, r1
+	blo	.L_available
+	bl	fill_input_buffer
+	ldr	r0, =input_buffer_ptr
+	ldr	r1, =input_buffer_end
+	ldr	r0, [r0]
+	ldr	r1, [r1]
+	cmp	r0, r1
+	bhs	.L_not_available
+.L_available:
+	movs	r0, #0
+	bx	lr
+.L_not_available:
+	movs	r0, #1
+	negs	r0, r0		/* EOF (-1) */
+	bx	lr
+	.fnsize	input_available
+
+	.thumb_func
+is_space:
+	cmp	r0, #' '
+	beq	.L_is_space
+	cmp	r0, #'\t'
+	beq	.L_is_space
+	cmp	r0, #'\r'
+	beq	.L_is_space
+	cmp	r0, #'\n'
+	beq	.L_is_space
+	movs	r0, #0
+	bx	lr
+.L_is_space:
+	movs	r0, #1
+	bx	lr
+	.fnsize	is_space
+
+	.thumb_func
+read_word:
+	/* Returns word length and pointer to word in r0 and r1. Word length is zero when no word is available on input. */
+	push	{lr}
+.L_skip_space:
+	bl	read_byte
+	movs	r4, r0
+	adds	r3, r0, #1
+	beq	.L_word_finish
+	bl	is_space
+	cmp	r0, #1
+	beq	.L_skip_space
+	ldr	r2, =expanse_ptr
+	ldr	r1, [r2]
+.L_word_loop:
+	strb	r4, [r1]
+	adds	r1, #1
+	mov	r8, r1
+	bl	read_byte
+	movs	r4, r0
+	mov	r1, r8
+	adds	r3, r0, #1
+	beq	.L_word_finish
+	bl	is_space
+	cmp	r0, #1
+	bne	.L_word_loop
+.L_word_finish:
+	ldr	r2, =expanse_ptr
+	ldr	r4, [r2]
+	subs	r0, r1, r4
+	cmp	r0, #0
+	beq	.L_no_word
+	str	r1, [r2]
+	movs	r1, r4
+.L_no_word:
+	pop	{pc}
+	.fnsize	read_word
+
+	.data
+	.balign 4
+sp_initial_value:	.4byte	0
+
+	.set	KiB,	1 << 10
+	.set	MiB,	1 << 20
+
+input_buffer:		.4byte	0
+input_buffer_size:	.4byte	4 * KiB
+input_buffer_ptr:	.4byte	0
+input_buffer_end:	.4byte	0
+input_buffer_length:	.4byte	0
+
+data_stack_start:	.4byte	0
+data_stack_size:	.4byte	64 * KiB
+data_stack_ptr:		.4byte	0
+
+expanse_start:		.4byte	0
+expanse_size:		.4byte	8 * MiB
+expanse_ptr:		.4byte	0
+
+last_created_word:	.4byte	0
+
+	/*
+	.set	vor_last_word, 0
+	.macro	.defword name str flags=0
+	.rodata
+vor_word_\name\():
+	.4byte	vor_last_word
+	.set	vor_last_word, vor_word_\name
+	.4byte	vor_\name
+	.2byte	\flags
+	.2byte	vor_wordstrsize_\name
+vor_wordstr_\name\():
+	.ascii	"\str"
+	.set vor_wordstrsize_\name\(), . - vor_wordstr_\name
+	.endm
+
+	The word definition thus have the following structure:
+	struct vor_word {
+		struct vor_word *prev;
+		// Takes and returns the data stack pointer.
+		cell *(*word_definition)(cell *);
+		uint16_t flags, name_size;
+		char name[];
+	};
+	*/
+
+	.defvar expanse_ptr "exptr"
+	.defvar data_stack_ptr "dsptr"
+	.defvar input_buffer "ibuf"
+	.defvar input_buffer_length "ibuflen"
+	.defvar input_buffer_ptr "ibufptr"
+	.defvar input_buffer_end "ibufend"
+	.defvar last_created_word "latest-word"
+
+	.section	.text.vor
+	.thumb_func
+vor_add:
+	ldm	r0!, {r1, r2}
+	adds	r1, r2
+	subs	r0, #4
+	str	r1, [r0]
+	bx	lr
+
+	.thumb_func
+vor_bit_inv:
+	ldr	r1, [r0]
+	mvns	r1, r1
+	str	r1, [r0]
+	bx	lr
+
+	.thumb_func
+vor_mul:
+	ldm	r0!, {r1, r2}
+	muls	r2, r1, r2
+	subs	r0, #4
+	str	r2, [r0]
+	bx	lr
+
+	.thumb_func
+vor_lsl:
+	/* a b -> (a << b) */
+	ldm	r0!, {r1, r2}
+	lsls	r2, r1
+	subs	r0, #4
+	str	r2, [r0]
+	bx	lr
+
+	.thumb_func
+vor_bit_or:
+	ldm	r0!, {r1, r2}
+	orrs	r1, r2
+	subs	r0, #4
+	str	r1, [r0]
+	bx	lr
+
+	.thumb_func
+vor_less_than:
+	ldm	r0!, {r1, r2}
+	movs	r3, #0
+	cmp	r2, r1
+	bge	.L_not_less
+	adds	r3, #1
+.L_not_less:
+	subs	r0, #4
+	str	r3, [r0]
+	bx	lr
+
+	.thumb_func
+vor_load_cell:
+	ldm	r0!, {r1}
+	ldr	r2, [r1]
+	subs	r0, #4
+	str	r2, [r0]
+	bx	lr
+
+	.thumb_func
+vor_store_cell:
+	/* v addr -> { *(cell *)addr <- v } */
+	ldm	r0!, {r1, r2}
+	str	r2, [r1]
+	bx	lr
+	
+	.thumb_func
+vor_load_byte:
+	ldm	r0!, {r1}
+	ldrb	r2, [r1]
+	subs	r0, #4
+	str	r2, [r0]
+	bx	lr
+
+	.thumb_func
+vor_store_byte:
+	/* v addr -> { *(byte *)addr <- v&0xff } */
+	ldm	r0!, {r1, r2}
+	strb	r2, [r1]
+	bx	lr
+	
+	.thumb_func
+vor_read_word:
+	push	{lr}
+	mov	r8, r0
+	bl	read_word
+	mov	r2, r8
+	subs	r2, #4
+	str	r1, [r2]
+	subs	r2, #4
+	str	r0, [r2]
+	movs	r0, r2
+	pop	{pc}
+
+	.thumb_func
+vor_lit:
+	mov	r1, lr
+	subs	r1, #1	/* undo interworking */
+	ldr	r2, [r1]
+	subs	r0, #4
+	str	r2, [r0]
+	adds	r1, #4
+	mov	pc, r1
+
+	.thumb_func
+vor_zskip:
+	mov	r1, lr
+	subs	r1, #1	/* undo interworking */
+	ldm	r0!, {r2}
+	cmp	r2, #0
+	bne	.L_no_skip
+	ldr	r3, [r1]
+	adds	r1, r3
+	mov	pc, r1
+.L_no_skip:
+	adds	r1, #4
+	mov	pc, r1
+	
+
+	.defword add "+"
+	.defword bit_inv "~"
+	.defword mul "*"
+	.defword lsl "lsl"
+	.defword bit_or
+	.defword less_than "<"
+	.defword load_cell "v"
+	.defword store_cell "^"
+	.defword load_byte "vb"
+	.defword store_byte "^b"
+	.defword read_word
+	.defword lit
+	.defword zskip
+	@.defword  ""
+
+	.defwort swap
+	ldm	r0!, {r1, r2}
+	subs	r0, #4
+	str	r1, [r0]
+	subs	r0, #4
+	str	r2, [r0]
+	.wortende
+
+	.defwort pick
+	ldm	r0!, {r1}
+	movs	r2, #2
+	lsls	r1, r2
+	adds	r3, r0, r1
+	ldr	r2, [r0]
+	subs	r0, #4
+	str	r2, [r0]
+	.wortende
+
+	.dkw dup  #0 pick
+	.dkw over  #1 pick
+	.dkws "2dup" two_dup  over over
+
+	.dkws "1+" incr  #1 add
+	.dkw negate  bit_inv incr
+	.dkws "-" subtract  negate add
+	.dkw bit_nor  bit_or bit_inv
+	.dkw bit_and  bit_inv swap bit_inv bit_nor
+	.dkw bit_xor  two_dup bit_nor bit_and bit_or
+
+	.dkws "vh" load_half_word  dup load_byte incr load_byte #8 lsl bit_or
+
+	/* Adds 2 for the name length field; adds 3 in the process of making the address cell size (- 4 bytes) aligned. */
+	.dkw get_past_word_header  #10 add dup load_half_word add #2 add #3 add #-4 bit_and 
+	.dkw get_variable_address  get_past_word_header load_cell
+	.dkw get_constant_value  get_past_word_header load_cell
+
+	.dkw start  #expanse_ptr load_cell #2 #2 add swap store_byte
+
-- 
cgit 1.4.1-2-gfad0