path: root/vor.S

	.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