Compiler/virtual machine interpreter
< Compiler
You are encouraged to solve this task according to the task description, using any language you may know.
Virtual Machine Interpreter
A virtual machine implements a computer in software.
Write a virtual machine interpreter. This interpreter should be able to run virtual assembly language programs created via the task. This is a byte-coded, 32-bit word stack based virtual machine.
The program should read input from a file and/or stdin, and write output to a file and/or stdout.
Input format
Given the following program:
count = 1;
while (count < 10) {
print("count is: ", count, "\n");
count = count + 1;
}
The output from the Code generator is a virtual assembly code program:
| Output from gen, input to VM |
|---|
Datasize: 1 Strings: 2
"count is: "
"\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (43) 65
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-51) 10
65 halt
|
The first line of the input specifies the datasize required and the number of constant strings, in the order that they are reference via the code.
The data can be stored in a separate array, or the data can be stored at the beginning of the stack. Data is addressed starting at 0. If there are 3 variables, the 3rd one if referenced at address 2.
If there are one or more constant strings, they come next. The code refers to these strings by their index. The index starts at 0. So if there are 3 strings, and the code wants to reference the 3rd string, 2 will be used.
Next comes the actual virtual assembly code. The first number is the code address of that instruction. After that is the instruction mnemonic, followed by optional operands, depending on the instruction.
Registers
sp:
the stack pointer - points to the next top of stack. The stack is a 32-bit integer array.
pc:
the program counter - points to the current instruction to be performed. The code is an array of bytes.
Data:
data string pool
Instructions
Each instruction is one byte. The following instructions also have a 32-bit integer operand:
fetch [index]
where index is an index into the data array.
store [index]
where index is an index into the data array.
push n
where value is a 32-bit integer that will be pushed onto the stack.
jmp (n) addr
where (n) is a 32-bit integer specifying the distance between the current location and the desired location. addr is an unsigned value of the actual code address.
jz (n) addr
where (n) is a 32-bit integer specifying the distance between the current location and the desired location. addr is an unsigned value of the actual code address.
The following instructions do not have an operand. They perform their operation directly against the stack:
For the following instructions, the operation is performed against the top two entries in the stack:
add sub mul div mod lt gt le ge eq ne and or
For the following instructions, the operation is performed against the top entry in the stack:
neg not
Print the word at stack top as a character.
prtc
Print the word at stack top as an integer.
prti
Stack top points to an index into the string pool. Print that entry.
prts
Unconditional stop.
halt
- A simple example virtual machine
def run_vm(data_size)
int stack[data_size + 1000]
set stack[0..data_size - 1] to 0
int pc = 0
while True:
op = code[pc]
pc += 1
if op == FETCH:
stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
pc += word_size
elif op == STORE:
stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
pc += word_size
elif op == PUSH:
stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
pc += word_size
elif op == ADD: stack[-2] += stack[-1]; stack.pop()
elif op == SUB: stack[-2] -= stack[-1]; stack.pop()
elif op == MUL: stack[-2] *= stack[-1]; stack.pop()
elif op == DIV: stack[-2] /= stack[-1]; stack.pop()
elif op == MOD: stack[-2] %= stack[-1]; stack.pop()
elif op == LT: stack[-2] = stack[-2] < stack[-1]; stack.pop()
elif op == GT: stack[-2] = stack[-2] > stack[-1]; stack.pop()
elif op == LE: stack[-2] = stack[-2] <= stack[-1]; stack.pop()
elif op == GE: stack[-2] = stack[-2] >= stack[-1]; stack.pop()
elif op == EQ: stack[-2] = stack[-2] == stack[-1]; stack.pop()
elif op == NE: stack[-2] = stack[-2] != stack[-1]; stack.pop()
elif op == AND: stack[-2] = stack[-2] and stack[-1]; stack.pop()
elif op == OR: stack[-2] = stack[-2] or stack[-1]; stack.pop()
elif op == NEG: stack[-1] = -stack[-1]
elif op == NOT: stack[-1] = not stack[-1]
elif op == JMP: pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == JZ: if stack.pop() then pc += word_size else pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == PRTC: print stack[-1] as a character; stack.pop()
elif op == PRTS: print the constant string referred to by stack[-1]; stack.pop()
elif op == PRTI: print stack[-1] as an integer; stack.pop()
elif op == HALT: break
- Additional examples
Your solution should pass all the test cases above and the additional tests found Here.
Reference
The C and Python versions can be considered reference implementations.
- Related Tasks
Ada
This program outputs only the standard output, because I did not feel like implementing stream output to a named file. (Text I/O would have appended a newline or some such page-ender to the output.) One does not really need more than standard output for this task.
This Ada program is one of the faster implementations I have written, but you have to turn off runtime checks to get that speed.
--
-- The Rosetta Code Virtual Machine, in Ada.
--
-- It is assumed the platform on which this program is run
-- has two's-complement integers. (Otherwise one could modify
-- the vmint_to_vmsigned and vmsigned_to_vmint functions. But
-- the chances your binary integers are not two's-complement
-- seem pretty low.)
--
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Text_Streams; use Ada.Text_IO.Text_Streams;
with Ada.Unchecked_Conversion;
procedure VM
is
bad_vm : exception;
vm_limit_exceeded : exception;
vm_runtime_error : exception;
status : Exit_Status;
input_file_name : Unbounded_String;
output_file_name : Unbounded_String;
input_file : File_Type;
output_file : File_Type;
-- Some limits of this implementation. You can adjust these to taste.
strings_size : constant := 2_048;
stack_size : constant := 2_048;
data_size : constant := 2_048;
code_size : constant := 32_768;
type byte is mod 16#100#;
type vmint is mod 16#1_0000_0000#;
subtype vmsigned is Integer range -2_147_483_648 .. 2_147_483_647;
op_halt : constant byte := 0;
op_add : constant byte := 1;
op_sub : constant byte := 2;
op_mul : constant byte := 3;
op_div : constant byte := 4;
op_mod : constant byte := 5;
op_lt : constant byte := 6;
op_gt : constant byte := 7;
op_le : constant byte := 8;
op_ge : constant byte := 9;
op_eq : constant byte := 10;
op_ne : constant byte := 11;
op_and : constant byte := 12;
op_or : constant byte := 13;
op_neg : constant byte := 14;
op_not : constant byte := 15;
op_prtc : constant byte := 16;
op_prti : constant byte := 17;
op_prts : constant byte := 18;
op_fetch : constant byte := 19;
op_store : constant byte := 20;
op_push : constant byte := 21;
op_jmp : constant byte := 22;
op_jz : constant byte := 23;
strings : array (0 .. strings_size - 1) of Unbounded_String;
stack : array (0 .. stack_size - 1) of vmint;
data : array (0 .. data_size - 1) of vmint;
code : array (0 .. code_size) of byte;
sp : vmint;
pc : vmint;
output_stream : Stream_Access;
function vmsigned_to_vmint is new Ada.Unchecked_Conversion
(Source => vmsigned, Target => vmint);
function vmint_to_vmsigned is new Ada.Unchecked_Conversion
(Source => vmint, Target => vmsigned);
function twos_complement
(x : in vmint)
return vmint
is
begin
return (not x) + 1;
end twos_complement;
function vmint_to_digits
(x : in vmint)
return Unbounded_String
is
s : Unbounded_String;
z : vmint;
begin
if x = 0 then
s := To_Unbounded_String ("0");
else
s := To_Unbounded_String ("");
z := x;
while z /= 0 loop
s := Character'Val ((z rem 10) + Character'Pos ('0')) & s;
z := z / 10;
end loop;
end if;
return s;
end vmint_to_digits;
function digits_to_vmint
(s : in String)
return vmint
is
zero : constant Character := '0';
zero_pos : constant Integer := Character'Pos (zero);
retval : vmint;
begin
if s'Length < 1 then
raise bad_vm with "expected a numeric literal";
end if;
retval := 0;
for i in s'Range loop
if Is_Decimal_Digit (s (i)) then
retval :=
(10 * retval) + vmint (Character'Pos (s (i)) - zero_pos);
else
raise bad_vm with "expected a decimal digit";
end if;
end loop;
return retval;
end digits_to_vmint;
function string_to_vmint
(s : in String)
return vmint
is
retval : vmint;
begin
if s'Length < 1 then
raise bad_vm with "expected a numeric literal";
end if;
if s (s'First) = '-' then
if s'Length < 2 then
raise bad_vm with "expected a numeric literal";
end if;
retval :=
twos_complement (digits_to_vmint (s (s'First + 1 .. s'Last)));
else
retval := digits_to_vmint (s);
end if;
return retval;
end string_to_vmint;
procedure parse_header
(s : in String;
data_count : out vmint;
strings_count : out vmint)
is
i : Positive;
j : Positive;
begin
i := s'First;
while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
i := i + 1;
end loop;
j := i;
while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
j := j + 1;
end loop;
data_count := digits_to_vmint (s (i .. j - 1));
i := j;
while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
i := i + 1;
end loop;
j := i;
while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
j := j + 1;
end loop;
strings_count := digits_to_vmint (s (i .. j - 1));
end parse_header;
function parse_string_literal
(s : in String)
return Unbounded_String
is
t : Unbounded_String;
i : Positive;
--
-- A little trick to get around mistaken highlighting on the
-- Rosetta Code site.
--
quote_string : constant String := """";
quote : constant Character := quote_string (1);
begin
t := To_Unbounded_String ("");
i := s'First;
while i <= s'Last and then s (i) /= quote loop
i := i + 1;
end loop;
if s'Last < i or else s (i) /= quote then
raise bad_vm with "expected a '""'";
end if;
i := i + 1;
while i <= s'Last and then s (i) /= quote loop
if s (i) /= '\' then
Append (t, s (i));
i := i + 1;
elsif s'Last < i + 1 then
raise bad_vm with "truncated string literal";
elsif s (i + 1) = 'n' then
Append (t, Character'Val (10));
i := i + 2;
elsif s (i + 1) = '\' then
Append (t, '\');
i := i + 2;
else
raise bad_vm with "unsupported escape sequence";
end if;
end loop;
return t;
end parse_string_literal;
function name_to_opcode
(s : in String)
return byte
is
retval : byte;
begin
if s = "halt" then
retval := op_halt;
elsif s = "add" then
retval := op_add;
elsif s = "sub" then
retval := op_sub;
elsif s = "mul" then
retval := op_mul;
elsif s = "div" then
retval := op_div;
elsif s = "mod" then
retval := op_mod;
elsif s = "lt" then
retval := op_lt;
elsif s = "gt" then
retval := op_gt;
elsif s = "le" then
retval := op_le;
elsif s = "ge" then
retval := op_ge;
elsif s = "eq" then
retval := op_eq;
elsif s = "ne" then
retval := op_ne;
elsif s = "and" then
retval := op_and;
elsif s = "or" then
retval := op_or;
elsif s = "neg" then
retval := op_neg;
elsif s = "not" then
retval := op_not;
elsif s = "prtc" then
retval := op_prtc;
elsif s = "prti" then
retval := op_prti;
elsif s = "prts" then
retval := op_prts;
elsif s = "fetch" then
retval := op_fetch;
elsif s = "store" then
retval := op_store;
elsif s = "push" then
retval := op_push;
elsif s = "jmp" then
retval := op_jmp;
elsif s = "jz" then
retval := op_jz;
else
raise bad_vm with ("unexpected opcode name");
end if;
return retval;
end name_to_opcode;
procedure parse_instruction
(s : in String;
address : out vmint;
opcode : out byte;
arg : out vmint)
is
i : Positive;
j : Positive;
begin
i := s'First;
while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
i := i + 1;
end loop;
j := i;
while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
j := j + 1;
end loop;
address := digits_to_vmint (s (i .. j - 1));
i := j;
while i <= s'Last and then not Is_Letter (s (i)) loop
i := i + 1;
end loop;
j := i;
while j <= s'Last and then Is_Letter (s (j)) loop
j := j + 1;
end loop;
opcode := name_to_opcode (s (i .. j - 1));
i := j;
while i <= s'Last and then Is_Space (s (i)) loop
i := i + 1;
end loop;
if s'Last < i then
arg := 0;
else
if not Is_Decimal_Digit (s (i)) and then s (i) /= '-' then
i := i + 1;
end if;
j := i;
while j <= s'Last
and then (Is_Decimal_Digit (s (j)) or else s (j) = '-')
loop
j := j + 1;
end loop;
arg := string_to_vmint (s (i .. j - 1));
end if;
end parse_instruction;
procedure read_and_parse_header
(data_count : out vmint;
strings_count : out vmint)
is
line : Unbounded_String;
begin
Get_Line (Current_Input, line);
parse_header (To_String (line), data_count, strings_count);
end read_and_parse_header;
procedure read_parse_and_store_strings
(strings_count : in vmint)
is
line : Unbounded_String;
begin
if strings_count /= 0 then
if strings_size < strings_count then
raise vm_limit_exceeded with "strings limit exceeded";
end if;
for i in 0 .. strings_count - 1 loop
Get_Line (Current_Input, line);
strings (Integer (i)) :=
parse_string_literal (To_String (line));
end loop;
end if;
end read_parse_and_store_strings;
function opcode_takes_arg
(opcode : in byte)
return Boolean
is
retval : Boolean;
begin
if opcode = op_fetch then
retval := True;
elsif opcode = op_store then
retval := True;
elsif opcode = op_push then
retval := True;
elsif opcode = op_jmp then
retval := True;
elsif opcode = op_jz then
retval := True;
else
retval := False;
end if;
return retval;
end opcode_takes_arg;
procedure read_parse_and_store_instructions
is
line : Unbounded_String;
address : vmint;
opcode : byte;
arg : vmint;
j : Positive;
begin
while not End_Of_File (Current_Input) loop
Get_Line (Current_Input, line);
j := 1;
while j <= Length (line) and then Is_Space (Element (line, j))
loop
j := j + 1;
end loop;
if j <= Length (line) then
parse_instruction (To_String (line), address, opcode, arg);
if opcode_takes_arg (opcode) then
if code_size - 4 <= address then
raise vm_limit_exceeded with "code space limit exceeded";
end if;
code (Integer (address)) := opcode;
--
-- Little-endian storage.
--
code (Integer (address) + 1) := byte (arg and 16#FF#);
code (Integer (address) + 2) :=
byte ((arg / 16#100#) and 16#FF#);
code (Integer (address) + 3) :=
byte ((arg / 16#1_0000#) and 16#FF#);
code (Integer (address) + 4) :=
byte ((arg / 16#100_0000#) and 16#FF#);
else
if code_size <= address then
raise vm_limit_exceeded with "code space limit exceeded";
end if;
code (Integer (address)) := opcode;
end if;
end if;
end loop;
end read_parse_and_store_instructions;
procedure read_parse_and_store_program
is
data_count : vmint;
strings_count : vmint;
begin
read_and_parse_header (data_count, strings_count);
read_parse_and_store_strings (strings_count);
read_parse_and_store_instructions;
end read_parse_and_store_program;
procedure pop_value
(x : out vmint)
is
begin
if sp = 0 then
raise vm_runtime_error with "stack underflow";
end if;
sp := sp - 1;
x := stack (Integer (sp));
end pop_value;
procedure push_value
(x : in vmint)
is
begin
if stack_size <= sp then
raise vm_runtime_error with "stack overflow";
end if;
stack (Integer (sp)) := x;
sp := sp + 1;
end push_value;
procedure get_value
(x : out vmint)
is
begin
if sp = 0 then
raise vm_runtime_error with "stack underflow";
end if;
x := stack (Integer (sp) - 1);
end get_value;
procedure put_value
(x : in vmint)
is
begin
if sp = 0 then
raise vm_runtime_error with "stack underflow";
end if;
stack (Integer (sp) - 1) := x;
end put_value;
procedure fetch_value
(i : in vmint;
x : out vmint)
is
begin
if data_size <= i then
raise vm_runtime_error with "data boundary exceeded";
end if;
x := data (Integer (i));
end fetch_value;
procedure store_value
(i : in vmint;
x : in vmint)
is
begin
if data_size <= i then
raise vm_runtime_error with "data boundary exceeded";
end if;
data (Integer (i)) := x;
end store_value;
procedure immediate_value
(x : out vmint)
is
b0, b1, b2, b3 : vmint;
begin
if code_size - 4 <= pc then
raise vm_runtime_error with "code boundary exceeded";
end if;
--
-- Little-endian order.
--
b0 := vmint (code (Integer (pc)));
b1 := vmint (code (Integer (pc) + 1));
b2 := vmint (code (Integer (pc) + 2));
b3 := vmint (code (Integer (pc) + 3));
x :=
b0 + (16#100# * b1) + (16#1_0000# * b2) + (16#100_0000# * b3);
end immediate_value;
procedure machine_add
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
put_value (x + y);
end machine_add;
procedure machine_sub
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
put_value (x - y);
end machine_sub;
procedure machine_mul
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
put_value
(vmsigned_to_vmint
(vmint_to_vmsigned (x) * vmint_to_vmsigned (y)));
end machine_mul;
procedure machine_div
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
put_value
(vmsigned_to_vmint
(vmint_to_vmsigned (x) / vmint_to_vmsigned (y)));
end machine_div;
procedure machine_mod
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
put_value
(vmsigned_to_vmint
(vmint_to_vmsigned (x) rem vmint_to_vmsigned (y)));
end machine_mod;
procedure machine_lt
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if vmint_to_vmsigned (x) < vmint_to_vmsigned (y) then
put_value (1);
else
put_value (0);
end if;
end machine_lt;
procedure machine_gt
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if vmint_to_vmsigned (x) > vmint_to_vmsigned (y) then
put_value (1);
else
put_value (0);
end if;
end machine_gt;
procedure machine_le
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if vmint_to_vmsigned (x) <= vmint_to_vmsigned (y) then
put_value (1);
else
put_value (0);
end if;
end machine_le;
procedure machine_ge
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if vmint_to_vmsigned (x) >= vmint_to_vmsigned (y) then
put_value (1);
else
put_value (0);
end if;
end machine_ge;
procedure machine_eq
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if x = y then
put_value (1);
else
put_value (0);
end if;
end machine_eq;
procedure machine_ne
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if x /= y then
put_value (1);
else
put_value (0);
end if;
end machine_ne;
procedure machine_and
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if x /= 0 and y /= 0 then
put_value (1);
else
put_value (0);
end if;
end machine_and;
procedure machine_or
is
x, y : vmint;
begin
pop_value (y);
get_value (x);
if x /= 0 or y /= 0 then
put_value (1);
else
put_value (0);
end if;
end machine_or;
procedure machine_neg
is
x : vmint;
begin
get_value (x);
put_value (twos_complement (x));
end machine_neg;
procedure machine_not
is
x : vmint;
begin
get_value (x);
if x = 0 then
put_value (1);
else
put_value (0);
end if;
end machine_not;
procedure machine_prtc
is
x : vmint;
begin
pop_value (x);
Character'Write (output_stream, Character'Val (x));
end machine_prtc;
procedure machine_prti
is
x : vmint;
begin
pop_value (x);
if 16#7FFF_FFFF# < x then
Character'Write (output_stream, '-');
String'Write
(output_stream,
To_String (vmint_to_digits (twos_complement (x))));
else
String'Write (output_stream, To_String (vmint_to_digits (x)));
end if;
end machine_prti;
procedure machine_prts
is
k : vmint;
begin
pop_value (k);
if strings_size <= k then
raise vm_runtime_error with "strings boundary exceeded";
end if;
String'Write (output_stream, To_String (strings (Integer (k))));
end machine_prts;
procedure machine_fetch
is
k : vmint;
x : vmint;
begin
immediate_value (k);
fetch_value (k, x);
push_value (x);
pc := pc + 4;
end machine_fetch;
procedure machine_store
is
k : vmint;
x : vmint;
begin
immediate_value (k);
pop_value (x);
store_value (k, x);
pc := pc + 4;
end machine_store;
procedure machine_push
is
x : vmint;
begin
immediate_value (x);
push_value (x);
pc := pc + 4;
end machine_push;
procedure machine_jmp
is
offset : vmint;
begin
immediate_value (offset);
pc := pc + offset;
end machine_jmp;
procedure machine_jz
is
x : vmint;
offset : vmint;
begin
pop_value (x);
if x = 0 then
immediate_value (offset);
pc := pc + offset;
else
pc := pc + 4;
end if;
end machine_jz;
procedure machine_step
(halt : out Boolean)
is
opcode : byte;
op_div_4, op_rem_4 : byte;
begin
if code_size <= pc then
raise vm_runtime_error with "code boundary exceeded";
end if;
opcode := code (Integer (pc));
pc := pc + 1;
halt := False;
op_div_4 := opcode / 4;
op_rem_4 := opcode rem 4;
if op_div_4 = 0 then
if op_rem_4 = 0 then
halt := True;
elsif op_rem_4 = 1 then
machine_add;
elsif op_rem_4 = 2 then
machine_sub;
else
machine_mul;
end if;
elsif op_div_4 = 1 then
if op_rem_4 = 0 then
machine_div;
elsif op_rem_4 = 1 then
machine_mod;
elsif op_rem_4 = 2 then
machine_lt;
else
machine_gt;
end if;
elsif op_div_4 = 2 then
if op_rem_4 = 0 then
machine_le;
elsif op_rem_4 = 1 then
machine_ge;
elsif op_rem_4 = 2 then
machine_eq;
else
machine_ne;
end if;
elsif op_div_4 = 3 then
if op_rem_4 = 0 then
machine_and;
elsif op_rem_4 = 1 then
machine_or;
elsif op_rem_4 = 2 then
machine_neg;
else
machine_not;
end if;
elsif op_div_4 = 4 then
if op_rem_4 = 0 then
machine_prtc;
elsif op_rem_4 = 1 then
machine_prti;
elsif op_rem_4 = 2 then
machine_prts;
else
machine_fetch;
end if;
elsif op_div_4 = 5 then
if op_rem_4 = 0 then
machine_store;
elsif op_rem_4 = 1 then
machine_push;
elsif op_rem_4 = 2 then
machine_jmp;
else
machine_jz;
end if;
else
-- Treat anything unrecognized as equivalent to a halt.
halt := True;
end if;
end machine_step;
procedure machine_continue
is
halt : Boolean;
begin
halt := False;
while not halt loop
machine_step (halt);
end loop;
end machine_continue;
procedure machine_run
is
begin
sp := 0;
pc := 0;
for i in data'Range loop
data (i) := 0;
end loop;
machine_continue;
end machine_run;
begin
status := 0;
input_file_name := To_Unbounded_String ("-");
if Argument_Count = 0 then
null;
elsif Argument_Count = 1 then
input_file_name := To_Unbounded_String (Argument (1));
else
Put ("Usage: ");
Put (Command_Name);
Put_Line (" [INPUTFILE]");
Put ("If either INPUTFILE is missing or ""-"",");
Put_Line (" standard input is used.");
Put_Line ("Output is always to standard output.");
status := 1;
end if;
if status = 0 then
if input_file_name /= "-" then
Open (input_file, In_File, To_String (input_file_name));
Set_Input (input_file);
end if;
output_stream := Stream (Current_Output);
read_parse_and_store_program;
machine_run;
if input_file_name /= "-" then
Set_Input (Standard_Input);
Close (input_file);
end if;
end if;
Set_Exit_Status (status);
end VM;
- Output:
$ gnatmake -q -gnatp -O3 -march=native vm.adb && ./vm compiler-tests/count.vm count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
Aime
integer n, pc, sp;
file f;
text s;
index code, Data;
list l, stack, strings;
f.affix(argv(1));
f.list(l, 0);
n = atoi(l[-1]);
while (n) {
f.lead(s);
strings.append(erase(s, -1, 0));
n -= 1;
}
while (f.list(l, 0) ^ -1) {
code.put(atoi(lf_x_text(l)), l);
}
pc = sp = 0;
while (1) {
l = code[pc];
s = l[0];
if (s == "jz") {
if (lb_pick(stack)) {
isk_greater(code, pc, pc);
} else {
pc = atoi(l[-1]);
}
} elif (s == "jmp") {
pc = atoi(l[-1]);
} else {
if (s == "push") {
lb_push(stack, atoi(l[1]));
} elif (s == "fetch") {
lb_push(stack, Data[atoi(erase(l[1], -1, 0))]);
} elif (s == "neg") {
stack[-1] = -stack[-1];
} elif (s == "not") {
stack[-1] = !stack[-1];
} elif (s == "halt") {
break;
} else {
n = lb_pick(stack);
if (s == "store") {
Data[atoi(erase(l[1], -1, 0))] = n;
} elif (s == "add") {
stack[-1] = stack[-1] + n;
} elif (s == "sub") {
stack[-1] = stack[-1] - n;
} elif (s == "mul") {
stack[-1] = stack[-1] * n;
} elif (s == "div") {
stack[-1] = stack[-1] / n;
} elif (s == "mod") {
stack[-1] = stack[-1] % n;
} elif (s == "lt") {
stack[-1] = stack[-1] < n;
} elif (s == "gt") {
stack[-1] = stack[-1] > n;
} elif (s == "le") {
stack[-1] = stack[-1] <= n;
} elif (s == "ge") {
stack[-1] = stack[-1] >= n;
} elif (s == "eq") {
stack[-1] = stack[-1] == n;
} elif (s == "ne") {
stack[-1] = stack[-1] != n;
} elif (s == "and") {
stack[-1] = stack[-1] && n;
} elif (s == "or") {
stack[-1] = stack[-1] || n;
} elif (s == "prtc") {
o_byte(n);
} elif (s == "prti") {
o_(n);
} elif (s == "prts") {
o_(strings[n]);
} else {
}
}
isk_greater(code, pc, pc);
}
}
ALGOL W
begin % virtual machine interpreter %
% string literals %
string(256) array stringValue ( 0 :: 256 );
integer array stringLength ( 0 :: 256 );
integer MAX_STRINGS;
% op codes %
integer oFetch, oStore, oPush
, oAdd, oSub, oMul, oDiv, oMod, oLt, oGt, oLe, oGe, oEq, oNe
, oAnd, oOr, oNeg, oNot, oJmp, oJz, oPrtc, oPrts, oPrti, oHalt
;
string(6) array opName ( 1 :: 24 );
integer OP_MAX;
% code %
string(1) array byteCode ( 0 :: 4096 );
integer nextLocation, MAX_LOCATION;
% data %
integer array data ( 0 :: 4096 );
integer dataSize, MAX_DATA, MAX_STACK;
% tracing %
logical trace;
% reports an error and stops %
procedure rtError( string(80) value message ); begin
integer errorPos;
write( s_w := 0, "**** Runtime error: " );
errorPos := 0;
while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
writeon( s_w := 0, message( errorPos // 1 ) );
errorPos := errorPos + 1
end while_not_at_end_of_message ;
writeon( s_w := 0, "." );
assert( false )
end genError ;
oFetch := 1; opName( oFetch ) := "fetch"; oStore := 2; opName( oStore ) := "store"; oPush := 3; opName( oPush ) := "push";
oAdd := 4; opName( oAdd ) := "add"; oSub := 5; opName( oSub ) := "sub"; oMul := 6; opName( oMul ) := "mul";
oDiv := 7; opName( oDiv ) := "div"; oMod := 8; opName( oMod ) := "mod"; oLt := 9; opName( oLt ) := "lt";
oGt := 10; opName( oGt ) := "gt"; oLe := 11; opName( oLe ) := "le"; oGe := 12; opName( oGe ) := "ge";
oEq := 13; opName( oEq ) := "eq"; oNe := 14; opName( oNe ) := "ne"; oAnd := 15; opName( oAnd ) := "and";
oOr := 16; opName( oOr ) := "or"; oNeg := 17; opName( oNeg ) := "neg"; oNot := 18; opName( oNot ) := "not";
oJmp := 19; opName( oJmp ) := "jmp"; oJz := 20; opName( oJz ) := "jz"; oPrtc := 21; opName( oPrtc ) := "prtc";
oPrts := 22; opName( oPrts ) := "prts"; oPrti := 23; opName( oPrti ) := "prti"; oHalt := 24; opName( oHalt ) := "halt";
OP_MAX := oHalt;
trace := false;
MAX_STACK := 256;
MAX_LOCATION := 4096;
for pc := 0 until MAX_LOCATION do byteCode( pc ) := code( 0 );
MAX_DATA := 4096;
for dPos := 0 until MAX_DATA do data( dPos ) := 0;
MAX_STRINGS := 256;
for sPos := 0 until MAX_STRINGS do begin
stringValue( sPos ) := " ";
stringLength( sPos ) := 0
end for_sPos ;
% load thge output from syntaxc analyser %
begin % readCode %
% skips spaces on the source line %
procedure skipSpaces ; begin
while line( lPos // 1 ) = " " do lPos := lPos + 1
end skipSpaces ;
% parses a string from line and stores it in the string literals table %
procedure readString ( integer value stringNumber ) ; begin
string(256) str;
integer sLen;
str := " ";
sLen := 0;
lPos := lPos + 1; % skip the opening double-quote %
while lPos <= 255 and line( lPos // 1 ) not = """" do begin
str( sLen // 1 ) := line( lPos // 1 );
sLen := sLen + 1;
lPos := lPos + 1
end while_more_string ;
if lPos > 255 then rtError( "Unterminated String." );
% store the string %
stringValue( stringNumber ) := str;
stringLength( stringNumber ) := sLen
end readString ;
% gets an integer from the line - checks for valid digits %
integer procedure readInteger ; begin
integer n;
skipSpaces;
n := 0;
while line( lPos // 1 ) >= "0" and line( lPos // 1 ) <= "9" do begin
n := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
lPos := lPos + 1
end while_not_end_of_integer ;
n
end readInteger ;
% reads the next line from standard input %
procedure readALine ; begin
lPos := 0;
readcard( line );
if trace then write( s_w := 0, ">> ", line( 0 // 32 ) )
end readALine ;
% loads an instruction from the current source line %
procedure loadCodeFromLine ; begin
integer pc, opCode, operand, oPos;
string(256) op;
logical haveOperand;
% get the code location %
pc := readInteger;
if pc > MAX_LOCATION then rtError( "Code too large." );
% get the opCode %
skipSpaces;
oPos := 0;
op := " ";
while lPos <= 255 and line( lPos // 1 ) not = " " do begin
op( oPos // 1 ) := line( lPos // 1 );
oPos := oPos + 1;
lPos := lPos + 1
end while_more_opName ;
% lookup the op code %
opCode := 0;
oPos := 1;
while oPos <= OP_MAX and opCode = 0 do begin
if opName( oPos ) = op then opCode := oPos
else oPos := oPos + 1
end while_op_not_found ;
if opCode = 0 then rtError( "Unknown op code." );
% get the operand if there is one %
operand := 0;
haveOperand := false;
if opCode = oFetch or opCode = oStore then begin
% fetch or store - operand is enclosed in square brackets %
skipSpaces;
if line( lPos // 1 ) not = "[" then rtError( """["" expected after fetch/store." );
lPos := lPos + 1;
operand := readInteger;
if operand > dataSize then rtError( "fetch/store address out of range." );
haveOperand := true
end
else if opCode = oPush then begin
% push integer literal instruction %
operand := readInteger;
haveOperand := true
end
else if opCode = oJmp or opCode = oJz then begin
% jump - the operand is the relative address enclosed in parenthesis %
% followed by the absolute address - we use the absolute address so %
% the opewrand will be >= 0 %
skipSpaces;
if line( lPos // 1 ) not = "(" then rtError( """("" expected after jmp/jz." );
lPos := lPos + 1;
if line( lPos // 1 ) = "-" then % negative relative address % lPos := lPos + 1;
operand := readInteger;
if line( lPos // 1 ) not = ")" then rtError( """)"" expected after jmp/jz." );
lPos := lPos + 1;
operand := readInteger;
haveOperand := true
end if_various_opcodes ;
% store the code %
byteCode( pc ) := code( opCode );
if haveOperand then begin
% have an operand for the op code %
if ( pc + 4 ) > MAX_LOCATION then rtError( "Code too large." );
for oPos := 1 until 4 do begin
pc := pc + 1;
byteCode( pc ) := code( operand rem 256 );
operand := operand div 256;
end for_oPos
end if_have_operand ;
end loadCodeFromLine ;
string(256) line;
string(16) name;
integer lPos, tPos, stringCount;
% allow us to detect EOF %
ENDFILE := EXCEPTION( false, 1, 0, false, "EOF" );
% first line should be "Datasize: d Strings: s" where d = number variables %
% and s = number of strings %
readALine;
if line = "trace" then begin
% extension - run in trace mode %
trace := true;
readALine
end if_line_eq_trace ;
if XCPNOTED(ENDFILE) then rtError( "Empty program file." );
if line( 0 // 10 ) not = "Datasize: " then rtError( "Header line missing." );
lPos := 10;
dataSize := readInteger;
if dataSize > MAX_DATA then rtError( "Datasize too large." );
skipSpaces;
if line( lPos // 9 ) not = "Strings: " then rtError( """Strings: "" missing on header line." );
lPos := lPos + 9;
stringCount := readInteger;
if stringCount > MAX_STRINGS then rtError( "Too many strings." );
% read the string table %
for stringNumber := 0 until stringCount - 1 do begin
string(256) str;
integer sLen, sPos;
readALine;
if XCPNOTED(ENDFILE) then rtError( "End-of-file in string table." );
if line( lPos // 1 ) not = """" then rtError( "String literal expected." );
str := " ";
sLen := 0;
lPos := lPos + 1; % skip the opening double-quote %
while lPos <= 255 and line( lPos // 1 ) not = """" do begin
str( sLen // 1 ) := line( lPos // 1 );
sLen := sLen + 1;
lPos := lPos + 1
end while_more_string ;
if lPos > 255 then rtError( "Unterminated String." );
% store the string %
stringValue( stringNumber ) := str;
stringLength( stringNumber ) := sLen
end for_sPos ;
% read the code %
readALine;
while not XCPNOTED(ENDFILE) do begin
if line not = " " then loadCodeFromLine;
readALine
end while_not_eof
end;
% run the program %
begin
integer pc, opCode, operand, sp;
integer array st ( 0 :: MAX_STACK );
logical halted;
% prints a string from the string pool, escape sequences are interpreted %
procedure writeOnString( integer value stringNumber ) ;
begin
integer cPos, sLen;
string(256) text;
if stringNumber < 0 or stringNumber > MAX_STRINGS then rtError( "Invalid string number." );
cPos := 0;
sLen := stringLength( stringNumber );
text := stringValue( stringNumber );
while cPos < stringLength( stringNumber ) do begin
string(1) ch;
ch := text( cPos // 1 );
if ch not = "\" then writeon( s_w := 0, ch )
else begin
% escaped character %
cPos := cPos + 1;
if cPos > sLen then rtError( "String terminates with ""\""." );
ch := text( cPos // 1 );
if ch = "n" then % newline % write()
else writeon( s_w := 0, ch )
end;
cPos := cPos + 1
end while_not_end_of_string
end writeOnString ;
pc := 0;
sp := -1;
halted := false;
while not halted do begin;
% get the next op code and operand %
opCode := decode( byteCode( pc ) );
pc := pc + 1;
operand := 0;
if opCode = oFetch or opCode = oStore or opCode = oPush or opCode = oJmp or opCode = oJz then begin
% this opCode has an operand %
pc := pc + 4;
for bPos := 1 until 4 do begin
operand := ( operand * 256 ) + decode( byteCode( pc - bPos ) );
end for_bPos
end if_opCode_with_an_operand ;
if trace then begin
write( i_w:= 1, s_w := 0, pc, " op(", opCode, "): ", opName( opCode ), " ", operand );
write()
end if_trace ;
% interpret the instruction %
if opCode = oFetch then begin sp := sp + 1; st( sp ) := data( operand ) end
else if opCode = oStore then begin data( operand ) := st( sp ); sp := sp - 1 end
else if opCode = oPush then begin sp := sp + 1; st( sp ) := operand end
else if opCode = oHalt then halted := true
else if opCode = oJmp then pc := operand
else if oPCode = oJz then begin
if st( sp ) = 0 then pc := operand;
sp := sp - 1
end
else if opCode = oPrtc then begin writeon( i_w := 1, s_w := 0, code( st( sp ) ) ); sp := sp - 1 end
else if opCode = oPrti then begin writeon( i_w := 1, s_w := 0, st( sp ) ); sp := sp - 1 end
else if opCode = oPrts then begin writeonString( st( sp ) ); sp := sp - 1 end
else if opCode = oNeg then st( sp ) := - st( sp )
else if opCode = oNot then st( sp ) := ( if st( sp ) = 0 then 1 else 0 )
else begin
operand := st( sp );
sp := sp - 1;
if opCode = oAdd then st( sp ) := st( sp ) + operand
else if opCode = oSub then st( sp ) := st( sp ) - operand
else if opCode = oMul then st( sp ) := st( sp ) * operand
else if opCode = oDiv then st( sp ) := st( sp ) div operand
else if opCode = oMod then st( sp ) := st( sp ) rem operand
else if opCode = oLt then st( sp ) := if st( sp ) < operand then 1 else 0
else if opCode = oGt then st( sp ) := if st( sp ) > operand then 1 else 0
else if opCode = oLe then st( sp ) := if st( sp ) <= operand then 1 else 0
else if opCode = oGe then st( sp ) := if st( sp ) >= operand then 1 else 0
else if opCode = oEq then st( sp ) := if st( sp ) = operand then 1 else 0
else if opCode = oNe then st( sp ) := if st( sp ) not = operand then 1 else 0
else if opCode = oAnd then st( sp ) := if st( sp ) not = 0 and operand not = 0 then 1 else 0
else if opCode = oOr then st( sp ) := if st( sp ) not = 0 or operand not = 0 then 1 else 0
else rtError( "Unknown opCode." )
end if_various_opCodes
end while_not_halted
end
end.ATS
Interpreter
Compile with ‘patscc -O3 -DATS_MEMALLOC_LIBC -o vm vm-postiats.dats -latslib’
With the C optimizer turned on, like this, the program should run pretty fast, despite being relatively safe against going out of bounds, etc. Try it on the ASCII Mandelbrot example.
(Without the C optimizer, ATS code can run much, much more slowly. It is worth comparing the Mandelbrot example with and without the optimizer.)
(*
Usage: vm [INPUTFILE [OUTPUTFILE]]
If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
or standard output is used, respectively.
The Rosetta Code virtual machine task in ATS2 (also known as
Postiats).
Some implementation notes:
* Values are stored as uint32, and it is checked that uint32
really is 32 bits, two’s-complement. Addition and subtraction
are allowed to roll around, and so can be done without casting
to int32. (The C standard specifies that unsigned integer values
will roll around, rather than signal an overflow.)
* Where it matters, the uint32 are stored in little-endian
order. I have *not* optimized the code for x86/AMD64 (which are
little-endian and also can address unaligned data).
* Here I am often writing out code instead of using some library
function. Partly this is to improve code safety (proof at
compile-time that buffers are not overrun, proof of loop
termination, etc.). Partly this is because I do not feel like
using the C library (or ATS interfaces to it) all that much.
* I am using linear types and so forth, because I think it
interesting to do so. It is unnecessary to use a garbage
collector, because there (hopefully) are no memory leaks. (Not
that we couldn’t simply let memory leak, for this little program
with no REPL.)
*)
#define ATS_EXTERN_PREFIX "rosettacode_vm_"
#define ATS_DYNLOADFLAG 0 (* No initialization is needed. *)
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
staload UN = "prelude/SATS/unsafe.sats"
#define NIL list_vt_nil ()
#define :: list_vt_cons
(* The stack has a fixed size but is very large. (Alternatively, one
could make the stack double in size whenever it overflows. Design
options such as using a linked list for the stack come with a
performance penalty.) *)
#define VMSTACK_SIZE 65536
macdef vmstack_size = (i2sz VMSTACK_SIZE)
(* In this program, exceptions are not meant to be caught, unless
the catcher terminates the program. Linear types and
general exception-catching do not go together well. *)
exception bad_vm of string
exception vm_runtime_error of string
(********************************************************************)
(* *)
(* Some string functions that are safe against buffer overruns. *)
(* *)
fn
skip_whitespace {n, i : int | 0 <= i; i <= n}
(s : string n,
n : size_t n,
i : size_t i) :
[j : int | i <= j; j <= n]
size_t j =
let
fun
loop {k : int | i <= k; k <= n} .<n - k>.
(k : size_t k) :
[j : int | i <= j; j <= n]
size_t j =
if k = n then
k
else if isspace (s[k]) then
loop (succ k)
else
k
in
loop (i)
end
fn
skip_non_whitespace {n, i : int | 0 <= i; i <= n}
(s : string n,
n : size_t n,
i : size_t i) :
[j : int | i <= j; j <= n]
size_t j =
let
fun
loop {k : int | i <= k; k <= n} .<n - k>.
(k : size_t k) :
[j : int | i <= j; j <= n]
size_t j =
if k = n then
k
else if isspace (s[k]) then
k
else
loop (succ k)
in
loop (i)
end
fn
substr_equal {n, i, j : int | 0 <= i; i <= j; j <= n}
{m : int | 0 <= m}
(s : string n,
i : size_t i,
j : size_t j,
t : string m) : bool =
(* Is s[i .. j-1] equal to t? *)
let
val m = string_length t
in
if m <> j - i then
false
else
let
fun
loop {k : int | 0 <= k; k <= m} .<m - k>.
(k : size_t k) : bool =
if k = m then
true
else if s[i + k] <> t[k] then
false
else
loop (succ k)
in
loop (i2sz 0)
end
end
(********************************************************************)
(* *)
(* vmint = 32-bit two’s-complement numbers. *)
(* *)
stadef vmint_kind = uint32_kind
typedef vmint = uint32
extern castfn i2vm : int -<> vmint
extern castfn u2vm : uint -<> vmint
extern castfn byte2vm : byte -<> vmint
extern castfn vm2i : vmint -<> int
extern castfn vm2sz : vmint -<> size_t
extern castfn vm2byte : vmint -<> byte
%{^
/*
* The ATS prelude might not have C implementations of all the
* operations we would like to have, so here are some.
*/
typedef uint32_t vmint_t;
ATSinline() vmint_t
rosettacode_vm_g0uint_add_vmint (vmint_t x, vmint_t y)
{
return (x + y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_sub_vmint (vmint_t x, vmint_t y)
{
return (x - y);
}
ATSinline() int
rosettacode_vm_g0uint_eq_vmint (vmint_t x, vmint_t y)
{
return (x == y);
}
ATSinline() int
rosettacode_vm_g0uint_neq_vmint (vmint_t x, vmint_t y)
{
return (x != y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_equality_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) (x == y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_inequality_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) (x != y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lt_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x < (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gt_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x > (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lte_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x <= (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gte_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x >= (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mul_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x * (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_div_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x / (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mod_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((int32_t) x % (int32_t) y);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_logical_not_vmint (vmint_t x)
{
return (vmint_t) (!x);
}
ATSinline() vmint_t
rosettacode_vm_g0uint_logical_and_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) ((!!x) * (!!y));
}
ATSinline() vmint_t
rosettacode_vm_g0uint_logical_or_vmint (vmint_t x, vmint_t y)
{
return (vmint_t) (1 - ((!x) * (!y)));
}
%}
extern fn g0uint_add_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_sub_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_eq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"
extern fn g0uint_neq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"
implement g0uint_add<vmint_kind> (x, y) = g0uint_add_vmint (x, y)
implement g0uint_sub<vmint_kind> (x, y) = g0uint_sub_vmint (x, y)
implement g0uint_eq<vmint_kind> (x, y) = g0uint_eq_vmint (x, y)
implement g0uint_neq<vmint_kind> (x, y) = g0uint_neq_vmint (x, y)
extern fn
g0uint_signed_mul_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_div_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_mod_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_equality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_inequality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_not_vmint (x : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_and_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_or_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
overload signed_mul with g0uint_signed_mul_vmint
overload signed_div with g0uint_signed_div_vmint
overload signed_mod with g0uint_signed_mod_vmint
overload equality with g0uint_equality_vmint
overload inequality with g0uint_inequality_vmint
overload signed_lt with g0uint_signed_lt_vmint
overload signed_gt with g0uint_signed_gt_vmint
overload signed_lte with g0uint_signed_lte_vmint
overload signed_gte with g0uint_signed_gte_vmint
overload logical_not with g0uint_logical_not_vmint
overload logical_and with g0uint_logical_and_vmint
overload logical_or with g0uint_logical_or_vmint
fn {}
twos_complement (x : vmint) :<>
vmint =
(~x) + i2vm 1
fn
ensure_that_vmint_is_suitable () : void =
{
val _ = assertloc (u2vm (0xFFFFFFFFU) + u2vm 1U = u2vm 0U)
val _ = assertloc (u2vm 0U - u2vm 1U = u2vm (0xFFFFFFFFU))
val _ = assertloc (i2vm (~1234) = twos_complement (i2vm 1234))
}
fn
parse_digits {n, i, j : int | 0 <= i; i <= j; j <= n}
(s : string n,
i : size_t i,
j : size_t j) :
vmint =
let
val bad_integer = "Bad integer."
fun
loop {k : int | i <= k; k <= j} .<j - k>.
(k : size_t k,
x : vmint) : vmint =
if k = j then
x
else if ~isdigit (s[k]) then
$raise bad_vm (bad_integer)
else
(* The result is allowed to overflow freely. *)
loop (succ k, (i2vm 10 * x) + i2vm (char2i s[k] - char2i '0'))
in
if j = i then
$raise bad_vm (bad_integer)
else
loop (i, i2vm 0)
end
fn
parse_integer {n, i, j : int | 0 <= i; i <= j; j <= n}
(s : string n,
i : size_t i,
j : size_t j) :
vmint =
let
val bad_integer = "Bad integer."
in
if j = i then
$raise bad_vm (bad_integer)
else if j = succ i && ~isdigit (s[i]) then
$raise bad_vm (bad_integer)
else if s[i] <> '-' then
parse_digits (s, i, j)
else if succ i = j then
$raise bad_vm (bad_integer)
else
twos_complement (parse_digits (s, succ i, j))
end
(********************************************************************)
(* *)
(* A linear array type for elements of vmint, byte, etc. *)
(* *)
vtypedef vmarray_vt (t : t@ype+, n : int, p : addr) =
@{
pf = @[t][n] @ p,
pfgc = mfree_gc_v p |
n = size_t n,
p = ptr p
}
vtypedef vmarray_vt (t : t@ype+, n : int) =
[p : addr] vmarray_vt (t, n, p)
fn {t : t@ype}
vmarray_vt_alloc {n : int}
(n : size_t n,
fill : t) :
[p : addr | null < p]
vmarray_vt (t, n, p) =
let
val @(pf, pfgc | p) = array_ptr_alloc<t> (n)
val _ = array_initize_elt (!p, n, fill)
in
@{
pf = pf,
pfgc = pfgc |
n = n,
p = p
}
end
fn {t : t@ype}
vmarray_vt_free {n : int}
{p : addr}
(arr : vmarray_vt (t, n, p)) :
void =
let
val @{
pf = pf,
pfgc = pfgc |
n = n,
p = p
} = arr
in
array_ptr_free (pf, pfgc | p)
end
fn {t : t@ype}
vmarray_vt_fill {n : int}
{p : addr}
(arr : !vmarray_vt (t, n, p),
fill : t) :
void =
array_initize_elt (!(arr.p), (arr.n), fill)
fn {t : t@ype}
{tk : tkind}
vmarray_vt_get_at_g1int {n, i : int | 0 <= i; i < n}
(arr : !vmarray_vt (t, n),
i : g1int (tk, i)) :
t =
array_get_at (!(arr.p), i)
fn {t : t@ype}
{tk : tkind}
vmarray_vt_get_at_g1uint {n, i : int | 0 <= i; i < n}
(arr : !vmarray_vt (t, n),
i : g1uint (tk, i)) :
t =
array_get_at (!(arr.p), i)
overload [] with vmarray_vt_get_at_g1int
overload [] with vmarray_vt_get_at_g1uint
fn {t : t@ype}
{tk : tkind}
vmarray_vt_set_at_g1int {n, i : int | 0 <= i; i < n}
(arr : !vmarray_vt (t, n),
i : g1int (tk, i),
x : t) :
void =
array_set_at (!(arr.p), i, x)
fn {t : t@ype}
{tk : tkind}
vmarray_vt_set_at_g1uint {n, i : int | 0 <= i; i < n}
(arr : !vmarray_vt (t, n),
i : g1uint (tk, i),
x : t) :
void =
array_set_at (!(arr.p), i, x)
overload [] with vmarray_vt_set_at_g1int
overload [] with vmarray_vt_set_at_g1uint
fn {t : t@ype}
vmarray_vt_length {n : int}
(arr : !vmarray_vt (t, n)) :<>
size_t n =
arr.n
(********************************************************************)
(* *)
(* Storage for the strings section. *)
(* *)
vtypedef vmstring_vt (n : int, p : addr) =
@{
(* A vmstring_vt is NUL-terminated, and thus there is [n + 1]
instead of [n] in the following declaration. *)
pf = @[char][n + 1] @ p,
pfgc = mfree_gc_v p |
length = size_t n,
p = ptr p
}
vtypedef vmstring_vt (n : int) = [p : addr] vmstring_vt (n, p)
vtypedef vmstring_vt = [n : int | 0 <= n] vmstring_vt (n)
vtypedef vmstrings_section_vt (n : int, p : addr) =
@{
pf = @[vmstring_vt][n] @ p,
pfgc = mfree_gc_v p |
n = size_t n,
p = ptr p
}
vtypedef vmstrings_section_vt (n : int) =
[p : addr] vmstrings_section_vt (n, p)
fn {t : t@ype}
vmstrings_section_vt_length {n : int}
(arr : !vmstrings_section_vt (n)) :<>
size_t n =
arr.n
fn
vmstring_vt_free {n : int}
{p : addr}
(s : vmstring_vt (n, p)) :
void =
array_ptr_free (s.pf, s.pfgc | s.p)
fn
vmstrings_section_vt_free {n : int}
{p : addr}
(strings : vmstrings_section_vt (n, p)) :
void =
{
fun
free_the_strings {n : int | 0 <= n}
{p : addr} .<n>.
(pf : !(@[vmstring_vt][n] @ p) >>
@[vmstring_vt?][n] @ p |
n : size_t n,
p : ptr p) : void =
if n = 0 then
{
prval _ = pf :=
array_v_unnil_nil {vmstring_vt, vmstring_vt?} pf
}
else
{
prval @(pf_element, pf_rest) = array_v_uncons pf
val _ = vmstring_vt_free (!p)
val p_next = ptr_succ<vmstring_vt> (p)
val _ = free_the_strings (pf_rest | pred n, p_next)
prval _ = pf := array_v_cons (pf_element, pf_rest)
}
val @{
pf = pf,
pfgc = pfgc |
n = n,
p = p
} = strings
prval _ = lemma_g1uint_param n
val _ = free_the_strings (pf | n, p)
val _ = array_ptr_free (pf, pfgc | p)
}
fn
quoted_string_length {n : int | 0 <= n}
(s : string n,
n : size_t n) :
[m : int | 0 <= m; m <= n - 2]
size_t m =
let
val bad_quoted_string = "Bad quoted string."
fun
loop {i : int | 1 <= i; i <= n - 1}
{j : int | 0 <= j; j <= i - 1} .<n - i>.
(i : size_t i,
j : size_t j) :
[k : int | 0 <= k; k <= n - 2]
size_t k =
if i = pred n then
j
else if s[i] <> '\\' then
loop (succ i, succ j)
else if succ i = pred n then
$raise bad_vm (bad_quoted_string)
else if s[succ i] = 'n' || s[succ i] = '\\' then
loop (succ (succ i), succ j)
else
$raise bad_vm (bad_quoted_string)
in
if n < i2sz 2 then
$raise bad_vm (bad_quoted_string)
else if s[0] <> '"' then
$raise bad_vm (bad_quoted_string)
else if s[pred n] <> '"' then
$raise bad_vm (bad_quoted_string)
else
loop (i2sz 1, i2sz 0)
end
fn
dequote_string {m, n : int | 0 <= m; m <= n - 2}
(s : string n,
n : size_t n,
t : !vmstring_vt m) :
void =
let
fun
loop {i : int | 1 <= i; i <= n - 1}
{j : int | 0 <= j; j <= i - 1} .<n - i>.
(t : !vmstring_vt m,
i : size_t i,
j : size_t j) : void =
let
macdef t_str = !(t.p)
in
if i = pred n then
()
else if (t.length) < j then
assertloc (false)
else if s[i] <> '\\' then
begin
t_str[j] := s[i];
loop (t, succ i, succ j)
end
else if succ i = pred n then
assertloc (false)
else if s[succ i] = 'n' then
begin
t_str[j] := '\n';
loop (t, succ (succ i), succ j)
end
else
begin
t_str[j] := s[succ i];
loop (t, succ (succ i), succ j)
end
end
in
loop (t, i2sz 1, i2sz 0)
end
fn
read_vmstrings {strings_size : int}
{strings_addr : addr}
(pf_strings :
!(@[vmstring_vt?][strings_size] @ strings_addr) >>
@[vmstring_vt][strings_size] @ strings_addr |
f : FILEref,
strings_size : size_t strings_size,
strings : ptr strings_addr) :
void =
let
prval _ = lemma_g1uint_param strings_size
fun
loop {k : int | 0 <= k; k <= strings_size} .<strings_size - k>.
(lst : list_vt (vmstring_vt, k),
k : size_t k) :
list_vt (vmstring_vt, strings_size) =
if k = strings_size then
list_vt_reverse (lst)
else
let
val bad_quoted_string = "Bad quoted string."
val line = fileref_get_line_string (f)
val s = $UN.strptr2string (line)
val n = string_length s
val str_length = quoted_string_length (s, n)
val (pf, pfgc | p) =
array_ptr_alloc<char> (succ str_length)
val _ = array_initize_elt (!p, succ str_length, '\0')
val vmstring =
@{
pf = pf,
pfgc = pfgc |
length = str_length,
p = p
}
in
dequote_string (s, n, vmstring);
free line;
loop (vmstring :: lst, succ k)
end
val lst = loop (NIL, i2sz 0)
in
array_initize_list_vt<vmstring_vt>
(!strings, sz2i strings_size, lst)
end
fn
vmstrings_section_vt_read {strings_size : int}
(f : FILEref,
strings_size : size_t strings_size) :
[p : addr]
vmstrings_section_vt (strings_size, p) =
let
val @(pf, pfgc | p) = array_ptr_alloc<vmstring_vt> strings_size
val _ = read_vmstrings (pf | f, strings_size, p)
in
@{
pf = pf,
pfgc = pfgc |
n = strings_size,
p = p
}
end
fn
vmstring_fprint {n, i : int | i < n}
(f : FILEref,
strings : !vmstrings_section_vt n,
i : size_t i) :
void =
{
(*
* The following code does some ‘unsafe’ tricks. For instance, it
* is assumed each stored string is NUL-terminated.
*)
fn
print_it (str : !vmstring_vt) : void =
fileref_puts (f, $UN.cast{string} (str.p))
prval _ = lemma_g1uint_param i
val p_element = array_getref_at (!(strings.p), i)
val @(pf_element | p_element) =
$UN.castvwtp0
{[n : int; p : addr] @(vmstring_vt @ p | ptr p)}
(p_element)
val _ = print_it (!p_element)
prval _ = $UN.castview0{void} pf_element
}
(********************************************************************)
(* *)
(* vm_vt: the dataviewtype for a virtual machine. *)
(* *)
datavtype instruction_vt =
| instruction_vt_1 of (byte)
| instruction_vt_5 of (byte, byte, byte, byte, byte)
#define OPCODE_COUNT 24
#define OP_HALT 0x0000 // 00000
#define OP_ADD 0x0001 // 00001
#define OP_SUB 0x0002 // 00010
#define OP_MUL 0x0003 // 00011
#define OP_DIV 0x0004 // 00100
#define OP_MOD 0x0005 // 00101
#define OP_LT 0x0006 // 00110
#define OP_GT 0x0007 // 00111
#define OP_LE 0x0008 // 01000
#define OP_GE 0x0009 // 01001
#define OP_EQ 0x000A // 01010
#define OP_NE 0x000B // 01011
#define OP_AND 0x000C // 01100
#define OP_OR 0x000D // 01101
#define OP_NEG 0x000E // 01110
#define OP_NOT 0x000F // 01111
#define OP_PRTC 0x0010 // 10000
#define OP_PRTI 0x0011 // 10001
#define OP_PRTS 0x0012 // 10010
#define OP_FETCH 0x0013 // 10011
#define OP_STORE 0x0014 // 10100
#define OP_PUSH 0x0015 // 10101
#define OP_JMP 0x0016 // 10110
#define OP_JZ 0x0017 // 10111
#define REGISTER_PC 0
#define REGISTER_SP 1
#define MAX_REGISTER REGISTER_SP
vtypedef vm_vt (strings_size : int,
strings_addr : addr,
code_size : int,
code_addr : addr,
data_size : int,
data_addr : addr,
stack_size : int,
stack_addr : addr) =
@{
strings = vmstrings_section_vt (strings_size, strings_addr),
code = vmarray_vt (byte, code_size, code_addr),
data = vmarray_vt (vmint, data_size, data_addr),
stack = vmarray_vt (vmint, stack_size, stack_addr),
registers = vmarray_vt (vmint, MAX_REGISTER + 1)
}
vtypedef vm_vt (strings_size : int,
code_size : int,
data_size : int,
stack_size : int) =
[strings_addr : addr]
[code_addr : addr]
[data_addr : addr]
[stack_addr : addr]
vm_vt (strings_size, strings_addr,
code_size, code_addr,
data_size, data_addr,
stack_size, stack_addr)
vtypedef vm_vt =
[strings_size : int]
[code_size : int]
[data_size : int]
[stack_size : int]
vm_vt (strings_size, code_size, data_size, stack_size)
fn
vm_vt_free (vm : vm_vt) :
void =
let
val @{
strings = strings,
code = code,
data = data,
stack = stack,
registers = registers
} = vm
in
vmstrings_section_vt_free strings;
vmarray_vt_free<byte> code;
vmarray_vt_free<vmint> data;
vmarray_vt_free<vmint> stack;
vmarray_vt_free<vmint> registers
end
fn
opcode_name_to_byte {n, i, j : int | 0 <= i; i <= j; j <= n}
(arr : &(@[String0][OPCODE_COUNT]),
str : string n,
i : size_t i,
j : size_t j) :
byte =
let
fun
loop {k : int | 0 <= k; k <= OPCODE_COUNT} .<OPCODE_COUNT - k>.
(arr : &(@[String0][OPCODE_COUNT]),
k : int k) : byte =
if k = OPCODE_COUNT then
$raise bad_vm ("Unrecognized opcode name.")
else if substr_equal (str, i, j, arr[k]) then
i2byte k
else
loop (arr, succ k)
in
loop (arr, 0)
end
fn {}
vmint_byte0 (i : vmint) :<>
byte =
vm2byte (i land (u2vm 0xFFU))
fn {}
vmint_byte1 (i : vmint) :<>
byte =
vm2byte ((i >> 8) land (u2vm 0xFFU))
fn {}
vmint_byte2 (i : vmint) :<>
byte =
vm2byte ((i >> 16) land (u2vm 0xFFU))
fn {}
vmint_byte3 (i : vmint) :<>
byte =
vm2byte (i >> 24)
fn
parse_instruction {n : int | 0 <= n}
(arr : &(@[String0][OPCODE_COUNT]),
line : string n) :
instruction_vt =
let
val bad_instruction = "Bad VM instruction."
val n = string_length (line)
val i = skip_whitespace (line, n, i2sz 0)
(* Skip the address field*)
val i = skip_non_whitespace (line, n, i)
val i = skip_whitespace (line, n, i)
val j = skip_non_whitespace (line, n, i)
val opcode = opcode_name_to_byte (arr, line, i, j)
val start_of_argument = j
fn
finish_push () :
instruction_vt =
let
val i1 = skip_whitespace (line, n, start_of_argument)
val j1 = skip_non_whitespace (line, n, i1)
val arg = parse_integer (line, i1, j1)
in
(* Little-endian storage. *)
instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
vmint_byte2 arg, vmint_byte3 arg)
end
fn
finish_fetch_or_store () :
instruction_vt =
let
val i1 = skip_whitespace (line, n, start_of_argument)
val j1 = skip_non_whitespace (line, n, i1)
in
if j1 - i1 < i2sz 3 then
$raise bad_vm (bad_instruction)
else if line[i1] <> '\[' || line[pred j1] <> ']' then
$raise bad_vm (bad_instruction)
else
let
val arg = parse_integer (line, succ i1, pred j1)
in
(* Little-endian storage. *)
instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
vmint_byte2 arg, vmint_byte3 arg)
end
end
fn
finish_jmp_or_jz () :
instruction_vt =
let
val i1 = skip_whitespace (line, n, start_of_argument)
val j1 = skip_non_whitespace (line, n, i1)
in
if j1 - i1 < i2sz 3 then
$raise bad_vm (bad_instruction)
else if line[i1] <> '\(' || line[pred j1] <> ')' then
$raise bad_vm (bad_instruction)
else
let
val arg = parse_integer (line, succ i1, pred j1)
in
(* Little-endian storage. *)
instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
vmint_byte2 arg, vmint_byte3 arg)
end
end
in
case+ byte2int0 opcode of
| OP_PUSH => finish_push ()
| OP_FETCH => finish_fetch_or_store ()
| OP_STORE => finish_fetch_or_store ()
| OP_JMP => finish_jmp_or_jz ()
| OP_JZ => finish_jmp_or_jz ()
| _ => instruction_vt_1 (opcode)
end
fn
read_instructions (f : FILEref,
arr : &(@[String0][OPCODE_COUNT])) :
(List_vt (instruction_vt), Size_t) =
(* Read the instructions from the input, producing a list of
instruction_vt objects, and also calculating the total
number of bytes in the instructions. *)
let
fun
loop (arr : &(@[String0][OPCODE_COUNT]),
lst : List_vt (instruction_vt),
bytes_needed : Size_t) :
@(List_vt (instruction_vt), Size_t) =
if fileref_is_eof f then
@(list_vt_reverse lst, bytes_needed)
else
let
val line = fileref_get_line_string (f)
in
if fileref_is_eof f then
begin
free line;
@(list_vt_reverse lst, bytes_needed)
end
else
let
val instruction =
parse_instruction (arr, $UN.strptr2string line)
val _ = free line
prval _ = lemma_list_vt_param lst
in
case+ instruction of
| instruction_vt_1 _ =>
loop (arr, instruction :: lst, bytes_needed + i2sz 1)
| instruction_vt_5 _ =>
loop (arr, instruction :: lst, bytes_needed + i2sz 5)
end
end
in
loop (arr, NIL, i2sz 0)
end
fn
list_of_instructions_to_code {bytes_needed : int}
(lst : List_vt (instruction_vt),
bytes_needed : size_t bytes_needed) :
[bytes_needed : int]
vmarray_vt (byte, bytes_needed) =
(* This routine consumes and destroys lst. *)
let
fun
loop {n : int | 0 <= n} .<n>.
(code : &vmarray_vt (byte, bytes_needed),
lst : list_vt (instruction_vt, n),
i : Size_t) : void =
case+ lst of
| ~ NIL => ()
| ~ head :: tail =>
begin
case head of
| ~ instruction_vt_1 (byte1) =>
let
val _ = assertloc (i < bytes_needed)
in
code[i] := byte1;
loop (code, tail, i + i2sz 1)
end
| ~ instruction_vt_5 (byte1, byte2, byte3, byte4, byte5) =>
let
val _ = assertloc (i + i2sz 4 < bytes_needed)
in
code[i] := byte1;
code[i + i2sz 1] := byte2;
code[i + i2sz 2] := byte3;
code[i + i2sz 3] := byte4;
code[i + i2sz 4] := byte5;
loop (code, tail, i + i2sz 5)
end
end
var code = vmarray_vt_alloc<byte> (bytes_needed, i2byte OP_HALT)
prval _ = lemma_list_vt_param lst
prval _ = lemma_g1uint_param bytes_needed
val _ = loop (code, lst, i2sz 0)
in
code
end
fn
read_and_parse_code (f : FILEref,
arr : &(@[String0][OPCODE_COUNT])) :
[bytes_needed : int]
vmarray_vt (byte, bytes_needed) =
let
val @(instructions, bytes_needed) = read_instructions (f, arr)
in
list_of_instructions_to_code (instructions, bytes_needed)
end
fn
parse_header_line {n : int | 0 <= n}
(line : string n) :
@(vmint, vmint) =
let
val bad_vm_header_line = "Bad VM header line."
val n = string_length (line)
val i = skip_whitespace (line, n, i2sz 0)
val j = skip_non_whitespace (line, n, i)
val _ = if ~substr_equal (line, i, j, "Datasize:") then
$raise bad_vm (bad_vm_header_line)
val i = skip_whitespace (line, n, j)
val j = skip_non_whitespace (line, n, i)
val data_size = parse_integer (line, i, j)
val i = skip_whitespace (line, n, j)
val j = skip_non_whitespace (line, n, i)
val _ = if ~substr_equal (line, i, j, "Strings:") then
$raise bad_vm (bad_vm_header_line)
val i = skip_whitespace (line, n, j)
val j = skip_non_whitespace (line, n, i)
val strings_size = parse_integer (line, i, j)
in
@(data_size, strings_size)
end
fn
read_vm (f : FILEref,
opcode_names_arr : &(@[String0][OPCODE_COUNT])) :
vm_vt =
let
val line = fileref_get_line_string (f)
val @(data_size, strings_size) =
parse_header_line ($UN.strptr2string line)
val _ = free line
val [data_size : int] data_size =
g1ofg0 (vm2sz data_size)
val [strings_size : int] strings_size =
g1ofg0 (vm2sz strings_size)
prval _ = lemma_g1uint_param data_size
prval _ = lemma_g1uint_param strings_size
prval _ = prop_verify {0 <= data_size} ()
prval _ = prop_verify {0 <= strings_size} ()
val strings = vmstrings_section_vt_read (f, strings_size)
val code = read_and_parse_code (f, opcode_names_arr)
val data = vmarray_vt_alloc<vmint> (data_size, i2vm 0)
val stack = vmarray_vt_alloc<vmint> (vmstack_size, i2vm 0)
val registers = vmarray_vt_alloc<vmint> (i2sz (MAX_REGISTER + 1),
i2vm 0)
in
@{
strings = strings,
code = code,
data = data,
stack = stack,
registers = registers
}
end
fn {}
pop (vm : &vm_vt) :
vmint =
let
macdef registers = vm.registers
macdef stack = vm.stack
val sp_before = registers[REGISTER_SP]
in
if sp_before = i2vm 0 then
$raise vm_runtime_error ("Stack underflow.")
else
let
val sp_after = sp_before - i2vm 1
val _ = registers[REGISTER_SP] := sp_after
val i = g1ofg0 (vm2sz sp_after)
(* What follows is a runtime assertion that the upper stack
boundary is not gone past, even though it certainly will
not. This is necessary (assuming one does not use something
such as $UN.prop_assert) because the stack pointer is a
vmint, whose bounds cannot be proven at compile time.
If you comment out the assertloc, the program will not pass
typechecking.
Compilers for many other languages will just insert such
checks willy-nilly, leading programmers to turn off such
instrumentation in the very code they provide to users.
One might be tempted to use Size_t instead for the stack
pointer, but what if the instruction set were later
augmented with ways to read from or write into the stack
pointer? *)
val _ = assertloc (i < vmarray_vt_length stack)
in
stack[i]
end
end
fn {}
push (vm : &vm_vt,
x : vmint) :
void =
let
macdef registers = vm.registers
macdef stack = vm.stack
val sp_before = registers[REGISTER_SP]
val i = g1ofg0 (vm2sz sp_before)
in
if vmarray_vt_length stack <= i then
$raise vm_runtime_error ("Stack overflow.")
else
let
val sp_after = sp_before + i2vm 1
in
registers[REGISTER_SP] := sp_after;
stack[i] := x
end
end
fn {}
fetch_data (vm : &vm_vt,
index : vmint) :
vmint =
let
macdef data = vm.data
val i = g1ofg0 (vm2sz index)
in
if vmarray_vt_length data <= i then
$raise vm_runtime_error ("Fetch from outside the data section.")
else
data[i]
end
fn {}
store_data (vm : &vm_vt,
index : vmint,
x : vmint) :
void =
let
macdef data = vm.data
val i = g1ofg0 (vm2sz index)
in
if vmarray_vt_length data <= i then
$raise vm_runtime_error ("Store to outside the data section.")
else
data[i] := x
end
fn {}
get_argument (vm : &vm_vt) :
vmint =
let
macdef code = vm.code
macdef registers = vm.registers
val pc = registers[REGISTER_PC]
val i = g1ofg0 (vm2sz pc)
in
if vmarray_vt_length code <= i + i2sz 4 then
$raise (vm_runtime_error
("The program counter is out of bounds."))
else
let
(* The data is stored little-endian. *)
val byte0 = byte2vm code[i]
val byte1 = byte2vm code[i + i2sz 1]
val byte2 = byte2vm code[i + i2sz 2]
val byte3 = byte2vm code[i + i2sz 3]
in
(byte0) lor (byte1 << 8) lor (byte2 << 16) lor (byte3 << 24)
end
end
fn {}
skip_argument (vm : &vm_vt) :
void =
let
macdef registers = vm.registers
val pc = registers[REGISTER_PC]
in
registers[REGISTER_PC] := pc + i2vm 4
end
extern fun {}
unary_operation$inner : vmint -<> vmint
fn {}
unary_operation (vm : &vm_vt) :
void =
let
macdef registers = vm.registers
macdef stack = vm.stack
val sp = registers[REGISTER_SP]
val i = g1ofg0 (vm2sz (sp))
prval _ = lemma_g1uint_param i
in
if i = i2sz 0 then
$raise vm_runtime_error ("Stack underflow.")
else
let
val _ = assertloc (i < vmarray_vt_length stack)
(* The actual unary operation is inserted here during
template expansion. *)
val result = unary_operation$inner<> (stack[i - 1])
in
stack[i - 1] := result
end
end
extern fun {}
binary_operation$inner : (vmint, vmint) -<> vmint
fn {}
binary_operation (vm : &vm_vt) :
void =
let
macdef registers = vm.registers
macdef stack = vm.stack
val sp_before = registers[REGISTER_SP]
val i = g1ofg0 (vm2sz (sp_before))
prval _ = lemma_g1uint_param i
in
if i <= i2sz 1 then
$raise vm_runtime_error ("Stack underflow.")
else
let
val _ = registers[REGISTER_SP] := sp_before - i2vm 1
val _ = assertloc (i < vmarray_vt_length stack)
(* The actual binary operation is inserted here during
template expansion. *)
val result =
binary_operation$inner<> (stack[i - 2], stack[i - 1])
in
stack[i - 2] := result
end
end
fn {}
uop_neg (vm : &vm_vt) :
void =
let
implement {}
unary_operation$inner (x) =
twos_complement x
in
unary_operation (vm)
end
fn {}
uop_not (vm : &vm_vt) :
void =
let
implement {}
unary_operation$inner (x) =
logical_not x
in
unary_operation (vm)
end
fn {}
binop_add (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x + y
in
binary_operation (vm)
end
fn {}
binop_sub (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x - y
in
binary_operation (vm)
end
fn {}
binop_mul (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_mul y
in
binary_operation (vm)
end
fn {}
binop_div (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_div y
in
binary_operation (vm)
end
fn {}
binop_mod (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_mod y
in
binary_operation (vm)
end
fn {}
binop_eq (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \equality y
in
binary_operation (vm)
end
fn {}
binop_ne (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \inequality y
in
binary_operation (vm)
end
fn {}
binop_lt (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_lt y
in
binary_operation (vm)
end
fn {}
binop_gt (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_gt y
in
binary_operation (vm)
end
fn {}
binop_le (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_lte y
in
binary_operation (vm)
end
fn {}
binop_ge (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \signed_gte y
in
binary_operation (vm)
end
fn {}
binop_and (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \logical_and y
in
binary_operation (vm)
end
fn {}
binop_or (vm : &vm_vt) :
void =
let
implement {}
binary_operation$inner (x, y) =
x \logical_or y
in
binary_operation (vm)
end
fn {}
do_push (vm : &vm_vt) :
void =
let
val arg = get_argument (vm)
in
push (vm, arg);
skip_argument (vm)
end
fn {}
do_fetch (vm : &vm_vt) :
void =
let
val i = get_argument (vm)
val x = fetch_data (vm, i)
in
push (vm, x);
skip_argument (vm)
end
fn {}
do_store (vm : &vm_vt) :
void =
let
val i = get_argument (vm)
val x = pop (vm)
in
store_data (vm, i, x);
skip_argument (vm)
end
fn {}
do_jmp (vm : &vm_vt) :
void =
let
macdef registers = vm.registers
val arg = get_argument (vm)
val pc = registers[REGISTER_PC]
in
registers[REGISTER_PC] := pc + arg
end
fn {}
do_jz (vm : &vm_vt) :
void =
let
val x = pop (vm)
in
if x = i2vm 0 then
do_jmp (vm)
else
skip_argument (vm)
end
fn {}
do_prtc (f_output : FILEref,
vm : &vm_vt) :
void =
let
val x = pop (vm)
in
fileref_putc (f_output, vm2i x)
end
fn {}
do_prti (f_output : FILEref,
vm : &vm_vt) :
void =
let
val x = pop (vm)
in
fprint! (f_output, vm2i x)
end
fn {}
do_prts (f_output : FILEref,
vm : &vm_vt) :
void =
let
val i = g1ofg0 (vm2sz (pop (vm)))
in
if vmstrings_section_vt_length (vm.strings) <= i then
$raise vm_runtime_error ("String index out of bounds.")
else
vmstring_fprint (f_output, vm.strings, i)
end
fn
vm_step (f_output : FILEref,
vm : &vm_vt,
machine_halt : &bool,
bad_opcode : &bool) :
void =
let
macdef code = vm.code
macdef registers = vm.registers
val pc = registers[REGISTER_PC]
val i = g1ofg0 (vm2sz (pc))
prval _ = lemma_g1uint_param i
in
if vmarray_vt_length (code) <= i then
$raise (vm_runtime_error
("The program counter is out of bounds."))
else
let
val _ = registers[REGISTER_PC] := pc + i2vm 1
val opcode = code[i]
val u_opcode = byte2uint0 opcode
in
(* Dispatch by bifurcation on the bit pattern of the
opcode. This method is logarithmic in the number
of opcode values. *)
machine_halt := false;
bad_opcode := false;
if (u_opcode land (~(0x1FU))) = 0U then
begin
if (u_opcode land 0x10U) = 0U then
begin
if (u_opcode land 0x08U) = 0U then
begin
if (u_opcode land 0x04U) = 0U then
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
(* OP_HALT *)
machine_halt := true
else
binop_add (vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
binop_sub (vm)
else
binop_mul (vm)
end
end
else
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
binop_div (vm)
else
binop_mod (vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
binop_lt (vm)
else
binop_gt (vm)
end
end
end
else
begin
if (u_opcode land 0x04U) = 0U then
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
binop_le (vm)
else
binop_ge (vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
binop_eq (vm)
else
binop_ne (vm)
end
end
else
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
binop_and (vm)
else
binop_or (vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
uop_neg (vm)
else
uop_not (vm)
end
end
end
end
else
begin
if (u_opcode land 0x08U) = 0U then
begin
if (u_opcode land 0x04U) = 0U then
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
do_prtc (f_output, vm)
else
do_prti (f_output, vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
do_prts (f_output, vm)
else
do_fetch (vm)
end
end
else
begin
if (u_opcode land 0x02U) = 0U then
begin
if (u_opcode land 0x01U) = 0U then
do_store (vm)
else
do_push (vm)
end
else
begin
if (u_opcode land 0x01U) = 0U then
do_jmp (vm)
else
do_jz (vm)
end
end
end
else
bad_opcode := true
end
end
else
bad_opcode := true
end
end
fn
vm_continue (f_output : FILEref,
vm : &vm_vt) :
void =
let
fun
loop (vm : &vm_vt,
machine_halt : &bool,
bad_opcode : &bool) : void =
if ~machine_halt && ~bad_opcode then
begin
vm_step (f_output, vm, machine_halt, bad_opcode);
loop (vm, machine_halt, bad_opcode)
end
var machine_halt : bool = false
var bad_opcode : bool = false
in
loop (vm, machine_halt, bad_opcode);
if bad_opcode then
$raise vm_runtime_error ("Unrecognized opcode at runtime.")
end
fn
vm_initialize (vm : &vm_vt) :
void =
let
macdef data = vm.data
macdef registers = vm.registers
in
vmarray_vt_fill (data, i2vm 0);
registers[REGISTER_PC] := i2vm 0;
registers[REGISTER_SP] := i2vm 0
end
fn
vm_run (f_output : FILEref,
vm : &vm_vt) :
void =
begin
vm_initialize (vm);
vm_continue (f_output, vm)
end
(********************************************************************)
implement
main0 (argc, argv) =
{
val inpfname =
if 2 <= argc then
$UN.cast{string} argv[1]
else
"-"
val outfname =
if 3 <= argc then
$UN.cast{string} argv[2]
else
"-"
val inpf =
if (inpfname : string) = "-" then
stdin_ref
else
fileref_open_exn (inpfname, file_mode_r)
val outf =
if (outfname : string) = "-" then
stdout_ref
else
fileref_open_exn (outfname, file_mode_w)
(* The following order must match that established by
OP_HALT, OP_ADD, OP_SUB, etc. *)
var opcode_order =
@[String0][OPCODE_COUNT] ("halt", // 00000 bit pattern
"add", // 00001
"sub", // 00010
"mul", // 00011
"div", // 00100
"mod", // 00101
"lt", // 00110
"gt", // 00111
"le", // 01000
"ge", // 01001
"eq", // 01010
"ne", // 01011
"and", // 01100
"or", // 01101
"neg", // 01110
"not", // 01111
"prtc", // 10000
"prti", // 10001
"prts", // 10010
"fetch", // 10011
"store", // 10100
"push", // 10101
"jmp", // 10110
"jz") // 10111
val _ = ensure_that_vmint_is_suitable ()
var vm = read_vm (inpf, opcode_order)
val _ = vm_run (outf, vm)
val _ = vm_vt_free vm
}
(********************************************************************)- Output:
$ patscc -O3 -DATS_MEMALLOC_LIBC -o vm vm-postiats.dats -latslib && ./lex < compiler-tests/count.t | ./parse | ./gen | ./vm
count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
Compiler
It seemed interesting to write translators from virtual machine code to other languages. Find at https://pastebin.com/pntTVTN3 a translator from Rosetta Code VM assembly language to ATS. The ATS program can be compiled to native code, which should run pretty fast if you use the C optimizer.
An ongoing project, to extend the translator to output languages other than ATS, is at https://sourceforge.net/p/chemoelectric/rosettacode-contributions/ci/default/tree/vmc.dats
AWK
Tested with gawk 4.1.1 and mawk 1.3.4.
function error(msg) {
printf("%s\n", msg)
exit(1)
}
function bytes_to_int(bstr, i, sum) {
sum = 0
for (i=word_size-1; i>=0; i--) {
sum *= 256
sum += code[bstr+i]
}
return sum
}
function emit_byte(x) {
code[next_free_code_index++] = x
}
function emit_word(x, i) {
for (i=0; i<word_size; i++) {
emit_byte(int(x)%256);
x = int(x/256)
}
}
function run_vm(data_size) {
sp = data_size + 1
pc = 0
while (1) {
op = code[pc++]
if (op == FETCH) {
stack[sp++] = stack[bytes_to_int(pc)]
pc += word_size
} else if (op == STORE) {
stack[bytes_to_int(pc)] = stack[--sp]
pc += word_size
} else if (op == PUSH) {
stack[sp++] = bytes_to_int(pc)
pc += word_size
} else if (op == ADD ) { stack[sp-2] += stack[sp-1]; sp--
} else if (op == SUB ) { stack[sp-2] -= stack[sp-1]; sp--
} else if (op == MUL ) { stack[sp-2] *= stack[sp-1]; sp--
} else if (op == DIV ) { stack[sp-2] = int(stack[sp-2] / stack[sp-1]); sp--
} else if (op == MOD ) { stack[sp-2] %= stack[sp-1]; sp--
} else if (op == LT ) { stack[sp-2] = stack[sp-2] < stack[sp-1]; sp--
} else if (op == GT ) { stack[sp-2] = stack[sp-2] > stack[sp-1]; sp--
} else if (op == LE ) { stack[sp-2] = stack[sp-2] <= stack[sp-1]; sp--
} else if (op == GE ) { stack[sp-2] = stack[sp-2] >= stack[sp-1]; sp--
} else if (op == EQ ) { stack[sp-2] = stack[sp-2] == stack[sp-1]; sp--
} else if (op == NE ) { stack[sp-2] = stack[sp-2] != stack[sp-1]; sp--
} else if (op == AND ) { stack[sp-2] = stack[sp-2] && stack[sp-1]; sp--
} else if (op == OR ) { stack[sp-2] = stack[sp-2] || stack[sp-1]; sp--
} else if (op == NEG ) { stack[sp-1] = - stack[sp-1]
} else if (op == NOT ) { stack[sp-1] = ! stack[sp-1]
} else if (op == JMP ) { pc += bytes_to_int(pc)
} else if (op == JZ ) { if (stack[--sp]) { pc += word_size } else { pc += bytes_to_int(pc) }
} else if (op == PRTC) { printf("%c", stack[--sp])
} else if (op == PRTS) { printf("%s", string_pool[stack[--sp]])
} else if (op == PRTI) { printf("%d", stack[--sp])
} else if (op == HALT) { break
}
} # while
}
function str_trans(srce, dest, i) {
dest = ""
for (i=1; i <= length(srce); ) {
if (substr(srce, i, 1) == "\\" && i < length(srce)) {
if (substr(srce, i+1, 1) == "n") {
dest = dest "\n"
i += 2
} else if (substr(srce, i+1, 1) == "\\") {
dest = dest "\\"
i += 2
}
} else {
dest = dest substr(srce, i, 1)
i += 1
}
}
return dest
}
function load_code( n, i) {
getline line
if (line == "")
error("empty line")
n=split(line, line_list)
data_size = line_list[2]
n_strings = line_list[4]
for (i=0; i<n_strings; i++) {
getline line
gsub(/\n/, "", line)
gsub(/"/ , "", line)
string_pool[i] = str_trans(line)
}
while (getline) {
offset = int($1)
instr = $2
opcode = code_map[instr]
if (opcode == "")
error("Unknown instruction " instr " at " offset)
emit_byte(opcode)
if (opcode == JMP || opcode == JZ) {
p = int($4)
emit_word(p - (offset + 1))
} else if (opcode == PUSH) {
value = int($3)
emit_word(value)
} else if (opcode == FETCH || opcode == STORE) {
gsub(/\[/, "", $3)
gsub(/\]/, "", $3)
value = int($3)
emit_word(value)
}
}
return data_size
}
BEGIN {
code_map["fetch"] = FETCH = 1
code_map["store"] = STORE = 2
code_map["push" ] = PUSH = 3
code_map["add" ] = ADD = 4
code_map["sub" ] = SUB = 5
code_map["mul" ] = MUL = 6
code_map["div" ] = DIV = 7
code_map["mod" ] = MOD = 8
code_map["lt" ] = LT = 9
code_map["gt" ] = GT = 10
code_map["le" ] = LE = 11
code_map["ge" ] = GE = 12
code_map["eq" ] = EQ = 13
code_map["ne" ] = NE = 14
code_map["and" ] = AND = 15
code_map["or" ] = OR = 16
code_map["neg" ] = NEG = 17
code_map["not" ] = NOT = 18
code_map["jmp" ] = JMP = 19
code_map["jz" ] = JZ = 20
code_map["prtc" ] = PRTC = 21
code_map["prts" ] = PRTS = 22
code_map["prti" ] = PRTI = 23
code_map["halt" ] = HALT = 24
next_free_node_index = 1
next_free_code_index = 0
word_size = 4
input_file = "-"
if (ARGC > 1)
input_file = ARGV[1]
data_size = load_code()
run_vm(data_size)
}
- Output — count:
count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
C
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <stdint.h>
#include <ctype.h>
#define NELEMS(arr) (sizeof(arr) / sizeof(arr[0]))
#define da_dim(name, type) type *name = NULL; \
int _qy_ ## name ## _p = 0; \
int _qy_ ## name ## _max = 0
#define da_redim(name) do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)
#define da_rewind(name) _qy_ ## name ## _p = 0
#define da_append(name, x) do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)
typedef unsigned char uchar;
typedef uchar code;
typedef enum { FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND,
OR, NEG, NOT, JMP, JZ, PRTC, PRTS, PRTI, HALT
} Code_t;
typedef struct Code_map {
char *text;
Code_t op;
} Code_map;
Code_map code_map[] = {
{"fetch", FETCH},
{"store", STORE},
{"push", PUSH },
{"add", ADD },
{"sub", SUB },
{"mul", MUL },
{"div", DIV },
{"mod", MOD },
{"lt", LT },
{"gt", GT },
{"le", LE },
{"ge", GE },
{"eq", EQ },
{"ne", NE },
{"and", AND },
{"or", OR },
{"neg", NEG },
{"not", NOT },
{"jmp", JMP },
{"jz", JZ },
{"prtc", PRTC },
{"prts", PRTS },
{"prti", PRTI },
{"halt", HALT },
};
FILE *source_fp;
da_dim(object, code);
void error(const char *fmt, ... ) {
va_list ap;
char buf[1000];
va_start(ap, fmt);
vsprintf(buf, fmt, ap);
va_end(ap);
printf("error: %s\n", buf);
exit(1);
}
/*** Virtual Machine interpreter ***/
void run_vm(const code obj[], int32_t data[], int g_size, char **string_pool) {
int32_t *sp = &data[g_size + 1];
const code *pc = obj;
again:
switch (*pc++) {
case FETCH: *sp++ = data[*(int32_t *)pc]; pc += sizeof(int32_t); goto again;
case STORE: data[*(int32_t *)pc] = *--sp; pc += sizeof(int32_t); goto again;
case PUSH: *sp++ = *(int32_t *)pc; pc += sizeof(int32_t); goto again;
case ADD: sp[-2] += sp[-1]; --sp; goto again;
case SUB: sp[-2] -= sp[-1]; --sp; goto again;
case MUL: sp[-2] *= sp[-1]; --sp; goto again;
case DIV: sp[-2] /= sp[-1]; --sp; goto again;
case MOD: sp[-2] %= sp[-1]; --sp; goto again;
case LT: sp[-2] = sp[-2] < sp[-1]; --sp; goto again;
case GT: sp[-2] = sp[-2] > sp[-1]; --sp; goto again;
case LE: sp[-2] = sp[-2] <= sp[-1]; --sp; goto again;
case GE: sp[-2] = sp[-2] >= sp[-1]; --sp; goto again;
case EQ: sp[-2] = sp[-2] == sp[-1]; --sp; goto again;
case NE: sp[-2] = sp[-2] != sp[-1]; --sp; goto again;
case AND: sp[-2] = sp[-2] && sp[-1]; --sp; goto again;
case OR: sp[-2] = sp[-2] || sp[-1]; --sp; goto again;
case NEG: sp[-1] = -sp[-1]; goto again;
case NOT: sp[-1] = !sp[-1]; goto again;
case JMP: pc += *(int32_t *)pc; goto again;
case JZ: pc += (*--sp == 0) ? *(int32_t *)pc : (int32_t)sizeof(int32_t); goto again;
case PRTC: printf("%c", sp[-1]); --sp; goto again;
case PRTS: printf("%s", string_pool[sp[-1]]); --sp; goto again;
case PRTI: printf("%d", sp[-1]); --sp; goto again;
case HALT: break;
default: error("Unknown opcode %d\n", *(pc - 1));
}
}
char *read_line(int *len) {
static char *text = NULL;
static int textmax = 0;
for (*len = 0; ; (*len)++) {
int ch = fgetc(source_fp);
if (ch == EOF || ch == '\n') {
if (*len == 0)
return NULL;
break;
}
if (*len + 1 >= textmax) {
textmax = (textmax == 0 ? 128 : textmax * 2);
text = realloc(text, textmax);
}
text[*len] = ch;
}
text[*len] = '\0';
return text;
}
char *rtrim(char *text, int *len) { // remove trailing spaces
for (; *len > 0 && isspace(text[*len - 1]); --(*len))
;
text[*len] = '\0';
return text;
}
char *translate(char *st) {
char *p, *q;
if (st[0] == '"') // skip leading " if there
++st;
p = q = st;
while ((*p++ = *q++) != '\0') {
if (q[-1] == '\\') {
if (q[0] == 'n') {
p[-1] = '\n';
++q;
} else if (q[0] == '\\') {
++q;
}
}
if (q[0] == '"' && q[1] == '\0') // skip trialing " if there
++q;
}
return st;
}
/* convert an opcode string into its byte value */
int findit(const char text[], int offset) {
for (size_t i = 0; i < sizeof(code_map) / sizeof(code_map[0]); i++) {
if (strcmp(code_map[i].text, text) == 0)
return code_map[i].op;
}
error("Unknown instruction %s at %d\n", text, offset);
return -1;
}
void emit_byte(int c) {
da_append(object, (uchar)c);
}
void emit_int(int32_t n) {
union {
int32_t n;
unsigned char c[sizeof(int32_t)];
} x;
x.n = n;
for (size_t i = 0; i < sizeof(x.n); ++i) {
emit_byte(x.c[i]);
}
}
/*
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
154 jmp (-73) 82
164 jz (32) 197
175 push 0
159 fetch [4]
149 store [3]
*/
/* Load code into global array object, return the string pool and data size */
char **load_code(int *ds) {
int line_len, n_strings;
char **string_pool;
char *text = read_line(&line_len);
text = rtrim(text, &line_len);
strtok(text, " "); // skip "Datasize:"
*ds = atoi(strtok(NULL, " ")); // get actual data_size
strtok(NULL, " "); // skip "Strings:"
n_strings = atoi(strtok(NULL, " ")); // get number of strings
string_pool = malloc(n_strings * sizeof(char *));
for (int i = 0; i < n_strings; ++i) {
text = read_line(&line_len);
text = rtrim(text, &line_len);
text = translate(text);
string_pool[i] = strdup(text);
}
for (;;) {
int len;
text = read_line(&line_len);
if (text == NULL)
break;
text = rtrim(text, &line_len);
int offset = atoi(strtok(text, " ")); // get the offset
char *instr = strtok(NULL, " "); // get the instruction
int opcode = findit(instr, offset);
emit_byte(opcode);
char *operand = strtok(NULL, " ");
switch (opcode) {
case JMP: case JZ:
operand++; // skip the '('
len = strlen(operand);
operand[len - 1] = '\0'; // remove the ')'
emit_int(atoi(operand));
break;
case PUSH:
emit_int(atoi(operand));
break;
case FETCH: case STORE:
operand++; // skip the '['
len = strlen(operand);
operand[len - 1] = '\0'; // remove the ']'
emit_int(atoi(operand));
break;
}
}
return string_pool;
}
void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) {
if (fn[0] == '\0')
*fp = std;
else if ((*fp = fopen(fn, mode)) == NULL)
error(0, 0, "Can't open %s\n", fn);
}
int main(int argc, char *argv[]) {
init_io(&source_fp, stdin, "r", argc > 1 ? argv[1] : "");
int data_size;
char **string_pool = load_code(&data_size);
int data[1000 + data_size];
run_vm(object, data, data_size, string_pool);
}
C++
This example passes all tests, although for brevity of output only one test result is shown.
#include <cstdint>
#include <fstream>
#include <iostream>
#include <sstream>
#include <string>
#include <unordered_map>
#include <vector>
std::vector<std::string> split_string(const std::string& text, const char& delimiter) {
std::vector<std::string> lines;
std::istringstream stream(text);
std::string line;
while ( std::getline(stream, line, delimiter) ) {
if ( ! line.empty() ) {
lines.emplace_back(line);
}
}
return lines;
}
std::string parseString(const std::string& text) {
std::string result = "";
uint32_t i = 0;
while ( i < text.length() ) {
if ( text[i] == '\\' && i + 1 < text.length() ) {
if ( text[i + 1] == 'n' ) {
result += "\n";
i++;
} else if ( text[i + 1] == '\\') {
result += "\\";
i++;
}
} else {
result += text[i];
}
i++;
}
return result;
}
void add_to_codes(const uint32_t& number, std::vector<uint8_t>& codes) {
for ( uint32_t i = 0; i < 32; i += 8 ) {
codes.emplace_back((number >> i) & 0xff);
}
}
uint32_t operand(const uint32_t& index, const std::vector<uint8_t>& codes) {
uint32_t result = 0;
for ( uint32_t i = index + 3; i >= index; --i ) {
result = ( result << 8 ) + codes[i];
}
return result;
}
struct VirtualMachineInfo {
uint32_t data_size;
std::vector<std::string> vm_strings;
std::vector<uint8_t> codes;
};
enum class Op_code {
HALT, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT,
PRTC, PRTI, PRTS, FETCH, STORE, PUSH, JMP, JZ
};
std::unordered_map<std::string, Op_code> string_to_enum = {
{ "halt", Op_code::HALT }, { "add", Op_code::ADD }, { "sub", Op_code::SUB },
{ "mul", Op_code::MUL }, { "div", Op_code::DIV }, { "mod", Op_code::MOD },
{ "lt", Op_code::LT }, { "gt", Op_code::GT }, { "le", Op_code::LE },
{ "ge", Op_code::GE }, { "eq", Op_code::EQ }, { "ne", Op_code::NE },
{ "and", Op_code::AND }, { "or", Op_code::OR }, { "neg", Op_code::NEG },
{ "not", Op_code::NOT }, { "prtc", Op_code::PRTC }, { "prti", Op_code::PRTI },
{ "prts", Op_code::PRTS }, { "fetch", Op_code::FETCH }, { "store", Op_code::STORE },
{ "push", Op_code::PUSH }, { "jmp", Op_code::JMP }, { "jz", Op_code::JZ }
};
VirtualMachineInfo load_code(const std::string& file_path) {
std::ifstream stream(file_path);
std::vector<std::string> lines;
std::string line;
while ( std::getline(stream, line) ) {
lines.emplace_back(line);
}
line = lines.front();
if ( line.substr(0, 3) == "lex" ) {
lines.erase(lines.begin());
line = lines.front();
}
std::vector<std::string> sections = split_string(line, ' ');
const uint32_t data_size = std::stoi(sections[1]);
const uint32_t string_count = std::stoi(sections[3]);
std::vector<std::string> vm_strings = { };
for ( uint32_t i = 1; i <= string_count; ++i ) {
std::string content = lines[i].substr(1, lines[i].length() - 2);
vm_strings.emplace_back(parseString(content));
}
uint32_t offset = 0;
std::vector<uint8_t> codes = { };
for ( uint32_t i = string_count + 1; i < lines.size(); ++i ) {
sections = split_string(lines[i], ' ');
offset = std::stoi(sections[0]);
Op_code op_code = string_to_enum[sections[1]];
codes.emplace_back(static_cast<uint8_t>(op_code));
switch ( op_code ) {
case Op_code::FETCH :
case Op_code::STORE :
add_to_codes(std::stoi(sections[2].substr(1, sections[2].length() - 2)), codes); break;
case Op_code::PUSH : add_to_codes(std::stoi(sections[2]), codes); break;
case Op_code::JMP :
case Op_code::JZ : add_to_codes(std::stoi(sections[3]) - offset - 1, codes); break;
default : break;
}
}
return VirtualMachineInfo(data_size, vm_strings, codes);
}
void runVirtualMachine(const uint32_t& data_size, const std::vector<std::string>& vm_strings,
const std::vector<uint8_t>& codes) {
const uint32_t word_size = 4;
std::vector<int32_t> stack(data_size, 0);
uint32_t index = 0;
Op_code op_code;
while ( op_code != Op_code::HALT ) {
op_code = static_cast<Op_code>(codes[index]);
index++;
switch ( op_code ) {
case Op_code::HALT : break;
case Op_code::ADD : stack[stack.size() - 2] += stack.back(); stack.pop_back(); break;
case Op_code::SUB : stack[stack.size() - 2] -= stack.back(); stack.pop_back(); break;
case Op_code::MUL : stack[stack.size() - 2] *= stack.back(); stack.pop_back(); break;
case Op_code::DIV : stack[stack.size() - 2] /= stack.back(); stack.pop_back(); break;
case Op_code::MOD : stack[stack.size() - 2] %= stack.back(); stack.pop_back(); break;
case Op_code::LT :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] < stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::GT :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] > stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::LE :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] <= stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::GE :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] >= stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::EQ :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] == stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::NE :
{ stack[stack.size() - 2] = ( stack[stack.size() - 2] != stack.back() ) ? 1 : 0;
stack.pop_back(); break;
}
case Op_code::AND :
{ uint32_t value = ( stack[stack.size() - 2] != 0 && stack.back() != 0 ) ? 1 : 0;
stack[stack.size() - 2] = value; stack.pop_back(); break;
}
case Op_code::OR :
{ uint32_t value = ( stack[stack.size() - 2] != 0 || stack.back() != 0 ) ? 1 : 0;
stack[stack.size() - 2] = value; stack.pop_back(); break;
}
case Op_code::NEG : stack.back() = -stack.back(); break;
case Op_code::NOT : stack.back() = ( stack.back() == 0 ) ? 1 : 0; break;
case Op_code::PRTC : std::cout << static_cast<char>(stack.back()); stack.pop_back(); break;
case Op_code::PRTI : std::cout << stack.back(); stack.pop_back(); break;
case Op_code::PRTS : std::cout << vm_strings[stack.back()]; stack.pop_back(); break;
case Op_code::FETCH : { stack.emplace_back(stack[operand(index, codes)]);
index += word_size; break;
}
case Op_code::STORE : { stack[operand(index, codes)] = stack.back(); index += word_size;
stack.pop_back(); break;
}
case Op_code::PUSH : stack.emplace_back(operand(index, codes)); index += word_size; break;
case Op_code::JMP : index += operand(index, codes); break;
case Op_code::JZ : { index += ( stack.back() == 0 ) ? operand(index, codes) : word_size;
stack.pop_back(); break;
}
}
}
}
int main() {
VirtualMachineInfo info = load_code("Compiler Test Cases/AsciiMandlebrot.txt");
runVirtualMachine(info.data_size, info.vm_strings, info.codes);
}
- Output:
1111111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222211111 1111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222222222211 1111111111111111112222222222222222222222222222222222222222222222222222222222222222222222222222222222222 1111111111111111222222222222222222233333333333333333333333222222222222222222222222222222222222222222222 1111111111111112222222222222333333333333333333333333333333333333222222222222222222222222222222222222222 1111111111111222222222233333333333333333333333344444456655544443333332222222222222222222222222222222222 1111111111112222222233333333333333333333333444444445567@@6665444444333333222222222222222222222222222222 11111111111222222333333333333333333333334444444445555679@@@@7654444443333333222222222222222222222222222 1111111112222223333333333333333333333444444444455556789@@@@98755544444433333332222222222222222222222222 1111111122223333333333333333333333344444444445556668@@@ @@@76555544444333333322222222222222222222222 1111111222233333333333333333333344444444455566667778@@ @987666555544433333333222222222222222222222 111111122333333333333333333333444444455556@@@@@99@@@@@@ @@@@@@877779@5443333333322222222222222222222 1111112233333333333333333334444455555556679@ @@@ @@@@@@ 8544333333333222222222222222222 1111122333333333333333334445555555556666789@@@ @86554433333333322222222222222222 1111123333333333333444456666555556666778@@ @ @@87655443333333332222222222222222 111123333333344444455568@887789@8777788@@@ @@@@65444333333332222222222222222 111133334444444455555668@@@@@@@@@@@@99@@@ @@765444333333333222222222222222 111133444444445555556778@@@ @@@@ @855444333333333222222222222222 11124444444455555668@99@@ @ @655444433333333322222222222222 11134555556666677789@@ @86655444433333333322222222222222 111 @@876555444433333333322222222222222 11134555556666677789@@ @86655444433333333322222222222222 11124444444455555668@99@@ @ @655444433333333322222222222222 111133444444445555556778@@@ @@@@ @855444333333333222222222222222 111133334444444455555668@@@@@@@@@@@@99@@@ @@765444333333333222222222222222 111123333333344444455568@887789@8777788@@@ @@@@65444333333332222222222222222 1111123333333333333444456666555556666778@@ @ @@87655443333333332222222222222222 1111122333333333333333334445555555556666789@@@ @86554433333333322222222222222222 1111112233333333333333333334444455555556679@ @@@ @@@@@@ 8544333333333222222222222222222 111111122333333333333333333333444444455556@@@@@99@@@@@@ @@@@@@877779@5443333333322222222222222222222 1111111222233333333333333333333344444444455566667778@@ @987666555544433333333222222222222222222222 1111111122223333333333333333333333344444444445556668@@@ @@@76555544444333333322222222222222222222222 1111111112222223333333333333333333333444444444455556789@@@@98755544444433333332222222222222222222222222 11111111111222222333333333333333333333334444444445555679@@@@7654444443333333222222222222222222222222222 1111111111112222222233333333333333333333333444444445567@@6665444444333333222222222222222222222222222222 1111111111111222222222233333333333333333333333344444456655544443333332222222222222222222222222222222222 1111111111111112222222222222333333333333333333333333333333333333222222222222222222222222222222222222222 1111111111111111222222222222222222233333333333333333333333222222222222222222222222222222222222222222222 1111111111111111112222222222222222222222222222222222222222222222222222222222222222222222222222222222222 1111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222222222211
COBOL
Code by Steve Williams (with changes to work around code highlighting issues). Tested with GnuCOBOL 2.2.
>>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. vminterpreter.
environment division.
configuration section.
repository. function all intrinsic.
input-output section.
file-control.
select input-file assign using input-name
status is input-status
organization is line sequential.
data division.
file section.
fd input-file.
01 input-record pic x(64).
working-storage section.
01 program-name pic x(32).
01 input-name pic x(32).
01 input-status pic xx.
01 error-record pic x(64) value spaces global.
01 v-max pic 99.
01 parameters.
03 offset pic 999.
03 opcode pic x(8).
03 parm0 pic x(16).
03 parm1 pic x(16).
03 parm2 pic x(16).
01 opcodes.
03 opFETCH pic x value x'00'.
03 opSTORE pic x value x'01'.
03 opPUSH pic x value x'02'.
03 opADD pic x value x'03'.
03 opSUB pic x value x'04'.
03 opMUL pic x value x'05'.
03 opDIV pic x value x'06'.
03 opMOD pic x value x'07'.
03 opLT pic x value x'08'.
03 opGT pic x value x'09'.
03 opLE pic x value x'0A'.
03 opGE pic x value x'0B'.
03 opEQ pic x value x'0C'.
03 opNE pic x value x'0D'.
03 opAND pic x value x'0E'.
03 opOR pic x value x'0F'.
03 opNEG pic x value x'10'.
03 opNOT pic x value x'11'.
03 opJMP pic x value x'13'.
03 opJZ pic x value x'14'.
03 opPRTC pic x value x'15'.
03 opPRTS pic x value x'16'.
03 opPRTI pic x value x'17'.
03 opHALT pic x value x'18'.
01 filler.
03 s pic 99.
03 s-max pic 99 value 0.
03 s-lim pic 99 value 16.
03 filler occurs 16.
05 string-length pic 99.
05 string-entry pic x(48).
01 filler.
03 v pic 99.
03 v-lim pic 99 value 16.
03 variables occurs 16 usage binary-int.
01 generated-code global.
03 c pic 999 value 1.
03 pc pic 999.
03 c-lim pic 999 value 512.
03 kode pic x(512).
01 filler.
03 stack1 pic 999 value 2.
03 stack2 pic 999 value 1.
03 stack-lim pic 999 value 998.
03 stack occurs 998 usage binary-int.
01 display-definitions global.
03 ascii-character.
05 numeric-value usage binary-char.
03 display-integer pic -(9)9.
03 word-x.
05 word usage binary-int.
03 word-length pic 9.
03 string1 pic 99.
03 length1 pic 99.
03 count1 pic 99.
03 display-pending pic x.
procedure division.
start-vminterpreter.
display 1 upon command-line *> get arg(1)
accept program-name from argument-value
move length(word) to word-length
perform load-code
perform run-code
stop run
.
run-code.
move 1 to pc
perform until pc >= c
evaluate kode(pc:1)
when opFETCH
perform push-stack
move kode(pc + 1:word-length) to word-x
add 1 to word *> convert offset to subscript
move variables(word) to stack(stack1)
add word-length to pc
when opPUSH
perform push-stack
move kode(pc + 1:word-length) to word-x
move word to stack(stack1)
add word-length to pc
when opNEG
compute stack(stack1) = -stack(stack1)
when opNOT
if stack(stack1) = 0
move 1 to stack(stack1)
else
move 0 to stack(stack1)
end-if
when opJMP
move kode(pc + 1:word-length) to word-x
move word to pc
when opHALT
if display-pending = 'Y'
display space
end-if
exit perform
when opJZ
if stack(stack1) = 0
move kode(pc + 1:word-length) to word-x
move word to pc
else
add word-length to pc
end-if
perform pop-stack
when opSTORE
move kode(pc + 1:word-length) to word-x
add 1 to word *> convert offset to subscript
move stack(stack1) to variables(word)
add word-length to pc
perform pop-stack
when opADD
add stack(stack1) to stack(stack2)
perform pop-stack
when opSUB
subtract stack(stack1) from stack(stack2)
perform pop-stack
when opMUL
multiply stack(stack1) by stack(stack2)
*>rounded mode nearest-toward-zero *> doesn't match python
perform pop-stack
when opDIV
divide stack(stack1) into stack(stack2)
*>rounded mode nearest-toward-zero *> doesn't match python
perform pop-stack
when opMOD
move mod(stack(stack2),stack(stack1)) to stack(stack2)
perform pop-stack
when opLT
if stack(stack2) < stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opGT
if stack(stack2) > stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opLE
if stack(stack2) <= stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opGE
if stack(stack2) >= stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opEQ
if stack(stack2) = stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opNE
if stack(stack2) <> stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opAND
call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
perform pop-stack
when opOR
call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
perform pop-stack
when opPRTC
move stack(stack1) to numeric-value
if numeric-value = 10
display space
move 'N' to display-pending
else
display ascii-character with no advancing
move 'Y' to display-pending
end-if
perform pop-stack
when opPRTS
add 1 to word *> convert offset to subscript
move 1 to string1
move string-length(word) to length1
perform until string1 > string-length(word)
move 0 to count1
inspect string-entry(word)(string1:length1)
tallying count1 for characters before initial '\' *> ' workaround code highlighter problem
evaluate true
when string-entry(word)(string1 + count1 + 1:1) = 'n' *> \n
display string-entry(word)(string1:count1)
move 'N' to display-pending
compute string1 = string1 + 2 + count1
compute length1 = length1 - 2 - count1
when string-entry(word)(string1 + count1 + 1:1) = '\' *> ' \\
display string-entry(word)(string1:count1 + 1) with no advancing
move 'Y' to display-pending
compute string1 = string1 + 2 + count1
compute length1 = length1 - 2 - count1
when other
display string-entry(word)(string1:count1) with no advancing
move 'Y' to display-pending
add count1 to string1
subtract count1 from length1
end-evaluate
end-perform
perform pop-stack
when opPRTI
move stack(stack1) to display-integer
display trim(display-integer) with no advancing
move 'Y' to display-pending
perform pop-stack
end-evaluate
add 1 to pc
end-perform
.
push-stack.
if stack1 >= stack-lim
string 'in vminterpreter at ' pc ' stack overflow at ' stack-lim into error-record
perform report-error
end-if
add 1 to stack1 stack2
>>d display ' push at ' pc space stack1 space stack2
.
pop-stack.
if stack1 < 2
string 'in vminterpreter at ' pc ' stack underflow' into error-record
perform report-error
end-if
>>d display ' pop at ' pc space stack1 space stack2
subtract 1 from stack1 stack2
.
load-code.
perform read-input
if input-status <> '00'
string 'in vminterpreter no input data' into error-record
perform report-error
end-if
unstring input-record delimited by all spaces into parm1 v-max parm2 s-max
if v-max > v-lim
string 'in vminterpreter datasize exceeds ' v-lim into error-record
perform report-error
end-if
if s-max > s-lim
string 'in vminterpreter number of strings exceeds ' s-lim into error-record
perform report-error
end-if
perform read-input
perform varying s from 1 by 1 until s > s-max
or input-status <> '00'
compute string-length(s) string-length(word) = length(trim(input-record)) - 2
move input-record(2:string-length(word)) to string-entry(s)
perform read-input
end-perform
if s <= s-max
string 'in vminterpreter not all strings found' into error-record
perform report-error
end-if
perform until input-status <> '00'
initialize parameters
unstring input-record delimited by all spaces into
parm0 offset opcode parm1 parm2
evaluate opcode
when 'fetch'
call 'emitbyte' using opFETCH
call 'emitword' using parm1
when 'store'
call 'emitbyte' using opSTORE
call 'emitword' using parm1
when 'push'
call 'emitbyte' using opPUSH
call 'emitword' using parm1
when 'add' call 'emitbyte' using opADD
when 'sub' call 'emitbyte' using opSUB
when 'mul' call 'emitbyte' using opMUL
when 'div' call 'emitbyte' using opDIV
when 'mod' call 'emitbyte' using opMOD
when 'lt' call 'emitbyte' using opLT
when 'gt' call 'emitbyte' using opGT
when 'le' call 'emitbyte' using opLE
when 'ge' call 'emitbyte' using opGE
when 'eq' call 'emitbyte' using opEQ
when 'ne' call 'emitbyte' using opNE
when 'and' call 'emitbyte' using opAND
when 'or' call 'emitbyte' using opOR
when 'not' call 'emitbyte' using opNOT
when 'neg' call 'emitbyte' using opNEG
when 'jmp'
call 'emitbyte' using opJMP
call 'emitword' using parm2
when 'jz'
call 'emitbyte' using opJZ
call 'emitword' using parm2
when 'prtc' call 'emitbyte' using opPRTC
when 'prts' call 'emitbyte' using opPRTS
when 'prti' call 'emitbyte' using opPRTI
when 'halt' call 'emitbyte' using opHALT
when other
string 'in vminterpreter unknown opcode ' trim(opcode) ' at ' offset into error-record
perform report-error
end-evaluate
perform read-input
end-perform
.
read-input.
if program-name = spaces
move '00' to input-status
accept input-record on exception move '10' to input-status end-accept
exit paragraph
end-if
if input-name = spaces
string program-name delimited by space '.gen' into input-name
open input input-file
if input-status <> '00'
string 'in vminterpreter ' trim(input-name) ' file open status ' input-status
into error-record
perform report-error
end-if
end-if
read input-file into input-record
evaluate input-status
when '00'
continue
when '10'
close input-file
when other
string 'in vminterpreter unexpected input-status: ' input-status into error-record
perform report-error
end-evaluate
.
report-error.
display error-record upon syserr
stop run with error status -1
.
identification division.
program-id. emitbyte.
data division.
linkage section.
01 opcode pic x.
procedure division using opcode.
start-emitbyte.
if c >= c-lim
string 'in vminterpreter emitbyte c exceeds ' c-lim into error-record
call 'reporterror'
end-if
move opcode to kode(c:1)
add 1 to c
.
end program emitbyte.
identification division.
program-id. emitword.
data division.
working-storage section.
01 word-temp pic x(8).
linkage section.
01 word-value any length.
procedure division using word-value.
start-emitword.
if c + word-length >= c-lim
string 'in vminterpreter emitword c exceeds ' c-lim into error-record
call 'reporterror'
end-if
move word-value to word-temp
inspect word-temp converting '[' to ' '
inspect word-temp converting ']' to ' '
move numval(trim(word-temp)) to word
move word-x to kode(c:word-length)
add word-length to c
.
end program emitword.
end program vminterpreter.
- Output — Count:
prompt$ ./lexer <testcases/Count | ./parser | ./generator | ./vminterpreter count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
Common Lisp
I ran it with SBCL, CCL, and ECL. SBCL gave by far the best performance on mandel.vm, although I do not know all the optimization tricks one can employ.
#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
(ros:ensure-asdf)
#+quicklisp(ql:quickload '() :silent t)
)
(defpackage :ros.script.vm.3858678051
(:use :cl))
(in-package :ros.script.vm.3858678051)
;;;
;;; The Rosetta Code Virtual Machine, in Common Lisp.
;;;
;;; Notes:
;;;
;;; * I have tried not to use foreign types or similar means of
;;; optimization.
;;;
;;; * Integers are stored in the VM's executable memory in
;;; big-endian order. Not because I prefer it, but because I do
;;; not want to get myself into a little-endian rut.
;;;
(require "cl-ppcre")
(require "trivia")
;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(defconstant executable-memory-size 65536
"The size of memory for executable code, in 8-bit words.")
;;; Similarly, I am going to have fixed size data and stack memory.
(defconstant data-memory-size 2048
"The size of memory for stored data, in 32-bit words.")
(defconstant stack-memory-size 2048
"The size of memory for the stack, in 32-bit words.")
;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(deftype word ()
'(unsigned-byte 32))
(deftype register ()
'(simple-array word (1)))
(deftype executable-memory ()
`(simple-array (unsigned-byte 8) ,(list executable-memory-size)))
(deftype data-memory ()
`(simple-array word ,(list data-memory-size)))
(deftype stack-memory ()
`(simple-array word ,(list stack-memory-size)))
(defconstant re-blank-line
(ppcre:create-scanner "^\\s*$"))
(defconstant re-parse-instr-1
(ppcre:create-scanner "^\\s*(\\d+)\\s*(.*\\S)"))
(defconstant re-parse-instr-2
(ppcre:create-scanner "(?i)^(\\S+)\\s*(.*)"))
(defconstant re-parse-instr-3
(ppcre:create-scanner "^[[(]?([0-9-]+)"))
(defconstant 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"))
(defun blank-line-p (s)
(not (not (ppcre:scan re-blank-line s))))
(defun opcode-from-name (s)
(position-if (lambda (name)
(string= s name))
opcode-names))
(defun create-executable-memory ()
(coerce (make-list executable-memory-size
:initial-element (opcode-from-name "halt"))
'executable-memory))
(defun create-data-memory ()
(coerce (make-list data-memory-size :initial-element 0)
'data-memory))
(defun create-stack-memory ()
(coerce (make-list stack-memory-size :initial-element 0)
'stack-memory))
(defun create-register ()
(coerce (make-list 1 :initial-element 0) 'register))
(defstruct machine
(sp (create-register) :type register) ; Stack pointer.
(ip (create-register) :type register) ; Instruction pointer (same
; thing as program counter).
(code (create-executable-memory) :type executable-memory)
(data (create-data-memory) :type data-memory)
(stack (create-stack-memory) :type stack-memory)
(strings nil)
output *standard-output*)
(defun insert-instruction (memory instr)
(declare (type executable-memory memory))
(trivia:match instr
((list address opcode arg)
(let ((instr-size (if arg 5 1)))
(unless (<= (+ address instr-size) executable-memory-size)
(warn "the VM's executable memory size is exceeded")
(uiop:quit 1))
(setf (elt memory address) opcode)
(when arg
;; Big-endian order.
(setf (elt memory (+ address 1)) (ldb (byte 8 24) arg))
(setf (elt memory (+ address 2)) (ldb (byte 8 16) arg))
(setf (elt memory (+ address 3)) (ldb (byte 8 8) arg))
(setf (elt memory (+ address 4)) (ldb (byte 8 0) arg)))))))
(defun load-executable-memory (memory instr-lst)
(declare (type executable-memory memory))
(loop for instr in instr-lst
do (insert-instruction memory instr)))
(defun parse-instruction (s)
(if (blank-line-p s)
nil
(let* ((strings (nth-value 1 (ppcre:scan-to-strings
re-parse-instr-1 s)))
(address (parse-integer (elt strings 0)))
(split (nth-value 1 (ppcre:scan-to-strings
re-parse-instr-2 (elt strings 1))))
(opcode-name (string-downcase (elt split 0)))
(opcode (opcode-from-name opcode-name))
(arguments (elt split 1))
(has-arg (trivia:match opcode-name
((or "fetch" "store" "push" "jmp" "jz") t)
(_ nil))))
(if has-arg
(let* ((argstr-lst
(nth-value 1 (ppcre:scan-to-strings
re-parse-instr-3 arguments)))
(argstr (elt argstr-lst 0)))
`(,address ,opcode ,(parse-integer argstr)))
`(,address ,opcode ())))))
(defun read-instructions (inpf)
(loop for line = (read-line inpf nil 'eoi)
until (eq line 'eoi)
for instr = (parse-instruction line)
when instr collect instr))
(defun read-datasize-and-strings-count (inpf)
(let ((line (read-line inpf)))
(multiple-value-bind (_whole-match strings)
;; This is a permissive implementation.
(ppcre:scan-to-strings
"(?i)^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+)"
line)
(declare (ignore _whole-match))
`(,(parse-integer (elt strings 0))
,(parse-integer (elt strings 1))))))
(defun parse-string-literal (s)
;; This is a permissive implementation, but only in that it skips
;; any leading space. It does not check carefully for outright
;; mistakes.
(let* ((s (ppcre:regex-replace "^\\s*" s ""))
(quote-mark (elt s 0))
(i 1)
(lst
(loop until (char= (elt s i) quote-mark)
collect (let ((c (elt s i)))
(if (char= c #\\)
(let ((c0 (trivia:match (elt s (1+ i))
(#\n #\newline)
(c1 c1))))
(setq i (+ i 2))
c0)
(progn
(setq i (1+ i))
c))))))
(coerce lst 'string)))
(defun read-string-literals (inpf strings-count)
(loop for i from 1 to strings-count
collect (parse-string-literal (read-line inpf))))
(defun open-inpf (inpf-filename)
(if (string= inpf-filename "-")
*standard-input*
(open inpf-filename :direction :input)))
(defun open-outf (outf-filename)
(if (string= outf-filename "-")
*standard-output*
(open outf-filename :direction :output
:if-exists :overwrite
:if-does-not-exist :create)))
(defun word-signbit-p (x)
"True if and only if the sign bit is set."
(declare (type word x))
(/= 0 (logand x #x80000000)))
(defun word-add (x y)
"Addition with overflow freely allowed."
(declare (type word x))
(declare (type word y))
(coerce (logand (+ x y) #xFFFFFFFF) 'word))
(defun word-neg (x)
"The two's complement."
(declare (type word x))
(word-add (logxor x #xFFFFFFFF) 1))
(defun word-sub (x y)
"Subtraction with overflow freely allowed."
(declare (type word x))
(declare (type word y))
(word-add x (word-neg y)))
(defun word-mul (x y)
"Signed multiplication."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-xy (the word
(logand (* abs-x abs-y) #xFFFFFFFF))))
(if x<0
(if y<0 abs-xy (word-neg abs-xy))
(if y<0 (word-neg abs-xy) abs-xy))))))
(defun word-div (x y)
"The quotient after signed integer division with truncation towards
zero."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x/y (the word
(logand (floor abs-x abs-y) #xFFFFFFFF))))
(if x<0
(if y<0 abs-x/y (word-neg abs-x/y))
(if y<0 (word-neg abs-x/y) abs-x/y))))))
(defun word-mod (x y)
"The remainder after signed integer division with truncation towards
zero."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x%y (the word
(logand (nth-value 1 (floor abs-x abs-y))
#xFFFFFFFF))))
(if x<0 (word-neg abs-x%y) abs-x%y)))))
(defun b2i (b)
(declare (type boolean b))
(if b 1 0))
(defun word-lt (x y)
"Signed comparison: is x less than y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (< x y) t)
(if y<0 nil (< x y))))))
(defun word-le (x y)
"Signed comparison: is x less than or equal to y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (<= x y) t)
(if y<0 nil (<= x y))))))
(defun word-gt (x y)
"Signed comparison: is x greater than y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (> x y) nil)
(if y<0 t (> x y))))))
(defun word-ge (x y)
"Signed comparison: is x greater than or equal to y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (>= x y) nil)
(if y<0 t (>= x y))))))
(defun word-eq (x y)
"Is x equal to y?"
(declare (type word x))
(declare (type word y))
(b2i (= x y)))
(defun word-ne (x y)
"Is x not equal to y?"
(declare (type word x))
(declare (type word y))
(b2i (/= x y)))
(defun word-cmp (x)
"The logical complement."
(declare (type word x))
(b2i (= x 0)))
(defun word-and (x y)
"The logical conjunction."
(declare (type word x))
(declare (type word y))
(b2i (and (/= x 0) (/= y 0))))
(defun word-or (x y)
"The logical disjunction."
(declare (type word x))
(declare (type word y))
(b2i (or (/= x 0) (/= y 0))))
(defun unop (stack sp operation)
"Perform a unary operation on the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type (function (word) word) operation))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (1- i))))
(setf (elt stack (1- i)) (funcall operation x)))))
(defun binop (stack sp operation)
"Perform a binary operation on the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type (function (word word) word) operation))
(let ((i (elt sp 0)))
(unless (<= 2 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (- i 2)))
(y (elt stack (1- i))))
(setf (elt stack (- i 2)) (funcall operation x y)))
(setf (elt sp 0) (1- i))))
(defun jri (code ip)
"Jump relative immediate."
(declare (type executable-memory code))
(declare (type register ip))
;; Big-endian order.
(let ((j (elt ip 0)))
(unless (<= (+ j 4) executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let* ((offset (elt code (+ j 3)))
(offset (dpb (elt code (+ j 2)) (byte 8 8) offset))
(offset (dpb (elt code (+ j 1)) (byte 8 16) offset))
(offset (dpb (elt code j) (byte 8 24) offset)))
(setf (elt ip 0) (word-add j offset)))))
(defun jriz (stack sp code ip)
"Jump relative immediate, if zero."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (1- i))))
(setf (elt sp 0) (1- i))
(if (= x 0)
(jri code ip)
(setf (elt ip 0) (+ (elt ip 0) 4))))))
(defun get-immediate-value (code ip)
(declare (type executable-memory code))
(declare (type register ip))
;; Big-endian order.
(let ((j (elt ip 0)))
(unless (<= (+ j 4) executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let* ((x (elt code (+ j 3)))
(x (dpb (elt code (+ j 2)) (byte 8 8) x))
(x (dpb (elt code (+ j 1)) (byte 8 16) x))
(x (dpb (elt code j) (byte 8 24) x)))
(setf (elt ip 0) (+ j 4))
x)))
(defun pushi (stack sp code ip)
"Push-immediate a value from executable memory onto the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(let ((i (elt sp 0)))
(unless (< i stack-memory-size)
(warn "stack overflow")
(uiop:quit 1))
(setf (elt stack i) (get-immediate-value code ip))
(setf (elt sp 0) (1+ i))))
(defun fetch (stack sp code ip data)
"Fetch data to the stack, using the storage location given in
executable memory."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(declare (type data-memory data))
(let ((i (elt sp 0)))
(unless (< i stack-memory-size)
(warn "stack overflow")
(uiop:quit 1))
(let* ((k (get-immediate-value code ip))
(x (elt data k)))
(setf (elt stack i) x)
(setf (elt sp 0) (1+ i)))))
(defun pop-one (stack sp)
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let* ((x (elt stack (1- i))))
(setf (elt sp 0) (1- i))
x)))
(defun store (stack sp code ip data)
"Store data from the stack, using the storage location given in
executable memory."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(declare (type data-memory data))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((k (get-immediate-value code ip))
(x (pop-one stack sp)))
(setf (elt data k) x))))
(defun prti (stack sp outf)
"Print the top value of the stack, as a signed decimal value."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((n (pop-one stack sp))
(n<0 (word-signbit-p n)))
(if n<0
(format outf "-~D" (word-neg n))
(format outf "~D" n))))
(defun prtc (stack sp outf)
"Print the top value of the stack, as a character."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((c (pop-one stack sp)))
(format outf "~C" (code-char c))))
(defun prts (stack sp strings outf)
"Print the string specified by the top of the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((k (pop-one stack sp))
(s (elt strings k)))
(format outf "~A" s)))
(defmacro defun-machine-binop (op)
(let ((machine-op (read-from-string
(concatenate 'string "machine-" (string op))))
(word-op (read-from-string
(concatenate 'string "word-" (string op)))))
`(defun ,machine-op (mach)
(declare (type machine mach))
(binop (machine-stack mach)
(machine-sp mach)
#',word-op))))
(defmacro defun-machine-unop (op)
(let ((machine-op (read-from-string
(concatenate 'string "machine-" (string op))))
(word-op (read-from-string
(concatenate 'string "word-" (string op)))))
`(defun ,machine-op (mach)
(declare (type machine mach))
(unop (machine-stack mach)
(machine-sp mach)
#',word-op))))
(defun-machine-binop "add")
(defun-machine-binop "sub")
(defun-machine-binop "mul")
(defun-machine-binop "div")
(defun-machine-binop "mod")
(defun-machine-binop "lt")
(defun-machine-binop "gt")
(defun-machine-binop "le")
(defun-machine-binop "ge")
(defun-machine-binop "eq")
(defun-machine-binop "ne")
(defun-machine-binop "and")
(defun-machine-binop "or")
(defun-machine-unop "neg")
(defun machine-not (mach)
(declare (type machine mach))
(unop (machine-stack mach)
(machine-sp mach)
#'word-cmp))
(defun machine-prtc (mach)
(declare (type machine mach))
(prtc (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(defun machine-prti (mach)
(declare (type machine mach))
(prti (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(defun machine-prts (mach)
(declare (type machine mach))
(prts (machine-stack mach)
(machine-sp mach)
(machine-strings mach)
(machine-output mach)))
(defun machine-fetch (mach)
(declare (type machine mach))
(fetch (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(defun machine-store (mach)
(declare (type machine mach))
(store (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(defun machine-push (mach)
(declare (type machine mach))
(pushi (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(defun machine-jmp (mach)
(declare (type machine mach))
(jri (machine-code mach)
(machine-ip mach)))
(defun machine-jz (mach)
(declare (type machine mach))
(jriz (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(defun get-opcode (mach)
(declare (type machine mach))
(let ((code (machine-code mach))
(ip (machine-ip mach)))
(let ((j (elt ip 0)))
(unless (< j executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let ((opcode (elt code j)))
(setf (elt ip 0) (1+ j))
opcode))))
(defun run-instruction (mach opcode)
(declare (type machine mach))
(declare (type fixnum opcode))
(let ((op-mod-4 (logand opcode #x3))
(op-div-4 (ash opcode -2)))
(trivia:match op-div-4
(0 (trivia:match op-mod-4
(1 (machine-add mach))
(2 (machine-sub mach))
(3 (machine-mul mach))))
(1 (trivia:match op-mod-4
(0 (machine-div mach))
(1 (machine-mod mach))
(2 (machine-lt mach))
(3 (machine-gt mach))))
(2 (trivia:match op-mod-4
(0 (machine-le mach))
(1 (machine-ge mach))
(2 (machine-eq mach))
(3 (machine-ne mach))))
(3 (trivia:match op-mod-4
(0 (machine-and mach))
(1 (machine-or mach))
(2 (machine-neg mach))
(3 (machine-not mach))))
(4 (trivia:match op-mod-4
(0 (machine-prtc mach))
(1 (machine-prti mach))
(2 (machine-prts mach))
(3 (machine-fetch mach))))
(5 (trivia:match op-mod-4
(0 (machine-store mach))
(1 (machine-push mach))
(2 (machine-jmp mach))
(3 (machine-jz mach)))))))
(defun run-vm (mach)
(declare (type machine mach))
(let ((opcode-for-halt (the fixnum (opcode-from-name "halt")))
(opcode-for-add (the fixnum (opcode-from-name "add")))
(opcode-for-jz (the fixnum (opcode-from-name "jz"))))
(loop for opcode = (the fixnum (get-opcode mach))
until (= opcode opcode-for-halt)
do (progn (when (or (< opcode opcode-for-add)
(< opcode-for-jz opcode))
(warn "unsupported opcode")
(uiop:quit 1))
(run-instruction mach opcode)))))
(defun usage-error ()
(princ "Usage: vm [INPUTFILE [OUTPUTFILE]]" *standard-output*)
(terpri *standard-output*)
(princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
*standard-output*)
(princ " standard I/O is used." *standard-output*)
(terpri *standard-output*)
(uiop:quit 1))
(defun get-filenames (argv)
(trivia:match argv
((list) '("-" "-"))
((list inpf-filename) `(,inpf-filename "-"))
((list inpf-filename outf-filename) `(,inpf-filename
,outf-filename))
(_ (usage-error))))
(defun main (&rest argv)
(let* ((filenames (get-filenames argv))
(inpf-filename (car filenames))
(inpf (open-inpf inpf-filename))
(outf-filename (cadr filenames))
(outf (open-outf outf-filename))
(sizes (read-datasize-and-strings-count inpf))
(datasize (car sizes))
(strings-count (cadr sizes))
(strings (read-string-literals inpf strings-count))
(instructions (read-instructions inpf))
;; We shall remain noncommittal about how strings are stored
;; on the hypothetical machine.
(strings (coerce strings 'simple-vector))
(mach (make-machine :strings strings
:output outf)))
(unless (<= datasize data-memory-size)
(warn "the VM's data memory size is exceeded")
(uiop:quit 1))
(load-executable-memory (machine-code mach) instructions)
(run-vm mach)
(unless (string= inpf-filename "-")
(close inpf))
(unless (string= outf-filename "-")
(close outf))
(uiop:quit 0)))
;;; vim: set ft=lisp lisp:
- Output:
$ ./vm.ros compiler-tests/count.vm count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
D
This program is fairly close to the ATS from which it was derived, although it differs greatly in certain details where the D code is significantly simpler, and was much easier to write.
If the D is optimized and compiled without bounds checks, the performance on the ASCII Mandelbrot seems comparable to that of the ATS. Differences, indeed, might rest mainly in the I/O library routines. It should be noted, though, that the ATS achieves bounds safety without runtime bounds checks; that is a major point in using it. Also, when debugging the D, I encountered a segfault due to assignment to a null class object; the ATS compiler would be much more likely to detect that kind of mistake.
//
// The Rosetta Code Virtual Machine in D.
//
// This code was migrated from an implementation in ATS. I have tried
// to keep it possible to compare the two languages easily, although
// in some cases the demonstration of "low level" techniques in ATS
// (such as avoiding memory leaks that might require garbage
// collection), or the use of linked lists as intermediate storage, or
// other such matters, seemed inappropriate to duplicate in D
// programming.
//
// (For example: in ATS, using a fully built linked list to initialize
// an array solves typechecking issues that simply do not exist in D's
// type system.)
//
import std.ascii;
import std.conv;
import std.stdint;
import std.stdio;
import std.string;
import std.typecons;
enum Op {
HALT = 0x0000, // 00000
ADD = 0x0001, // 00001
SUB = 0x0002, // 00010
MUL = 0x0003, // 00011
DIV = 0x0004, // 00100
MOD = 0x0005, // 00101
LT = 0x0006, // 00110
GT = 0x0007, // 00111
LE = 0x0008, // 01000
GE = 0x0009, // 01001
EQ = 0x000A, // 01010
NE = 0x000B, // 01011
AND = 0x000C, // 01100
OR = 0x000D, // 01101
NEG = 0x000E, // 01110
NOT = 0x000F, // 01111
PRTC = 0x0010, // 10000
PRTI = 0x0011, // 10001
PRTS = 0x0012, // 10010
FETCH = 0x0013, // 10011
STORE = 0x0014, // 10100
PUSH = 0x0015, // 10101
JMP = 0x0016, // 10110
JZ = 0x0017 // 10111
}
const string[] opcodeOrder =
["halt", // 00000 bit pattern
"add", // 00001
"sub", // 00010
"mul", // 00011
"div", // 00100
"mod", // 00101
"lt", // 00110
"gt", // 00111
"le", // 01000
"ge", // 01001
"eq", // 01010
"ne", // 01011
"and", // 01100
"or", // 01101
"neg", // 01110
"not", // 01111
"prtc", // 10000
"prti", // 10001
"prts", // 10010
"fetch", // 10011
"store", // 10100
"push", // 10101
"jmp", // 10110
"jz"]; // 10111
enum Register {
PC = 0,
SP = 1,
MAX = SP
}
alias vmint = uint32_t;
class VM {
string[] strings;
ubyte[] code;
vmint[] data;
vmint[] stack;
vmint[Register.MAX + 1] registers;
}
class BadVMException : Exception
{
this(string msg, string file = __FILE__, size_t line = __LINE__)
{
super(msg, file, line);
}
}
class VMRuntimeException : Exception
{
this(string msg, string file = __FILE__, size_t line = __LINE__)
{
super(msg, file, line);
}
}
vmint
twosComplement (vmint x)
{
// This computes the negative of x, if x is regarded as signed.
pragma(inline);
return (~x) + vmint(1U);
}
vmint
add (vmint x, vmint y)
{
// This works whether x or y is regarded as unsigned or signed.
pragma(inline);
return x + y;
}
vmint
sub (vmint x, vmint y)
{
// This works whether x or y is regarded as unsigned or signed.
pragma(inline);
return x - y;
}
vmint
equality (vmint x, vmint y)
{
pragma(inline);
return vmint(x == y);
}
vmint
inequality (vmint x, vmint y)
{
pragma(inline);
return vmint(x != y);
}
vmint
signedLt (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) < int32_t(y));
}
vmint
signedGt (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) > int32_t(y));
}
vmint
signedLte (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) <= int32_t(y));
}
vmint
signedGte (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) >= int32_t(y));
}
vmint
signedMul (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) * int32_t(y));
}
vmint
signedDiv (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) / int32_t(y));
}
vmint
signedMod (vmint x, vmint y)
{
pragma(inline);
return vmint(int32_t(x) % int32_t(y));
}
vmint
logicalNot (vmint x)
{
pragma(inline);
return vmint(!x);
}
vmint
logicalAnd (vmint x, vmint y)
{
pragma(inline);
return vmint((!!x) * (!!y));
}
vmint
logicalOr (vmint x, vmint y)
{
pragma(inline);
return (vmint(1) - vmint((!x) * (!y)));
}
vmint
parseDigits (string s, size_t i, size_t j)
{
const badInteger = "bad integer";
if (j == i)
throw new BadVMException (badInteger);
auto x = vmint(0);
for (size_t k = i; k < j; k += 1)
if (!isDigit (s[k]))
throw new BadVMException (badInteger);
else
// The result is allowed to overflow freely.
x = (vmint(10) * x) + vmint(s[k] - '0');
return x;
}
vmint
parseInteger (string s, size_t i, size_t j)
{
const badInteger = "bad integer";
vmint retval;
if (j == i)
throw new BadVMException (badInteger);
else if (j == i + vmint(1) && !isDigit (s[i]))
throw new BadVMException (badInteger);
else if (s[i] != '-')
retval = parseDigits (s, i, j);
else if (j == i + vmint(1))
throw new BadVMException (badInteger);
else
retval = twosComplement (parseDigits (s, i + vmint(1), j));
return retval;
}
size_t
skipWhitespace (string s, size_t n, size_t i)
{
while (i < n && isWhite (s[i]))
i += 1;
return i;
}
size_t
skipNonwhitespace (string s, size_t n, size_t i)
{
while (i < n && !isWhite (s[i]))
i += 1;
return i;
}
bool
substrEqual (string s, size_t i, size_t j, string t)
{
// Is s[i .. j-1] equal to t?
auto retval = false;
auto m = t.length;
if (m == j - i)
{
auto k = size_t(0);
while (k < m && s[i + k] == t[k])
k += 1;
retval = (k == m);
}
return retval;
}
string
dequoteString (string s, size_t n)
{
const badQuotedString = "bad quoted string";
string t = "";
s = strip(s);
if (s.length < 2 || s[0] != '"' || s[$ - 1] != '"')
throw new BadVMException (badQuotedString);
auto i = 1;
while (i < s.length - 1)
if (s[i] != '\\')
{
t ~= s[i];
i += 1;
}
else if (i + 1 == s.length - 1)
throw new BadVMException (badQuotedString);
else if (s[i + 1] == 'n')
{
t ~= '\n';
i += 2;
}
else if (s[i + 1] == '\\')
{
t ~= '\\';
i += 2;
}
else
throw new BadVMException (badQuotedString);
return t;
}
string[]
readStrings (File f, size_t stringsSize)
{
const badQuotedString = "Bad quoted string.";
string[] strings;
strings.length = stringsSize;
for (size_t k = 0; k < stringsSize; k += 1)
{
auto line = f.readln();
strings[k] = dequoteString (line, line.length);
}
return strings;
}
ubyte
opcodeNameTo_ubyte (string str, size_t i, size_t j)
{
size_t k = 0;
while (k < opcodeOrder.length &&
!substrEqual (str, i, j, opcodeOrder[k]))
k += 1;
if (k == opcodeOrder.length)
throw new BadVMException ("unrecognized opcode name");
return to!ubyte(k);
}
ubyte
vmintByte0 (vmint i)
{
return (i & 0xFF);
}
ubyte
vmintByte1 (vmint i)
{
return ((i >> 8) & 0xFF);
}
ubyte
vmintByte2 (vmint i)
{
return ((i >> 16) & 0xFF);
}
ubyte
vmintByte3 (vmint i)
{
return (i >> 24);
}
ubyte[]
parseInstruction (string line)
{
const bad_instruction = "bad VM instruction";
const n = line.length;
auto i = skipWhitespace (line, n, 0);
// Skip the address field.
i = skipNonwhitespace (line, n, i);
i = skipWhitespace (line, n, i);
auto j = skipNonwhitespace (line, n, i);
auto opcode = opcodeNameTo_ubyte (line, i, j);
auto startOfArgument = j;
ubyte[] finishPush ()
{
const i1 = skipWhitespace (line, n, startOfArgument);
const j1 = skipNonwhitespace (line, n, i1);
const arg = parseInteger (line, i1, j1);
// Little-endian storage.
return [opcode, vmintByte0 (arg), vmintByte1 (arg),
vmintByte2 (arg), vmintByte3 (arg)];
}
ubyte[] finishFetchOrStore ()
{
const i1 = skipWhitespace (line, n, startOfArgument);
const j1 = skipNonwhitespace (line, n, i1);
if (j1 - i1 < 3 || line[i1] != '[' || line[j1 - 1] != ']')
throw new BadVMException (bad_instruction);
const arg = parseInteger (line, i1 + 1, j1 - 1);
// Little-endian storage.
return [opcode, vmintByte0 (arg), vmintByte1 (arg),
vmintByte2 (arg), vmintByte3 (arg)];
}
ubyte[] finishJmpOrJz ()
{
const i1 = skipWhitespace (line, n, startOfArgument);
const j1 = skipNonwhitespace (line, n, i1);
if (j1 - i1 < 3 || line[i1] != '(' || line[j1 - 1] != ')')
throw new BadVMException (bad_instruction);
const arg = parseInteger (line, i1 + 1, j1 - 1);
// Little-endian storage.
return [opcode, vmintByte0 (arg), vmintByte1 (arg),
vmintByte2 (arg), vmintByte3 (arg)];
}
ubyte[] retval;
switch (opcode)
{
case Op.PUSH:
retval = finishPush ();
break;
case Op.FETCH:
case Op.STORE:
retval = finishFetchOrStore ();
break;
case Op.JMP:
case Op.JZ:
retval = finishJmpOrJz ();
break;
default:
retval = [opcode];
break;
}
return retval;
}
ubyte[]
readCode (File f)
{
// Read the instructions from the input, producing an array of
// array of instruction bytes.
ubyte[] code = [];
auto line = f.readln();
while (line !is null)
{
code ~= parseInstruction (line);
line = f.readln();
}
return code;
}
void
parseHeaderLine (string line, ref size_t dataSize,
ref size_t stringsSize)
{
const bad_vm_header_line = "bad VM header line";
const n = line.length;
auto i = skipWhitespace (line, n, 0);
auto j = skipNonwhitespace (line, n, i);
if (!substrEqual (line, i, j, "Datasize:"))
throw new BadVMException (bad_vm_header_line);
i = skipWhitespace (line, n, j);
j = skipNonwhitespace (line, n, i);
dataSize = parseInteger (line, i, j);
i = skipWhitespace (line, n, j);
j = skipNonwhitespace (line, n, i);
if (!substrEqual (line, i, j, "Strings:"))
throw new BadVMException (bad_vm_header_line);
i = skipWhitespace (line, n, j);
j = skipNonwhitespace (line, n, i);
stringsSize = parseInteger (line, i, j);
}
VM
readVM (File f)
{
const line = f.readln();
size_t dataSize;
size_t stringsSize;
parseHeaderLine (line, dataSize, stringsSize);
VM vm = new VM();
vm.strings = readStrings (f, stringsSize);
vm.code = readCode (f);
vm.data.length = dataSize;
vm.stack.length = 65536; // A VERY big stack, MUCH bigger than is
// "reasonable" for this VM. The same size
// as in the ATS, however.
vm.registers[Register.PC] = vmint(0);
vm.registers[Register.SP] = vmint(0);
return vm;
}
vmint
pop (VM vm)
{
pragma(inline);
const spBefore = vm.registers[Register.SP];
if (spBefore == 0)
throw new VMRuntimeException ("stack underflow");
const spAfter = spBefore - vmint(1);
vm.registers[Register.SP] = spAfter;
return vm.stack[spAfter];
}
void
push (VM vm, vmint x)
{
pragma(inline);
const spBefore = vm.registers[Register.SP];
if (vm.stack.length <= spBefore)
throw new VMRuntimeException ("stack overflow");
vm.stack[spBefore] = x;
const spAfter = spBefore + vmint(1);
vm.registers[Register.SP] = spAfter;
}
vmint
fetchData (VM vm, vmint index)
{
pragma(inline);
if (vm.data.length <= index)
throw new VMRuntimeException
("fetch from outside the data section");
return vm.data[index];
}
void
storeData (VM vm, vmint index, vmint x)
{
pragma(inline);
if (vm.data.length <= index)
throw new VMRuntimeException
("store to outside the data section");
vm.data[index] = x;
}
vmint
getArgument (VM vm)
{
pragma(inline);
auto pc = vm.registers[Register.PC];
if (vm.code.length <= pc + vmint(4))
throw new VMRuntimeException
("the program counter is out of bounds");
// The data is stored little-endian.
const byte0 = vmint (vm.code[pc]);
const byte1 = vmint (vm.code[pc + vmint(1)]);
const byte2 = vmint (vm.code[pc + vmint(2)]);
const byte3 = vmint (vm.code[pc + vmint(3)]);
return (byte0) | (byte1 << 8) | (byte2 << 16) | (byte3 << 24);
}
void
skipArgument (VM vm)
{
pragma(inline);
vm.registers[Register.PC] += vmint(4);
}
//
// The string mixins below are going to do for us *some* of what the
// ATS template system did for us. The two methods hardly resemble
// each other, but both can be used to construct function definitions
// at compile time.
//
template
UnaryOperation (alias name, alias func)
{
const char[] UnaryOperation =
"void " ~
name ~ " (VM vm)
{
pragma(inline);
const sp = vm.registers[Register.SP];
if (sp == vmint(0))
throw new VMRuntimeException (\"stack underflow\");
const x = vm.stack[sp - vmint(1)];
const z = " ~ func ~ " (x);
vm.stack[sp - vmint(1)] = z;
}";
}
template
BinaryOperation (alias name, alias func)
{
const char[] BinaryOperation =
"void " ~
name ~ " (VM vm)
{
pragma(inline);
const spBefore = vm.registers[Register.SP];
if (spBefore <= vmint(1))
throw new VMRuntimeException (\"stack underflow\");
const spAfter = spBefore - vmint(1);
vm.registers[Register.SP] = spAfter;
const x = vm.stack[spAfter - vmint(1)];
const y = vm.stack[spAfter];
const z = " ~ func ~ "(x, y);
vm.stack[spAfter - vmint(1)] = z;
}";
}
mixin (UnaryOperation!("uopNeg", "twosComplement"));
mixin (UnaryOperation!("uopNot", "logicalNot"));
mixin (BinaryOperation!("binopAdd", "add"));
mixin (BinaryOperation!("binopSub", "sub"));
mixin (BinaryOperation!("binopMul", "signedMul"));
mixin (BinaryOperation!("binopDiv", "signedDiv"));
mixin (BinaryOperation!("binopMod", "signedMod"));
mixin (BinaryOperation!("binopEq", "equality"));
mixin (BinaryOperation!("binopNe", "inequality"));
mixin (BinaryOperation!("binopLt", "signedLt"));
mixin (BinaryOperation!("binopGt", "signedGt"));
mixin (BinaryOperation!("binopLe", "signedLte"));
mixin (BinaryOperation!("binopGe", "signedGte"));
mixin (BinaryOperation!("binopAnd", "logicalAnd"));
mixin (BinaryOperation!("binopOr", "logicalOr"));
void
doPush (VM vm)
{
pragma(inline);
const arg = getArgument (vm);
push (vm, arg);
skipArgument (vm);
}
void
doFetch (VM vm)
{
pragma(inline);
const i = getArgument (vm);
const x = fetchData (vm, i);
push (vm, x);
skipArgument (vm);
}
void
doStore (VM vm)
{
pragma(inline);
const i = getArgument (vm);
const x = pop (vm);
storeData (vm, i, x);
skipArgument (vm);
}
void
doJmp (VM vm)
{
pragma(inline);
const arg = getArgument (vm);
vm.registers[Register.PC] += arg;
}
void
doJz (VM vm)
{
pragma(inline);
const x = pop (vm);
if (x == vmint(0))
doJmp (vm);
else
skipArgument (vm);
}
void
doPrtc (File fOut, VM vm)
{
const x = pop (vm);
fOut.write (to!char(x));
}
void
doPrti (File fOut, VM vm)
{
const x = pop (vm);
fOut.write (int32_t(x));
}
void
doPrts (File fOut, VM vm)
{
const i = pop (vm);
if (vm.strings.length <= i)
throw new VMRuntimeException ("string index out of bounds");
fOut.write (vm.strings[i]);
}
void
vmStep (File fOut, VM vm, ref bool machineHalt, ref bool badOpcode)
{
const pc = vm.registers[Register.PC];
if (vm.code.length <= pc)
throw new VMRuntimeException
("the program counter is out of bounds");
vm.registers[Register.PC] = pc + vmint(1);
const opcode = vm.code[pc];
const uOpcode = uint(opcode);
// Dispatch by bifurcation on the bit pattern of the opcode. This
// method is logarithmic in the number of opcode values.
machineHalt = false;
badOpcode = false;
if ((uOpcode & (~0x1FU)) == 0U)
{
if ((uOpcode & 0x10U) == 0U)
{
if ((uOpcode & 0x08U) == 0U)
{
if ((uOpcode & 0x04U) == 0U)
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
machineHalt = true;
else
binopAdd (vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
binopSub (vm);
else
binopMul (vm);
}
}
else
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
binopDiv (vm);
else
binopMod (vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
binopLt (vm);
else
binopGt (vm);
}
}
}
else
{
if ((uOpcode & 0x04U) == 0U)
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
binopLe (vm);
else
binopGe (vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
binopEq (vm);
else
binopNe (vm);
}
}
else
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
binopAnd (vm);
else
binopOr (vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
uopNeg (vm);
else
uopNot (vm);
}
}
}
}
else
{
if ((uOpcode & 0x08U) == 0U)
{
if ((uOpcode & 0x04U) == 0U)
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
doPrtc (fOut, vm);
else
doPrti (fOut, vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
doPrts (fOut, vm);
else
doFetch (vm);
}
}
else
{
if ((uOpcode & 0x02U) == 0U)
{
if ((uOpcode & 0x01U) == 0U)
doStore (vm);
else
doPush (vm);
}
else
{
if ((uOpcode & 0x01U) == 0U)
doJmp (vm);
else
doJz (vm);
}
}
}
else
badOpcode = true;
}
}
else
badOpcode = true;
}
void
vmContinue (File fOut, VM vm)
{
auto machineHalt = false;
auto badOpcode = false;
while (!machineHalt && !badOpcode)
vmStep (fOut, vm, machineHalt, badOpcode);
if (badOpcode)
throw new VMRuntimeException ("unrecognized opcode at runtime");
}
void
vmInitialize (VM vm)
{
foreach (ref x; vm.data)
x = vmint(0);
vm.registers[Register.PC] = vmint(0);
vm.registers[Register.SP] = vmint(0);
}
void
vmRun (File fOut, VM vm)
{
vmInitialize (vm);
vmContinue (fOut, vm);
}
void
ensure_that_vmint_is_suitable ()
{
// Try to guarantee that vmint is exactly 32 bits, and that it
// allows overflow in either direction.
assert (vmint(0xFFFFFFFFU) + vmint(1U) == vmint(0U));
assert (vmint(0U) - vmint(1U) == vmint(0xFFFFFFFFU));
assert (vmint(-1234) == twosComplement (vmint(1234)));
}
int
main (char[][] args)
{
auto inpFilename = "-";
auto outFilename = "-";
if (2 <= args.length)
inpFilename = to!string (args[1]);
if (3 <= args.length)
outFilename = to!string (args[2]);
auto inpF = stdin;
if (inpFilename != "-")
inpF = File (inpFilename, "r");
auto vm = readVM (inpF);
if (inpFilename != "-")
inpF.close();
auto outF = stdout;
if (outFilename != "-")
outF = File (outFilename, "w");
ensure_that_vmint_is_suitable ();
vmRun (outF, vm);
if (outFilename != "-")
outF.close();
return 0;
}
- Output:
$ gdc -Wall -Wextra -fno-bounds-check -O3 -march=native -fno-stack-protector vm_in_D.d && ./a.out compiler-tests/count.vm count is: 1 count is: 2 count is: 3 count is: 4 count is: 5 count is: 6 count is: 7 count is: 8 count is: 9
Forth
Tested with Gforth 0.7.3
CREATE BUF 0 , \ single-character look-ahead buffer
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
: SPACE? DUP BL = SWAP 9 14 WITHIN OR ;
: >SPACE BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT? 48 58 WITHIN ;
: >INT ( -- n) >SPACE 0
BEGIN PEEK DIGIT?
WHILE GETC [CHAR] 0 - SWAP 10 * + REPEAT ;
CREATE A 0 ,
: C@A ( -- c) A @ C@ ;
: C@A+ ( -- c) C@A 1 CHARS A +! ;
: C!A+ ( c --) A @ C! 1 CHARS A +! ;
: WORD ( -- c-addr) >SPACE PAD 1+ A !
BEGIN PEEK SPACE? INVERT WHILE GETC C!A+ REPEAT
>SPACE PAD A @ OVER - 1- PAD C! ;
: >STRING ( -- c-addr) >SPACE GETC DROP PAD 1+ A !
BEGIN PEEK [CHAR] " <> WHILE GETC C!A+ REPEAT
GETC DROP PAD A @ OVER - 1- PAD C! ;
: \INTERN ( c-addr -- c-addr) HERE >R A ! C@A+ DUP C,
BEGIN DUP WHILE C@A+
DUP [CHAR] \ = IF DROP -1 R@ +! C@A+
[CHAR] n = IF 10 ELSE [CHAR] \ THEN
THEN C, 1-
REPEAT DROP R> ;
: . 0 .R ;
CREATE DATA 0 ,
CREATE STRINGS 0 ,
: >DATA HERE DATA !
WORD DROP >INT 4 * BEGIN DUP WHILE 0 C, 1- REPEAT DROP ;
: >STRINGS HERE STRINGS !
WORD DROP >INT DUP >R CELLS ALLOT
0 BEGIN DUP R@ < WHILE
DUP CELLS >STRING \INTERN STRINGS @ ROT + ! 1+
REPEAT R> DROP DROP ;
: >HEADER >DATA >STRINGS ;
: i32! ( n addr --)
OVER $FF AND OVER C! 1+
OVER 8 RSHIFT $FF AND OVER C! 1+
OVER 16 RSHIFT $FF AND OVER C! 1+
SWAP 24 RSHIFT $FF AND SWAP C! ;
: i32@ ( addr -- n) >R \ This is kinda slow... hmm
R@ C@
R@ 1 + C@ 8 LSHIFT OR
R@ 2 + C@ 16 LSHIFT OR
R> 3 + C@ 24 LSHIFT OR
DUP $7FFFFFFF AND SWAP $80000000 AND - ; \ sign extend
: i32, ( n --) HERE 4 ALLOT i32! ;
: i32@+ ( -- n) A @ i32@ A @ 4 + A ! ;
CREATE BYTECODE 0 ,
: @fetch i32@+ 4 * DATA @ + i32@ ;
: @store i32@+ 4 * DATA @ + i32! ;
: @jmp i32@+ BYTECODE @ + A ! ;
: @jz IF 4 A +! ELSE @jmp THEN ;
: @prts CELLS STRINGS @ + @ COUNT TYPE ;
: @div >R S>D R> SM/REM SWAP DROP ;
CREATE OPS
' @fetch , ' @store , ' i32@+ , ' @jmp , ' @jz ,
' EMIT , ' . , ' @prts , ' NEGATE , ' 0= ,
' + , ' - , ' * , ' @div , ' MOD ,
' < , ' > , ' <= , ' >= ,
' = , ' <> , ' AND , ' OR , ' BYE ,
CREATE #OPS 0 ,
: OP: CREATE #OPS @ , 1 #OPS +! DOES> @ ;
OP: fetch OP: store OP: push OP: jmp OP: jz
OP: prtc OP: prti OP: prts OP: neg OP: not
OP: add OP: sub OP: mul OP: div OP: mod
OP: lt OP: gt OP: le OP: ge
OP: eq OP: ne OP: and OP: or OP: halt
: >OP WORD FIND
0= IF ." Unrecognized opcode" ABORT THEN EXECUTE ;
: >i32 >INT i32, ;
: >[i32] GETC DROP >i32 GETC DROP ;
: >OFFSET WORD DROP ( drop relative offset) >i32 ;
CREATE >PARAM ' >[i32] DUP , , ' >i32 , ' >OFFSET DUP , ,
: >BYTECODE HERE >R
BEGIN >INT DROP >OP >R R@ C,
R@ 5 < IF R@ CELLS >PARAM + @ EXECUTE THEN
R> halt = UNTIL R> BYTECODE ! ;
: RUN BYTECODE @ A !
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN
Fortran
Fortran 2008/2018 code with some limited use of the C preprocessor. If you are on a platform with case-sensitive filenames, and call the source file vm.F90, then gfortran will know to use the C preprocessor.
module compiler_type_kinds
use, intrinsic :: iso_fortran_env, only: int32
use, intrinsic :: iso_fortran_env, only: int64
implicit none
private
! Synonyms.
integer, parameter, public :: size_kind = int64
integer, parameter, public :: length_kind = size_kind
integer, parameter, public :: nk = size_kind
! Synonyms for character capable of storing a Unicode code point.
integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
integer, parameter, public :: ck = unicode_char_kind
! Synonyms for integers capable of storing a Unicode code point.
integer, parameter, public :: unicode_ichar_kind = int32
integer, parameter, public :: ick = unicode_ichar_kind
! Synonyms for integers in the virtual machine or the interpreter’s
! runtime. (The Rosetta Code task says integers in the virtual
! machine are 32-bit, but there is nothing in the task that prevents
! us using 64-bit integers in the compiler and interpreter.)
integer, parameter, public :: runtime_int_kind = int64
integer, parameter, public :: rik = runtime_int_kind
end module compiler_type_kinds
module helpers
use, non_intrinsic :: compiler_type_kinds, only: nk, rik, ck
implicit none
private
public :: new_storage_size
public :: next_power_of_two
public :: isspace
public :: quoted_string
public :: int32_to_vm_bytes
public :: uint32_to_vm_bytes
public :: int32_from_vm_bytes
public :: uint32_from_vm_bytes
public :: bool2int
character(1, kind = ck), parameter, public :: horizontal_tab_char = char (9, kind = ck)
character(1, kind = ck), parameter, public :: linefeed_char = char (10, kind = ck)
character(1, kind = ck), parameter, public :: vertical_tab_char = char (11, kind = ck)
character(1, kind = ck), parameter, public :: formfeed_char = char (12, kind = ck)
character(1, kind = ck), parameter, public :: carriage_return_char = char (13, kind = ck)
character(1, kind = ck), parameter, public :: space_char = ck_' '
! The following is correct for Unix and its relatives.
character(1, kind = ck), parameter, public :: newline_char = linefeed_char
character(1, kind = ck), parameter, public :: backslash_char = char (92, kind = ck)
contains
elemental function new_storage_size (length_needed) result (size)
integer(kind = nk), intent(in) :: length_needed
integer(kind = nk) :: size
! Increase storage by orders of magnitude.
if (2_nk**32 < length_needed) then
size = huge (1_nk)
else
size = next_power_of_two (length_needed)
end if
end function new_storage_size
elemental function next_power_of_two (x) result (y)
integer(kind = nk), intent(in) :: x
integer(kind = nk) :: y
!
! It is assumed that no more than 64 bits are used.
!
! The branch-free algorithm is that of
! https://archive.is/nKxAc#RoundUpPowerOf2
!
! Fill in bits until one less than the desired power of two is
! reached, and then add one.
!
y = x - 1
y = ior (y, ishft (y, -1))
y = ior (y, ishft (y, -2))
y = ior (y, ishft (y, -4))
y = ior (y, ishft (y, -8))
y = ior (y, ishft (y, -16))
y = ior (y, ishft (y, -32))
y = y + 1
end function next_power_of_two
elemental function isspace (ch) result (bool)
character(1, kind = ck), intent(in) :: ch
logical :: bool
bool = (ch == horizontal_tab_char) .or. &
& (ch == linefeed_char) .or. &
& (ch == vertical_tab_char) .or. &
& (ch == formfeed_char) .or. &
& (ch == carriage_return_char) .or. &
& (ch == space_char)
end function isspace
function quoted_string (str) result (qstr)
character(*, kind = ck), intent(in) :: str
character(:, kind = ck), allocatable :: qstr
integer(kind = nk) :: n, i, j
! Compute n = the size of qstr.
n = 2_nk
do i = 1_nk, len (str, kind = nk)
select case (str(i:i))
case (newline_char, backslash_char)
n = n + 2
case default
n = n + 1
end select
end do
allocate (character(n, kind = ck) :: qstr)
! Quote the string.
qstr(1:1) = ck_'"'
j = 2_nk
do i = 1_nk, len (str, kind = nk)
select case (str(i:i))
case (newline_char)
qstr(j:j) = backslash_char
qstr((j + 1):(j + 1)) = ck_'n'
j = j + 2
case (backslash_char)
qstr(j:j) = backslash_char
qstr((j + 1):(j + 1)) = backslash_char
j = j + 2
case default
qstr(j:j) = str(i:i)
j = j + 1
end select
end do
if (j /= n) error stop ! Check code correctness.
qstr(n:n) = ck_'"'
end function quoted_string
subroutine int32_to_vm_bytes (n, bytes, i)
integer(kind = rik), intent(in) :: n
character(1), intent(inout) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
bytes(i) = achar (ibits (n, 0, 8))
bytes(i + 1) = achar (ibits (n, 8, 8))
bytes(i + 2) = achar (ibits (n, 16, 8))
bytes(i + 3) = achar (ibits (n, 24, 8))
end subroutine int32_to_vm_bytes
subroutine uint32_to_vm_bytes (n, bytes, i)
integer(kind = rik), intent(in) :: n
character(1), intent(inout) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
call int32_to_vm_bytes (n, bytes, i)
end subroutine uint32_to_vm_bytes
subroutine int32_from_vm_bytes (n, bytes, i)
integer(kind = rik), intent(out) :: n
character(1), intent(in) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
call uint32_from_vm_bytes (n, bytes, i)
if (ibits (n, 31, 1) == 1) then
! Extend the sign bit.
n = ior (n, not ((2_rik ** 32) - 1))
end if
end subroutine int32_from_vm_bytes
subroutine uint32_from_vm_bytes (n, bytes, i)
integer(kind = rik), intent(out) :: n
character(1), intent(in) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
integer(kind = rik) :: n0, n1, n2, n3
n0 = iachar (bytes(i), kind = rik)
n1 = ishft (iachar (bytes(i + 1), kind = rik), 8)
n2 = ishft (iachar (bytes(i + 2), kind = rik), 16)
n3 = ishft (iachar (bytes(i + 3), kind = rik), 24)
n = ior (n0, ior (n1, ior (n2, n3)))
end subroutine uint32_from_vm_bytes
elemental function bool2int (bool) result (int)
logical, intent(in) :: bool
integer(kind = rik) :: int
if (bool) then
int = 1_rik
else
int = 0_rik
end if
end function bool2int
end module helpers
module string_buffers
use, intrinsic :: iso_fortran_env, only: error_unit
use, intrinsic :: iso_fortran_env, only: int64
use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
use, non_intrinsic :: helpers
implicit none
private
public :: strbuf_t
public :: skip_whitespace
public :: skip_non_whitespace
public :: skip_whitespace_backwards
public :: at_end_of_line
type :: strbuf_t
integer(kind = nk), private :: len = 0
!
! ‘chars’ is made public for efficient access to the individual
! characters.
!
character(1, kind = ck), allocatable, public :: chars(:)
contains
procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
procedure, pass :: length => strbuf_t_length
procedure, pass :: set => strbuf_t_set
procedure, pass :: append => strbuf_t_append
generic :: to_unicode => to_unicode_full_string
generic :: to_unicode => to_unicode_substring
generic :: assignment(=) => set
end type strbuf_t
contains
function strbuf_t_to_unicode_full_string (strbuf) result (s)
class(strbuf_t), intent(in) :: strbuf
character(:, kind = ck), allocatable :: s
!
! This does not actually ensure that the string is valid Unicode;
! any 31-bit ‘character’ is supported.
!
integer(kind = nk) :: i
allocate (character(len = strbuf%len, kind = ck) :: s)
do i = 1, strbuf%len
s(i:i) = strbuf%chars(i)
end do
end function strbuf_t_to_unicode_full_string
function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
!
! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
! the beginning’, ‘up to the end’, or ‘empty substring’.
!
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i, j
character(:, kind = ck), allocatable :: s
!
! This does not actually ensure that the string is valid Unicode;
! any 31-bit ‘character’ is supported.
!
integer(kind = nk) :: i1, j1
integer(kind = nk) :: n
integer(kind = nk) :: k
i1 = max (1_nk, i)
j1 = min (strbuf%len, j)
n = max (0_nk, (j1 - i1) + 1_nk)
allocate (character(n, kind = ck) :: s)
do k = 1, n
s(k:k) = strbuf%chars(i1 + (k - 1_nk))
end do
end function strbuf_t_to_unicode_substring
elemental function strbuf_t_length (strbuf) result (n)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk) :: n
n = strbuf%len
end function strbuf_t_length
subroutine strbuf_t_ensure_storage (strbuf, length_needed)
class(strbuf_t), intent(inout) :: strbuf
integer(kind = nk), intent(in) :: length_needed
integer(kind = nk) :: len_needed
integer(kind = nk) :: new_size
type(strbuf_t) :: new_strbuf
len_needed = max (length_needed, 1_nk)
if (.not. allocated (strbuf%chars)) then
! Initialize a new strbuf%chars array.
new_size = new_storage_size (len_needed)
allocate (strbuf%chars(1:new_size))
else if (ubound (strbuf%chars, 1) < len_needed) then
! Allocate a new strbuf%chars array, larger than the current
! one, but containing the same characters.
new_size = new_storage_size (len_needed)
allocate (new_strbuf%chars(1:new_size))
new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
call move_alloc (new_strbuf%chars, strbuf%chars)
end if
end subroutine strbuf_t_ensure_storage
subroutine strbuf_t_set (dst, src)
class(strbuf_t), intent(inout) :: dst
class(*), intent(in) :: src
integer(kind = nk) :: n
integer(kind = nk) :: i
select type (src)
type is (character(*, kind = ck))
n = len (src, kind = nk)
call dst%ensure_storage(n)
do i = 1, n
dst%chars(i) = src(i:i)
end do
dst%len = n
type is (character(*))
n = len (src, kind = nk)
call dst%ensure_storage(n)
do i = 1, n
dst%chars(i) = src(i:i)
end do
dst%len = n
class is (strbuf_t)
n = src%len
call dst%ensure_storage(n)
dst%chars(1:n) = src%chars(1:n)
dst%len = n
class default
error stop
end select
end subroutine strbuf_t_set
subroutine strbuf_t_append (dst, src)
class(strbuf_t), intent(inout) :: dst
class(*), intent(in) :: src
integer(kind = nk) :: n_dst, n_src, n
integer(kind = nk) :: i
select type (src)
type is (character(*, kind = ck))
n_dst = dst%len
n_src = len (src, kind = nk)
n = n_dst + n_src
call dst%ensure_storage(n)
do i = 1, n_src
dst%chars(n_dst + i) = src(i:i)
end do
dst%len = n
type is (character(*))
n_dst = dst%len
n_src = len (src, kind = nk)
n = n_dst + n_src
call dst%ensure_storage(n)
do i = 1, n_src
dst%chars(n_dst + i) = src(i:i)
end do
dst%len = n
class is (strbuf_t)
n_dst = dst%len
n_src = src%len
n = n_dst + n_src
call dst%ensure_storage(n)
dst%chars((n_dst + 1):n) = src%chars(1:n_src)
dst%len = n
class default
error stop
end select
end subroutine strbuf_t_append
function skip_whitespace (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
logical :: done
j = i
done = .false.
do while (.not. done)
if (at_end_of_line (strbuf, j)) then
done = .true.
else if (.not. isspace (strbuf%chars(j))) then
done = .true.
else
j = j + 1
end if
end do
end function skip_whitespace
function skip_non_whitespace (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
logical :: done
j = i
done = .false.
do while (.not. done)
if (at_end_of_line (strbuf, j)) then
done = .true.
else if (isspace (strbuf%chars(j))) then
done = .true.
else
j = j + 1
end if
end do
end function skip_non_whitespace
function skip_whitespace_backwards (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
logical :: done
j = i
done = .false.
do while (.not. done)
if (j == -1) then
done = .true.
else if (.not. isspace (strbuf%chars(j))) then
done = .true.
else
j = j - 1
end if
end do
end function skip_whitespace_backwards
function at_end_of_line (strbuf, i) result (bool)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
logical :: bool
bool = (strbuf%length() < i)
end function at_end_of_line
end module string_buffers
module reading_one_line_from_a_stream
use, intrinsic :: iso_fortran_env, only: input_unit
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
use, non_intrinsic :: string_buffers
implicit none
private
! get_line_from_stream: read an entire input line from a stream into
! a strbuf_t.
public :: get_line_from_stream
character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
! The following is correct for Unix and its relatives.
character(1, kind = ck), parameter :: newline_char = linefeed_char
contains
subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
integer, intent(in) :: unit_no
logical, intent(out) :: eof ! End of file?
logical, intent(out) :: no_newline ! There is a line but it has no
! newline? (Thus eof also must
! be .true.)
class(strbuf_t), intent(inout) :: strbuf
character(1, kind = ck) :: ch
strbuf = ''
call get_ch (unit_no, eof, ch)
do while (.not. eof .and. ch /= newline_char)
call strbuf%append (ch)
call get_ch (unit_no, eof, ch)
end do
no_newline = eof .and. (strbuf%length() /= 0)
end subroutine get_line_from_stream
subroutine get_ch (unit_no, eof, ch)
!
! Read a single code point from the stream.
!
! Currently this procedure simply inputs ‘ASCII’ bytes rather than
! Unicode code points.
!
integer, intent(in) :: unit_no
logical, intent(out) :: eof
character(1, kind = ck), intent(out) :: ch
integer :: stat
character(1) :: c = '*'
eof = .false.
if (unit_no == input_unit) then
call get_input_unit_char (c, stat)
else
read (unit = unit_no, iostat = stat) c
end if
if (stat < 0) then
ch = ck_'*'
eof = .true.
else if (0 < stat) then
write (error_unit, '("Input error with status code ", I0)') stat
stop 1
else
ch = char (ichar (c, kind = ick), kind = ck)
end if
end subroutine get_ch
!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__
subroutine get_input_unit_char (c, stat)
!
! The following works if you are using gfortran.
!
! (FGETC is considered a feature for backwards compatibility with
! g77. However, I know of no way to reconfigure input_unit as a
! Fortran 2003 stream, for use with ordinary ‘read’.)
!
character, intent(inout) :: c
integer, intent(out) :: stat
call fgetc (input_unit, c, stat)
end subroutine get_input_unit_char
#else
subroutine get_input_unit_char (c, stat)
!
! An alternative implementation of get_input_unit_char. This
! actually reads input from the C standard input, which might not
! be the same as input_unit.
!
use, intrinsic :: iso_c_binding, only: c_int
character, intent(inout) :: c
integer, intent(out) :: stat
interface
!
! Use getchar(3) to read characters from standard input. This
! assumes there is actually such a function available, and that
! getchar(3) does not exist solely as a macro. (One could write
! one’s own getchar() if necessary, of course.)
!
function getchar () result (c) bind (c, name = 'getchar')
use, intrinsic :: iso_c_binding, only: c_int
integer(kind = c_int) :: c
end function getchar
end interface
integer(kind = c_int) :: i_char
i_char = getchar ()
!
! The C standard requires that EOF have a negative value. If the
! value returned by getchar(3) is not EOF, then it will be
! representable as an unsigned char. Therefore, to check for end
! of file, one need only test whether i_char is negative.
!
if (i_char < 0) then
stat = -1
else
stat = 0
c = char (i_char)
end if
end subroutine get_input_unit_char
#endif
end module reading_one_line_from_a_stream
module vm_reader
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds
use, non_intrinsic :: helpers
use, non_intrinsic :: string_buffers
use, non_intrinsic :: reading_one_line_from_a_stream
implicit none
private
public :: vm_code_t
public :: vm_t
public :: read_vm
!
! Arbitrarily chosen opcodes.
!
! I think there should be a no-operation ‘nop’ opcode, to reserve
! space for later hand-patching. :)
!
integer, parameter, public :: opcode_nop = 0
integer, parameter, public :: opcode_halt = 1
integer, parameter, public :: opcode_add = 2
integer, parameter, public :: opcode_sub = 3
integer, parameter, public :: opcode_mul = 4
integer, parameter, public :: opcode_div = 5
integer, parameter, public :: opcode_mod = 6
integer, parameter, public :: opcode_lt = 7
integer, parameter, public :: opcode_gt = 8
integer, parameter, public :: opcode_le = 9
integer, parameter, public :: opcode_ge = 10
integer, parameter, public :: opcode_eq = 11
integer, parameter, public :: opcode_ne = 12
integer, parameter, public :: opcode_and = 13
integer, parameter, public :: opcode_or = 14
integer, parameter, public :: opcode_neg = 15
integer, parameter, public :: opcode_not = 16
integer, parameter, public :: opcode_prtc = 17
integer, parameter, public :: opcode_prti = 18
integer, parameter, public :: opcode_prts = 19
integer, parameter, public :: opcode_fetch = 20
integer, parameter, public :: opcode_store = 21
integer, parameter, public :: opcode_push = 22
integer, parameter, public :: opcode_jmp = 23
integer, parameter, public :: opcode_jz = 24
character(8, kind = ck), parameter, public :: opcode_names(0:24) = &
& (/ "nop ", &
& "halt ", &
& "add ", &
& "sub ", &
& "mul ", &
& "div ", &
& "mod ", &
& "lt ", &
& "gt ", &
& "le ", &
& "ge ", &
& "eq ", &
& "ne ", &
& "and ", &
& "or ", &
& "neg ", &
& "not ", &
& "prtc ", &
& "prti ", &
& "prts ", &
& "fetch ", &
& "store ", &
& "push ", &
& "jmp ", &
& "jz " /)
type :: vm_code_t
integer(kind = rik), private :: len = 0_rik
character(1), allocatable :: bytes(:)
contains
procedure, pass, private :: ensure_storage => vm_code_t_ensure_storage
procedure, pass :: length => vm_code_t_length
end type vm_code_t
type :: vm_t
integer(kind = rik), allocatable :: string_boundaries(:)
character(:, kind = ck), allocatable :: strings
character(1), allocatable :: data(:)
character(1), allocatable :: stack(:)
type(vm_code_t) :: code
integer(kind = rik) :: sp = 0_rik
integer(kind = rik) :: pc = 0_rik
end type vm_t
contains
subroutine vm_code_t_ensure_storage (code, length_needed)
class(vm_code_t), intent(inout) :: code
integer(kind = nk), intent(in) :: length_needed
integer(kind = nk) :: len_needed
integer(kind = nk) :: new_size
type(vm_code_t) :: new_code
len_needed = max (length_needed, 1_nk)
if (.not. allocated (code%bytes)) then
! Initialize a new code%bytes array.
new_size = new_storage_size (len_needed)
allocate (code%bytes(0:(new_size - 1)))
else if (ubound (code%bytes, 1) < len_needed - 1) then
! Allocate a new code%bytes array, larger than the current one,
! but containing the same bytes.
new_size = new_storage_size (len_needed)
allocate (new_code%bytes(0:(new_size - 1)))
new_code%bytes(0:(code%len - 1)) = code%bytes(0:(code%len - 1))
call move_alloc (new_code%bytes, code%bytes)
end if
end subroutine vm_code_t_ensure_storage
elemental function vm_code_t_length (code) result (len)
class(vm_code_t), intent(in) :: code
integer(kind = rik) :: len
len = code%len
end function vm_code_t_length
subroutine read_vm (inp, strbuf, vm)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
type(vm_t), intent(out) :: vm
integer(kind = rik) :: data_size
integer(kind = rik) :: number_of_strings
! Read the header.
call read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)
! Allocate storage for data_size 32-bit numbers. Initialize them
! to zero, for no better reason than that C initializes global
! variables to zero.
allocate (vm%data(0_rik:(4_rik * (data_size - 1))), source = achar (0))
! Allocate storage for indices/bounds of the strings to be loaded
! into the string storage space.
allocate (vm%string_boundaries(0_rik:number_of_strings))
! Fill the strings storage and the string boundaries array.
call read_strings (inp, strbuf, number_of_strings, vm)
! Read the program instructions.
call read_code (inp, strbuf, vm)
! Allocate a stack. Let us say that the stack size must be a
! multiple of 4, and is fixed at 65536 = 4**8 bytes. Pushing a
! 32-bit integer increases the stack pointer by 4, popping
! decreases it by 4.
allocate (vm%stack(0_rik:(4_rik ** 8)))
end subroutine read_vm
subroutine read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
integer(kind = rik), intent(out) :: data_size
integer(kind = rik), intent(out) :: number_of_strings
logical :: eof
logical :: no_newline
integer(kind = nk) :: i, j
character(:, kind = ck), allocatable :: data_size_str
character(:, kind = ck), allocatable :: number_of_strings_str
integer :: stat
call get_line_from_stream (inp, eof, no_newline, strbuf)
if (eof) call bad_vm_assembly
i = skip_whitespace (strbuf, 1_nk)
i = skip_datasize_keyword (strbuf, i)
i = skip_whitespace (strbuf, i)
i = skip_specific_character (strbuf, i, ck_':')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (data_size_str, source = strbuf%to_unicode (i, j - 1))
i = skip_whitespace(strbuf, j)
i = skip_strings_keyword (strbuf, i)
i = skip_whitespace (strbuf, i)
i = skip_specific_character (strbuf, i, ck_':')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (number_of_strings_str, source = strbuf%to_unicode (i, j - 1))
read (data_size_str, *, iostat = stat) data_size
if (stat /= 0) call bad_vm_assembly
read (number_of_strings_str, *, iostat = stat) number_of_strings
if (stat /= 0) call bad_vm_assembly
end subroutine read_datasize_and_number_of_strings
subroutine read_strings (inp, strbuf, number_of_strings, vm)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
integer(kind = rik), intent(in) :: number_of_strings
type(vm_t), intent(inout) :: vm
type(strbuf_t) :: strings_temporary
integer(kind = rik) :: i
vm%string_boundaries(0)