308 lines
14 KiB
Plaintext
308 lines
14 KiB
Plaintext
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.
|