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

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Task/Compiler-virtual-machine-interpreter/00-META.yaml Normal file
View file

@ -0,0 +1,2 @@
---
from: http://rosettacode.org/wiki/Compiler/virtual_machine_interpreter

211
Task/Compiler-virtual-machine-interpreter/00-TASK.txt Normal file
View file

@ -0,0 +1,211 @@
Virtual Machine Interpreter
A virtual machine implements a computer in software.
{{task heading}}
Write a virtual machine interpreter. This interpreter should be able to run virtual
assembly language programs created via the [[Compiler/code_generator|task]]. This is a
byte-coded, 32-bit word stack based virtual machine.
The program should read input from a file and/or stdin, and write output to a file and/or
stdout.
Input format:
Given the following program:
count = 1;
while (count < 10) {
print("count is: ", count, "\n");
count = count + 1;
}
The output from the [[Compiler/code_generator|Code generator]] is a virtual assembly code program:
{| class="wikitable"
|-
! Output from gen, input to VM
|-
| style="vertical-align:top" |
<b><pre>Datasize: 1 Strings: 2
"count is: "
"\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (43) 65
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-51) 10
65 halt</pre></b>
|}
The first line of the input specifies the datasize required and the number of constant
strings, in the order that they are reference via the code.
The data can be stored in a separate array, or the data can be stored at the beginning of
the stack. Data is addressed starting at 0. If there are 3 variables, the 3rd one if
referenced at address 2.
If there are one or more constant strings, they come next. The code refers to these
strings by their index. The index starts at 0. So if there are 3 strings, and the code
wants to reference the 3rd string, 2 will be used.
Next comes the actual virtual assembly code. The first number is the code address of that
instruction. After that is the instruction mnemonic, followed by optional operands,
depending on the instruction.
Registers:
sp:
the stack pointer - points to the next top of stack. The stack is a 32-bit integer
array.
pc:
the program counter - points to the current instruction to be performed. The code is an
array of bytes.
Data:
data
string pool
Instructions:
Each instruction is one byte. The following instructions also have a 32-bit integer
operand:
fetch [index]
where index is an index into the data array.
store [index]
where index is an index into the data array.
push n
where value is a 32-bit integer that will be pushed onto the stack.
jmp (n) addr
where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.
jz (n) addr
where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.
The following instructions do not have an operand. They perform their operation directly
against the stack:
For the following instructions, the operation is performed against the top two entries in
the stack:
add
sub
mul
div
mod
lt
gt
le
ge
eq
ne
and
or
For the following instructions, the operation is performed against the top entry in the
stack:
neg
not
Print the word at stack top as a character.
prtc
Print the word at stack top as an integer.
prti
Stack top points to an index into the string pool. Print that entry.
prts
Unconditional stop.
halt
; A simple example virtual machine:
<syntaxhighlight lang="python">def run_vm(data_size)
int stack[data_size + 1000]
set stack[0..data_size - 1] to 0
int pc = 0
while True:
op = code[pc]
pc += 1
if op == FETCH:
stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
pc += word_size
elif op == STORE:
stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
pc += word_size
elif op == PUSH:
stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
pc += word_size
elif op == ADD: stack[-2] += stack[-1]; stack.pop()
elif op == SUB: stack[-2] -= stack[-1]; stack.pop()
elif op == MUL: stack[-2] *= stack[-1]; stack.pop()
elif op == DIV: stack[-2] /= stack[-1]; stack.pop()
elif op == MOD: stack[-2] %= stack[-1]; stack.pop()
elif op == LT: stack[-2] = stack[-2] < stack[-1]; stack.pop()
elif op == GT: stack[-2] = stack[-2] > stack[-1]; stack.pop()
elif op == LE: stack[-2] = stack[-2] <= stack[-1]; stack.pop()
elif op == GE: stack[-2] = stack[-2] >= stack[-1]; stack.pop()
elif op == EQ: stack[-2] = stack[-2] == stack[-1]; stack.pop()
elif op == NE: stack[-2] = stack[-2] != stack[-1]; stack.pop()
elif op == AND: stack[-2] = stack[-2] and stack[-1]; stack.pop()
elif op == OR: stack[-2] = stack[-2] or stack[-1]; stack.pop()
elif op == NEG: stack[-1] = -stack[-1]
elif op == NOT: stack[-1] = not stack[-1]
elif op == JMP: pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == JZ: if stack.pop() then pc += word_size else pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == PRTC: print stack[-1] as a character; stack.pop()
elif op == PRTS: print the constant string referred to by stack[-1]; stack.pop()
elif op == PRTI: print stack[-1] as an integer; stack.pop()
elif op == HALT: break</syntaxhighlight>
; Additional examples
Your solution should pass all the test cases above and the additional tests found '''[[Compiler/Sample_programs|Here]]'''.
{{task heading|Reference}}
The C and Python versions can be considered reference implementations.
;Related Tasks
* [[Compiler/lexical_analyzer|Lexical Analyzer task]]
* [[Compiler/syntax_analyzer|Syntax Analyzer task]]
* [[Compiler/code_generator|Code Generator task]]
* [[Compiler/AST_interpreter|AST Interpreter task]]
<hr>
__TOC__

307
Task/Compiler-virtual-machine-interpreter/ALGOL-W/compiler-virtual-machine-interpreter.alg Normal file
View file

@ -0,0 +1,307 @@
begin % virtual machine interpreter %
% string literals %
string(256) array stringValue ( 0 :: 256 );
integer array stringLength ( 0 :: 256 );
integer MAX_STRINGS;
% op codes %
integer oFetch, oStore, oPush
, oAdd, oSub, oMul, oDiv, oMod, oLt, oGt, oLe, oGe, oEq, oNe
, oAnd, oOr, oNeg, oNot, oJmp, oJz, oPrtc, oPrts, oPrti, oHalt
;
string(6) array opName ( 1 :: 24 );
integer OP_MAX;
% code %
string(1) array byteCode ( 0 :: 4096 );
integer nextLocation, MAX_LOCATION;
% data %
integer array data ( 0 :: 4096 );
integer dataSize, MAX_DATA, MAX_STACK;
% tracing %
logical trace;
% reports an error and stops %
procedure rtError( string(80) value message ); begin
integer errorPos;
write( s_w := 0, "**** Runtime error: " );
errorPos := 0;
while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
writeon( s_w := 0, message( errorPos // 1 ) );
errorPos := errorPos + 1
end while_not_at_end_of_message ;
writeon( s_w := 0, "." );
assert( false )
end genError ;
oFetch := 1; opName( oFetch ) := "fetch"; oStore := 2; opName( oStore ) := "store"; oPush := 3; opName( oPush ) := "push";
oAdd := 4; opName( oAdd ) := "add"; oSub := 5; opName( oSub ) := "sub"; oMul := 6; opName( oMul ) := "mul";
oDiv := 7; opName( oDiv ) := "div"; oMod := 8; opName( oMod ) := "mod"; oLt := 9; opName( oLt ) := "lt";
oGt := 10; opName( oGt ) := "gt"; oLe := 11; opName( oLe ) := "le"; oGe := 12; opName( oGe ) := "ge";
oEq := 13; opName( oEq ) := "eq"; oNe := 14; opName( oNe ) := "ne"; oAnd := 15; opName( oAnd ) := "and";
oOr := 16; opName( oOr ) := "or"; oNeg := 17; opName( oNeg ) := "neg"; oNot := 18; opName( oNot ) := "not";
oJmp := 19; opName( oJmp ) := "jmp"; oJz := 20; opName( oJz ) := "jz"; oPrtc := 21; opName( oPrtc ) := "prtc";
oPrts := 22; opName( oPrts ) := "prts"; oPrti := 23; opName( oPrti ) := "prti"; oHalt := 24; opName( oHalt ) := "halt";
OP_MAX := oHalt;
trace := false;
MAX_STACK := 256;
MAX_LOCATION := 4096;
for pc := 0 until MAX_LOCATION do byteCode( pc ) := code( 0 );
MAX_DATA := 4096;
for dPos := 0 until MAX_DATA do data( dPos ) := 0;
MAX_STRINGS := 256;
for sPos := 0 until MAX_STRINGS do begin
stringValue( sPos ) := " ";
stringLength( sPos ) := 0
end for_sPos ;
% load thge output from syntaxc analyser %
begin % readCode %
% skips spaces on the source line %
procedure skipSpaces ; begin
while line( lPos // 1 ) = " " do lPos := lPos + 1
end skipSpaces ;
% parses a string from line and stores it in the string literals table %
procedure readString ( integer value stringNumber ) ; begin
string(256) str;
integer sLen;
str := " ";
sLen := 0;
lPos := lPos + 1; % skip the opening double-quote %
while lPos <= 255 and line( lPos // 1 ) not = """" do begin
str( sLen // 1 ) := line( lPos // 1 );
sLen := sLen + 1;
lPos := lPos + 1
end while_more_string ;
if lPos > 255 then rtError( "Unterminated String." );
% store the string %
stringValue( stringNumber ) := str;
stringLength( stringNumber ) := sLen
end readString ;
% gets an integer from the line - checks for valid digits %
integer procedure readInteger ; begin
integer n;
skipSpaces;
n := 0;
while line( lPos // 1 ) >= "0" and line( lPos // 1 ) <= "9" do begin
n := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
lPos := lPos + 1
end while_not_end_of_integer ;
n
end readInteger ;
% reads the next line from standard input %
procedure readALine ; begin
lPos := 0;
readcard( line );
if trace then write( s_w := 0, ">> ", line( 0 // 32 ) )
end readALine ;
% loads an instruction from the current source line %
procedure loadCodeFromLine ; begin
integer pc, opCode, operand, oPos;
string(256) op;
logical haveOperand;
% get the code location %
pc := readInteger;
if pc > MAX_LOCATION then rtError( "Code too large." );
% get the opCode %
skipSpaces;
oPos := 0;
op := " ";
while lPos <= 255 and line( lPos // 1 ) not = " " do begin
op( oPos // 1 ) := line( lPos // 1 );
oPos := oPos + 1;
lPos := lPos + 1
end while_more_opName ;
% lookup the op code %
opCode := 0;
oPos := 1;
while oPos <= OP_MAX and opCode = 0 do begin
if opName( oPos ) = op then opCode := oPos
else oPos := oPos + 1
end while_op_not_found ;
if opCode = 0 then rtError( "Unknown op code." );
% get the operand if there is one %
operand := 0;
haveOperand := false;
if opCode = oFetch or opCode = oStore then begin
% fetch or store - operand is enclosed in square brackets %
skipSpaces;
if line( lPos // 1 ) not = "[" then rtError( """["" expected after fetch/store." );
lPos := lPos + 1;
operand := readInteger;
if operand > dataSize then rtError( "fetch/store address out of range." );
haveOperand := true
end
else if opCode = oPush then begin
% push integer literal instruction %
operand := readInteger;
haveOperand := true
end
else if opCode = oJmp or opCode = oJz then begin
% jump - the operand is the relative address enclosed in parenthesis %
% followed by the absolute address - we use the absolute address so %
% the opewrand will be >= 0 %
skipSpaces;
if line( lPos // 1 ) not = "(" then rtError( """("" expected after jmp/jz." );
lPos := lPos + 1;
if line( lPos // 1 ) = "-" then % negative relative address % lPos := lPos + 1;
operand := readInteger;
if line( lPos // 1 ) not = ")" then rtError( """)"" expected after jmp/jz." );
lPos := lPos + 1;
operand := readInteger;
haveOperand := true
end if_various_opcodes ;
% store the code %
byteCode( pc ) := code( opCode );
if haveOperand then begin
% have an operand for the op code %
if ( pc + 4 ) > MAX_LOCATION then rtError( "Code too large." );
for oPos := 1 until 4 do begin
pc := pc + 1;
byteCode( pc ) := code( operand rem 256 );
operand := operand div 256;
end for_oPos
end if_have_operand ;
end loadCodeFromLine ;
string(256) line;
string(16) name;
integer lPos, tPos, stringCount;
% allow us to detect EOF %
ENDFILE := EXCEPTION( false, 1, 0, false, "EOF" );
% first line should be "Datasize: d Strings: s" where d = number variables %
% and s = number of strings %
readALine;
if line = "trace" then begin
% extension - run in trace mode %
trace := true;
readALine
end if_line_eq_trace ;
if XCPNOTED(ENDFILE) then rtError( "Empty program file." );
if line( 0 // 10 ) not = "Datasize: " then rtError( "Header line missing." );
lPos := 10;
dataSize := readInteger;
if dataSize > MAX_DATA then rtError( "Datasize too large." );
skipSpaces;
if line( lPos // 9 ) not = "Strings: " then rtError( """Strings: "" missing on header line." );
lPos := lPos + 9;
stringCount := readInteger;
if stringCount > MAX_STRINGS then rtError( "Too many strings." );
% read the string table %
for stringNumber := 0 until stringCount - 1 do begin
string(256) str;
integer sLen, sPos;
readALine;
if XCPNOTED(ENDFILE) then rtError( "End-of-file in string table." );
if line( lPos // 1 ) not = """" then rtError( "String literal expected." );
str := " ";
sLen := 0;
lPos := lPos + 1; % skip the opening double-quote %
while lPos <= 255 and line( lPos // 1 ) not = """" do begin
str( sLen // 1 ) := line( lPos // 1 );
sLen := sLen + 1;
lPos := lPos + 1
end while_more_string ;
if lPos > 255 then rtError( "Unterminated String." );
% store the string %
stringValue( stringNumber ) := str;
stringLength( stringNumber ) := sLen
end for_sPos ;
% read the code %
readALine;
while not XCPNOTED(ENDFILE) do begin
if line not = " " then loadCodeFromLine;
readALine
end while_not_eof
end;
% run the program %
begin
integer pc, opCode, operand, sp;
integer array st ( 0 :: MAX_STACK );
logical halted;
% prints a string from the string pool, escape sequences are interpreted %
procedure writeOnString( integer value stringNumber ) ;
begin
integer cPos, sLen;
string(256) text;
if stringNumber < 0 or stringNumber > MAX_STRINGS then rtError( "Invalid string number." );
cPos := 0;
sLen := stringLength( stringNumber );
text := stringValue( stringNumber );
while cPos < stringLength( stringNumber ) do begin
string(1) ch;
ch := text( cPos // 1 );
if ch not = "\" then writeon( s_w := 0, ch )
else begin
% escaped character %
cPos := cPos + 1;
if cPos > sLen then rtError( "String terminates with ""\""." );
ch := text( cPos // 1 );
if ch = "n" then % newline % write()
else writeon( s_w := 0, ch )
end;
cPos := cPos + 1
end while_not_end_of_string
end writeOnString ;
pc := 0;
sp := -1;
halted := false;
while not halted do begin;
% get the next op code and operand %
opCode := decode( byteCode( pc ) );
pc := pc + 1;
operand := 0;
if opCode = oFetch or opCode = oStore or opCode = oPush or opCode = oJmp or opCode = oJz then begin
% this opCode has an operand %
pc := pc + 4;
for bPos := 1 until 4 do begin
operand := ( operand * 256 ) + decode( byteCode( pc - bPos ) );
end for_bPos
end if_opCode_with_an_operand ;
if trace then begin
write( i_w:= 1, s_w := 0, pc, " op(", opCode, "): ", opName( opCode ), " ", operand );
write()
end if_trace ;
% interpret the instruction %
if opCode = oFetch then begin sp := sp + 1; st( sp ) := data( operand ) end
else if opCode = oStore then begin data( operand ) := st( sp ); sp := sp - 1 end
else if opCode = oPush then begin sp := sp + 1; st( sp ) := operand end
else if opCode = oHalt then halted := true
else if opCode = oJmp then pc := operand
else if oPCode = oJz then begin
if st( sp ) = 0 then pc := operand;
sp := sp - 1
end
else if opCode = oPrtc then begin writeon( i_w := 1, s_w := 0, code( st( sp ) ) ); sp := sp - 1 end
else if opCode = oPrti then begin writeon( i_w := 1, s_w := 0, st( sp ) ); sp := sp - 1 end
else if opCode = oPrts then begin writeonString( st( sp ) ); sp := sp - 1 end
else if opCode = oNeg then st( sp ) := - st( sp )
else if opCode = oNot then st( sp ) := ( if st( sp ) = 0 then 1 else 0 )
else begin
operand := st( sp );
sp := sp - 1;
if opCode = oAdd then st( sp ) := st( sp ) + operand
else if opCode = oSub then st( sp ) := st( sp ) - operand
else if opCode = oMul then st( sp ) := st( sp ) * operand
else if opCode = oDiv then st( sp ) := st( sp ) div operand
else if opCode = oMod then st( sp ) := st( sp ) rem operand
else if opCode = oLt then st( sp ) := if st( sp ) < operand then 1 else 0
else if opCode = oGt then st( sp ) := if st( sp ) > operand then 1 else 0
else if opCode = oLe then st( sp ) := if st( sp ) <= operand then 1 else 0
else if opCode = oGe then st( sp ) := if st( sp ) >= operand then 1 else 0
else if opCode = oEq then st( sp ) := if st( sp ) = operand then 1 else 0
else if opCode = oNe then st( sp ) := if st( sp ) not = operand then 1 else 0
else if opCode = oAnd then st( sp ) := if st( sp ) not = 0 and operand not = 0 then 1 else 0
else if opCode = oOr then st( sp ) := if st( sp ) not = 0 or operand not = 0 then 1 else 0
else rtError( "Unknown opCode." )
end if_various_opCodes
end while_not_halted
end
end.

1803
Task/Compiler-virtual-machine-interpreter/ATS/compiler-virtual-machine-interpreter.ats Normal file
View file

File diff suppressed because it is too large Load diff

154
Task/Compiler-virtual-machine-interpreter/AWK/compiler-virtual-machine-interpreter.awk Normal file
View file

@ -0,0 +1,154 @@
function error(msg) {
printf("%s\n", msg)
exit(1)
}
function bytes_to_int(bstr, i, sum) {
sum = 0
for (i=word_size-1; i>=0; i--) {
sum *= 256
sum += code[bstr+i]
}
return sum
}
function emit_byte(x) {
code[next_free_code_index++] = x
}
function emit_word(x, i) {
for (i=0; i<word_size; i++) {
emit_byte(int(x)%256);
x = int(x/256)
}
}
function run_vm(data_size) {
sp = data_size + 1
pc = 0
while (1) {
op = code[pc++]
if (op == FETCH) {
stack[sp++] = stack[bytes_to_int(pc)]
pc += word_size
} else if (op == STORE) {
stack[bytes_to_int(pc)] = stack[--sp]
pc += word_size
} else if (op == PUSH) {
stack[sp++] = bytes_to_int(pc)
pc += word_size
} else if (op == ADD ) { stack[sp-2] += stack[sp-1]; sp--
} else if (op == SUB ) { stack[sp-2] -= stack[sp-1]; sp--
} else if (op == MUL ) { stack[sp-2] *= stack[sp-1]; sp--
} else if (op == DIV ) { stack[sp-2] = int(stack[sp-2] / stack[sp-1]); sp--
} else if (op == MOD ) { stack[sp-2] %= stack[sp-1]; sp--
} else if (op == LT ) { stack[sp-2] = stack[sp-2] < stack[sp-1]; sp--
} else if (op == GT ) { stack[sp-2] = stack[sp-2] > stack[sp-1]; sp--
} else if (op == LE ) { stack[sp-2] = stack[sp-2] <= stack[sp-1]; sp--
} else if (op == GE ) { stack[sp-2] = stack[sp-2] >= stack[sp-1]; sp--
} else if (op == EQ ) { stack[sp-2] = stack[sp-2] == stack[sp-1]; sp--
} else if (op == NE ) { stack[sp-2] = stack[sp-2] != stack[sp-1]; sp--
} else if (op == AND ) { stack[sp-2] = stack[sp-2] && stack[sp-1]; sp--
} else if (op == OR ) { stack[sp-2] = stack[sp-2] || stack[sp-1]; sp--
} else if (op == NEG ) { stack[sp-1] = - stack[sp-1]
} else if (op == NOT ) { stack[sp-1] = ! stack[sp-1]
} else if (op == JMP ) { pc += bytes_to_int(pc)
} else if (op == JZ ) { if (stack[--sp]) { pc += word_size } else { pc += bytes_to_int(pc) }
} else if (op == PRTC) { printf("%c", stack[--sp])
} else if (op == PRTS) { printf("%s", string_pool[stack[--sp]])
} else if (op == PRTI) { printf("%d", stack[--sp])
} else if (op == HALT) { break
}
} # while
}
function str_trans(srce, dest, i) {
dest = ""
for (i=1; i <= length(srce); ) {
if (substr(srce, i, 1) == "\\" && i < length(srce)) {
if (substr(srce, i+1, 1) == "n") {
dest = dest "\n"
i += 2
} else if (substr(srce, i+1, 1) == "\\") {
dest = dest "\\"
i += 2
}
} else {
dest = dest substr(srce, i, 1)
i += 1
}
}
return dest
}
function load_code( n, i) {
getline line
if (line == "")
error("empty line")
n=split(line, line_list)
data_size = line_list[2]
n_strings = line_list[4]
for (i=0; i<n_strings; i++) {
getline line
gsub(/\n/, "", line)
gsub(/"/ , "", line)
string_pool[i] = str_trans(line)
}
while (getline) {
offset = int($1)
instr = $2
opcode = code_map[instr]
if (opcode == "")
error("Unknown instruction " instr " at " offset)
emit_byte(opcode)
if (opcode == JMP || opcode == JZ) {
p = int($4)
emit_word(p - (offset + 1))
} else if (opcode == PUSH) {
value = int($3)
emit_word(value)
} else if (opcode == FETCH || opcode == STORE) {
gsub(/\[/, "", $3)
gsub(/\]/, "", $3)
value = int($3)
emit_word(value)
}
}
return data_size
}
BEGIN {
code_map["fetch"] = FETCH = 1
code_map["store"] = STORE = 2
code_map["push" ] = PUSH = 3
code_map["add" ] = ADD = 4
code_map["sub" ] = SUB = 5
code_map["mul" ] = MUL = 6
code_map["div" ] = DIV = 7
code_map["mod" ] = MOD = 8
code_map["lt" ] = LT = 9
code_map["gt" ] = GT = 10
code_map["le" ] = LE = 11
code_map["ge" ] = GE = 12
code_map["eq" ] = EQ = 13
code_map["ne" ] = NE = 14
code_map["and" ] = AND = 15
code_map["or" ] = OR = 16
code_map["neg" ] = NEG = 17
code_map["not" ] = NOT = 18
code_map["jmp" ] = JMP = 19
code_map["jz" ] = JZ = 20
code_map["prtc" ] = PRTC = 21
code_map["prts" ] = PRTS = 22
code_map["prti" ] = PRTI = 23
code_map["halt" ] = HALT = 24
next_free_node_index = 1
next_free_code_index = 0
word_size = 4
input_file = "-"
if (ARGC > 1)
input_file = ARGV[1]
data_size = load_code()
run_vm(data_size)
}

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

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

87
Task/Compiler-virtual-machine-interpreter/Aime/compiler-virtual-machine-interpreter.aime Normal file
View file

@ -0,0 +1,87 @@
integer n, pc, sp;
file f;
text s;
index code, Data;
list l, stack, strings;
f.affix(argv(1));
f.list(l, 0);
n = atoi(l[-1]);
while (n) {
f.lead(s);
strings.append(erase(s, -1, 0));
n -= 1;
}
while (f.list(l, 0) ^ -1) {
code.put(atoi(lf_x_text(l)), l);
}
pc = sp = 0;
while (1) {
l = code[pc];
s = l[0];
if (s == "jz") {
if (lb_pick(stack)) {
isk_greater(code, pc, pc);
} else {
pc = atoi(l[-1]);
}
} elif (s == "jmp") {
pc = atoi(l[-1]);
} else {
if (s == "push") {
lb_push(stack, atoi(l[1]));
} elif (s == "fetch") {
lb_push(stack, Data[atoi(erase(l[1], -1, 0))]);
} elif (s == "neg") {
stack[-1] = -stack[-1];
} elif (s == "not") {
stack[-1] = !stack[-1];
} elif (s == "halt") {
break;
} else {
n = lb_pick(stack);
if (s == "store") {
Data[atoi(erase(l[1], -1, 0))] = n;
} elif (s == "add") {
stack[-1] = stack[-1] + n;
} elif (s == "sub") {
stack[-1] = stack[-1] - n;
} elif (s == "mul") {
stack[-1] = stack[-1] * n;
} elif (s == "div") {
stack[-1] = stack[-1] / n;
} elif (s == "mod") {
stack[-1] = stack[-1] % n;
} elif (s == "lt") {
stack[-1] = stack[-1] < n;
} elif (s == "gt") {
stack[-1] = stack[-1] > n;
} elif (s == "le") {
stack[-1] = stack[-1] <= n;
} elif (s == "ge") {
stack[-1] = stack[-1] >= n;
} elif (s == "eq") {
stack[-1] = stack[-1] == n;
} elif (s == "ne") {
stack[-1] = stack[-1] != n;
} elif (s == "and") {
stack[-1] = stack[-1] && n;
} elif (s == "or") {
stack[-1] = stack[-1] || n;
} elif (s == "prtc") {
o_byte(n);
} elif (s == "prti") {
o_(n);
} elif (s == "prts") {
o_(strings[n]);
} else {
}
}
isk_greater(code, pc, pc);
}
}

267
Task/Compiler-virtual-machine-interpreter/C/compiler-virtual-machine-interpreter.c Normal file
View file

@ -0,0 +1,267 @@
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <stdint.h>
#include <ctype.h>
#define NELEMS(arr) (sizeof(arr) / sizeof(arr[0]))
#define da_dim(name, type) type *name = NULL; \
int _qy_ ## name ## _p = 0; \
int _qy_ ## name ## _max = 0
#define da_redim(name) do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)
#define da_rewind(name) _qy_ ## name ## _p = 0
#define da_append(name, x) do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)
typedef unsigned char uchar;
typedef uchar code;
typedef enum { FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND,
OR, NEG, NOT, JMP, JZ, PRTC, PRTS, PRTI, HALT
} Code_t;
typedef struct Code_map {
char *text;
Code_t op;
} Code_map;
Code_map code_map[] = {
{"fetch", FETCH},
{"store", STORE},
{"push", PUSH },
{"add", ADD },
{"sub", SUB },
{"mul", MUL },
{"div", DIV },
{"mod", MOD },
{"lt", LT },
{"gt", GT },
{"le", LE },
{"ge", GE },
{"eq", EQ },
{"ne", NE },
{"and", AND },
{"or", OR },
{"neg", NEG },
{"not", NOT },
{"jmp", JMP },
{"jz", JZ },
{"prtc", PRTC },
{"prts", PRTS },
{"prti", PRTI },
{"halt", HALT },
};
FILE *source_fp;
da_dim(object, code);
void error(const char *fmt, ... ) {
va_list ap;
char buf[1000];
va_start(ap, fmt);
vsprintf(buf, fmt, ap);
va_end(ap);
printf("error: %s\n", buf);
exit(1);
}
/*** Virtual Machine interpreter ***/
void run_vm(const code obj[], int32_t data[], int g_size, char **string_pool) {
int32_t *sp = &data[g_size + 1];
const code *pc = obj;
again:
switch (*pc++) {
case FETCH: *sp++ = data[*(int32_t *)pc]; pc += sizeof(int32_t); goto again;
case STORE: data[*(int32_t *)pc] = *--sp; pc += sizeof(int32_t); goto again;
case PUSH: *sp++ = *(int32_t *)pc; pc += sizeof(int32_t); goto again;
case ADD: sp[-2] += sp[-1]; --sp; goto again;
case SUB: sp[-2] -= sp[-1]; --sp; goto again;
case MUL: sp[-2] *= sp[-1]; --sp; goto again;
case DIV: sp[-2] /= sp[-1]; --sp; goto again;
case MOD: sp[-2] %= sp[-1]; --sp; goto again;
case LT: sp[-2] = sp[-2] < sp[-1]; --sp; goto again;
case GT: sp[-2] = sp[-2] > sp[-1]; --sp; goto again;
case LE: sp[-2] = sp[-2] <= sp[-1]; --sp; goto again;
case GE: sp[-2] = sp[-2] >= sp[-1]; --sp; goto again;
case EQ: sp[-2] = sp[-2] == sp[-1]; --sp; goto again;
case NE: sp[-2] = sp[-2] != sp[-1]; --sp; goto again;
case AND: sp[-2] = sp[-2] && sp[-1]; --sp; goto again;
case OR: sp[-2] = sp[-2] || sp[-1]; --sp; goto again;
case NEG: sp[-1] = -sp[-1]; goto again;
case NOT: sp[-1] = !sp[-1]; goto again;
case JMP: pc += *(int32_t *)pc; goto again;
case JZ: pc += (*--sp == 0) ? *(int32_t *)pc : (int32_t)sizeof(int32_t); goto again;
case PRTC: printf("%c", sp[-1]); --sp; goto again;
case PRTS: printf("%s", string_pool[sp[-1]]); --sp; goto again;
case PRTI: printf("%d", sp[-1]); --sp; goto again;
case HALT: break;
default: error("Unknown opcode %d\n", *(pc - 1));
}
}
char *read_line(int *len) {
static char *text = NULL;
static int textmax = 0;
for (*len = 0; ; (*len)++) {
int ch = fgetc(source_fp);
if (ch == EOF || ch == '\n') {
if (*len == 0)
return NULL;
break;
}
if (*len + 1 >= textmax) {
textmax = (textmax == 0 ? 128 : textmax * 2);
text = realloc(text, textmax);
}
text[*len] = ch;
}
text[*len] = '\0';
return text;
}
char *rtrim(char *text, int *len) { // remove trailing spaces
for (; *len > 0 && isspace(text[*len - 1]); --(*len))
;
text[*len] = '\0';
return text;
}
char *translate(char *st) {
char *p, *q;
if (st[0] == '"') // skip leading " if there
++st;
p = q = st;
while ((*p++ = *q++) != '\0') {
if (q[-1] == '\\') {
if (q[0] == 'n') {
p[-1] = '\n';
++q;
} else if (q[0] == '\\') {
++q;
}
}
if (q[0] == '"' && q[1] == '\0') // skip trialing " if there
++q;
}
return st;
}
/* convert an opcode string into its byte value */
int findit(const char text[], int offset) {
for (size_t i = 0; i < sizeof(code_map) / sizeof(code_map[0]); i++) {
if (strcmp(code_map[i].text, text) == 0)
return code_map[i].op;
}
error("Unknown instruction %s at %d\n", text, offset);
return -1;
}
void emit_byte(int c) {
da_append(object, (uchar)c);
}
void emit_int(int32_t n) {
union {
int32_t n;
unsigned char c[sizeof(int32_t)];
} x;
x.n = n;
for (size_t i = 0; i < sizeof(x.n); ++i) {
emit_byte(x.c[i]);
}
}
/*
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
154 jmp (-73) 82
164 jz (32) 197
175 push 0
159 fetch [4]
149 store [3]
*/
/* Load code into global array object, return the string pool and data size */
char **load_code(int *ds) {
int line_len, n_strings;
char **string_pool;
char *text = read_line(&line_len);
text = rtrim(text, &line_len);
strtok(text, " "); // skip "Datasize:"
*ds = atoi(strtok(NULL, " ")); // get actual data_size
strtok(NULL, " "); // skip "Strings:"
n_strings = atoi(strtok(NULL, " ")); // get number of strings
string_pool = malloc(n_strings * sizeof(char *));
for (int i = 0; i < n_strings; ++i) {
text = read_line(&line_len);
text = rtrim(text, &line_len);
text = translate(text);
string_pool[i] = strdup(text);
}
for (;;) {
int len;
text = read_line(&line_len);
if (text == NULL)
break;
text = rtrim(text, &line_len);
int offset = atoi(strtok(text, " ")); // get the offset
char *instr = strtok(NULL, " "); // get the instruction
int opcode = findit(instr, offset);
emit_byte(opcode);
char *operand = strtok(NULL, " ");
switch (opcode) {
case JMP: case JZ:
operand++; // skip the '('
len = strlen(operand);
operand[len - 1] = '\0'; // remove the ')'
emit_int(atoi(operand));
break;
case PUSH:
emit_int(atoi(operand));
break;
case FETCH: case STORE:
operand++; // skip the '['
len = strlen(operand);
operand[len - 1] = '\0'; // remove the ']'
emit_int(atoi(operand));
break;
}
}
return string_pool;
}
void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) {
if (fn[0] == '\0')
*fp = std;
else if ((*fp = fopen(fn, mode)) == NULL)
error(0, 0, "Can't open %s\n", fn);
}
int main(int argc, char *argv[]) {
init_io(&source_fp, stdin, "r", argc > 1 ? argv[1] : "");
int data_size;
char **string_pool = load_code(&data_size);
int data[1000 + data_size];
run_vm(object, data, data_size, string_pool);
}

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

@ -0,0 +1,422 @@
>>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.

725
Task/Compiler-virtual-machine-interpreter/Common-Lisp/compiler-virtual-machine-interpreter.lisp Normal file
View file

@ -0,0 +1,725 @@
#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
(ros:ensure-asdf)
#+quicklisp(ql:quickload '() :silent t)
)
(defpackage :ros.script.vm.3858678051
(:use :cl))
(in-package :ros.script.vm.3858678051)
;;;
;;; The Rosetta Code Virtual Machine, in Common Lisp.
;;;
;;; Notes:
;;;
;;; * I have tried not to use foreign types or similar means of
;;; optimization.
;;;
;;; * Integers are stored in the VM's executable memory in
;;; big-endian order. Not because I prefer it, but because I do
;;; not want to get myself into a little-endian rut.
;;;
(require "cl-ppcre")
(require "trivia")
;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(defconstant executable-memory-size 65536
"The size of memory for executable code, in 8-bit words.")
;;; Similarly, I am going to have fixed size data and stack memory.
(defconstant data-memory-size 2048
"The size of memory for stored data, in 32-bit words.")
(defconstant stack-memory-size 2048
"The size of memory for the stack, in 32-bit words.")
;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(deftype word ()
'(unsigned-byte 32))
(deftype register ()
'(simple-array word (1)))
(deftype executable-memory ()
`(simple-array (unsigned-byte 8) ,(list executable-memory-size)))
(deftype data-memory ()
`(simple-array word ,(list data-memory-size)))
(deftype stack-memory ()
`(simple-array word ,(list stack-memory-size)))
(defconstant re-blank-line
(ppcre:create-scanner "^\\s*$"))
(defconstant re-parse-instr-1
(ppcre:create-scanner "^\\s*(\\d+)\\s*(.*\\S)"))
(defconstant re-parse-instr-2
(ppcre:create-scanner "(?i)^(\\S+)\\s*(.*)"))
(defconstant re-parse-instr-3
(ppcre:create-scanner "^[[(]?([0-9-]+)"))
(defconstant opcode-names
#("halt"
"add"
"sub"
"mul"
"div"
"mod"
"lt"
"gt"
"le"
"ge"
"eq"
"ne"
"and"
"or"
"neg"
"not"
"prtc"
"prti"
"prts"
"fetch"
"store"
"push"
"jmp"
"jz"))
(defun blank-line-p (s)
(not (not (ppcre:scan re-blank-line s))))
(defun opcode-from-name (s)
(position-if (lambda (name)
(string= s name))
opcode-names))
(defun create-executable-memory ()
(coerce (make-list executable-memory-size
:initial-element (opcode-from-name "halt"))
'executable-memory))
(defun create-data-memory ()
(coerce (make-list data-memory-size :initial-element 0)
'data-memory))
(defun create-stack-memory ()
(coerce (make-list stack-memory-size :initial-element 0)
'stack-memory))
(defun create-register ()
(coerce (make-list 1 :initial-element 0) 'register))
(defstruct machine
(sp (create-register) :type register) ; Stack pointer.
(ip (create-register) :type register) ; Instruction pointer (same
; thing as program counter).
(code (create-executable-memory) :type executable-memory)
(data (create-data-memory) :type data-memory)
(stack (create-stack-memory) :type stack-memory)
(strings nil)
output *standard-output*)
(defun insert-instruction (memory instr)
(declare (type executable-memory memory))
(trivia:match instr
((list address opcode arg)
(let ((instr-size (if arg 5 1)))
(unless (<= (+ address instr-size) executable-memory-size)
(warn "the VM's executable memory size is exceeded")
(uiop:quit 1))
(setf (elt memory address) opcode)
(when arg
;; Big-endian order.
(setf (elt memory (+ address 1)) (ldb (byte 8 24) arg))
(setf (elt memory (+ address 2)) (ldb (byte 8 16) arg))
(setf (elt memory (+ address 3)) (ldb (byte 8 8) arg))
(setf (elt memory (+ address 4)) (ldb (byte 8 0) arg)))))))
(defun load-executable-memory (memory instr-lst)
(declare (type executable-memory memory))
(loop for instr in instr-lst
do (insert-instruction memory instr)))
(defun parse-instruction (s)
(if (blank-line-p s)
nil
(let* ((strings (nth-value 1 (ppcre:scan-to-strings
re-parse-instr-1 s)))
(address (parse-integer (elt strings 0)))
(split (nth-value 1 (ppcre:scan-to-strings
re-parse-instr-2 (elt strings 1))))
(opcode-name (string-downcase (elt split 0)))
(opcode (opcode-from-name opcode-name))
(arguments (elt split 1))
(has-arg (trivia:match opcode-name
((or "fetch" "store" "push" "jmp" "jz") t)
(_ nil))))
(if has-arg
(let* ((argstr-lst
(nth-value 1 (ppcre:scan-to-strings
re-parse-instr-3 arguments)))
(argstr (elt argstr-lst 0)))
`(,address ,opcode ,(parse-integer argstr)))
`(,address ,opcode ())))))
(defun read-instructions (inpf)
(loop for line = (read-line inpf nil 'eoi)
until (eq line 'eoi)
for instr = (parse-instruction line)
when instr collect instr))
(defun read-datasize-and-strings-count (inpf)
(let ((line (read-line inpf)))
(multiple-value-bind (_whole-match strings)
;; This is a permissive implementation.
(ppcre:scan-to-strings
"(?i)^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+)"
line)
(declare (ignore _whole-match))
`(,(parse-integer (elt strings 0))
,(parse-integer (elt strings 1))))))
(defun parse-string-literal (s)
;; This is a permissive implementation, but only in that it skips
;; any leading space. It does not check carefully for outright
;; mistakes.
(let* ((s (ppcre:regex-replace "^\\s*" s ""))
(quote-mark (elt s 0))
(i 1)
(lst
(loop until (char= (elt s i) quote-mark)
collect (let ((c (elt s i)))
(if (char= c #\\)
(let ((c0 (trivia:match (elt s (1+ i))
(#\n #\newline)
(c1 c1))))
(setq i (+ i 2))
c0)
(progn
(setq i (1+ i))
c))))))
(coerce lst 'string)))
(defun read-string-literals (inpf strings-count)
(loop for i from 1 to strings-count
collect (parse-string-literal (read-line inpf))))
(defun open-inpf (inpf-filename)
(if (string= inpf-filename "-")
*standard-input*
(open inpf-filename :direction :input)))
(defun open-outf (outf-filename)
(if (string= outf-filename "-")
*standard-output*
(open outf-filename :direction :output
:if-exists :overwrite
:if-does-not-exist :create)))
(defun word-signbit-p (x)
"True if and only if the sign bit is set."
(declare (type word x))
(/= 0 (logand x #x80000000)))
(defun word-add (x y)
"Addition with overflow freely allowed."
(declare (type word x))
(declare (type word y))
(coerce (logand (+ x y) #xFFFFFFFF) 'word))
(defun word-neg (x)
"The two's complement."
(declare (type word x))
(word-add (logxor x #xFFFFFFFF) 1))
(defun word-sub (x y)
"Subtraction with overflow freely allowed."
(declare (type word x))
(declare (type word y))
(word-add x (word-neg y)))
(defun word-mul (x y)
"Signed multiplication."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-xy (the word
(logand (* abs-x abs-y) #xFFFFFFFF))))
(if x<0
(if y<0 abs-xy (word-neg abs-xy))
(if y<0 (word-neg abs-xy) abs-xy))))))
(defun word-div (x y)
"The quotient after signed integer division with truncation towards
zero."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x/y (the word
(logand (floor abs-x abs-y) #xFFFFFFFF))))
(if x<0
(if y<0 abs-x/y (word-neg abs-x/y))
(if y<0 (word-neg abs-x/y) abs-x/y))))))
(defun word-mod (x y)
"The remainder after signed integer division with truncation towards
zero."
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x%y (the word
(logand (nth-value 1 (floor abs-x abs-y))
#xFFFFFFFF))))
(if x<0 (word-neg abs-x%y) abs-x%y)))))
(defun b2i (b)
(declare (type boolean b))
(if b 1 0))
(defun word-lt (x y)
"Signed comparison: is x less than y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (< x y) t)
(if y<0 nil (< x y))))))
(defun word-le (x y)
"Signed comparison: is x less than or equal to y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (<= x y) t)
(if y<0 nil (<= x y))))))
(defun word-gt (x y)
"Signed comparison: is x greater than y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (> x y) nil)
(if y<0 t (> x y))))))
(defun word-ge (x y)
"Signed comparison: is x greater than or equal to y?"
(declare (type word x))
(declare (type word y))
(let ((x<0 (word-signbit-p x))
(y<0 (word-signbit-p y)))
(b2i (if x<0
(if y<0 (>= x y) nil)
(if y<0 t (>= x y))))))
(defun word-eq (x y)
"Is x equal to y?"
(declare (type word x))
(declare (type word y))
(b2i (= x y)))
(defun word-ne (x y)
"Is x not equal to y?"
(declare (type word x))
(declare (type word y))
(b2i (/= x y)))
(defun word-cmp (x)
"The logical complement."
(declare (type word x))
(b2i (= x 0)))
(defun word-and (x y)
"The logical conjunction."
(declare (type word x))
(declare (type word y))
(b2i (and (/= x 0) (/= y 0))))
(defun word-or (x y)
"The logical disjunction."
(declare (type word x))
(declare (type word y))
(b2i (or (/= x 0) (/= y 0))))
(defun unop (stack sp operation)
"Perform a unary operation on the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type (function (word) word) operation))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (1- i))))
(setf (elt stack (1- i)) (funcall operation x)))))
(defun binop (stack sp operation)
"Perform a binary operation on the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type (function (word word) word) operation))
(let ((i (elt sp 0)))
(unless (<= 2 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (- i 2)))
(y (elt stack (1- i))))
(setf (elt stack (- i 2)) (funcall operation x y)))
(setf (elt sp 0) (1- i))))
(defun jri (code ip)
"Jump relative immediate."
(declare (type executable-memory code))
(declare (type register ip))
;; Big-endian order.
(let ((j (elt ip 0)))
(unless (<= (+ j 4) executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let* ((offset (elt code (+ j 3)))
(offset (dpb (elt code (+ j 2)) (byte 8 8) offset))
(offset (dpb (elt code (+ j 1)) (byte 8 16) offset))
(offset (dpb (elt code j) (byte 8 24) offset)))
(setf (elt ip 0) (word-add j offset)))))
(defun jriz (stack sp code ip)
"Jump relative immediate, if zero."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((x (elt stack (1- i))))
(setf (elt sp 0) (1- i))
(if (= x 0)
(jri code ip)
(setf (elt ip 0) (+ (elt ip 0) 4))))))
(defun get-immediate-value (code ip)
(declare (type executable-memory code))
(declare (type register ip))
;; Big-endian order.
(let ((j (elt ip 0)))
(unless (<= (+ j 4) executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let* ((x (elt code (+ j 3)))
(x (dpb (elt code (+ j 2)) (byte 8 8) x))
(x (dpb (elt code (+ j 1)) (byte 8 16) x))
(x (dpb (elt code j) (byte 8 24) x)))
(setf (elt ip 0) (+ j 4))
x)))
(defun pushi (stack sp code ip)
"Push-immediate a value from executable memory onto the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(let ((i (elt sp 0)))
(unless (< i stack-memory-size)
(warn "stack overflow")
(uiop:quit 1))
(setf (elt stack i) (get-immediate-value code ip))
(setf (elt sp 0) (1+ i))))
(defun fetch (stack sp code ip data)
"Fetch data to the stack, using the storage location given in
executable memory."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(declare (type data-memory data))
(let ((i (elt sp 0)))
(unless (< i stack-memory-size)
(warn "stack overflow")
(uiop:quit 1))
(let* ((k (get-immediate-value code ip))
(x (elt data k)))
(setf (elt stack i) x)
(setf (elt sp 0) (1+ i)))))
(defun pop-one (stack sp)
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let* ((x (elt stack (1- i))))
(setf (elt sp 0) (1- i))
x)))
(defun store (stack sp code ip data)
"Store data from the stack, using the storage location given in
executable memory."
(declare (type stack-memory stack))
(declare (type register sp))
(declare (type executable-memory code))
(declare (type register ip))
(declare (type data-memory data))
(let ((i (elt sp 0)))
(unless (<= 1 i)
(warn "stack underflow")
(uiop:quit 1))
(let ((k (get-immediate-value code ip))
(x (pop-one stack sp)))
(setf (elt data k) x))))
(defun prti (stack sp outf)
"Print the top value of the stack, as a signed decimal value."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((n (pop-one stack sp))
(n<0 (word-signbit-p n)))
(if n<0
(format outf "-~D" (word-neg n))
(format outf "~D" n))))
(defun prtc (stack sp outf)
"Print the top value of the stack, as a character."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((c (pop-one stack sp)))
(format outf "~C" (code-char c))))
(defun prts (stack sp strings outf)
"Print the string specified by the top of the stack."
(declare (type stack-memory stack))
(declare (type register sp))
(let* ((k (pop-one stack sp))
(s (elt strings k)))
(format outf "~A" s)))
(defmacro defun-machine-binop (op)
(let ((machine-op (read-from-string
(concatenate 'string "machine-" (string op))))
(word-op (read-from-string
(concatenate 'string "word-" (string op)))))
`(defun ,machine-op (mach)
(declare (type machine mach))
(binop (machine-stack mach)
(machine-sp mach)
#',word-op))))
(defmacro defun-machine-unop (op)
(let ((machine-op (read-from-string
(concatenate 'string "machine-" (string op))))
(word-op (read-from-string
(concatenate 'string "word-" (string op)))))
`(defun ,machine-op (mach)
(declare (type machine mach))
(unop (machine-stack mach)
(machine-sp mach)
#',word-op))))
(defun-machine-binop "add")
(defun-machine-binop "sub")
(defun-machine-binop "mul")
(defun-machine-binop "div")
(defun-machine-binop "mod")
(defun-machine-binop "lt")
(defun-machine-binop "gt")
(defun-machine-binop "le")
(defun-machine-binop "ge")
(defun-machine-binop "eq")
(defun-machine-binop "ne")
(defun-machine-binop "and")
(defun-machine-binop "or")
(defun-machine-unop "neg")
(defun machine-not (mach)
(declare (type machine mach))
(unop (machine-stack mach)
(machine-sp mach)
#'word-cmp))
(defun machine-prtc (mach)
(declare (type machine mach))
(prtc (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(defun machine-prti (mach)
(declare (type machine mach))
(prti (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(defun machine-prts (mach)
(declare (type machine mach))
(prts (machine-stack mach)
(machine-sp mach)
(machine-strings mach)
(machine-output mach)))
(defun machine-fetch (mach)
(declare (type machine mach))
(fetch (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(defun machine-store (mach)
(declare (type machine mach))
(store (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(defun machine-push (mach)
(declare (type machine mach))
(pushi (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(defun machine-jmp (mach)
(declare (type machine mach))
(jri (machine-code mach)
(machine-ip mach)))
(defun machine-jz (mach)
(declare (type machine mach))
(jriz (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(defun get-opcode (mach)
(declare (type machine mach))
(let ((code (machine-code mach))
(ip (machine-ip mach)))
(let ((j (elt ip 0)))
(unless (< j executable-memory-size)
(warn "address past end of executable memory")
(uiop:quit 1))
(let ((opcode (elt code j)))
(setf (elt ip 0) (1+ j))
opcode))))
(defun run-instruction (mach opcode)
(declare (type machine mach))
(declare (type fixnum opcode))
(let ((op-mod-4 (logand opcode #x3))
(op-div-4 (ash opcode -2)))
(trivia:match op-div-4
(0 (trivia:match op-mod-4
(1 (machine-add mach))
(2 (machine-sub mach))
(3 (machine-mul mach))))
(1 (trivia:match op-mod-4
(0 (machine-div mach))
(1 (machine-mod mach))
(2 (machine-lt mach))
(3 (machine-gt mach))))
(2 (trivia:match op-mod-4
(0 (machine-le mach))
(1 (machine-ge mach))
(2 (machine-eq mach))
(3 (machine-ne mach))))
(3 (trivia:match op-mod-4
(0 (machine-and mach))
(1 (machine-or mach))
(2 (machine-neg mach))
(3 (machine-not mach))))
(4 (trivia:match op-mod-4
(0 (machine-prtc mach))
(1 (machine-prti mach))
(2 (machine-prts mach))
(3 (machine-fetch mach))))
(5 (trivia:match op-mod-4
(0 (machine-store mach))
(1 (machine-push mach))
(2 (machine-jmp mach))
(3 (machine-jz mach)))))))
(defun run-vm (mach)
(declare (type machine mach))
(let ((opcode-for-halt (the fixnum (opcode-from-name "halt")))
(opcode-for-add (the fixnum (opcode-from-name "add")))
(opcode-for-jz (the fixnum (opcode-from-name "jz"))))
(loop for opcode = (the fixnum (get-opcode mach))
until (= opcode opcode-for-halt)
do (progn (when (or (< opcode opcode-for-add)
(< opcode-for-jz opcode))
(warn "unsupported opcode")
(uiop:quit 1))
(run-instruction mach opcode)))))
(defun usage-error ()
(princ "Usage: vm [INPUTFILE [OUTPUTFILE]]" *standard-output*)
(terpri *standard-output*)
(princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
*standard-output*)
(princ " standard I/O is used." *standard-output*)
(terpri *standard-output*)
(uiop:quit 1))
(defun get-filenames (argv)
(trivia:match argv
((list) '("-" "-"))
((list inpf-filename) `(,inpf-filename "-"))
((list inpf-filename outf-filename) `(,inpf-filename
,outf-filename))
(_ (usage-error))))
(defun main (&rest argv)
(let* ((filenames (get-filenames argv))
(inpf-filename (car filenames))
(inpf (open-inpf inpf-filename))
(outf-filename (cadr filenames))
(outf (open-outf outf-filename))
(sizes (read-datasize-and-strings-count inpf))
(datasize (car sizes))
(strings-count (cadr sizes))
(strings (read-string-literals inpf strings-count))
(instructions (read-instructions inpf))
;; We shall remain noncommittal about how strings are stored
;; on the hypothetical machine.
(strings (coerce strings 'simple-vector))
(mach (make-machine :strings strings
:output outf)))
(unless (<= datasize data-memory-size)
(warn "the VM's data memory size is exceeded")
(uiop:quit 1))
(load-executable-memory (machine-code mach) instructions)
(run-vm mach)
(unless (string= inpf-filename "-")
(close inpf))
(unless (string= outf-filename "-")
(close outf))
(uiop:quit 0)))
;;; vim: set ft=lisp lisp:

907
Task/Compiler-virtual-machine-interpreter/D/compiler-virtual-machine-interpreter.d Normal file
View file

@ -0,0 +1,907 @@
//
// 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;
}

83
Task/Compiler-virtual-machine-interpreter/Forth/compiler-virtual-machine-interpreter.fth Normal file
View file

@ -0,0 +1,83 @@
CREATE BUF 0 , \ single-character look-ahead buffer
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
: SPACE? DUP BL = SWAP 9 14 WITHIN OR ;
: >SPACE BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT? 48 58 WITHIN ;
: >INT ( -- n) >SPACE 0
BEGIN PEEK DIGIT?
WHILE GETC [CHAR] 0 - SWAP 10 * + REPEAT ;
CREATE A 0 ,
: C@A ( -- c) A @ C@ ;
: C@A+ ( -- c) C@A 1 CHARS A +! ;
: C!A+ ( c --) A @ C! 1 CHARS A +! ;
: WORD ( -- c-addr) >SPACE PAD 1+ A !
BEGIN PEEK SPACE? INVERT WHILE GETC C!A+ REPEAT
>SPACE PAD A @ OVER - 1- PAD C! ;
: >STRING ( -- c-addr) >SPACE GETC DROP PAD 1+ A !
BEGIN PEEK [CHAR] " <> WHILE GETC C!A+ REPEAT
GETC DROP PAD A @ OVER - 1- PAD C! ;
: \INTERN ( c-addr -- c-addr) HERE >R A ! C@A+ DUP C,
BEGIN DUP WHILE C@A+
DUP [CHAR] \ = IF DROP -1 R@ +! C@A+
[CHAR] n = IF 10 ELSE [CHAR] \ THEN
THEN C, 1-
REPEAT DROP R> ;
: . 0 .R ;
CREATE DATA 0 ,
CREATE STRINGS 0 ,
: >DATA HERE DATA !
WORD DROP >INT 4 * BEGIN DUP WHILE 0 C, 1- REPEAT DROP ;
: >STRINGS HERE STRINGS !
WORD DROP >INT DUP >R CELLS ALLOT
0 BEGIN DUP R@ < WHILE
DUP CELLS >STRING \INTERN STRINGS @ ROT + ! 1+
REPEAT R> DROP DROP ;
: >HEADER >DATA >STRINGS ;
: i32! ( n addr --)
OVER $FF AND OVER C! 1+
OVER 8 RSHIFT $FF AND OVER C! 1+
OVER 16 RSHIFT $FF AND OVER C! 1+
SWAP 24 RSHIFT $FF AND SWAP C! ;
: i32@ ( addr -- n) >R \ This is kinda slow... hmm
R@ C@
R@ 1 + C@ 8 LSHIFT OR
R@ 2 + C@ 16 LSHIFT OR
R> 3 + C@ 24 LSHIFT OR
DUP $7FFFFFFF AND SWAP $80000000 AND - ; \ sign extend
: i32, ( n --) HERE 4 ALLOT i32! ;
: i32@+ ( -- n) A @ i32@ A @ 4 + A ! ;
CREATE BYTECODE 0 ,
: @fetch i32@+ 4 * DATA @ + i32@ ;
: @store i32@+ 4 * DATA @ + i32! ;
: @jmp i32@+ BYTECODE @ + A ! ;
: @jz IF 4 A +! ELSE @jmp THEN ;
: @prts CELLS STRINGS @ + @ COUNT TYPE ;
: @div >R S>D R> SM/REM SWAP DROP ;
CREATE OPS
' @fetch , ' @store , ' i32@+ , ' @jmp , ' @jz ,
' EMIT , ' . , ' @prts , ' NEGATE , ' 0= ,
' + , ' - , ' * , ' @div , ' MOD ,
' < , ' > , ' <= , ' >= ,
' = , ' <> , ' AND , ' OR , ' BYE ,
CREATE #OPS 0 ,
: OP: CREATE #OPS @ , 1 #OPS +! DOES> @ ;
OP: fetch OP: store OP: push OP: jmp OP: jz
OP: prtc OP: prti OP: prts OP: neg OP: not
OP: add OP: sub OP: mul OP: div OP: mod
OP: lt OP: gt OP: le OP: ge
OP: eq OP: ne OP: and OP: or OP: halt
: >OP WORD FIND
0= IF ." Unrecognized opcode" ABORT THEN EXECUTE ;
: >i32 >INT i32, ;
: >[i32] GETC DROP >i32 GETC DROP ;
: >OFFSET WORD DROP ( drop relative offset) >i32 ;
CREATE >PARAM ' >[i32] DUP , , ' >i32 , ' >OFFSET DUP , ,
: >BYTECODE HERE >R
BEGIN >INT DROP >OP >R R@ C,
R@ 5 < IF R@ CELLS >PARAM + @ EXECUTE THEN
R> halt = UNTIL R> BYTECODE ! ;
: RUN BYTECODE @ A !
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN

1534
Task/Compiler-virtual-machine-interpreter/Fortran/compiler-virtual-machine-interpreter.f Normal file
View file

File diff suppressed because it is too large Load diff

303
Task/Compiler-virtual-machine-interpreter/Go/compiler-virtual-machine-interpreter.go Normal file
View file

@ -0,0 +1,303 @@
package main
import (
"bufio"
"encoding/binary"
"fmt"
"log"
"math"
"os"
"strconv"
"strings"
)
type code = byte
const (
fetch code = iota
store
push
add
sub
mul
div
mod
lt
gt
le
ge
eq
ne
and
or
neg
not
jmp
jz
prtc
prts
prti
halt
)
var codeMap = map[string]code{
"fetch": fetch,
"store": store,
"push": push,
"add": add,
"sub": sub,
"mul": mul,
"div": div,
"mod": mod,
"lt": lt,
"gt": gt,
"le": le,
"ge": ge,
"eq": eq,
"ne": ne,
"and": and,
"or": or,
"neg": neg,
"not": not,
"jmp": jmp,
"jz": jz,
"prtc": prtc,
"prts": prts,
"prti": prti,
"halt": halt,
}
var (
err error
scanner *bufio.Scanner
object []code
stringPool []string
)
func reportError(msg string) {
log.Fatalf("error : %s\n", msg)
}
func check(err error) {
if err != nil {
log.Fatal(err)
}
}
func btoi(b bool) int32 {
if b {
return 1
}
return 0
}
func itob(i int32) bool {
if i != 0 {
return true
}
return false
}
func emitByte(c code) {
object = append(object, c)
}
func emitWord(n int) {
bs := make([]byte, 4)
binary.LittleEndian.PutUint32(bs, uint32(n))
for _, b := range bs {
emitByte(code(b))
}
}
/*** Virtual Machine interpreter ***/
func runVM(dataSize int) {
stack := make([]int32, dataSize+1)
pc := int32(0)
for {
op := object[pc]
pc++
switch op {
case fetch:
x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
stack = append(stack, stack[x])
pc += 4
case store:
x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
ln := len(stack)
stack[x] = stack[ln-1]
stack = stack[:ln-1]
pc += 4
case push:
x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
stack = append(stack, x)
pc += 4
case add:
ln := len(stack)
stack[ln-2] += stack[ln-1]
stack = stack[:ln-1]
case sub:
ln := len(stack)
stack[ln-2] -= stack[ln-1]
stack = stack[:ln-1]
case mul:
ln := len(stack)
stack[ln-2] *= stack[ln-1]
stack = stack[:ln-1]
case div:
ln := len(stack)
stack[ln-2] = int32(float64(stack[ln-2]) / float64(stack[ln-1]))
stack = stack[:ln-1]
case mod:
ln := len(stack)
stack[ln-2] = int32(math.Mod(float64(stack[ln-2]), float64(stack[ln-1])))
stack = stack[:ln-1]
case lt:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] < stack[ln-1])
stack = stack[:ln-1]
case gt:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] > stack[ln-1])
stack = stack[:ln-1]
case le:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] <= stack[ln-1])
stack = stack[:ln-1]
case ge:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] >= stack[ln-1])
stack = stack[:ln-1]
case eq:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] == stack[ln-1])
stack = stack[:ln-1]
case ne:
ln := len(stack)
stack[ln-2] = btoi(stack[ln-2] != stack[ln-1])
stack = stack[:ln-1]
case and:
ln := len(stack)
stack[ln-2] = btoi(itob(stack[ln-2]) && itob(stack[ln-1]))
stack = stack[:ln-1]
case or:
ln := len(stack)
stack[ln-2] = btoi(itob(stack[ln-2]) || itob(stack[ln-1]))
stack = stack[:ln-1]
case neg:
ln := len(stack)
stack[ln-1] = -stack[ln-1]
case not:
ln := len(stack)
stack[ln-1] = btoi(!itob(stack[ln-1]))
case jmp:
x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
pc += x
case jz:
ln := len(stack)
v := stack[ln-1]
stack = stack[:ln-1]
if v != 0 {
pc += 4
} else {
x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
pc += x
}
case prtc:
ln := len(stack)
fmt.Printf("%c", stack[ln-1])
stack = stack[:ln-1]
case prts:
ln := len(stack)
fmt.Printf("%s", stringPool[stack[ln-1]])
stack = stack[:ln-1]
case prti:
ln := len(stack)
fmt.Printf("%d", stack[ln-1])
stack = stack[:ln-1]
case halt:
return
default:
reportError(fmt.Sprintf("Unknown opcode %d\n", op))
}
}
}
func translate(s string) string {
var d strings.Builder
for i := 0; i < len(s); i++ {
if s[i] == '\\' && (i+1) < len(s) {
if s[i+1] == 'n' {
d.WriteByte('\n')
i++
} else if s[i+1] == '\\' {
d.WriteByte('\\')
i++
}
} else {
d.WriteByte(s[i])
}
}
return d.String()
}
func loadCode() int {
var dataSize int
firstLine := true
for scanner.Scan() {
line := strings.TrimRight(scanner.Text(), " \t")
if len(line) == 0 {
if firstLine {
reportError("empty line")
} else {
break
}
}
lineList := strings.Fields(line)
if firstLine {
dataSize, err = strconv.Atoi(lineList[1])
check(err)
nStrings, err := strconv.Atoi(lineList[3])
check(err)
for i := 0; i < nStrings; i++ {
scanner.Scan()
s := strings.Trim(scanner.Text(), "\"\n")
stringPool = append(stringPool, translate(s))
}
firstLine = false
continue
}
offset, err := strconv.Atoi(lineList[0])
check(err)
instr := lineList[1]
opCode, ok := codeMap[instr]
if !ok {
reportError(fmt.Sprintf("Unknown instruction %s at %d", instr, opCode))
}
emitByte(opCode)
switch opCode {
case jmp, jz:
p, err := strconv.Atoi(lineList[3])
check(err)
emitWord(p - offset - 1)
case push:
value, err := strconv.Atoi(lineList[2])
check(err)
emitWord(value)
case fetch, store:
value, err := strconv.Atoi(strings.Trim(lineList[2], "[]"))
check(err)
emitWord(value)
}
}
check(scanner.Err())
return dataSize
}
func main() {
codeGen, err := os.Open("codegen.txt")
check(err)
defer codeGen.Close()
scanner = bufio.NewScanner(codeGen)
runVM(loadCode())
}

375
Task/Compiler-virtual-machine-interpreter/Icon/compiler-virtual-machine-interpreter.icon Normal file
View file

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

76
Task/Compiler-virtual-machine-interpreter/J/compiler-virtual-machine-interpreter-1.j Normal file
View file

@ -0,0 +1,76 @@
(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
}}-.LF
unpack=: {{
lines=. <;._2 y
'ds0 ds s0 s'=.;:0{::lines
assert.'Datasize:Strings:'-:ds0,s0
vars=: (".ds)#0
strings=: rplc&('\\';'\';'\n';LF)L:0 '"'-.L:0~(1+i.".s){lines
object=: ;xlate L:1 (;:'()[]') -.~L:1 ;:L:0 '-_' rplc~L:0 (1+".s)}.lines
outbuf=: stack=: i.0
}}
xlate=: {{
if.2<#y do.
(opcodes i. 1{y),(4#256)#:".2{::y
else.
opcodes i. 1{y
end.
}}
NB. ensure we maintain 32 bit signed int representation
signadj=: _2147483648+4294967296|2147483648+]
getint=: signadj@(256 #. ])
PUSH=: {{ stack=:stack,signadj y }}
POP=: {{ (stack=: _1 }. stack) ] _1 { stack }}
POP2=: {{ (stack=: _2 }. stack) ] _2 {. stack }}
emit=:{{
outbuf=: outbuf,y
if.LF e. outbuf do.
ndx=. outbuf i:LF
echo ndx{.outbuf
outbuf=: }.ndx}.outbuf
end.
}}
run_vm=: {{
unpack y
stack=: i.pc=:0
lim=. <:#object
while.do.
pc=: pc+1 [ op=: (pc { object){opcodes
i=. getint (lim<.pc+i.4) { object
k=. 0
select.op
case.fetch do. k=.4 [PUSH i{vars
case.store do. k=.4 [vars=: (POP'') i} vars
case.push do. k=.4 [PUSH i
case.add do. PUSH +/POP2''
case.sub do. PUSH -/POP2''
case.mul do. PUSH */POP2''
case.div do. PUSH<.%/POP2''
case.mod do. PUSH |~/POP2''
case.lt do. PUSH </POP2''
case.le do. PUSH <:/POP2''
case.eq do. PUSH =/POP2''
case.ne do. PUSH ~:/POP2''
case.ge do. PUSH >:/POP2''
case.gt do. PUSH >/POP2''
case.and do. PUSH */0~:POP2''
case.or do. PUSH +./0~:POP2''
case.neg do. PUSH -POP''
case.not do. PUSH 0=POP''
case.jmp do. k=. i
case.jz do. k=. (0=POP''){4,i
case.prtc do. emit u:POP''
case.prts do. emit (POP''){::strings
case.prti do. emit rplc&'_-'":POP''
case.halt do. if.#outbuf do.echo outbuf end.EMPTY return.
end.
pc=: pc+k
end.
}}

18
Task/Compiler-virtual-machine-interpreter/J/compiler-virtual-machine-interpreter-2.j Normal file
View file

@ -0,0 +1,18 @@
count=:{{)n
count = 1;
while (count < 10) {
print("count is: ", count, "\n");
count = count + 1;
}
}}
run_vm gen syntax lex count
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

103
Task/Compiler-virtual-machine-interpreter/Julia/compiler-virtual-machine-interpreter.julia Normal file
View file

@ -0,0 +1,103 @@
mutable struct VM32
code::Vector{UInt8}
stack::Vector{Int32}
data::Vector{Int32}
strings::Vector{String}
offsets::Vector{Int32}
lastargs::Vector{Int32}
ip::Int32
VM32() = new(Vector{UInt8}(), Vector{Int32}(), Vector{Int32}(),
Vector{String}(), Vector{Int32}(), Vector{Int32}(), 1)
end
halt, add, sub, mul, Div, mod, not, neg, and, or, lt, gt, le, ge, ne, eq, prts,
prti, prtc, store, Fetch, push, jmp, jz = UInt8.(collect(1:24))
function assemble(io)
vm = VM32()
header = readline(io)
datasize, nstrings = match(r"\w+:\s*(\d+)\s+\w+:\s*(\d+)", header).captures
vm.data = zeros(Int32, parse(Int, datasize) + 4)
for i in 1:parse(Int, nstrings)
line = replace(strip(readline(io), ['"', '\n']), r"\\." => x -> x[end] == 'n' ? "\n" : string(x[end]))
push!(vm.strings, line)
end
while !eof(io)
line = readline(io)
offset, op, arg1, arg2 = match(r"(\d+)\s+(\w+)\s*(\S+)?\s*(\S+)?", line).captures
op = op in ["fetch", "div"] ? uppercasefirst(op) : op
push!(vm.code, eval(Symbol(op)))
if arg1 != nothing
v = parse(Int32, strip(arg1, ['[', ']', '(', ')']))
foreach(x -> push!(vm.code, x), reinterpret(UInt8, [v]))
end
if arg2 != nothing
push!(vm.lastargs, (x = tryparse(Int32, arg2)) == nothing ? 0 : x)
end
push!(vm.offsets, parse(Int32, offset))
end
vm
end
function runvm(vm)
value() = (x = vm.ip; vm.ip += 4; reinterpret(Int32, vm.code[x:x+3])[1])
tobool(x) = (x != 0)
ops = Dict(
halt => () -> exit(),
add => () -> begin vm.stack[end-1] += vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
sub => () -> begin vm.stack[end-1] -= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
mul => () -> begin vm.stack[end-1] *= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
Div => () -> begin vm.stack[end-1] /= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
mod => () -> begin vm.stack[end-1] %= vm.stack[1]; pop!(vm.stack); vm.stack[end] end,
not => () -> vm.stack[end] = vm.stack[end] ? 0 : 1,
neg => () -> vm.stack[end] = -vm.stack[end],
and => () -> begin vm.stack[end-1] = tobool(vm.stack[end-1]) && tobool(vm.stack[end]) ? 1 : 0; pop!(vm.stack); vm.stack[end] end,
or => () -> begin vm.stack[end-1] = tobool(vm.stack[end-1]) || tobool(vm.stack[end]) ? 1 : 0; pop!(vm.stack); vm.stack[end] end,
lt => () -> begin x = (vm.stack[end-1] < vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
gt => () -> begin x = (vm.stack[end-1] > vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
le => () -> begin x = (vm.stack[end-1] <= vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
ge => () -> begin x = (vm.stack[end-1] >= vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
ne => () -> begin x = (vm.stack[end-1] != vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
eq => () -> begin x = (vm.stack[end-1] == vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
prts => () -> print(vm.strings[pop!(vm.stack) + 1]),
prti => () -> print(pop!(vm.stack)),
prtc => () -> print(Char(pop!(vm.stack))),
store => () -> vm.data[value() + 1] = pop!(vm.stack),
Fetch => () -> push!(vm.stack, vm.data[value() + 1]),
push => () -> push!(vm.stack, value()),
jmp => () -> vm.ip += value(),
jz => () -> if pop!(vm.stack) == 0 vm.ip += value() else vm.ip += 4 end)
vm.ip = 1
while true
op = vm.code[vm.ip]
vm.ip += 1
ops[op]()
end
end
const testasm = """
Datasize: 1 Strings: 2
"count is: "
"\\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (43) 65
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-51) 10
65 halt """
const iob = IOBuffer(testasm)
const vm = assemble(iob)
runvm(vm)

172
Task/Compiler-virtual-machine-interpreter/M2000-Interpreter/compiler-virtual-machine-interpreter-1.m2000 Normal file
View file

@ -0,0 +1,172 @@
Module Virtual_Machine_Interpreter (a$){
\\ function to extract string, replacing escape codes.
Function GetString$(a$) {
s=instr(a$, chr$(34))
m=rinstr(a$,chr$(34))-s
if m>1 then
\\ process escape codes
=format$(mid$(a$, s+1, m-1))
else
=""
end if
}
\\ module to print a string to console using codes, 13, 10, 9
Module printsrv (a$) {
for i=1 to len(a$)
select case chrcode(Mid$(a$,i,1))
case 13
cursor 0
case 10
cursor 0 : Print
case 9
cursor ((pos+tab) div tab)*tab
else case
{
m=pos :if pos>=width then Print : m=pos
Print Mid$(a$,i,1);
if m<=width then cursor m+1
}
end select
next i
}
const nl$=chr$(13)+chr$(10)
\\ we can set starting value to any number n where 0<=n<=232
enum op { halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
jmp_, jz_
}
Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot examlpe
Report "Virtual Assembly Code:"+{
}+a$
Print "Prepare Byte Code"
\\ get datasize
a$=rightpart$(a$, "Datasize:")
m=0
data_size=val(a$, "int", m)
a$=mid$(a$, m)
\\ make stack
if data_size>0 then Buffer Clear stack_ as long*data_size
\\ dim or redim buffer append 1000 long as is.
Buffer stack_ as long*(1000+data_size)
\\ get strings
a$=rightpart$(a$, "Strings:")
m=0
strings=val(a$, "int", m)
a$=rightpart$(a$, nl$)
if strings>0 then
Dim strings$(strings)
for i=0 to strings-1
strings$(i)=GetString$(leftpart$(a$, nl$))
a$=rightpart$(a$, nl$)
Next i
End if
buffer clear code_ as byte*1000
do
m=0
offset=val(a$,"int", m)
if m<0 then exit
a$=mid$(a$,m)
line$=trim$(leftpart$(a$,nl$))
if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
if not valid(eval(op$+"_")) then exit
opc=eval(op$+"_")
Return code_, offset:=opc
if opc>=store_ then
line$=rightpart$(line$," ")
select case opc
case store_, fetch_
Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
case push_
Return code_, offset+1:=uint(val(line$)) as long : offset+=4
case jz_, jmp_
Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
end select
end if
Always
Print "Press any key" : Push key$ : Drop
\\ Prepare VM
let pc=0, sp=len(stack_) div 4
do {
func=eval(code_, pc)
pc++
select case func
case halt_
exit
case push_
sp--:return stack_, sp:=eval(code_, pc as long):pc+=4
case jz_
sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
case jmp_
pc=eval(code_, pc as long)
case fetch_
sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4
case store_
Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4
case add_
Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++
case sub_
Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++
case mul_
Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++
case div_
Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++
case mod_
Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod sint(eval(stack_, sp))) :sp++
case not_
Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)
case neg_ \\ we can use neg(sint(value))+1 or uint(-sint(value))
Return stack_, sp:=uint(-sint(eval(stack_, sp)))
case and_
Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++
case or_
Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++
case lt_
Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++
case gt_
Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++
case le_
Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++
case ge_
Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++
case ne_
Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++
case eq_
Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++
case prts_
printsrv strings$(eval(stack_,sp)):sp++
case prti_
printsrv str$(sint(eval(stack_,sp)),0):sp++
case prtc_
printsrv chrcode$(eval(stack_,sp)):sp++
else case
Error "Unkown op "+str$(func)
end select
} always
Print "done"
}
Virtual_Machine_Interpreter {
Datasize: 1 Strings: 2
"count is: "
"\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (43) 65
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-51) 10
65 halt
}

148
Task/Compiler-virtual-machine-interpreter/M2000-Interpreter/compiler-virtual-machine-interpreter-2.m2000 Normal file
View file

@ -0,0 +1,148 @@
Module Virtual_Machine_Interpreter (a$){
\\ function to extract string, replacing escape codes.
Function GetString$(a$) {
s=instr(a$, chr$(34))
m=rinstr(a$,chr$(34))-s
if m>1 then
\\ process escape codes
=format$(mid$(a$, s+1, m-1))
else
=""
end if
}
\\ module to print a string to console using codes, 13, 10, 9
Module printsrv (a$) {
for i=1 to len(a$)
select case chrcode(Mid$(a$,i,1))
case 13
cursor 0
case 10
cursor 0 : Print
case 9
cursor ((pos+tab) div tab)*tab
else case
{
m=pos :if pos>=width then Print : m=pos
Print Mid$(a$,i,1);
if m<=width then cursor m+1
}
end select
next i
}
const nl$=chr$(13)+chr$(10)
\\ we can set starting value to any number n where 0<=n<=232
enum op { halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
jmp_, jz_
}
exit_now=false
Inventory func=halt_:=lambda->{exit_now=true}
Append func, push_:=lambda->{sp--:return stack_, sp:=eval(code_, pc as long):pc+=4}
Append func, jz_:=lambda->{
sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
}
Append func, jmp_:=lambda->{pc=eval(code_, pc as long)}
Append func, fetch_:=lambda->{sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4}
Append func, store_:=lambda->{Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4}
Append func, add_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++}
Append func, sub_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++}
Append func, mul_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++}
Append func, div_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++}
Append func, mod_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod sint(eval(stack_, sp))) :sp++}
Append func, not_:=lambda->{Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)}
Append func, neg_:=lambda->{Return stack_, sp:=uint(-sint(eval(stack_, sp)))}
Append func, and_:=lambda->{Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++ }
Append func, or_:=lambda->{Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++ }
Append func, lt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++}
Append func, gt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++}
Append func, le_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++}
Append func, ge_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++}
Append func, ne_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++}
Append func, eq_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++}
Append func, prts_:=lambda->{printsrv strings$(eval(stack_,sp)):sp++}
Append func, prti_:=lambda->{printsrv str$(sint(eval(stack_,sp)),0):sp++}
Append func, prtc_:=lambda->{printsrv chrcode$(eval(stack_,sp)):sp++}
Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot examlpe
Report "Virtual Assembly Code:"+{
}+a$
Print "Prepare Byte Code"
\\ get datasize
a$=rightpart$(a$, "Datasize:")
m=0
data_size=val(a$, "int", m)
a$=mid$(a$, m)
\\ make stack
if data_size>0 then Buffer Clear stack_ as long*data_size
\\ dim or redim buffer append 1000 long as is.
Buffer stack_ as long*(1000+data_size)
\\ get strings
a$=rightpart$(a$, "Strings:")
m=0
strings=val(a$, "int", m)
a$=rightpart$(a$, nl$)
if strings>0 then
Dim strings$(strings)
for i=0 to strings-1
strings$(i)=GetString$(leftpart$(a$, nl$))
a$=rightpart$(a$, nl$)
Next i
End if
buffer clear code_ as byte*1000
do
m=0
offset=val(a$,"int", m)
if m<0 then exit
a$=mid$(a$,m)
line$=trim$(leftpart$(a$,nl$))
if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
if not valid(eval(op$+"_")) then exit
opc=eval(op$+"_")
Return code_, offset:=opc
if opc>=store_ then
line$=rightpart$(line$," ")
select case opc
case store_, fetch_
Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
case push_
Return code_, offset+1:=uint(val(line$)) as long : offset+=4
case jz_, jmp_
Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
end select
end if
Always
Print "Press any key" : Push key$ : Drop
\\ Prepare VM
let pc=0, sp=len(stack_) div 4
do
b=func(eval(code_, pc))
pc++
call local b()
until exit_now
Print "done"
}
Virtual_Machine_Interpreter {
Datasize: 1 Strings: 2
"count is: "
"\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (43) 65
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-51) 10
65 halt
}

892
Task/Compiler-virtual-machine-interpreter/Mercury/compiler-virtual-machine-interpreter.mercury Normal file
View file

@ -0,0 +1,892 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, in Mercury.
%%%
%%% (This particular machine is arbitrarily chosen to be big-endian.)
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module vm.
:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.
:- implementation.
:- import_module array.
:- import_module bool.
:- import_module char.
:- import_module exception.
:- import_module int.
:- import_module int32.
:- import_module list.
:- import_module string.
:- import_module uint.
:- import_module uint8.
:- import_module uint32.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% uint32 operations.
%%%
:- func twos_cmp(uint32) = uint32.
:- mode twos_cmp(in) = out is det.
:- pragma inline(twos_cmp/1).
twos_cmp(U) = NegU :-
(NegU = (\U) + 1_u32).
:- func unsigned_add(uint32, uint32) = uint32.
:- mode unsigned_add(in, in) = out is det.
:- pragma inline(unsigned_add/2).
unsigned_add(U, V) = U_plus_V :-
(U_plus_V = U + V).
:- func unsigned_sub(uint32, uint32) = uint32.
:- mode unsigned_sub(in, in) = out is det.
:- pragma inline(unsigned_sub/2).
unsigned_sub(U, V) = U_minus_V :-
(U_minus_V = U - V).
:- func signed_mul(uint32, uint32) = uint32.
:- mode signed_mul(in, in) = out is det.
:- pragma inline(signed_mul/2).
signed_mul(U, V) = UV :-
UV = cast_from_int32(cast_from_uint32(U) * cast_from_uint32(V)).
:- func signed_quot(uint32, uint32) = uint32.
:- mode signed_quot(in, in) = out is det.
:- pragma inline(signed_quot/2).
signed_quot(U, V) = U_quot_V :- % Truncation towards zero.
U_quot_V = cast_from_int32(cast_from_uint32(U)
// cast_from_uint32(V)).
:- func signed_rem(uint32, uint32) = uint32.
:- mode signed_rem(in, in) = out is det.
:- pragma inline(signed_rem/2).
signed_rem(U, V) = U_rem_V :- % Truncation towards zero, sign of U.
U_rem_V = cast_from_int32(cast_from_uint32(U)
rem cast_from_uint32(V)).
:- func signed_lt(uint32, uint32) = uint32.
:- mode signed_lt(in, in) = out is det.
:- pragma inline(signed_lt/2).
signed_lt(U, V) = U_lt_V :-
if (int32.cast_from_uint32(U) < int32.cast_from_uint32(V))
then (U_lt_V = 1_u32)
else (U_lt_V = 0_u32).
:- func signed_le(uint32, uint32) = uint32.
:- mode signed_le(in, in) = out is det.
:- pragma inline(signed_le/2).
signed_le(U, V) = U_le_V :-
if (int32.cast_from_uint32(U) =< int32.cast_from_uint32(V))
then (U_le_V = 1_u32)
else (U_le_V = 0_u32).
:- func signed_gt(uint32, uint32) = uint32.
:- mode signed_gt(in, in) = out is det.
:- pragma inline(signed_gt/2).
signed_gt(U, V) = U_gt_V :-
U_gt_V = signed_lt(V, U).
:- func signed_ge(uint32, uint32) = uint32.
:- mode signed_ge(in, in) = out is det.
:- pragma inline(signed_ge/2).
signed_ge(U, V) = U_ge_V :-
U_ge_V = signed_le(V, U).
:- func unsigned_eq(uint32, uint32) = uint32.
:- mode unsigned_eq(in, in) = out is det.
:- pragma inline(unsigned_eq/2).
unsigned_eq(U, V) = U_eq_V :-
if (U = V)
then (U_eq_V = 1_u32)
else (U_eq_V = 0_u32).
:- func unsigned_ne(uint32, uint32) = uint32.
:- mode unsigned_ne(in, in) = out is det.
:- pragma inline(unsigned_ne/2).
unsigned_ne(U, V) = U_ne_V :-
if (U \= V)
then (U_ne_V = 1_u32)
else (U_ne_V = 0_u32).
:- func logical_cmp(uint32) = uint32.
:- mode logical_cmp(in) = out is det.
:- pragma inline(logical_cmp/1).
logical_cmp(U) = NotU :-
if (U = 0_u32)
then (NotU = 1_u32)
else (NotU = 0_u32).
:- func logical_and(uint32, uint32) = uint32.
:- mode logical_and(in, in) = out is det.
:- pragma inline(logical_and/2).
logical_and(U, V) = U_and_V :-
if (U \= 0_u32, V \= 0_u32)
then (U_and_V = 1_u32)
else (U_and_V = 0_u32).
:- func logical_or(uint32, uint32) = uint32.
:- mode logical_or(in, in) = out is det.
:- pragma inline(logical_or/2).
logical_or(U, V) = U_or_V :-
if (U \= 0_u32; V \= 0_u32)
then (U_or_V = 1_u32)
else (U_or_V = 0_u32).
:- pred to_bytes(uint32, uint8, uint8, uint8, uint8).
:- mode to_bytes(in, out, out, out, out) is det.
:- pragma inline(to_bytes/5).
to_bytes(U, B3, B2, B1, B0) :-
(B0 = cast_from_int(cast_to_int(U /\ 0xFF_u32))),
(B1 = cast_from_int(cast_to_int((U >> 8) /\ 0xFF_u32))),
(B2 = cast_from_int(cast_to_int((U >> 16) /\ 0xFF_u32))),
(B3 = cast_from_int(cast_to_int((U >> 24) /\ 0xFF_u32))).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% String operations.
%%%
:- pred digit_u32(char, uint32).
:- mode digit_u32(in, out) is semidet.
digit_u32(('0'), 0_u32).
digit_u32(('1'), 1_u32).
digit_u32(('2'), 2_u32).
digit_u32(('3'), 3_u32).
digit_u32(('4'), 4_u32).
digit_u32(('5'), 5_u32).
digit_u32(('6'), 6_u32).
digit_u32(('7'), 7_u32).
digit_u32(('8'), 8_u32).
digit_u32(('9'), 9_u32).
:- pred is_not_digit(char).
:- mode is_not_digit(in) is semidet.
is_not_digit(C) :-
not is_digit(C).
:- pred is_not_alnum_nor_minus(char).
:- mode is_not_alnum_nor_minus(in) is semidet.
is_not_alnum_nor_minus(C) :-
not (is_alnum(C); C = ('-')).
:- pred det_string_to_uint32(string, uint32).
:- mode det_string_to_uint32(in, out) is det.
det_string_to_uint32(S, U) :-
to_char_list(S) = CL,
(if (det_string_to_uint32_loop(CL, 0_u32, U1))
then (U = U1)
else throw("cannot convert string to uint32")).
:- pred det_string_to_uint32_loop(list(char), uint32, uint32).
:- mode det_string_to_uint32_loop(in, in, out) is semidet.
det_string_to_uint32_loop([], U0, U1) :- U1 = U0.
det_string_to_uint32_loop([C | Tail], U0, U1) :-
digit_u32(C, Digit),
det_string_to_uint32_loop(Tail, (U0 * 10_u32) + Digit, U1).
:- pred det_signed_string_to_uint32(string, uint32).
:- mode det_signed_string_to_uint32(in, out) is det.
det_signed_string_to_uint32(S, U) :-
if prefix(S, "-")
then (det_remove_prefix("-", S, S1),
det_string_to_uint32(S1, U1),
U = twos_cmp(U1))
else det_string_to_uint32(S, U).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Parsing the "assembly" language.
%%%
:- func opcode_halt = uint8.
:- func opcode_add = uint8.
:- func opcode_sub = uint8.
:- func opcode_mul = uint8.
:- func opcode_div = uint8.
:- func opcode_mod = uint8.
:- func opcode_lt = uint8.
:- func opcode_gt = uint8.
:- func opcode_le = uint8.
:- func opcode_ge = uint8.
:- func opcode_eq = uint8.
:- func opcode_ne = uint8.
:- func opcode_and = uint8.
:- func opcode_or = uint8.
:- func opcode_neg = uint8.
:- func opcode_not = uint8.
:- func opcode_prtc = uint8.
:- func opcode_prti = uint8.
:- func opcode_prts = uint8.
:- func opcode_fetch = uint8.
:- func opcode_store = uint8.
:- func opcode_push = uint8.
:- func opcode_jmp = uint8.
:- func opcode_jz = uint8.
opcode_halt = 0_u8.
opcode_add = 1_u8.
opcode_sub = 2_u8.
opcode_mul = 3_u8.
opcode_div = 4_u8.
opcode_mod = 5_u8.
opcode_lt = 6_u8.
opcode_gt = 7_u8.
opcode_le = 8_u8.
opcode_ge = 9_u8.
opcode_eq = 10_u8.
opcode_ne = 11_u8.
opcode_and = 12_u8.
opcode_or = 13_u8.
opcode_neg = 14_u8.
opcode_not = 15_u8.
opcode_prtc = 16_u8.
opcode_prti = 17_u8.
opcode_prts = 18_u8.
opcode_fetch = 19_u8.
opcode_store = 20_u8.
opcode_push = 21_u8.
opcode_jmp = 22_u8.
opcode_jz = 23_u8.
:- pred opcode(string, uint8).
:- mode opcode(in, out) is semidet.
%:- mode opcode(out, in) is semidet. <-- Not needed.
opcode("halt", opcode_halt).
opcode("add", opcode_add).
opcode("sub", opcode_sub).
opcode("mul", opcode_mul).
opcode("div", opcode_div).
opcode("mod", opcode_mod).
opcode("lt", opcode_lt).
opcode("gt", opcode_gt).
opcode("le", opcode_le).
opcode("ge", opcode_ge).
opcode("eq", opcode_eq).
opcode("ne", opcode_ne).
opcode("and", opcode_and).
opcode("or", opcode_or).
opcode("neg", opcode_neg).
opcode("not", opcode_not).
opcode("prtc", opcode_prtc).
opcode("prti", opcode_prti).
opcode("prts", opcode_prts).
opcode("fetch", opcode_fetch).
opcode("store", opcode_store).
opcode("push", opcode_push).
opcode("jmp", opcode_jmp).
opcode("jz", opcode_jz).
:- pred parse_header(string, uint32, uint32).
:- mode parse_header(in, out, out) is det.
parse_header(S, Datasize, Strings_Count) :-
% Split S on any non-digit characters, leaving a list of the two
% runs of digits.
if (words_separator(is_not_digit, S) = [S_Datasize, S_Strings])
% Convert the runs of digits to uint32.
then (det_string_to_uint32(S_Datasize, Datasize),
det_string_to_uint32(S_Strings, Strings_Count))
else throw("cannot parse the header").
:- pred parse_string_literal(string, string).
:- mode parse_string_literal(in, out) is det.
parse_string_literal(S0, S) :-
% Strip leading/trailing space.
S1 = strip(S0),
% Remove the " characters.
det_remove_prefix("\"", S1, S2),
det_remove_suffix(S2, "\"") = S3,
% Deal with "\\" and "\n".
replace_escapes(S3, S).
:- pred replace_escapes(string, string).
:- mode replace_escapes(in, out) is det.
replace_escapes(S0, S) :-
CL0 = to_char_list(S0),
replace_escapes(CL0, [], CL),
S = from_rev_char_list(CL).
:- pred replace_escapes(list(char), list(char), list(char)).
:- mode replace_escapes(in, in, out) is det.
replace_escapes([], Dst0, Dst) :-
Dst = Dst0.
replace_escapes([C | Tail], Dst0, Dst) :-
if (C \= ('\\'))
then replace_escapes(Tail, [C | Dst0], Dst)
else (if (Tail = [C1 | Tail1])
then (if (C1 = ('n'))
then replace_escapes(Tail1, [('\n') | Dst0], Dst)
else if (C1 = ('\\'))
then replace_escapes(Tail1, [('\\') | Dst0], Dst)
else throw("illegal escape sequence"))
else throw("truncated escape sequence")).
:- pred parse_instruction(string, {uint32, uint8, uint32}).
:- mode parse_instruction(in, out) is det.
parse_instruction(S, {Address, Opcode, Arg}) :-
words_separator(is_not_alnum_nor_minus, S) = Lst,
(if parse_instr_lst(Lst, {Addr, Op, A})
then (Address = Addr, Opcode = Op, Arg = A)
else throw("cannot parse instruction")).
:- pred parse_instr_lst(list(string), {uint32, uint8, uint32}).
:- mode parse_instr_lst(in, out) is semidet.
parse_instr_lst([S_Address, S_Opcode],
{Address, Opcode, Arg}) :-
det_string_to_uint32(S_Address, Address),
opcode(S_Opcode, Opcode),
Arg = 0_u32.
parse_instr_lst([S_Address, S_Opcode, S_Arg | _],
{Address, Opcode, Arg}) :-
det_string_to_uint32(S_Address, Address),
opcode(S_Opcode, Opcode),
det_signed_string_to_uint32(S_Arg, Arg).
:- pred parse_assembly((io.text_input_stream), uint32, uint32,
array(string),
list({uint32, uint8, uint32}),
io, io).
:- mode parse_assembly(in, out, out, out, out, di, uo) is det.
parse_assembly(InpF, Datasize, Strings_Count, Strings,
Instructions, !IO) :-
read_line_as_string(InpF, Res, !IO),
(if (Res = ok(Line))
then (parse_header(Line, Datasize, Strings_Count),
read_and_parse_strings(InpF, Strings_Count, Strings, !IO),
read_and_parse_instructions(InpF, Instructions, !IO))
else if (Res = eof)
then throw("empty input")
else throw("read error")).
:- pred read_and_parse_strings((io.text_input_stream), uint32,
array(string), io, io).
:- mode read_and_parse_strings(in, in, out, di, uo) is det.
read_and_parse_strings(InpF, Strings_Count, Strings, !IO) :-
read_n_string_literals(InpF, Strings_Count, [], Lst, !IO),
Strings = array(Lst).
:- pred read_n_string_literals((io.text_input_stream), uint32,
list(string), list(string),
io, io).
:- mode read_n_string_literals(in, in, in, out, di, uo) is det.
read_n_string_literals(InpF, N, Lst0, Lst, !IO) :-
if (N = 0_u32)
then (Lst = reverse(Lst0))
else (read_line_as_string(InpF, Res, !IO),
(if (Res = ok(Line))
then (parse_string_literal(Line, S),
read_n_string_literals(InpF, N - 1_u32,
[S | Lst0], Lst, !IO))
else if (Res = eof)
then throw("premature end of input")
else throw("read error"))).
:- pred read_and_parse_instructions((io.text_input_stream),
list({uint32, uint8, uint32}),
io, io).
:- mode read_and_parse_instructions(in, out, di, uo) is det.
read_and_parse_instructions(InpF, Instructions, !IO) :-
read_all_instructions(InpF, [], Instructions, !IO).
:- pred read_all_instructions((io.text_input_stream),
list({uint32, uint8, uint32}),
list({uint32, uint8, uint32}),
io, io).
:- mode read_all_instructions(in, in, out, di, uo) is det.
read_all_instructions(InpF, Lst0, Lst, !IO) :-
read_line_as_string(InpF, Res, !IO),
(if (Res = eof)
then (Lst = Lst0) % There is no need to reverse the list.
else if (Res = ok(Line))
then (strip(Line) = S,
(if is_empty(S)
then read_all_instructions(InpF, Lst0, Lst, !IO)
else (parse_instruction(S, Instr),
read_all_instructions(InpF, [Instr | Lst0], Lst,
!IO))))
else throw("read error")).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Constructing the executable memory.
%%%
:- func greatest_address(list({uint32, uint8, uint32}),
uint32) = uint32.
:- mode greatest_address(in, in) = out is det.
greatest_address([], Min_Result) = Result :-
Result = Min_Result.
greatest_address([{Addr, _, _} | Tail], Min_Result) = Result :-
if (Min_Result < Addr)
then (Result = greatest_address(Tail, Addr))
else (Result = greatest_address(Tail, Min_Result)).
:- pred executable_memory(list({uint32, uint8, uint32}),
array(uint8)).
:- mode executable_memory(in, out) is det.
executable_memory(Instructions, Code) :-
greatest_address(Instructions, 0_u32) = Addr,
Code_Size = (Addr + 5_u32), % At least enough memory.
init(cast_to_int(Code_Size), opcode_halt, Code0),
fill_executable_memory(Instructions, Code0, Code).
:- pred fill_executable_memory(list({uint32, uint8, uint32}),
array(uint8), array(uint8)).
:- mode fill_executable_memory(in, array_di, array_uo) is det.
fill_executable_memory([], !Code) :- true.
fill_executable_memory([Instr | Tail], !Code) :-
Instr = {Address, Opcode, Arg},
Addr = cast_to_int(Address),
set(Addr, Opcode, !Code),
(if (Opcode = opcode_fetch;
Opcode = opcode_store;
Opcode = opcode_push;
Opcode = opcode_jmp;
Opcode = opcode_jz)
then (to_bytes(Arg, B3, B2, B1, B0),
% Store the argument in big-endian order.
set(Addr + 1, B3, !Code),
set(Addr + 2, B2, !Code),
set(Addr + 3, B1, !Code),
set(Addr + 4, B0, !Code))
else true),
fill_executable_memory(Tail, !Code).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%e
%%%
%%% Executing the code.
%%%
:- pred machine_add(array(uint32), array(uint32), uint32, uint32).
:- mode machine_add(array_di, array_uo, in, out) is det.
:- pragma inline(machine_add/4).
machine_add(Stack0, Stack, SP0, SP) :-
Result = unsigned_add(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_sub(array(uint32), array(uint32), uint32, uint32).
:- mode machine_sub(array_di, array_uo, in, out) is det.
:- pragma inline(machine_sub/4).
machine_sub(Stack0, Stack, SP0, SP) :-
Result = unsigned_sub(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_mul(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mul(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mul/4).
machine_mul(Stack0, Stack, SP0, SP) :-
Result = signed_mul(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_div(array(uint32), array(uint32), uint32, uint32).
:- mode machine_div(array_di, array_uo, in, out) is det.
:- pragma inline(machine_div/4).
machine_div(Stack0, Stack, SP0, SP) :-
Result = signed_quot(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_mod(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mod(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mod/4).
machine_mod(Stack0, Stack, SP0, SP) :-
Result = signed_rem(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_lt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_lt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_lt/4).
machine_lt(Stack0, Stack, SP0, SP) :-
Result = signed_lt(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_le(array(uint32), array(uint32), uint32, uint32).
:- mode machine_le(array_di, array_uo, in, out) is det.
:- pragma inline(machine_le/4).
machine_le(Stack0, Stack, SP0, SP) :-
Result = signed_le(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_gt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_gt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_gt/4).
machine_gt(Stack0, Stack, SP0, SP) :-
Result = signed_gt(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_ge(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ge(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ge/4).
machine_ge(Stack0, Stack, SP0, SP) :-
Result = signed_ge(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_eq(array(uint32), array(uint32), uint32, uint32).
:- mode machine_eq(array_di, array_uo, in, out) is det.
:- pragma inline(machine_eq/4).
machine_eq(Stack0, Stack, SP0, SP) :-
Result = unsigned_eq(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_ne(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ne(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ne/4).
machine_ne(Stack0, Stack, SP0, SP) :-
Result = unsigned_ne(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_and(array(uint32), array(uint32), uint32, uint32).
:- mode machine_and(array_di, array_uo, in, out) is det.
:- pragma inline(machine_and/4).
machine_and(Stack0, Stack, SP0, SP) :-
Result = logical_and(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_or(array(uint32), array(uint32), uint32, uint32).
:- mode machine_or(array_di, array_uo, in, out) is det.
:- pragma inline(machine_or/4).
machine_or(Stack0, Stack, SP0, SP) :-
Result = logical_or(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
:- pred machine_neg(array(uint32), array(uint32), uint32, uint32).
:- mode machine_neg(array_di, array_uo, in, out) is det.
:- pragma inline(machine_neg/4).
machine_neg(Stack0, Stack, SP0, SP) :-
SP = SP0,
(I = uint32.cast_to_int(SP0)),
Result = twos_cmp(lookup(Stack0, I - 1)),
set(I - 1, Result, Stack0, Stack).
:- pred machine_not(array(uint32), array(uint32), uint32, uint32).
:- mode machine_not(array_di, array_uo, in, out) is det.
:- pragma inline(machine_not/4).
machine_not(Stack0, Stack, SP0, SP) :-
SP = SP0,
(I = uint32.cast_to_int(SP0)),
Result = logical_cmp(lookup(Stack0, I - 1)),
set(I - 1, Result, Stack0, Stack).
:- pred machine_prtc((io.text_output_stream),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prtc(in, array_di, array_uo, in, out,
di, uo) is det.
machine_prtc(OutF, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
X = lookup(Stack0, I - 1),
C = (char.det_from_int(uint32.cast_to_int(X))),
(io.write_char(OutF, C, !IO)),
SP = SP0 - 1_u32.
:- pred machine_prti((io.text_output_stream),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prti(in, array_di, array_uo, in, out,
di, uo) is det.
machine_prti(OutF, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
(X = int32.cast_from_uint32(lookup(Stack0, I - 1))),
(io.write_int32(OutF, X, !IO)),
SP = SP0 - 1_u32.
:- pred machine_prts((io.text_output_stream),
array(string),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prts(in, in, array_di, array_uo, in, out,
di, uo) is det.
machine_prts(OutF, Strings, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
(K = uint32.cast_to_int(lookup(Stack0, I - 1))),
S = lookup(Strings, K),
(io.write_string(OutF, S, !IO)),
SP = SP0 - 1_u32.
:- func get_immediate(array(uint8), uint32) = uint32.
:- mode get_immediate(in, in) = out is det.
:- pragma inline(get_immediate/2).
get_immediate(Code, IP) = Immediate_Value :-
% Big-endian order.
I = cast_to_int(IP),
B3 = lookup(Code, I),
B2 = lookup(Code, I + 1),
B1 = lookup(Code, I + 2),
B0 = lookup(Code, I + 3),
Immediate_Value = from_bytes_be(B3, B2, B1, B0).
:- pred machine_fetch(array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_fetch(array_di, array_uo, in, in, out,
array_di, array_uo, in, out) is det.
:- pragma inline(machine_fetch/9).
machine_fetch(Data0, Data, Code, IP0, IP, !Stack, SP0, SP) :-
Data = Data0,
K = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
X = lookup(Data0, cast_to_int(K)),
set(cast_to_int(SP0), X, !Stack),
SP = SP0 + 1_u32.
:- pred machine_store(array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_store(array_di, array_uo, in, in, out,
array_di, array_uo, in, out) is det.
:- pragma inline(machine_store/9).
machine_store(!Data, Code, IP0, IP, Stack0, Stack, SP0, SP) :-
Stack = Stack0,
K = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
SP = SP0 - 1_u32,
X = lookup(Stack0, cast_to_int(SP)),
set(cast_to_int(K), X, !Data).
:- pred machine_push(array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_push(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_push/7).
machine_push(Code, IP0, IP, !Stack, SP0, SP) :-
X = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
set(cast_to_int(SP0), X, !Stack),
SP = SP0 + 1_u32.
:- pred machine_jmp(array(uint8), uint32, uint32).
:- mode machine_jmp(in, in, out) is det.
:- pragma inline(machine_jmp/3).
machine_jmp(Code, IP0, IP) :-
Offset = get_immediate(Code, IP0),
IP = unsigned_add(IP0, Offset).
:- pred machine_jz(array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_jz(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_jz/7).
machine_jz(Code, IP0, IP, Stack0, Stack, SP0, SP) :-
Stack = Stack0,
SP = SP0 - 1_u32,
X = lookup(Stack0, cast_to_int(SP)),
(if (X = 0_u32)
then (Offset = get_immediate(Code, IP0),
IP = unsigned_add(IP0, Offset))
else (IP = IP0 + 4_u32)).
:- pred run_one_instruction((io.text_output_stream),
array(string),
array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32, bool, io, io).
:- mode run_one_instruction(in, in, array_di, array_uo,
in, in, out, array_di, array_uo,
in, out, out, di, uo) is det.
run_one_instruction(OutF, Strings, !Data,
Code, IP0, IP, !Stack, !SP,
Halt, !IO) :-
%
% In the following implementation, any unrecognized instruction
% causes a HALT, just as an actual "halt" opcode would.
%
Opcode = lookup(Code, cast_to_int(IP0)),
IP1 = IP0 + 1_u32,
I = (Opcode >> 2),
J = (Opcode /\ 0x03_u8),
(if (I = 0_u8)
then (IP = IP1,
(if (J = 0_u8)
then (Halt = yes)
else if (J = 1_u8)
then (machine_add(!Stack, !SP),
Halt = no)
else if (J = 2_u8)
then (machine_sub(!Stack, !SP),
Halt = no)
else (machine_mul(!Stack, !SP),
Halt = no)))
else if (I = 1_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_div(!Stack, !SP)
else if (J = 1_u8)
then machine_mod(!Stack, !SP)
else if (J = 2_u8)
then machine_lt(!Stack, !SP)
else machine_gt(!Stack, !SP)))
else if (I = 2_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_le(!Stack, !SP)
else if (J = 1_u8)
then machine_ge(!Stack, !SP)
else if (J = 2_u8)
then machine_eq(!Stack, !SP)
else machine_ne(!Stack, !SP)))
else if (I = 3_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_and(!Stack, !SP)
else if (J = 1_u8)
then machine_or(!Stack, !SP)
else if (J = 2_u8)
then machine_neg(!Stack, !SP)
else machine_not(!Stack, !SP)))
else if (I = 4_u8)
then (Halt = no,
(if (J = 0_u8)
then (machine_prtc(OutF, !Stack, !SP, !IO),
IP = IP1)
else if (J = 1_u8)
then (machine_prti(OutF, !Stack, !SP, !IO),
IP = IP1)
else if (J = 2_u8)
then (machine_prts(OutF, Strings, !Stack, !SP, !IO),
IP = IP1)
else machine_fetch(!Data, Code, IP1, IP, !Stack, !SP)))
else if (I = 5_u8)
then (Halt = no,
(if (J = 0_u8)
then machine_store(!Data, Code, IP1, IP, !Stack, !SP)
else if (J = 1_u8)
then machine_push(Code, IP1, IP, !Stack, !SP)
else if (J = 2_u8)
then machine_jmp(Code, IP1, IP)
else machine_jz(Code, IP1, IP, !Stack, !SP)))
else (Halt = yes, IP = IP1)).
:- pred run_program((io.text_output_stream), array(string),
array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode run_program(in, in, array_di, array_uo,
in, in, out, array_di, array_uo,
in, out, di, uo) is det.
run_program(OutF, Strings, !Data, Code, !IP, !Stack, !SP, !IO) :-
run_one_instruction(OutF, Strings, !Data, Code, !IP, !Stack, !SP,
Halt, !IO),
(if (Halt = yes)
then true
else run_program(OutF, Strings, !Data, Code, !IP, !Stack,
!SP, !IO)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- pred open_InpF(text_input_stream, string, io, io).
:- mode open_InpF(out, in, di, uo) is det.
open_InpF(InpF, InpF_filename, !IO) :-
if (InpF_filename = "-")
then (InpF = io.stdin_stream)
else (open_input(InpF_filename, InpF_result, !IO),
(if (InpF_result = ok(F))
then (InpF = F)
else throw("Error: cannot open " ++ InpF_filename ++
" for input"))).
:- pred open_OutF(text_output_stream, string, io, io).
:- mode open_OutF(out, in, di, uo) is det.
open_OutF(OutF, OutF_filename, !IO) :-
if (OutF_filename = "-")
then (OutF = io.stdout_stream)
else (open_output(OutF_filename, OutF_result, !IO),
(if (OutF_result = ok(F))
then (OutF = F)
else throw("Error: cannot open " ++ OutF_filename ++
" for output"))).
:- pred main_program(string, string, io, io).
:- mode main_program(in, in, di, uo) is det.
main_program(InpF_filename, OutF_filename, !IO) :-
open_InpF(InpF, InpF_filename, !IO),
open_OutF(OutF, OutF_filename, !IO),
parse_assembly(InpF, Datasize, _Strings_Count, Strings,
Instructions, !IO),
(if (InpF_filename = "-")
then true
else close_input(InpF, !IO)),
executable_memory(Instructions, Code),
init(cast_to_int(Datasize), 0_u32, Data0),
init(2048, 0_u32, Stack0), % Stack is 2048 words.
IP0 = 0_u32,
SP0 = 0_u32,
run_program(OutF, Strings, Data0, _Data, Code, IP0, _IP,
Stack0, _Stack, SP0, _SP, !IO),
(if (OutF_filename = "-")
then true
else close_output(OutF, !IO)).
:- pred usage_error(io, io).
:- mode usage_error(di, uo) is det.
usage_error(!IO) :-
progname("lex", ProgName, !IO),
(io.format("Usage: %s [INPUT_FILE [OUTPUT_FILE]]\n",
[s(ProgName)], !IO)),
(io.write_string(
"If INPUT_FILE is \"-\" or not present then standard input is used.\n",
!IO)),
(io.write_string(
"If OUTPUT_FILE is \"-\" or not present then standard output is used.\n",
!IO)),
set_exit_status(1, !IO).
main(!IO) :-
command_line_arguments(Args, !IO),
(if (Args = [])
then (InpF_filename = "-",
OutF_filename = "-",
main_program(InpF_filename, OutF_filename, !IO))
else if (Args = [F1])
then (InpF_filename = F1,
OutF_filename = "-",
main_program(InpF_filename, OutF_filename, !IO))
else if (Args = [F1, F2])
then (InpF_filename = F1,
OutF_filename = F2,
main_program(InpF_filename, OutF_filename, !IO))
else usage_error(!IO)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

321
Task/Compiler-virtual-machine-interpreter/Nim/compiler-virtual-machine-interpreter.nim Normal file
View file

@ -0,0 +1,321 @@
import os, parseutils, strutils, strscans, strformat
type
Value = int32
BytesValue = array[4, byte]
Address = int32
OpCode = enum
opFetch = "fetch"
opStore = "store"
opPush = "push"
opJmp = "jmp"
opJz = "jz"
opAdd = "add"
opSub = "sub"
opMul = "mul"
opDiv = "div"
opMod = "mod"
opLt = "lt"
opgt = "gt"
opLe = "le"
opGe = "ge"
opEq = "eq"
opNe = "ne"
opAnd = "and"
opOr = "or"
opNeg = "neg"
opNot = "not"
opPrtc = "prtc"
opPrti = "prti"
opPrts = "prts"
opHalt = "halt"
opInvalid = "invalid"
# Virtual machine description.
VM = object
stack: seq[Value] # Evaluation stack.
memory: seq[byte] # Memory to store program.
data: seq[Value] # Data storage.
strings: seq[string] # String storage.
pc: Address # Program counter.
# Exceptions.
LoadingError = object of CatchableError
RuntimeError = object of CatchableError
####################################################################################################
# Running program.
proc checkStackLength(vm: VM; minLength: int) {.inline.} =
## Check that evaluation stack contains at least "minLength" elements.
if vm.stack.len < minLength:
raise newException(RuntimeError, &"not enough operands on the stack (pc = {vm.pc}).")
#---------------------------------------------------------------------------------------------------
proc getOperand(vm: var VM): Value =
## Get a 32 bits operand.
type Union {.union.} = object
value: Value
bytes: BytesValue
if vm.pc + 4 >= vm.memory.len:
raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")
var aux: Union
let address = vm.pc + 1
for idx in 0..3:
aux.bytes[idx] = vm.memory[address + idx]
result = aux.value
#---------------------------------------------------------------------------------------------------
proc run(vm: var VM) =
## Run a program loaded in VM memory.
vm.pc = 0
while true:
if vm.pc notin 0..vm.memory.high:
raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")
let opcode = OpCode(vm.memory[vm.pc])
case opcode
of opFetch, opStore:
let index = vm.getOperand()
if index notin 0..vm.data.high:
raise newException(RuntimeError, &"wrong memory index (pc = {vm.pc}).")
if opcode == opFetch:
vm.stack.add(vm.data[index])
else:
vm.checkStackLength(1)
vm.data[index] = vm.stack.pop()
inc vm.pc, 4
of opPush:
let value = vm.getOperand()
vm.stack.add(value)
inc vm.pc, 4
of opJmp:
let offset = vm.getOperand()
inc vm.pc, offset
of opJz:
let offset = vm.getOperand()
vm.checkStackLength(1)
let value = vm.stack.pop()
inc vm.pc, if value == 0: offset else: 4
of opAdd..opOr:
# Two operands instructions.
vm.checkStackLength(2)
let op2 = vm.stack.pop()
let op1 = vm.stack.pop()
case range[opAdd..opOr](opcode)
of opAdd:
vm.stack.add(op1 + op2)
of opSub:
vm.stack.add(op1 - op2)
of opMul:
vm.stack.add(op1 * op2)
of opDiv:
vm.stack.add(op1 div op2)
of opMod:
vm.stack.add(op1 mod op2)
of opLt:
vm.stack.add(Value(op1 < op2))
of opgt:
vm.stack.add(Value(op1 > op2))
of opLe:
vm.stack.add(Value(op1 <= op2))
of opGe:
vm.stack.add(Value(op1 >= op2))
of opEq:
vm.stack.add(Value(op1 == op2))
of opNe:
vm.stack.add(Value(op1 != op2))
of opAnd:
vm.stack.add(op1 and op2)
of opOr:
vm.stack.add(op1 or op2)
of opNeg..opPrts:
# One operand instructions.
vm.checkStackLength(1)
let op = vm.stack.pop()
case range[opNeg..opPrts](opcode)
of opNeg:
vm.stack.add(-op)
of opNot:
vm.stack.add(not op)
of opPrtc:
stdout.write(chr(op))
of opPrti:
stdout.write(op)
of opPrts:
if op notin 0..vm.strings.high:
raise newException(RuntimeError, &"wrong string index (pc = {vm.pc}).")
stdout.write(vm.strings[op])
of opHalt:
break
of opInvalid:
discard # Not possible.
inc vm.pc
####################################################################################################
# Loading assembly file.
proc parseHeader(line: string): tuple[dataSize, stringCount: int] =
## Parse the header.
if not line.scanf("Datasize: $s$i $sStrings: $i", result.dataSize, result.stringCount):
raise newException(LoadingError, "Wrong header in code.")
#---------------------------------------------------------------------------------------------------
import re
proc parseString(line: string; linenum: int): string =
## Parse a string.
if not line.startsWith('"'):
raise newException(LoadingError, "Line $1: incorrect string.".format(linenum))
# Can't use "unescape" as it is confused by "\\n" and "\n".
result = line.replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")
#---------------------------------------------------------------------------------------------------
proc parseValue(line: string; linenum: int; pos: var int; msg: string): int32 =
## Parse an int32 value.
var value: int
pos += line.skipWhitespace(pos)
let parsed = line.parseInt(value, pos)
if parsed == 0:
raise newException(LoadingError, "Line $1: ".format(linenum) & msg)
pos += parsed
result = int32(value)
#---------------------------------------------------------------------------------------------------
proc parseOpcode(line: string; linenum: int; pos: var int): OpCode =
## Parse an opcode.
var opstring: string
pos += line.skipWhitespace(pos)
let parsed = line.parseIdent(opstring, pos)
if parsed == 0:
raise newException(LoadingError, "Line $1: opcode expected".format(linenum))
pos += parsed
result = parseEnum[OpCode](opstring, opInvalid)
if result == opInvalid:
raise newException(LoadingError, "Line $1: invalid opcode encountered".format(linenum))
#---------------------------------------------------------------------------------------------------
proc parseMemoryIndex(line: string; linenum: int; pos: var int): int32 =
## Parse a memory index (int32 value between brackets).
var memIndex: int
pos += line.skipWhitespace(pos)
let str = line.captureBetween('[', ']', pos)
if str.parseInt(memIndex) == 0 or memIndex < 0:
raise newException(LoadingError, "Line $1: invalid memory index".format(lineNum))
pos += str.len + 2
result = int32(memIndex)
#---------------------------------------------------------------------------------------------------
proc parseOffset(line: string; linenum: int; pos: var int): int32 =
## Parse an offset (int32 value between parentheses).
var offset: int
pos += line.skipWhitespace(pos)
let str = line.captureBetween('(', ')', pos)
if str.parseInt(offset) == 0:
raise newException(LoadingError, "Line $1: invalid offset".format(linenum))
pos += str.len + 2
result = int32(offset)
#---------------------------------------------------------------------------------------------------
proc load(vm: var VM; code: string) =
## Load an assembly code into VM memory.
# Analyze header.
let lines = code.splitlines()
let (dataSize, stringCount) = parseHeader(lines[0])
vm.data.setLen(dataSize)
vm.strings.setLen(stringCount)
# Load strings.
for idx in 1..stringCount:
vm.strings[idx - 1] = lines[idx].parseString(idx + 1)
# Load code.
var pc: Address = 0
for idx in (stringCount + 1)..lines.high:
var pos = 0
let line = lines[idx]
if line.len == 0: continue
# Process address.
let address = line.parseValue(idx + 1, pos, "address expected")
if address != pc:
raise newException(LoadingError, "Line $1: wrong address".format(idx + 1))
# Process opcode.
let opcode = line.parseOpcode(idx + 1, pos)
vm.memory.add(byte(opcode))
# Process operand.
case opcode
of opFetch, opStore:
# Find memory index.
let memIndex = line.parseMemoryIndex(idx + 1, pos)
vm.memory.add(cast[BytesValue](Value(memIndex)))
inc pc, 5
of opJmp, opJz:
# Find offset.
let offset = line.parseOffset(idx + 1, pos)
vm.memory.add(cast[BytesValue](Value(offset)))
# Find and check branch address.
let branchAddress = line.parseValue(idx + 1, pos, "branch address expected")
if branchAddress != pc + offset + 1:
raise newException(LoadingError, "Line $1: wrong branch address".format(idx + 1))
inc pc, 5
of opPush:
# Find value.
let value = line.parseValue(idx + 1, pos, "value expected")
vm.memory.add(cast[BytesValue](Value(value)))
inc pc, 5
else:
inc pc
#———————————————————————————————————————————————————————————————————————————————————————————————————
let code = if paramCount() == 0: stdin.readAll() else: paramStr(1).readFile()
var vm: VM
vm.load(code)
vm.run()

408
Task/Compiler-virtual-machine-interpreter/ObjectIcon/compiler-virtual-machine-interpreter.oi Normal file
View file

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

50
Task/Compiler-virtual-machine-interpreter/Perl/compiler-virtual-machine-interpreter.pl Normal file
View file

@ -0,0 +1,50 @@
#!/usr/bin/perl
# http://www.rosettacode.org/wiki/Compiler/virtual_machine_interpreter
use strict; # vm.pl - run rosetta code
use warnings;
use integer;
my ($binary, $pc, @stack, @data) = ('', 0);
<> =~ /Strings: (\d+)/ or die "bad header";
my @strings = map <> =~ tr/\n""//dr =~ s/\\(.)/$1 eq 'n' ? "\n" : $1/ger, 1..$1;
sub value { unpack 'l', substr $binary, ($pc += 4) - 4, 4 }
my @ops = (
[ halt => sub { exit } ],
[ add => sub { $stack[-2] += pop @stack } ],
[ sub => sub { $stack[-2] -= pop @stack } ],
[ mul => sub { $stack[-2] *= pop @stack } ],
[ div => sub { $stack[-2] /= pop @stack } ],
[ mod => sub { $stack[-2] %= pop @stack } ],
[ not => sub { $stack[-1] = $stack[-1] ? 0 : 1 } ],
[ neg => sub { $stack[-1] = - $stack[-1] } ],
[ and => sub { $stack[-2] &&= $stack[-1]; pop @stack } ],
[ or => sub { $stack[-2] ||= $stack[-1]; pop @stack } ],
[ lt => sub { $stack[-1] = $stack[-2] < pop @stack ? 1 : 0 } ],
[ gt => sub { $stack[-1] = $stack[-2] > pop @stack ? 1 : 0 } ],
[ le => sub { $stack[-1] = $stack[-2] <= pop @stack ? 1 : 0 } ],
[ ge => sub { $stack[-1] = $stack[-2] >= pop @stack ? 1 : 0 } ],
[ ne => sub { $stack[-1] = $stack[-2] != pop @stack ? 1 : 0 } ],
[ eq => sub { $stack[-1] = $stack[-2] == pop @stack ? 1 : 0 } ],
[ prts => sub { print $strings[pop @stack] } ],
[ prti => sub { print pop @stack } ],
[ prtc => sub { print chr pop @stack } ],
[ store => sub { $data[value()] = pop @stack } ],
[ fetch => sub { push @stack, $data[value()] // 0 } ],
[ push => sub { push @stack, value() } ],
[ jmp => sub { $pc += value() - 4 } ],
[ jz => sub { $pc += pop @stack ? 4 : value() - 4 } ],
);
my %op2n = map { $ops[$_][0], $_ } 0..$#ops; # map name to op number
while(<>)
{
/^ *\d+ +(\w+)/ or die "bad line $_"; # format error
$binary .= chr( $op2n{$1} // die "$1 not defined" ) . # op code
(/\((-?\d+)\)|(\d+)]?$/ and pack 'l', $+); # 4 byte value
}
$ops[vec($binary, $pc++, 8)][1]->() while 1; # run it

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

@ -0,0 +1,41 @@
(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>
<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>
<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>
<!--

367
Task/Compiler-virtual-machine-interpreter/Phix/compiler-virtual-machine-interpreter-2.phix Normal file
View file

@ -0,0 +1,367 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, for GNU Prolog.
%%%
%%% The following code uses GNU Prolog's extensions for global
%%% variables.
%%%
%%% Usage: vm [INPUTFILE [OUTPUTFILE]]
%%% The notation "-" means to use standard input or standard output.
%%% Leaving out an argument is equivalent to specifying "-".
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
make_and_run_machine(Input, Output) :-
make_machine(Input),
run_machine(Output).
run_machine(Output) :-
repeat,
next_instruction(Opcode, Arg),
(Opcode == ('halt')
-> true
; (run_instruction(Output, Opcode, Arg),
fail % Backtracks to the 'repeat'.
)).
run_instruction(Output, Opcode, Arg) :-
(
(Opcode == ('add'),
pop_value(Y),
pop_value(X),
is(Z, X + Y),
push_value(Z))
; (Opcode == ('sub'),
pop_value(Y),
pop_value(X),
is(Z, X - Y),
push_value(Z))
; (Opcode == ('mul'),
pop_value(Y),
pop_value(X),
is(Z, X * Y),
push_value(Z))
; (Opcode == ('div'),
pop_value(Y),
pop_value(X),
is(Z, X // Y),
push_value(Z))
; (Opcode == ('mod'),
pop_value(Y),
pop_value(X),
is(Z, X rem Y),
push_value(Z))
; (Opcode == ('lt'),
pop_value(Y),
pop_value(X),
(X < Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('le'),
pop_value(Y),
pop_value(X),
(X =< Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('gt'),
pop_value(Y),
pop_value(X),
(X > Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('ge'),
pop_value(Y),
pop_value(X),
(X >= Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('eq'),
pop_value(Y),
pop_value(X),
(X =:= Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('ne'),
pop_value(Y),
pop_value(X),
(X =\= Y -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('and'),
pop_value(Y),
pop_value(X),
((X =\= 0, Y =\= 0) -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('or'),
pop_value(Y),
pop_value(X),
((X =\= 0; Y =\= 0) -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('neg'),
pop_value(X),
is(Z, -X),
push_value(Z))
; (Opcode == ('not'),
pop_value(X),
(X =:= 0 -> Z = 1; Z = 0),
push_value(Z))
; (Opcode == ('prtc'),
pop_value(X),
char_code(C, X),
write(Output, C))
; (Opcode == ('prti'),
pop_value(X),
write(Output, X))
; (Opcode == ('prts'),
pop_value(K),
g_read(the_strings(K), S),
write(Output, S))
; (Opcode == ('fetch'),
g_read(the_data(Arg), X),
push_value(X),
skip_argument)
; (Opcode == ('store'),
pop_value(X),
g_assign(the_data(Arg), X),
skip_argument)
; (Opcode == ('push'),
push_value(Arg),
skip_argument)
; (Opcode == ('jmp'),
relative_jump(Arg))
; (Opcode == ('jz'),
pop_value(X),
(X =:= 0
-> relative_jump(Arg)
; skip_argument))
).
relative_jump(Offset) :-
g_read(the_program_counter, PC),
is(PC1, PC + Offset),
g_assign(the_program_counter, PC1).
skip_argument :-
g_read(the_program_counter, PC),
is(PC1, PC + 4),
g_assign(the_program_counter, PC1).
next_instruction(Opcode, Arg) :-
g_read(the_program_counter, PC),
is(PC1, PC + 1),
g_assign(the_program_counter, PC1),
g_read(the_code(PC), {Opcode, Arg}).
push_value(X) :-
g_read(the_stack_pointer, SP),
is(SP1, SP + 1),
g_assign(the_stack_pointer, SP1),
g_assign(the_stack(SP), X).
pop_value(X) :-
g_read(the_stack_pointer, SP),
is(SP1, SP - 1),
g_assign(the_stack_pointer, SP1),
g_read(the_stack(SP1), X).
make_machine(Input) :-
get_and_parse_the_header(Input, Datasize, Strings_Count),
(Strings_Count =:= 0
-> true
; get_and_parse_the_strings(Input, Strings_Count)),
get_and_parse_the_instructions(Input),
(Datasize =:= 0
-> true
; g_assign(the_data, g_array(Datasize))),
g_assign(the_stack, g_array(2048)),
g_assign(the_stack_pointer, 0),
g_assign(the_program_counter, 0).
get_and_parse_the_header(Stream, Datasize, Strings_Count) :-
get_line(Stream, Line, ('\n')),
parse_header(Line, Datasize, Strings_Count).
get_and_parse_the_strings(Stream, Strings_Count) :-
% Make 'the_strings' an array of the string literals.
get_and_parse_the_strings(Stream, Strings_Count, Lst),
g_assign(the_strings, g_array(Lst)).
get_and_parse_the_strings(Stream, I, Lst) :-
% Note: this implementation is non-tail recursive.
(I == 0
-> Lst = []
; (get_line(Stream, Line, ('\n')),
parse_string_literal(Line, S),
is(I1, I - 1),
get_and_parse_the_strings(Stream, I1, Lst1),
Lst = [S | Lst1])).
get_and_parse_the_instructions(Stream) :-
get_and_parse_the_instructions(Stream, Lst),
keysort(Lst, Lst1),
last(Lst1, Addr_Max-_),
is(Code_Size, Addr_Max + 5),
g_assign(the_code, g_array(Code_Size, {('halt'), 0})),
maplist(fill_instruction, Lst1).
get_and_parse_the_instructions(Stream, Lst) :-
get_and_parse_the_instructions(Stream, [], Lst).
get_and_parse_the_instructions(Stream, Lst0, Lst) :-
% This implementation is tail recursive. We consider the order of
% the resulting list to be arbitrary.
(get_line(Stream, Line, Terminal),
drop_spaces(Line, S),
(S = []
-> (Terminal = end_of_file
-> Lst = Lst0
; get_and_parse_the_instructions(Stream, Lst0, Lst))
; (parse_instruction(S, Address, Opcode, Arg),
Instr = Address-{Opcode, Arg},
(Terminal = end_of_file
-> reverse([Instr | Lst0], Lst)
; get_and_parse_the_instructions(Stream, [Instr | Lst0],
Lst))))).
fill_instruction(Addr-Instr) :-
g_assign(the_code(Addr), Instr).
parse_header(Line, Datasize, Strings_Count) :-
drop_nondigits(Line, Lst1),
split_digits(Lst1, Datasize_Digits, Rest1),
drop_nondigits(Rest1, Lst2),
split_digits(Lst2, Strings_Digits, _Rest2),
number_chars(Datasize, Datasize_Digits),
number_chars(Strings_Count, Strings_Digits).
parse_string_literal(Line, S) :-
drop_spaces(Line, Lst1),
Lst1 = ['"' | Lst2],
rework_escape_sequences(Lst2, Lst3),
atom_chars(S, Lst3).
rework_escape_sequences(Lst0, Lst) :-
(Lst0 = [('"') | _]
-> Lst = []
; (Lst0 = [('\\'), ('n') | Tail1]
-> (rework_escape_sequences(Tail1, Lst1),
Lst = [('\n') | Lst1])
; (Lst0 = [('\\'), ('\\') | Tail1]
-> (rework_escape_sequences(Tail1, Lst1),
Lst = [('\\') | Lst1])
; (Lst0 = [C | Tail1],
rework_escape_sequences(Tail1, Lst1),
Lst = [C | Lst1])))).
parse_instruction(Line, Address, Opcode, Arg) :-
drop_spaces(Line, Lst1),
split_digits(Lst1, Address_Digits, Rest1),
number_chars(Address, Address_Digits),
drop_spaces(Rest1, Lst2),
split_nonspaces(Lst2, Opcode_Chars, Rest2),
atom_chars(Opcode, Opcode_Chars),
drop_spaces(Rest2, Lst3),
(Lst3 = []
-> Arg = 0
; (Lst3 = [C | Rest3],
(is_digit(C)
-> (split_digits(Lst3, Arg_Chars, _),
number_chars(Arg, Arg_Chars))
; (C = ('(')
-> (split_before_char((')'), Rest3, Arg_Chars, _),
number_chars(Arg, Arg_Chars))
; (C = ('['),
split_before_char((']'), Rest3, Arg_Chars, _),
number_chars(Arg, Arg_Chars)))))).
is_space(C) :-
(C = (' '); C = ('\t'); C = ('\n');
C = ('\v'); C = ('\f'); C = ('\r')).
is_digit(C) :-
(C = ('0'); C = ('1'); C = ('2'); C = ('3'); C = ('4');
C = ('5'); C = ('6'); C = ('7'); C = ('8'); C = ('9')).
drop_spaces([], Lst) :-
Lst = [].
drop_spaces([C | Tail], Lst) :-
(is_space(C)
-> drop_spaces(Tail, Lst)
; Lst = [C | Tail]).
drop_nondigits([], Lst) :-
Lst = [].
drop_nondigits([C | Tail], Lst) :-
(is_digit(C)
-> Lst = [C | Tail]
; drop_nondigits(Tail, Lst)).
split_nonspaces([], Word, Rest) :-
(Word = [], Rest = []).
split_nonspaces([C | Tail], Word, Rest) :-
(is_space(C)
-> (Word = [], Rest = [C | Tail])
; (split_nonspaces(Tail, Word1, Rest),
Word = [C | Word1])).
split_digits([], Digits, Rest) :-
(Digits = [], Rest = []).
split_digits([C | Tail], Digits, Rest) :-
(is_digit(C)
-> (split_digits(Tail, Digits1, Rest),
Digits = [C | Digits1])
; (Digits = [], Rest = [C | Tail])).
split_before_char(_, [], Before, After) :-
(Before = [], After = []).
split_before_char(C, [C1 | Rest], Before, After) :-
(C = C1
-> (Before = [], After = [C1 | Rest])
; (split_before_char(C, Rest, Before1, After),
Before = [C1 | Before1])).
get_line(Stream, Line, Terminal) :-
% Reads a line of input as a list of characters. The character that
% terminates the line is returned separately; it may be either '\n'
% or end_of_file.
get_line_chars(Stream, [], Line, Terminal).
get_line_chars(Stream, Chars0, Chars, Terminal) :-
% Helper predicate for get_line.
get_char(Stream, C),
((C = end_of_file; C = ('\n'))
-> (reverse(Chars0, Chars), Terminal = C)
; get_line_chars(Stream, [C | Chars0], Chars, Terminal)).
main(Args) :-
(Args = []
-> current_input(Input),
current_output(Output),
make_and_run_machine(Input, Output)
; (Args = [Inp_Name]
-> (Inp_Name = ('-')
-> main([])
; (open(Inp_Name, 'read', Input),
current_output(Output),
make_and_run_machine(Input, Output),
close(Input)))
; (Args = [Inp_Name, Out_Name | _],
(Inp_Name = ('-')
-> (Out_Name = ('-')
-> main([])
; (current_input(Input),
open(Out_Name, 'write', Output),
make_and_run_machine(Input, Output),
close(Output)))
; (Out_Name = ('-')
-> main([Inp_Name])
; (open(Inp_Name, 'read', Input),
open(Out_Name, 'write', Output),
make_and_run_machine(Input, Output),
close(Input),
close(Output))))))).
main :-
argument_list(Args),
main(Args).
:- initialization(main).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: prolog
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

168
Task/Compiler-virtual-machine-interpreter/Python/compiler-virtual-machine-interpreter.py Normal file
View file

@ -0,0 +1,168 @@
from __future__ import print_function
import sys, struct
FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT, \
JMP, JZ, PRTC, PRTS, PRTI, HALT = range(24)
code_map = {
"fetch": FETCH,
"store": STORE,
"push": PUSH,
"add": ADD,
"sub": SUB,
"mul": MUL,
"div": DIV,
"mod": MOD,
"lt": LT,
"gt": GT,
"le": LE,
"ge": GE,
"eq": EQ,
"ne": NE,
"and": AND,
"or": OR,
"not": NOT,
"neg": NEG,
"jmp": JMP,
"jz": JZ,
"prtc": PRTC,
"prts": PRTS,
"prti": PRTI,
"halt": HALT
}
input_file = None
code = bytearray()
string_pool = []
word_size = 4
#*** show error and exit
def error(msg):
print("%s" % (msg))
exit(1)
def int_to_bytes(val):
return struct.pack("<i", val)
def bytes_to_int(bstr):
return struct.unpack("<i", bstr)
#***
def emit_byte(x):
code.append(x)
#***
def emit_word(x):
s = int_to_bytes(x)
for x in s:
code.append(x)
#***
def run_vm(data_size):
stack = [0 for i in range(data_size + 1)]
pc = 0
while True:
op = code[pc]
pc += 1
if op == FETCH:
stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
pc += word_size
elif op == STORE:
stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
pc += word_size
elif op == PUSH:
stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
pc += word_size
elif op == ADD: stack[-2] += stack[-1]; stack.pop()
elif op == SUB: stack[-2] -= stack[-1]; stack.pop()
elif op == MUL: stack[-2] *= stack[-1]; stack.pop()
# use C like division semantics
elif op == DIV: stack[-2] = int(float(stack[-2]) / stack[-1]); stack.pop()
elif op == MOD: stack[-2] = int(float(stack[-2]) % stack[-1]); stack.pop()
elif op == LT: stack[-2] = stack[-2] < stack[-1]; stack.pop()
elif op == GT: stack[-2] = stack[-2] > stack[-1]; stack.pop()
elif op == LE: stack[-2] = stack[-2] <= stack[-1]; stack.pop()
elif op == GE: stack[-2] = stack[-2] >= stack[-1]; stack.pop()
elif op == EQ: stack[-2] = stack[-2] == stack[-1]; stack.pop()
elif op == NE: stack[-2] = stack[-2] != stack[-1]; stack.pop()
elif op == AND: stack[-2] = stack[-2] and stack[-1]; stack.pop()
elif op == OR: stack[-2] = stack[-2] or stack[-1]; stack.pop()
elif op == NEG: stack[-1] = -stack[-1]
elif op == NOT: stack[-1] = not stack[-1]
elif op == JMP: pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == JZ:
if stack.pop():
pc += word_size
else:
pc += bytes_to_int(code[pc:pc+word_size])[0]
elif op == PRTC: print("%c" % (stack[-1]), end=''); stack.pop()
elif op == PRTS: print("%s" % (string_pool[stack[-1]]), end=''); stack.pop()
elif op == PRTI: print("%d" % (stack[-1]), end=''); stack.pop()
elif op == HALT: break
def str_trans(srce):
dest = ""
i = 0
while i < len(srce):
if srce[i] == '\\' and i + 1 < len(srce):
if srce[i + 1] == 'n':
dest += '\n'
i += 2
elif srce[i + 1] == '\\':
dest += '\\'
i += 2
else:
dest += srce[i]
i += 1
return dest
#***
def load_code():
global string_pool
line = input_file.readline()
if len(line) == 0:
error("empty line")
line_list = line.split()
data_size = int(line_list[1])
n_strings = int(line_list[3])
for i in range(n_strings):
string_pool.append(str_trans(input_file.readline().strip('"\n')))
while True:
line = input_file.readline()
if len(line) == 0:
break
line_list = line.split()
offset = int(line_list[0])
instr = line_list[1]
opcode = code_map.get(instr)
if opcode == None:
error("Unknown instruction %s at %d" % (instr, offset))
emit_byte(opcode)
if opcode in [JMP, JZ]:
p = int(line_list[3])
emit_word(p - (offset + 1))
elif opcode == PUSH:
value = int(line_list[2])
emit_word(value)
elif opcode in [FETCH, STORE]:
value = int(line_list[2].strip('[]'))
emit_word(value)
return data_size
#*** main driver
input_file = sys.stdin
if len(sys.argv) > 1:
try:
input_file = open(sys.argv[1], "r", 4096)
except IOError as e:
error(0, 0, "Can't open %s" % sys.argv[1])
data_size = load_code()
run_vm(data_size)

1233
Task/Compiler-virtual-machine-interpreter/RATFOR/compiler-virtual-machine-interpreter.ratfor Normal file
View file

File diff suppressed because it is too large Load diff

748
Task/Compiler-virtual-machine-interpreter/Racket/compiler-virtual-machine-interpreter.rkt Normal file
View file

@ -0,0 +1,748 @@
#lang typed/racket
;;;
;;; The Rosetta Code Virtual Machine, in Typed Racket.
;;;
;;; Migrated from the Common Lisp.
;;;
;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(: executable-memory-size Positive-Fixnum)
(define executable-memory-size 65536)
;;; Similarly, I am going to have fixed size data and stack memory.
(: data-memory-size Positive-Fixnum)
(define data-memory-size 2048)
(: stack-memory-size Positive-Fixnum)
(define stack-memory-size 2048)
;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(define-type Word Nonnegative-Fixnum)
(define-type Register (Boxof Word))
(define-type Executable-Memory (Mutable-Vectorof Byte))
(define-type Data-Memory (Mutable-Vectorof Word))
(define-type Stack-Memory (Mutable-Vectorof Word))
(define re-blank-line #px"^\\s*$")
(define re-parse-instr-1 #px"^\\s*(\\d+)\\s*(.*\\S)")
(define re-parse-instr-2 #px"(?i:^(\\S+)\\s*(.*))")
(define re-parse-instr-3 #px"^[[(]?([0-9-]+)")
(define re-header
#px"(?i:^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+))")
(define re-leading-spaces #px"^\\s*")
(define opcode-names
'("halt"
"add"
"sub"
"mul"
"div"
"mod"
"lt"
"gt"
"le"
"ge"
"eq"
"ne"
"and"
"or"
"neg"
"not"
"prtc"
"prti"
"prts"
"fetch"
"store"
"push"
"jmp"
"jz"))
(: blank-line? (String -> Boolean))
(define (blank-line? s)
(not (not (regexp-match re-blank-line s))))
(: opcode-from-name (String -> Byte))
(define (opcode-from-name s)
(let ((i (index-of opcode-names s)))
(assert i)
(cast i Byte)))
(: create-executable-memory (-> Executable-Memory))
(define (create-executable-memory)
(make-vector executable-memory-size (opcode-from-name "halt")))
(: create-data-memory (-> Data-Memory))
(define (create-data-memory)
(make-vector data-memory-size 0))
(: create-stack-memory (-> Stack-Memory))
(define (create-stack-memory)
(make-vector stack-memory-size 0))
(: create-register (-> Register))
(define (create-register)
(box 0))
(struct machine
((sp : Register) ; Stack pointer.
(ip : Register) ; Instruction pointer (that is, program counter).
(code : Executable-Memory)
(data : Data-Memory)
(stack : Stack-Memory)
(strings : (Immutable-Vectorof String))
(output : Output-Port))
#:type-name Machine
#:constructor-name %make-machine)
(: make-machine ((Immutable-Vectorof String) Output-Port -> Machine))
(define (make-machine strings outf)
(%make-machine (create-register)
(create-register)
(create-executable-memory)
(create-data-memory)
(create-stack-memory)
strings
outf))
(define-type Instruction-Data (List Word Byte (U False Word)))
(: insert-instruction (Executable-Memory Instruction-Data -> Void))
(define (insert-instruction memory instr)
(void
(match instr
((list address opcode arg)
(let ((instr-size (if arg 5 1)))
(unless (<= (+ address instr-size) executable-memory-size)
(raise-user-error
"the VM's executable memory size is exceeded"))
(vector-set! memory address opcode)
(when arg
;; Big-endian order.
(vector-set! memory (+ address 1)
(bitwise-and (arithmetic-shift arg -24) #xFF))
(vector-set! memory (+ address 2)
(bitwise-and (arithmetic-shift arg -16) #xFF))
(vector-set! memory (+ address 3)
(bitwise-and (arithmetic-shift arg -8) #xFF))
(vector-set! memory (+ address 4)
(bitwise-and arg #xFF))))))))
(: load-executable-memory (Executable-Memory
(Listof Instruction-Data) ->
Void))
(define (load-executable-memory memory instr-lst)
(let loop ((p instr-lst))
(if (null? p)
(void)
(let ((instr (car p)))
(insert-instruction memory (car p))
(loop (cdr p))))))
(: number->word (Number -> Word))
(define (number->word n)
(cast (bitwise-and (cast n Integer) #xFFFFFFFF) Word))
(: string->word (String -> Word))
(define (string->word s)
(let ((n (string->number s)))
(assert (number? n))
(number->word n)))
(: parse-instruction (String -> (U False Instruction-Data)))
(define (parse-instruction s)
(and (not (blank-line? s))
(let* ((strings (cast (regexp-match re-parse-instr-1 s)
(Listof String)))
(address (cast (string->number (second strings))
Word))
(split (cast (regexp-match re-parse-instr-2
(third strings))
(Listof String)))
(opcode-name (string-downcase (second split)))
(opcode (opcode-from-name opcode-name))
(arguments (third split))
(has-arg? (match opcode-name
((or "fetch" "store" "push" "jmp" "jz") #t)
(_ #f))))
(if has-arg?
(let* ((argstr-lst
(cast (regexp-match re-parse-instr-3 arguments)
(Listof String)))
(argstr (second argstr-lst))
(arg (string->word argstr)))
`(,address ,opcode ,arg))
`(,address ,opcode #f)))))
(: read-instructions (Input-Port -> (Listof Instruction-Data)))
(define (read-instructions inpf)
(let loop ((line (read-line inpf))
(lst (cast '() (Listof Instruction-Data))))
(if (eof-object? line)
(reverse lst)
(let ((instr (parse-instruction line)))
(loop (read-line inpf)
(if instr
(cons instr lst)
lst))))))
(: read-datasize-and-strings-count (Input-Port -> (Values Word Word)))
(define (read-datasize-and-strings-count inpf)
(let ((line (read-line inpf)))
(unless (string? line)
(raise-user-error "empty input"))
;; This is a permissive implementation.
(let* ((strings (cast (regexp-match re-header line)
(Listof String)))
(datasize (string->word (second strings)))
(strings-count (string->word (third strings))))
(values datasize strings-count))))
(: parse-string-literal (String -> String))
(define (parse-string-literal s)
;; This is a permissive implementation, but only in that it skips
;; any leading space. It does not check carefully for outright
;; mistakes.
(let* ((s (regexp-replace re-leading-spaces s ""))
(quote-mark (string-ref s 0)))
(let loop ((i 1)
(lst (cast '() (Listof Char))))
(if (char=? (string-ref s i) quote-mark)
(list->string (reverse lst))
(let ((c (string-ref s i)))
(if (char=? c #\\)
(let ((c0 (match (string-ref s (+ i 1))
(#\n #\newline)
(c1 c1))))
(loop (+ i 2) (cons c0 lst)))
(loop (+ i 1) (cons c lst))))))))
(: read-string-literals (Input-Port Word -> (Listof String)))
(define (read-string-literals inpf strings-count)
(for/list ((i (in-range strings-count)))
(let ((line (read-line inpf)))
(begin (assert (string? line))
(parse-string-literal line)))))
(: open-inpf (String -> Input-Port))
(define (open-inpf inpf-filename)
(if (string=? inpf-filename "-")
(current-input-port)
(open-input-file inpf-filename)))
(: open-outf (String -> Output-Port))
(define (open-outf outf-filename)
(if (string=? outf-filename "-")
(current-output-port)
(open-output-file outf-filename #:exists 'truncate)))
(: word-signbit? (Word -> Boolean))
(define (word-signbit? x)
;; True if and only if the sign bit is set.
(not (zero? (bitwise-and x #x80000000))))
(: word-add (Word Word -> Word))
(define (word-add x y)
;; Addition with overflow freely allowed.
(cast (bitwise-and (+ x y) #xFFFFFFFF) Word))
(: word-neg (Word -> Word))
(define (word-neg x)
;; The two's complement.
(word-add (cast (bitwise-xor x #xFFFFFFFF) Word) 1))
(: word-sub (Word Word -> Word))
(define (word-sub x y)
;; Subtraction with overflow freely allowed.
(word-add x (word-neg y)))
(: word-mul (Word Word -> Word))
(define (word-mul x y)
;; Signed multiplication.
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-xy (cast (bitwise-and (* abs-x abs-y) #xFFFFFFFF)
Word)))
(if x<0
(if y<0 abs-xy (word-neg abs-xy))
(if y<0 (word-neg abs-xy) abs-xy))))))
(: word-div (Word Word -> Word))
(define (word-div x y)
;; The quotient after signed integer division with truncation
;; towards zero.
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x/y (cast (bitwise-and (quotient abs-x abs-y)
#xFFFFFFFF)
Word)))
(if x<0
(if y<0 abs-x/y (word-neg abs-x/y))
(if y<0 (word-neg abs-x/y) abs-x/y))))))
(: word-mod (Word Word -> Word))
(define (word-mod x y)
;; The remainder after signed integer division with truncation
;; towards zero.
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(let ((abs-x (if x<0 (word-neg x) x))
(abs-y (if y<0 (word-neg y) y)))
(let* ((abs-x/y (cast (bitwise-and (remainder abs-x abs-y)
#xFFFFFFFF)
Word)))
(if x<0
(if y<0 abs-x/y (word-neg abs-x/y))
(if y<0 (word-neg abs-x/y) abs-x/y))))))
(: b2i (Boolean -> (U Zero One)))
(define (b2i b)
(if b 1 0))
(: word-lt (Word Word -> Word))
(define (word-lt x y)
;; Signed comparison: is x less than y?
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(b2i (if x<0
(if y<0 (< x y) #t)
(if y<0 #f (< x y))))))
(: word-le (Word Word -> Word))
(define (word-le x y)
;; Signed comparison: is x less than or equal to y?
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(b2i (if x<0
(if y<0 (<= x y) #t)
(if y<0 #f (<= x y))))))
(: word-gt (Word Word -> Word))
(define (word-gt x y)
;; Signed comparison: is x greater than y?
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(b2i (if x<0
(if y<0 (> x y) #f)
(if y<0 #t (> x y))))))
(: word-ge (Word Word -> Word))
(define (word-ge x y)
;; Signed comparison: is x greater than or equal to y?
(let ((x<0 (word-signbit? x))
(y<0 (word-signbit? y)))
(b2i (if x<0
(if y<0 (>= x y) #f)
(if y<0 #t (>= x y))))))
(: word-eq (Word Word -> Word))
(define (word-eq x y)
;; Is x equal to y?
(b2i (= x y)))
(: word-ne (Word Word -> Word))
(define (word-ne x y)
;; Is x not equal to y?
(b2i (not (= x y))))
(: word-cmp (Word -> Word))
(define (word-cmp x)
;; The logical complement.
(b2i (zero? x)))
(: word-and (Word Word -> Word))
(define (word-and x y)
;; The logical conjunction.
(b2i (and (not (zero? x)) (not (zero? y)))))
(: word-or (Word Word -> Word))
(define (word-or x y)
;; The logical disjunction.
(b2i (or (not (zero? x)) (not (zero? y)))))
(: unop (Stack-Memory Register (Word -> Word) -> Void))
(define (unop stack sp operation)
;; Perform a unary operation on the stack.
(let ((i (unbox sp)))
(unless (<= 1 i)
(raise-user-error "stack underflow"))
(let ((x (vector-ref stack (- i 1))))
;; Note how, in contrast to Common Lisp, "operation" is not in a
;; namespace separate from that of "ordinary" values, such as
;; numbers and strings. (Which way is "better" is a matter of
;; taste, and probably depends mostly on what "functional"
;; language one learnt first. Mine was Caml Light, so I prefer
;; the Scheme way. :) )
(vector-set! stack (- i 1) (operation x)))))
(: binop (Stack-Memory Register (Word Word -> Word) -> Void))
(define (binop stack sp operation)
;; Perform a binary operation on the stack.
(let ((i (unbox sp)))
(unless (<= 2 i)
(raise-user-error "stack underflow"))
(let ((x (vector-ref stack (- i 2)))
(y (vector-ref stack (- i 1))))
(vector-set! stack (- i 2) (operation x y)))
(set-box! sp (cast (- i 1) Word))))
(: jri (Executable-Memory Register -> Void))
(define (jri code ip)
;; Jump relative immediate.
(let ((j (unbox ip)))
(unless (<= (+ j 4) executable-memory-size)
(raise-user-error "address past end of executable memory"))
;; Big-endian order.
(let* ((offset (vector-ref code (+ j 3)))
(offset (bitwise-ior
(arithmetic-shift (vector-ref code (+ j 2)) 8)
offset))
(offset (bitwise-ior
(arithmetic-shift (vector-ref code (+ j 1)) 16)
offset))
(offset (bitwise-ior
(arithmetic-shift (vector-ref code j) 24)
offset)))
(set-box! ip (word-add j (cast offset Word))))))
(: jriz (Stack-Memory Register Executable-Memory Register -> Void))
(define (jriz stack sp code ip)
;; Jump relative immediate, if zero.
(let ((i (unbox sp)))
(unless (<= 1 i)
(raise-user-error "stack underflow"))
(let ((x (vector-ref stack (- i 1))))
(set-box! sp (- i 1))
(if (zero? x)
(jri code ip)
(let ((j (unbox ip)))
(set-box! ip (cast (+ j 4) Word)))))))
(: get-immediate-value (Executable-Memory Register -> Word))
(define (get-immediate-value code ip)
(let ((j (unbox ip)))
(unless (<= (+ j 4) executable-memory-size)
(raise-user-error "address past end of executable memory"))
;; Big-endian order.
(let* ((x (vector-ref code (+ j 3)))
(x (bitwise-ior
(arithmetic-shift (vector-ref code (+ j 2)) 8)
x))
(x (bitwise-ior
(arithmetic-shift (vector-ref code (+ j 1)) 16)
x))
(x (bitwise-ior
(arithmetic-shift (vector-ref code j) 24)
x)))
(set-box! ip (cast (+ j 4) Word))
(cast x Word))))
(: pushi (Stack-Memory Register Executable-Memory Register -> Void))
(define (pushi stack sp code ip)
;; Push-immediate a value from executable memory onto the stack.
(let ((i (unbox sp)))
(unless (< i stack-memory-size)
(raise-user-error "stack overflow"))
(vector-set! stack i (get-immediate-value code ip))
(set-box! sp (cast (+ i 1) Word))))
(: fetch (Stack-Memory
Register Executable-Memory Register
Data-Memory -> Void))
(define (fetch stack sp code ip data)
;; Fetch data to the stack, using the storage location given in
;; executable memory.
(let ((i (unbox sp)))
(unless (< i stack-memory-size)
(raise-user-error "stack overflow"))
(let* ((k (get-immediate-value code ip))
(x (vector-ref data k)))
(vector-set! stack i x)
(set-box! sp (cast (+ i 1) Word)))))
(: pop-one (Stack-Memory Register -> Word))
(define (pop-one stack sp)
(let ((i (unbox sp)))
(unless (<= 1 i)
(raise-user-error "stack underflow"))
(let* ((x (vector-ref stack (- i 1))))
(set-box! sp (- i 1))
x)))
(: store (Stack-Memory
Register Executable-Memory Register
Data-Memory -> Void))
(define (store stack sp code ip data)
;; Store data from the stack, using the storage location given in
;; executable memory.
(let ((i (unbox sp)))
(unless (<= 1 i)
(raise-user-error "stack underflow"))
(let ((k (get-immediate-value code ip))
(x (pop-one stack sp)))
(vector-set! data k x))))
(: prti (Stack-Memory Register Output-Port -> Void))
(define (prti stack sp outf)
;; Print the top value of the stack, as a signed decimal value.
(let* ((n (pop-one stack sp))
(n<0 (word-signbit? n)))
(if n<0
(begin (display "-" outf)
(display (word-neg n) outf))
(display n outf))))
(: prtc (Stack-Memory Register Output-Port -> Void))
(define (prtc stack sp outf)
;; Print the top value of the stack, as a character.
(let ((c (pop-one stack sp)))
(display (integer->char c) outf)))
(: prts (Stack-Memory
Register (Immutable-Vectorof String) Output-Port -> Void))
(define (prts stack sp strings outf)
;; Print the string specified by the top of the stack.
(let* ((k (pop-one stack sp))
(s (vector-ref strings k)))
(display s outf)))
;;
;; I have written macros in the standard R6RS fashion, with a lambda
;; and syntax-case, so the examples may be widely illustrative. Racket
;; supports this style, despite (purposely) not adhering to any Scheme
;; standard.
;;
;; Some Schemes that do not provide syntax-case (CHICKEN, for
;; instance) provide alternatives that may be quite different.
;;
;; R5RS and R7RS require only syntax-rules, which cannot do what we
;; are doing here. (What we are doing is similar to using ## in a
;; modern C macro, except that the pieces are not merely raw text, and
;; they must be properly typed at every stage.)
;;
(define-syntax define-machine-binop
(lambda (stx)
(syntax-case stx ()
((_ op)
(let* ((op^ (syntax->datum #'op))
(machine-op (string-append "machine-" op^))
(machine-op (string->symbol machine-op))
(machine-op (datum->syntax stx machine-op))
(word-op (string-append "word-" op^))
(word-op (string->symbol word-op))
(word-op (datum->syntax stx word-op)))
#`(begin
(: #,machine-op (Machine -> Void))
(define (#,machine-op mach)
(binop (machine-stack mach)
(machine-sp mach)
#,word-op))))))))
(define-syntax define-machine-unop
(lambda (stx)
(syntax-case stx ()
((_ op)
(let* ((op^ (syntax->datum #'op))
(machine-op (string-append "machine-" op^))
(machine-op (string->symbol machine-op))
(machine-op (datum->syntax stx machine-op))
(word-op (string-append "word-" op^))
(word-op (string->symbol word-op))
(word-op (datum->syntax stx word-op)))
#`(begin
(: #,machine-op (Machine -> Void))
(define (#,machine-op mach)
(unop (machine-stack mach)
(machine-sp mach)
#,word-op))))))))
(define-machine-binop "add")
(define-machine-binop "sub")
(define-machine-binop "mul")
(define-machine-binop "div")
(define-machine-binop "mod")
(define-machine-binop "lt")
(define-machine-binop "gt")
(define-machine-binop "le")
(define-machine-binop "ge")
(define-machine-binop "eq")
(define-machine-binop "ne")
(define-machine-binop "and")
(define-machine-binop "or")
(define-machine-unop "neg")
(: machine-not (Machine -> Void))
(define (machine-not mach)
(unop (machine-stack mach)
(machine-sp mach)
word-cmp))
(: machine-prtc (Machine -> Void))
(define (machine-prtc mach)
(prtc (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(: machine-prti (Machine -> Void))
(define (machine-prti mach)
(prti (machine-stack mach)
(machine-sp mach)
(machine-output mach)))
(: machine-prts (Machine -> Void))
(define (machine-prts mach)
(prts (machine-stack mach)
(machine-sp mach)
(machine-strings mach)
(machine-output mach)))
(: machine-fetch (Machine -> Void))
(define (machine-fetch mach)
(fetch (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(: machine-store (Machine -> Void))
(define (machine-store mach)
(store (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)
(machine-data mach)))
(: machine-push (Machine -> Void))
(define (machine-push mach)
(pushi (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(: machine-jmp (Machine -> Void))
(define (machine-jmp mach)
(jri (machine-code mach)
(machine-ip mach)))
(: machine-jz (Machine -> Void))
(define (machine-jz mach)
(jriz (machine-stack mach)
(machine-sp mach)
(machine-code mach)
(machine-ip mach)))
(: get-opcode (Machine -> Byte))
(define (get-opcode mach)
(let ((code (machine-code mach))
(ip (machine-ip mach)))
(let ((j (unbox ip)))
(unless (< j executable-memory-size)
(raise-user-error "address past end of executable memory"))
(let ((opcode (vector-ref code j)))
(set-box! ip (cast (+ j 1) Word))
opcode))))
(: run-instruction (Machine Byte -> Void))
(define (run-instruction mach opcode)
(let ((op-mod-4 (bitwise-and opcode #x3))
(op-div-4 (arithmetic-shift opcode -2)))
(match op-div-4
(0 (match op-mod-4
(1 (machine-add mach))
(2 (machine-sub mach))
(3 (machine-mul mach))))
(1 (match op-mod-4
(0 (machine-div mach))
(1 (machine-mod mach))
(2 (machine-lt mach))
(3 (machine-gt mach))))
(2 (match op-mod-4
(0 (machine-le mach))
(1 (machine-ge mach))
(2 (machine-eq mach))
(3 (machine-ne mach))))
(3 (match op-mod-4
(0 (machine-and mach))
(1 (machine-or mach))
(2 (machine-neg mach))
(3 (machine-not mach))))
(4 (match op-mod-4
(0 (machine-prtc mach))
(1 (machine-prti mach))
(2 (machine-prts mach))
(3 (machine-fetch mach))))
(5 (match op-mod-4
(0 (machine-store mach))
(1 (machine-push mach))
(2 (machine-jmp mach))
(3 (machine-jz mach)))))))
(: run-vm (Machine -> Void))
(define (run-vm mach)
(let ((opcode-for-halt (cast (opcode-from-name "halt") Byte))
(opcode-for-add (cast (opcode-from-name "add") Byte))
(opcode-for-jz (cast (opcode-from-name "jz") Byte)))
(let loop ((opcode (get-opcode mach)))
(unless (= opcode opcode-for-halt)
(begin
(when (or (< opcode opcode-for-add)
(< opcode-for-jz opcode))
(raise-user-error "unsupported opcode"))
(run-instruction mach opcode)
(loop (get-opcode mach)))))))
(define (usage-error)
(display "Usage: vm [INPUTFILE [OUTPUTFILE]]" (current-error-port))
(newline (current-error-port))
(display "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
(current-error-port))
(display " standard I/O is used." (current-error-port))
(newline (current-error-port))
(exit 1))
(: get-filenames (-> (Values String String)))
(define (get-filenames)
(match (current-command-line-arguments)
((vector) (values "-" "-"))
((vector inpf-filename)
(values (cast inpf-filename String) "-"))
((vector inpf-filename outf-filename)
(values (cast inpf-filename String)
(cast outf-filename String)))
(_ (usage-error)
(values "" ""))))
(let-values (((inpf-filename outf-filename) (get-filenames)))
(let* ((inpf (open-inpf inpf-filename))
(outf (open-outf outf-filename)))
(let-values (((datasize strings-count)
(read-datasize-and-strings-count inpf)))
(let* ((strings
(vector->immutable-vector
(list->vector
(read-string-literals inpf strings-count))))
(instructions (read-instructions inpf))
(mach (make-machine strings outf)))
(unless (<= datasize data-memory-size)
(raise-user-error
"the VM's data memory size is exceeded"))
(load-executable-memory (machine-code mach) instructions)
(run-vm mach)
(unless (string=? inpf-filename "-")
(close-input-port inpf))
(unless (string=? outf-filename "-")
(close-output-port outf))
(exit 0)))))

78
Task/Compiler-virtual-machine-interpreter/Raku/compiler-virtual-machine-interpreter.raku Normal file
View file

@ -0,0 +1,78 @@
my @CODE = q:to/END/.lines;
Datasize: 3 Strings: 2
"count is: "
"\n"
0 push 1
5 store [0]
10 fetch [0]
15 push 10
20 lt
21 jz (68) 65 # jump value adjusted
26 push 0
31 prts
32 fetch [0]
37 prti
38 push 1
43 prts
44 fetch [0]
49 push 1
54 add
55 store [0]
60 jmp (-87) 10 # jump value adjusted
65 halt
END
my (@stack, @strings, @data, $memory);
my $pc = 0;
(@CODE.shift) ~~ /'Datasize:' \s+ (\d+) \s+ 'Strings:' \s+ (\d+)/ or die "bad header";
my $w = $0; # 'wordsize' of op-codes and 'width' of data values
@strings.push: (my $s = @CODE.shift) eq '"\n"' ?? "\n" !! $s.subst(/'"'/, '', :g) for 1..$1;
sub value { substr($memory, ($pc += $w) - $w, $w).trim }
my %ops = (
'no-op' => sub { },
'add' => sub { @stack[*-2] += @stack.pop },
'sub' => sub { @stack[*-2] -= @stack.pop },
'mul' => sub { @stack[*-2] *= @stack.pop },
'div' => sub { @stack[*-2] /= @stack.pop },
'mod' => sub { @stack[*-2] %= @stack.pop },
'neg' => sub { @stack[*-1] = - @stack[*-1] },
'and' => sub { @stack[*-2] &&= @stack[*-1]; @stack.pop },
'or' => sub { @stack[*-2] ||= @stack[*-1]; @stack.pop },
'not' => sub { @stack[*-1] = @stack[*-1] ?? 0 !! 1 },
'lt' => sub { @stack[*-1] = @stack[*-2] < @stack.pop ?? 1 !! 0 },
'gt' => sub { @stack[*-1] = @stack[*-2] > @stack.pop ?? 1 !! 0 },
'le' => sub { @stack[*-1] = @stack[*-2] <= @stack.pop ?? 1 !! 0 },
'ge' => sub { @stack[*-1] = @stack[*-2] >= @stack.pop ?? 1 !! 0 },
'ne' => sub { @stack[*-1] = @stack[*-2] != @stack.pop ?? 1 !! 0 },
'eq' => sub { @stack[*-1] = @stack[*-2] == @stack.pop ?? 1 !! 0 },
'store' => sub { @data[&value] = @stack.pop },
'fetch' => sub { @stack.push: @data[&value] // 0 },
'push' => sub { @stack.push: value() },
'jmp' => sub { $pc += value() - $w },
'jz' => sub { $pc += @stack.pop ?? $w !! value() - $w },
'prts' => sub { print @strings[@stack.pop] },
'prti' => sub { print @stack.pop },
'prtc' => sub { print chr @stack.pop },
'halt' => sub { exit }
);
my %op2n = %ops.keys.sort Z=> 0..*;
my %n2op = %op2n.invert;
%n2op{''} = 'no-op';
for @CODE -> $_ {
next unless /\w/;
/^ \s* \d+ \s+ (\w+)/ or die "bad line $_";
$memory ~= %op2n{$0}.fmt("%{$w}d");
/'(' ('-'?\d+) ')' | (\d+) ']'? $/;
$memory ~= $0 ?? $0.fmt("%{$w}d") !! ' ' x $w;
}
loop {
my $opcode = substr($memory, $pc, $w).trim;
$pc += $w;
%ops{%n2op{ $opcode }}();
}

216
Task/Compiler-virtual-machine-interpreter/Scala/compiler-virtual-machine-interpreter-1.scala Normal file
View file

@ -0,0 +1,216 @@
package xyz.hyperreal.rosettacodeCompiler
import java.io.{BufferedReader, FileReader, Reader, StringReader}
import scala.collection.mutable
import scala.collection.mutable.ArrayBuffer
object VirtualMachine {
private object Opcodes {
val FETCH: Byte = 0
val STORE: Byte = 1
val PUSH: Byte = 2
val JMP: Byte = 3
val JZ: Byte = 4
val ADD: Byte = 5
val SUB: Byte = 6
val MUL: Byte = 7
val DIV: Byte = 8
val MOD: Byte = 9
val LT: Byte = 10
val GT: Byte = 11
val LE: Byte = 12
val GE: Byte = 13
val EQ: Byte = 14
val NE: Byte = 15
val AND: Byte = 16
val OR: Byte = 17
val NEG: Byte = 18
val NOT: Byte = 19
val PRTC: Byte = 20
val PRTI: Byte = 21
val PRTS: Byte = 22
val HALT: Byte = 23
}
import Opcodes._
private val HEADER_REGEX = "Datasize: ([0-9]+) Strings: ([0-9]+)" r
private val STRING_REGEX = "\"([^\"]*)\"" r
private val PUSH_REGEX = " *[0-9]+ push +([0-9]+|'(?:[^'\\n]|\\\\n|\\\\\\\\)')" r
private val PRTS_REGEX = " *[0-9]+ prts" r
private val PRTI_REGEX = " *[0-9]+ prti" r
private val PRTC_REGEX = " *[0-9]+ prtc" r
private val HALT_REGEX = " *[0-9]+ halt" r
private val STORE_REGEX = " *[0-9]+ store +\\[([0-9]+)\\]" r
private val FETCH_REGEX = " *[0-9]+ fetch +\\[([0-9]+)\\]" r
private val LT_REGEX = " *[0-9]+ lt" r
private val GT_REGEX = " *[0-9]+ gt" r
private val LE_REGEX = " *[0-9]+ le" r
private val GE_REGEX = " *[0-9]+ ge" r
private val NE_REGEX = " *[0-9]+ ne" r
private val EQ_REGEX = " *[0-9]+ eq" r
private val JZ_REGEX = " *[0-9]+ jz +\\((-?[0-9]+)\\) [0-9]+" r
private val ADD_REGEX = " *[0-9]+ add" r
private val SUB_REGEX = " *[0-9]+ sub" r
private val MUL_REGEX = " *[0-9]+ mul" r
private val DIV_REGEX = " *[0-9]+ div" r
private val MOD_REGEX = " *[0-9]+ mod" r
private val AND_REGEX = " *[0-9]+ and" r
private val OR_REGEX = " *[0-9]+ or" r
private val NOT_REGEX = " *[0-9]+ not" r
private val NEG_REGEX = " *[0-9]+ neg" r
private val JMP_REGEX = " *[0-9]+ jmp +\\((-?[0-9]+)\\) [0-9]+" r
def fromStdin = fromReader(Console.in)
def fromFile(file: String) = fromReader(new FileReader(file))
def fromString(src: String) = fromReader(new StringReader(src))
def fromReader(r: Reader) = {
val in = new BufferedReader(r)
val vm =
in.readLine match {
case HEADER_REGEX(datasize, stringsize) =>
val strings =
for (_ <- 1 to stringsize.toInt)
yield
in.readLine match {
case STRING_REGEX(s) => unescape(s)
case null => sys.error("expected string constant but encountered end of input")
case s => sys.error(s"expected string constant: $s")
}
var line: String = null
val code = new ArrayBuffer[Byte]
def addShort(a: Int) = {
code += (a >> 8).toByte
code += a.toByte
}
def addInstIntOperand(opcode: Byte, operand: Int) = {
code += opcode
addShort(operand >> 16)
addShort(operand)
}
def addInst(opcode: Byte, operand: String) = addInstIntOperand(opcode, operand.toInt)
while ({ line = in.readLine; line ne null }) line match {
case PUSH_REGEX(n) if n startsWith "'" =>
addInstIntOperand(PUSH, unescape(n.substring(1, n.length - 1)).head)
case PUSH_REGEX(n) => addInst(PUSH, n)
case PRTS_REGEX() => code += PRTS
case PRTI_REGEX() => code += PRTI
case PRTC_REGEX() => code += PRTC
case HALT_REGEX() => code += HALT
case STORE_REGEX(idx) => addInst(STORE, idx)
case FETCH_REGEX(idx) => addInst(FETCH, idx)
case LT_REGEX() => code += LT
case GT_REGEX() => code += GT
case LE_REGEX() => code += LE
case GE_REGEX() => code += GE
case NE_REGEX() => code += NE
case EQ_REGEX() => code += EQ
case JZ_REGEX(disp) => addInst(JZ, disp)
case ADD_REGEX() => code += ADD
case SUB_REGEX() => code += SUB
case MUL_REGEX() => code += MUL
case DIV_REGEX() => code += DIV
case MOD_REGEX() => code += MOD
case AND_REGEX() => code += AND
case OR_REGEX() => code += OR
case NOT_REGEX() => code += NOT
case NEG_REGEX() => code += NEG
case JMP_REGEX(disp) => addInst(JMP, disp)
}
new VirtualMachine(code, datasize.toInt, strings)
case _ => sys.error("expected header")
}
in.close
vm
}
}
class VirtualMachine(code: IndexedSeq[Byte], datasize: Int, strings: IndexedSeq[String]) {
import VirtualMachine.Opcodes._
var pc = 0
val stack = new mutable.ArrayStack[Int]
val data = new Array[Int](datasize)
var running = false
def getByte = {
val byte = code(pc) & 0xFF
pc += 1
byte
}
def getShort = getByte << 8 | getByte
def getInt = getShort << 16 | getShort
def pushBoolean(b: Boolean) = stack push (if (b) 1 else 0)
def popBoolean = if (stack.pop != 0) true else false
def operator(f: (Int, Int) => Int) = {
val y = stack.pop
stack.push(f(stack.pop, y))
}
def relation(r: (Int, Int) => Boolean) = {
val y = stack.pop
pushBoolean(r(stack.pop, y))
}
def connective(c: (Boolean, Boolean) => Boolean) = pushBoolean(c(popBoolean, popBoolean))
def execute: Unit =
getByte match {
case FETCH => stack push data(getInt)
case STORE => data(getInt) = stack.pop
case PUSH => stack push getInt
case JMP => pc = pc + getInt
case JZ => if (stack.pop == 0) pc = pc + getInt else pc += 4
case ADD => operator(_ + _)
case SUB => operator(_ - _)
case MUL => operator(_ * _)
case DIV => operator(_ / _)
case MOD => operator(_ % _)
case LT => relation(_ < _)
case GT => relation(_ > _)
case LE => relation(_ <= _)
case GE => relation(_ >= _)
case EQ => relation(_ == _)
case NE => relation(_ != _)
case AND => connective(_ && _)
case OR => connective(_ || _)
case NEG => stack push -stack.pop
case NOT => pushBoolean(!popBoolean)
case PRTC => print(stack.pop.toChar)
case PRTI => print(stack.pop)
case PRTS => print(strings(stack.pop))
case HALT => running = false
}
def run = {
pc = 0
stack.clear
running = true
for (i <- data.indices) data(i) = 0
while (running) execute
}
}

27
Task/Compiler-virtual-machine-interpreter/Scala/compiler-virtual-machine-interpreter-2.scala Normal file
View file

@ -0,0 +1,27 @@
package xyz.hyperreal
import java.io.ByteArrayOutputStream
package object rosettacodeCompiler {
val escapes = "\\\\b|\\\\f|\\\\t|\\\\r|\\\\n|\\\\\\\\|\\\\\"" r
def unescape(s: String) =
escapes.replaceAllIn(s, _.matched match {
case "\\b" => "\b"
case "\\f" => "\f"
case "\\t" => "\t"
case "\\r" => "\r"
case "\\n" => "\n"
case "\\\\" => "\\"
case "\\\"" => "\""
})
def capture(thunk: => Unit) = {
val buf = new ByteArrayOutputStream
Console.withOut(buf)(thunk)
buf.toString
}
}

162
Task/Compiler-virtual-machine-interpreter/Scheme/compiler-virtual-machine-interpreter.ss Normal file
View file

@ -0,0 +1,162 @@
(import (scheme base)
(scheme char)
(scheme file)
(scheme process-context)
(scheme write)
(only (srfi 13) string-contains string-delete string-filter
string-replace string-tokenize))
(define *word-size* 4)
;; Mappings from operation symbols to internal procedures.
;; We define operations appropriate to virtual machine:
;; e.g. division must return an int, not a rational
;; boolean values are treated as numbers: 0 is false, other is true
(define *unary-ops*
(list (cons 'neg (lambda (a) (- a)))
(cons 'not (lambda (a) (if (zero? a) 1 0)))))
(define *binary-ops*
(let ((number-comp (lambda (op) (lambda (a b) (if (op a b) 1 0)))))
(list (cons 'add +)
(cons 'sub -)
(cons 'mul *)
(cons 'div (lambda (a b) (truncate (/ a b)))) ; int division
(cons 'mod modulo)
(cons 'lt (number-comp <))
(cons 'gt (number-comp >))
(cons 'le (number-comp <=))
(cons 'ge (number-comp >=))
(cons 'eq (lambda (a b) (if (= a b) 1 0)))
(cons 'ne (lambda (a b) (if (= a b) 0 1)))
(cons 'and (lambda (a b) ; make "and" work on numbers
(if (and (not (zero? a)) (not (zero? b))) 1 0)))
(cons 'or (lambda (a b) ; make "or" work on numbers
(if (or (not (zero? a)) (not (zero? b))) 1 0))))))
;; read information from file, returning vectors for data and strings
;; and a list of the code instructions
(define (read-code filename)
(define (setup-definitions str)
(values ; return vectors for (data strings) of required size
(make-vector (string->number (list-ref str 1)) #f)
(make-vector (string->number (list-ref str 3)) #f)))
(define (read-strings strings) ; read constant strings into data structure
(define (replace-newlines chars) ; replace newlines, obeying \\n
(cond ((< (length chars) 2) ; finished list
chars)
((and (>= (length chars) 3) ; preserve \\n
(char=? #\\ (car chars))
(char=? #\\ (cadr chars))
(char=? #\n (cadr (cdr chars))))
(cons (car chars)
(cons (cadr chars)
(cons (cadr (cdr chars))
(replace-newlines (cdr (cdr (cdr chars))))))))
((and (char=? #\\ (car chars)) ; replace \n with newline
(char=? #\n (cadr chars)))
(cons #\newline (replace-newlines (cdr (cdr chars)))))
(else ; keep char and look further
(cons (car chars) (replace-newlines (cdr chars))))))
(define (tidy-string str) ; remove quotes, map newlines to actual newlines
(list->string
(replace-newlines
(string->list
(string-delete #\" str))))) ; " (needed to satisfy rosettacode's scheme syntax highlighter)
;
(do ((i 0 (+ i 1)))
((= i (vector-length strings)) )
(vector-set! strings i (tidy-string (read-line)))))
(define (read-code)
(define (cleanup-code opn) ; tidy instructions, parsing numbers
(let ((addr (string->number (car opn)))
(instr (string->symbol (cadr opn))))
(cond ((= 2 (length opn))
(list addr instr))
((= 3 (length opn))
(list addr
instr
(string->number
(string-filter char-numeric? (list-ref opn 2)))))
(else ; assume length 4, jump instructions
(list addr instr (string->number (list-ref opn 3)))))))
;
(let loop ((result '()))
(let ((line (read-line)))
(if (eof-object? line)
(reverse (map cleanup-code result))
(loop (cons (string-tokenize line) result))))))
;
(with-input-from-file
filename
(lambda ()
(let-values (((data strings)
(setup-definitions (string-tokenize (read-line)))))
(read-strings strings)
(values data
strings
(read-code))))))
;; run the virtual machine
(define (run-program data strings code)
(define (get-instruction n)
(if (assq n code)
(cdr (assq n code))
(error "Could not find instruction")))
;
(let loop ((stack '())
(pc 0))
(let ((op (get-instruction pc)))
(case (car op)
((fetch)
(loop (cons (vector-ref data (cadr op)) stack)
(+ pc 1 *word-size*)))
((store)
(vector-set! data (cadr op) (car stack))
(loop (cdr stack)
(+ pc 1 *word-size*)))
((push)
(loop (cons (cadr op) stack)
(+ pc 1 *word-size*)))
((add sub mul div mod lt gt le eq ne and or)
(let ((instr (assq (car op) *binary-ops*)))
(if instr
(loop (cons ((cdr instr) (cadr stack) ; replace top two with result
(car stack))
(cdr (cdr stack)))
(+ pc 1))
(error "Unknown binary operation"))))
((neg not)
(let ((instr (assq (car op) *unary-ops*)))
(if instr
(loop (cons ((cdr instr) (car stack)) ; replace top with result
(cdr stack))
(+ pc 1))
(error "Unknown unary operation"))))
((jmp)
(loop stack
(cadr op)))
((jz)
(loop (cdr stack)
(if (zero? (car stack))
(cadr op)
(+ pc 1 *word-size*))))
((prtc)
(display (integer->char (car stack)))
(loop (cdr stack)
(+ pc 1)))
((prti)
(display (car stack))
(loop (cdr stack)
(+ pc 1)))
((prts)
(display (vector-ref strings (car stack)))
(loop (cdr stack)
(+ pc 1)))
((halt)
#t)))))
;; create and run virtual machine from filename passed on command line
(if (= 2 (length (command-line)))
(let-values (((data strings code) (read-code (cadr (command-line)))))
(run-program data strings code))
(display "Error: pass a .asm filename\n"))

267
Task/Compiler-virtual-machine-interpreter/Wren/compiler-virtual-machine-interpreter.wren Normal file
View file

@ -0,0 +1,267 @@
import "/dynamic" for Enum
import "/crypto" for Bytes
import "/fmt" for Conv
import "/ioutil" for FileUtil
var codes = [
"fetch",
"store",
"push",
"add",
"sub",
"mul",
"div",
"mod",
"lt",
"gt",
"le",
"ge",
"eq",
"ne",
"and",
"or",
"neg",
"not",
"jmp",
"jz",
"prtc",
"prts",
"prti",
"halt"
]
var Code = Enum.create("Code", codes)
var codeMap = {
"fetch": Code.fetch,
"store": Code.store,
"push": Code.push,
"add": Code.add,
"sub": Code.sub,
"mul": Code.mul,
"div": Code.div,
"mod": Code.mod,
"lt": Code.lt,
"gt": Code.gt,
"le": Code.le,
"ge": Code.ge,
"eq": Code.eq,
"ne": Code.ne,
"and": Code.and,
"or": Code.or,
"neg": Code.neg,
"not": Code.not,
"jmp": Code.jmp,
"jz": Code.jz,
"prtc": Code.prtc,
"prts": Code.prts,
"prti": Code.prti,
"halt": Code.halt
}
var object = []
var stringPool = []
var reportError = Fn.new { |msg| Fiber.abort("error : %(msg)") }
var emitByte = Fn.new { |c| object.add(c) }
var emitWord = Fn.new { |n|
var bs = Bytes.fromIntLE(n)
for (b in bs) emitByte.call(b)
}
// Converts the 4 bytes starting at object[pc] to an unsigned 32 bit integer
// and thence to a signed 32 bit integer
var toInt32LE = Fn.new { |pc|
var x = Bytes.toIntLE(object[pc...pc+4])
if (x >= 2.pow(31)) x = x - 2.pow(32)
return x
}
/* Virtual Machine interpreter */
var runVM = Fn.new { |dataSize|
var stack = List.filled(dataSize + 1, 0)
var pc = 0
while (true) {
var op = object[pc]
pc = pc + 1
if (op == Code.fetch) {
var x = toInt32LE.call(pc)
stack.add(stack[x])
pc = pc + 4
} else if (op == Code.store) {
var x = toInt32LE.call(pc)
var ln = stack.count
stack[x] = stack[ln-1]
stack = stack[0...ln-1]
pc = pc + 4
} else if (op == Code.push) {
var x = toInt32LE.call(pc)
stack.add(x)
pc = pc + 4
} else if (op == Code.add) {
var ln = stack.count
stack[ln-2] = stack[ln-2] + stack[ln-1]
stack = stack[0...ln-1]
} else if (op == Code.sub) {
var ln = stack.count
stack[ln-2] = stack[ln-2] - stack[ln-1]
stack = stack[0...ln-1]
} else if (op == Code.mul) {
var ln = stack.count
stack[ln-2] = stack[ln-2] * stack[ln-1]
stack = stack[0...ln-1]
} else if (op == Code.div) {
var ln = stack.count
stack[ln-2] = (stack[ln-2] / stack[ln-1]).truncate
stack = stack[0...ln-1]
} else if (op == Code.mod) {
var ln = stack.count
stack[ln-2] = stack[ln-2] % stack[ln-1]
stack = stack[0...ln-1]
} else if (op == Code.lt) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] < stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.gt) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] > stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.le) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] <= stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.ge) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] >= stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.eq) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] == stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.ne) {
var ln = stack.count
stack[ln-2] = Conv.btoi(stack[ln-2] != stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.and) {
var ln = stack.count
stack[ln-2] = Conv.btoi(Conv.itob(stack[ln-2]) && Conv.itob(stack[ln-1]))
stack = stack[0...ln-1]
} else if (op == Code.or) {
var ln = stack.count
stack[ln-2] = Conv.btoi(Conv.itob(stack[ln-2]) || Conv.itob(stack[ln-1]))
stack = stack[0...ln-1]
} else if (op == Code.neg) {
var ln = stack.count
stack[ln-1] = -stack[ln-1]
} else if (op == Code.not) {
var ln = stack.count
stack[ln-1] = Conv.btoi(!Conv.itob(stack[ln-1]))
} else if (op == Code.jmp) {
var x = toInt32LE.call(pc)
pc = pc + x
} else if (op == Code.jz) {
var ln = stack.count
var v = stack[ln-1]
stack = stack[0...ln-1]
if (v != 0) {
pc = pc + 4
} else {
var x = toInt32LE.call(pc)
pc = pc + x
}
} else if (op == Code.prtc) {
var ln = stack.count
System.write(String.fromByte(stack[ln-1]))
stack = stack[0...ln-1]
} else if (op == Code.prts) {
var ln = stack.count
System.write(stringPool[stack[ln-1]])
stack = stack[0...ln-1]
} else if (op == Code.prti) {
var ln = stack.count
System.write(stack[ln-1])
stack = stack[0...ln-1]
} else if (op == Code.halt) {
return
} else {
reportError.call("Unknown opcode %(op)")
}
}
}
var translate = Fn.new { |s|
var d = ""
var i = 0
while (i < s.count) {
if (s[i] == "\\" && (i+1) < s.count) {
if (s[i+1] == "n") {
d = d + "\n"
i = i + 1
} else if (s[i+1] == "\\") {
d = d + "\\"
i = i + 1
}
} else {
d = d + s[i]
}
i = i + 1
}
return d
}
var lines = []
var lineCount = 0
var lineNum = 0
var loadCode = Fn.new {
var dataSize
var firstLine = true
while (lineNum < lineCount) {
var line = lines[lineNum].trimEnd(" \t")
lineNum = lineNum + 1
if (line.count == 0) {
if (firstLine) {
reportError.call("empty line")
} else {
break
}
}
var lineList = line.split(" ").where { |s| s != "" }.toList
if (firstLine) {
dataSize = Num.fromString(lineList[1])
var nStrings = Num.fromString(lineList[3])
for (i in 0...nStrings) {
var s = lines[lineNum].trim("\"\n")
lineNum = lineNum + 1
stringPool.add(translate.call(s))
}
firstLine = false
continue
}
var offset = Num.fromString(lineList[0])
var instr = lineList[1]
var opCode = codeMap[instr]
if (!opCode) {
reportError.call("Unknown instruction %(instr) at %(opCode)")
}
emitByte.call(opCode)
if (opCode == Code.jmp || opCode == Code.jz) {
var p = Num.fromString(lineList[3])
emitWord.call(p - offset - 1)
} else if (opCode == Code.push) {
var value = Num.fromString(lineList[2])
emitWord.call(value)
} else if (opCode == Code.fetch || opCode == Code.store) {
var value = Num.fromString(lineList[2].trim("[]"))
emitWord.call(value)
}
}
return dataSize
}
lines = FileUtil.readLines("codegen.txt")
lineCount = lines.count
runVM.call(loadCode.call())

322
Task/Compiler-virtual-machine-interpreter/Zig/compiler-virtual-machine-interpreter.zig Normal file
View file

@ -0,0 +1,322 @@
const std = @import("std");
pub const VirtualMachineError = error{OutOfMemory};
pub const VirtualMachine = struct {
allocator: std.mem.Allocator,
stack: [stack_size]i32,
program: std.ArrayList(u8),
sp: usize, // stack pointer
pc: usize, // program counter
string_pool: std.ArrayList([]const u8), // all the strings in the program
globals: std.ArrayList(i32), // all the variables in the program, they are global
output: std.ArrayList(u8), // Instead of outputting to stdout, we do it here for better testing.
const Self = @This();
const stack_size = 32; // Can be arbitrarily increased/decreased as long as we have enough.
const word_size = @sizeOf(i32);
pub fn init(
allocator: std.mem.Allocator,
program: std.ArrayList(u8),
string_pool: std.ArrayList([]const u8),
globals: std.ArrayList(i32),
) Self {
return VirtualMachine{
.allocator = allocator,
.stack = [_]i32{std.math.maxInt(i32)} ** stack_size,
.program = program,
.sp = 0,
.pc = 0,
.string_pool = string_pool,
.globals = globals,
.output = std.ArrayList(u8).init(allocator),
};
}
pub fn interp(self: *Self) VirtualMachineError!void {
while (true) : (self.pc += 1) {
switch (@intToEnum(Op, self.program.items[self.pc])) {
.push => self.push(self.unpackInt()),
.store => self.globals.items[@intCast(usize, self.unpackInt())] = self.pop(),
.fetch => self.push(self.globals.items[@intCast(usize, self.unpackInt())]),
.jmp => self.pc = @intCast(usize, self.unpackInt() - 1),
.jz => {
if (self.pop() == 0) {
// -1 because `while` increases it with every iteration.
// This doesn't allow to jump to location 0 because we use `usize` for `pc`,
// just arbitrary implementation limitation.
self.pc = @intCast(usize, self.unpackInt() - 1);
} else {
self.pc += word_size;
}
},
.prts => try self.out("{s}", .{self.string_pool.items[@intCast(usize, self.pop())]}),
.prti => try self.out("{d}", .{self.pop()}),
.prtc => try self.out("{c}", .{@intCast(u8, self.pop())}),
.lt => self.binOp(lt),
.le => self.binOp(le),
.gt => self.binOp(gt),
.ge => self.binOp(ge),
.eq => self.binOp(eq),
.ne => self.binOp(ne),
.add => self.binOp(add),
.mul => self.binOp(mul),
.sub => self.binOp(sub),
.div => self.binOp(div),
.mod => self.binOp(mod),
.@"and" => self.binOp(@"and"),
.@"or" => self.binOp(@"or"),
.not => self.push(@boolToInt(self.pop() == 0)),
.neg => self.push(-self.pop()),
.halt => break,
}
}
}
fn push(self: *Self, n: i32) void {
self.sp += 1;
self.stack[self.sp] = n;
}
fn pop(self: *Self) i32 {
std.debug.assert(self.sp != 0);
self.sp -= 1;
return self.stack[self.sp + 1];
}
fn unpackInt(self: *Self) i32 {
const arg_ptr = @ptrCast(*[4]u8, self.program.items[self.pc + 1 .. self.pc + 1 + word_size]);
self.pc += word_size;
var arg_array = arg_ptr.*;
const arg = @ptrCast(*i32, @alignCast(@alignOf(i32), &arg_array));
return arg.*;
}
pub fn out(self: *Self, comptime format: []const u8, args: anytype) VirtualMachineError!void {
try self.output.writer().print(format, args);
}
fn binOp(self: *Self, func: fn (a: i32, b: i32) i32) void {
const a = self.pop();
const b = self.pop();
// Note that arguments are in reversed order because this is how we interact with
// push/pop operations of the stack.
const result = func(b, a);
self.push(result);
}
fn lt(a: i32, b: i32) i32 {
return @boolToInt(a < b);
}
fn le(a: i32, b: i32) i32 {
return @boolToInt(a <= b);
}
fn gt(a: i32, b: i32) i32 {
return @boolToInt(a > b);
}
fn ge(a: i32, b: i32) i32 {
return @boolToInt(a >= b);
}
fn eq(a: i32, b: i32) i32 {
return @boolToInt(a == b);
}
fn ne(a: i32, b: i32) i32 {
return @boolToInt(a != b);
}
fn add(a: i32, b: i32) i32 {
return a + b;
}
fn sub(a: i32, b: i32) i32 {
return a - b;
}
fn mul(a: i32, b: i32) i32 {
return a * b;
}
fn div(a: i32, b: i32) i32 {
return @divTrunc(a, b);
}
fn mod(a: i32, b: i32) i32 {
return @mod(a, b);
}
fn @"or"(a: i32, b: i32) i32 {
return @boolToInt((a != 0) or (b != 0));
}
fn @"and"(a: i32, b: i32) i32 {
return @boolToInt((a != 0) and (b != 0));
}
};
pub fn main() !void {
var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
defer arena.deinit();
const allocator = arena.allocator();
var arg_it = std.process.args();
_ = try arg_it.next(allocator) orelse unreachable; // program name
const file_name = arg_it.next(allocator);
// We accept both files and standard input.
var file_handle = blk: {
if (file_name) |file_name_delimited| {
const fname: []const u8 = try file_name_delimited;
break :blk try std.fs.cwd().openFile(fname, .{});
} else {
break :blk std.io.getStdIn();
}
};
defer file_handle.close();
const input_content = try file_handle.readToEndAlloc(allocator, std.math.maxInt(usize));
var string_pool = std.ArrayList([]const u8).init(allocator);
var globals = std.ArrayList(i32).init(allocator);
const bytecode = try loadBytecode(allocator, input_content, &string_pool, &globals);
var vm = VirtualMachine.init(allocator, bytecode, string_pool, globals);
try vm.interp();
const result: []const u8 = vm.output.items;
_ = try std.io.getStdOut().write(result);
}
pub const Op = enum(u8) {
fetch,
store,
push,
add,
sub,
mul,
div,
mod,
lt,
gt,
le,
ge,
eq,
ne,
@"and",
@"or",
neg,
not,
jmp,
jz,
prtc,
prts,
prti,
halt,
const from_string = std.ComptimeStringMap(Op, .{
.{ "fetch", .fetch },
.{ "store", .store },
.{ "push", .push },
.{ "add", .add },
.{ "sub", .sub },
.{ "mul", .mul },
.{ "div", .div },
.{ "mod", .mod },
.{ "lt", .lt },
.{ "gt", .gt },
.{ "le", .le },
.{ "ge", .ge },
.{ "eq", .eq },
.{ "ne", .ne },
.{ "and", .@"and" },
.{ "or", .@"or" },
.{ "neg", .neg },
.{ "not", .not },
.{ "jmp", .jmp },
.{ "jz", .jz },
.{ "prtc", .prtc },
.{ "prts", .prts },
.{ "prti", .prti },
.{ "halt", .halt },
});
pub fn fromString(str: []const u8) Op {
return from_string.get(str).?;
}
};
// 100 lines of code to load serialized bytecode, eh
fn loadBytecode(
allocator: std.mem.Allocator,
str: []const u8,
string_pool: *std.ArrayList([]const u8),
globals: *std.ArrayList(i32),
) !std.ArrayList(u8) {
var result = std.ArrayList(u8).init(allocator);
var line_it = std.mem.split(u8, str, "\n");
while (line_it.next()) |line| {
if (std.mem.indexOf(u8, line, "halt")) |_| {
var tok_it = std.mem.tokenize(u8, line, " ");
const size = try std.fmt.parseInt(usize, tok_it.next().?, 10);
try result.resize(size + 1);
break;
}
}
line_it.index = 0;
const first_line = line_it.next().?;
const strings_index = std.mem.indexOf(u8, first_line, " Strings: ").?;
const globals_size = try std.fmt.parseInt(usize, first_line["Datasize: ".len..strings_index], 10);
const string_pool_size = try std.fmt.parseInt(usize, first_line[strings_index + " Strings: ".len ..], 10);
try globals.resize(globals_size);
try string_pool.ensureTotalCapacity(string_pool_size);
var string_cnt: usize = 0;
while (string_cnt < string_pool_size) : (string_cnt += 1) {
const line = line_it.next().?;
var program_string = try std.ArrayList(u8).initCapacity(allocator, line.len);
var escaped = false;
// Skip double quotes
for (line[1 .. line.len - 1]) |ch| {
if (escaped) {
escaped = false;
switch (ch) {
'\\' => try program_string.append('\\'),
'n' => try program_string.append('\n'),
else => {
std.debug.print("unknown escape sequence: {c}\n", .{ch});
std.os.exit(1);
},
}
} else {
switch (ch) {
'\\' => escaped = true,
else => try program_string.append(ch),
}
}
}
try string_pool.append(program_string.items);
}
while (line_it.next()) |line| {
if (line.len == 0) break;
var tok_it = std.mem.tokenize(u8, line, " ");
const address = try std.fmt.parseInt(usize, tok_it.next().?, 10);
const op = Op.fromString(tok_it.next().?);
result.items[address] = @enumToInt(op);
switch (op) {
.fetch, .store => {
const index_bracketed = tok_it.rest();
const index = try std.fmt.parseInt(i32, index_bracketed[1 .. index_bracketed.len - 1], 10);
insertInt(&result, address + 1, index);
},
.push => {
insertInt(&result, address + 1, try std.fmt.parseInt(i32, tok_it.rest(), 10));
},
.jmp, .jz => {
_ = tok_it.next();
insertInt(&result, address + 1, try std.fmt.parseInt(i32, tok_it.rest(), 10));
},
else => {},
}
}
return result;
}
fn insertInt(array: *std.ArrayList(u8), address: usize, n: i32) void {
const word_size = @sizeOf(i32);
var i: usize = 0;
var n_var = n;
var n_bytes = @ptrCast(*[4]u8, &n_var);
while (i < word_size) : (i += 1) {
array.items[@intCast(usize, address + i)] = n_bytes[@intCast(usize, i)];
}
}

62
Task/Compiler-virtual-machine-interpreter/Zkl/compiler-virtual-machine-interpreter.zkl Normal file
View file

@ -0,0 +1,62 @@
// This is a little endian machine
const WORD_SIZE=4;
const{ var _n=-1; var[proxy]N=fcn{ _n+=1 } } // enumerator
const FETCH=N, STORE=N, PUSH=N, ADD=N, SUB=N, MUL=N, DIV=N, MOD=N,
LT=N, GT=N, LE=N, GE=N, EQ=N, NE=N, AND=N, OR=N, NEG=N, NOT=N,
JMP=N, JZ=N, PRTC=N, PRTS=N, PRTI=N, HALT=N;
var [const]
bops=Dictionary(ADD,'+, SUB,'-, MUL,'*, DIV,'/, MOD,'%,
LT,'<, GT,'>, LE,'<=, GE,'>=, NE,'!=, EQ,'==, NE,'!=),
strings=List(); // filled in by the loader
;
// do a binary op
fcn bop(stack,op){ a,b:=stack.pop(),stack.pop(); stack.append(bops[op](b,a)) }
fcn run_vm(code,stackSz){
stack,pc := List.createLong(stackSz,0), 0;
while(True){
op:=code[pc]; pc+=1;
switch(op){
case(FETCH){
stack.append(stack[code.toLittleEndian(pc,WORD_SIZE,False)]);
pc+=WORD_SIZE;
}
case(STORE){
stack[code.toLittleEndian(pc,WORD_SIZE)]=stack.pop();
pc+=WORD_SIZE;
}
case(PUSH){
stack.append(code.toLittleEndian(pc,WORD_SIZE,False)); // signed
pc+=WORD_SIZE;
}
case(ADD,SUB,MUL,DIV,MOD,LT,GT,LE,GE,EQ,NE) { bop(stack,op) }
case(AND){ stack[-2] = stack[-2] and stack[-1]; stack.pop() }
case(OR) { stack[-2] = stack[-2] or stack[-1]; stack.pop() }
case(NEG){ stack[-1] = -stack[-1] }
case(NOT){ stack[-1] = not stack[-1] }
case(JMP){ pc+=code.toLittleEndian(pc,WORD_SIZE,False); } // signed
case(JZ) {
if(stack.pop()) pc+=WORD_SIZE;
else pc+=code.toLittleEndian(pc,WORD_SIZE,False);
}
case(PRTC){ } // not implemented
case(PRTS){ print(strings[stack.pop()]) }
case(PRTI){ print(stack.pop()) }
case(HALT){ break }
else{ throw(Exception.AssertionError(
"Bad op code (%d) @%d".fmt(op,pc-1))) }
}
}
}
code:=File(vm.nthArg(0)).read(); // binary code file
// the string table is prepended to the code:
// 66,1 byte len,text, no trailing '\0' needed
while(code[0]==66){ // read the string table
sz:=code[1];
strings.append(code[2,sz].text);
code.del(0,sz+2);
}
run_vm(code,1000);