First commit main

1 files changed, 433 insertions, 0 deletions

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
+