376 lines
8.4 KiB
Plaintext
376 lines
8.4 KiB
Plaintext
# -*- Icon -*-
|
||
#
|
||
# The Rosetta Code virtual machine in Icon. Migrated from the
|
||
# ObjectIcon.
|
||
#
|
||
# See https://rosettacode.org/wiki/Compiler/virtual_machine_interpreter
|
||
#
|
||
|
||
record VirtualMachine(code, global_data, strings, stack, pc)
|
||
|
||
global opcode_names
|
||
global opcode_values
|
||
global op_halt
|
||
global op_add
|
||
global op_sub
|
||
global op_mul
|
||
global op_div
|
||
global op_mod
|
||
global op_lt
|
||
global op_gt
|
||
global op_le
|
||
global op_ge
|
||
global op_eq
|
||
global op_ne
|
||
global op_and
|
||
global op_or
|
||
global op_neg
|
||
global op_not
|
||
global op_prtc
|
||
global op_prti
|
||
global op_prts
|
||
global op_fetch
|
||
global op_store
|
||
global op_push
|
||
global op_jmp
|
||
global op_jz
|
||
|
||
global whitespace_chars
|
||
|
||
procedure main(args)
|
||
local f_inp, f_out
|
||
local vm
|
||
|
||
whitespace_chars := ' \t\n\r\f\v'
|
||
initialize_opcodes()
|
||
|
||
if 3 <= *args then {
|
||
write("Usage: ", &progname, " [INPUT_FILE [OUTPUT_FILE]]")
|
||
exit(1)
|
||
}
|
||
|
||
if 1 <= *args then {
|
||
f_inp := open(args[1], "r") | {
|
||
write(&errout, "Failed to open ", args[1], " for reading.")
|
||
exit(1)
|
||
}
|
||
} else {
|
||
f_inp := &input
|
||
}
|
||
|
||
if 2 <= *args then {
|
||
f_out := open(args[2], "w") | {
|
||
write(&errout, "Failed to open ", args[2], " for writing.")
|
||
exit(1)
|
||
}
|
||
} else {
|
||
f_out := &output
|
||
}
|
||
|
||
vm := VirtualMachine()
|
||
read_assembly_code(f_inp, vm)
|
||
run_vm(f_out, vm)
|
||
end
|
||
|
||
procedure initialize_opcodes()
|
||
local i
|
||
|
||
opcode_names :=
|
||
["halt", "add", "sub", "mul", "div",
|
||
"mod", "lt", "gt", "le", "ge",
|
||
"eq", "ne", "and", "or", "neg",
|
||
"not", "prtc", "prti", "prts", "fetch",
|
||
"store", "push", "jmp", "jz"]
|
||
|
||
opcode_values := table()
|
||
every i := 1 to *opcode_names do
|
||
opcode_values[opcode_names[i]] := char(i)
|
||
|
||
op_halt := opcode_values["halt"]
|
||
op_add := opcode_values["add"]
|
||
op_sub := opcode_values["sub"]
|
||
op_mul := opcode_values["mul"]
|
||
op_div := opcode_values["div"]
|
||
op_mod := opcode_values["mod"]
|
||
op_lt := opcode_values["lt"]
|
||
op_gt := opcode_values["gt"]
|
||
op_le := opcode_values["le"]
|
||
op_ge := opcode_values["ge"]
|
||
op_eq := opcode_values["eq"]
|
||
op_ne := opcode_values["ne"]
|
||
op_and := opcode_values["and"]
|
||
op_or := opcode_values["or"]
|
||
op_neg := opcode_values["neg"]
|
||
op_not := opcode_values["not"]
|
||
op_prtc := opcode_values["prtc"]
|
||
op_prti := opcode_values["prti"]
|
||
op_prts := opcode_values["prts"]
|
||
op_fetch := opcode_values["fetch"]
|
||
op_store := opcode_values["store"]
|
||
op_push := opcode_values["push"]
|
||
op_jmp := opcode_values["jmp"]
|
||
op_jz := opcode_values["jz"]
|
||
end
|
||
|
||
procedure int2bytes (n)
|
||
local bytes
|
||
|
||
# The VM is little-endian.
|
||
|
||
bytes := "****"
|
||
bytes[1] := char (iand(n, 16rFF))
|
||
bytes[2] := char(iand(ishift(n, -8), 16rFF))
|
||
bytes[3] := char(iand(ishift(n, -16), 16rFF))
|
||
bytes[4] := char(iand(ishift(n, -24), 16rFF))
|
||
return bytes
|
||
end
|
||
|
||
procedure bytes2int(bytes, i)
|
||
local n0, n1, n2, n3, n
|
||
|
||
# The VM is little-endian.
|
||
|
||
n0 := ord(bytes[i])
|
||
n1 := ishift(ord(bytes[i + 1]), 8)
|
||
n2 := ishift(ord(bytes[i + 2]), 16)
|
||
n3 := ishift(ord(bytes[i + 3]), 24)
|
||
n := ior (n0, ior (n1, ior (n2, n3)))
|
||
|
||
# Do not forget to extend the sign bit.
|
||
return (if n3 <= 16r7F then n else ior(n, icom(16rFFFFFFFF)))
|
||
end
|
||
|
||
procedure read_assembly_code(f, vm)
|
||
local data_size, number_of_strings
|
||
local line, ch
|
||
local i
|
||
local address
|
||
local opcode
|
||
|
||
# Read the header line.
|
||
line := read(f) | bad_vm()
|
||
line ? {
|
||
tab(many(whitespace_chars))
|
||
tab(match("Datasize")) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(any(':')) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
data_size :=
|
||
integer(tab(many(&digits))) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(match("Strings")) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(any(':')) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
number_of_strings :=
|
||
integer(tab(many(&digits))) | bad_vm()
|
||
}
|
||
|
||
# Read the strings.
|
||
vm.strings := list(number_of_strings)
|
||
every i := 1 to number_of_strings do {
|
||
vm.strings[i] := ""
|
||
line := read(f) | bad_vm()
|
||
line ? {
|
||
tab(many(whitespace_chars))
|
||
tab(any('"')) | bad_vm()
|
||
while ch := tab(any(~'"')) do {
|
||
if ch == '\\' then {
|
||
ch := tab(any('n\\')) | bad_vm()
|
||
vm.strings[i] ||:=
|
||
(if (ch == "n") then "\n" else "\\")
|
||
} else {
|
||
vm.strings[i] ||:= ch
|
||
}
|
||
}
|
||
}
|
||
}
|
||
|
||
# Read the code.
|
||
vm.code := ""
|
||
while line := read(f) do {
|
||
line ? {
|
||
tab(many(whitespace_chars))
|
||
address := integer(tab(many(&digits))) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
opcode := tab(many(~whitespace_chars)) | bad_vm()
|
||
vm.code ||:= opcode_values[opcode]
|
||
case opcode of {
|
||
"push": {
|
||
tab(many(whitespace_chars))
|
||
vm.code ||:=
|
||
int2bytes(integer(tab(many(&digits)))) |
|
||
int2bytes(integer(tab(any('-')) ||
|
||
tab(many(&digits)))) |
|
||
bad_vm()
|
||
}
|
||
"fetch" | "store": {
|
||
tab(many(whitespace_chars))
|
||
tab(any('[')) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
vm.code ||:=
|
||
int2bytes(integer(tab(many(&digits)))) |
|
||
bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(any(']')) | bad_vm()
|
||
}
|
||
"jmp" | "jz": {
|
||
tab(many(whitespace_chars))
|
||
tab(any('(')) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
vm.code ||:=
|
||
int2bytes(integer(tab(many(&digits)))) |
|
||
int2bytes(integer(tab(any('-')) ||
|
||
tab(many(&digits)))) |
|
||
bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(any(')')) | bad_vm()
|
||
tab(many(whitespace_chars))
|
||
tab(many(&digits)) | bad_vm()
|
||
}
|
||
default: {
|
||
# Do nothing
|
||
}
|
||
}
|
||
}
|
||
}
|
||
|
||
# Create a global data area.
|
||
vm.global_data := list(data_size, &null)
|
||
|
||
initialize_vm(vm)
|
||
end
|
||
|
||
procedure run_vm(f_out, vm)
|
||
initialize_vm(vm)
|
||
continue_vm(f_out, vm)
|
||
end
|
||
|
||
procedure continue_vm(f_out, vm)
|
||
while vm.code[vm.pc] ~== op_halt do
|
||
step_vm(f_out, vm)
|
||
end
|
||
|
||
procedure step_vm(f_out, vm)
|
||
local opcode
|
||
|
||
opcode := vm.code[vm.pc]
|
||
vm.pc +:= 1
|
||
case opcode of {
|
||
op_add: binop(vm, "+")
|
||
op_sub: binop(vm, "-")
|
||
op_mul: binop(vm, "*")
|
||
op_div: binop(vm, "/")
|
||
op_mod: binop(vm, "%")
|
||
op_lt: comparison(vm, "<")
|
||
op_gt: comparison(vm, ">")
|
||
op_le: comparison(vm, "<=")
|
||
op_ge: comparison(vm, ">=")
|
||
op_eq: comparison(vm, "=")
|
||
op_ne: comparison(vm, "~=")
|
||
op_and: logical_and(vm)
|
||
op_or: logical_or(vm)
|
||
op_neg: negate(vm)
|
||
op_not: logical_not(vm)
|
||
op_prtc: printc(f_out, vm)
|
||
op_prti: printi(f_out, vm)
|
||
op_prts: prints(f_out, vm)
|
||
op_fetch: fetch_global(vm)
|
||
op_store: store_global(vm)
|
||
op_push: push_argument(vm)
|
||
op_jmp: jump(vm)
|
||
op_jz: jump_if_zero(vm)
|
||
default: bad_opcode()
|
||
}
|
||
end
|
||
|
||
procedure negate(vm)
|
||
vm.stack[1] := -vm.stack[1]
|
||
end
|
||
|
||
procedure binop(vm, func)
|
||
vm.stack[2] := func(vm.stack[2], vm.stack[1])
|
||
pop(vm.stack)
|
||
end
|
||
|
||
procedure comparison(vm, func)
|
||
vm.stack[2] := (if func(vm.stack[2], vm.stack[1]) then 1 else 0)
|
||
pop(vm.stack)
|
||
end
|
||
|
||
procedure logical_and(vm)
|
||
vm.stack[2] :=
|
||
(if vm.stack[2] ~= 0 & vm.stack[1] ~= 0 then 1 else 0)
|
||
pop(vm.stack)
|
||
end
|
||
|
||
procedure logical_or(vm)
|
||
vm.stack[2] :=
|
||
(if vm.stack[2] ~= 0 | vm.stack[1] ~= 0 then 1 else 0)
|
||
pop(vm.stack)
|
||
end
|
||
|
||
procedure logical_not(vm)
|
||
vm.stack[1] := (if vm.stack[1] ~= 0 then 0 else 1)
|
||
end
|
||
|
||
procedure printc(f_out, vm)
|
||
writes(f_out, char(pop(vm.stack)))
|
||
end
|
||
|
||
procedure printi(f_out, vm)
|
||
writes(f_out, pop(vm.stack))
|
||
end
|
||
|
||
procedure prints(f_out, vm)
|
||
writes(f_out, vm.strings[pop(vm.stack) + 1])
|
||
end
|
||
|
||
procedure fetch_global(vm)
|
||
push(vm.stack, vm.global_data[get_argument(vm) + 1])
|
||
vm.pc +:= 4
|
||
end
|
||
|
||
procedure store_global(vm)
|
||
vm.global_data[get_argument(vm) + 1] := pop(vm.stack)
|
||
vm.pc +:= 4
|
||
end
|
||
|
||
procedure push_argument(vm)
|
||
push(vm.stack, get_argument(vm))
|
||
vm.pc +:= 4
|
||
end
|
||
|
||
procedure jump(vm)
|
||
vm.pc +:= get_argument(vm)
|
||
end
|
||
|
||
procedure jump_if_zero(vm)
|
||
if pop(vm.stack) = 0 then
|
||
vm.pc +:= get_argument(vm)
|
||
else
|
||
vm.pc +:= 4
|
||
end
|
||
|
||
procedure get_argument(vm)
|
||
return bytes2int(vm.code, vm.pc)
|
||
end
|
||
|
||
procedure initialize_vm(vm)
|
||
# The program counter starts at 1, for convenient indexing into
|
||
# the code[] array. Icon indexing starts at 1 (for a *very* good
|
||
# reason, but that’s a topic for another day).
|
||
vm.pc := 1
|
||
vm.stack := []
|
||
end
|
||
|
||
procedure bad_vm()
|
||
write(&errout, "Bad VM.")
|
||
exit(1)
|
||
end
|
||
|
||
procedure bad_opcode()
|
||
write(&errout, "Bad opcode.")
|
||
exit(1)
|
||
end
|