aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data update

Browse source
This commit is contained in:
Ingy döt Net 2026-02-01 16:33:20 -08:00
parent 5150844a7d
commit 4bb20c9b71
7735 changed files with 38060 additions and 199180 deletions
Download patch file Download diff file Expand all files Collapse all files

935
Task/Compiler-virtual-machine-interpreter/Ada/compiler-virtual-machine-interpreter.ada
View file

@ -1,935 +0,0 @@
--
-- 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;

422
Task/Compiler-virtual-machine-interpreter/COBOL/compiler-virtual-machine-interpreter.cobol
View file

@ -1,422 +0,0 @@
>>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. vminterpreter.
environment division.
configuration section.
repository. function all intrinsic.
input-output section.
file-control.
select input-file assign using input-name
status is input-status
organization is line sequential.
data division.
file section.
fd input-file.
01 input-record pic x(64).
working-storage section.
01 program-name pic x(32).
01 input-name pic x(32).
01 input-status pic xx.
01 error-record pic x(64) value spaces global.
01 v-max pic 99.
01 parameters.
03 offset pic 999.
03 opcode pic x(8).
03 parm0 pic x(16).
03 parm1 pic x(16).
03 parm2 pic x(16).
01 opcodes.
03 opFETCH pic x value x'00'.
03 opSTORE pic x value x'01'.
03 opPUSH pic x value x'02'.
03 opADD pic x value x'03'.
03 opSUB pic x value x'04'.
03 opMUL pic x value x'05'.
03 opDIV pic x value x'06'.
03 opMOD pic x value x'07'.
03 opLT pic x value x'08'.
03 opGT pic x value x'09'.
03 opLE pic x value x'0A'.
03 opGE pic x value x'0B'.
03 opEQ pic x value x'0C'.
03 opNE pic x value x'0D'.
03 opAND pic x value x'0E'.
03 opOR pic x value x'0F'.
03 opNEG pic x value x'10'.
03 opNOT pic x value x'11'.
03 opJMP pic x value x'13'.
03 opJZ pic x value x'14'.
03 opPRTC pic x value x'15'.
03 opPRTS pic x value x'16'.
03 opPRTI pic x value x'17'.
03 opHALT pic x value x'18'.
01 filler.
03 s pic 99.
03 s-max pic 99 value 0.
03 s-lim pic 99 value 16.
03 filler occurs 16.
05 string-length pic 99.
05 string-entry pic x(48).
01 filler.
03 v pic 99.
03 v-lim pic 99 value 16.
03 variables occurs 16 usage binary-int.
01 generated-code global.
03 c pic 999 value 1.
03 pc pic 999.
03 c-lim pic 999 value 512.
03 kode pic x(512).
01 filler.
03 stack1 pic 999 value 2.
03 stack2 pic 999 value 1.
03 stack-lim pic 999 value 998.
03 stack occurs 998 usage binary-int.
01 display-definitions global.
03 ascii-character.
05 numeric-value usage binary-char.
03 display-integer pic -(9)9.
03 word-x.
05 word usage binary-int.
03 word-length pic 9.
03 string1 pic 99.
03 length1 pic 99.
03 count1 pic 99.
03 display-pending pic x.
procedure division.
start-vminterpreter.
display 1 upon command-line *> get arg(1)
accept program-name from argument-value
move length(word) to word-length
perform load-code
perform run-code
stop run
.
run-code.
move 1 to pc
perform until pc >= c
evaluate kode(pc:1)
when opFETCH
perform push-stack
move kode(pc + 1:word-length) to word-x
add 1 to word *> convert offset to subscript
move variables(word) to stack(stack1)
add word-length to pc
when opPUSH
perform push-stack
move kode(pc + 1:word-length) to word-x
move word to stack(stack1)
add word-length to pc
when opNEG
compute stack(stack1) = -stack(stack1)
when opNOT
if stack(stack1) = 0
move 1 to stack(stack1)
else
move 0 to stack(stack1)
end-if
when opJMP
move kode(pc + 1:word-length) to word-x
move word to pc
when opHALT
if display-pending = 'Y'
display space
end-if
exit perform
when opJZ
if stack(stack1) = 0
move kode(pc + 1:word-length) to word-x
move word to pc
else
add word-length to pc
end-if
perform pop-stack
when opSTORE
move kode(pc + 1:word-length) to word-x
add 1 to word *> convert offset to subscript
move stack(stack1) to variables(word)
add word-length to pc
perform pop-stack
when opADD
add stack(stack1) to stack(stack2)
perform pop-stack
when opSUB
subtract stack(stack1) from stack(stack2)
perform pop-stack
when opMUL
multiply stack(stack1) by stack(stack2)
*>rounded mode nearest-toward-zero *> doesn't match python
perform pop-stack
when opDIV
divide stack(stack1) into stack(stack2)
*>rounded mode nearest-toward-zero *> doesn't match python
perform pop-stack
when opMOD
move mod(stack(stack2),stack(stack1)) to stack(stack2)
perform pop-stack
when opLT
if stack(stack2) < stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opGT
if stack(stack2) > stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opLE
if stack(stack2) <= stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opGE
if stack(stack2) >= stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opEQ
if stack(stack2) = stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opNE
if stack(stack2) <> stack(stack1)
move 1 to stack(stack2)
else
move 0 to stack(stack2)
end-if
perform pop-stack
when opAND
call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
perform pop-stack
when opOR
call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
perform pop-stack
when opPRTC
move stack(stack1) to numeric-value
if numeric-value = 10
display space
move 'N' to display-pending
else
display ascii-character with no advancing
move 'Y' to display-pending
end-if
perform pop-stack
when opPRTS
add 1 to word *> convert offset to subscript
move 1 to string1
move string-length(word) to length1
perform until string1 > string-length(word)
move 0 to count1
inspect string-entry(word)(string1:length1)
tallying count1 for characters before initial '\' *> ' workaround code highlighter problem
evaluate true
when string-entry(word)(string1 + count1 + 1:1) = 'n' *> \n
display string-entry(word)(string1:count1)
move 'N' to display-pending
compute string1 = string1 + 2 + count1
compute length1 = length1 - 2 - count1
when string-entry(word)(string1 + count1 + 1:1) = '\' *> ' \\
display string-entry(word)(string1:count1 + 1) with no advancing
move 'Y' to display-pending
compute string1 = string1 + 2 + count1
compute length1 = length1 - 2 - count1
when other
display string-entry(word)(string1:count1) with no advancing
move 'Y' to display-pending
add count1 to string1
subtract count1 from length1
end-evaluate
end-perform
perform pop-stack
when opPRTI
move stack(stack1) to display-integer
display trim(display-integer) with no advancing
move 'Y' to display-pending
perform pop-stack
end-evaluate
add 1 to pc
end-perform
.
push-stack.
if stack1 >= stack-lim
string 'in vminterpreter at ' pc ' stack overflow at ' stack-lim into error-record
perform report-error
end-if
add 1 to stack1 stack2
>>d display ' push at ' pc space stack1 space stack2
.
pop-stack.
if stack1 < 2
string 'in vminterpreter at ' pc ' stack underflow' into error-record
perform report-error
end-if
>>d display ' pop at ' pc space stack1 space stack2
subtract 1 from stack1 stack2
.
load-code.
perform read-input
if input-status <> '00'
string 'in vminterpreter no input data' into error-record
perform report-error
end-if
unstring input-record delimited by all spaces into parm1 v-max parm2 s-max
if v-max > v-lim
string 'in vminterpreter datasize exceeds ' v-lim into error-record
perform report-error
end-if
if s-max > s-lim
string 'in vminterpreter number of strings exceeds ' s-lim into error-record
perform report-error
end-if
perform read-input
perform varying s from 1 by 1 until s > s-max
or input-status <> '00'
compute string-length(s) string-length(word) = length(trim(input-record)) - 2
move input-record(2:string-length(word)) to string-entry(s)
perform read-input
end-perform
if s <= s-max
string 'in vminterpreter not all strings found' into error-record
perform report-error
end-if
perform until input-status <> '00'
initialize parameters
unstring input-record delimited by all spaces into
parm0 offset opcode parm1 parm2
evaluate opcode
when 'fetch'
call 'emitbyte' using opFETCH
call 'emitword' using parm1
when 'store'
call 'emitbyte' using opSTORE
call 'emitword' using parm1
when 'push'
call 'emitbyte' using opPUSH
call 'emitword' using parm1
when 'add' call 'emitbyte' using opADD
when 'sub' call 'emitbyte' using opSUB
when 'mul' call 'emitbyte' using opMUL
when 'div' call 'emitbyte' using opDIV
when 'mod' call 'emitbyte' using opMOD
when 'lt' call 'emitbyte' using opLT
when 'gt' call 'emitbyte' using opGT
when 'le' call 'emitbyte' using opLE
when 'ge' call 'emitbyte' using opGE
when 'eq' call 'emitbyte' using opEQ
when 'ne' call 'emitbyte' using opNE
when 'and' call 'emitbyte' using opAND
when 'or' call 'emitbyte' using opOR
when 'not' call 'emitbyte' using opNOT
when 'neg' call 'emitbyte' using opNEG
when 'jmp'
call 'emitbyte' using opJMP
call 'emitword' using parm2
when 'jz'
call 'emitbyte' using opJZ
call 'emitword' using parm2
when 'prtc' call 'emitbyte' using opPRTC
when 'prts' call 'emitbyte' using opPRTS
when 'prti' call 'emitbyte' using opPRTI
when 'halt' call 'emitbyte' using opHALT
when other
string 'in vminterpreter unknown opcode ' trim(opcode) ' at ' offset into error-record
perform report-error
end-evaluate
perform read-input
end-perform
.
read-input.
if program-name = spaces
move '00' to input-status
accept input-record on exception move '10' to input-status end-accept
exit paragraph
end-if
if input-name = spaces
string program-name delimited by space '.gen' into input-name
open input input-file
if input-status <> '00'
string 'in vminterpreter ' trim(input-name) ' file open status ' input-status
into error-record
perform report-error
end-if
end-if
read input-file into input-record
evaluate input-status
when '00'
continue
when '10'
close input-file
when other
string 'in vminterpreter unexpected input-status: ' input-status into error-record
perform report-error
end-evaluate
.
report-error.
display error-record upon syserr
stop run with error status -1
.
identification division.
program-id. emitbyte.
data division.
linkage section.
01 opcode pic x.
procedure division using opcode.
start-emitbyte.
if c >= c-lim
string 'in vminterpreter emitbyte c exceeds ' c-lim into error-record
call 'reporterror'
end-if
move opcode to kode(c:1)
add 1 to c
.
end program emitbyte.
identification division.
program-id. emitword.
data division.
working-storage section.
01 word-temp pic x(8).
linkage section.
01 word-value any length.
procedure division using word-value.
start-emitword.
if c + word-length >= c-lim
string 'in vminterpreter emitword c exceeds ' c-lim into error-record
call 'reporterror'
end-if
move word-value to word-temp
inspect word-temp converting '[' to ' '
inspect word-temp converting ']' to ' '
move numval(trim(word-temp)) to word
move word-x to kode(c:word-length)
add word-length to c
.
end program emitword.
end program vminterpreter.

70
Task/Compiler-virtual-machine-interpreter/Phix/compiler-virtual-machine-interpreter-1.phix
View file

@ -1,41 +1,33 @@
(notonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\vm.exw
-- ============================
--
-- Since we have generated executable machine code, the virtual machine, such as it is, is just
-- the higher level implementations of printc/i/s, see setbuiltins() in cgen.e
-- Otherwise the only difference between this and cgen.exw is call(code_mem) instead of decode().
--
-- A quick test (calculating fib(44) 10^6 times) suggests ~500 times faster than interp.exw -
-- which is to be expected given that a single add instruction (1 clock) here is implemented as
-- at least three (and quite possibly five!) resursive calls to interp() in the other.</span>
-- demo\rosetta\Compiler\vm.exw
-- Since we have generated executable machine code, the virtual machine, such as it is, is just
-- the higher level implementations of printc/i/s, see setbuiltins() in cgen.e
-- Otherwise the only difference between this and cgen.exw is call(code_mem) instead of decode().
-- A quick test (calculating fib(44) 10^6 times) suggests ~500 times faster than interp.exw -
-- which is to be expected given that a single add instruction (1 clock) here is implemented as
-- at least three (and quite possibly five!) resursive calls to interp() in the other.
format PE32
--format ELF32
-- Note: cgen generates 32-bit machine code, which cannot be executed directly from a 64-bit interpreter.
-- You can however, via the magic of either the above format directives, use a 64-bit version of
-- Phix to compile this (just add a -c command line option) to a 32-bit executable, which can.
-- It would not be particularly difficult to emit 32 or 64 bit code, but some source code files
-- would, fairly obviously, then be very nearly twice as long, and a fair bit harder to read.
without js -- (machine code!)
include cgen.e
<span style="color: #000000;">format</span> <span style="color: #000000;">PE32</span>
<span style="color: #000080;font-style:italic;">--format ELF32
-- Note: cgen generates 32-bit machine code, which cannot be executed directly from a 64-bit interpreter.
-- You can however, via the magic of either the above format directives, use a 64-bit version of
-- Phix to compile this (just add a -c command line option) to a 32-bit executable, which can.
-- It would not be particularly difficult to emit 32 or 64 bit code, but some source code files
-- would, fairly obviously, then be very nearly twice as long, and a fair bit harder to read.</span>
procedure main(sequence cl)
open_files(cl)
toks = lex()
object t = parse()
code_gen(t)
fixup()
if machine_bits()=32 then
-- ^ as per note above
call(code_mem)
end if
free({var_mem,code_mem})
close_files()
end procedure
<span style="color: #008080;">without</span> <span style="color: #008080;">js</span> <span style="color: #000080;font-style:italic;">-- (machine code!)</span>
<span style="color: #008080;">include</span> <span style="color: #000000;">cgen</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">main</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">open_files</span><span style="color: #0000FF;">(</span><span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">toks</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">lex</span><span style="color: #0000FF;">()</span>
<span style="color: #004080;">object</span> <span style="color: #000000;">t</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">()</span>
<span style="color: #000000;">code_gen</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">fixup</span><span style="color: #0000FF;">()</span>
<span style="color: #008080;">if</span> <span style="color: #7060A8;">machine_bits</span><span style="color: #0000FF;">()=</span><span style="color: #000000;">32</span> <span style="color: #008080;">then</span>
<span style="color: #000080;font-style:italic;">-- ^ as per note above</span>
<span style="color: #000000;">call</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #7060A8;">free</span><span style="color: #0000FF;">({</span><span style="color: #000000;">var_mem</span><span style="color: #0000FF;">,</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">})</span>
<span style="color: #000000;">close_files</span><span style="color: #0000FF;">()</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<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>
<!--
--main(command_line())
main({0,0,"count.c"})