.gitignore

@@ -1,6 +1,3 @@
 /build/
-.cache/
-CMakeFiles/
-CMakeCache.txt
-node_modules/
-/dist-newstyle/
+a.out
+/vendor/

.ruby-version

@@ -1 +0,0 @@
-3.3.6

Gemfile

@@ -0,0 +1,9 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+# frozen_string_literal: true
+
+source 'https://rubygems.org'
+
+gem 'term-ansicolor', '~> 1.2'
+gem 'rake', '~> 13.2'

Gemfile.lock

@@ -0,0 +1,22 @@
+GEM
+  remote: https://rubygems.org/
+  specs:
+    bigdecimal (3.1.9)
+    rake (13.2.1)
+    sync (0.5.0)
+    term-ansicolor (1.11.2)
+      tins (~> 1.0)
+    tins (1.38.0)
+      bigdecimal
+      sync
+
+PLATFORMS
+  ruby
+  x86_64-linux
+
+DEPENDENCIES
+  rake (~> 13.2)
+  term-ansicolor (~> 1.2)
+
+BUNDLED WITH
+   2.6.7

README

@@ -1,37 +0,0 @@
-# Elna programming language
-
-Elna compiles simple mathematical operations to machine code.
-The compiled program returns the result of the operation.
-
-## File extension
-
-.elna
-
-## Grammar PL/0
-
-program = block "." ;
-
-block = [ "const" ident "=" number {"," ident "=" number} ";"]
-        [ "var" ident {"," ident} ";"]
-        { "procedure" ident ";" block ";" } statement ;
-
-statement = [ ident ":=" expression | "call" ident 
-              | "?" ident | "!" expression 
-              | "begin" statement {";" statement } "end" 
-              | "if" condition "then" statement 
-              | "while" condition "do" statement ];
-
-condition = "odd" expression |
-            expression ("="|"#"|"<"|"<="|">"|">=") expression ;
-
-expression = [ "+"|"-"] term { ("+"|"-") term};
-
-term = factor {("*"|"/") factor};
-
-factor = ident | number | "(" expression ")";
-
-## Operations
-
-"!" - Write a line.
-"?" - Read user input.
-"odd" - The only function, returns whether a number is odd.

README.md

@@ -0,0 +1,11 @@
+# Elna programming language
+
+Elna is a simple, imperative, low-level programming language.
+
+It is intendet to accompany other languages in the areas, where a high-level
+language doesn't fit well. It is also supposed to be an intermediate
+representation for a such high-level hypothetical programming language.
+
+## File extension
+
+.elna

Rakefile

@@ -0,0 +1,38 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+# frozen_string_literal: true
+
+require 'open3'
+require 'rake/clean'
+require 'term/ansicolor'
+
+CLEAN.include 'build/boot'
+
+directory 'build/boot'
+
+desc 'Final stage'
+task default: ['build/boot/stage2b', 'build/boot/stage2b.s', 'boot/stage2.elna'] do |t|
+  exe, previous_output, source = t.prerequisites
+
+  cat_arguments = ['cat', source]
+  compiler_arguments = [QEMU, '-L', SYSROOT, exe]
+  diff_arguments = ['diff', '-Nur', '--text', previous_output, '-']
+  Open3.pipeline(cat_arguments, compiler_arguments, diff_arguments)
+end
+
+file 'build/boot/test.s' => ['build/boot/stage1', 'boot/test.elna'] do |t|
+  source, exe = t.prerequisites.partition { |prerequisite| prerequisite.end_with? '.elna' }
+
+  File.open t.name, 'w' do |output|
+    assemble_stage output, exe, source
+  end
+end
+
+file 'build/boot/test' => ['build/boot/test.s', 'boot/common-boot.s'] do |t|
+  sh CROSS_GCC, '-nostdlib', '-o', t.name, *t.prerequisites
+end
+
+task test: 'build/boot/test' do |t|
+  sh QEMU, '-L', SYSROOT, t.prerequisites.first
+end

TODO

@@ -1,10 +0,0 @@
-# ELF generation
-
-- Don't ignore relocations where the symbol is not defined in the symbol table.
-  Report an error about an undefined symbol.
-
-# Register allocation
-
-- Each temporary variable gets a tn register where n is the variable index. If
-  there more variables the allocation will fail with out of bounds runtime
-  error. Implement spill over.

boot/common-boot.s

@@ -0,0 +1,630 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+
+.global _is_alpha, _is_digit, _is_alnum, _is_upper, _is_lower
+.global _write_s, _read_file, _write_error, _write_c, _write_i, _print_i
+.global _memcmp, _memchr, _memmem, _memcpy, _mmap
+.global _current, _get, _advance, _label_counter
+.global _divide_by_zero_error, _exit, _strings_index, _string_equal
+
+.section .rodata
+
+.equ SYS_READ, 63
+.equ SYS_WRITE, 64
+.equ SYS_EXIT, 93
+.equ SYS_MMAP2, 222
+.equ STDIN, 0
+.equ STDOUT, 1
+.equ STDERR, 2
+.equ PROT_READ, 0x1
+.equ PROT_WRITE, 0x2
+.equ MAP_PRIVATE, 0x02
+.equ MAP_ANONYMOUS, 0x20
+
+new_line: .ascii "\n"
+
+.section .text
+
+# Write the current token to stderr. Ends the output with a newline.
+#
+# a0 - String pointer.
+# a1 - String length.
+.type _write_error, @function
+_write_error:
+	mv t0, a0
+	mv t1, a1
+
+	li a0, STDERR
+	mv a1, t0
+	mv a2, t1
+	li a7, SYS_WRITE
+	ecall
+
+	li a0, STDERR
+	la a1, new_line
+	li a2, 1
+	li a7, SYS_WRITE
+	ecall
+
+	ret
+
+# a0 - First pointer.
+# a1 - Second pointer.
+# a2 - The length to compare.
+#
+# Returns 0 in a0 if memory regions are equal.
+.type _memcmp, @function
+_memcmp:
+	mv t0, a0
+	li a0, 0
+
+.Lmemcmp_loop:
+	beqz a2, .Lmemcmp_end
+
+	lbu t1, (t0)
+	lbu t2, (a1)
+	sub a0, t1, t2
+
+	bnez a0, .Lmemcmp_end
+
+	addi t0, t0, 1
+	addi a1, a1, 1
+	addi a2, a2, -1
+
+	j .Lmemcmp_loop
+
+.Lmemcmp_end:
+	ret
+
+# Detects if a0 is an uppercase character. Sets a0 to 1 if so, otherwise to 0.
+.type _is_upper, @function
+_is_upper:
+	li t0, 'A' - 1
+	sltu t1, t0, a0 # t1 = a0 >= 'A'
+
+	sltiu t2, a0, 'Z' + 1 # t2 = a0 <= 'Z'
+	and a0, t1, t2 # t1 = a0 >= 'A' & a0 <= 'Z'
+
+	ret
+
+# Detects if a0 is an lowercase character. Sets a0 to 1 if so, otherwise to 0.
+.type _is_lower, @function
+_is_lower:
+	li t0, 'a' - 1
+	sltu t2, t0, a0 # t2 = a0 >= 'a'
+
+	sltiu t3, a0, 'z' + 1 # t3 = a0 <= 'z'
+	and a0, t2, t3 # t2 = a0 >= 'a' & a0 <= 'z'
+
+	ret
+
+# Detects if the passed character is a 7-bit alpha character or an underscore.
+# The character is passed in a0.
+# Sets a0 to 1 if the character is an alpha character or underscore, sets it to 0 otherwise.
+.type _is_alpha, @function
+_is_alpha:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	sw a0, 4(sp)
+
+	call _is_upper
+	sw a0, 0(sp)
+
+	lw a0, 4(sp)
+	call _is_lower
+
+	lw t0, 4(sp)
+	xori t1, t0, '_'
+	seqz t1, t1
+
+	lw t0, 0(sp)
+	or a0, a0, t0
+	or a0, a0, t1
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret
+
+# Detects whether the passed character is a digit
+# (a value between 0 and 9).
+#
+# Parameters:
+# a0 - Exemined value.
+#
+# Sets a0 to 1 if it is a digit, to 0 otherwise.
+.type _is_digit, @function
+_is_digit:
+	li t0, '0' - 1
+	sltu t1, t0, a0 # t1 = a0 >= '0'
+
+	sltiu t2, a0, '9' + 1 # t2 = a0 <= '9'
+
+	and a0, t1, t2
+
+	ret
+
+.type _is_alnum, @function
+_is_alnum:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	sw a0, 4(sp)
+
+	call _is_alpha
+	sw a0, 0(sp)
+
+	lw a0, 4(sp)
+	call _is_digit
+
+	lw a1, 0(sp)
+	or a0, a0, a1
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret
+
+# Writes a string to the standard output.
+#
+# Parameters:
+# a0 - Length of the string.
+# a1 - String pointer.
+.type _write_s, @function
+_write_s:
+	# Prologue.
+	addi sp, sp, -8
+	sw ra, 4(sp)
+	sw s0, 0(sp)
+	addi s0, sp, 8
+
+	mv a2, a0
+	li a0, STDOUT
+	li a7, SYS_WRITE
+	ecall
+
+	# Epilogue.
+	lw ra, 4(sp)
+	lw s0, 0(sp)
+	addi sp, sp, 8
+	ret
+
+# Reads standard input into a buffer.
+# a0 - Buffer pointer.
+# a1 - Buffer size.
+#
+# Sets s1 to the buffer passed in a0.
+#
+# Returns the amount of bytes written in a0.
+.type _read_file, @function
+_read_file:
+	# Prologue.
+	addi sp, sp, -8
+	sw ra, 4(sp)
+	sw s0, 0(sp)
+	addi s0, sp, 8
+
+	mv s1, a0
+
+	li a0, STDIN
+	mv a2, a1
+	mv a1, s1
+	li a7, SYS_READ
+	ecall
+
+	# Epilogue.
+	lw ra, 4(sp)
+	lw s0, 0(sp)
+	addi sp, sp, 8
+	ret
+
+# Terminates the program. a0 contains the return code.
+#
+# Parameters:
+# a0 - Status code.
+.type _exit, @function
+_exit:
+	li a7, SYS_EXIT
+	ecall
+	# ret
+
+.type _divide_by_zero_error, @function
+_divide_by_zero_error:
+    addi a7, zero, 172 # getpid
+    ecall
+
+    addi a1, zero, 8 # SIGFPE
+    addi a7, zero, 129 # kill
+    ecall
+    ret
+
+# Writes a number to a string buffer.
+#
+# t0 - Local buffer.
+# t1 - Constant 10.
+# t2 - Current character.
+# t3 - Whether the number is negative.
+#
+# Parameters:
+# a0 - Whole number.
+# a1 - Buffer pointer.
+#
+# Sets a0 to the length of the written number.
+.type _print_i, @function
+_print_i:
+    addi sp, sp, -32
+    sw ra, 28(sp)
+    sw s0, 24(sp)
+    addi s0, sp, 32
+
+    li t1, 10
+    addi t0, s0, -9
+
+    li t3, 0
+    bgez a0, .Lprint_i_digit10
+    li t3, 1
+    neg a0, a0
+
+.Lprint_i_digit10:
+    rem t2, a0, t1
+    addi t2, t2, '0'
+    sb t2, 0(t0)
+    div a0, a0, t1
+    addi t0, t0, -1
+    bne zero, a0, .Lprint_i_digit10
+
+    beq zero, t3, .Lprint_i_write_call
+    addi t2, zero, '-'
+    sb t2, 0(t0)
+    addi t0, t0, -1
+
+.Lprint_i_write_call:
+	mv a0, a1
+	addi a1, t0, 1
+    sub a2, s0, t0
+	addi a2, a2, -9
+	sw a2, 0(sp)
+
+	call _memcpy
+
+	lw a0, 0(sp)
+
+    lw ra, 28(sp)
+    lw s0, 24(sp)
+    addi sp, sp, 32
+    ret
+
+# Writes a number to the standard output.
+#
+# Parameters:
+# a0 - Whole number.
+.type _write_i, @function
+_write_i:
+    addi sp, sp, -32
+    sw ra, 28(sp)
+    sw s0, 24(sp)
+    addi s0, sp, 32
+
+	addi a1, sp, 0
+	call _print_i
+
+	addi a1, sp, 0
+	call _write_s
+
+    lw ra, 28(sp)
+    lw s0, 24(sp)
+    addi sp, sp, 32
+    ret
+
+# Writes a character from a0 into the standard output.
+.type _write_c, @function
+_write_c:
+	# Prologue
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	sb a0, 4(sp)
+	li a0, STDOUT
+	addi a1, sp, 4
+	li a2, 1
+	li a7, SYS_WRITE
+	ecall
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	add sp, sp, 16
+	ret
+
+# a0 - Pointer to an array to get the first element.
+#
+# Dereferences a pointer and returns what is on the address in a0.
+.type _get, @function
+_get:
+	lw a0, (a0)
+	ret
+
+# Searches for the occurences of a character in the given memory block.
+#
+# Parameters:
+# a0 - Memory block.
+# a1 - Needle.
+# a2 - Memory size.
+#
+# Sets a0 to the pointer to the found character or to null if the character
+# doesn't occur in the memory block.
+.type _memchr, @function
+_memchr:
+.Lmemchr_loop:
+	beqz a2, .Lmemchr_nil # Exit if the length is 0.
+
+	lbu t0, (a0) # Load the character from the memory block.
+	beq t0, a1, .Lmemchr_end # Exit if the character was found.
+
+	# Otherwise, continue with the next character.
+	addi a0, a0, 1
+	addi a2, a2, -1
+
+	j .Lmemchr_loop
+
+.Lmemchr_nil:
+	li a0, 0
+
+.Lmemchr_end:
+	ret
+
+# Locates a substring.
+#
+# Parameters:
+# a0 - Haystack.
+# a1 - Haystack size.
+# a2 - Needle.
+# a3 - Needle size.
+#
+# Sets a0 to the pointer to the beginning of the substring in memory or to 0
+# if the substring doesn't occur in the block.
+.type _memmem, @function
+_memmem:
+	# Prologue.
+	addi sp, sp, -24
+	sw ra, 20(sp)
+	sw s0, 16(sp)
+	addi s0, sp, 24
+
+	# Save preserved registers. They are used to keep arguments.
+	sw s1, 12(sp)
+	sw s2, 8(sp)
+	sw s3, 4(sp)
+	sw s4, 0(sp)
+
+	mv s1, a0
+	mv s2, a1
+	mv s3, a2
+	mv s4, a3
+
+.Lmemmem_loop:
+	blt s2, s3, .Lmemmem_nil # Exit if the needle length is greater than memory.
+
+	mv a0, s1
+	mv a1, s3
+	mv a2, s4
+	call _memcmp
+
+	mv t0, a0 # memcmp result.
+	mv a0, s1 # Memory pointer for the case the substring was found.
+	beqz t0, .Lmemmem_end
+
+	addi s1, s1, 1
+	add s2, s2, -1
+
+	j .Lmemmem_loop
+
+.Lmemmem_nil:
+	li a0, 0
+
+.Lmemmem_end:
+
+	# Restore the preserved registers.
+	lw s1, 12(sp)
+	lw s2, 8(sp)
+	lw s3, 4(sp)
+	lw s4, 0(sp)
+
+	# Epilogue.
+	lw ra, 20(sp)
+	lw s0, 16(sp)
+	add sp, sp, 24
+	ret
+
+# Copies memory.
+#
+# Parameters:
+# a0 - Destination.
+# a1 - Source.
+# a2 - Size.
+#
+# Preserves a0.
+.type _memcpy, @function
+_memcpy:
+	mv t0, a0
+
+.Lmemcpy_loop:
+	beqz a2, .Lmemcpy_end
+
+	lbu t1, (a1)
+	sb t1, (a0)
+
+	addi a0, a0, 1
+	addi a1, a1, 1
+	addi a2, a2, -1
+
+	j .Lmemcpy_loop
+
+.Lmemcpy_end:
+	mv a0, t0
+	ret
+
+# Searches for a string in a string array.
+#
+# Parameters:
+# a0 - Number of elements in the string array.
+# a1 - String array.
+# a2 - Needle length.
+# a3 - Needle.
+#
+# Sets a0 to the 1-based index of the needle in the haystack or to 0 if the
+# element could not be found.
+.type _strings_index, @function
+_strings_index:
+	# Prologue.
+	addi sp, sp, -32
+	sw ra, 28(sp)
+	sw s0, 24(sp)
+	addi s0, sp, 32
+
+	sw s1, 20(sp)
+	mv s1, a0
+	sw s2, 16(sp)
+	mv s2, a1
+	sw s3, 12(sp)
+	mv s3, a2
+	sw s4, 8(sp)
+	mv s4, a3
+	sw s5, 4(sp)
+	li s5, 0 # Index counter.
+
+.Lstrings_index_loop:
+	addi s5, s5, 1
+	beqz s1, .Lstrings_index_missing
+
+	lw a2, (s2) # Read the length of the current element in the haystack.
+	bne a2, s3, .Lstrings_index_next # Lengths don't match, skip the iteration.
+
+	addi a0, s2, 4
+	mv a1, s4
+	call _memcmp
+
+	beqz a0, .Lstrings_index_end
+
+.Lstrings_index_next:
+	# Advance the pointer, reduce the length.
+	lw a2, (s2)
+	addi s2, s2, 4
+	add s2, s2, a2
+	addi s1, s1, -1
+	j .Lstrings_index_loop
+
+.Lstrings_index_missing:
+	li s5, 0
+
+.Lstrings_index_end:
+	mv a0, s5
+
+	lw s1, 20(sp)
+	lw s2, 16(sp)
+	lw s3, 12(sp)
+	lw s4, 8(sp)
+	lw s5, 4(sp)
+
+	# Epilogue.
+	lw ra, 28(sp)
+	lw s0, 24(sp)
+	add sp, sp, 32
+	ret
+
+# Compares two strings for equality.
+#
+# Parameters:
+# a0 - Length of the first string.
+# a1 - Pointer to the first string.
+# a2 - Length of the second string.
+# a3 - Pointer to the second string.
+#
+# Sets a0 to 1 if the string are equal, to 0 if not.
+.type _string_equal, @function
+_string_equal:
+	# Prologue.
+	addi sp, sp, -32
+	sw ra, 28(sp)
+	sw s0, 24(sp)
+	addi s0, sp, 32
+
+	# Compare string lengths.
+	bne a0, a2, .Lstring_equal_not_found
+
+	# If lengths match, compare the content.
+	mv a0, a1
+	mv a1, a3
+	# a2 is already set to the length.
+	call _memcmp
+
+	bnez a0, .Lstring_equal_not_found
+
+	li a0, 1
+	j .Lstring_equal_end
+
+.Lstring_equal_not_found:
+	mv a0, zero
+
+.Lstring_equal_end:
+	# Epilogue.
+	lw ra, 28(sp)
+	lw s0, 24(sp)
+	addi sp, sp, 32
+	ret
+
+# Sets a0 to the mapping address.
+.type _mmap, @function
+_mmap:
+	li a0, 0 # Address at which to create the mapping.
+	li a1, 4096 # The length of the mapping.
+	li a2, PROT_READ | PROT_WRITE # Protection flags.
+	li a3, MAP_ANONYMOUS | MAP_PRIVATE # The mapping is not backed by a file.
+	li a4, -1 # File descriptor.
+	li a5, 0 # Page offset.
+	li a7, SYS_MMAP2
+	ecall
+
+	ret
+
+# Sets the a0 to the current position in the source text (s1).
+.type _current, @function
+_current:
+	mv a0, s1
+	ret
+
+# Advances the position of the source text.
+#
+# Parameters:
+# a0 - The number of bytes to advance.
+.type _advance, @function
+_advance:
+	add s1, s1, a0
+	ret
+
+# Advances the global label counter by 1 setting a0 to the previous value.
+#
+# Parameters:
+# a0 - If it is 0, resets the counter to 1.
+.type _label_counter, @function
+_label_counter:
+	bnez a0, .Llabel_counter_advance
+	li s2, 0
+
+.Llabel_counter_advance:
+	mv a0, s2
+	addi s2, s2, 1
+
+	ret

boot/definitions.inc

@@ -0,0 +1,68 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+
+#
+# Tokens.
+#
+
+# The constant should match the index in the keywords array in tokenizer.s.
+
+.equ TOKEN_PROGRAM, 1
+.equ TOKEN_IMPORT, 2
+.equ TOKEN_CONST, 3
+.equ TOKEN_VAR, 4
+.equ TOKEN_IF, 5
+.equ TOKEN_THEN, 6
+.equ TOKEN_ELSIF, 7
+.equ TOKEN_ELSE, 8
+.equ TOKEN_WHILE, 9
+.equ TOKEN_DO, 10
+.equ TOKEN_PROC, 11
+.equ TOKEN_BEGIN, 12
+.equ TOKEN_END, 13
+.equ TOKEN_TYPE, 14
+.equ TOKEN_RECORD, 15
+.equ TOKEN_UNION, 16
+.equ TOKEN_TRUE, 17
+.equ TOKEN_FALSE, 18
+.equ TOKEN_NIL, 19
+.equ TOKEN_XOR, 20
+.equ TOKEN_OR, 21
+.equ TOKEN_RETURN, 22
+.equ TOKEN_CAST, 23
+.equ TOKEN_GOTO, 24
+.equ TOKEN_CASE, 25
+.equ TOKEN_OF, 26
+
+.equ TOKEN_IDENTIFIER, 27
+# The constant should match the character index in the byte_keywords string.
+
+.equ TOKEN_AND, TOKEN_IDENTIFIER + 1
+.equ TOKEN_DOT, TOKEN_IDENTIFIER + 2
+.equ TOKEN_COMMA, TOKEN_IDENTIFIER + 3
+.equ TOKEN_COLON, TOKEN_IDENTIFIER + 4
+.equ TOKEN_SEMICOLON, TOKEN_IDENTIFIER + 5
+.equ TOKEN_LEFT_PAREN, TOKEN_IDENTIFIER + 6
+.equ TOKEN_RIGHT_PAREN, TOKEN_IDENTIFIER + 7
+.equ TOKEN_LEFT_BRACKET, TOKEN_IDENTIFIER + 8
+.equ TOKEN_RIGHT_BRACKET, TOKEN_IDENTIFIER + 9
+.equ TOKEN_HAT, TOKEN_IDENTIFIER + 10
+.equ TOKEN_EQUALS, TOKEN_IDENTIFIER + 11
+.equ TOKEN_PLUS, TOKEN_IDENTIFIER + 12
+.equ TOKEN_MINUS, TOKEN_IDENTIFIER + 13
+.equ TOKEN_ASTERISK, TOKEN_IDENTIFIER + 14
+.equ TOKEN_AT, TOKEN_IDENTIFIER + 15
+
+.equ TOKEN_ASSIGN, 43
+.equ TOKEN_INTEGER, 44
+
+#
+# Symbols.
+#
+.equ TYPE_PRIMITIVE, 0x01
+.equ TYPE_POINTER, 0x02
+.equ TYPE_PROCEDURE, 0x03
+.equ INFO_PARAMETER, 0x10
+.equ INFO_LOCAL, 0x20
+.equ INFO_PROCEDURE, 0x30

boot/symbol.s

@@ -0,0 +1,297 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+
+.global symbol_table
+.global symbol_table_build, symbol_table_lookup, symbol_table_enter, symbol_table_dump
+.global symbol_table_make_pointer, symbol_table_make_parameter, symbol_table_make_local, symbol_table_make_procedure
+
+.include "boot/definitions.inc"
+
+.equ SYMBOL_PRIME, 1543
+
+.section .rodata
+
+.type symbol_builtin_name_int, @object
+symbol_builtin_name_int: .ascii "Int"
+.type symbol_builtin_name_word, @object
+symbol_builtin_name_word: .ascii "Word"
+.type symbol_builtin_name_byte, @object
+symbol_builtin_name_byte: .ascii "Byte"
+.type symbol_builtin_name_char, @object
+symbol_builtin_name_char: .ascii "Char"
+.type symbol_builtin_name_bool, @object
+symbol_builtin_name_bool: .ascii "Bool"
+
+# Every type info starts with a word describing what type it is.
+
+# Primitive types have only type size.
+.type symbol_builtin_type_int, @object
+symbol_builtin_type_int: .word TYPE_PRIMITIVE
+	.word 4
+.type symbol_builtin_type_word, @object
+symbol_builtin_type_word: .word TYPE_PRIMITIVE
+	.word 4
+.type symbol_builtin_type_byte, @object
+symbol_builtin_type_byte: .word TYPE_PRIMITIVE
+	.word 1
+.type symbol_builtin_type_char, @object
+symbol_builtin_type_char: .word TYPE_PRIMITIVE
+	.word 1
+.type symbol_builtin_type_bool, @object
+symbol_builtin_type_bool: .word TYPE_PRIMITIVE
+	.word 1
+
+.section .bss
+
+# The first word of the symbol table is its length.
+# Then a list of type infos follows:
+#
+# record
+#   name: String
+#   info: ^TypeInfo
+# end
+.type symbol_table, @object
+symbol_table: .zero SYMBOL_PRIME
+
+.section .text
+
+# Prints the list of symbols in the table.
+.type symbol_table_dump, @function
+symbol_table_dump:
+	# Prologue.
+	addi sp, sp, -32
+	sw ra, 28(sp)
+	sw s0, 24(sp)
+	addi s0, sp, 32
+
+	sw s1, 20(sp) # Current symbol in the table.
+	sw s2, 16(sp) # Symbol table length.
+
+	la s1, symbol_table
+	lw s2, 0(s1)
+	addi s1, s1, 4 # Advance to the first symbol in the table.
+
+.Lsymbol_table_dump_loop:
+	beqz s2, .Lsymbol_table_dump_end
+
+	# Compare string lengths.
+	lw a0, 4(s1)
+	lw a1, 0(s1)
+	call _write_error
+
+	addi s1, s1, 12
+	addi s2, s2, -1
+	j .Lsymbol_table_dump_loop
+
+.Lsymbol_table_dump_end:
+	lw s1, 20(sp)
+	lw s2, 16(sp)
+
+	# Epilogue.
+	lw ra, 28(sp)
+	lw s0, 24(sp)
+	addi sp, sp, 32
+	ret
+
+# Searches for a symbol by name.
+#
+# Parameters:
+# a0 - Length of the symbol to search.
+# a1 - Pointer to the symbol name.
+#
+# Sets a0 to the symbol info pointer or 0 if the symbol has not been found.
+.type symbol_table_lookup, @function
+symbol_table_lookup:
+	# Prologue.
+	addi sp, sp, -32
+	sw ra, 28(sp)
+	sw s0, 24(sp)
+	addi s0, sp, 32
+
+	sw s1, 20(sp) # Current symbol in the table.
+	sw s2, 16(sp) # Symbol table length.
+	sw s3, 12(sp) # Length of the symbol to search.
+	sw s4, 8(sp) # Pointer to the symbol to search.
+
+	mv s3, a0
+	mv s4, a1
+
+	la s1, symbol_table
+	lw s2, 0(s1)
+	addi s1, s1, 4 # Advance to the first symbol in the table.
+
+.Lsymbol_table_lookup_loop:
+	beqz s2, .Lsymbol_table_lookup_not_found
+
+	# Compare string lengths.
+	mv a0, s3
+	mv a1, s4
+	lw a2, 0(s1)
+	lw a3, 4(s1)
+	call _string_equal
+
+	beqz a0, .Lsymbol_table_lookup_continue
+
+	lw a0, 8(s1) # Pointer to the symbol.
+	j .Lsymbol_table_lookup_end
+
+.Lsymbol_table_lookup_continue:
+	addi s1, s1, 12
+	addi s2, s2, -1
+	j .Lsymbol_table_lookup_loop
+
+.Lsymbol_table_lookup_not_found:
+	li a0, 0
+
+.Lsymbol_table_lookup_end:
+	lw s1, 20(sp)
+	lw s2, 16(sp)
+	lw s3, 12(sp)
+	lw s4, 8(sp)
+
+	# Epilogue.
+	lw ra, 28(sp)
+	lw s0, 24(sp)
+	addi sp, sp, 32
+	ret
+
+# Creates a pointer type.
+#
+# Parameters:
+# a0 - Pointer to the base type.
+# a1 - Output memory.
+#
+# Sets a0 to the size of newly created type in bytes.
+.type symbol_table_make_pointer, @function
+symbol_table_make_pointer:
+	li t0, TYPE_POINTER
+	sw t0, 0(a1)
+	sw a0, 4(a1)
+
+	li a0, 8
+	ret
+
+# Creates a parameter info.
+#
+# Parameters:
+# a0 - Pointer to the parameter type.
+# a1 - Parameter offset.
+# a2 - Output memory.
+#
+# Sets a0 to the size of newly created info object in bytes.
+.type symbol_table_make_parameter, @function
+symbol_table_make_parameter:
+	li t0, INFO_PARAMETER
+	sw t0, 0(a2)
+	sw a0, 4(a2)
+	sw a1, 8(a2)
+
+	li a0, 12
+	ret
+
+# Creates a local variable info.
+#
+# Parameters:
+# a0 - Pointer to the variable type.
+# a1 - Variable stack offset.
+# a2 - Output memory.
+#
+# Sets a0 to the size of newly created info object in bytes.
+.type symbol_table_make_local, @function
+symbol_table_make_local:
+	li t0, INFO_LOCAL
+	sw t0, 0(a2)
+	sw a0, 4(a2)
+	sw a1, 8(a2)
+
+	li a0, 12
+	ret
+
+# Creates a procedure type and procedure info objects refering the type.
+#
+# Parameters:
+# a0 - Output memory.
+#
+# Sets a0 to the size of newly created info object in bytes.
+.type symbol_table_make_procedure, @function
+symbol_table_make_procedure:
+	li t0, TYPE_PROCEDURE
+	sw t0, 8(a0)
+
+	li t0, INFO_PROCEDURE
+	sw t0, 0(a0)
+	sw a0, 4(a0) # Procedure type stored in the same memory segment.
+
+	li a0, 12
+	ret
+
+# Inserts a symbol into the table.
+#
+# Parameters:
+# a0 - Symbol name length.
+# a1 - Symbol name pointer.
+# a2 - Symbol pointer.
+.type symbol_table_enter, @function
+symbol_table_enter:
+	la t0, symbol_table
+
+	lw t1, 0(t0) # Current table length.
+	li t2, 12 # Calculate the offset to the next entry.
+	mul t2, t1, t2
+	addi t2, t2, 4
+	add t2, t0, t2
+
+	sw a0, 0(t2)
+	sw a1, 4(t2)
+	sw a2, 8(t2)
+
+	addi t1, t1, 1 # Save the new length.
+	sw t1, 0(t0)
+
+	ret
+
+# Build the initial symbols.
+#
+# Sets a0 to the pointer to the global symbol table.
+.type symbol_build, @function
+symbol_table_build:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	la a0, symbol_table
+	addi t0, a0, 4
+
+	li a0, 3 # Length of the word "Int".
+	la a1, symbol_builtin_name_int
+	la a2, symbol_builtin_type_int
+	call symbol_table_enter
+
+	li a0, 4 # Length of the word "Word".
+	la a1, symbol_builtin_name_word
+	la a2, symbol_builtin_type_word
+	call symbol_table_enter
+
+	li a0, 4 # Length of the word "Byte".
+	la a1, symbol_builtin_name_byte
+	la a2, symbol_builtin_type_byte
+	call symbol_table_enter
+
+	li a0, 4 # Length of the word "Char".
+	la a1, symbol_builtin_name_char
+	la a2, symbol_builtin_type_char
+	call symbol_table_enter
+
+	li a0, 4 # Length of the word "Bool".
+	la a1, symbol_builtin_name_bool
+	la a2, symbol_builtin_type_bool
+	call symbol_table_enter
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret

boot/test.elna

@@ -0,0 +1,14 @@
+program
+
+proc main(x: Word, y: Word)
+begin
+	_write_s(4, @x);
+	_write_s(4, @y);
+
+	y := 0x0a2c3063;
+	_write_s(4, @y)
+end
+
+begin
+	main(0x0a2c3061, 0x0a2c3062)
+end.

boot/tokenizer.s

@@ -0,0 +1,616 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/.
+
+.global lex_next, classification, transitions, keywords, byte_keywords
+
+.include "boot/definitions.inc"
+
+.section .rodata
+
+#
+# Classification table assigns each possible character to a group (class). All
+# characters of the same group a handled equivalently.
+#
+# Classification:
+#
+.equ CLASS_INVALID, 0x00
+.equ CLASS_DIGIT, 0x01
+.equ CLASS_CHARACTER, 0x02
+.equ CLASS_SPACE, 0x03
+.equ CLASS_COLON, 0x04
+.equ CLASS_EQUALS, 0x05
+.equ CLASS_LEFT_PAREN, 0x06
+.equ CLASS_RIGHT_PAREN, 0x07
+.equ CLASS_ASTERISK, 0x08
+.equ CLASS_UNDERSCORE, 0x09
+.equ CLASS_SINGLE, 0x0a
+.equ CLASS_HEX, 0x0b
+.equ CLASS_ZERO, 0x0c
+.equ CLASS_X, 0x0d
+.equ CLASS_EOF, 0x0e
+.equ CLASS_DOT, 0x0f
+.equ CLASS_MINUS, 0x10
+.equ CLASS_QUOTE, 0x11
+.equ CLASS_GREATER, 0x12
+.equ CLASS_LESS, 0x13
+
+.equ CLASS_COUNT, 20
+
+.type classification, @object
+classification:
+	.byte CLASS_EOF # 00 NUL
+	.byte CLASS_INVALID # 01 SOH
+	.byte CLASS_INVALID # 02 STX
+	.byte CLASS_INVALID # 03 ETX
+	.byte CLASS_INVALID # 04 EOT
+	.byte CLASS_INVALID # 05 ENQ
+	.byte CLASS_INVALID # 06 ACK
+	.byte CLASS_INVALID # 07 BEL
+	.byte CLASS_INVALID # 08 BS
+	.byte CLASS_SPACE # 09 HT
+	.byte CLASS_SPACE # 0A LF
+	.byte CLASS_INVALID # 0B VT
+	.byte CLASS_INVALID # 0C FF
+	.byte CLASS_SPACE # 0D CR
+	.byte CLASS_INVALID # 0E SO
+	.byte CLASS_INVALID # 0F SI
+	.byte CLASS_INVALID # 10 DLE
+	.byte CLASS_INVALID # 11 DC1
+	.byte CLASS_INVALID # 12 DC2
+	.byte CLASS_INVALID # 13 DC3
+	.byte CLASS_INVALID # 14 DC4
+	.byte CLASS_INVALID # 15 NAK
+	.byte CLASS_INVALID # 16 SYN
+	.byte CLASS_INVALID # 17 ETB
+	.byte CLASS_INVALID # 18 CAN
+	.byte CLASS_INVALID # 19 EM
+	.byte CLASS_INVALID # 1A SUB
+	.byte CLASS_INVALID # 1B ESC
+	.byte CLASS_INVALID # 1C FS
+	.byte CLASS_INVALID # 1D GS
+	.byte CLASS_INVALID # 1E RS
+	.byte CLASS_INVALID # 1F US
+	.byte CLASS_SPACE # 20 Space
+	.byte CLASS_SINGLE # 21 !
+	.byte CLASS_QUOTE # 22 "
+	.byte 0x00 # 23 #
+	.byte 0x00 # 24 $
+	.byte CLASS_SINGLE # 25 %
+	.byte CLASS_SINGLE # 26 &
+	.byte CLASS_QUOTE # 27 '
+	.byte CLASS_LEFT_PAREN # 28 (
+	.byte CLASS_RIGHT_PAREN # 29 )
+	.byte CLASS_ASTERISK # 2A *
+	.byte CLASS_SINGLE # 2B +
+	.byte CLASS_SINGLE # 2C ,
+	.byte CLASS_MINUS # 2D -
+	.byte CLASS_DOT # 2E .
+	.byte CLASS_SINGLE # 2F /
+	.byte CLASS_ZERO # 30 0
+	.byte CLASS_DIGIT # 31 1
+	.byte CLASS_DIGIT # 32 2
+	.byte CLASS_DIGIT # 33 3
+	.byte CLASS_DIGIT # 34 4
+	.byte CLASS_DIGIT # 35 5
+	.byte CLASS_DIGIT # 36 6
+	.byte CLASS_DIGIT # 37 7
+	.byte CLASS_DIGIT # 38 8
+	.byte CLASS_DIGIT # 39 9
+	.byte CLASS_COLON # 3A :
+	.byte CLASS_SINGLE # 3B ;
+	.byte CLASS_LESS # 3C <
+	.byte CLASS_EQUALS # 3D =
+	.byte CLASS_GREATER # 3E >
+	.byte 0x00 # 3F ?
+	.byte CLASS_SINGLE # 40 @
+	.byte CLASS_CHARACTER # 41 A
+	.byte CLASS_CHARACTER # 42 B
+	.byte CLASS_CHARACTER # 43 C
+	.byte CLASS_CHARACTER # 44 D
+	.byte CLASS_CHARACTER # 45 E
+	.byte CLASS_CHARACTER # 46 F
+	.byte CLASS_CHARACTER # 47 G
+	.byte CLASS_CHARACTER # 48 H
+	.byte CLASS_CHARACTER # 49 I
+	.byte CLASS_CHARACTER # 4A J
+	.byte CLASS_CHARACTER # 4B K
+	.byte CLASS_CHARACTER # 4C L
+	.byte CLASS_CHARACTER # 4D M
+	.byte CLASS_CHARACTER # 4E N
+	.byte CLASS_CHARACTER # 4F O
+	.byte CLASS_CHARACTER # 50 P
+	.byte CLASS_CHARACTER # 51 Q
+	.byte CLASS_CHARACTER # 52 R
+	.byte CLASS_CHARACTER # 53 S
+	.byte CLASS_CHARACTER # 54 T
+	.byte CLASS_CHARACTER # 55 U
+	.byte CLASS_CHARACTER # 56 V
+	.byte CLASS_CHARACTER # 57 W
+	.byte CLASS_CHARACTER # 58 X
+	.byte CLASS_CHARACTER # 59 Y
+	.byte CLASS_CHARACTER # 5A Z
+	.byte CLASS_SINGLE # 5B [
+	.byte 0x00 # 5C \
+	.byte CLASS_SINGLE # 5D ]
+	.byte CLASS_SINGLE # 5E ^
+	.byte CLASS_UNDERSCORE # 5F _
+	.byte 0x00 # 60 `
+	.byte CLASS_HEX # 61 a
+	.byte CLASS_HEX # 62 b
+	.byte CLASS_HEX # 63 c
+	.byte CLASS_HEX # 64 d
+	.byte CLASS_HEX # 65 e
+	.byte CLASS_HEX # 66 f
+	.byte CLASS_CHARACTER # 67 g
+	.byte CLASS_CHARACTER # 68 h
+	.byte CLASS_CHARACTER # 69 i
+	.byte CLASS_CHARACTER # 6A j
+	.byte CLASS_CHARACTER # 6B k
+	.byte CLASS_CHARACTER # 6C l
+	.byte CLASS_CHARACTER # 6D m
+	.byte CLASS_CHARACTER # 6E n
+	.byte CLASS_CHARACTER # 6F o
+	.byte CLASS_CHARACTER # 70 p
+	.byte CLASS_CHARACTER # 71 q
+	.byte CLASS_CHARACTER # 72 r
+	.byte CLASS_CHARACTER # 73 s
+	.byte CLASS_CHARACTER # 74 t
+	.byte CLASS_CHARACTER # 75 u
+	.byte CLASS_CHARACTER # 76 v
+	.byte CLASS_CHARACTER # 77 w
+	.byte CLASS_X # 78 x
+	.byte CLASS_CHARACTER # 79 y
+	.byte CLASS_CHARACTER # 7A z
+	.byte 0x00 # 7B {
+	.byte CLASS_SINGLE # 7C |
+	.byte 0x00 # 7D }
+	.byte CLASS_SINGLE # 7E ~
+	.byte CLASS_INVALID # 7F DEL
+
+#
+# Textual keywords in the language.
+#
+.equ KEYWORDS_COUNT, TOKEN_IDENTIFIER - 1
+
+.type keywords, @object
+keywords:
+	.word 7
+	.ascii "program"
+	.word 6
+	.ascii "import"
+	.word 5
+	.ascii "const"
+	.word 3
+	.ascii "var"
+	.word 2
+	.ascii "if"
+	.word 4
+	.ascii "then"
+	.word 5
+	.ascii "elsif"
+	.word 4
+	.ascii "else"
+	.word 5
+	.ascii "while"
+	.word 2
+	.ascii "do"
+	.word 4
+	.ascii "proc"
+	.word 5
+	.ascii "begin"
+	.word 3
+	.ascii "end"
+	.word 4
+	.ascii "type"
+	.word 6
+	.ascii "record"
+	.word 5
+	.ascii "union"
+	.word 4
+	.ascii "true"
+	.word 5
+	.ascii "false"
+	.word 3
+	.ascii "nil"
+	.word 3
+	.ascii "xor"
+	.word 2
+	.ascii "or"
+	.word 6
+	.ascii "return"
+	.word 4
+	.ascii "cast"
+	.word 4
+	.ascii "goto"
+	.word 4
+	.ascii "case"
+	.word 2
+	.ascii "of"
+
+.type byte_keywords, @object
+byte_keywords: .ascii "&.,:;()[]^=+-*@"
+.equ BYTE_KEYWORDS_SIZE, . - byte_keywords
+
+.section .data
+
+# The transition table describes transitions from one state to another, given
+# a symbol (character class).
+#
+# The table has m rows and n columns, where m is the amount of states and n is
+# the amount of classes. So given the current state and a classified character
+# the table can be used to look up the next state.
+#
+# Each cell is a word long.
+# - The least significant byte of the word is a row number (beginning with 0).
+#   It specifies the target state. "ff" means that this is an end state and no
+#   transition is possible.
+# - The next byte is the action that should be performed when transitioning.
+#   For the meaning of actions see labels in the lex_next function, which
+#   handles each action.
+#
+.type transitions, @object
+transitions:
+	#     Invalid Digit   Alpha   Space   :       =       (       )     
+	#     *       _       Single  Hex     0       x       NUL     .
+	#     -       " or '  >       <
+	.word 0x00ff, 0x0103, 0x0102, 0x0300, 0x0101, 0x06ff, 0x0106, 0x06ff
+	.word 0x06ff, 0x0102, 0x06ff, 0x0102, 0x010c, 0x0102, 0x00ff, 0x06ff
+	.word 0x0105, 0x0110, 0x0104, 0x0107 # 0x00 Start
+
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x07ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff # 0x01 Colon
+
+	.word 0x05ff, 0x0102, 0x0102, 0x05ff, 0x05ff, 0x05ff, 0x05ff, 0x05ff
+	.word 0x05ff, 0x0102, 0x05ff, 0x0102, 0x0102, 0x0102, 0x05ff, 0x05ff
+	.word 0x05ff, 0x05ff, 0x05ff, 0x05ff # 0x02 Identifier
+
+	.word 0x08ff, 0x0103, 0x00ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff
+	.word 0x08ff, 0x00ff, 0x08ff, 0x00ff, 0x0103, 0x00ff, 0x08ff, 0x08ff
+	.word 0x08ff, 0x08ff, 0x08ff, 0x08ff # 0x03 Decimal
+
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x04ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x04ff, 0x02ff # 0x04 Greater
+
+	.word 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff
+	.word 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff
+	.word 0x06ff, 0x06ff, 0x04ff, 0x06ff # 0x05 Minus
+
+	.word 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff
+	.word 0x0109, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff, 0x06ff
+	.word 0x06ff, 0x06ff, 0x06ff, 0x06ff # 0x06 Left paren
+
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff, 0x02ff
+	.word 0x02ff, 0x02ff, 0x02ff, 0x04ff # 0x07 Less
+
+	.word 0x08ff, 0x0108, 0x00ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff
+	.word 0x08ff, 0x00ff, 0x08ff, 0x0108, 0x0108, 0x00ff, 0x08ff, 0x08ff
+	.word 0x08ff, 0x08ff, 0x08ff, 0x08ff # 0x08 Hexadecimal after 0x.
+
+	.word 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109
+	.word 0x010a, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x00ff, 0x0109
+	.word 0x0109, 0x0109, 0x0109, 0x0109 # 0x09 Comment
+
+	.word 0x00ff, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x04ff
+	.word 0x010a, 0x0109, 0x0109, 0x0109, 0x0109, 0x0109, 0x00ff, 0x0109
+	.word 0x0109, 0x0109, 0x0109, 0x0109 # 0x0a Closing comment
+
+	.word 0x00ff, 0x010b, 0x010b, 0x010b, 0x010b, 0x010b, 0x010b, 0x0110
+	.word 0x010b, 0x010b, 0x010b, 0x010b, 0x010b, 0x010b, 0x010b, 0x0110
+	.word 0x010b, 0x04ff, 0x010b, 0x010b # 0x0b String
+
+	.word 0x08ff, 0x00ff, 0x00ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff, 0x08ff
+	.word 0x08ff, 0x00ff, 0x08ff, 0x00ff, 0x00ff, 0x010d, 0x08ff, 0x08ff
+	.word 0x08ff, 0x08ff, 0x08ff, 0x08ff # 0x0c Leading zero
+
+	.word 0x00ff, 0x0108, 0x00ff, 0x00ff, 0x00ff, 0x00ff, 0x00ff, 0x00ff
+	.word 0x00ff, 0x00ff, 0x00ff, 0x0108, 0x0108, 0x00ff, 0x00ff, 0x00ff
+	.word 0x00ff, 0x00ff, 0x00ff, 0x00ff # 0x0d Starting hexadecimal
+
+.section .text
+
+# Returns the class from the classification table for the given character.
+#
+# Parameters:
+# a0 - Character.
+#
+# Sets a0 to the class number.
+.type classify, @function
+classify:
+	la t0, classification
+	add t0, t0, a0 # Character class pointer.
+	lbu a0, (t0) # Character class.
+	ret
+
+# Given the current state and a character class, calculates the next state.
+
+# Parameters:
+# a0 - Current state.
+# a1 - Character class.
+#
+# Sets a0 to the next state.
+.type lookup_state, @function
+lookup_state:
+	li t0, CLASS_COUNT
+	mul a0, a0, t0 # Transition row.
+	add a0, a0, a1 # Transition column.
+
+	li t0, 4
+	mul a0, a0, t0 # Multiply by the word size.
+
+	la t0, transitions
+	add t0, t0, a0
+	lw a0, (t0) # Next state.
+
+	ret
+
+# Chains classify and lookup_state.
+#
+# Parameters:
+# a0 - Current state.
+# a1 - Character.
+#
+# Sets a0 to the next state based on the given character.
+.type _next_state, @function
+_next_state:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	sw a0, 4(sp)
+	mv a0, a1
+	call classify
+
+	mv a1, a0
+	lw a0, 4(sp)
+	call lookup_state
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret
+
+# Takes an identifier and checks whether it's a keyword.
+#
+# Parameters:
+# a0 - Token length.
+# a1 - Token pointer.
+#
+# Sets a0 to the appropriate token type.
+.type classify_identifier, @function
+classify_identifier:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	mv a2, a0
+	mv a3, a1
+	li a0, KEYWORDS_COUNT
+	la a1, keywords
+	call _strings_index
+
+	bnez a0, .Lclassify_identifier_end
+	li a0, TOKEN_IDENTIFIER
+
+.Lclassify_identifier_end:
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret
+
+# Takes a symbol and determines its type.
+#
+# Parameters:
+# a0 - Token character.
+#
+# Sets a0 to the appropriate token type.
+.type classify_single, @function
+classify_single:
+	# Prologue.
+	addi sp, sp, -16
+	sw ra, 12(sp)
+	sw s0, 8(sp)
+	addi s0, sp, 16
+
+	mv a1, a0
+	li a2, BYTE_KEYWORDS_SIZE
+	la a0, byte_keywords
+	call _memchr
+
+	la a1, byte_keywords
+	sub a0, a0, a1
+	addi a0, a0, TOKEN_IDENTIFIER + 1
+
+	# Epilogue.
+	lw ra, 12(sp)
+	lw s0, 8(sp)
+	addi sp, sp, 16
+	ret
+
+# Classified a symbol containing multiple characters (probably 2).
+#
+# Parameters:
+# a0 - Token length.
+# a1 - Token pointer.
+#
+# Sets a0 to the appropriate token type.
+.type classify_composite, @function
+classify_composite:
+	lbu t0, 0(a1)
+	li t1, ':'
+	beq t0, t1, .Lclassify_composite_assign
+
+	j .Lclassify_composite_end
+
+.Lclassify_composite_assign:
+	li a0, TOKEN_ASSIGN
+	j .Lclassify_composite_end
+
+.Lclassify_composite_end:
+	ret
+
+# Initializes the classification table.
+#
+# Paramaters:
+# a0 - Source text pointer.
+# a1 - A pointer for output value, the token kind. 4 Bytes.
+#
+# Sets a0 to the position of the next token.
+.type lex_next, @function
+lex_next:
+	# Prologue.
+	addi sp, sp, -32
+	sw ra, 28(sp)
+	sw s0, 24(sp)
+	addi s0, sp, 32
+
+	sw s1, 20(sp) # Preserve s1 used for current source text position.
+	mv s1, a0
+	sw a0, 12(sp) # Keeps a pointer to the beginning of a token.
+	# 4(sp) and 8(sp) are reserved for the kind and length of the token if needed.
+
+	sw s2, 16(sp) # Preserve s2 containing the current state.
+	li s2, 0x00 # Initial, start state.
+
+	sw a1, 0(sp)
+	sw zero, (a1) # Initialize.
+
+.Llex_next_loop:
+	mv a0, s2
+	lbu a1, (s1)
+	call _next_state
+
+	li t0, 0xff
+	and s2, a0, t0 # Next state.
+
+	li t0, 0xff00
+	and t1, a0, t0 # Transition action.
+	srli t1, t1, 8
+
+	# Perform the provided action.
+	li t0, 0x01 # Accumulate action.
+	beq t1, t0, .Llex_next_accumulate
+
+	li t0, 0x02 # Print action.
+	beq t1, t0, .Llex_next_print
+
+	li t0, 0x03 # Skip action.
+	beq t1, t0, .Llex_next_skip
+
+	li t0, 0x04 # Delimited string action.
+	beq t1, t0, .Llex_next_comment
+
+	li t0, 0x05 # Finalize identifier.
+	beq t1, t0, .Llex_next_identifier
+
+	li t0, 0x06 # Single character symbol action.
+	beq t1, t0, .Llex_next_single
+
+	li t0, 0x07 # An action for symbols containing multiple characters.
+	beq t1, t0, .Llex_next_composite
+
+	li t0, 0x08 # Integer action.
+	beq t1, t0, .Llex_next_integer
+
+	j .Llex_next_reject
+
+.Llex_next_reject:
+	addi s1, s1, 1
+
+	j .Llex_next_end
+
+.Llex_next_accumulate:
+	addi s1, s1, 1
+
+	j .Llex_next_loop
+
+.Llex_next_skip:
+	addi s1, s1, 1
+	lw t0, 12(sp)
+	addi t0, t0, 1
+	sw t0, 12(sp)
+
+	j .Llex_next_loop
+
+.Llex_next_print:
+	/* DEBUG
+	addi a0, a0, 21
+	sw a0, 0(sp)
+	addi a0, sp, 0
+	li a1, 1
+	call _write_error */
+
+	j .Llex_next_end
+
+.Llex_next_comment:
+	addi s1, s1, 1
+
+	j .Llex_next_end
+
+.Llex_next_identifier:
+	# An identifier can be a textual keyword.
+	# Check the kind of the token and write it into the output parameter.
+	lw a1, 12(sp)
+	sub a0, s1, a1
+	sw a0, 8(sp)
+	call classify_identifier
+	sw a0, 4(sp)
+	lw a0, 0(sp)
+	addi a1, sp, 4
+	li a2, 12
+	call _memcpy
+
+	j .Llex_next_end
+
+.Llex_next_single:
+	lw a0, 12(sp)
+	addi s1, a0, 1
+	lbu a0, (a0)
+	call classify_single
+	lw a1, 0(sp)
+	sw a0, (a1)
+
+	j .Llex_next_end
+
+.Llex_next_composite:
+	addi s1, s1, 1
+	lw a1, 12(sp)
+	sub a0, s1, a1
+	call classify_composite
+	lw a1, 0(sp)
+	sw a0, (a1)
+
+	j .Llex_next_end
+
+.Llex_next_integer:
+	lw t0, 0(sp)
+	li t1, TOKEN_INTEGER
+	sw t1, 0(t0)
+	lw t1, 12(sp)
+	sw t1, 8(t0)
+	sub t1, s1, t1
+	sw t1, 4(t0)
+
+	j .Llex_next_end
+
+.Llex_next_end:
+	mv a0, s1 # Return the advanced text pointer.
+
+	# Restore saved registers.
+	lw s1, 20(sp)
+	lw s2, 16(sp)
+
+	# Epilogue.
+	lw ra, 28(sp)
+	lw s0, 24(sp)
+	addi sp, sp, 32
+	ret

elna.cabal

@@ -1,88 +0,0 @@
-cabal-version: 3.4
-name: elna
-version: 0.1.0.0
-synopsis:
-    Elna programming language compiles simple mathematical operations to RISC-V code
-
-license:            MPL-2.0
-license-file:       LICENSE
-author:             Eugen Wissner
-maintainer:         belka@caraus.de
-category: Language
-build-type: Simple
-extra-doc-files: TODO README
-
-common warnings
-    build-depends:
-        base >=4.7 && <5,
-        bytestring ^>= 0.12.1,
-        filepath ^>= 1.5.3,
-        megaparsec ^>= 9.6,
-        optparse-applicative ^>= 0.18.1,
-        vector ^>= 0.13.1,
-        text ^>= 2.0
-    ghc-options: -Wall
-    default-extensions:
-        DataKinds,
-        ExplicitForAll,
-        LambdaCase,
-        OverloadedStrings,
-        DuplicateRecordFields,
-        RecordWildCards
-    default-language: GHC2021
-
-library elna-internal
-    import: warnings
-    exposed-modules:
-        Language.Elna.Architecture.RiscV
-        Language.Elna.Backend.Allocator
-        Language.Elna.Backend.Intermediate
-        Language.Elna.Driver
-        Language.Elna.Driver.CommandLine
-        Language.Elna.Frontend.AST
-        Language.Elna.Frontend.NameAnalysis
-        Language.Elna.Frontend.Parser
-        Language.Elna.Frontend.SymbolTable
-        Language.Elna.Frontend.TypeAnalysis
-        Language.Elna.Frontend.Types
-        Language.Elna.Glue
-        Language.Elna.Location
-        Language.Elna.Object.Elf
-        Language.Elna.Object.ElfCoder
-        Language.Elna.Object.StringTable
-        Language.Elna.RiscV.CodeGenerator
-        Language.Elna.RiscV.ElfWriter
-    build-depends:
-        exceptions ^>= 0.10,
-        hashable ^>= 1.4.3,
-        parser-combinators ^>= 1.3,
-        transformers ^>= 0.6.1,
-        unordered-containers ^>= 0.2.20
-    hs-source-dirs: lib
-
-executable elna
-    import: warnings
-    main-is: Main.hs
-    build-depends:
-        elna:elna-internal
-    hs-source-dirs: src
-
-test-suite elna-test
-    import: warnings
-    type: exitcode-stdio-1.0
-    main-is: Spec.hs
-    other-modules:
-        Language.Elna.NameAnalysisSpec
-        Language.Elna.ParserSpec
-    hs-source-dirs:
-        tests
-    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
-
-    build-depends:
-        elna:elna-internal,
-        hspec >= 2.10.9 && < 2.12,
-        hspec-expectations ^>= 0.8.2,
-        hspec-megaparsec ^>= 2.2.0,
-        text
-    build-tool-depends:
-        hspec-discover:hspec-discover

lib/Language/Elna/Architecture/RiscV.hs

@@ -1,326 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Architecture.RiscV
-    ( BaseOpcode(..)
-    , RelocationType(..)
-    , Funct3(..)
-    , Funct7(..)
-    , Funct12(..)
-    , Instruction(..)
-    , Type(..)
-    , XRegister(..)
-    , baseOpcode
-    , funct3
-    , funct12
-    , instruction
-    , xRegister
-    ) where
-
-import qualified Data.ByteString.Builder as ByteString.Builder
-import Data.Bits (Bits(..))
-import Data.Text (Text)
-import Data.Word (Word8, Word32)
-
-data XRegister
-    = Zero
-    | RA
-    | SP
-    | GP
-    | TP
-    | T0
-    | T1
-    | T2
-    | S0
-    | S1
-    | A0
-    | A1
-    | A2
-    | A3
-    | A4
-    | A5
-    | A6
-    | A7
-    | S2
-    | S3
-    | S4
-    | S5
-    | S6
-    | S7
-    | S8
-    | S9
-    | S10
-    | S11
-    | T3
-    | T4
-    | T5
-    | T6
-    deriving Eq
-
-data Funct3
-    = ADDI
-    | SLTI
-    | SLTIU
-    | ANDI
-    | ORI
-    | XORI
-    | SLLI
-    | SRLI
-    | SRAI
-    | ADD
-    | SLT
-    | SLTU
-    | AND
-    | OR
-    | XOR
-    | SLL
-    | SRL
-    | SUB
-    | SRA
-    | BEQ
-    | BNE
-    | BLT
-    | BLTU
-    | BGE
-    | BGEU
-    | FENCE
-    | FENCEI
-    | CSRRW
-    | CSRRS
-    | CSRRC
-    | CSRRWI
-    | CSRRSI
-    | CSRRCI
-    | PRIV
-    | SB
-    | SH
-    | SW
-    | LB
-    | LH
-    | LW
-    | LBU
-    | LHU
-    | JALR
-    | MUL
-    | MULH
-    | MULHSU
-    | MULHU
-    | DIV
-    | DIVU
-    | REM
-    | REMU
-    deriving Eq
-
-data Funct12
-    = ECALL
-    | EBREAK
-    deriving Eq
-
-newtype Funct7 = Funct7
-    { funct7 :: Word8
-    } deriving Eq
-
-data BaseOpcode
-    = OpImm
-    | Lui
-    | Auipc
-    | Op
-    | Jal
-    | Jalr
-    | Branch
-    | Load
-    | Store
-    | MiscMem
-    | System
-    deriving Eq
-
-data Type
-    = I XRegister Funct3 XRegister Word32
-    | S Word32 Funct3 XRegister XRegister
-    | B Word32 Funct3 XRegister XRegister
-    | R XRegister Funct3 XRegister XRegister Funct7
-    | U XRegister Word32
-    | J XRegister Word32
-    | Type XRegister Funct3 XRegister Funct12 -- Privileged.
-    deriving Eq
-
-data RelocationType
-    = RLower12I XRegister Funct3 XRegister Text
-    | RLower12S Text Funct3 XRegister XRegister
-    | RHigher20 XRegister Text -- Type U.
-    | RBranch Text Funct3 XRegister XRegister -- Type B.
-    | RJal XRegister Text -- Type J.
-    deriving Eq
-
-data Instruction
-    = BaseInstruction BaseOpcode Type
-    | RelocatableInstruction BaseOpcode RelocationType
-    | CallInstruction Text
-    deriving Eq
-
-xRegister :: XRegister -> Word8
-xRegister Zero = 0
-xRegister RA = 1
-xRegister SP = 2
-xRegister GP = 3
-xRegister TP = 4
-xRegister T0 = 5
-xRegister T1 = 6
-xRegister T2 = 7
-xRegister S0 = 8
-xRegister S1 = 9
-xRegister A0 = 10
-xRegister A1 = 11
-xRegister A2 = 12
-xRegister A3 = 13
-xRegister A4 = 14
-xRegister A5 = 15
-xRegister A6 = 16
-xRegister A7 = 17
-xRegister S2 = 18
-xRegister S3 = 19
-xRegister S4 = 20
-xRegister S5 = 21
-xRegister S6 = 22
-xRegister S7 = 23
-xRegister S8 = 24
-xRegister S9 = 25
-xRegister S10 = 26
-xRegister S11 = 27
-xRegister T3 = 28
-xRegister T4 = 29
-xRegister T5 = 30
-xRegister T6 = 31
-
-funct3 :: Funct3 -> Word8
-funct3 ADDI = 0b000
-funct3 SLTI = 0b001
-funct3 SLTIU = 0b011
-funct3 ANDI = 0b111
-funct3 ORI = 0b110
-funct3 XORI = 0b100
-funct3 SLLI = 0b000
-funct3 SRLI = 0b101
-funct3 SRAI = 0b101
-funct3 ADD = 0b000
-funct3 SLT = 0b010
-funct3 SLTU = 0b011
-funct3 AND = 0b111
-funct3 OR = 0b110
-funct3 XOR = 0b100
-funct3 SLL = 0b001
-funct3 SRL = 0b101
-funct3 SUB = 0b000
-funct3 SRA = 0b101
-funct3 BEQ = 0b000
-funct3 BNE = 0b001
-funct3 BLT = 0b100
-funct3 BLTU = 0b110
-funct3 BGE = 0b101
-funct3 BGEU = 0b111
-funct3 FENCE = 0b000
-funct3 FENCEI = 0b001
-funct3 CSRRW = 0b001
-funct3 CSRRS = 0b010
-funct3 CSRRC = 0b011
-funct3 CSRRWI = 0b101
-funct3 CSRRSI = 0b110
-funct3 CSRRCI = 0b111
-funct3 PRIV = 0b000
-funct3 SB = 0b000
-funct3 SH = 0b001
-funct3 SW = 0b010
-funct3 LB = 0b000
-funct3 LH = 0b001
-funct3 LW = 0b010
-funct3 LBU = 0b100
-funct3 LHU = 0b101
-funct3 JALR = 0b000
-funct3 MUL = 0b000
-funct3 MULH = 0b001
-funct3 MULHSU = 0b010
-funct3 MULHU = 0b011
-funct3 DIV = 0b100
-funct3 DIVU = 0b101
-funct3 REM = 0b110
-funct3 REMU = 0b111
-
-funct12 :: Funct12 -> Word8
-funct12 ECALL = 0b000000000000
-funct12 EBREAK = 0b000000000001
-
-baseOpcode :: BaseOpcode -> Word8
-baseOpcode OpImm = 0b0010011
-baseOpcode Lui = 0b0110111
-baseOpcode Auipc = 0b0010111
-baseOpcode Op = 0b0110011
-baseOpcode Jal = 0b1101111
-baseOpcode Jalr = 0b1100111
-baseOpcode Branch = 0b1100011
-baseOpcode Load = 0b0000011
-baseOpcode Store = 0b0100011
-baseOpcode MiscMem = 0b0001111
-baseOpcode System = 0b1110011
-
-type' :: Type -> Word32
-type' (I rd funct3' rs1 immediate)
-    = (fromIntegral (xRegister rd) `shiftL` 7)
-    .|. (fromIntegral (funct3 funct3') `shiftL` 12)
-    .|. (fromIntegral (xRegister rs1) `shiftL` 15)
-    .|. (immediate `shiftL` 20);
-type' (S immediate funct3' rs1 rs2)
-    = ((immediate .&. 0x1f) `shiftL` 7)
-    .|. (fromIntegral (funct3 funct3') `shiftL` 12)
-    .|. (fromIntegral (xRegister rs1) `shiftL` 15)
-    .|. (fromIntegral (xRegister rs2) `shiftL` 20)
-    .|. ((immediate .&. 0xfe0) `shiftL` 20)
-type' (B immediate funct3' rs1 rs2)
-    = ((immediate .&. 0x800) `shiftR` 4)
-    .|. ((immediate .&. 0x1e) `shiftL` 7)
-    .|. (fromIntegral (funct3 funct3') `shiftL` 12)
-    .|. (fromIntegral (xRegister rs1) `shiftL` 15)
-    .|. (fromIntegral (xRegister rs2) `shiftL` 20)
-    .|. ((immediate .&. 0x7e0) `shiftL` 20)
-    .|. ((immediate .&. 0x1000) `shiftL` 19)
-type' (R rd funct3' rs1 rs2 funct7')
-    = (fromIntegral (xRegister rd) `shiftL` 7)
-    .|. (fromIntegral (funct3 funct3') `shiftL` 12)
-    .|. (fromIntegral (xRegister rs1) `shiftL` 15)
-    .|. (fromIntegral (xRegister rs2) `shiftL` 20)
-    .|. (fromIntegral (funct7 funct7') `shiftL` 25);
-type' (U rd immediate)
-    = (fromIntegral (xRegister rd) `shiftL` 7)
-    .|. (immediate `shiftL` 12)
-type' (J rd immediate)
-     = (fromIntegral (xRegister rd) `shiftL` 7)
-     .|. (immediate .&. 0xff000)
-     .|. ((immediate .&. 0x800) `shiftL` 9)
-     .|. ((immediate .&. 0x7fe) `shiftL` 20)
-     .|. ((immediate .&. 0x100000) `shiftL` 11);
-type' (Type rd funct3' rs1 funct12')
-    = (fromIntegral (xRegister rd) `shiftL` 7)
-    .|. (fromIntegral (funct3 funct3') `shiftL` 12)
-    .|. (fromIntegral (xRegister rs1) `shiftL` 15)
-    .|. (fromIntegral (funct12 funct12') `shiftL` 20);
-
-relocationType :: RelocationType -> Word32
-relocationType (RLower12I rd funct3' rs1 _) = type' $ I rd funct3' rs1 0
-relocationType (RLower12S _ funct3' rs1 rs2) = type' $ S 0 funct3' rs1 rs2
-relocationType (RHigher20 rd _) = type' $ U rd 0
-relocationType (RBranch _ funct3' rs1 rs2) = type' $ B 0 funct3' rs1 rs2
-relocationType (RJal rd _) = type' $ J rd 0
-
-instruction :: Instruction -> ByteString.Builder.Builder
-instruction = \case
-    (BaseInstruction base instructionType) -> go base $ type' instructionType
-    (RelocatableInstruction base instructionType) -> go base $ relocationType instructionType
-    (CallInstruction _) -> foldMap instruction
-        [ BaseInstruction Auipc $ U RA 0
-        , BaseInstruction Jalr $ I RA JALR RA 0
-        ]
-  where
-    go base instructionType
-        = ByteString.Builder.word32LE
-        $ fromIntegral (baseOpcode base)
-        .|. instructionType

lib/Language/Elna/Backend/Allocator.hs

@@ -1,182 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Backend.Allocator
-    ( MachineConfiguration(..)
-    , Store(..)
-    , allocate
-    ) where
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Int (Int32)
-import Data.Vector (Vector)
-import Language.Elna.Backend.Intermediate
-    ( ProcedureQuadruples(..)
-    , Operand(..)
-    , Quadruple(..)
-    , Variable(..)
-    )
-import Language.Elna.Location (Identifier(..))
-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
-import Control.Monad.Trans.State (State, runState)
-import GHC.Records (HasField(..))
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
-import Data.List ((!?))
-import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
-import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
-
-data Store r
-    = RegisterStore r
-    | StackStore Int32 r
-
-data AllocationError
-    = OutOfRegistersError
-    | UnexpectedProcedureInfoError Info
-    | UndefinedSymbolError Identifier
-    deriving Eq
-
-instance Show AllocationError
-  where
-    show OutOfRegistersError = "Ran out of registers during register allocation"
-    show (UnexpectedProcedureInfoError info) =
-        "Expected to encounter a procedure, got: " <> show info
-    show (UndefinedSymbolError identifier) =
-        concat ["Symbol \"", show identifier, "\" is not defined"]
-
-newtype MachineConfiguration r = MachineConfiguration
-    { temporaryRegisters :: [r]
-    }
-
-newtype MachineState = MachineState
-    { symbolTable :: SymbolTable
-    } deriving (Eq, Show)
-
-newtype Allocator r a = Allocator
-    { runAllocator :: ExceptT AllocationError (ReaderT (MachineConfiguration r) (State MachineState)) a
-    }
-
-instance forall r. Functor (Allocator r)
-  where
-    fmap f = Allocator . fmap f . runAllocator
-
-instance forall r. Applicative (Allocator r)
-  where
-    pure = Allocator . pure
-    (Allocator x) <*> (Allocator y) = Allocator $ x <*> y
-
-instance forall r. Monad (Allocator r)
-  where
-    (Allocator allocator) >>= f = Allocator $ allocator >>= (runAllocator . f)
-
-allocate
-    :: forall r
-    . MachineConfiguration r
-    -> SymbolTable
-    -> HashMap Identifier (Vector (Quadruple Variable))
-    -> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
-allocate machineConfiguration globalTable = HashMap.traverseWithKey function
-  where
-    run localTable = flip runState (MachineState{ symbolTable = localTable })
-        . flip runReaderT machineConfiguration
-        . runExceptT
-        . runAllocator
-        . mapM quadruple
-    function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
-    function procedureName quadruples' =
-        case SymbolTable.lookup procedureName globalTable of
-            Just (ProcedureInfo localTable _) ->
-                let (result, lastState) = run localTable quadruples'
-                 in makeResult lastState <$> result
-            Just anotherInfo -> Left $ UnexpectedProcedureInfoError anotherInfo
-            Nothing -> Left $ UndefinedSymbolError procedureName
-
-    makeResult MachineState{ symbolTable } result = ProcedureQuadruples
-        { quadruples = result
-        , stackSize = fromIntegral $ SymbolTable.size symbolTable * 4
-        }
-
-quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
-quadruple = \case
-    StartQuadruple -> pure StartQuadruple
-    StopQuadruple -> pure StopQuadruple
-    ParameterQuadruple operand1 -> ParameterQuadruple
-        <$> operand operand1
-    CallQuadruple name count -> pure $ CallQuadruple name count
-    AddQuadruple operand1 operand2 variable -> AddQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> storeVariable variable
-    SubtractionQuadruple operand1 operand2 variable -> SubtractionQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> storeVariable variable
-    NegationQuadruple operand1 variable -> NegationQuadruple
-        <$> operand operand1
-        <*> storeVariable variable
-    ProductQuadruple operand1 operand2 variable -> ProductQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> storeVariable variable
-    DivisionQuadruple operand1 operand2 variable -> DivisionQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> storeVariable variable
-    LabelQuadruple label -> pure $ LabelQuadruple label
-    GoToQuadruple label -> pure $ GoToQuadruple label
-    EqualQuadruple operand1 operand2 goToLabel -> EqualQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> pure goToLabel
-    NonEqualQuadruple operand1 operand2 goToLabel -> NonEqualQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> pure goToLabel
-    LessQuadruple operand1 operand2 goToLabel -> LessQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> pure goToLabel
-    GreaterQuadruple operand1 operand2 goToLabel -> do
-        operand1' <- operand operand1
-        operand2' <- operand operand2
-        pure $ GreaterQuadruple operand1' operand2' goToLabel
-    LessOrEqualQuadruple operand1 operand2 goToLabel -> LessOrEqualQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> pure goToLabel
-    GreaterOrEqualQuadruple operand1 operand2 goToLabel -> GreaterOrEqualQuadruple
-        <$> operand operand1
-        <*> operand operand2
-        <*> pure goToLabel
-    AssignQuadruple operand1 variable -> AssignQuadruple 
-        <$> operand operand1
-        <*> storeVariable variable
-    ArrayAssignQuadruple operand1 operand2 variable -> ArrayAssignQuadruple 
-        <$> operand operand1
-        <*> operand operand2
-        <*> storeVariable variable
-    ArrayQuadruple variable1 operand1 variable2 -> ArrayQuadruple 
-        <$> storeVariable variable1
-        <*> operand operand1
-        <*> storeVariable variable2
-
-operand :: Operand Variable -> Allocator r (Operand (Store r))
-operand (IntOperand literalOperand) = pure $ IntOperand literalOperand
-operand (VariableOperand variableOperand) =
-    VariableOperand <$> storeVariable variableOperand
-
-storeVariable :: Variable -> Allocator r (Store r)
-storeVariable (TempVariable index) = do
-    temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
-    maybe (Allocator $ throwE OutOfRegistersError) (pure . RegisterStore)
-        $ temporaryRegisters' !? fromIntegral index
-storeVariable (LocalVariable index) = do
-    temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
-    maybe (Allocator $ throwE OutOfRegistersError) (pure . StackStore (fromIntegral (succ index) * (-4)))
-        $ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index)
-storeVariable (ParameterVariable index) = do
-    temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
-    maybe (Allocator $ throwE OutOfRegistersError) (pure . StackStore (fromIntegral index * 4))
-        $ temporaryRegisters' !? fromIntegral index

lib/Language/Elna/Backend/Intermediate.hs

@@ -1,66 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Backend.Intermediate
-    ( ProcedureQuadruples(..)
-    , Operand(..)
-    , Quadruple(..)
-    , Label(..)
-    , Variable(..)
-    ) where
-
-import Data.Int (Int32)
-import Data.Vector (Vector)
-import Data.Word (Word32)
-import Data.Text (Text)
-import qualified Data.Text as Text
-
-newtype Label = Label { unLabel :: Text }
-    deriving Eq
-
-instance Show Label
-  where
-    show (Label label) = '.' : Text.unpack label
-
-data Variable = TempVariable Word32 | LocalVariable Word32 | ParameterVariable Word32
-    deriving Eq
-
-instance Show Variable
-  where
-    show (LocalVariable variable) = '@' : show variable
-    show (TempVariable variable) = '$' : show variable
-    show (ParameterVariable variable) = '%' : show variable
-
-data Operand v
-    = IntOperand Int32
-    | VariableOperand v
-    deriving (Eq, Show)
-
-data ProcedureQuadruples v = ProcedureQuadruples
-    { quadruples :: Vector (Quadruple v)
-    , stackSize :: Word32
-    } deriving (Eq, Show)
-
-data Quadruple v
-    = StartQuadruple
-    | StopQuadruple
-    | ParameterQuadruple (Operand v)
-    | CallQuadruple Text Word32
-    | AddQuadruple (Operand v) (Operand v) v
-    | SubtractionQuadruple (Operand v) (Operand v) v
-    | NegationQuadruple (Operand v) v
-    | ProductQuadruple (Operand v) (Operand v) v
-    | DivisionQuadruple (Operand v) (Operand v) v
-    | GoToQuadruple Label
-    | AssignQuadruple (Operand v) v
-    | ArrayQuadruple v (Operand v) v
-    | ArrayAssignQuadruple (Operand v) (Operand v) v
-    | LessOrEqualQuadruple (Operand v) (Operand v) Label
-    | GreaterOrEqualQuadruple (Operand v) (Operand v) Label
-    | GreaterQuadruple (Operand v) (Operand v) Label
-    | LessQuadruple (Operand v) (Operand v) Label
-    | NonEqualQuadruple (Operand v) (Operand v) Label
-    | EqualQuadruple (Operand v) (Operand v) Label
-    | LabelQuadruple Label
-    deriving (Eq, Show)

lib/Language/Elna/Driver.hs

@@ -1,37 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Driver
-    ( Driver(..)
-    , IntermediateStage(..)
-    , drive
-    , execParser
-    ) where
-
-import Data.Maybe (fromMaybe)
-import Language.Elna.Driver.CommandLine
-    ( CommandLine(..)
-    , IntermediateStage(..)
-    , commandLine
-    )
-import Options.Applicative (execParser)
-import System.FilePath (replaceExtension, takeFileName)
-
-data Driver = Driver
-    { input :: FilePath
-    , output :: FilePath
-    , intermediateStage :: Maybe IntermediateStage
-    } deriving (Eq, Show)
-
-drive :: IO Driver
-drive = rewrite <$> execParser commandLine
-  where
-    rewrite CommandLine{..} =
-        let defaultOutputName = replaceExtension (takeFileName input) "o"
-            outputName = fromMaybe defaultOutputName output
-         in Driver
-            { input = input
-            , output = outputName
-            , intermediateStage = intermediateStage
-            }

lib/Language/Elna/Driver/CommandLine.hs

@@ -1,69 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Driver.CommandLine
-    ( CommandLine(..)
-    , IntermediateStage(..)
-    , commandLine
-    ) where
-
-import Options.Applicative
-    ( Parser
-    , ParserInfo(..)
-    , argument
-    , flag'
-    , fullDesc
-    , help
-    , helper
-    , info
-    , long
-    , metavar
-    , optional
-    , progDesc
-    , short
-    , str
-    , strOption
-    )
-import Control.Applicative (Alternative(..), (<**>))
-
-data IntermediateStage
-    = ParseStage
-    | ValidateStage
-    | CodeGenStage
-    deriving (Eq, Show)
-
-data CommandLine = CommandLine
-    { input :: FilePath
-    , output :: Maybe FilePath
-    , intermediateStage :: Maybe IntermediateStage
-    } deriving (Eq, Show)
-
-intermediateStageP :: Parser IntermediateStage
-intermediateStageP
-    = flag' ParseStage parseStageP
-    <|>  flag' ValidateStage validateStageP
-    <|> flag' CodeGenStage codeGenStageP
-  where
-    parseStageP = long "parse"
-        <> help "Run the lexer and parser, but stop before assembly generation"
-    validateStageP = long "validate"
-        <> help "Run through the semantic analysis stage, stopping before TAC generation"
-    codeGenStageP = long "codegen"
-        <> help "Perform lexing, parsing, and assembly generation, but stop before code emission"
-
-commandLineP :: Parser CommandLine
-commandLineP = CommandLine
-    <$> argument str inFile
-    <*> optional (strOption outFile)
-    <*> optional intermediateStageP
-  where
-    inFile = metavar "INFILE" <> help "Input file."
-    outFile = long "output"
-        <> short 'o'
-        <> metavar "OUTFILE"
-        <> help "Output file."
-
-commandLine :: ParserInfo CommandLine
-commandLine = info (commandLineP <**> helper)
-    $ fullDesc <> progDesc "Elna compiler."

lib/Language/Elna/Frontend/AST.hs

@@ -1,210 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.AST
-    ( Declaration(..)
-    , Identifier(..)
-    , Parameter(..)
-    , Program(..)
-    , Statement(..)
-    , TypeExpression(..)
-    , VariableDeclaration(..)
-    , VariableAccess(..)
-    , Condition(..)
-    , Expression(..)
-    , Literal(..)
-    ) where
-
-import Data.Char (chr)
-import Data.Int (Int32)
-import Data.List (intercalate)
-import Data.Word (Word8)
-import Language.Elna.Location (Identifier(..), showArrayType)
-import Numeric (showHex)
-import Data.Bifunctor (Bifunctor(bimap))
-
-newtype Program = Program [Declaration]
-    deriving Eq
-
-instance Show Program
-  where
-    show (Program declarations) = unlines (show <$> declarations)
-
-data Declaration
-    = ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement]
-    | TypeDefinition Identifier TypeExpression
-    deriving Eq
-
-instance Show Declaration
-  where
-    show (TypeDefinition identifier typeExpression) =
-        concat ["type ", show identifier, " = ", show typeExpression, ";"]
-    show (ProcedureDeclaration procedureName parameters variables body)
-        = "proc " <> show procedureName <> showParameters parameters <> " {\n"
-        <> unlines (("  " <>) . show <$> variables)
-        <> unlines (("  " <>) . show <$> body)
-        <> "}"
-
-data Parameter = Parameter Identifier TypeExpression Bool
-    deriving Eq
-
-instance Show Parameter
-  where
-    show (Parameter identifier typeName ref) = concat
-        [ if ref then "ref " else ""
-        , show identifier, ": ", show typeName
-        ]
-
-showParameters :: [Parameter] -> String
-showParameters parameters =
-    "(" <> intercalate ", " (show <$> parameters) <> ")"
-
-data TypeExpression
-    = NamedType Identifier
-    | ArrayType Literal TypeExpression
-    deriving Eq
-
-instance Show TypeExpression
-  where
-    show (NamedType typeName) = show typeName
-    show (ArrayType elementCount typeName) =
-        showArrayType elementCount typeName
-
-data Statement
-    = EmptyStatement
-    | IfStatement Condition Statement (Maybe Statement)
-    | AssignmentStatement VariableAccess Expression
-    | WhileStatement Condition Statement
-    | CompoundStatement [Statement]
-    | CallStatement Identifier [Expression]
-    deriving Eq
-
-instance Show Statement
-  where
-    show EmptyStatement = ";"
-    show (IfStatement condition if' else') = concat
-        [ "if (", show condition, ") "
-        , show if'
-        , maybe "" ((<> " else ") . show) else'
-        ]
-    show (AssignmentStatement lhs rhs) =
-        concat [show lhs, " := ", show rhs, ";"]
-    show (WhileStatement expression statement) =
-        concat ["while (", show expression, ") ", show statement, ";"]
-    show (CompoundStatement statements) =
-        concat ["{\n", unlines (show <$> statements), " }"]
-    show (CallStatement name parameters) = show name <> "("
-        <> intercalate ", " (show <$> parameters) <> ")"
-
-data VariableDeclaration =
-    VariableDeclaration Identifier TypeExpression
-    deriving Eq
-
-data Literal
-    = DecimalLiteral Int32
-    | HexadecimalLiteral Int32
-    | CharacterLiteral Word8
-    deriving Eq
-
-instance Show Literal
-  where
-    show (DecimalLiteral integer) = show integer
-    show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
-    show (CharacterLiteral character) =
-        '\'' : chr (fromEnum character) : ['\'']
-
-instance Ord Literal
-  where
-    compare x y = compare (int32Literal x) (int32Literal y)
-
-instance Num Literal
-  where
-    x + y = DecimalLiteral $ int32Literal x + int32Literal y
-    x * y = DecimalLiteral $ int32Literal x * int32Literal y
-    abs (DecimalLiteral x) = DecimalLiteral $ abs x
-    abs (HexadecimalLiteral x) = HexadecimalLiteral $ abs x
-    abs (CharacterLiteral x) = CharacterLiteral $ abs x
-    negate (DecimalLiteral x) = DecimalLiteral $ negate x
-    negate (HexadecimalLiteral x) = HexadecimalLiteral $ negate x
-    negate (CharacterLiteral x) = CharacterLiteral $ negate x
-    signum (DecimalLiteral x) = DecimalLiteral $ signum x
-    signum (HexadecimalLiteral x) = HexadecimalLiteral $ signum x
-    signum (CharacterLiteral x) = CharacterLiteral $ signum x
-    fromInteger = DecimalLiteral . fromInteger
-
-instance Real Literal
-  where
-    toRational (DecimalLiteral integer) = toRational integer
-    toRational (HexadecimalLiteral integer) = toRational integer
-    toRational (CharacterLiteral integer) = toRational integer
-
-instance Enum Literal
-  where
-   toEnum = DecimalLiteral . fromIntegral
-   fromEnum = fromEnum . int32Literal
-
-instance Integral Literal
-  where
-    toInteger = toInteger . int32Literal
-    quotRem x y = bimap DecimalLiteral DecimalLiteral
-        $ quotRem (int32Literal x) (int32Literal y)
-
-int32Literal :: Literal -> Int32
-int32Literal (DecimalLiteral integer) = integer
-int32Literal (HexadecimalLiteral integer) = integer
-int32Literal (CharacterLiteral integer) = fromIntegral integer
-
-instance Show VariableDeclaration
-  where
-    show (VariableDeclaration identifier typeExpression) =
-        concat ["var ", show identifier, ": " <> show typeExpression, ";"]
-
-data Expression
-    = LiteralExpression Literal
-    | SumExpression Expression Expression
-    | SubtractionExpression Expression Expression
-    | NegationExpression Expression
-    | ProductExpression Expression Expression
-    | DivisionExpression Expression Expression
-    | VariableExpression VariableAccess
-    deriving Eq
-
-instance Show Expression
-  where
-    show (LiteralExpression literal) = show literal
-    show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs]
-    show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs]
-    show (NegationExpression negation) = '-' : show negation
-    show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
-    show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs]
-    show (VariableExpression variable) = show variable
-
-data VariableAccess
-    = VariableAccess Identifier
-    | ArrayAccess VariableAccess Expression
-    deriving Eq
-
-instance Show VariableAccess
-  where
-    show (VariableAccess variableName) = show variableName
-    show (ArrayAccess arrayAccess elementIndex) =
-        concat [show arrayAccess, "[", show elementIndex, "]"]
-
-data Condition
-    = EqualCondition Expression Expression
-    | NonEqualCondition Expression Expression
-    | LessCondition Expression Expression
-    | GreaterCondition Expression Expression
-    | LessOrEqualCondition Expression Expression
-    | GreaterOrEqualCondition Expression Expression
-    deriving Eq
-
-instance Show Condition
-  where
-    show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs]
-    show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs]
-    show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs]
-    show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs]
-    show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs]
-    show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs]

lib/Language/Elna/Frontend/NameAnalysis.hs

@@ -1,211 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.NameAnalysis
-    ( nameAnalysis
-    , Error(..)
-    ) where
-
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Vector as Vector
-import qualified Language.Elna.Frontend.AST as AST
-import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
-import Language.Elna.Frontend.SymbolTable
-    ( SymbolTable
-    , Info(..)
-    , ParameterInfo(..)
-    )
-import Control.Monad.Trans.Except (Except, runExcept, throwE)
-import Data.Functor ((<&>))
-import Language.Elna.Location (Identifier(..))
-import Language.Elna.Frontend.Types (Type(..))
-import Data.Foldable (traverse_)
-import Control.Monad (foldM, unless)
-
-data Error
-    = UndefinedTypeError Identifier
-    | UnexpectedTypeInfoError Info
-    | IdentifierAlreadyDefinedError Identifier
-    | UndefinedSymbolError Identifier
-    | UnexpectedArrayByValue Identifier
-    deriving Eq
-
-instance Show Error
-  where
-    show (UndefinedTypeError identifier) =
-        concat ["Type \"", show identifier, "\" is not defined"]
-    show (UnexpectedTypeInfoError info) = show info
-        <> " expected to be a type"
-    show (IdentifierAlreadyDefinedError identifier) =
-        concat ["The identifier \"", show identifier, "\" is already defined"]
-    show (UndefinedSymbolError identifier) =
-        concat ["Symbol \"", show identifier, "\" is not defined"]
-    show (UnexpectedArrayByValue identifier) = concat
-        [ "Array \""
-        , show identifier
-        , "\" cannot be passed by value, only by reference"
-        ]
-
-newtype NameAnalysis a = NameAnalysis
-    { runNameAnalysis :: Except Error a
-    }
-
-instance Functor NameAnalysis
-  where
-    fmap f (NameAnalysis x) = NameAnalysis $ f <$> x
-
-instance Applicative NameAnalysis
-  where
-    pure = NameAnalysis . pure
-    (NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x
-
-instance Monad NameAnalysis
-  where
-    (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
-
-nameAnalysis :: AST.Program -> Either Error SymbolTable
-nameAnalysis = runExcept
-    . runNameAnalysis
-    . program SymbolTable.builtInSymbolTable
-
-program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable
-program symbolTable (AST.Program declarations) = do
-    globalTable <- foldM procedureDeclaration symbolTable declarations
-    foldM declaration globalTable declarations
-
-procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
-procedureDeclaration globalTable = \case
-    (AST.ProcedureDeclaration identifier parameters _ _)
-        -> mapM (parameter globalTable) parameters
-        >>= enterOrFail identifier
-        . ProcedureInfo SymbolTable.empty
-        . Vector.fromList
-    (AST.TypeDefinition identifier typeExpression)
-        -> dataType globalTable typeExpression
-        >>= enterOrFail identifier . SymbolTable.TypeInfo
-  where
-    enterOrFail identifier declarationInfo =
-        maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure
-            $ SymbolTable.enter identifier declarationInfo globalTable
-
-declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
-declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do
-    variableInfo <- mapM (variableDeclaration globalTable) variables
-    parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters
-    procedureTable <- fmap (SymbolTable.scope globalTable)
-        $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure
-        $ SymbolTable.fromList
-        $ parameterInfo <> variableInfo
-    traverse_ (statement procedureTable) body
-    pure $ SymbolTable.update (updater procedureTable) identifier globalTable
-  where
-    updater procedureTable (ProcedureInfo _ parameters') = Just
-        $ ProcedureInfo procedureTable parameters'
-    updater _ _ = Nothing
-declaration globalTable (AST.TypeDefinition _ _) = pure globalTable
-
-parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info)
-parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter')
-    = (identifier,) . VariableInfo isReferenceParameter'
-    <$> dataType symbolTable typeExpression
-
-variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
-variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression)
-    = (identifier,) . VariableInfo False
-    <$> dataType globalTable typeExpression
-
-parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo
-parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do
-    parameterType <- dataType environmentSymbolTable typeExpression
-    case parameterType of
-        ArrayType _ _
-            | not isReferenceParameter' -> NameAnalysis
-                $ throwE $ UnexpectedArrayByValue identifier
-        _ ->
-            let parameterInfo = ParameterInfo
-                    { name = identifier
-                    , type' = parameterType
-                    , isReferenceParameter = isReferenceParameter'
-                    }
-             in pure parameterInfo
-
-dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type
-dataType environmentSymbolTable (AST.NamedType baseType) = do
-    case SymbolTable.lookup baseType environmentSymbolTable of
-        Just baseInfo
-            | TypeInfo baseType' <- baseInfo -> pure baseType'
-            | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
-        _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
-dataType environmentSymbolTable (AST.ArrayType arraySize baseType) =
-    dataType environmentSymbolTable baseType <&> ArrayType (fromIntegral arraySize)
-
-checkSymbol :: SymbolTable -> Identifier -> NameAnalysis ()
-checkSymbol globalTable identifier
-    = unless (SymbolTable.member identifier globalTable)
-    $ NameAnalysis $ throwE
-    $ UndefinedSymbolError identifier
-
-expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
-expression _ (AST.LiteralExpression _) = pure ()
-expression globalTable (AST.SumExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.SubtractionExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.NegationExpression negation) =
-    expression globalTable negation
-expression globalTable (AST.ProductExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.DivisionExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.VariableExpression variableExpression) =
-    variableAccess globalTable variableExpression
-
-statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
-statement _ AST.EmptyStatement = pure ()
-statement globalTable (AST.CallStatement name arguments)
-    = checkSymbol globalTable name
-    >> traverse_ (expression globalTable) arguments
-statement globalTable (AST.CompoundStatement statements) =
-    traverse_ (statement globalTable) statements
-statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
-    = condition globalTable ifCondition
-    >> statement globalTable ifStatement
-    >> maybe (pure ()) (statement globalTable) elseStatement
-statement globalTable (AST.AssignmentStatement lvalue rvalue)
-    = variableAccess globalTable lvalue
-    >> expression globalTable rvalue
-statement globalTable (AST.WhileStatement whileCondition loop)
-    = condition globalTable whileCondition
-    >> statement globalTable loop
-
-condition :: SymbolTable -> AST.Condition -> NameAnalysis ()
-condition globalTable (AST.EqualCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-condition globalTable (AST.NonEqualCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-condition globalTable (AST.LessCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-condition globalTable (AST.GreaterCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-condition globalTable (AST.LessOrEqualCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-condition globalTable (AST.GreaterOrEqualCondition lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-
-variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis ()
-variableAccess globalTable (AST.VariableAccess identifier) =
-    checkSymbol globalTable identifier
-variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression)
-    = variableAccess globalTable arrayExpression
-    >> expression globalTable indexExpression

lib/Language/Elna/Frontend/Parser.hs

@@ -1,227 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.Parser
-    ( Parser
-    , programP
-    ) where
-
-import Control.Monad (void)
-import Control.Monad.Combinators.Expr (Operator(..), makeExprParser)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Void (Void)
-import Language.Elna.Frontend.AST
-    ( Declaration(..)
-    , Identifier(..)
-    , Parameter(..)
-    , Program(..)
-    , Statement(..)
-    , TypeExpression(..)
-    , VariableDeclaration(..)
-    , VariableAccess(..)
-    , Condition(..)
-    , Expression(..)
-    , Literal(..)
-    )
-import Text.Megaparsec
-    ( Parsec
-    , (<?>)
-    , MonadParsec(..)
-    , eof
-    , optional
-    , between
-    , sepBy
-    , choice
-    )
-import qualified Text.Megaparsec.Char.Lexer as Lexer
-import Text.Megaparsec.Char
-    ( alphaNumChar
-    , char
-    , letterChar
-    , space1
-    , string
-    )
-import Control.Applicative (Alternative(..))
-import Data.Maybe (isJust)
-
-type Parser = Parsec Void Text
-
-literalP :: Parser Literal
-literalP
-    = HexadecimalLiteral <$> Lexer.signed space hexadecimalP
-    <|> DecimalLiteral <$> Lexer.signed space decimalP
-    <|> CharacterLiteral <$> lexeme charP
-  where
-    charP = fromIntegral . fromEnum
-        <$> between (char '\'') (char '\'') Lexer.charLiteral
-
-typeDefinitionP :: Parser Declaration
-typeDefinitionP = TypeDefinition
-    <$> (symbol "type" *> identifierP)
-    <*> (symbol "=" *> typeExpressionP)
-    <* semicolonP
-    <?> "type definition"
-
-termP :: Parser Expression
-termP = choice
-    [ parensP expressionP
-    , LiteralExpression <$> literalP
-    , VariableExpression <$> variableAccessP
-    ]
-
-operatorTable :: [[Operator Parser Expression]]
-operatorTable =
-    [ unaryOperator
-    , factorOperator
-    , termOperator
-    ]
-  where
-    unaryOperator =
-        [ prefix "-" NegationExpression
-        , prefix "+" id
-        ]
-    factorOperator =
-        [ binary "*" ProductExpression
-        , binary "/" DivisionExpression
-        ]
-    termOperator =
-        [ binary "+" SumExpression
-        , binary "-" SubtractionExpression
-        ]
-    prefix name f = Prefix (f <$ symbol name)
-    binary name f = InfixL (f <$ symbol name)
-
-expressionP :: Parser Expression
-expressionP = makeExprParser termP operatorTable
-
-variableAccessP :: Parser VariableAccess
-variableAccessP = do
-    identifier <- identifierP
-    indices <- many $ bracketsP expressionP
-    pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices
-
-conditionP :: Parser Condition
-conditionP = do
-    lhs <- expressionP
-    conditionCons <- choice comparisonOperator
-    conditionCons lhs <$> expressionP
-  where
-    comparisonOperator =
-        [ symbol "<=" >> pure LessOrEqualCondition
-        , symbol "<" >> pure LessCondition
-        , symbol ">=" >> pure GreaterOrEqualCondition
-        , symbol ">" >> pure GreaterCondition
-        , symbol "=" >> pure EqualCondition
-        , symbol "#" >> pure NonEqualCondition
-        ]
-
-symbol :: Text -> Parser Text
-symbol = Lexer.symbol space
-
-space :: Parser ()
-space = Lexer.space space1 (Lexer.skipLineComment "//")
-    $ Lexer.skipBlockComment "/*" "*/"
-
-lexeme :: forall a. Parser a -> Parser a
-lexeme = Lexer.lexeme space
-
-blockP :: forall a. Parser a -> Parser a
-blockP = between (symbol "{") (symbol "}")
-
-parensP :: forall a. Parser a -> Parser a
-parensP = between (symbol "(")  (symbol ")")
-
-bracketsP :: forall a. Parser a -> Parser a
-bracketsP = between (symbol "[") (symbol "]")
-
-colonP :: Parser ()
-colonP = void $ symbol ":"
-
-commaP :: Parser ()
-commaP = void $ symbol ","
-
-semicolonP :: Parser ()
-semicolonP = void $ symbol ";"
-
-decimalP :: Integral a => Parser a
-decimalP = lexeme Lexer.decimal
-
-hexadecimalP :: Integral a => Parser a
-hexadecimalP = string "0x" *> lexeme Lexer.hexadecimal
-
-identifierP :: Parser Identifier
-identifierP =
-    let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier"
-     in fmap Identifier $ lexeme $ Text.pack <$> wordParser
-
-procedureP :: Parser ()
-procedureP = void $ symbol "proc"
-
-parameterP :: Parser Parameter
-parameterP = paramCons
-    <$> optional (symbol "ref")
-    <*> identifierP
-    <*> (colonP *> typeExpressionP)
-  where
-    paramCons ref name typeName = Parameter name typeName (isJust ref)
-
-typeExpressionP :: Parser TypeExpression
-typeExpressionP = arrayTypeExpression
-    <|> NamedType <$> identifierP
-    <?> "type expression"
-  where
-    arrayTypeExpression = ArrayType
-        <$> (symbol "array" *> bracketsP literalP)
-        <*> (symbol "of" *> typeExpressionP)
-
-procedureDeclarationP :: Parser Declaration
-procedureDeclarationP = procedureCons
-    <$> (procedureP *> identifierP)
-    <*> parensP (sepBy parameterP commaP)
-    <*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
-    <?> "procedure definition"
-  where
-    procedureCons procedureName parameters (variables, body) =
-        ProcedureDeclaration procedureName parameters variables body
-
-statementP :: Parser Statement
-statementP
-    = EmptyStatement <$ semicolonP
-    <|> ifElseP
-    <|> CompoundStatement <$> blockP (many statementP)
-    <|> try assignmentP
-    <|> try whileP
-    <|> callP
-    <?> "statement"
-  where
-    callP = CallStatement
-        <$> identifierP
-        <*> parensP (sepBy expressionP commaP)
-        <* semicolonP
-    ifElseP = IfStatement
-        <$> (symbol "if" *> parensP conditionP)
-        <*> statementP
-        <*> optional (symbol "else" *> statementP)
-    whileP = WhileStatement
-        <$> (symbol "while" *> parensP conditionP)
-        <*> statementP
-    assignmentP = AssignmentStatement
-        <$> variableAccessP
-        <* symbol ":="
-        <*> expressionP
-        <* semicolonP
-
-variableDeclarationP :: Parser VariableDeclaration
-variableDeclarationP = VariableDeclaration
-    <$> (symbol "var" *> identifierP)
-    <*> (colonP *> typeExpressionP)
-    <* semicolonP
-    <?> "variable declaration"
-
-declarationP :: Parser Declaration
-declarationP = procedureDeclarationP <|> typeDefinitionP
-
-programP :: Parser Program
-programP = Program <$> many declarationP <* eof

lib/Language/Elna/Frontend/SymbolTable.hs

@@ -1,109 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.SymbolTable
-    ( SymbolTable
-    , Info(..)
-    , ParameterInfo(..)
-    , builtInSymbolTable
-    , empty
-    , enter
-    , fromList
-    , lookup
-    , member
-    , scope
-    , size
-    , toMap
-    , update
-    ) where
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.List (sort)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (isJust)
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import Language.Elna.Location (Identifier(..))
-import Language.Elna.Frontend.Types (Type(..), intType)
-import Prelude hiding (lookup)
-
-data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
-    deriving (Eq, Show)
-
-empty :: SymbolTable
-empty = SymbolTable Nothing HashMap.empty
-
-update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable
-update updater key (SymbolTable parent mappings) = SymbolTable parent
-    $ HashMap.update updater key mappings
-
-scope :: SymbolTable -> SymbolTable -> SymbolTable
-scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings
-
-builtInSymbolTable :: SymbolTable
-builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList
-    [ ("printi", ProcedureInfo empty (Vector.singleton printiX))
-    , ("printc", ProcedureInfo empty (Vector.singleton printcI))
-    , ("exit", ProcedureInfo empty Vector.empty)
-    , ("int", TypeInfo intType)
-    ]
-  where
-    printiX = ParameterInfo
-        { name = "x"
-        , type' = intType
-        , isReferenceParameter = False
-        }
-    printcI = ParameterInfo
-        { name = "i"
-        , type' = intType
-        , isReferenceParameter = False
-        }
-
-toMap :: SymbolTable  -> HashMap Identifier Info
-toMap (SymbolTable _ map') = map'
-
-enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable
-enter identifier info table@(SymbolTable parent hashTable)
-    | member identifier table = Nothing
-    | otherwise = Just
-        $ SymbolTable parent (HashMap.insert identifier info hashTable)
-
-lookup :: Identifier -> SymbolTable -> Maybe Info
-lookup identifier (SymbolTable parent table)
-    | Just found <- HashMap.lookup identifier table = Just found
-    | Just parent' <- parent = lookup identifier parent'
-    | otherwise = Nothing
-
-member :: Identifier -> SymbolTable -> Bool
-member identifier table =
-    isJust $ lookup identifier table
-
-size :: SymbolTable -> Int
-size (SymbolTable _ map') = HashMap.size map'
-
-fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
-fromList elements
-    | Just identifierDuplicates' <- identifierDuplicates =
-        Left identifierDuplicates'
-    | otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements
-  where
-    identifierDuplicates = NonEmpty.nonEmpty
-        $ fmap NonEmpty.head
-        $ filter ((> 1) . NonEmpty.length)
-        $ NonEmpty.group . sort
-        $ fst <$> elements
-
-data ParameterInfo = ParameterInfo
-    { name :: Identifier
-    , type' :: Type
-    , isReferenceParameter :: Bool
-    } deriving (Eq, Show)
-
-data Info
-    = TypeInfo Type
-    | VariableInfo Bool Type
-    | ProcedureInfo SymbolTable (Vector ParameterInfo)
-    deriving (Eq, Show)

lib/Language/Elna/Frontend/TypeAnalysis.hs

@@ -1,208 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.TypeAnalysis
-    ( typeAnalysis
-    , -- Error(..)
-    ) where
-
-import Control.Applicative (Alternative(..))
-import Control.Monad (unless)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Except (Except, runExcept, throwE)
-import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT, ask, asks)
-import Data.Foldable (traverse_)
-import qualified Data.Vector as Vector
-import qualified Language.Elna.Frontend.AST as AST
-import Language.Elna.Frontend.SymbolTable (Info(..), ParameterInfo(..), SymbolTable)
-import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
-import Language.Elna.Frontend.Types (Type(..), booleanType, intType)
-import Language.Elna.Location (Identifier(..))
-
-typeAnalysis :: SymbolTable -> AST.Program -> Maybe Error
-typeAnalysis globalTable = either Just (const Nothing)
-    . runExcept
-    . flip runReaderT globalTable
-    . runTypeAnalysis
-    . program
-
-data Error
-    = UnexpectedProcedureInfoError Info
-    | UndefinedSymbolError Identifier
-    | ParameterCountMismatchError Int Int
-    | UnexpectedVariableInfoError Info
-    | ArithmeticExpressionError Type
-    | ComparisonExpressionError Type Type
-    | InvalidConditionTypeError Type
-    {- | ExpectedLvalueError AST.Expression
-    | ArgumentTypeMismatchError Type Type -}
-    | ArrayIndexError Type
-    | ArrayAccessError Type
-    deriving Eq
-
-instance Show Error
-  where
-    show (UnexpectedProcedureInfoError info) =
-        "Expected to encounter a procedure, got: " <> show info
-    show (UndefinedSymbolError identifier) =
-        concat ["Symbol \"", show identifier, "\" is not defined"]
-    show (ParameterCountMismatchError parameterCount argumentCount)
-        = "The function was expected to receive " <> show argumentCount
-        <> " arguments, but got " <> show parameterCount
-    show (UnexpectedVariableInfoError info) =
-        "Expected to encounter a variable, got: " <> show info
-    show (ArithmeticExpressionError got) =
-        "Expected an arithmetic expression to be an integer, got: " <> show got
-    show (ComparisonExpressionError lhs rhs)
-        = "Expected an arithmetic expression to be an integer, got \""
-        <> show lhs <> "\" and \"" <> show rhs <> "\""
-    show (InvalidConditionTypeError got) =
-        "Expected a condition to be a boolean, got: " <> show got
-    show (ArrayIndexError got) =
-        "Expected an array index expression to be an integer, got: " <> show got
-    show (ArrayAccessError got) =
-        "Expected to encounter an array, got: " <> show got
-
-newtype TypeAnalysis a = TypeAnalysis
-    { runTypeAnalysis :: ReaderT SymbolTable (Except Error) a
-    }
-
-instance Functor TypeAnalysis
-  where
-    fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x
-
-instance Applicative TypeAnalysis
-  where
-    pure = TypeAnalysis . pure
-    (TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x
-
-instance Monad TypeAnalysis
-  where
-    (TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f)
-
-program :: AST.Program -> TypeAnalysis ()
-program (AST.Program declarations) = traverse_ declaration declarations
-
-declaration :: AST.Declaration -> TypeAnalysis ()
-declaration (AST.ProcedureDeclaration procedureName _ _ body) = do
-    globalTable <- TypeAnalysis ask
-    case SymbolTable.lookup procedureName globalTable of
-        Just (ProcedureInfo localTable _) -> TypeAnalysis
-            $ withReaderT (const localTable)
-            $ runTypeAnalysis
-            $ traverse_ (statement globalTable) body
-        Just anotherInfo -> TypeAnalysis $ lift $ throwE
-            $ UnexpectedProcedureInfoError anotherInfo
-        Nothing -> TypeAnalysis $ lift $ throwE
-            $ UndefinedSymbolError procedureName
-declaration (AST.TypeDefinition _ _) = pure ()
-
-statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
-statement globalTable = \case
-    AST.EmptyStatement -> pure ()
-    AST.AssignmentStatement lhs rhs -> do
-        lhsType <- variableAccess globalTable lhs
-        rhsType <- expression globalTable rhs
-        unless (lhsType == intType)
-            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
-        unless (rhsType == intType)
-            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
-    AST.WhileStatement whileCondition whileStatement -> do
-        conditionType <- condition globalTable whileCondition
-        unless (conditionType == booleanType)
-            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
-        statement globalTable whileStatement
-    AST.IfStatement ifCondition ifStatement elseStatement -> do
-        conditionType <- condition globalTable ifCondition
-        unless (conditionType == booleanType)
-            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
-        statement globalTable ifStatement
-        maybe (pure ()) (statement globalTable) elseStatement
-    AST.CompoundStatement statements -> traverse_ (statement globalTable) statements
-    AST.CallStatement procedureName arguments ->
-        case SymbolTable.lookup procedureName globalTable of
-            Just (ProcedureInfo _ parameters)
-                | parametersLength <- Vector.length parameters
-                , argumentsLength <- length arguments
-                , Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE
-                    $ ParameterCountMismatchError parametersLength argumentsLength
-                | otherwise -> traverse_ (uncurry checkArgument)
-                    $ Vector.zip parameters (Vector.fromList arguments)
-            Just anotherInfo -> TypeAnalysis $ lift $ throwE
-                $ UnexpectedVariableInfoError anotherInfo
-            Nothing -> TypeAnalysis $ lift $ throwE
-                $ UndefinedSymbolError procedureName
-  where
-    checkArgument ParameterInfo{} _argument = pure () {-
-        argumentType <- expression globalTable argument
-        unless (argumentType == type')
-            $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
-        when (isReferenceParameter && not (isLvalue argument))
-            $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument
-    isLvalue (AST.VariableExpression _) = True
-    isLvalue _ = False -}
-
-variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type
-variableAccess globalTable (AST.VariableAccess identifier) = do
-    localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier
-    case localLookup <|> SymbolTable.lookup identifier globalTable of
-        Just (VariableInfo _ variableType) -> pure variableType
-        Just anotherInfo -> TypeAnalysis $ lift $ throwE
-            $ UnexpectedVariableInfoError anotherInfo
-        Nothing -> TypeAnalysis $ lift $ throwE
-            $ UndefinedSymbolError identifier
-variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do
-        arrayType <- variableAccess globalTable arrayExpression
-        indexType <- expression globalTable indexExpression
-        unless (indexType == intType)
-            $ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType
-        case arrayType of
-            ArrayType _ baseType -> pure baseType
-            nonArrayType -> TypeAnalysis $ lift $ throwE
-                $ ArrayAccessError nonArrayType
-
-expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type
-expression globalTable = \case
-    AST.VariableExpression variableExpression ->
-        variableAccess globalTable variableExpression
-    AST.LiteralExpression literal' -> literal literal'
-    AST.NegationExpression negation -> do
-        operandType <- expression globalTable negation
-        if operandType == intType
-        then pure intType
-        else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType
-    AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs
-    AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs
-    AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs
-    AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs
-  where
-    arithmeticExpression lhs rhs = do
-        lhsType <- expression globalTable lhs
-        unless (lhsType == intType)
-            $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType
-        rhsType <- expression globalTable rhs
-        unless (rhsType == intType)
-            $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType
-        pure intType
-
-condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type
-condition globalTable = \case
-    AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs
-    AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs
-    AST.LessCondition lhs rhs -> comparisonExpression lhs rhs
-    AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs
-    AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
-    AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
-  where
-    comparisonExpression lhs rhs = do
-        lhsType <- expression globalTable lhs
-        rhsType <- expression globalTable rhs
-        if lhsType == intType && rhsType == intType
-        then pure booleanType
-        else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType
-
-literal :: AST.Literal -> TypeAnalysis Type
-literal (AST.DecimalLiteral _) = pure intType
-literal (AST.HexadecimalLiteral _) = pure intType
-literal (AST.CharacterLiteral _) = pure intType

lib/Language/Elna/Frontend/Types.hs

@@ -1,33 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Frontend.Types
-    ( Type(..)
-    , addressByteSize
-    , booleanType
-    , intType
-    ) where
-
-import Data.Text (Text)
-import Data.Word (Word32)
-import Language.Elna.Location (showArrayType)
-
-addressByteSize :: Int
-addressByteSize = 4
-
-data Type
-    = PrimitiveType Text Int
-    | ArrayType Word32 Type
-    deriving Eq
-
-instance Show Type
-  where
-    show (PrimitiveType typeName _) = show typeName
-    show (ArrayType elementCount typeName) = showArrayType elementCount typeName
-
-intType :: Type
-intType = PrimitiveType "int" 4
-
-booleanType :: Type
-booleanType = PrimitiveType "boolean" 1

lib/Language/Elna/Glue.hs

@@ -1,312 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Glue
-    ( glue
-    ) where
-
-import Control.Monad.Trans.State (State, gets, modify', runState)
-import Data.Bifunctor (Bifunctor(..))
-import Data.Foldable (Foldable(..), traverse_)
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (catMaybes)
-import Data.Vector (Vector)
-import qualified Data.Text.Lazy.Builder.Int as Text.Builder
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import qualified Data.Text.Lazy as Text.Lazy
-import qualified Data.Vector as Vector
-import Data.Word (Word32)
-import qualified Language.Elna.Frontend.AST as AST
-import Language.Elna.Frontend.Types (Type(..))
-import Language.Elna.Backend.Intermediate
-    ( Label(..)
-    , Operand(..)
-    , Quadruple(..)
-    , Variable(..)
-    )
-import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
-import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
-import GHC.Records (HasField(..))
-import Language.Elna.Frontend.AST (Identifier(..))
-import Debug.Trace (traceShow)
-
-data Paste = Paste
-    { temporaryCounter :: Word32
-    , labelCounter :: Word32
-    , localMap :: HashMap Identifier Variable
-    }
-
-newtype Glue a = Glue
-    { runGlue :: State Paste a }
-
-instance Functor Glue
-  where
-    fmap f (Glue x) = Glue $ f <$> x
-
-instance Applicative Glue
-  where
-    pure = Glue . pure
-    (Glue f) <*> (Glue x) = Glue $ f <*> x
-
-instance Monad Glue
-  where
-    (Glue x) >>= f = Glue $ x >>= (runGlue . f)
-
-glue :: SymbolTable -> AST.Program -> HashMap Identifier (Vector (Quadruple Variable))
-glue globalTable
-    = fst
-    . flip runState emptyPaste
-    . runGlue
-    . program globalTable
-  where
-    emptyPaste = Paste
-        { temporaryCounter = 0
-        , labelCounter = 0
-        , localMap = mempty
-        }
-
-program :: SymbolTable -> AST.Program -> Glue (HashMap Identifier (Vector (Quadruple Variable)))
-program globalTable (AST.Program declarations)
-    = HashMap.fromList . catMaybes
-    <$> traverse (declaration globalTable) declarations
-
-declaration
-    :: SymbolTable
-    -> AST.Declaration
-    -> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
-declaration globalTable (AST.ProcedureDeclaration procedureName parameters variableDeclarations statements) =
-    let Just (ProcedureInfo localTable _) = SymbolTable.lookup procedureName globalTable
-     in Glue (modify' resetTemporaryCounter)
-        >> traverseWithIndex registerVariable variableDeclarations
-        >> traverseWithIndex registerParameter (reverse parameters)
-        >> nameQuadruplesTuple <$> traverse (statement localTable) statements
-  where
-    traverseWithIndex f = traverse_ (uncurry f) . zip [0..]
-    registerParameter index (AST.Parameter identifier _ _) =
-        Glue $ modify' $ modifier identifier $ ParameterVariable index
-    registerVariable index (AST.VariableDeclaration identifier _) =
-        Glue $ modify' $ modifier identifier $ LocalVariable index
-    modifier identifier currentCounter generator = generator
-        { localMap = HashMap.insert identifier currentCounter
-            $ getField @"localMap" generator
-        }
-    nameQuadruplesTuple quadrupleList = Just
-        ( procedureName
-        , Vector.cons StartQuadruple
-            $ flip Vector.snoc StopQuadruple
-            $ fold quadrupleList
-        )
-    resetTemporaryCounter paste = paste
-        { temporaryCounter = 0
-        , localMap = mempty
-        }
-declaration _ (AST.TypeDefinition _ _) = pure Nothing
-
-statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable))
-statement _ AST.EmptyStatement = pure mempty
-statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
-    visitedArguments <- traverse (expression localTable) arguments
-    let (parameterStatements, argumentStatements)
-            = bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
-            $ unzip visitedArguments
-     in pure
-        $ Vector.snoc (argumentStatements <> parameterStatements)
-        $ CallQuadruple callName
-        $ fromIntegral
-        $ length arguments
-statement localTable (AST.CompoundStatement statements) =
-    fold <$> traverse (statement localTable) statements
-statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
-    (conditionStatements, jumpConstructor) <- condition localTable ifCondition
-    ifLabel <- createLabel
-    endLabel <- createLabel
-    ifStatements <- statement localTable ifStatement
-    possibleElseStatements <- traverse (statement localTable) elseStatement
-    pure $ conditionStatements <> case possibleElseStatements of
-        Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
-            <> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
-            <> Vector.snoc ifStatements (LabelQuadruple endLabel)
-        Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
-            <> Vector.snoc ifStatements (LabelQuadruple endLabel)
-statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
-    (rhsOperand, rhsStatements) <- expression localTable assignee
-    let variableType' = variableType variableAccess' localTable
-    accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
-    lhsStatements <- case accessResult of
-            (identifier, Just accumulatedIndex, accumulatedStatements)
-                -> Vector.snoc accumulatedStatements
-                . ArrayAssignQuadruple rhsOperand accumulatedIndex
-                <$> lookupLocal identifier
-            (identifier, Nothing, accumulatedStatements)
-                -> Vector.snoc accumulatedStatements
-                . AssignQuadruple rhsOperand
-                <$> lookupLocal identifier
-    pure $ rhsStatements <> lhsStatements
-statement localTable (AST.WhileStatement whileCondition whileStatement) = do
-    (conditionStatements, jumpConstructor) <- condition localTable whileCondition
-    startLabel <- createLabel
-    endLabel <- createLabel
-    conditionLabel <- createLabel
-    whileStatements <- statement localTable whileStatement
-    pure $ Vector.fromList [LabelQuadruple conditionLabel]
-        <> conditionStatements
-        <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
-        <> whileStatements
-        <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
-
-createTemporary :: Glue Variable
-createTemporary = do
-    currentCounter <- Glue $ gets $ getField @"temporaryCounter"
-    Glue $ modify' modifier
-    pure $ TempVariable currentCounter
-  where
-    modifier generator = generator
-        { temporaryCounter = getField @"temporaryCounter" generator + 1
-        }
-
-lookupLocal :: Identifier -> Glue Variable
-lookupLocal identifier =
-    fmap (HashMap.! identifier) $ Glue $ gets $ getField @"localMap"
-
-createLabel :: Glue Label
-createLabel = do
-    currentCounter <- Glue $ gets $ getField @"labelCounter"
-    Glue $ modify' modifier
-    pure $ Label
-        $ Text.Lazy.toStrict
-        $ Text.Builder.toLazyText
-        $ ".L" <> Text.Builder.decimal currentCounter
-  where
-    modifier generator = generator
-        { labelCounter = getField @"labelCounter" generator + 1
-        }
-
-condition
-    :: SymbolTable
-    -> AST.Condition
-    -> Glue (Vector (Quadruple Variable), Label -> Quadruple Variable)
-condition localTable (AST.EqualCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure
-        ( lhsStatements <> rhsStatements
-        , EqualQuadruple lhsOperand rhsOperand
-        )
-condition localTable (AST.NonEqualCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure
-        ( lhsStatements <> rhsStatements
-        , NonEqualQuadruple lhsOperand rhsOperand
-        )
-condition localTable (AST.LessCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
-condition localTable (AST.GreaterCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure
-        ( lhsStatements <> rhsStatements
-        , GreaterQuadruple lhsOperand rhsOperand
-        )
-condition localTable (AST.LessOrEqualCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure
-        ( lhsStatements <> rhsStatements
-        , LessOrEqualQuadruple lhsOperand rhsOperand
-        )
-condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do
-    (lhsOperand, lhsStatements) <- expression localTable lhs
-    (rhsOperand, rhsStatements) <- expression localTable rhs
-    pure
-        ( lhsStatements <> rhsStatements
-        , GreaterOrEqualQuadruple lhsOperand rhsOperand
-        )
-
-variableAccess
-    :: SymbolTable
-    -> AST.VariableAccess
-    -> Maybe (Operand Variable)
-    -> Type
-    -> Vector (Quadruple Variable)
-    -> Glue (AST.Identifier, Maybe (Operand Variable), Vector (Quadruple Variable))
-variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
-    pure (identifier, accumulatedIndex, accumulatedStatements)
-variableAccess localTable accessKind accumulatedIndex arrayType statements
-    | (AST.ArrayAccess access1 index1) <- accessKind
-    , (ArrayType arraySize baseType) <- arrayType = do
-        (indexPlace, statements') <- expression localTable index1
-        case accumulatedIndex  of
-            Just baseIndex -> do
-                resultVariable <- createTemporary
-                let resultOperand = VariableOperand resultVariable
-                    indexCalculation = Vector.fromList
-                        [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
-                        , AddQuadruple indexPlace resultOperand resultVariable
-                        ]
-                 in variableAccess localTable access1 (Just resultOperand) baseType
-                    $ statements <> indexCalculation <> statements'
-            Nothing ->
-                variableAccess localTable access1 (Just indexPlace) baseType statements'
-variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
-
-variableType :: AST.VariableAccess -> SymbolTable -> Type
-variableType (AST.VariableAccess identifier) symbolTable
-    | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
-    | Just (VariableInfo _ type') <- SymbolTable.lookup identifier symbolTable = type'
-    | otherwise = traceShow identifier $ error "Undefined type."
-variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
-    variableType arrayAccess' symbolTable
-
-expression :: SymbolTable -> AST.Expression -> Glue (Operand Variable, Vector (Quadruple Variable))
-expression localTable = \case
-    (AST.LiteralExpression literal') -> pure (literal literal', mempty)
-    (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
-    (AST.SubtractionExpression lhs rhs) ->
-        binaryExpression SubtractionQuadruple lhs rhs
-    (AST.NegationExpression negation) -> do
-        (operand, statements) <- expression localTable negation
-        tempVariable <- createTemporary
-        let negationQuadruple = NegationQuadruple operand tempVariable
-        pure
-            ( VariableOperand tempVariable
-            , Vector.snoc statements negationQuadruple
-            )
-    (AST.ProductExpression lhs rhs) ->
-        binaryExpression ProductQuadruple lhs rhs
-    (AST.DivisionExpression lhs rhs) ->
-        binaryExpression DivisionQuadruple lhs rhs
-    (AST.VariableExpression variableExpression) -> do
-        let variableType' = variableType variableExpression localTable
-        variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
-        case variableAccess' of
-            (identifier, Nothing, statements)
-                -> (, statements) . VariableOperand 
-                <$> lookupLocal identifier
-            (identifier, Just operand, statements) -> do
-                arrayAddress <- createTemporary
-                localVariable <- lookupLocal identifier
-                let arrayStatement = ArrayQuadruple localVariable operand arrayAddress
-                pure
-                    ( VariableOperand arrayAddress
-                    , Vector.snoc statements arrayStatement
-                    )
-  where
-    binaryExpression f lhs rhs = do
-        (lhsOperand, lhsStatements) <- expression localTable lhs
-        (rhsOperand, rhsStatements) <- expression localTable rhs
-        tempVariable <- createTemporary
-        let newQuadruple = f lhsOperand rhsOperand tempVariable
-        pure
-            ( VariableOperand tempVariable
-            , Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
-            )
-
-literal :: AST.Literal -> Operand Variable
-literal (AST.DecimalLiteral integer) = IntOperand integer
-literal (AST.HexadecimalLiteral integer) = IntOperand integer
-literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character

lib/Language/Elna/Location.hs

@@ -1,62 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Location
-    ( Identifier(..)
-    , Location(..)
-    , Node(..)
-    , showArrayType
-    ) where
-
-import Data.Hashable (Hashable(..))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Word (Word32)
-
-data Location = Location
-    { line :: Word32
-    , column :: Word32
-    } deriving (Eq, Show)
-
-instance Semigroup Location
-  where
-    (Location thisLine thisColumn) <> (Location thatLine thatColumn) = Location
-        { line = thisLine + thatLine
-        , column = thisColumn + thatColumn
-        }
-
-instance Monoid Location
-  where
-   mempty = Location{ line = 1, column = 1 }
-
-data Node a = Node a Location
-    deriving (Eq, Show)
-
-instance Functor Node
-  where
-    fmap f (Node node location) = Node (f node) location
-
-newtype Identifier = Identifier { unIdentifier :: Text }
-    deriving Eq
-
-instance Show Identifier
-  where
-    show (Identifier identifier) = Text.unpack identifier
-
-instance IsString Identifier
-  where
-    fromString = Identifier . Text.pack
-
-instance Ord Identifier
-  where
-    compare (Identifier lhs) (Identifier rhs) = compare lhs rhs
-
-instance Hashable Identifier
-  where
-    hashWithSalt salt (Identifier identifier) = hashWithSalt salt identifier
-
-showArrayType :: (Show a, Show b) => a -> b -> String
-showArrayType elementCount typeName = concat
-    ["array[", show elementCount, "] of ", show typeName]

lib/Language/Elna/Object/Elf.hs

@@ -1,492 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Object.Elf
-    ( ByteOrder(..)
-    , Elf32_Addr
-    , Elf32_Off
-    , Elf32_Half
-    , Elf32_Word
-    , Elf32_Sword
-    , Elf32_Ehdr(..)
-    , Elf32_Rel(..)
-    , Elf32_Rela(..)
-    , Elf32_Shdr(..)
-    , Elf32_Sym(..)
-    , ElfEncodingError(..)
-    , ElfIdentification(..)
-    , ElfMachine(..)
-    , ElfVersion(..)
-    , ElfClass(..)
-    , ElfData(..)
-    , ElfType(..)
-    , ElfSectionType(..)
-    , ElfSymbolBinding(..)
-    , ElfSymbolType(..)
-    , byteOrder
-    , elf32Addr
-    , elf32Half
-    , elf32Off
-    , elf32Shdr
-    , elf32Sword
-    , elf32Word
-    , elf32Ehdr
-    , elf32Rel
-    , elf32Rela
-    , elf32Sym
-    , elfIdentification
-    , rInfo
-    , shfWrite
-    , shfAlloc
-    , shfExecinstr
-    , shfMascproc
-    , shfInfoLink
-    , stInfo
-    ) where
-
-import Control.Exception (Exception(..))
-import Data.Bits (Bits(..))
-import qualified Data.ByteString.Builder as ByteString.Builder
-import Data.Int (Int32)
-import Data.Word (Word8, Word16, Word32)
-import qualified Data.ByteString as ByteString
-
--- * Data types.
-
-type Elf32_Addr = Word32 -- ^ Unsigned program address.
-type Elf32_Half = Word16 -- ^ Unsigned medium integer.
-type Elf32_Off = Word32 -- ^ Unsigned file offset.
-type Elf32_Sword = Int32 -- ^ Signed large integer.
-type Elf32_Word = Word32 -- ^ Unsigned large integer.
-
-data ElfClass
-    = ELFCLASSNONE -- ^ Invalid class.
-    | ELFCLASS32 -- ^ 32-bit objects.
-    | ELFCLASS64 -- ^ 64-bit objects.
-    deriving Eq
-
-instance Show ElfClass
-  where
-    show ELFCLASSNONE = "ELFCLASSNONE"
-    show ELFCLASS32 = "ELFCLASS32"
-    show ELFCLASS64 = "ELFCLASS64"
-
-instance Enum ElfClass
-  where
-    toEnum 0 = ELFCLASSNONE
-    toEnum 1 = ELFCLASS32
-    toEnum 2 = ELFCLASS64
-    toEnum _ = error "Unknown Elf class"
-    fromEnum ELFCLASSNONE = 0
-    fromEnum ELFCLASS32 = 1
-    fromEnum ELFCLASS64 = 1
-
--- | Data encoding.
-data ElfData
-    = ELFDATANONE
-    | ELFDATA2LSB
-    | ELFDATA2MSB
-    deriving Eq
-
-instance Show ElfData
-  where
-    show ELFDATANONE = "ELFDATANONE"
-    show ELFDATA2LSB = "ELFDATA2LSB"
-    show ELFDATA2MSB = "ELFDATA2MSB"
-
-instance Enum ElfData
-  where
-    toEnum 0 = ELFDATANONE
-    toEnum 1 = ELFDATA2LSB
-    toEnum 2 = ELFDATA2MSB
-    toEnum _ = error "Unknown elf data"
-    fromEnum ELFDATANONE = 0
-    fromEnum ELFDATA2LSB = 1
-    fromEnum ELFDATA2MSB = 2
-
-data ElfIdentification = ElfIdentification ElfClass ElfData
-    deriving Eq
-
--- | ELF header.
-data Elf32_Ehdr = Elf32_Ehdr
-    { e_ident :: ElfIdentification
-    , e_type :: ElfType
-    , e_machine :: ElfMachine
-    , e_version :: ElfVersion
-    , e_entry :: Elf32_Addr
-    , e_phoff :: Elf32_Off
-    , e_shoff :: Elf32_Off
-    , e_flags :: Elf32_Word
-    , e_ehsize :: Elf32_Half
-    , e_phentsize :: Elf32_Half
-    , e_phnum :: Elf32_Half
-    , e_shentsize :: Elf32_Half
-    , e_shnum :: Elf32_Half
-    , e_shstrndx :: Elf32_Half
-    } deriving Eq
-
--- | Section header.
-data Elf32_Shdr = Elf32_Shdr
-    { sh_name :: Elf32_Word
-    , sh_type :: ElfSectionType
-    , sh_flags :: Elf32_Word
-    , sh_addr :: Elf32_Addr
-    , sh_offset :: Elf32_Off
-    , sh_size :: Elf32_Word
-    , sh_link :: Elf32_Word
-    , sh_info :: Elf32_Word
-    , sh_addralign :: Elf32_Word
-    , sh_entsize :: Elf32_Word
-    } deriving Eq
-
-data ElfMachine
-    = ElfMachine Elf32_Half
-    | EM_NONE -- ^ No machine.
-    | EM_M32 -- ^ AT&T WE 32100.
-    | EM_SPARC -- ^ SPARC.
-    | EM_386 -- ^ Intel Architecture.
-    | EM_68K -- ^ Motorola 68000.
-    | EM_88K -- ^ Motorola 88000.
-    | EM_860 -- ^ Intel 80860.
-    | EM_MIPS -- ^ MIPS RS3000 Big-Endian.
-    | EM_MIPS_RS4_BE -- ^ MIPS RS4000 Big-Endian.
-    | EM_RISCV -- ^ RISC-V.
-    deriving Eq
-
-instance Enum ElfMachine
-  where
-    toEnum 0x0 = EM_NONE
-    toEnum 0x1 = EM_M32
-    toEnum 0x2 = EM_SPARC
-    toEnum 0x3 = EM_386
-    toEnum 0x4 = EM_68K
-    toEnum 0x5 = EM_88K
-    toEnum 0x7 = EM_860
-    toEnum 0x8 = EM_MIPS
-    toEnum 0xa = EM_MIPS_RS4_BE
-    toEnum 0xf3 = EM_RISCV
-    toEnum x = ElfMachine $ fromIntegral x
-    fromEnum EM_NONE = 0x0
-    fromEnum EM_M32 = 0x1
-    fromEnum EM_SPARC = 0x2
-    fromEnum EM_386 = 0x3
-    fromEnum EM_68K = 0x4
-    fromEnum EM_88K = 0x5
-    fromEnum EM_860 = 0x7
-    fromEnum EM_MIPS = 0x8
-    fromEnum EM_MIPS_RS4_BE = 0xa
-    fromEnum EM_RISCV = 0xf3
-    fromEnum (ElfMachine x) = fromIntegral x
-
-data ElfVersion
-    = ElfVersion Elf32_Word
-    | EV_NONE -- ^ Invalid versionn.
-    | EV_CURRENT -- ^ Current version.
-    deriving Eq
-
-instance Enum ElfVersion
-  where
-    toEnum 0 = EV_NONE
-    toEnum 1 = EV_CURRENT
-    toEnum x = ElfVersion $ fromIntegral x
-    fromEnum EV_NONE = 0
-    fromEnum EV_CURRENT = 1
-    fromEnum (ElfVersion x) = fromIntegral x
-
-data ElfType
-    = ElfType Elf32_Half
-    | ET_NONE -- ^ No file type.
-    | ET_REL -- ^ Relocatable file.
-    | ET_EXEC -- ^ Executable file.
-    | ET_DYN -- ^ Shared object file.
-    | ET_CORE -- ^ Core file.
-    | ET_LOPROC -- ^ Processor-specific.
-    | ET_HIPROC -- ^ Processor-specific.
-    deriving Eq
-
-instance Enum ElfType
-  where
-    toEnum 0 = ET_NONE
-    toEnum 1 = ET_REL
-    toEnum 2 = ET_EXEC
-    toEnum 3 = ET_DYN
-    toEnum 4 = ET_CORE
-    toEnum 0xff00 = ET_LOPROC
-    toEnum 0xffff = ET_HIPROC
-    toEnum x = ElfType $ fromIntegral x
-    fromEnum ET_NONE = 0
-    fromEnum ET_REL = 1
-    fromEnum ET_EXEC = 2
-    fromEnum ET_DYN = 3
-    fromEnum ET_CORE = 4
-    fromEnum ET_LOPROC = 0xff00
-    fromEnum ET_HIPROC = 0xffff
-    fromEnum (ElfType x) = fromIntegral x
-
-data Elf32_Sym = Elf32_Sym
-    { st_name :: Elf32_Word
-    , st_value :: Elf32_Addr
-    , st_size :: Elf32_Word
-    , st_info :: Word8
-    , st_other :: Word8
-    , st_shndx :: Elf32_Half
-    } deriving Eq
-
-data ElfSymbolBinding
-    = ElfSymbolBinding Word8
-    | STB_LOCAL
-    | STB_GLOBAL
-    | STB_WEAK
-    | STB_LOPROC
-    | STB_HIPROC
-    deriving Eq
-
-instance Enum ElfSymbolBinding
-  where
-    toEnum 0 = STB_LOCAL
-    toEnum 1 = STB_GLOBAL
-    toEnum 2 = STB_WEAK
-    toEnum 13 = STB_LOPROC
-    toEnum 15 = STB_HIPROC
-    toEnum x = ElfSymbolBinding $ fromIntegral x
-    fromEnum STB_LOCAL = 0
-    fromEnum STB_GLOBAL = 1
-    fromEnum STB_WEAK = 2
-    fromEnum STB_LOPROC = 13
-    fromEnum STB_HIPROC = 15
-    fromEnum (ElfSymbolBinding x) = fromIntegral x
-
-data ElfSymbolType
-    = ElfSymbolType Word8
-    | STT_NOTYPE
-    | STT_OBJECT
-    | STT_FUNC
-    | STT_SECTION
-    | STT_FILE
-    | STT_LOPROC
-    | STT_HIPROC
-    deriving Eq
-
-instance Enum ElfSymbolType
-  where
-    toEnum 0 = STT_NOTYPE
-    toEnum 1 = STT_OBJECT
-    toEnum 2 = STT_FUNC
-    toEnum 3 = STT_SECTION
-    toEnum 4 = STT_FILE
-    toEnum 13 = STT_LOPROC
-    toEnum 15 = STT_HIPROC
-    toEnum x = ElfSymbolType $ fromIntegral x
-    fromEnum STT_NOTYPE = 0
-    fromEnum STT_OBJECT = 1
-    fromEnum STT_FUNC = 2
-    fromEnum STT_SECTION = 3
-    fromEnum STT_FILE = 4
-    fromEnum STT_LOPROC = 13
-    fromEnum STT_HIPROC = 15
-    fromEnum (ElfSymbolType x) = fromIntegral x
-
-data Elf32_Rel = Elf32_Rel
-    { r_offset :: Elf32_Addr
-    , r_info :: Elf32_Word
-    } deriving Eq
-
-data Elf32_Rela = Elf32_Rela
-    { r_offset :: Elf32_Addr
-    , r_info :: Elf32_Word
-    , r_addend :: Elf32_Sword
-    } deriving Eq
-
-data ElfSectionType
-    = ElfSectionType Elf32_Word
-    | SHT_NULL
-    | SHT_PROGBITS
-    | SHT_SYMTAB
-    | SHT_STRTAB
-    | SHT_RELA
-    | SHT_HASH
-    | SHT_DYNAMIC
-    | SHT_NOTE
-    | SHT_NOBITS
-    | SHT_REL
-    | SHT_SHLIB
-    | SHT_DYNSYM
-    | SHT_LOPROC
-    | SHT_HIPROC
-    | SHT_LOUSER
-    | SHT_HIUSER
-    deriving Eq
-
-instance Enum ElfSectionType
-  where
-    toEnum 0 = SHT_NULL
-    toEnum 1 = SHT_PROGBITS
-    toEnum 2 = SHT_SYMTAB
-    toEnum 3 = SHT_STRTAB
-    toEnum 4 = SHT_RELA
-    toEnum 5 = SHT_HASH
-    toEnum 6 = SHT_DYNAMIC
-    toEnum 7 = SHT_NOTE
-    toEnum 8 = SHT_NOBITS
-    toEnum 9 = SHT_REL
-    toEnum 10 = SHT_SHLIB
-    toEnum 11 = SHT_DYNSYM
-    toEnum 0x70000000 = SHT_LOPROC
-    toEnum 0x7fffffff = SHT_HIPROC
-    toEnum 0x80000000 = SHT_LOUSER
-    toEnum 0xffffffff = SHT_HIUSER
-    toEnum x = ElfSectionType $ fromIntegral x
-    fromEnum SHT_NULL = 0
-    fromEnum SHT_PROGBITS = 1
-    fromEnum SHT_SYMTAB = 2
-    fromEnum SHT_STRTAB = 3
-    fromEnum SHT_RELA = 4
-    fromEnum SHT_HASH = 5
-    fromEnum SHT_DYNAMIC = 6
-    fromEnum SHT_NOTE = 7
-    fromEnum SHT_NOBITS = 8
-    fromEnum SHT_REL = 9
-    fromEnum SHT_SHLIB = 10
-    fromEnum SHT_DYNSYM = 11
-    fromEnum SHT_LOPROC = 0x70000000
-    fromEnum SHT_HIPROC = 0x7fffffff
-    fromEnum SHT_LOUSER = 0x80000000
-    fromEnum SHT_HIUSER = 0xffffffff
-    fromEnum (ElfSectionType x) = fromIntegral x
-
--- * Constants.
-
-shfWrite :: Elf32_Word
-shfWrite = 0x1
-
-shfAlloc :: Elf32_Word
-shfAlloc = 0x2
-
-shfExecinstr:: Elf32_Word
-shfExecinstr = 0x4
-
-shfMascproc :: Elf32_Word
-shfMascproc = 0xf0000000
-
-shfInfoLink :: Elf32_Word
-shfInfoLink = 0x40
-
--- * Encoding functions.
-
-elf32Addr :: ByteOrder -> Elf32_Addr -> ByteString.Builder.Builder
-elf32Addr LSB = ByteString.Builder.word32LE
-elf32Addr MSB = ByteString.Builder.word32BE
-
-elf32Half :: ByteOrder -> Elf32_Half -> ByteString.Builder.Builder
-elf32Half LSB = ByteString.Builder.word16LE
-elf32Half MSB = ByteString.Builder.word16BE
-
-elf32Off :: ByteOrder -> Elf32_Off -> ByteString.Builder.Builder
-elf32Off LSB = ByteString.Builder.word32LE
-elf32Off MSB = ByteString.Builder.word32BE
-
-elf32Sword :: ByteOrder -> Elf32_Sword -> ByteString.Builder.Builder
-elf32Sword LSB = ByteString.Builder.int32LE
-elf32Sword MSB = ByteString.Builder.int32BE
-
-elf32Word :: ByteOrder -> Elf32_Word -> ByteString.Builder.Builder
-elf32Word LSB = ByteString.Builder.word32LE
-elf32Word MSB = ByteString.Builder.word32BE
-
-elfIdentification :: ElfIdentification -> ByteString.Builder.Builder
-elfIdentification (ElfIdentification elfClass elfData)
-    = ByteString.Builder.word8 0x7f
-    <> ByteString.Builder.string7 "ELF"
-    <> ByteString.Builder.word8 (fromIntegralEnum elfClass)
-    <> ByteString.Builder.word8 (fromIntegralEnum elfData)
-    <> ByteString.Builder.word8 (fromIntegralEnum EV_CURRENT)
-    <> ByteString.Builder.byteString (ByteString.replicate 9 0)
-
-elf32Ehdr :: Elf32_Ehdr -> Either ElfEncodingError ByteString.Builder.Builder
-elf32Ehdr Elf32_Ehdr{..} = encode <$> byteOrder e_ident
-  where
-    encode byteOrder'
-        = elfIdentification e_ident
-        <> elf32Half byteOrder' (fromIntegralEnum e_type)
-        <> elf32Half byteOrder' (fromIntegralEnum e_machine)
-        <> elf32Word byteOrder' (fromIntegralEnum e_version)
-        <> elf32Addr byteOrder' e_entry
-        <> elf32Off byteOrder' e_phoff
-        <> elf32Off byteOrder' e_shoff
-        <> elf32Word byteOrder' e_flags
-        <> elf32Half byteOrder' e_ehsize
-        <> elf32Half byteOrder' e_phentsize
-        <> elf32Half byteOrder' e_phnum
-        <> elf32Half byteOrder' e_shentsize
-        <> elf32Half byteOrder' e_shnum
-        <> elf32Half byteOrder' e_shstrndx
-
-byteOrder :: ElfIdentification -> Either ElfEncodingError ByteOrder
-byteOrder (ElfIdentification class' _)
-    | class' /= ELFCLASS32 = Left $ ElfUnsupportedClassError class'
-byteOrder (ElfIdentification _ ELFDATA2MSB) = Right MSB
-byteOrder (ElfIdentification _ ELFDATA2LSB) = Right LSB
-byteOrder (ElfIdentification _ ELFDATANONE) = Left ElfInvalidByteOrderError
-
-elf32Shdr :: ByteOrder -> Elf32_Shdr -> ByteString.Builder.Builder
-elf32Shdr byteOrder' Elf32_Shdr{..}
-    = elf32Word byteOrder' sh_name
-    <> elf32Word byteOrder' (fromIntegralEnum sh_type)
-    <> elf32Word byteOrder' sh_flags
-    <> elf32Addr byteOrder' sh_addr
-    <> elf32Off byteOrder' sh_offset
-    <> elf32Word byteOrder' sh_size
-    <> elf32Word byteOrder' sh_link
-    <> elf32Word byteOrder' sh_info
-    <> elf32Word byteOrder' sh_addralign
-    <> elf32Word byteOrder' sh_entsize
-
-elf32Sym :: ByteOrder -> Elf32_Sym -> ByteString.Builder.Builder
-elf32Sym byteOrder' Elf32_Sym{..}
-    = elf32Word byteOrder' st_name
-    <> elf32Addr byteOrder' st_value
-    <> elf32Word byteOrder' st_size
-    <> ByteString.Builder.word8 st_info
-    <> ByteString.Builder.word8 st_other
-    <> elf32Half byteOrder' st_shndx
-
-elf32Rel :: ByteOrder -> Elf32_Rel -> ByteString.Builder.Builder
-elf32Rel byteOrder' Elf32_Rel{..}
-    = elf32Addr byteOrder' r_offset
-    <> elf32Word byteOrder' r_info
-
-elf32Rela :: ByteOrder -> Elf32_Rela -> ByteString.Builder.Builder
-elf32Rela byteOrder' Elf32_Rela{..}
-    = elf32Addr byteOrder' r_offset
-    <> elf32Word byteOrder' r_info
-    <> elf32Sword byteOrder' r_addend
-
-stInfo :: ElfSymbolBinding -> ElfSymbolType -> Word8
-stInfo binding type' = fromIntegralEnum binding `shiftL` 4
-    .|. (fromIntegralEnum type' .&. 0xf)
-
-rInfo :: Elf32_Word -> Word8 -> Elf32_Word
-rInfo symbol type' = symbol `shiftL` 8
-    .|. fromIntegralEnum type'
-
--- * Help types and functions.
-
-data ByteOrder = LSB | MSB
-    deriving Eq
-
-data ElfEncodingError
-    = ElfInvalidByteOrderError
-    | ElfUnsupportedClassError ElfClass
-    deriving Eq
-
-instance Show ElfEncodingError
-  where
-    show ElfInvalidByteOrderError = "Invalid byte order."
-    show (ElfUnsupportedClassError class') =
-        concat ["Elf class \"", show class', "\" is not supported."]
-
-instance Exception ElfEncodingError
-
-fromIntegralEnum :: (Enum a, Num b) => a -> b
-fromIntegralEnum = fromIntegral . fromEnum

lib/Language/Elna/Object/ElfCoder.hs

@@ -1,148 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
--- | Object file generation.
-module Language.Elna.Object.ElfCoder
-    ( ElfEnvironment(..)
-    , ElfWriter(..)
-    , ElfHeaderResult(..)
-    , UnresolvedRelocation(..)
-    , UnresolvedRelocations(..)
-    , addHeaderToResult
-    , addSectionHeader
-    , elfHeaderSize
-    , elfObject
-    , elfSectionsSize
-    , putSectionHeader
-    , partitionSymbols
-    , module Language.Elna.Object.Elf
-    ) where
-
-import Control.Exception (throwIO)
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.State (StateT, runStateT, modify', gets)
-import Data.Bits (Bits(..))
-import Data.ByteString (StrictByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Builder as ByteString.Builder
-import Data.Word (Word8)
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import System.IO (Handle, IOMode(..), SeekMode(..), hSeek, withFile)
-import Data.Foldable (traverse_)
-import Language.Elna.Object.Elf
-import Language.Elna.Object.StringTable (StringTable)
-import qualified Language.Elna.Object.StringTable as StringTable
-import GHC.Records (HasField(..))
-
-data UnresolvedRelocation = UnresolvedRelocation StrictByteString Elf32_Addr Word8
-data UnresolvedRelocations =
-    UnresolvedRelocations (Vector UnresolvedRelocation) (ElfHeaderResult Elf32_Sym) Elf32_Word
-
-data ElfEnvironment = ElfEnvironment
-    { objectHeaders :: ElfHeaderResult Elf32_Shdr
-    , objectHandle :: Handle
-    }
-
-newtype ElfWriter a = ElfWriter
-    { runElfWriter :: StateT ElfEnvironment IO a
-    }
-
-data ElfHeaderResult a = ElfHeaderResult
-    { sectionNames :: StringTable
-    , sectionHeaders :: Vector a
-    } deriving Eq
-
-instance Functor ElfWriter
-  where
-    fmap f (ElfWriter x) = ElfWriter $ f <$> x
-
-instance Applicative ElfWriter
-  where
-    pure = ElfWriter . pure
-    (ElfWriter f) <*> (ElfWriter x) = ElfWriter $ f <*> x
-
-instance Monad ElfWriter
-  where
-    (ElfWriter x) >>= f = ElfWriter $ x >>= (runElfWriter . f)
-
-instance MonadIO ElfWriter
-  where
-    liftIO = ElfWriter . liftIO
-
-partitionSymbols :: ElfHeaderResult Elf32_Sym -> (Vector Elf32_Sym, Vector Elf32_Sym)
-partitionSymbols =  Vector.partition go . getField @"sectionHeaders"
-  where
-    go Elf32_Sym{ st_info } = (st_info .&. 0xf0) == 0
-
--- | ELF header size.
-elfHeaderSize :: Elf32_Off
-elfHeaderSize = 52
-
--- | Calculates the size of all sections based on the 'sh_size' in the given
--- headers and adds 'elfHeaderSize' to it.
-elfSectionsSize :: Vector Elf32_Shdr -> Elf32_Off
-elfSectionsSize = (elfHeaderSize +)
-    . Vector.foldr ((+) . sh_size) 0
-
-addHeaderToResult :: StrictByteString -> a -> ElfHeaderResult a -> ElfHeaderResult a
-addHeaderToResult name newHeader accumulator@ElfHeaderResult{..} = accumulator
-    { sectionHeaders = Vector.snoc sectionHeaders newHeader
-    , sectionNames = StringTable.append name sectionNames
-    }
-
-addSectionHeader :: StrictByteString -> Elf32_Shdr -> ElfWriter ()
-addSectionHeader name newHeader = ElfWriter $ modify' modifier
-  where
-    modifier elfEnvironment@ElfEnvironment{ objectHeaders } = elfEnvironment
-        { objectHeaders = addHeaderToResult name newHeader objectHeaders
-        }
-
-putSectionHeader :: StrictByteString -> Elf32_Shdr -> StrictByteString -> ElfWriter ()
-putSectionHeader name newHeader encoded = do
-    objectHandle' <- ElfWriter $ gets $ getField @"objectHandle"
-    liftIO $ ByteString.hPut objectHandle' encoded
-    addSectionHeader name newHeader
-
--- Writes an ELF object to the provided file path. The callback writes the
--- sections, collects headers for those sections and returns the ELF header.
-elfObject :: FilePath -> ElfWriter Elf32_Ehdr -> IO ()
-elfObject outFile putContents = withFile outFile WriteMode withObjectFile
-  where
-    withObjectFile objectHandle
-        = hSeek objectHandle AbsoluteSeek (fromIntegral elfHeaderSize)
-        >> putContents' objectHandle
-        >>= uncurry afterContents
-    putContents' objectHandle
-        = flip runStateT (initialState objectHandle)
-        $ runElfWriter putContents
-    zeroHeader = Elf32_Shdr
-        { sh_type = SHT_NULL
-        , sh_size = 0
-        , sh_offset = 0
-        , sh_name = 0
-        , sh_link = 0
-        , sh_info = 0
-        , sh_flags = 0
-        , sh_entsize = 0
-        , sh_addralign = 0
-        , sh_addr = 0
-        }
-    initialState objectHandle = ElfEnvironment
-        { objectHeaders = ElfHeaderResult
-            { sectionHeaders = Vector.singleton zeroHeader
-            , sectionNames = mempty
-            }
-        , objectHandle = objectHandle
-        }
-    afterContents header ElfEnvironment{ objectHeaders = ElfHeaderResult{..}, ..} =
-        let hPutBuilder = ByteString.Builder.hPutBuilder objectHandle
-            writeSectionHeaders byteOrder' =
-                traverse_ (hPutBuilder . elf32Shdr byteOrder') sectionHeaders
-         in either throwIO pure (byteOrder (e_ident header))
-            >>= writeSectionHeaders
-            >> either throwIO (putHeaders objectHandle) (elf32Ehdr header)
-    putHeaders objectHandle encodedHeader
-        = hSeek objectHandle AbsoluteSeek 0
-        >> ByteString.Builder.hPutBuilder objectHandle encodedHeader

lib/Language/Elna/Object/StringTable.hs

@@ -1,48 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.Object.StringTable
-    ( StringTable
-    , append
-    , elem
-    , index
-    , encode
-    , size
-    ) where
-
-import Data.ByteString (StrictByteString)
-import qualified Data.ByteString as ByteString
-import Language.Elna.Object.Elf
-import Prelude hiding (elem)
-
-newtype StringTable = StringTable StrictByteString
-    deriving Eq
-
-instance Semigroup StringTable
-  where
-    (StringTable x) <> (StringTable y) = StringTable $ x <> ByteString.drop 1 y
-
-instance Monoid StringTable
-  where
-    mempty = StringTable "\0"
-
-size :: StringTable -> Elf32_Word
-size (StringTable container) =
-    fromIntegral $ ByteString.length container
-
-elem :: StrictByteString -> StringTable -> Bool
-elem needle (StringTable container) =
-    ("\0" <> needle <> "\0") `ByteString.isInfixOf` container
-
-append :: StrictByteString -> StringTable -> StringTable
-append element (StringTable container) =
-    StringTable $ container <> element <> "\0"
-
-index :: Elf32_Word -> StringTable -> StrictByteString
-index stringTableIndex (StringTable stringTable)
-    = ByteString.takeWhile (/= 0)
-    $ ByteString.drop (fromIntegral stringTableIndex) stringTable
-
-encode :: StringTable -> StrictByteString
-encode (StringTable container) = container

lib/Language/Elna/RiscV/CodeGenerator.hs

@@ -1,519 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.RiscV.CodeGenerator
-    ( Directive(..)
-    , Statement(..)
-    , generateRiscV
-    , riscVConfiguration
-    ) where
-
-import Control.Monad.Trans.State (State, get, evalState, modify')
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Int (Int32)
-import Data.Word (Word32)
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import qualified Language.Elna.Architecture.RiscV as RiscV
-import Language.Elna.Backend.Allocator (MachineConfiguration(..), Store(..))
-import Language.Elna.Backend.Intermediate
-    ( Label(..)
-    , Operand(..)
-    , ProcedureQuadruples(..)
-    , Quadruple(..)
-    )
-import Language.Elna.Location (Identifier(..))
-import Data.Bits (Bits(..))
-import Data.Foldable (Foldable(..), foldlM)
-import Data.Text (Text)
-import qualified Data.Text.Lazy.Builder.Int as Text.Builder
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import qualified Data.Text.Lazy as Text.Lazy
-
-data Directive
-    = GlobalDirective
-    | FunctionDirective
-    deriving (Eq, Show)
-
-data Statement
-    = Instruction RiscV.Instruction
-    | JumpLabel Text [Directive]
-    deriving Eq
-
-riscVConfiguration :: MachineConfiguration RiscV.XRegister
-riscVConfiguration = MachineConfiguration
-    { temporaryRegisters =
-        [ RiscV.T0
-        , RiscV.T1
-        , RiscV.T2
-        , RiscV.T3
-        , RiscV.T4
-        , RiscV.T5
-        , RiscV.T6
-        ]
-    }
-
--- | Reserved register used for calculations to save an immediate temporary.
-immediateRegister :: RiscV.XRegister
-immediateRegister = RiscV.A7
-
-type RiscVStore = Store RiscV.XRegister
-type RiscVQuadruple = Quadruple RiscVStore
-type RiscVOperand = Operand RiscVStore
-
-newtype RiscVGenerator a = RiscVGenerator
-    { runRiscVGenerator :: State Word32 a }
-
-instance Functor RiscVGenerator
-  where
-    fmap f (RiscVGenerator x) = RiscVGenerator $ f <$> x
-
-instance Applicative RiscVGenerator
-  where
-    pure = RiscVGenerator . pure
-    (RiscVGenerator f) <*> (RiscVGenerator x) = RiscVGenerator $ f <*> x
-
-instance Monad RiscVGenerator
-  where
-    (RiscVGenerator x) >>= f = RiscVGenerator $ x >>= (runRiscVGenerator . f)
-
-createLabel :: RiscVGenerator Text
-createLabel = do
-    currentCounter <- RiscVGenerator get
-    RiscVGenerator $ modify' (+ 1)
-    pure
-        $ mappend ".A"
-        $ Text.Lazy.toStrict
-        $ Text.Builder.toLazyText
-        $ Text.Builder.decimal currentCounter
-
-generateRiscV :: HashMap Identifier (ProcedureQuadruples RiscVStore) -> Vector Statement
-generateRiscV = flip evalState 0
-    . runRiscVGenerator
-    . foldlM go Vector.empty
-    . HashMap.toList
-  where
-    go accumulator (Identifier key, ProcedureQuadruples{ stackSize, quadruples = value }) =
-        let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
-                . fold <$> mapM (quadruple stackSize) value
-         in (accumulator <>) <$> code
-
-quadruple :: Word32 -> RiscVQuadruple -> RiscVGenerator (Vector Statement)
-quadruple stackSize StartQuadruple =
-    let totalStackSize = stackSize + 8
-     in pure $ Vector.fromList
-        [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate totalStackSize))
-        , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0)
-        , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA)
-        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP totalStackSize)
-        ]
-quadruple stackSize StopQuadruple =
-    let totalStackSize = stackSize + 8
-     in pure $ Vector.fromList
-        [ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0)
-        , Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4)
-        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP totalStackSize)
-        , Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0)
-        ]
-quadruple _ (ParameterQuadruple operand1) =
-    let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
-     in pure $ mappend statements $ Vector.fromList
-        [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
-        , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister)
-        ]
-quadruple _ (CallQuadruple callName numberOfArguments) =
-    let restoreStackSize = numberOfArguments * 4
-     in pure $ Vector.fromList
-        [ Instruction (RiscV.CallInstruction callName)
-        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP restoreStackSize)
-        ]
-quadruple _ (AddQuadruple operand1 operand2 store) =
-    commutativeBinary (+) RiscV.ADD (RiscV.Funct7 0b0000000) (operand1, operand2) store
-quadruple _ (ProductQuadruple operand1 operand2 store) =
-    commutativeBinary (*) RiscV.MUL (RiscV.Funct7 0b0000001) (operand1, operand2) store
-quadruple _ (SubtractionQuadruple operand1 operand2 store)
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-         in pure $ lui (immediateOperand1 - immediateOperand2) storeRegister <> storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.SUB operandRegister1 operandRegister2
-                $ RiscV.Funct7 0b0100000
-        in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-            statements1 = lui immediateOperand1 storeRegister
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.SUB storeRegister operandRegister2
-                $ RiscV.Funct7 0b0100000
-         in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-            statements2 = lui (negate immediateOperand2) storeRegister
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.ADD storeRegister operandRegister1
-                $ RiscV.Funct7 0b0000000
-         in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
-quadruple _ (NegationQuadruple operand1 store)
-    | IntOperand immediateOperand1 <- operand1 =
-        let (storeRegister, storeStatements) = storeToStore store
-         in pure $ lui (negate immediateOperand1) storeRegister <> storeStatements
-    | VariableOperand variableOperand1 <- operand1 =
-        let (storeRegister, storeStatements) = storeToStore store
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.SUB RiscV.Zero operandRegister1
-                $ RiscV.Funct7 0b0100000
-         in pure $ statements1 <> Vector.cons instruction storeStatements
-quadruple _ (DivisionQuadruple operand1 operand2 store)
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        if immediateOperand2 == 0
-        then pure $ Vector.singleton
-            $ Instruction (RiscV.CallInstruction "_divide_by_zero_error")
-        else
-            let (storeRegister, storeStatements) = storeToStore store
-            in pure $ lui (quot immediateOperand1 immediateOperand2) storeRegister <> storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 = do
-        let (storeRegister, storeStatements) = storeToStore store
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            divisionInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.DIV operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
-        branchLabel <- createLabel
-        let branchInstruction = Instruction
-                $ RiscV.RelocatableInstruction RiscV.Branch
-                $ RiscV.RBranch branchLabel RiscV.BNE RiscV.Zero operandRegister2
-        pure $ statements1 <> statements2 <> Vector.fromList
-            [ branchInstruction
-            , Instruction (RiscV.CallInstruction "_divide_by_zero_error")
-            , JumpLabel branchLabel []
-            , divisionInstruction
-            ] <> storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-            statements2 = lui immediateOperand2 storeRegister
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            operationInstruction
-                | immediateOperand2 == 0 =
-                    RiscV.CallInstruction "_divide_by_zero_error"
-                | otherwise = RiscV.BaseInstruction RiscV.Op
-                    $ RiscV.R storeRegister RiscV.DIV operandRegister1 storeRegister
-                    $ RiscV.Funct7 0b0000001
-         in pure $ statements1 <> statements2
-            <> Vector.cons (Instruction operationInstruction) storeStatements
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 = do
-        let (storeRegister, storeStatements) = storeToStore store
-            statements1 = lui immediateOperand1 storeRegister
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            divisionInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister RiscV.DIV storeRegister operandRegister2 (RiscV.Funct7 0b0000001)
-        branchLabel <- createLabel
-        let branchInstruction = Instruction
-                $ RiscV.RelocatableInstruction RiscV.Branch
-                $ RiscV.RBranch branchLabel RiscV.BNE RiscV.Zero operandRegister2
-        pure $ statements1 <> statements2 <> Vector.fromList 
-            [ branchInstruction
-            , Instruction (RiscV.CallInstruction "_divide_by_zero_error")
-            , JumpLabel branchLabel []
-            , divisionInstruction
-            ] <> storeStatements
-quadruple _ (LabelQuadruple (Label label)) = pure $ Vector.singleton $ JumpLabel label mempty
-quadruple _ (GoToQuadruple label) = pure $ Vector.singleton $ unconditionalJal label
-quadruple _ (EqualQuadruple operand1 operand2 goToLabel) =
-    commutativeComparison (==) RiscV.BEQ (operand1, operand2) goToLabel
-quadruple _ (NonEqualQuadruple operand1 operand2 goToLabel) =
-    commutativeComparison (/=) RiscV.BNE (operand1, operand2) goToLabel
-quadruple _ (LessQuadruple operand1 operand2 goToLabel) =
-    lessThan (operand1, operand2) goToLabel
-quadruple _ (GreaterQuadruple operand1 operand2 goToLabel) =
-    lessThan (operand2, operand1) goToLabel
-quadruple _ (LessOrEqualQuadruple operand1 operand2 goToLabel) =
-    lessOrEqualThan (operand1, operand2) goToLabel
-quadruple _ (GreaterOrEqualQuadruple operand1 operand2 goToLabel) =
-    lessOrEqualThan (operand2, operand1) goToLabel
-quadruple _ (AssignQuadruple operand1 store)
-    | IntOperand immediateOperand1 <- operand1 =
-        let (storeRegister, storeStatements) = storeToStore store
-         in pure $ lui immediateOperand1 storeRegister <> storeStatements
-    | VariableOperand variableOperand1 <- operand1 =
-        let (operandRegister1, statements1) = loadFromStore variableOperand1
-            (storeRegister, storeStatements) = storeToStore store
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.OpImm
-                $ RiscV.I storeRegister RiscV.ADDI operandRegister1 0
-         in pure $ statements1 <> Vector.cons instruction storeStatements 
-quadruple _ (ArrayAssignQuadruple assigneeOperand indexOperand store)
-    | IntOperand immediateAssigneeOperand <- assigneeOperand =
-        let (storeRegister, storeStatements) = storeWithOffset store indexOperand
-         in pure $ lui immediateAssigneeOperand storeRegister <> storeStatements
-    | VariableOperand variableAssigneeOperand <- assigneeOperand =
-        let (assigneeOperandRegister, assigneeStatements) = loadFromStore variableAssigneeOperand
-            (storeRegister, storeStatements) = storeWithOffset store indexOperand
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.OpImm
-                $ RiscV.I storeRegister RiscV.ADDI assigneeOperandRegister 0
-         in pure $ assigneeStatements <> Vector.cons instruction storeStatements 
-  where
-    storeWithOffset :: RiscVStore -> Operand RiscVStore -> (RiscV.XRegister, Vector Statement)
-    storeWithOffset (RegisterStore register) _ = (register, mempty)
-    storeWithOffset (StackStore offset register) (IntOperand indexOffset) =
-        let storeInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Store
-                $ RiscV.S (fromIntegral $ offset + indexOffset * 4) RiscV.SW RiscV.S0 register
-         in (register, Vector.singleton storeInstruction)
-    storeWithOffset (StackStore offset register) (VariableOperand indexOffset) =
-        let storeInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Store
-                $ RiscV.S (fromIntegral offset) RiscV.SW immediateRegister register
-            statements = calculateIndexOffset indexOffset
-         in (register, Vector.snoc statements storeInstruction)
-quadruple _ (ArrayQuadruple assigneeVariable indexOperand store) =
-    let (operandRegister1, statements1) = loadWithOffset assigneeVariable indexOperand
-        (storeRegister, storeStatements) = storeToStore store
-        instruction = Instruction
-            $ RiscV.BaseInstruction RiscV.OpImm
-            $ RiscV.I storeRegister RiscV.ADDI operandRegister1 0
-     in pure $ statements1 <> Vector.cons instruction storeStatements 
-  where
-    loadWithOffset :: RiscVStore -> Operand RiscVStore -> (RiscV.XRegister, Vector Statement)
-    loadWithOffset (RegisterStore register) _ = (register, mempty)
-    loadWithOffset (StackStore offset register) (IntOperand indexOffset) =
-        let loadInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Load
-                $ RiscV.I register RiscV.LW RiscV.S0 (fromIntegral $ offset + indexOffset * 4)
-         in (register, Vector.singleton loadInstruction)
-    loadWithOffset (StackStore offset register) (VariableOperand indexOffset) =
-        let loadInstruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Load
-                $ RiscV.I register RiscV.SW immediateRegister (fromIntegral offset)
-            statements = calculateIndexOffset indexOffset
-         in (register, Vector.snoc statements loadInstruction)
-
-calculateIndexOffset :: RiscVStore -> Vector Statement
-calculateIndexOffset indexOffset =
-    let (indexRegister, indexStatements) = loadFromStore indexOffset
-        baseRegisterInstruction = Instruction
-            $ RiscV.BaseInstruction RiscV.OpImm
-            $ RiscV.I immediateRegister RiscV.ADDI RiscV.Zero 4
-        indexRelativeOffset = Instruction
-            $ RiscV.BaseInstruction RiscV.Op
-            $ RiscV.R immediateRegister RiscV.MUL immediateRegister indexRegister (RiscV.Funct7 0b0000001)
-        registerWithOffset = Instruction
-            $ RiscV.BaseInstruction RiscV.Op
-            $ RiscV.R immediateRegister RiscV.ADD immediateRegister RiscV.S0 (RiscV.Funct7 0b0000000)
-        statements = Vector.fromList
-            [ baseRegisterInstruction
-            , indexRelativeOffset
-            , registerWithOffset
-            ]
-     in indexStatements <> statements
-
-unconditionalJal :: Label -> Statement
-unconditionalJal (Label goToLabel) = Instruction
-    $ RiscV.RelocatableInstruction RiscV.Jal
-    $ RiscV.RJal RiscV.Zero goToLabel
-
-loadImmediateOrRegister :: RiscVOperand -> RiscV.XRegister -> (RiscV.XRegister, Vector Statement)
-loadImmediateOrRegister (IntOperand intValue) targetRegister =
-    (targetRegister, lui intValue targetRegister)
-loadImmediateOrRegister (VariableOperand store) _ = loadFromStore store
-
-lui :: Int32 -> RiscV.XRegister -> Vector Statement
-lui intValue targetRegister
-    | intValue >= -2048
-    , intValue <= 2047 = Vector.singleton
-        $ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI RiscV.Zero lo)
-    | intValue .&. 0x800 /= 0 = Vector.fromList
-        [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral $ succ hi)
-        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
-        ]
-    | otherwise = Vector.fromList
-        [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral hi)
-        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
-        ]
-  where
-    hi = intValue `shiftR` 12
-    lo = fromIntegral intValue
-
-commutativeBinary
-    :: (Int32 -> Int32 -> Int32)
-    -> RiscV.Funct3
-    -> RiscV.Funct7
-    -> (Operand RiscVStore, Operand RiscVStore)
-    -> Store RiscV.XRegister
-    -> RiscVGenerator (Vector Statement)
-commutativeBinary immediateOperation funct3 funct7 (operand1, operand2) store
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let (storeRegister, storeStatements) = storeToStore store
-            immediateOperation' = immediateOperation immediateOperand1 immediateOperand2
-         in pure $ lui immediateOperation' storeRegister <> storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        let (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            (storeRegister, storeStatements) = storeToStore store
-            instruction = Instruction $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister funct3 operandRegister1 operandRegister2 funct7
-         in pure $ statements1 <> statements2
-            <> Vector.cons instruction storeStatements
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        commutativeImmediateRegister variableOperand1 immediateOperand2
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        commutativeImmediateRegister variableOperand2 immediateOperand1
-  where
-    commutativeImmediateRegister variableOperand immediateOperand = 
-        let (storeRegister, storeStatements) = storeToStore store
-            immediateStatements = lui immediateOperand storeRegister
-            (operandRegister, registerStatements) = loadFromStore variableOperand
-            instruction = Instruction
-                $ RiscV.BaseInstruction RiscV.Op
-                $ RiscV.R storeRegister funct3 storeRegister operandRegister funct7
-        in pure $ immediateStatements <> registerStatements
-            <> Vector.cons instruction storeStatements
-
-commutativeComparison
-    :: (Int32 -> Int32 -> Bool)
-    -> RiscV.Funct3
-    -> (Operand RiscVStore, Operand RiscVStore)
-    -> Label
-    -> RiscVGenerator (Vector Statement)
-commutativeComparison immediateOperation funct3 (operand1, operand2) goToLabel
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        if immediateOperation immediateOperand1 immediateOperand2
-        then pure $ Vector.singleton $ unconditionalJal goToLabel
-        else pure Vector.empty
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 = do
-        let (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            Label goToLabel' = goToLabel
-        pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' funct3 operandRegister1 operandRegister2
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        compareImmediateRegister variableOperand1 immediateOperand2
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        compareImmediateRegister variableOperand2 immediateOperand1
-  where
-    compareImmediateRegister variableOperand immediateOperand = 
-        let immediateStatements = lui immediateOperand immediateRegister
-            (operandRegister, registerStatements) = loadFromStore variableOperand
-            Label goToLabel' = goToLabel
-        in pure $ Vector.snoc (immediateStatements <> registerStatements)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' funct3 operandRegister immediateRegister
-
-lessThan :: (Operand RiscVStore, Operand RiscVStore) -> Label -> RiscVGenerator (Vector Statement)
-lessThan (operand1, operand2) goToLabel
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        if immediateOperand1 < immediateOperand2
-        then pure $ Vector.singleton $ unconditionalJal goToLabel
-        else pure Vector.empty
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 = do
-        let (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            Label goToLabel' = goToLabel
-        pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BLT operandRegister1 operandRegister2
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let statements2 = lui immediateOperand2 immediateRegister
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            Label goToLabel' = goToLabel
-        in pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BLT operandRegister1 immediateRegister
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        let statements1 = lui immediateOperand1 immediateRegister
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            Label goToLabel' = goToLabel
-        in pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BLT immediateRegister operandRegister2
-
-lessOrEqualThan :: (Operand RiscVStore, Operand RiscVStore) -> Label -> RiscVGenerator (Vector Statement)
-lessOrEqualThan (operand1, operand2) goToLabel
-    | IntOperand immediateOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        if immediateOperand1 <= immediateOperand2
-        then pure $ Vector.singleton $ unconditionalJal goToLabel
-        else pure Vector.empty
-    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 = do
-        let (operandRegister1, statements1) = loadFromStore variableOperand1
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            Label goToLabel' = goToLabel
-        pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BGE operandRegister2 operandRegister1
-    | VariableOperand variableOperand1 <- operand1
-    , IntOperand immediateOperand2 <- operand2 =
-        let statements2 = lui immediateOperand2 immediateRegister
-            (operandRegister1, statements1) = loadFromStore variableOperand1
-            Label goToLabel' = goToLabel
-        in pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BGE immediateRegister operandRegister1
-    | IntOperand immediateOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
-        let statements1 = lui immediateOperand1 immediateRegister
-            (operandRegister2, statements2) = loadFromStore variableOperand2
-            Label goToLabel' = goToLabel
-        in pure $ Vector.snoc (statements1 <> statements2)
-            $ Instruction
-            $ RiscV.RelocatableInstruction RiscV.Branch
-            $ RiscV.RBranch goToLabel' RiscV.BGE operandRegister2 immediateRegister
-
-loadFromStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
-loadFromStore (RegisterStore register) = (register, mempty)
-loadFromStore (StackStore offset register) =
-    let loadInstruction = Instruction
-            $ RiscV.BaseInstruction RiscV.Load
-            $ RiscV.I register RiscV.LW RiscV.S0 (fromIntegral offset)
-     in (register, Vector.singleton loadInstruction)
-
-storeToStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
-storeToStore (RegisterStore register) = (register, mempty)
-storeToStore (StackStore offset register) =
-    let storeInstruction = Instruction
-            $ RiscV.BaseInstruction RiscV.Store
-            $ RiscV.S (fromIntegral offset) RiscV.SW RiscV.S0 register
-     in (register, Vector.singleton storeInstruction)

lib/Language/Elna/RiscV/ElfWriter.hs

@@ -1,338 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
--- | Writer assembler to an object file.
-module Language.Elna.RiscV.ElfWriter
-    ( riscv32Elf
-    ) where
-
-import Data.ByteString (StrictByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Builder as ByteString.Builder
-import Data.ByteString.Lazy (LazyByteString)
-import qualified Data.ByteString.Lazy as LazyByteString
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import Language.Elna.Object.ElfCoder
-    ( ByteOrder(..)
-    , Elf32_Ehdr(..)
-    , Elf32_Half
-    , Elf32_Word
-    , Elf32_Sym(..)
-    , ElfMachine(..)
-    , ElfType(..)
-    , ElfVersion(..)
-    , ElfIdentification(..)
-    , ElfClass(..)
-    , ElfData(..)
-    , Elf32_Shdr(..)
-    , ElfSectionType(..)
-    , ElfSymbolBinding(..)
-    , ElfSymbolType(..)
-    , Elf32_Rel(..)
-    , ElfWriter(..)
-    , ElfHeaderResult(..)
-    , ElfEnvironment(..)
-    , UnresolvedRelocation(..)
-    , UnresolvedRelocations(..)
-    , addHeaderToResult
-    , addSectionHeader
-    , elf32Sym
-    , elfHeaderSize
-    , elfSectionsSize
-    , stInfo
-    , rInfo
-    , elf32Rel
-    , shfInfoLink
-    , partitionSymbols
-    , putSectionHeader
-    )
-import qualified Language.Elna.Architecture.RiscV as RiscV
-import qualified Data.Text.Encoding as Text
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.State (get, gets)
-import Language.Elna.RiscV.CodeGenerator (Directive(..), Statement(..))
-import Language.Elna.Object.StringTable (StringTable)
-import qualified Language.Elna.Object.StringTable as StringTable
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HashSet
-import GHC.Records (HasField(..))
-
-data TextAccumulator = TextAccumulator
-    { encodedAccumulator :: LazyByteString
-    , relocationAccumulator :: Vector UnresolvedRelocation
-    , symbolAccumulator :: ElfHeaderResult Elf32_Sym
-    , definitionAccumulator :: HashSet StrictByteString
-    }
-
-riscv32Elf :: Vector Statement -> ElfWriter Elf32_Ehdr
-riscv32Elf code = text code
-    >>= symtab
-    >>= uncurry symrel
-    >>= strtab
-    >> shstrtab
-    >>= riscv32Header
-  where
-    riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr
-    riscv32Header shstrndx = do
-        ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-        pure $ Elf32_Ehdr
-            { e_version = EV_CURRENT
-            , e_type = ET_REL
-            , e_shstrndx = shstrndx
-            , e_shoff = elfSectionsSize sectionHeaders
-            , e_shnum = fromIntegral (Vector.length sectionHeaders)
-            , e_shentsize = 40
-            , e_phoff = 0
-            , e_phnum = 0
-            , e_phentsize = 32
-            , e_machine = EM_RISCV
-            , e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB
-            , e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE
-            , e_entry = 0
-            , e_ehsize = fromIntegral elfHeaderSize
-            }
-
-text :: Vector Statement -> ElfWriter UnresolvedRelocations
-text code = do
-    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-    let textTabIndex = fromIntegral $ Vector.length sectionHeaders
-        initialHeaders = ElfHeaderResult mempty
-            $ Vector.singleton
-            $ Elf32_Sym
-                { st_value = 0
-                , st_size = 0
-                , st_shndx = 0
-                , st_other = 0
-                , st_name = 0
-                , st_info = 0
-                }
-        TextAccumulator{..} = encodeFunctions textTabIndex code
-            $ TextAccumulator
-                { encodedAccumulator = mempty 
-                , relocationAccumulator = Vector.empty
-                , symbolAccumulator = initialHeaders
-                , definitionAccumulator = HashSet.empty
-                }
-        size = fromIntegral $ LazyByteString.length encodedAccumulator
-        newHeader = Elf32_Shdr
-            { sh_type = SHT_PROGBITS
-            , sh_size = size
-            , sh_offset = elfSectionsSize sectionHeaders
-            , sh_name = StringTable.size sectionNames
-            , sh_link = 0
-            , sh_info = 0
-            , sh_flags = 0b110
-            , sh_entsize = 0
-            , sh_addralign = 4
-            , sh_addr = 0
-            }
-    putSectionHeader ".text" newHeader $ LazyByteString.toStrict encodedAccumulator
-    let filterPredicate :: StrictByteString -> Bool
-        filterPredicate = not
-            . (`StringTable.elem` getField @"sectionNames" symbolAccumulator)
-        symbolResult = HashSet.foldl' encodeEmptyDefinitions symbolAccumulator
-            $ HashSet.filter filterPredicate definitionAccumulator
-    pure $ UnresolvedRelocations relocationAccumulator symbolResult
-        $ fromIntegral $ Vector.length sectionHeaders
-  where
-    encodeEmptyDefinitions (ElfHeaderResult names entries) definition =
-        let nextEntry = Elf32_Sym
-                { st_value = 0
-                , st_size = 0
-                , st_shndx = 0
-                , st_other = 0
-                , st_name = StringTable.size names
-                , st_info = stInfo STB_GLOBAL STT_FUNC
-                }
-         in ElfHeaderResult (StringTable.append definition names)
-            $ Vector.snoc entries nextEntry
-    encodeFunctions shndx instructions textAccumulator
-        | Just (instruction, rest) <- Vector.uncons instructions =
-            case instruction of
-                Instruction _ ->
-                    let (textAccumulator', rest') = encodeInstructions shndx (textAccumulator, instructions)
-                     in encodeFunctions shndx rest' textAccumulator'
-                JumpLabel labelName directives ->
-                    let (TextAccumulator{..}, rest') =
-                            encodeInstructions shndx (textAccumulator, rest)
-                        newEntry = Elf32_Sym
-                            { st_value = fromIntegral
-                                $ LazyByteString.length
-                                $ getField @"encodedAccumulator" textAccumulator
-                            , st_size = fromIntegral $ LazyByteString.length encodedAccumulator
-                            , st_shndx = shndx
-                            , st_other = 0
-                            , st_name = StringTable.size $ getField @"sectionNames" symbolAccumulator
-                            , st_info = stInfo (directivesBinding directives) STT_FUNC
-                            }
-                     in encodeFunctions shndx rest'
-                        $ TextAccumulator
-                            { encodedAccumulator = encodedAccumulator
-                            , relocationAccumulator = relocationAccumulator
-                            , symbolAccumulator =
-                                addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolAccumulator
-                            , definitionAccumulator = definitionAccumulator
-                            }
-        | otherwise = textAccumulator
-    directivesBinding directives
-        | GlobalDirective `elem` directives = STB_GLOBAL
-        | otherwise = STB_LOCAL
-    encodeInstructions shndx (TextAccumulator encoded relocations symbolResult definitions, instructions)
-        | Just (Instruction instruction, rest) <- Vector.uncons instructions =
-            let offset = fromIntegral $ LazyByteString.length encoded
-                unresolvedRelocation = case instruction of
-                    RiscV.RelocatableInstruction _ instructionType
-                        | RiscV.RHigher20 _ symbolName <- instructionType
-                            -> Just -- R_RISCV_HI20
-                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 26
-                        | RiscV.RLower12I _ _ _ symbolName <- instructionType
-                            -> Just -- R_RISCV_LO12_I
-                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 27
-                        | RiscV.RLower12S symbolName _ _ _ <- instructionType
-                            -> Just -- R_RISCV_LO12_S
-                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 28
-                        | RiscV.RBranch symbolName _ _ _ <- instructionType
-                            -> Just -- R_RISCV_BRANCH
-                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 16
-                        | RiscV.RJal _ symbolName <- instructionType
-                            -> Just -- R_RISCV_JAL
-                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 17
-                    RiscV.CallInstruction symbolName
-                        -> Just -- R_RISCV_CALL_PLT
-                        $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 19
-                    RiscV.BaseInstruction _ _ -> Nothing
-                chunk = ByteString.Builder.toLazyByteString
-                    $ RiscV.instruction instruction
-                result = TextAccumulator
-                    (encoded <> chunk)
-                    (maybe relocations (Vector.snoc relocations) unresolvedRelocation)
-                    symbolResult
-                    (addDefinition unresolvedRelocation definitions)
-             in encodeInstructions shndx (result, rest)
-        | Just (JumpLabel labelName directives , rest) <- Vector.uncons instructions
-        , FunctionDirective `notElem` directives =
-            let newEntry = Elf32_Sym
-                    { st_value = fromIntegral $ LazyByteString.length encoded
-                    , st_size = 0
-                    , st_shndx = shndx
-                    , st_other = 0
-                    , st_name = StringTable.size $ getField @"sectionNames" symbolResult
-                    , st_info = stInfo (directivesBinding directives) STT_NOTYPE
-                    }
-                result = TextAccumulator
-                    encoded
-                    relocations
-                    (addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolResult)
-                    definitions
-                in encodeInstructions shndx (result, rest)
-        | otherwise = (TextAccumulator encoded relocations symbolResult definitions, instructions)
-    addDefinition (Just (UnresolvedRelocation symbolName _ _)) =
-        HashSet.insert symbolName
-    addDefinition Nothing = id
-
-shstrtab :: ElfWriter Elf32_Half
-shstrtab = do
-    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-    let stringTable = ".shstrtab"
-        currentNamesSize = StringTable.size sectionNames
-        nextHeader = Elf32_Shdr
-            { sh_type = SHT_STRTAB
-            , sh_size = currentNamesSize -- Adding trailing null character.
-                + fromIntegral (succ $ ByteString.length stringTable)
-            , sh_offset = elfSectionsSize sectionHeaders
-            , sh_name = currentNamesSize
-            , sh_link = 0
-            , sh_info = 0
-            , sh_flags = 0
-            , sh_entsize = 0
-            , sh_addralign = 1
-            , sh_addr = 0
-            }
-    addSectionHeader stringTable nextHeader
-
-    ElfEnvironment{..} <- ElfWriter get
-    liftIO $ ByteString.hPut objectHandle
-        $ StringTable.encode
-        $ getField @"sectionNames" objectHeaders
-    pure $ fromIntegral $ Vector.length sectionHeaders
-
-symtab :: UnresolvedRelocations -> ElfWriter (Elf32_Word, UnresolvedRelocations)
-symtab (UnresolvedRelocations relocationList symbolResult index) = do 
-    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-    let (localSymbols, globalSymbols) = partitionSymbols symbolResult
-        sortedSymbols = localSymbols <> globalSymbols
-        sortedResult = symbolResult{ sectionHeaders = sortedSymbols }
-        encodedSymbols = LazyByteString.toStrict
-            $ ByteString.Builder.toLazyByteString
-            $ foldMap (elf32Sym LSB) sortedSymbols
-        symHeader = Elf32_Shdr
-            { sh_type = SHT_SYMTAB
-            , sh_size = fromIntegral $ ByteString.length encodedSymbols
-            , sh_offset = elfSectionsSize sectionHeaders
-            , sh_name = StringTable.size sectionNames
-            , sh_link = fromIntegral $ Vector.length sectionHeaders + 2
-            , sh_info = fromIntegral $ Vector.length localSymbols
-            , sh_flags = 0
-            , sh_entsize = 16
-            , sh_addralign = 4
-            , sh_addr = 0
-            }
-    putSectionHeader ".symtab" symHeader encodedSymbols
-    pure
-        ( fromIntegral $ Vector.length sectionHeaders
-        , UnresolvedRelocations relocationList sortedResult index
-        )
-
-symrel :: Elf32_Word -> UnresolvedRelocations -> ElfWriter StringTable
-symrel sectionHeadersLength relocations = do
-    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-
-    let UnresolvedRelocations relocationList symbols index = relocations
-        encodedRelocations = LazyByteString.toStrict
-            $ ByteString.Builder.toLazyByteString
-            $ Vector.foldMap (either (const mempty) (elf32Rel LSB))
-            $ resolveRelocation symbols <$> relocationList
-        relHeader = Elf32_Shdr
-            { sh_type = SHT_REL
-            , sh_size = fromIntegral $ ByteString.length encodedRelocations
-            , sh_offset = elfSectionsSize sectionHeaders
-            , sh_name = StringTable.size sectionNames
-            , sh_link = sectionHeadersLength
-            , sh_info = index
-            , sh_flags = shfInfoLink
-            , sh_entsize = 8
-            , sh_addralign = 4
-            , sh_addr = 0
-            }
-    putSectionHeader ".rel.text" relHeader encodedRelocations
-    pure $ getField @"sectionNames" symbols
-  where
-    takeStringZ stringTable Elf32_Sym{ st_name }
-        = StringTable.index st_name stringTable
-    resolveRelocation (ElfHeaderResult stringTable entries) unresolvedRelocation
-        | UnresolvedRelocation symbolName offset type' <- unresolvedRelocation
-        , Just entry <- Vector.findIndex ((== symbolName) . takeStringZ stringTable) entries =
-            Right $ Elf32_Rel
-                { r_offset = offset
-                , r_info = rInfo (fromIntegral entry) type'
-                }
-        | otherwise = Left unresolvedRelocation
-
-strtab :: StringTable -> ElfWriter ()
-strtab stringTable = do
-    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-    let strHeader = Elf32_Shdr
-            { sh_type = SHT_STRTAB
-            , sh_size = StringTable.size stringTable
-            , sh_offset = elfSectionsSize sectionHeaders
-            , sh_name = StringTable.size sectionNames
-            , sh_link = 0
-            , sh_info = 0
-            , sh_flags = 0
-            , sh_entsize = 0
-            , sh_addralign = 1
-            , sh_addr = 0
-            }
-    putSectionHeader ".strtab" strHeader $ StringTable.encode stringTable

rakelib/cross.rake

@@ -1,6 +1,7 @@
 # This Source Code Form is subject to the terms of the Mozilla Public License,
 # v. 2.0. If a copy of the MPL was not distributed with this file, You can
 # obtain one at https://mozilla.org/MPL/2.0/. -}
+# frozen_string_literal: true
 
 require 'pathname'
 require 'uri'
@@ -8,14 +9,13 @@ require 'net/http'
 require 'rake/clean'
 require 'open3'
 require 'etc'
-require_relative 'shared'
 
-GCC_VERSION = "14.2.0"
-BINUTILS_VERSION = '2.43.1'
-GLIBC_VERSION = '2.40'
-KERNEL_VERSION = '5.15.166'
+GCC_VERSION = "15.1.0"
+BINUTILS_VERSION = '2.44'
+GLIBC_VERSION = '2.41'
+KERNEL_VERSION = '5.15.181'
 
-CLOBBER.include TMP
+CLOBBER.include 'build'
 
 class BuildTarget
   attr_accessor(:build, :gcc, :target, :tmp)
@@ -35,20 +35,6 @@ class BuildTarget
   def tools
     tmp + 'tools'
   end
-
-  def configuration
-    case target
-    when /^riscv[[:digit:]]+-/
-      [
-        '--with-arch=rv32imafdc',
-        '--with-abi=ilp32d',
-        '--with-tune=rocket',
-        '--with-isa-spec=20191213'
-      ]
-    else
-      []
-    end
-  end
 end
 
 def gcc_verbose(gcc_binary)
@@ -77,7 +63,7 @@ def find_build_target(gcc_version, task)
         accumulator.gcc = line.split('=').last.strip
       end
     end
-  result.tmp = TMP
+  result.tmp = Pathname.new('./build')
   task.with_defaults target: 'riscv32-unknown-linux-gnu'
   result.target = task[:target]
   result
@@ -169,11 +155,15 @@ namespace :cross do
     options.sysroot.mkpath
 
     sh 'contrib/download_prerequisites', chdir: source_directory.to_path
-    configure_options = options.configuration + [
+    configure_options = [
       "--prefix=#{options.rootfs.realpath}",
       "--with-sysroot=#{options.sysroot.realpath}",
       '--enable-languages=c,c++',
       '--disable-shared',
+      '--with-arch=rv32imafdc',
+      '--with-abi=ilp32d',
+      '--with-tune=rocket',
+      '--with-isa-spec=20191213',
       '--disable-bootstrap',
       '--disable-multilib',
       '--disable-libmudflap',
@@ -285,12 +275,16 @@ namespace :cross do
     rm_rf cwd
     cwd.mkpath
 
-    configure_options = options.configuration + [
+    configure_options = [
       "--prefix=#{options.rootfs.realpath}",
       "--with-sysroot=#{options.sysroot.realpath}",
       '--enable-languages=c,c++,lto',
       '--enable-lto',
       '--enable-shared',
+      '--with-arch=rv32imafdc',
+      '--with-abi=ilp32d',
+      '--with-tune=rocket',
+      '--with-isa-spec=20191213',
       '--disable-bootstrap',
       '--disable-multilib',
       '--enable-checking=release',
@@ -315,27 +309,15 @@ namespace :cross do
     sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
     sh env, 'make', 'install', chdir: cwd.to_path
   end
-
-  task :init, [:target]  do |_, args|
-    options = find_build_target GCC_VERSION, args
-    env = {
-      'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}"
-    }
-    sh env, 'riscv32-unknown-linux-gnu-gcc',
-      '-ffreestanding', '-static',
-      '-o', (options.tools + 'init').to_path,
-      'tools/init.c'
-  end
 end
 
 desc 'Build cross toolchain'
-task :cross, [:target] => [
+task cross: [
   'cross:binutils',
   'cross:gcc1',
   'cross:headers',
   'cross:kernel',
   'cross:glibc',
-  'cross:gcc2',
-  'cross:init'
+  'cross:gcc2'
 ] do
 end

rakelib/shared.rb

@@ -1,5 +0,0 @@
-# This Source Code Form is subject to the terms of the Mozilla Public License,
-# v. 2.0. If a copy of the MPL was not distributed with this file, You can
-# obtain one at https://mozilla.org/MPL/2.0/. -}
-
-TMP = Pathname.new('./build')

rakelib/stage.rake

@@ -0,0 +1,61 @@
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# v. 2.0. If a copy of the MPL was not distributed with this file, You can
+# obtain one at https://mozilla.org/MPL/2.0/. -}
+# frozen_string_literal: true
+
+CROSS_GCC = 'build/rootfs/bin/riscv32-unknown-linux-gnu-gcc'
+SYSROOT = 'build/sysroot'
+QEMU = 'qemu-riscv32'
+
+def assemble_stage(output, compiler, source)
+  arguments = [QEMU, '-L', SYSROOT, *compiler]
+
+  puts Term::ANSIColor.green(arguments * ' ')
+  puts
+  Open3.popen2(*arguments) do |qemu_in, qemu_out|
+    qemu_in.write File.read(*source)
+    qemu_in.close
+
+    IO.copy_stream qemu_out, output
+    qemu_out.close
+  end
+end
+
+library = []
+
+Dir.glob('boot/*.s').each do |assembly_source|
+  source_basename = Pathname.new(assembly_source).basename
+  target_object = Pathname.new('build/boot') + source_basename.sub_ext('.o')
+
+  file target_object.to_s => [assembly_source, 'build/boot'] do |t|
+    sh CROSS_GCC, '-c', '-o', t.name, assembly_source
+  end
+  library << assembly_source unless source_basename.to_s.start_with? 'stage'
+end
+
+desc 'Initial stage'
+file 'build/boot/stage1' => ['build/boot/stage1.o', *library] do |t|
+  sh CROSS_GCC, '-nostdlib', '-o', t.name, *t.prerequisites
+end
+
+file 'build/boot/stage2a.s' => ['build/boot/stage1', 'boot/stage2.elna'] do |t|
+  source, exe = t.prerequisites.partition { |prerequisite| prerequisite.end_with? '.elna' }
+
+  File.open t.name, 'w' do |output|
+    assemble_stage output, exe, source
+  end
+end
+
+['build/boot/stage2a', 'build/boot/stage2b'].each do |exe|
+  file exe => [exe.ext('.s'), *library] do |t|
+    sh CROSS_GCC, '-nostdlib', '-o', t.name, *t.prerequisites
+  end
+end
+
+file 'build/boot/stage2b.s' => ['build/boot/stage2a', 'boot/stage2.elna'] do |t|
+  source, exe = t.prerequisites.partition { |prerequisite| prerequisite.end_with? '.elna' }
+
+  File.open t.name, 'w' do |output|
+    assemble_stage output, exe, source
+  end
+end

rakelib/tester.rake

@@ -1,100 +0,0 @@
-# This Source Code Form is subject to the terms of the Mozilla Public License,
-# v. 2.0. If a copy of the MPL was not distributed with this file, You can
-# obtain one at https://mozilla.org/MPL/2.0/. -}
-
-require 'open3'
-require 'rake/clean'
-require_relative 'shared'
-
-CLEAN.include(TMP + 'riscv')
-
-LINKER = 'build/rootfs/riscv32-unknown-linux-gnu/bin/ld'
-AS = 'build/rootfs/riscv32-unknown-linux-gnu/bin/as'
-
-namespace :test do
-  test_sources = FileList['tests/vm/*.elna', 'tests/vm/*.s']
-  compiler = `cabal list-bin elna`.strip
-  object_directory = TMP + 'riscv/tests'
-  root_directory = TMP + 'riscv/root'
-  executable_directory = root_directory + 'tests'
-  expectation_directory = root_directory + 'expectations'
-  init = TMP + 'riscv/root/init'
-  builtin = TMP + 'riscv/builtin.o'
-
-  directory root_directory
-  directory object_directory
-  directory executable_directory
-  directory expectation_directory
-
-  file builtin => ['tools/builtin.s', object_directory] do |task|
-    sh AS, '-o', task.name, task.prerequisites.first
-  end
-
-  test_files = test_sources.flat_map do |test_source|
-    test_basename = File.basename(test_source, '.*')
-    test_object = object_directory + test_basename.ext('.o')
-
-    file test_object => [test_source, object_directory] do |task|
-      case File.extname(task.prerequisites.first)
-      when '.s'
-        sh AS, '-mno-relax', '-o', task.name, task.prerequisites.first
-      when '.elna'
-        sh compiler, '--output', task.name, task.prerequisites.first
-      else
-        raise "Unknown source file extension #{task.prerequisites.first}"
-      end
-    end
-    test_executable = executable_directory + test_basename
-
-    file test_executable => [test_object, executable_directory, builtin] do |task|
-      objects = task.prerequisites.filter { |prerequisite| File.file? prerequisite }
-
-      sh LINKER, '-o', test_executable.to_path, *objects
-    end
-    expectation_name = test_basename.ext '.txt'
-    source_expectation = "tests/expectations/#{expectation_name}"
-    target_expectation = expectation_directory + expectation_name
-
-    file target_expectation => [source_expectation, expectation_directory] do
-      cp source_expectation, target_expectation
-    end
-
-    [test_executable, target_expectation]
-  end
-
-  file init => [root_directory] do |task|
-    cp (TMP + 'tools/init'), task.name
-  end
-  # Directories should come first.
-  test_files.unshift executable_directory, expectation_directory, init
-
-  file (TMP + 'riscv/root.cpio') => test_files do |task|
-    root_files = task.prerequisites
-      .map { |prerequisite| Pathname.new(prerequisite).relative_path_from(root_directory).to_path }
-
-    File.open task.name, 'wb' do |cpio_file|
-      cpio_options = {
-        chdir: root_directory.to_path
-      }
-      cpio_stream = Open3.popen2 'cpio', '-o', '--format=newc', cpio_options do |stdin, stdout, wait_thread|
-        stdin.write root_files.join("\n")
-        stdin.close
-        stdout.each { |chunk| cpio_file.write chunk }
-        wait_thread.value
-      end
-    end
-  end
-
-  task :vm => (TMP + 'riscv/root.cpio') do |task|
-    kernels = FileList.glob(TMP + 'tools/linux-*/arch/riscv/boot/Image')
-
-    sh 'qemu-system-riscv32',
-      '-nographic',
-      '-M', 'virt',
-      '-bios', 'default',
-      '-kernel', kernels.first,
-      '-append', 'quiet panic=1',
-      '-initrd', task.prerequisites.first,
-      '-no-reboot'
-  end
-end

src/Main.hs

@@ -1,62 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Main
-    ( main
-    ) where
-
-import Language.Elna.Driver
-    ( Driver(..)
-    , IntermediateStage(..)
-    , drive
-    )
-import Language.Elna.Object.ElfCoder (elfObject)
-import Language.Elna.Backend.Allocator (allocate)
-import Language.Elna.Glue (glue)
-import Language.Elna.Frontend.NameAnalysis (nameAnalysis)
-import Language.Elna.Frontend.Parser (programP)
-import Language.Elna.Frontend.TypeAnalysis (typeAnalysis)
-import Language.Elna.RiscV.CodeGenerator (generateRiscV, riscVConfiguration)
-import Language.Elna.RiscV.ElfWriter (riscv32Elf)
-import Text.Megaparsec (runParser, errorBundlePretty)
-import qualified Data.Text.IO as Text
-import System.Exit (ExitCode(..), exitWith)
-import Control.Exception (IOException, catch)
-
--- * Error codes
---
--- 1 - Command line parsing failed and other errors.
--- 2 - The input could not be read.
--- 3 - Parse error.
--- 4 - Name analysis error.
--- 5 - Type error.
--- 6 - Register allocation error.
-
-main :: IO ()
-main = drive >>= withCommandLine
-  where
-    withCommandLine driver@Driver{ input }
-        = catch (Text.readFile input) (printAndExit 2 :: IOException -> IO a)
-        >>= withParsedInput driver
-        . runParser programP input
-    withParsedInput driver@Driver{ intermediateStage } (Right program)
-        | Just ParseStage <- intermediateStage = pure ()
-        | otherwise
-            = either (printAndExit 4) (withSymbolTable driver program)
-            $ nameAnalysis program 
-    withParsedInput _ (Left errorBundle)
-        = putStrLn (errorBundlePretty errorBundle)
-        >> exitWith (ExitFailure 3)
-    withSymbolTable driver@Driver{ intermediateStage } program symbolTable
-        | Just typeError <- typeAnalysis symbolTable program =
-            printAndExit 5 typeError
-        | Just ValidateStage <- intermediateStage = pure ()
-        | otherwise = either (printAndExit 6) (withTac driver)
-            $ allocate riscVConfiguration symbolTable
-            $ glue symbolTable program
-    withTac Driver{ intermediateStage, output } tac
-        | Just CodeGenStage <- intermediateStage = pure ()
-        | otherwise = elfObject output $ riscv32Elf $ generateRiscV tac
-    printAndExit :: Show b => forall a. Int -> b -> IO a
-    printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode)

tests/Language/Elna/NameAnalysisSpec.hs

@@ -1,82 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.NameAnalysisSpec
-    ( spec
-    ) where
-
-import Data.Text (Text)
-import Text.Megaparsec (runParser)
-import Test.Hspec
-    ( Spec
-    , describe
-    , expectationFailure
-    , it
-    , shouldBe
-    , shouldSatisfy
-    )
-import Language.Elna.NameAnalysis (Error(..), nameAnalysis)
-import Language.Elna.SymbolTable (Info(..), SymbolTable)
-import qualified Language.Elna.SymbolTable as SymbolTable
-import qualified Language.Elna.Parser as AST
-import Language.Elna.Types (intType)
-import Control.Exception (throwIO)
-
-nameAnalysisOnText :: Text -> IO (Either Error SymbolTable)
-nameAnalysisOnText sourceText = nameAnalysis
-    <$> either throwIO pure (runParser AST.programP "" sourceText)
-
-spec :: Spec
-spec = describe "nameAnalysis" $ do
-    it "adds type to the symbol table" $ do
-        let given = "type A = int;"
-            expected = Right $ Just $ TypeInfo intType
-        actual <- nameAnalysisOnText given
-
-        actual `shouldSatisfy` (expected ==) . fmap (SymbolTable.lookup "A")
-
-    it "errors when the aliased type is not defined" $ do
-        let given = "type A = B;"
-            expected = Left $ UndefinedTypeError "B"
-        actual <- nameAnalysisOnText given
-
-        actual `shouldBe` expected
-
-    it "errors if the aliased identifier is not a type" $ do
-        let given = "proc main() {} type A = main;"
-            expected = Left
-                $ UnexpectedTypeInfoError
-                $ ProcedureInfo mempty mempty
-        actual <- nameAnalysisOnText given
-
-        actual `shouldBe` expected
-
-    it "replaces the alias with an equivalent base type" $ do
-        let given = "type A = int; type B = A; type C = B;"
-            expected = Right $ Just $ TypeInfo intType
-        actual <- nameAnalysisOnText given
-
-        actual `shouldSatisfy` (expected ==) . fmap (SymbolTable.lookup "C")
-
-    it "puts parameters into the local symbol table" $ do
-        let given = "proc main(ref param: int) {}"
-            expected = SymbolTable.enter "param" (VariableInfo True intType) SymbolTable.empty
-        actual <- nameAnalysisOnText given
-
-        case SymbolTable.lookup "main" <$> actual of
-            Right lookupResult
-                | Just (ProcedureInfo localTable _) <- lookupResult ->
-                    Just localTable `shouldBe` expected
-            _ -> expectationFailure "Procedure symbol not found"
-
-    it "puts variables into the local symbol table" $ do
-        let given = "proc main() { var var1: int; }"
-            expected = SymbolTable.enter "var1" (VariableInfo False intType) SymbolTable.empty
-        actual <- nameAnalysisOnText given
-
-        case SymbolTable.lookup "main" <$> actual of
-            Right lookupResult
-                | Just (ProcedureInfo localTable _) <- lookupResult ->
-                    Just localTable `shouldBe` expected
-            _ -> expectationFailure "Procedure symbol not found"

tests/Language/Elna/ParserSpec.hs

@@ -1,146 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-module Language.Elna.ParserSpec
-    ( spec
-    ) where
-
-import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn, parseSatisfies)
-import Language.Elna.Parser (programP)
-import Text.Megaparsec (parse)
-import Language.Elna.AST
-    ( Declaration(..)
-    , Expression(..)
-    , Literal(..)
-    , Statement(..)
-    , Parameter(..)
-    , Program(..)
-    , VariableDeclaration(..)
-    , TypeExpression(..)
-    )
-
-spec :: Spec
-spec =
-    describe "programP" $ do
-        it "parses an empty main function" $
-            parse programP "" `shouldSucceedOn` "proc main() {}"
-
-        it "parses type definition for a type starting like array" $
-            let expected = Program [TypeDefinition "t" $ NamedType "arr"]
-                actual = parse programP "" "type t = arr;"
-             in actual `shouldParse` expected
-
-        it "parses array type definition" $
-            let expected = Program [TypeDefinition "t" $ ArrayType 10 (NamedType "int")]
-                actual = parse programP "" "type t = array[10] of int;"
-             in actual `shouldParse` expected
-
-        it "parses parameters" $
-            let given = "proc main(x: int) {}"
-                parameters = [Parameter "x" (NamedType "int") False]
-                expected = Program [ProcedureDefinition "main" parameters [] []]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses ref parameters" $
-            let given = "proc main(x: int, ref y: boolean) {}"
-                parameters =
-                    [ Parameter "x" (NamedType "int") False
-                    , Parameter "y" (NamedType "boolean") True
-                    ]
-                expected = Program [ProcedureDefinition "main" parameters [] []]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses variable declaration" $
-            let given = "proc main() { var x: int; }"
-                expected (Program [ProcedureDefinition _ _ variables _]) =
-                    not $ null variables
-                expected _ = False
-                actual = parse programP "" given
-             in actual `parseSatisfies` expected
-
-        it "parses negation" $
-            let given = "proc main(x: int) { var y: int; y := -x; }"
-                parameters = pure $ Parameter "x" (NamedType "int") False
-                variables = pure
-                    $ VariableDeclaration "y"
-                    $ NamedType "int"
-                body = pure
-                    $ AssignmentStatement (VariableExpression "y")
-                    $ NegationExpression
-                    $ VariableExpression "x"
-                expected = Program
-                    [ProcedureDefinition "main" parameters variables body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses comparison with lower precedence than other binary operators" $
-            let given = "proc main() { var x: boolean; x := 1 + 2 = 3 * 4; }"
-                variables = pure
-                    $ VariableDeclaration "x"
-                    $ NamedType "boolean"
-                lhs = SumExpression (LiteralExpression (IntegerLiteral 1))
-                    $ LiteralExpression (IntegerLiteral 2)
-                rhs = ProductExpression (LiteralExpression (IntegerLiteral 3))
-                    $ LiteralExpression (IntegerLiteral 4)
-                body = pure
-                    $ AssignmentStatement (VariableExpression "x")
-                    $ EqualExpression lhs rhs
-                expected = Program
-                    [ProcedureDefinition "main" [] variables body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses hexadecimals" $
-            let given = "proc main() { var x: int; x := 0x10; }"
-                variables = pure
-                    $ VariableDeclaration "x"
-                    $ NamedType "int"
-                body = pure
-                    $ AssignmentStatement (VariableExpression "x")
-                    $ LiteralExpression (HexadecimalLiteral 16)
-                expected = Program
-                    [ProcedureDefinition "main" [] variables body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses procedure calls" $
-            let given = "proc main() { f('c'); }"
-                body = pure
-                    $ CallStatement "f" [LiteralExpression (CharacterLiteral 99)]
-                expected = Program
-                    [ProcedureDefinition "main" [] [] body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses an if statement" $
-            let given = "proc main() { if (true) ; }"
-                body = pure
-                    $ IfStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement Nothing
-                expected = Program
-                    [ProcedureDefinition "main" [] [] body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "associates else with the nearst if statement" $
-            let given = "proc main() { if (true) if (false) ; else ; }"
-                if' = IfStatement (LiteralExpression $ BooleanLiteral False) EmptyStatement
-                    $ Just EmptyStatement
-                body = pure
-                    $ IfStatement (LiteralExpression $ BooleanLiteral True) if' Nothing
-                expected = Program
-                    [ProcedureDefinition "main" [] [] body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected
-
-        it "parses a while statement" $
-            let given = "proc main() { while (true) ; }"
-                body = pure
-                    $ WhileStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement
-                expected = Program
-                    [ProcedureDefinition "main" [] [] body]
-                actual = parse programP "" given
-             in actual `shouldParse` expected

tests/Spec.hs

@@ -1,5 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

tests/expectations/add_products.txt

@@ -1 +0,0 @@
-38

tests/expectations/add_to_variable.txt

@@ -1 +0,0 @@
-58

tests/expectations/array_element_assignment.txt

@@ -1 +0,0 @@
-5

tests/expectations/array_with_variable_index.txt

@@ -1,2 +0,0 @@
-5
-7

tests/expectations/define_variable.txt

@@ -1 +0,0 @@
-58

tests/expectations/exit_between_statements.txt

@@ -1 +0,0 @@
-c

tests/expectations/parse_negative_numbers.txt

@@ -1 +0,0 @@
--8

tests/expectations/print0.txt

@@ -1 +0,0 @@
-0

tests/expectations/print_2_digits.txt

@@ -1 +0,0 @@
-13

tests/expectations/print_2_statements.txt

@@ -1,2 +0,0 @@
-13
-2097150

tests/expectations/print_after_loop.txt

@@ -1 +0,0 @@
-2

tests/expectations/print_array_element.txt

@@ -1,2 +0,0 @@
-5
-7

tests/expectations/print_char.txt

@@ -1 +0,0 @@
-x

tests/expectations/print_in_proc.txt

@@ -1,2 +0,0 @@
-14
-8

tests/expectations/print_more_20_bits.txt

@@ -1 +0,0 @@
-2097150

tests/expectations/print_negate.txt

@@ -1 +0,0 @@
--8

tests/expectations/print_product.txt

@@ -1 +0,0 @@
-1000

tests/expectations/print_subtraction.txt

@@ -1 +0,0 @@
--8

tests/expectations/print_sum.txt

@@ -1 +0,0 @@
-18

tests/expectations/printi_hex.txt

@@ -1 +0,0 @@
-129

tests/expectations/printi_if.txt

@@ -1 +0,0 @@
-3

tests/expectations/printi_if_greater.txt

@@ -1 +0,0 @@
-5

tests/expectations/printi_if_greater_equal.txt

@@ -1 +0,0 @@
-5

tests/expectations/printi_if_less.txt

@@ -1 +0,0 @@
-3

tests/expectations/printi_if_less_equal.txt

@@ -1 +0,0 @@
-3

tests/expectations/printi_if_not.txt

@@ -1 +0,0 @@
-3

tests/expectations/printi_if_not_compound.txt

@@ -1,2 +0,0 @@
-3
-7

tests/expectations/printi_negative_hex.txt

@@ -1 +0,0 @@
--129

tests/expectations/printi_quotient.txt

@@ -1 +0,0 @@
-2

tests/expectations/printi_signed_hex.txt

@@ -1 +0,0 @@
-129

tests/expectations/two_variables.txt

@@ -1,2 +0,0 @@
-58
-28

tests/vm/add_products.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(2 * 3 + 4 * 8);
-}

tests/vm/add_to_variable.elna

@@ -1,6 +0,0 @@
-proc main() {
-  var i: int;
-  i := 28;
-
-  printi(i + 30);
-}

tests/vm/array_element_assignment.elna

@@ -1,6 +0,0 @@
-proc main() {
-  var a: array[1] of int;
-  a[0] := 5;
-
-  printi(a[0]);
-}

tests/vm/array_with_variable_index.elna

@@ -1,11 +0,0 @@
-proc main() {
-  var a: array[2] of int;
-  var i: int;
-
-  i := 1;
-  a[0] := 5;
-  a[i] := 7;
-
-  printi(a[0]);
-  printi(a[i]);
-}

tests/vm/define_variable.elna

@@ -1,6 +0,0 @@
-proc main() {
-  var i: int;
-  i := 58;
-
-  printi(i);
-}

tests/vm/exit_between_statements.elna

@@ -1,5 +0,0 @@
-proc main() {
-  printc('c');
-  exit();
-  printi(1234);
-}

tests/vm/parse_negative_numbers.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(-8);
-}

tests/vm/print0.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(0);
-}

tests/vm/print_2_digits.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(13);
-}

tests/vm/print_2_statements.elna

@@ -1,4 +0,0 @@
-proc main() {
-  printi(13);
-  printi(2097150);
-}

tests/vm/print_after_loop.elna

@@ -1,9 +0,0 @@
-proc main() {
-  var x: int;
-
-  x := 0;
-  while (x < 2) {
-    x := x + 1;
-  }
-  printi(x);
-}

tests/vm/print_array_element.elna

@@ -1,8 +0,0 @@
-proc main() {
-  var a: array[2] of int;
-  a[0] := 5;
-  a[1] := 7;
-
-  printi(a[0]);
-  printi(a[1]);
-}

tests/vm/print_char.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printc('x');
-}

tests/vm/print_in_proc.elna

@@ -1,8 +0,0 @@
-proc print2(a: int, b: int) {
-  printi(a);
-  printi(b);
-}
-
-proc main() {
-  print2(14, 8);
-}

tests/vm/print_more_20_bits.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(2097150);
-}

tests/vm/print_negate.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(-(8));
-}

tests/vm/print_product.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(20 * 50);
-}

tests/vm/print_subtraction.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(5 - 13);
-}

tests/vm/print_sum.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(5 + 13);
-}

tests/vm/printi_hex.elna

@@ -1,3 +0,0 @@
-proc main() {
-  printi(0x81);
-}

tests/vm/printi_if.elna

@@ -1,4 +0,0 @@
-proc main() {
-  if (1 = 1)
-    printi(3);
-}

tests/vm/printi_if_greater.elna

@@ -1,6 +0,0 @@
-proc main() {
-  if ((1 + 1) > 2)
-    printi(3);
-  else
-    printi(5);
-}

tests/vm/printi_if_greater_equal.elna

@@ -1,6 +0,0 @@
-proc main() {
-  if ((1 + 1) >= (2 + 3))
-    printi(3);
-  else
-    printi(5);
-}

tests/vm/printi_if_less.elna

@@ -1,6 +0,0 @@
-proc main() {
-  if (1 < 2)
-    printi(3);
-  else
-    printi(5);
-}

tests/vm/printi_if_less_equal.elna

@@ -1,6 +0,0 @@
-proc main() {
-  if (2 <= (2 + 1))
-    printi(3);
-  else
-    printi(5);
-}

tests/vm/printi_if_not.elna

@@ -1,6 +0,0 @@
-proc main() {
-  if (1 # 2)
-    printi(3);
-  else
-    printi(5);
-}

tests/vm/printi_if_not_compound.elna

@@ -1,9 +0,0 @@
-proc main() {
-  if (1 # 2) {
-    printi(3);
-    printi(7);
-  } else {
-    printi(5);
-    printi(9);
-  }
-}