// =======================================
// OxygenBasic port of Ed Davis'
// Toy byte-code compiler/interpreter
//
// Ported by Mike Lobanovsky
// July 2014
//
// (See the author's original blurb below)
// =======================================

' QB64/FreeBasic version of Toy byte-code compiler/interpreter
' June 2012 by Ed Davis (ed_davis2 around yahoo)
'
' To compile with QB64:
' qb64 -c toy.bas
'
' To compile with FreeBasic:
' fbc -lang qb toy.bas
'
' Grammar:
'
'pgm = {int_decl} stmt_seq .
'int_decl = "integer" ident {"," ident} .
'stmt_seq = {print_stmt | halt_stmt | while_stmt | assign | if_stmt} .
'print_stmt = "print" (string | expr) {, (string | expr) } .
'halt_stmt = "halt" .
'while_stmt = "while" expr "do" stmt_seq "end" "while" .
'assign = ident "=" expr .
'if_stmt = "if" expr "then" stmt_seq ["else" stmt_seq] "end" "if" .
'exp    = orexp .
'orexp  = andexp {"or" andexp} .
'andexp = eqlexp {"and" eqlexp} .
'eqlexp = relexp {eqlop relexp} .
'relexp = addexp {relop addexp} .
'addexp = mulexp {addop mulexp} .
'mulexp = factor {mulop factor} .
'factor = '(' exp ')' | number | ident .
'unary_exp  = "not" | "-" .
'eqlop = "=" | "<>"
'relop = "<" | "<=" | ">" | ">="
'addop = "+" | "-"
'mulop = "*" | "/" | "mod"
'
' example program - find primes:
'
'   integer n, lim, k, p
'   n = 1
'   lim = 100
'   while n < lim do
'       k = 3
'       p = 1
'       n = n + 2
'       while k * k <= n and p do
'           p = n / k * k <> n
'           k = k + 2
'       end while
'       if p then
'           print n, " is prime"
'       end if
'   end while
'
' Comments are denoted by the single quote, and extend until the end-of-line

$Filename "toy_o2.exe"
includepath "$\inc\"
'include "RTL32.inc" 'uncomment to create EXE file
include "console.inc"

! sub SetCurrentDirectoryA lib "kernel32.dll" (lpPathName as asciiz)

#lookahead

const as long true = -1, false = 0
' variables for the lexer

dim as string cur_line ' text of current line
dim as string cur_ch ' the current character
dim as long sym ' the current symbol (keyword, operator, etc)
dim as string token ' text version of current symbol

dim as long cur_col
dim as long cur_line_num
dim as long error_line
dim as long error_col

type Key_words
	keyword as string
	sym as long
end type

const as long MAX_KEYWORDS = 13, MAX_SYMTAB = 100, MAX_CODE = 1000, MAX_STACK = 1000
dim key_words_tab(MAX_KEYWORDS) as Key_words

' symbol table - all program identifiers stored here

type Symbol_table
	ident as string
	data_index as long
end type

dim sym_tab(MAX_SYMTAB) as Symbol_table
dim as long sym_tab_used ' highest used entry

dim as long data_index ' highest used data entry - symbol table version

' Virtual Machine
dim as long ccc(12)
dim as long code_arr(MAX_CODE) ' code store
dim as long code_index ' highest used code position
dim as long data_size ' highest used data entry - VM version

' Equates for the symbol type, e.g. what type of symbol have we just read
' the lexer sets variable sym to one of these
const as long sym_unknown = 0, sym_eoi = 1, sym_string_const = 2, sym_lparen = 3, sym_rparen = 4
const as long sym_multiply = 5, sym_plus = 6, sym_comma = 7, sym_minus = 8, sym_divide = 9
const as long sym_integer_const = 10, sym_ident = 11, sym_print = 12, sym_while = 13
const as long sym_do = 14, sym_end = 15, sym_halt = 16, sym_if = 17, sym_then = 18
const as long sym_else = 19, sym_integer_var = 20, sym_equal = 21, sym_mod = 22, sym_or = 23
const as long sym_and = 24, sym_neq = 25, sym_lss = 26, sym_leq = 27, sym_gtr = 28
const as long sym_geq = 29, sym_neg = 30, sym_not = 31, sym_whtspc = 32

const as long left_assoc = 1, right_assoc = 0

' Instructions for the virtual machine
const as long op_halt = 0, op_push_int = 1, op_add = 2, op_sub = 3, op_mul = 4, op_div = 5
const as long op_prt_str = 6, op_prt_int = 7, op_prt_nl = 8, op_jmp = 9, op_jz = 10
const as long op_push_int_var = 11, op_stor = 12, op_mod = 13, op_or = 14, op_and = 15
const as long op_neq = 16, op_equal = 17, op_lss = 18, op_leq = 19, op_gtr = 20, op_geq = 21
const as long op_neg = 22, op_not = 23

dim as string code // SCRIPT CODE BUFFER

main()

sub main()
	print "enter filename (^C to quit): "
    dim as string filename = rtrim(input())

	init_sym_tab()
	init_code()
	init_lex(filename)
	parse()
	list_code()
	interpret()
	press_a_key()
end sub


sub init_lex(filename as string)
	// MAKE SURE CODE BUFFER ENDS IN EMPTY STRING
    getfile(filename, code)
    code = code & chr(13) & chr(10)
	cur_line_num = 0
	
	key_words_tab( 1).sym = sym_and
	key_words_tab( 2).sym = sym_do
	key_words_tab( 3).sym = sym_else
	key_words_tab( 4).sym = sym_end
	key_words_tab( 5).sym = sym_halt
	key_words_tab( 6).sym = sym_if
	key_words_tab( 7).sym = sym_integer_var
	key_words_tab( 8).sym = sym_mod
	key_words_tab( 9).sym = sym_not
	key_words_tab(10).sym = sym_or
	key_words_tab(11).sym = sym_print
	key_words_tab(12).sym = sym_then
	key_words_tab(13).sym = sym_while
	
	key_words_tab( 1).keyword = "and"
	key_words_tab( 2).keyword = "do"
	key_words_tab( 3).keyword = "else"
	key_words_tab( 4).keyword = "end"
	key_words_tab( 5).keyword = "halt"
	key_words_tab( 6).keyword = "if"
	key_words_tab( 7).keyword = "integer"
	key_words_tab( 8).keyword = "mod"
	key_words_tab( 9).keyword = "not"
	key_words_tab(10).keyword = "or"
	key_words_tab(11).keyword = "print"
	key_words_tab(12).keyword = "then"
	key_words_tab(13).keyword = "while"

    next_char()
end sub

sub next_line() ' read the next line of input from the source file
	cur_line = ""
	cur_ch = "" ' empty cur_ch means end-of-file
	cur_line = get_line()
	if cur_line = "" then exit sub
	cur_line = cur_line & chr(10) // LF
	cur_line_num = cur_line_num + 1
    print cur_line // CONTAINS LF
	cur_col = 1
end sub

sub next_char() ' get the next char
	cur_ch = ""
	cur_col = cur_col + 1
	if cur_col > len(cur_line) then next_line()
	
	if cur_col <= len(cur_line) then
		cur_ch = mid(cur_line, cur_col, 1)
	end if
end sub

sub skip_white_space()
	' apparently BASIC doesn't do short circuiting of long expressions
	' pick off the empty string first, since asc of an empty string causes an error
    byte c
	do
        c = asc(cur_ch)
        select case c
            case " ", 9, 10
                next_char()
            case else
                exit do
        end select
	end do
end sub

sub next_sym() ' determine the next symbol
    byte c

    token = ""
	skip_white_space()
	error_line = cur_line_num
	error_col = cur_col
    c = asc(cur_ch)
	select case c // O2 SPECIFIC!
		case ""
			sym = sym_eoi
		case "+"
			sym = sym_plus
			next_char()
		case "-"
			sym = sym_minus
			next_char()
		case "*"
			sym = sym_multiply
			next_char()
		case "/"
			sym = sym_divide
			next_char()
		case ","
			sym = sym_comma
			next_char()
		case "("
			sym = sym_lparen
			next_char()
		case ")"
			sym = sym_rparen
			next_char()
		case "="
			sym = sym_equal
			next_char()
		case "<"
			sym = sym_lss
			next_char()
			if cur_ch = ">" then
				sym = sym_neq
				next_char()
			elseif cur_ch = "=" then
				sym = sym_leq
				next_char()
			end if
		case ">"
			sym = sym_gtr
			next_char()
			if cur_ch = "=" then
				sym = sym_geq
				next_char()
			end if
		case 34 ' a double quote
			get_string()
		case else
			if is_numeric() then
				get_digits()
			elseif is_alpha() then
				get_ident()
			else
				error_msg("unrecognized character: " & cur_ch & " asc = " & str(c))
			end if
	end select
end sub

sub get_string()
	dim as long start_line
    dim as string DQ = chr(34)
    
	sym = sym_string_const
	token = ""
	start_line = error_line
	next_char()
	while cur_ch <> DQ
		if cur_ch = "" then
			sym = sym_eoi
			error_msg("eof found in string")
		end if
		if error_line > start_line then
			error_msg("string must be on one line")
		end if
		token = token & cur_ch
		next_char()
	wend
	if cur_ch = DQ then next_char()
end sub

sub get_digits()
    sym = sym_integer_const
	token = ""
	while is_numeric()
        token = token & cur_ch
		next_char()
	wend
end sub

sub get_ident()
	token = ""
	while is_alpha() or is_numeric() or cur_ch = "_"
		token = token & cur_ch
		next_char()
	wend
	sym = search_key_words()
end sub

' look for a key word - return either the matching sym or sym_ident
function search_key_words() as long
	dim as long i

    for i = 1 to MAX_KEYWORDS
		if token = key_words_tab(i).keyword then
            return key_words_tab(i).sym
        end if
	next
	
	return sym_ident
end function

'------ Symbol table ---------------------------------------------------

sub init_sym_tab()
	data_index = 1
	sym_tab_used = 0
end sub

function get_data_size() as long
	return data_index
end function

' internal routine
function find_sym_tab(ident as string) as long
	dim as long i
	for i = 1 to sym_tab_used
		if ident = sym_tab(i).ident then return i
	next
	
	return 0
end function

sub insert_sym_tab()
	if sym_tab_used >= MAX_SYMTAB then
		error_msg("Symbol table exhausted")
	end if
	
	if find_sym_tab(token) > 0 then
		error_msg(token & " has already been defined")
	end if
    sym_tab_used = sym_tab_used + 1
	sym_tab(sym_tab_used).ident = token
	sym_tab(sym_tab_used).data_index = data_index
	data_index = data_index + 1
end sub

' see if an ident exists in the symbol table - long return
function is_in_sym_tab(byref address as long) as long
	dim as long i
	
	i = find_sym_tab(token)
	if i = 0 then return false

    address = sym_tab(i).data_index
	return true
end function

'------ virtual machine -------------------------------------------------------------

' code generator

sub init_code()
	code_index = 1
end sub

sub set_data_size(size_to_set as long)
	data_size = size_to_set
end sub

function get_cur_loc() as long
	return code_index
end function

sub emit_at(location as long, operand as long)
	code_arr(location) = operand
end sub

sub emit(opcode as long)
	if code_index >= MAX_CODE then
		error_msg("code array exhausted: " & str(code_index))
	end if
	code_arr(code_index) = opcode
	code_index = code_index + 1
end sub

function emit2(opcode as long, operand as long) as long
	dim as long location = code_index
	emit(opcode)
	emit(operand)
	return location
end function

sub patch_jmp_to_current(fix_addr as long)
	' skip over opcode
	emit_at(fix_addr + 1, code_index)
end sub

' code lister
sub list_code()
	dim as long i
	dim as long last_code

    dim as long operand
    dim as string st
    dim as long tmp
    dim as long tmp2

	print cr "Code listing..." cr
	last_code = code_index
	i = 1
	do
		select case code_arr(i)
			case op_halt
				print i " halt" cr
			case op_push_int
				print i " push-int " code_arr(i + 1) cr
				i = i + 1
			case op_push_int_var
				print i " push-int-var " code_arr(i + 1) cr
				i = i + 1
			case op_stor
				print i " store " code_arr(i + 1) cr
				i = i + 1
			case op_jmp
				print i " jmp " code_arr(i + 1) cr
				i = i + 1
			case op_jz
				print i " jz " code_arr(i + 1) cr
				i = i + 1
			case op_add: print i " add" cr
			case op_sub: print i " sub" cr
			case op_mul: print i " mul" cr
			case op_div: print i " div" cr
			case op_mod: print i " mod" cr
			case op_or: print i " or" cr
			case op_and: print i " and" cr
			case op_neq: print i " neq" cr
			case op_equal: print i " equal" cr
			case op_lss: print i " lss" cr
			case op_leq: print i " leq" cr
			case op_gtr: print i " gtr" cr
			case op_geq: print i " geq" cr
			case op_neg: print i " neg" cr
			case op_not: print i " not" cr
			case op_prt_nl: print i " print-nl" cr
			case op_prt_str
				st = ""
				operand = code_arr(i + 1)
				tmp = operand
				tmp2 = i
				i = i + 1
				while operand > 0
					i = i + 1
					st = st & chr(code_arr(i))
					operand = operand - 1
				wend
				print tmp2 " print-str " tmp " " st cr
			case op_prt_int
				print i " print-int" cr
			case else
				error_msg("unexpected opcode " & str(code_arr(i)) & " at position " & str(i))
		end select
		i = i + 1
        if i >= last_code then exit do
	end do
	print cr
end sub

' virtual machine interpreter

sub interpret()
	dim as long last_code
	dim as long pc
	dim as long sp
	dim as long halted
	dim as long stack(MAX_STACK)
	
	dim as long opcode
	dim as long operand
	dim as string st
	
	print "Running... code_index: " code_index cr
	last_code = code_index - 1
	halted = false
	pc = 1
	sp = data_size
	do
		opcode = 0
		operand = 0
		st = ""
		
		if pc > last_code then
			error_msg("pc: (" & str(pc) & ") > last_code: (" & str(last_code) & ")")
		end if
		if sp < 0 then
			error_msg("stack underflow")
		end if
		
		opcode = code_arr(pc)
		pc = pc + 1
		
		select case opcode
			case op_push_int
				sp = sp + 1
				stack(sp) = code_arr(pc)
				pc = pc + 1
			case op_push_int_var
				sp = sp + 1
				stack(sp) = stack(code_arr(pc))
				pc = pc + 1
			case op_jz
				if stack(sp) = 0 then
					pc = code_arr(pc)
				else
					pc = pc + 1
				end if
				sp = sp - 1
			case op_stor
				stack(code_arr(pc)) = stack(sp)
				sp = sp - 1
				pc = pc + 1
			case op_jmp
				pc = code_arr(pc)
			case op_add
				sp = sp - 1
				stack(sp) = stack(sp) + stack(sp + 1)
			case op_sub
				sp = sp - 1
				stack(sp) = stack(sp) - stack(sp + 1)
			case op_mul
				sp = sp - 1
				stack(sp) = stack(sp) * stack(sp + 1)
			case op_div
				sp = sp - 1
				if stack(sp + 1) = 0 then
					error_msg("divide by zero")
				end if
				stack(sp) = stack(sp) \ stack(sp + 1)
			case op_mod
				sp = sp - 1
				if stack(sp + 1) = 0 then
					error_msg("divide by zero")
				end if
				stack(sp) = mod(stack(sp), stack(sp + 1))
			case op_or
				sp = sp - 1
				stack(sp) = stack(sp) or stack(sp + 1)
			case op_and
				sp = sp - 1
				stack(sp) = stack(sp) and stack(sp + 1)
			case op_neq
				sp = sp - 1
				stack(sp) = stack(sp) <> stack(sp + 1)
			case op_equal
				sp = sp - 1
				stack(sp) = stack(sp) = stack(sp + 1)
			case op_lss
				sp = sp - 1
				stack(sp) = stack(sp) < stack(sp + 1)
			case op_leq
				sp = sp - 1
				stack(sp) = stack(sp) <= stack(sp + 1)
			case op_gtr
				sp = sp - 1
				stack(sp) = stack(sp) > stack(sp + 1)
			case op_geq
				sp = sp - 1
				stack(sp) = stack(sp) >= stack(sp + 1)
			case op_neg
				stack(sp) = -stack(sp)
			case op_not
				stack(sp) = not stack(sp)
			case op_prt_str
				operand = code_arr(pc)
				pc = pc + 1
				st = ""
				while operand > 0
					st = st & chr(code_arr(pc))
					pc = pc + 1
					operand = operand - 1
				wend
				print st
            case op_prt_int
				print stack(sp)
				sp = sp - 1
			case op_prt_nl
				print cr
			case op_halt
				halted = true
				exit do
			case else
				error_msg("Unknown opcode " & str(opcode))
		end select
        if halted then exit do
	end do
	print "Finished..." cr
end sub

' parser ----------------------------------------------------------------------

sub emit_op(symbol as long)
	select case symbol
		case sym_or: emit(op_or)
		case sym_and: emit(op_and)
		case sym_equal: emit(op_equal)
		case sym_neq: emit(op_neq)
		case sym_lss: emit(op_lss)
		case sym_leq: emit(op_leq)
		case sym_gtr: emit(op_gtr)
		case sym_geq: emit(op_geq)
		case sym_plus: emit(op_add)
		case sym_minus: emit(op_sub)
		case sym_multiply: emit(op_mul)
		case sym_divide: emit(op_div)
		case sym_mod: emit(op_mod)
		case sym_neg: emit(op_neg)
		case sym_not: emit(op_not)
	end select
end sub

sub expect(symbol as long)
	if symbol = sym then
		next_sym()
	else
		error_msg("unexpected token - expected: " & str(symbol) & " got: " & str(sym))
	end if
end sub

function is_binary_operator(symbol as long) as long
	select case symbol
		case sym_or, sym_and
		case sym_equal, sym_neq
		case sym_lss, sym_leq, sym_gtr, sym_geq
		case sym_plus, sym_minus
		case sym_multiply, sym_divide, sym_mod
            
		case else
			return false
	end select
	return true
end function

function is_relational_operator(symbol as long) as long
	select case symbol
		case sym_equal, sym_neq
		case sym_lss, sym_leq, sym_gtr, sym_geq
            
        case else
			return false
	end select
	return true
end function

function unary_prec(symbol as long) as long
	select case symbol
		case sym_neg, sym_not
			return 70
		case else
			return 0
	end select
end function

function binary_prec(symbol as long) as long
	select case symbol
		case sym_multiply, sym_divide, sym_mod
			return 60
			
		case sym_plus, sym_minus
			return 50
			
		case sym_lss, sym_leq, sym_gtr, sym_geq
			return 40
			
		case sym_equal, sym_neq
			return 30
			
		case sym_or
			return 20
			
		case sym_and
			return 10
			
		case else
			return 0
	end select
end function

function associativity(symbol as long) as long
	return left_assoc
end function

sub primary()
	dim as long op
    dim as long address
	select case sym
		case sym_integer_const
			emit2(op_push_int, val(token))
			next_sym()
		case sym_ident
			if not is_in_sym_tab(address) then
				error_msg("primary: '" & token & "' has not been defined")
			end if
			emit2(op_push_int_var, address)
			next_sym()
		case sym_lparen
			next_sym()
			expr(0)
			if sym <> sym_rparen then
				error_msg("expecting ')'")
			end if
			next_sym()
		case sym_minus, sym_not
			op = sym
			if sym = sym_minus then
				op = sym_neg
			end if
			next_sym()
			expr(unary_prec(op))
			emit_op(op)
		case else
			error_msg("expecting number")
	end select
end sub

sub expr(p as long)
	dim as long op
	dim as long tmp
	
	primary()
	while is_binary_operator(sym) and binary_prec(sym) >= p
		op = sym
		next_sym()
		tmp = 0
		if associativity(op) = left_assoc then tmp = 1
		expr(binary_prec(op) + tmp)
		emit_op(op)
		if is_relational_operator(op) and is_relational_operator(sym) then
			error_msg("consecutive relational operators not allowed")
		end if
	wend
end sub

' ident = expr
sub assign_stmt()
	dim address as long

    if not is_in_sym_tab(address) then
		error_msg("assign: '" & token & "' has not been defined")
	end if
	
	expect(sym_ident)
	expect(sym_equal)
	expr(0)
	emit2(op_stor, address)
end sub

' if expr then stmt_seq (else stmt_seq) end if
sub if_stmt()
	dim as long fix1
	dim as long fix2
	
	fix2 = -1
	expect(sym_if)
	expr(0)
	fix1 = emit2(op_jz, 0)
	expect(sym_then)
	stmt_seq()
	if sym = sym_else then
		fix2 = emit2(op_jmp, 0)
		patch_jmp_to_current(fix1)
		expect(sym_else)
		stmt_seq()
	else
		patch_jmp_to_current(fix1)
	end if
	expect(sym_end)
	expect(sym_if)
	if fix2 <> -1 then
		patch_jmp_to_current(fix2)
	end if
end sub

sub halt_stmt()
	emit(op_halt)
	next_sym()
end sub

' while expr do stmts end while
sub while_stmt()
	dim as long top
	dim as long fix1
	
	expect(sym_while)
	top = get_cur_loc()
	expr(0)
	fix1 = emit2(op_jz, 0)
	expect(sym_do)
	stmt_seq()
	emit2(op_jmp, top)
	patch_jmp_to_current(fix1)
	expect(sym_end)
	expect(sym_while)
end sub

sub do_string()
	dim as long i
	
	for i = 1 to len(token)
		emit(asc(mid(token, i, 1)))
	next
	next_sym()
end sub

' print expr|string {, expr|string}
sub print_stmt()
	do
		next_sym()
		if sym = sym_string_const then
			emit2(op_prt_str, len(token))
			do_string()
		elseif sym = sym_integer_const or sym = sym_ident then
			expr(0)
			emit(op_prt_int)
		else
			error_msg("expecting string or integer")
		end if
        if sym <> sym_comma then exit do
	end do
	emit(op_prt_nl)
end sub

' {print | halt | while | assign | if}
sub stmt_seq()
	while sym <> sym_eoi and sym <> sym_end and sym <> sym_else
		select case sym
			case sym_print: print_stmt()
			case sym_halt: halt_stmt()
			case sym_if: if_stmt()
			case sym_while: while_stmt()
			case sym_ident: assign_stmt()
			case else: error_msg("unrecognized statement: (" & str(sym) & ") " & token)
		end select
	wend
end sub

' {integer ident {, ident}}
sub variable_decl()
	dim address as long
	while sym = sym_integer_var
		expect(sym_integer_var)
		do
			if is_in_sym_tab(address) then
				error_msg("'" & token & "' has already been defined")
			end if
			insert_sym_tab()
			expect(sym_ident)
			if sym <> sym_comma then exit do
			expect(sym_comma)
		end do
	wend
end sub

' {variable_decl} stmt_seq
sub parse()
	next_sym()
	variable_decl()
	stmt_seq()
	if sym <> sym_eoi then
		error_msg("a statement was expected")
	end if
	emit(op_halt)
	set_data_size(get_data_size())
end sub

'------ other stuff ---------------------------------------------------

sub error_msg(msg as string)
	print "line=" error_line "; col=" error_col " << " msg cr
	press_a_key()
end sub

'-------------- utilities -----------------------------------------------

function is_alpha() as long
    byte c = asc(cur_ch)
    select case c
        case "a" to "z", "A" to "Z"
            return true
    end select
    return false
end function

//// ML: NOT USED
//function is_print(ch as string) as long
//	dim as long asc_ch = asc(ch)
//	return ch <> "" and asc_ch >= 32 and asc_ch <= 126
//end function

function is_numeric() as long
    byte c = asc(cur_ch)
    select case c
        case "0" to "9"
            return true
    end select
    return false
end function

sub press_a_key()
    print cr "Press any key to continue..."
    waitkey
end sub

' ----------------------------------------------------------------------

function get_line() as string // PARSE CODE BUFFER INTO SUCCESSIVE LINES
	static as long head = 1
    static as string crlf = chr(13) & chr(10)
	dim as long tail
	dim as string ret

    tail = instr(head, code, crlf)
	ret = mid(code, head, tail - head)
	head = tail + 2

    return ret
end function