Compiler/virtual machine interpreter: Difference between revisions
Content added Content deleted
Line 209: | Line 209: | ||
<hr> |
<hr> |
||
__TOC__ |
__TOC__ |
||
=={{header|Ada}}== |
|||
{{works with|GNAT|Community 2021}} |
|||
<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; |
|||
begin |
|||
t := To_Unbounded_String (""); |
|||
i := s'First; |
|||
while i <= s'Last and then s (i) /= '"' loop |
|||
i := i + 1; |
|||
end loop; |
|||
if s'Last < i or else s (i) /= '"' then |
|||
raise bad_vm with "expected a '""'"; |
|||
end if; |
|||
i := i + 1; |
|||
while i <= s'Last and then s (i) /= '"' 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;</lang> |
|||
{{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}}== |
=={{header|Aime}}== |