Compiler/virtual machine interpreter: Difference between revisions

New post.
(New post.)
 
(14 intermediate revisions by 5 users not shown)
Line 153:
; A simple example virtual machine:
 
<langsyntaxhighlight lang="python">def run_vm(data_size)
int stack[data_size + 1000]
set stack[0..data_size - 1] to 0
Line 190:
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</langsyntaxhighlight>
 
; Additional examples
Line 209:
<hr>
__TOC__
 
=={{header|Ada}}==
{{works with|GNAT|Community 2021}}
 
 
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.
 
 
<syntaxhighlight lang="ada">--
-- 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;</syntaxhighlight>
 
 
{{out}}
<pre>$ 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</pre>
 
=={{header|Aime}}==
<syntaxhighlight lang="text">integer n, pc, sp;
file f;
text s;
Line 297 ⟶ 1,255:
isk_greater(code, pc, pc);
}
}</langsyntaxhighlight>
 
=={{header|ALGOL W}}==
<langsyntaxhighlight lang="algolw">begin % virtual machine interpreter %
% string literals %
string(256) array stringValue ( 0 :: 256 );
Line 606 ⟶ 1,564:
end while_not_halted
end
end.</langsyntaxhighlight>
 
=={{header|ATS}}==
 
===Interpreter===
 
{{works with|ATS|Postiats 0.4.1}}
 
Line 617 ⟶ 1,578:
(Without the C optimizer, ATS code can run much, much more slowly. It is worth comparing the Mandelbrot example with and without the optimizer.)
 
<langsyntaxhighlight lang="ats">(*
Usage: vm [INPUTFILE [OUTPUTFILE]]
If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
Line 2,419 ⟶ 3,380:
}
 
(********************************************************************)</langsyntaxhighlight>
 
{{out}}
Line 2,432 ⟶ 3,393:
count is: 8
count is: 9</pre>
 
===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
 
=={{header|AWK}}==
Tested with gawk 4.1.1 and mawk 1.3.4.
<syntaxhighlight lang="awk">
<lang AWK>
function error(msg) {
printf("%s\n", msg)
Line 2,590 ⟶ 3,557:
run_vm(data_size)
}
</syntaxhighlight>
</lang>
{{out|case=count}}
<b>
Line 2,608 ⟶ 3,575:
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<langsyntaxhighlight Clang="c">#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
Line 2,874 ⟶ 3,841:
int data[1000 + data_size];
run_vm(object, data, data_size, string_pool);
}</langsyntaxhighlight>
 
=={{header|C++}}==
This examples passes all tests, although for brevity of output only one test result is shown.
<syntaxhighlight lang="c++">
#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);
}
</syntaxhighlight>
{{ out }}
<pre>
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
</pre>
 
=={{header|COBOL}}==
Code by Steve Williams (with changes to work around code highlighting issues). Tested with GnuCOBOL 2.2.
 
<langsyntaxhighlight lang="cobol"> >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
Line 3,300 ⟶ 4,505:
end program emitword.
 
end program vminterpreter.</langsyntaxhighlight>
 
{{out|case=Count}}
Line 3,324 ⟶ 4,529:
 
 
<langsyntaxhighlight lang="lisp">#!/bin/sh
#|-*- mode:lisp -*-|#
#|
Line 4,048 ⟶ 5,253:
(uiop:quit 0)))
 
;;; vim: set ft=lisp lisp:</langsyntaxhighlight>
 
 
Line 4,062 ⟶ 5,267:
count is: 8
count is: 9</pre>
 
=={{header|D}}==
{{works with|gcc|11.2.1}}
{{works with|dmd|2.096.1}}
{{trans|ATS}}
 
 
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.
 
 
<syntaxhighlight lang="d">//
// 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;
}</syntaxhighlight>
 
 
{{out}}
<pre>$ 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</pre>
 
 
 
=={{header|Forth}}==
Tested with Gforth 0.7.3
<langsyntaxhighlight Forthlang="forth">CREATE BUF 0 , \ single-character look-ahead buffer
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
Line 4,147 ⟶ 6,286:
: RUN BYTECODE @ A !
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN</langsyntaxhighlight>
 
=={{header|Fortran}}==
{{works with|gfortran|11.2.1}}
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.
<langsyntaxhighlight lang="fortran">module compiler_type_kinds
use, intrinsic :: iso_fortran_env, only: int32
use, intrinsic :: iso_fortran_env, only: int64
Line 5,685 ⟶ 7,824:
end subroutine print_usage
end program vm</langsyntaxhighlight>
 
{{out}}
Line 5,701 ⟶ 7,840:
=={{header|Go}}==
{{trans|Python}}
<langsyntaxhighlight lang="go">package main
 
import (
Line 6,003 ⟶ 8,142:
scanner = bufio.NewScanner(codeGen)
runVM(loadCode())
}</langsyntaxhighlight>
 
{{out}}
Line 6,021 ⟶ 8,160:
=={{header|Icon}}==
{{trans|ObjectIcon}}
<langsyntaxhighlight lang="icon"># -*- Icon -*-
#
# The Rosetta Code virtual machine in Icon. Migrated from the
Line 6,395 ⟶ 8,534:
write(&errout, "Bad opcode.")
exit(1)
end</langsyntaxhighlight>
 
{{out}}
Line 6,411 ⟶ 8,550:
=={{header|J}}==
Implementation:
<langsyntaxhighlight Jlang="j">(opcodes)=: opcodes=: ;:{{)n
fetch store push add sub mul div mod lt gt le ge
eq ne and or neg not jmp jz prtc prts prti halt
Line 6,486 ⟶ 8,625:
pc=: pc+k
end.
}}</langsyntaxhighlight>
 
Task example:
<langsyntaxhighlight Jlang="j">count=:{{)n
count = 1;
while (count < 10) {
Line 6,507 ⟶ 8,646:
count is: 8
count is: 9
</syntaxhighlight>
</lang>
 
=={{header|Java}}==
This examples passes all tests, although for brevity of output only one test result is shown.
<syntaxhighlight lang="java">
import java.io.IOException;
import java.nio.ByteBuffer;
import java.nio.ByteOrder;
import java.nio.charset.StandardCharsets;
import java.nio.file.Files;
import java.nio.file.Path;
import java.util.ArrayList;
import java.util.List;
import java.util.Stack;
 
public final class CompilerVirtualMachineInterpreter {
 
public static void main(String[] args) throws IOException {
Path filePath = Path.of("Compiler Test Cases/AsciiMandlebrot.txt");
VirtualMachineInfo info = loadCode(filePath);
runVirtualMachine(info.dataSize, info.vmStrings, info.codes());
}
 
private static void runVirtualMachine(int dataSize, List<String> vmStrings, List<Byte> codes) {
final int wordSize = 4;
Stack<Integer> stack = new Stack<Integer>();
for ( int i = 0; i < dataSize; i++ ) {
stack.push(0);
}
int index = 0;
OpCode opCode = null;
while ( opCode != OpCode.HALT ) {
opCode = OpCode.havingCode(codes.get(index));
index += 1;
switch ( opCode ) {
case HALT -> { }
case ADD -> stack.set(stack.size() - 2, stack.get(stack.size() - 2) + stack.pop());
case SUB -> stack.set(stack.size() - 2, stack.get(stack.size() - 2) - stack.pop());
case MUL -> stack.set(stack.size() - 2, stack.get(stack.size() - 2) * stack.pop());
case DIV -> stack.set(stack.size() - 2, stack.get(stack.size() - 2) / stack.pop());
case MOD -> stack.set(stack.size() - 2, Math.floorMod(stack.get(stack.size() - 2), stack.pop()));
case LT -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) < stack.pop() ) ? 1 : 0);
case GT -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) > stack.pop() ) ? 1 : 0);
case LE -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) <= stack.pop() ) ? 1 : 0);
case GE -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) >= stack.pop() ) ? 1 : 0);
case EQ -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) == stack.pop() ) ? 1 : 0);
case NE -> stack.set(stack.size() - 2, ( stack.get(stack.size() - 2) != stack.pop() ) ? 1 : 0);
case AND -> { final int value = ( stack.get(stack.size() - 2) != 0 && stack.pop() != 0 ) ? 1 : 0;
stack.set(stack.size() - 1, value);
}
case OR -> { final int value = ( stack.get(stack.size() - 2) != 0 || stack.pop() != 0 ) ? 1 : 0;
stack.set(stack.size() - 1, value);
}
case NEG -> stack.set(stack.size() - 1, -stack.peek());
case NOT -> stack.set(stack.size() - 1, ( stack.peek() == 0 ) ? 1 : 0);
case PRTC -> System.out.print((char) stack.pop().intValue());
case PRTI -> System.out.print(stack.pop());
case PRTS -> System.out.print(vmStrings.get(stack.pop()));
case FETCH -> { stack.push(stack.get(operand(index, codes))); index += wordSize; }
case STORE -> { stack.set(operand(index, codes), stack.pop()); index += wordSize; }
case PUSH -> { stack.push(operand(index, codes)); index += wordSize; }
case JMP -> index += operand(index, codes);
case JZ -> index += ( stack.pop() == 0 ) ? operand(index, codes) : wordSize;
}
}
}
private static VirtualMachineInfo loadCode(Path filePath) throws IOException {
List<String> lines = Files.readAllLines(filePath, StandardCharsets.UTF_8);
String line = lines.getFirst();
if ( line.startsWith("lex") ) {
lines.removeFirst();
line = lines.getFirst();
}
String[] sections = line.trim().split(" ");
final int dataSize = Integer.parseInt(sections[1]);
final int stringCount = Integer.parseInt(sections[3]);
List<String> VMstrings = new ArrayList<String>();
for ( int i = 1; i <= stringCount; i++ ) {
String content = lines.get(i).substring(1, lines.get(i).length() - 1);
VMstrings.addLast(parseString(content));
}
int offset = 0;
List<Byte> codes = new ArrayList<Byte>();
for ( int i = stringCount + 1; i < lines.size(); i++ ) {
sections = lines.get(i).trim().split("\\s+");
offset = Integer.parseInt(sections[0]);
OpCode opCode = OpCode.valueOf(sections[1].toUpperCase());
codes.addLast(opCode.byteCode());
switch ( opCode ) {
case FETCH, STORE -> addToCodes(Integer.parseInt(sections[2]
.substring(1, sections[2].length() - 1)), codes);
case PUSH -> addToCodes(Integer.parseInt(sections[2]), codes);
case JMP, JZ -> addToCodes(Integer.parseInt(sections[3]) - offset - 1, codes);
default -> { }
}
}
return new VirtualMachineInfo(dataSize, VMstrings, codes);
}
private static int operand(int index, List<Byte> codes) {
byteBuffer.clear();
for ( int i = index; i < index + 4; i++ ) {
byteBuffer.put(codes.get(i));
}
byteBuffer.flip();
return byteBuffer.getInt();
}
private static void addToCodes(int number, List<Byte> codes) {
byteBuffer.clear();
byteBuffer.putInt(number);
byteBuffer.flip();
for ( byte bb : byteBuffer.array() ) {
codes.addLast(bb);
}
}
private static String parseString(String text) {
StringBuilder result = new StringBuilder();
int i = 0;
while ( i < text.length() ) {
if ( text.charAt(i) == '\\' && i + 1 < text.length() ) {
if ( text.charAt(i + 1) == 'n' ) {
result.append("\n");
i += 1;
} else if ( text.charAt(i + 1) == '\\') {
result.append("\\");
i += 1;
}
} else {
result.append(text.charAt(i));
}
i += 1;
}
return result.toString();
}
private static ByteBuffer byteBuffer = ByteBuffer.allocate(4).order(ByteOrder.LITTLE_ENDIAN);
private static enum OpCode {
HALT(0), ADD(1), SUB(2), MUL(3), DIV(4), MOD(5), LT(6), GT(7), LE(8), GE(9), EQ(10), NE(11),
AND(12), OR(13), NEG(14), NOT(15),
PRTC(16), PRTI(17), PRTS(18), FETCH(19), STORE(20), PUSH(21), JMP(22), JZ(23);
public byte byteCode() {
return (byte) byteCode;
}
public static OpCode havingCode(Byte byteCode) {
return op_codes[(int) byteCode];
}
private OpCode(int aByteCode) {
byteCode = aByteCode;
}
private int byteCode;
private static OpCode[] op_codes = values();
}
private static record VirtualMachineInfo(int dataSize, List<String> vmStrings, List<Byte> codes) {}
 
}
</syntaxhighlight>
{{ out }}
<pre>
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
</pre>
 
=={{header|Julia}}==
<langsyntaxhighlight lang="julia">mutable struct VM32
code::Vector{UInt8}
stack::Vector{Int32}
Line 6,613 ⟶ 8,973:
const vm = assemble(iob)
runvm(vm)
</langsyntaxhighlight>{{output}}<pre>
count is: 1
count is: 2
Line 6,627 ⟶ 8,987:
=={{header|M2000 Interpreter}}==
===Using Select Case===
<syntaxhighlight lang="m2000 interpreter">
<lang M2000 Interpreter>
Module Virtual_Machine_Interpreter (a$){
\\ function to extract string, replacing escape codes.
Line 6,800 ⟶ 9,160:
65 halt
}
</syntaxhighlight>
</lang>
 
===Using Lambda functions===
Line 6,806 ⟶ 9,166:
A call local to function pass the current scope to function, so it's like a call to subroutine, but faster.
 
<syntaxhighlight lang="m2000 interpreter">
<lang M2000 Interpreter>
Module Virtual_Machine_Interpreter (a$){
\\ function to extract string, replacing escape codes.
Line 6,955 ⟶ 9,315:
65 halt
}
</syntaxhighlight>
</lang>
 
=={{header|Mercury}}==
Line 6,968 ⟶ 9,328:
 
 
<langsyntaxhighlight Mercurylang="mercury">%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, in Mercury.
Line 7,859 ⟶ 10,219:
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%</langsyntaxhighlight>
 
 
Line 7,881 ⟶ 10,241:
=={{header|Nim}}==
 
<langsyntaxhighlight Nimlang="nim">import os, parseutils, strutils, strscans, strformat
 
type
Line 8,201 ⟶ 10,561:
 
vm.load(code)
vm.run()</langsyntaxhighlight>
 
All tests passed.
 
=={{header|ObjectIcon}}==
<langsyntaxhighlight lang="objecticon"># -*- ObjectIcon -*-
#
# The Rosetta Code virtual machine in Object Icon.
Line 8,613 ⟶ 10,973:
exit(1)
end
end</langsyntaxhighlight>
 
{{out}}
Line 8,629 ⟶ 10,989:
=={{header|Perl}}==
Tested with perl v5.26.1
<langsyntaxhighlight Perllang="perl">#!/usr/bin/perl
 
# http://www.rosettacode.org/wiki/Compiler/virtual_machine_interpreter
Line 8,678 ⟶ 11,038:
}
 
$ops[vec($binary, $pc++, 8)][1]->() while 1; # run it</langsyntaxhighlight>
Passes all tests.
 
=={{header|Phix}}==
Reusing cgen.e from the [[Compiler/code_generator#Phix|Code Generator task]]
<!--<langsyntaxhighlight Phixlang="phix">(notonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\vm.exw
Line 8,723 ⟶ 11,083:
<span style="color: #000080;font-style:italic;">--main(command_line())</span>
<span style="color: #000000;">main</span><span style="color: #0000FF;">({</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"count.c"</span><span style="color: #0000FF;">})</span>
<!--</langsyntaxhighlight>-->
{{out}}
<pre>
Line 8,741 ⟶ 11,101:
 
 
<langsyntaxhighlight lang="prolog">%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, for GNU Prolog.
Line 9,107 ⟶ 11,467:
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%</langsyntaxhighlight>
 
 
Line 9,124 ⟶ 11,484:
=={{header|Python}}==
Tested with Python 2.7 and 3.x
<langsyntaxhighlight Pythonlang="python">from __future__ import print_function
import sys, struct
 
Line 9,291 ⟶ 11,651:
 
data_size = load_code()
run_vm(data_size)</langsyntaxhighlight>
 
=={{header|Racket}}==
Line 9,302 ⟶ 11,662:
 
 
<langsyntaxhighlight Racketlang="racket">#lang typed/racket
;;;
;;; The Rosetta Code Virtual Machine, in Typed Racket.
Line 10,049 ⟶ 12,409:
(close-output-port outf))
 
(exit 0)))))</langsyntaxhighlight>
 
 
Line 10,074 ⟶ 12,434:
 
{{trans|Perl}}
<syntaxhighlight lang="raku" perl6line>my @CODE = q:to/END/.lines;
Datasize: 3 Strings: 2
"count is: "
Line 10,151 ⟶ 12,511:
$pc += $w;
%ops{%n2op{ $opcode }}();
}</langsyntaxhighlight>
{{out}}
<pre>count is: 1
Line 10,162 ⟶ 12,522:
count is: 8
count is: 9</pre>
 
=={{header|RATFOR}}==
{{works with|ratfor77|[https://sourceforge.net/p/chemoelectric/ratfor77/ public domain 1.0]}}
{{works with|gfortran|11.3.0}}
{{works with|f2c|20100827}}
 
 
<syntaxhighlight lang="ratfor">######################################################################
#
# The Rosetta Code code virtual machine in Ratfor 77.
#
# The implementation assumes your FORTRAN compiler supports 1-byte
# INTEGER*1 and 4-byte INTEGER*4. Integer storage will be
# native-endian, achieved via EQUIVALENCE. (GNU Fortran and f2c both
# should work.)
#
#
# How to deal with FORTRAN 77 input is a problem. I use formatted
# input, treating each line as an array of type CHARACTER--regrettably
# of no more than some predetermined, finite length. It is a very
# simple method and presents no significant difficulties, aside from
# the restriction on line length of the input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
# ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
# f2c -C -Nc40 vm-in-ratfor.f
# cc vm-in-ratfor.c -lf2c
# ./a.out < compiler-tests/primes.vm
#
# With gfortran, a little differently:
#
# ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
# gfortran -fcheck=all -std=legacy vm-in-ratfor.f
# ./a.out < compiler-tests/primes.vm
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------
 
# Some parameters you may wish to modify.
 
define(LINESZ, 256) # Size of an input line.
define(OUTLSZ, 1024) # Size of an output line.
define(STRNSZ, 4096) # Size of the string pool.
define(STCKSZ, 4096) # Size of stacks.
define(MAXVAR, 256) # Maximum number of variables.
define(MAXSTR, 256) # Maximum number of strings.
define(CODESZ, 16384) # Maximum size of a compiled program.
 
define(STRSZ, 2) # Size of an entry in the VM strings array.
define(STRI, 1) # Index of the string within strngs.
define(STRN, 2) # Length of the string.
 
#---------------------------------------------------------------------
 
define(NEWLIN, 10) # The Unix newline character (ASCII LF).
define(DQUOTE, 34) # The double quote character.
define(BACKSL, 92) # The backslash character.
 
#---------------------------------------------------------------------
 
define(OPHALT, 1)
define(OPADD, 2)
define(OPSUB, 3)
define(OPMUL, 4)
define(OPDIV, 5)
define(OPMOD, 6)
define(OPLT, 7)
define(OPGT, 8)
define(OPLE, 9)
define(OPGE, 10)
define(OPEQ, 11)
define(OPNE, 12)
define(OPAND, 13)
define(OPOR, 14)
define(OPNEG, 15)
define(OPNOT, 16)
define(OPPRTC, 17)
define(OPPRTI, 18)
define(OPPRTS, 19)
define(OPFTCH, 20)
define(OPSTOR, 21)
define(OPPUSH, 22)
define(OPJMP, 23)
define(OPJZ, 24)
 
#---------------------------------------------------------------------
 
function issp (c)
 
# Is a character a space character?
 
implicit none
 
character c
logical issp
 
integer ic
 
ic = ichar (c)
issp = (ic == 32 || (9 <= ic && ic <= 13))
end
 
function isalph (c)
 
# Is c character code for a letter?
 
implicit none
 
integer c
logical isalph
 
#
# The following is correct for ASCII and Unicode, but not for
# EBCDIC.
#
isalph = (ichar ('a') <= c && c <= ichar ('z')) _
|| (ichar ('A') <= c && c <= ichar ('Z'))
end
 
function isdgt (c)
 
# Is c character code for a digit?
 
implicit none
 
integer c
logical isdgt
 
isdgt = (ichar ('0') <= c && c <= ichar ('9'))
end
 
function skipsp (str, i, imax)
 
# Skip past spaces in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipsp
 
logical issp
 
logical done
 
skipsp = i
done = .false.
while (!done)
{
if (imax <= skipsp)
done = .true.
else if (!issp (str(skipsp)))
done = .true.
else
skipsp = skipsp + 1
}
end
 
function skipns (str, i, imax)
 
# Skip past non-spaces in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipns
 
logical issp
 
logical done
 
skipns = i
done = .false.
while (!done)
{
if (imax <= skipns)
done = .true.
else if (issp (str(skipns)))
done = .true.
else
skipns = skipns + 1
}
end
 
function trimrt (str, n)
 
# Find the length of a string, if one ignores trailing spaces.
 
implicit none
 
character str(*)
integer n
integer trimrt
 
logical issp
 
logical done
 
trimrt = n
done = .false.
while (!done)
{
if (trimrt == 0)
done = .true.
else if (!issp (str(trimrt)))
done = .true.
else
trimrt = trimrt - 1
}
end
 
function skipal (str, i, imax)
 
# Skip past alphabetic characters in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipal
 
logical isalph
 
logical done
 
skipal = i
done = .false.
while (!done)
{
if (imax <= skipal)
done = .true.
else if (!isalph (ichar (str(skipal))))
done = .true.
else
skipal = skipal + 1
}
end
 
function skipdg (str, i, imax)
 
# Skip past digits in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipdg
 
logical isdgt
 
logical done
 
skipdg = i
done = .false.
while (!done)
{
if (imax <= skipdg)
done = .true.
else if (!isdgt (ichar (str(skipdg))))
done = .true.
else
skipdg = skipdg + 1
}
end
 
function skipnd (str, i, imax)
 
# Skip past nondigits in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipnd
 
logical isdgt
 
logical done
 
skipnd = i
done = .false.
while (!done)
{
if (imax <= skipnd)
done = .true.
else if (isdgt (ichar (str(skipnd))))
done = .true.
else
skipnd = skipnd + 1
}
end
 
function skipd1 (str, i, imax)
 
# Skip past digits and '-' in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipd1
 
logical isdgt
 
logical done
 
skipd1 = i
done = .false.
while (!done)
{
if (imax <= skipd1)
done = .true.
else if (!isdgt (ichar (str(skipd1))) && str(skipd1) != '-')
done = .true.
else
skipd1 = skipd1 + 1
}
end
 
function skipn1 (str, i, imax)
 
# Skip past nondigits in a string, except '-'.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipn1
 
logical isdgt
 
logical done
 
skipn1 = i
done = .false.
while (!done)
{
if (imax <= skipn1)
done = .true.
else if (isdgt (ichar (str(skipn1))) || str(skipn1) == '-')
done = .true.
else
skipn1 = skipn1 + 1
}
end
 
function tolowr (c)
 
implicit none
 
character c
character tolowr
 
integer ic
 
# The following is correct for ASCII, and will work with Unicode
# code points, but is incorrect for EBCDIC.
 
ic = ichar (c)
if (ichar ('A') <= ic && ic <= ichar ('Z'))
ic = ic - ichar('A') + ichar('a')
tolowr = char (ic)
end
 
#---------------------------------------------------------------------
 
subroutine addstq (strngs, istrng, src, i0, n0, i, n)
 
# Add a quoted string to the string pool.
 
implicit none
 
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
character src(*) # Source string.
integer i0, n0 # Index and length in source string.
integer i, n # Index and length in string pool.
 
integer j
logical done
 
1000 format ('attempt to treat an unquoted string as a quoted string')
 
if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
{
write (*, 1000)
stop
}
 
i = istrng
 
n = 0
j = i0 + 1
done = .false.
while (j != i0 + n0 - 1)
if (i == STRNSZ)
{
write (*, '(''string pool exhausted'')')
stop
}
else if (src(j) == char (BACKSL))
{
if (j == i0 + n0 - 1)
{
write (*, '(''incorrectly formed quoted string'')')
stop
}
if (src(j + 1) == 'n')
strngs(istrng) = char (NEWLIN)
else if (src(j + 1) == char (BACKSL))
strngs(istrng) = src(j + 1)
else
{
write (*, '(''unrecognized escape sequence'')')
stop
}
istrng = istrng + 1
n = n + 1
j = j + 2
}
else
{
strngs(istrng) = src(j)
istrng = istrng + 1
n = n + 1
j = j + 1
}
end
 
#---------------------------------------------------------------------
 
subroutine push (stack, sp, i)
 
implicit none
 
integer stack(STCKSZ)
integer sp # Stack pointer.
integer i # Value to push.
 
if (sp == STCKSZ)
{
write (*, '(''stack overflow in push'')')
stop
}
stack(sp) = i
sp = sp + 1
end
 
function pop (stack, sp)
 
implicit none
 
integer stack(STCKSZ)
integer sp # Stack pointer.
integer pop
 
if (sp == 1)
{
write (*, '(''stack underflow in pop'')')
stop
}
sp = sp - 1
pop = stack(sp)
end
 
function nstack (sp)
 
implicit none
 
integer sp # Stack pointer.
integer nstack
 
nstack = sp - 1 # Current cardinality of the stack.
end
 
#---------------------------------------------------------------------
 
subroutine flushl (outbuf, noutbf)
 
# Flush a line from the output buffer.
 
implicit none
 
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
 
character*20 fmt
integer i
 
if (noutbf == 0)
write (*, '()')
else
{
write (fmt, 1000) noutbf
1000 format ('(', I10, 'A)')
write (*, fmt) (outbuf(i), i = 1, noutbf)
noutbf = 0
}
end
 
subroutine wrtchr (outbuf, noutbf, ch)
 
# Write a character to output.
 
implicit none
 
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
character ch # The character to output.
 
# This routine silently truncates anything that goes past the buffer
# boundary.
 
if (ch == char (NEWLIN))
call flushl (outbuf, noutbf)
else if (noutbf < OUTLSZ)
{
noutbf = noutbf + 1
outbuf(noutbf) = ch
}
end
 
subroutine wrtstr (outbuf, noutbf, str, i, n)
 
# Write a substring to output.
 
implicit none
 
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
character str(*) # The string from which to output.
integer i, n # Index and length of the substring.
 
integer j
 
for (j = 0; j < n; j = j + 1)
call wrtchr (outbuf, noutbf, str(i + j))
end
 
subroutine wrtint (outbuf, noutbf, ival, colcnt)
 
# Write an integer to output.
 
implicit none
 
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
integer ival # The non-negative integer to print.
integer colcnt # Column count, or zero for free format.
 
integer skipsp
 
character*40 buf
integer i, j
 
write (buf, '(I40)') ival
i = skipsp (buf, 1, 41)
if (0 < colcnt)
for (j = 1; j < colcnt - (40 - i); j = j + 1)
call wrtchr (outbuf, noutbf, ' ')
while (i <= 40)
{
call wrtchr (outbuf, noutbf, buf(i:i))
i = i + 1
}
end
 
#---------------------------------------------------------------------
 
function strnat (str, i, n)
 
# Convert a string to a non-negative integer.
 
implicit none
 
character str(*)
integer i, n
integer strnat
 
integer j
 
strnat = 0
for (j = 0; j < n; j = j + 1)
strnat = (10 * strnat) + (ichar (str(i + j)) - ichar ('0'))
end
 
function strint (str, i, n)
 
# Convert a string to an integer
 
implicit none
 
character str(*)
integer i, n
integer strint
 
integer strnat
 
if (str(i) == '-')
strint = -strnat (str, i + 1, n - 1)
else
strint = strnat (str, i, n)
end
 
#---------------------------------------------------------------------
 
subroutine put1 (code, i, opcode)
 
# Store a 1-byte operation.
 
implicit none
 
integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address to put the code at.
integer*1 opcode
 
if (CODESZ - i < 1)
{
write (*, '(''address beyond the size of memory'')')
stop
}
code(i) = opcode
end
 
subroutine put5 (code, i, opcode, ival)
 
# Store a 5-byte operation.
 
implicit none
 
integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address to put the code at.
integer*1 opcode #
integer ival # Immediate integer value.
 
integer*4 ival32
integer*1 ival8(4)
equivalence (ival32, ival8)
 
if (CODESZ - i < 5)
{
write (*, '(''address beyond the size of memory'')')
stop
}
code(i) = opcode
 
# Native-endian storage.
ival32 = ival
code(i + 1) = ival8(1)
code(i + 2) = ival8(2)
code(i + 3) = ival8(3)
code(i + 4) = ival8(4)
end
 
function getimm (code, i)
 
# Get an immediate value from the code, at address i.
 
implicit none
 
integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address at which the integer resides.
integer getimm # Immediate integer value.
 
integer*4 ival32
integer*1 ival8(4)
equivalence (ival32, ival8)
 
if (i < 0 || CODESZ <= i + 3)
{
write (*, '(''code address out of range'')')
stop
}
 
# Native-endian storage.
ival8(1) = code(i)
ival8(2) = code(i + 1)
ival8(3) = code(i + 2)
ival8(4) = code(i + 3)
getimm = ival32
end
 
#---------------------------------------------------------------------
 
subroutine rdhead (datsiz, strsiz)
 
# Read the header line.
 
implicit none
 
integer datsiz
integer strsiz
 
integer skipnd
integer skipdg
integer strnat
 
character line(LINESZ)
character*20 fmt
integer i1, j1, i2, j2
 
# Read a line of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ
read (*, fmt) line
 
i1 = skipnd (line, 1, LINESZ + 1)
j1 = skipdg (line, i1, LINESZ + 1)
i2 = skipnd (line, j1, LINESZ + 1)
j2 = skipdg (line, i2, LINESZ + 1)
if (i1 == j1 || i2 == j2)
{
write (*, '(''bad header line'')')
stop
}
datsiz = strnat (line, i1, j1 - i1)
strsiz = strnat (line, i2, j2 - i2)
end
 
subroutine rdstrs (strs, strsiz, strngs, istrng)
 
implicit none
 
integer strs(1:STRSZ, 0 : MAXSTR - 1)
integer strsiz
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
 
integer trimrt
integer skipsp
 
character line(LINESZ)
character*20 fmt
integer j
integer i, n
integer i0, n0
 
# Read lines of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ
 
for (j = 0; j < strsiz; j = j + 1)
{
read (*, fmt) line
n0 = trimrt (line, LINESZ)
i0 = skipsp (line, 1, n0 + 1)
if (i0 == n0 + 1)
{
write (*, '(''blank line where a string should be'')')
stop
}
call addstq (strngs, istrng, line, i0, n0 - i0 + 1, i, n)
strs(STRI, j) = i
strs(STRN, j) = n
}
end
 
function stropc (str, i, n)
 
# Convert substring to an opcode.
 
implicit none
 
character str(*)
integer i, n
integer*1 stropc
 
stropc = -1
if (n == 2)
{
if (str(i) == 'l')
{
if (str(i + 1) == 't')
stropc = OPLT
else if (str(i + 1) == 'e')
stropc = OPLE
}
else if (str(i) == 'g')
{
if (str(i + 1) == 't')
stropc = OPGT
else if (str(i + 1) == 'e')
stropc = OPGE
}
else if (str(i) == 'e' && str(i + 1) == 'q')
stropc = OPEQ
else if (str(i) == 'n' && str(i + 1) == 'e')
stropc = OPNE
else if (str(i) == 'o' && str(i + 1) == 'r')
stropc = OPOR
else if (str(i) == 'j' && str(i + 1) == 'z')
stropc = OPJZ
}
else if (n == 3)
{
if (str(i) == 'a')
{
if (str(i + 1) == 'd' && str(i + 2) == 'd')
stropc = OPADD
else if (str(i + 1) == 'n' && str(i + 2) == 'd')
stropc = OPAND
}
else if (str(i) == 'm')
{
if (str(i + 1) == 'o' && str(i + 2) == 'd')
stropc = OPMOD
else if (str(i + 1) == 'u' && str(i + 2) == 'l')
stropc = OPMUL
}
else if (str(i) == 'n')
{
if (str(i + 1) == 'e' && str(i + 2) == 'g')
stropc = OPNEG
else if (str(i + 1) == 'o' && str(i + 2) == 't')
stropc = OPNOT
}
else if (str(i) == 's' && str(i + 1) == 'u' _
&& str(i + 2) == 'b')
stropc = OPSUB
else if (str(i) == 'd' && str(i + 1) == 'i' _
&& str(i + 2) == 'v')
stropc = OPDIV
else if (str(i) == 'j' && str(i + 1) == 'm' _
&& str(i + 2) == 'p')
stropc = OPJMP
}
else if (n == 4)
{
if (str(i) == 'p')
{
if (str(i + 1) == 'r' && str(i + 2) == 't')
{
if (str(i + 3) == 'c')
stropc = OPPRTC
else if (str(i + 3) == 'i')
stropc = OPPRTI
else if (str(i + 3) == 's')
stropc = OPPRTS
}
if (str(i + 1) == 'u' && str(i + 2) == 's' _
&& str(i + 3) == 'h')
stropc = OPPUSH
}
else if (str(i) == 'h' && str(i + 1) == 'a' _
&& str(i + 2) == 'l' && str(i + 3) == 't')
stropc = OPHALT
}
else if (n == 5)
{
if (str(i) == 'f' && str(i + 1) == 'e' && str(i + 2) == 't' _
&& str(i + 3) == 'c' && str(i + 4) == 'h')
stropc = OPFTCH
if (str(i) == 's' && str(i + 1) == 't' && str(i + 2) == 'o' _
&& str(i + 3) == 'r' && str(i + 4) == 'e')
stropc = OPSTOR
}
if (stropc == -1)
{
write (*, '(''unrecognized opcode name'')')
stop
}
end
 
subroutine rdops (code)
 
# Read the opcodes and their immediate values.
 
implicit none
 
integer*1 code(0 : CODESZ - 1) # The byte code.
 
integer trimrt
integer skipsp
integer skipal
integer skipdg
integer skipd1
integer skipn1
integer strnat
integer strint
integer*1 stropc
character tolowr
 
character line(LINESZ)
character*20 fmt
integer stat
integer n
integer j
integer iaddr, jaddr # Address index and size.
integer iopnm, jopnm # Opcode name index and size.
integer iarg, jarg
integer addr
integer arg
integer*1 opcode
 
# Read lines of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ
 
read (*, fmt, iostat = stat) line
while (stat == 0)
{
n = trimrt (line, LINESZ)
 
for (j = 1; j <= n; j = j + 1)
line(j) = tolowr (line(j))
 
iaddr = skipsp (line, 1, n + 1)
jaddr = skipdg (line, iaddr, n + 1)
addr = strnat (line, iaddr, jaddr - iaddr)
 
iopnm = skipsp (line, jaddr, n + 1)
jopnm = skipal (line, iopnm, n + 1)
opcode = stropc (line, iopnm, jopnm - iopnm)
 
if (opcode == OPPUSH || opcode == OPFTCH || opcode == OPSTOR _
|| opcode == OPJMP || opcode == OPJZ)
{
iarg = skipn1 (line, jopnm, n + 1)
jarg = skipd1 (line, iarg, n + 1)
arg = strint (line, iarg, jarg - iarg)
call put5 (code, addr, opcode, arg)
}
else
call put1 (code, addr, opcode)
 
read (*, fmt, iostat = stat) line
}
end
 
subroutine rdcode (strs, strngs, istrng, code)
 
# Read and parse the "assembly" code.
 
implicit none
 
integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer*1 code(0 : CODESZ - 1) # The byte code.
 
integer datsiz
integer strsiz
 
call rdhead (datsiz, strsiz)
if (MAXVAR < datsiz)
{
write (*, '(''too many variables'')')
stop
}
if (MAXSTR < strsiz)
{
write (*, '(''too many strings'')')
stop
}
 
call rdstrs (strs, strsiz, strngs, istrng)
call rdops (code)
end
 
#---------------------------------------------------------------------
 
subroutine stkbin (sp)
 
implicit none
 
integer sp
 
if (sp < 3)
{
write (*, '(''stack underflow in binary operation'')')
stop
}
end
 
subroutine stkun (sp)
 
implicit none
 
integer sp
 
if (sp < 2)
{
write (*, '(''stack underflow in unary operation'')')
stop
}
end
 
function logl2i (b)
 
implicit none
 
logical b
integer logl2i
 
if (b)
logl2i = 1
else
logl2i = 0
end
 
subroutine rncode (strs, strngs, code, outbuf, noutbf)
 
# Run the code.
 
implicit none
 
integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer*1 code(0 : CODESZ - 1) # The byte code.
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
 
integer logl2i
integer getimm
integer pop
 
integer stack(STCKSZ)
integer data(0 : MAXVAR - 1)
integer sp # Stack pointer.
 
integer pc # Program counter.
integer ip # Instruction pointer.
equivalence (pc, ip) # LOL, use either name. :)
 
integer i, n
integer*1 opcode
logical done
 
sp = 1
ip = 0
 
done = .false.
while (!done)
{
if (ip < 0 || CODESZ <= ip)
{
write (*, '(''code address out of range'')')
stop
}
opcode = code(ip)
ip = ip + 1
if (opcode == OPADD)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) + stack(sp)
}
else if (opcode == OPSUB)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) - stack(sp)
}
else if (opcode == OPMUL)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) * stack(sp)
}
else if (opcode == OPDIV)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) / stack(sp)
}
else if (opcode == OPMOD)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = mod (stack (sp - 1), stack(sp))
}
else if (opcode == OPLT)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) < stack(sp))
}
else if (opcode == OPGT)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) > stack(sp))
}
else if (opcode == OPLE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) <= stack(sp))
}
else if (opcode == OPGE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) >= stack(sp))
}
else if (opcode == OPEQ)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) == stack(sp))
}
else if (opcode == OPNE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) != stack(sp))
}
else if (opcode == OPAND)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = _
logl2i (stack (sp - 1) != 0 && stack(sp) != 0)
}
else if (opcode == OPOR)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = _
logl2i (stack (sp - 1) != 0 || stack(sp) != 0)
}
else if (opcode == OPNEG)
{
call stkun (sp)
stack(sp - 1) = -stack(sp - 1)
}
else if (opcode == OPNOT)
{
call stkun (sp)
stack(sp - 1) = logl2i (stack(sp - 1) == 0)
}
else if (opcode == OPPRTC)
{
call wrtchr (outbuf, noutbf, char (pop (stack, sp)))
}
else if (opcode == OPPRTI)
{
call wrtint (outbuf, noutbf, pop (stack, sp), 0)
}
else if (opcode == OPPRTS)
{
i = pop (stack, sp)
if (i < 0 || MAXSTR <= i)
{
write (*, '(''string address out of range'')')
stop
}
n = strs(STRN, i)
i = strs(STRI, i)
call wrtstr (outbuf, noutbf, strngs, i, n)
}
else if (opcode == OPFTCH)
{
i = getimm (code, ip)
ip = ip + 4
if (i < 0 || MAXVAR <= i)
{
write (*, '(''data address out of range'')')
stop
}
call push (stack, sp, data(i))
}
else if (opcode == OPSTOR)
{
i = getimm (code, ip)
ip = ip + 4
if (i < 0 || MAXVAR <= i)
{
write (*, '(''data address out of range'')')
stop
}
data(i) = pop (stack, sp)
}
else if (opcode == OPPUSH)
{
call push (stack, sp, getimm (code, ip))
ip = ip + 4
}
else if (opcode == OPJMP)
{
ip = ip + getimm (code, ip)
}
else if (opcode == OPJZ)
{
if (pop (stack, sp) == 0)
ip = ip + getimm (code, ip)
else
ip = ip + 4
}
else
{
# Halt on OPHALT or any unrecognized code.
done = .true.
}
}
end
 
#---------------------------------------------------------------------
 
program vm
 
implicit none
 
integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer*1 code(0 : CODESZ - 1) # The byte code.
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
 
integer j
 
istrng = 1
noutbf = 0
 
for (j = 0; j < CODESZ; j = j + 1)
code(j) = OPHALT
 
call rdcode (strs, strngs, istrng, code)
call rncode (strs, strngs, code, outbuf, noutbf)
 
if (noutbf != 0)
call flushl (outbuf, noutbf)
end
 
######################################################################</syntaxhighlight>
 
 
{{out}}
<pre>$ ratfor77 vm-in-ratfor.r > vm-in-ratfor.f && gfortran -O2 -fcheck=all -std=legacy vm-in-ratfor.f && ./a.out < compiler-tests/primes.vm
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26</pre>
 
=={{header|Scala}}==
Line 10,168 ⟶ 13,798:
The following code implements a virtual machine for the output of the [http://rosettacode.org/wiki/Compiler/code_generator#Scala code generator].
 
<langsyntaxhighlight lang="scala">
package xyz.hyperreal.rosettacodeCompiler
 
Line 10,385 ⟶ 14,015:
 
}
</syntaxhighlight>
</lang>
 
The above code depends on the function <tt>unescape()</tt> to perform string escape sequence translation. That function is defined in the following separate source file.
 
<langsyntaxhighlight lang="scala">
package xyz.hyperreal
 
Line 10,417 ⟶ 14,047:
 
}
</syntaxhighlight>
</lang>
 
=={{header|Scheme}}==
Line 10,425 ⟶ 14,055:
All of the "Compiler/Sample programs" are correctly interpreted.
 
<langsyntaxhighlight lang="scheme">
(import (scheme base)
(scheme char)
Line 10,588 ⟶ 14,218:
(run-program data strings code))
(display "Error: pass a .asm filename\n"))
</syntaxhighlight>
</lang>
 
=={{header|Wren}}==
Line 10,596 ⟶ 14,226:
{{libheader|Wren-fmt}}
{{libheader|Wren-ioutil}}
<langsyntaxhighlight ecmascriptlang="wren">import "./dynamic" for Enum
import "./crypto" for Bytes
import "./fmt" for Conv
import "./ioutil" for FileUtil
 
var codes = [
Line 10,862 ⟶ 14,492:
lines = FileUtil.readLines("codegen.txt")
lineCount = lines.count
runVM.call(loadCode.call())</langsyntaxhighlight>
 
{{out}}
Line 10,878 ⟶ 14,508:
 
=={{header|Zig}}==
<langsyntaxhighlight lang="zig">
const std = @import("std");
 
Line 11,201 ⟶ 14,831:
}
}
</syntaxhighlight>
</lang>
 
=={{header|zkl}}==
{{trans|Python}}
File rvm.zkl:
<langsyntaxhighlight lang="zkl">// This is a little endian machine
const WORD_SIZE=4;
const{ var _n=-1; var[proxy]N=fcn{ _n+=1 } } // enumerator
Line 11,267 ⟶ 14,897:
code.del(0,sz+2);
}
run_vm(code,1000);</langsyntaxhighlight>
The binary code file code.bin:
{{out}}
871

edits