Compiler/virtual machine interpreter: Difference between revisions

Content added Content deleted
Line 12,054: Line 12,054:
count is: 8
count is: 8
count is: 9</pre>
count is: 9</pre>

=={{header|RATFOR}}==
{{works with|ratfor77|[https://sourceforge.net/p/chemoelectric/ratfor77/ public domain 1.0]}}
{{works with|gfortran|11.2.1}}
{{works with|f2c|20100827}}


<lang ratfor>######################################################################
#
# The Rosetta Code code virtual machine in Ratfor 77.
#
# The implementation assumes your FORTRAN compiler supports 1-byte
# INTEGER*1 and 4-byte INTEGER*4. Integer storage will be
# native-endian, achieved via EQUIVALENCE. (GNU Fortran and f2c both
# should work.)
#
#
# How to deal with FORTRAN 77 input is a problem. I use formatted
# input, treating each line as an array of type CHARACTER--regrettably
# of no more than some predetermined, finite length. It is a very
# simple method and presents no significant difficulties, aside from
# the restriction on line length of the input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
# ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
# f2c -C -Nc40 vm-in-ratfor.f
# cc vm-in-ratfor.c -lf2c
# ./a.out < compiler-tests/primes.vm
#
# With gfortran, a little differently:
#
# ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
# gfortran -fcheck=all -std=legacy vm-in-ratfor.f
# ./a.out < compiler-tests/primes.vm
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------

# Some parameters you may wish to modify.

define(LINESZ, 256) # Size of an input line.
define(OUTLSZ, 1024) # Size of an output line.
define(STRNSZ, 4096) # Size of the string pool.
define(STCKSZ, 4096) # Size of stacks.
define(MAXVAR, 256) # Maximum number of variables.
define(MAXSTR, 256) # Maximum number of strings.
define(CODESZ, 16384) # Maximum size of a compiled program.

define(STRSZ, 2) # Size of an entry in the VM strings array.
define(STRI, 1) # Index of the string within strngs.
define(STRN, 2) # Length of the string.

#---------------------------------------------------------------------

define(NEWLIN, 10) # The Unix newline character (ASCII LF).
define(DQUOTE, 34) # The double quote character.
define(BACKSL, 92) # The backslash character.

#---------------------------------------------------------------------

define(OPHALT, 1)
define(OPADD, 2)
define(OPSUB, 3)
define(OPMUL, 4)
define(OPDIV, 5)
define(OPMOD, 6)
define(OPLT, 7)
define(OPGT, 8)
define(OPLE, 9)
define(OPGE, 10)
define(OPEQ, 11)
define(OPNE, 12)
define(OPAND, 13)
define(OPOR, 14)
define(OPNEG, 15)
define(OPNOT, 16)
define(OPPRTC, 17)
define(OPPRTI, 18)
define(OPPRTS, 19)
define(OPFTCH, 20)
define(OPSTOR, 21)
define(OPPUSH, 22)
define(OPJMP, 23)
define(OPJZ, 24)

#---------------------------------------------------------------------

function issp (c)

# Is a character a space character?

implicit none

character c
logical issp

integer ic

ic = ichar (c)
issp = (ic == 32 || (9 <= ic && ic <= 13))
end

function isalph (c)

# Is c character code for a letter?

implicit none

integer c
logical isalph

#
# The following is correct for ASCII and Unicode, but not for
# EBCDIC.
#
isalph = (ichar ('a') <= c && c <= ichar ('z')) _
|| (ichar ('A') <= c && c <= ichar ('Z'))
end

function isdgt (c)

# Is c character code for a digit?

implicit none

integer c
logical isdgt

isdgt = (ichar ('0') <= c && c <= ichar ('9'))
end

function skipsp (str, i, imax)

# Skip past spaces in a string.

implicit none

character str(*)
integer i
integer imax
integer skipsp

logical issp

logical done

skipsp = i
done = .false.
while (!done)
{
if (imax <= skipsp)
done = .true.
else if (!issp (str(skipsp)))
done = .true.
else
skipsp = skipsp + 1
}
end

function skipns (str, i, imax)

# Skip past non-spaces in a string.

implicit none

character str(*)
integer i
integer imax
integer skipns

logical issp

logical done

skipns = i
done = .false.
while (!done)
{
if (imax <= skipns)
done = .true.
else if (issp (str(skipns)))
done = .true.
else
skipns = skipns + 1
}
end

function trimrt (str, n)

# Find the length of a string, if one ignores trailing spaces.

implicit none

character str(*)
integer n
integer trimrt

logical issp

logical done

trimrt = n
done = .false.
while (!done)
{
if (trimrt == 0)
done = .true.
else if (!issp (str(trimrt)))
done = .true.
else
trimrt = trimrt - 1
}
end

function skipal (str, i, imax)

# Skip past alphabetic characters in a string.

implicit none

character str(*)
integer i
integer imax
integer skipal

logical isalph

logical done

skipal = i
done = .false.
while (!done)
{
if (imax <= skipal)
done = .true.
else if (!isalph (ichar (str(skipal))))
done = .true.
else
skipal = skipal + 1
}
end

function skipdg (str, i, imax)

# Skip past digits in a string.

implicit none

character str(*)
integer i
integer imax
integer skipdg

logical isdgt

logical done

skipdg = i
done = .false.
while (!done)
{
if (imax <= skipdg)
done = .true.
else if (!isdgt (ichar (str(skipdg))))
done = .true.
else
skipdg = skipdg + 1
}
end

function skipnd (str, i, imax)

# Skip past nondigits in a string.

implicit none

character str(*)
integer i
integer imax
integer skipnd

logical isdgt

logical done

skipnd = i
done = .false.
while (!done)
{
if (imax <= skipnd)
done = .true.
else if (isdgt (ichar (str(skipnd))))
done = .true.
else
skipnd = skipnd + 1
}
end

function skipd1 (str, i, imax)

# Skip past digits and '-' in a string.

implicit none

character str(*)
integer i
integer imax
integer skipd1

logical isdgt

logical done

skipd1 = i
done = .false.
while (!done)
{
if (imax <= skipd1)
done = .true.
else if (!isdgt (ichar (str(skipd1))) && str(skipd1) != '-')
done = .true.
else
skipd1 = skipd1 + 1
}
end

function skipn1 (str, i, imax)

# Skip past nondigits in a string, except '-'.

implicit none

character str(*)
integer i
integer imax
integer skipn1

logical isdgt

logical done

skipn1 = i
done = .false.
while (!done)
{
if (imax <= skipn1)
done = .true.
else if (isdgt (ichar (str(skipn1))) || str(skipn1) == '-')
done = .true.
else
skipn1 = skipn1 + 1
}
end

function tolowr (c)

implicit none

character c
character tolowr

integer ic

# The following is correct for ASCII, and will work with Unicode
# code points, but is incorrect for EBCDIC.

ic = ichar (c)
if (ichar ('A') <= ic && ic <= ichar ('Z'))
ic = ic - ichar('A') + ichar('a')
tolowr = char (ic)
end

#---------------------------------------------------------------------

subroutine addstq (strngs, istrng, src, i0, n0, i, n)

# Add a quoted string to the string pool.

implicit none

character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
character src(*) # Source string.
integer i0, n0 # Index and length in source string.
integer i, n # Index and length in string pool.

integer j
logical done

1000 format ('attempt to treat an unquoted string as a quoted string')

if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
{
write (*, 1000)
stop
}

i = istrng

n = 0
j = i0 + 1
done = .false.
while (j != i0 + n0 - 1)
if (i == STRNSZ)
{
write (*, '(''string pool exhausted'')')
stop
}
else if (src(j) == char (BACKSL))
{
if (j == i0 + n0 - 1)
{
write (*, '(''incorrectly formed quoted string'')')
stop
}
if (src(j + 1) == 'n')
strngs(istrng) = char (NEWLIN)
else if (src(j + 1) == char (BACKSL))
strngs(istrng) = src(j + 1)
else
{
write (*, '(''unrecognized escape sequence'')')
stop
}
istrng = istrng + 1
n = n + 1
j = j + 2
}
else
{
strngs(istrng) = src(j)
istrng = istrng + 1
n = n + 1
j = j + 1
}
end

#---------------------------------------------------------------------

subroutine push (stack, sp, i)

implicit none

integer stack(STCKSZ)
integer sp # Stack pointer.
integer i # Value to push.

if (sp == STCKSZ)
{
write (*, '(''stack overflow in push'')')
stop
}
stack(sp) = i
sp = sp + 1
end

function pop (stack, sp)

implicit none

integer stack(STCKSZ)
integer sp # Stack pointer.
integer pop

if (sp == 1)
{
write (*, '(''stack underflow in pop'')')
stop
}
sp = sp - 1
pop = stack(sp)
end

function nstack (sp)

implicit none

integer sp # Stack pointer.
integer nstack

nstack = sp - 1 # Current cardinality of the stack.
end

#---------------------------------------------------------------------

subroutine flushl (outbuf, noutbf)

# Flush a line from the output buffer.

implicit none

character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.

character*20 fmt
integer i

if (noutbf == 0)
write (*, '()')
else
{
write (fmt, 1000) noutbf
1000 format ('(', I10, 'A)')
write (*, fmt) (outbuf(i), i = 1, noutbf)
noutbf = 0
}
end

subroutine wrtchr (outbuf, noutbf, ch)

# Write a character to output.

implicit none

character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
character ch # The character to output.

# This routine silently truncates anything that goes past the buffer
# boundary.

if (ch == char (NEWLIN))
call flushl (outbuf, noutbf)
else if (noutbf < OUTLSZ)
{
noutbf = noutbf + 1
outbuf(noutbf) = ch
}
end

subroutine wrtstr (outbuf, noutbf, str, i, n)

# Write a substring to output.

implicit none

character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
character str(*) # The string from which to output.
integer i, n # Index and length of the substring.

integer j

for (j = 0; j < n; j = j + 1)
call wrtchr (outbuf, noutbf, str(i + j))
end

subroutine wrtint (outbuf, noutbf, ival, colcnt)

# Write an integer to output.

implicit none

character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.
integer ival # The non-negative integer to print.
integer colcnt # Column count, or zero for free format.

integer skipsp

character*40 buf
integer i, j

write (buf, '(I40)') ival
i = skipsp (buf, 1, 41)
if (0 < colcnt)
for (j = 1; j < colcnt - (40 - i); j = j + 1)
call wrtchr (outbuf, noutbf, ' ')
while (i <= 40)
{
call wrtchr (outbuf, noutbf, buf(i:i))
i = i + 1
}
end

#---------------------------------------------------------------------

function strnat (str, i, n)

# Convert a string to a non-negative integer.

implicit none

character str(*)
integer i, n
integer strnat

integer j

strnat = 0
for (j = 0; j < n; j = j + 1)
strnat = (10 * strnat) + (ichar (str(i + j)) - ichar ('0'))
end

function strint (str, i, n)

# Convert a string to an integer

implicit none

character str(*)
integer i, n
integer strint

integer strnat

if (str(i) == '-')
strint = -strnat (str, i + 1, n - 1)
else
strint = strnat (str, i, n)
end

#---------------------------------------------------------------------

subroutine put1 (code, i, opcode)

# Store a 1-byte operation.

implicit none

integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address to put the code at.
integer*1 opcode

if (CODESZ - i < 1)
{
write (*, '(''address beyond the size of memory'')')
stop
}
code(i) = opcode
end

subroutine put5 (code, i, opcode, ival)

# Store a 5-byte operation.

implicit none

integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address to put the code at.
integer*1 opcode #
integer ival # Immediate integer value.

integer*4 ival32
integer*1 ival8(4)
equivalence (ival32, ival8)

if (CODESZ - i < 5)
{
write (*, '(''address beyond the size of memory'')')
stop
}
code(i) = opcode

# Native-endian storage.
ival32 = ival
code(i + 1) = ival8(1)
code(i + 2) = ival8(2)
code(i + 3) = ival8(3)
code(i + 4) = ival8(4)
end

function getimm (code, i)

# Get an immediate value from the code, at address i.

implicit none

integer*1 code(0 : CODESZ - 1) # Byte code.
integer i # Address at which the integer resides.
integer getimm # Immediate integer value.

integer*4 ival32
integer*1 ival8(4)
equivalence (ival32, ival8)

if (i < 0 || CODESZ <= i + 3)
{
write (*, '(''code address out of range'')')
stop
}

# Native-endian storage.
ival8(1) = code(i)
ival8(2) = code(i + 1)
ival8(3) = code(i + 2)
ival8(4) = code(i + 3)
getimm = ival32
end

#---------------------------------------------------------------------

subroutine rdhead (datsiz, strsiz)

# Read the header line.

implicit none

integer datsiz
integer strsiz

integer skipnd
integer skipdg
integer strnat

character line(LINESZ)
character*20 fmt
integer i1, j1, i2, j2

# Read a line of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ
read (*, fmt) line

i1 = skipnd (line, 1, LINESZ + 1)
j1 = skipdg (line, i1, LINESZ + 1)
i2 = skipnd (line, j1, LINESZ + 1)
j2 = skipdg (line, i2, LINESZ + 1)
if (i1 == j1 || i2 == j2)
{
write (*, '(''bad header line'')')
stop
}
datsiz = strnat (line, i1, j1 - i1)
strsiz = strnat (line, i2, j2 - i2)
end

subroutine rdstrs (strs, strsiz, strngs, istrng)

implicit none

integer strs(1:STRSZ, 0 : MAXSTR - 1)
integer strsiz
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.

integer trimrt
integer skipsp

character line(LINESZ)
character*20 fmt
integer j
integer i, n
integer i0, n0

# Read lines of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ

for (j = 0; j < strsiz; j = j + 1)
{
read (*, fmt) line
n0 = trimrt (line, LINESZ)
i0 = skipsp (line, 1, n0 + 1)
if (i0 == n0 + 1)
{
write (*, '(''blank line where a string should be'')')
stop
}
call addstq (strngs, istrng, line, i0, n0 - i0 + 1, i, n)
strs(STRI, j) = i
strs(STRN, j) = n
}
end

function stropc (str, i, n)

# Convert substring to an opcode.

implicit none

character str(*)
integer i, n
integer*1 stropc

stropc = -1
if (n == 2)
{
if (str(i) == 'l')
{
if (str(i + 1) == 't')
stropc = OPLT
else if (str(i + 1) == 'e')
stropc = OPLE
}
else if (str(i) == 'g')
{
if (str(i + 1) == 't')
stropc = OPGT
else if (str(i + 1) == 'e')
stropc = OPGE
}
else if (str(i) == 'e' && str(i + 1) == 'q')
stropc = OPEQ
else if (str(i) == 'n' && str(i + 1) == 'e')
stropc = OPNE
else if (str(i) == 'o' && str(i + 1) == 'r')
stropc = OPOR
else if (str(i) == 'j' && str(i + 1) == 'z')
stropc = OPJZ
}
else if (n == 3)
{
if (str(i) == 'a')
{
if (str(i + 1) == 'd' && str(i + 2) == 'd')
stropc = OPADD
else if (str(i + 1) == 'n' && str(i + 2) == 'd')
stropc = OPAND
}
else if (str(i) == 'm')
{
if (str(i + 1) == 'o' && str(i + 2) == 'd')
stropc = OPMOD
else if (str(i + 1) == 'u' && str(i + 2) == 'l')
stropc = OPMUL
}
else if (str(i) == 'n')
{
if (str(i + 1) == 'e' && str(i + 2) == 'g')
stropc = OPNEG
else if (str(i + 1) == 'o' && str(i + 2) == 't')
stropc = OPNOT
}
else if (str(i) == 's' && str(i + 1) == 'u' _
&& str(i + 2) == 'b')
stropc = OPSUB
else if (str(i) == 'd' && str(i + 1) == 'i' _
&& str(i + 2) == 'v')
stropc = OPDIV
else if (str(i) == 'j' && str(i + 1) == 'm' _
&& str(i + 2) == 'p')
stropc = OPJMP
}
else if (n == 4)
{
if (str(i) == 'p')
{
if (str(i + 1) == 'r' && str(i + 2) == 't')
{
if (str(i + 3) == 'c')
stropc = OPPRTC
else if (str(i + 3) == 'i')
stropc = OPPRTI
else if (str(i + 3) == 's')
stropc = OPPRTS
}
if (str(i + 1) == 'u' && str(i + 2) == 's' _
&& str(i + 3) == 'h')
stropc = OPPUSH
}
else if (str(i) == 'h' && str(i + 1) == 'a' _
&& str(i + 2) == 'l' && str(i + 3) == 't')
stropc = OPHALT
}
else if (n == 5)
{
if (str(i) == 'f' && str(i + 1) == 'e' && str(i + 2) == 't' _
&& str(i + 3) == 'c' && str(i + 4) == 'h')
stropc = OPFTCH
if (str(i) == 's' && str(i + 1) == 't' && str(i + 2) == 'o' _
&& str(i + 3) == 'r' && str(i + 4) == 'e')
stropc = OPSTOR
}
if (stropc == -1)
{
write (*, '(''unrecognized opcode name'')')
stop
}
end

subroutine rdops (code)

# Read the opcodes and their immediate values.

implicit none

integer*1 code(0 : CODESZ - 1) # The byte code.

integer trimrt
integer skipsp
integer skipal
integer skipdg
integer skipd1
integer skipn1
integer strnat
integer strint
integer*1 stropc
character tolowr

character line(LINESZ)
character*20 fmt
integer stat
integer n
integer j
integer iaddr, jaddr # Address index and size.
integer iopnm, jopnm # Opcode name index and size.
integer iarg, jarg
integer addr
integer arg
integer*1 opcode

# Read lines of text as an array of characters.
write (fmt, '(''('', I10, ''A)'')') LINESZ

read (*, fmt, iostat = stat) line
while (stat == 0)
{
n = trimrt (line, LINESZ)

for (j = 1; j <= n; j = j + 1)
line(j) = tolowr (line(j))

iaddr = skipsp (line, 1, n + 1)
jaddr = skipdg (line, iaddr, n + 1)
addr = strnat (line, iaddr, jaddr - iaddr)

iopnm = skipsp (line, jaddr, n + 1)
jopnm = skipal (line, iopnm, n + 1)
opcode = stropc (line, iopnm, jopnm - iopnm)

if (opcode == OPPUSH || opcode == OPFTCH || opcode == OPSTOR _
|| opcode == OPJMP || opcode == OPJZ)
{
iarg = skipn1 (line, jopnm, n + 1)
jarg = skipd1 (line, iarg, n + 1)
arg = strint (line, iarg, jarg - iarg)
call put5 (code, addr, opcode, arg)
}
else
call put1 (code, addr, opcode)

read (*, fmt, iostat = stat) line
}
end

subroutine rdcode (strs, strngs, istrng, code)

# Read and parse the "assembly" code.

implicit none

integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer*1 code(0 : CODESZ - 1) # The byte code.

integer datsiz
integer strsiz

call rdhead (datsiz, strsiz)
if (MAXVAR < datsiz)
{
write (*, '(''too many variables'')')
stop
}
if (MAXSTR < strsiz)
{
write (*, '(''too many strings'')')
stop
}

call rdstrs (strs, strsiz, strngs, istrng)
call rdops (code)
end

#---------------------------------------------------------------------

subroutine stkbin (sp)

implicit none

integer sp

if (sp < 3)
{
write (*, '(''stack underflow in binary operation'')')
stop
}
end

subroutine stkun (sp)

implicit none

integer sp

if (sp < 2)
{
write (*, '(''stack underflow in unary operation'')')
stop
}
end

function logl2i (b)

implicit none

logical b
integer logl2i

if (b)
logl2i = 1
else
logl2i = 0
end

subroutine rncode (strs, strngs, code, outbuf, noutbf)

# Run the code.

implicit none

integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer*1 code(0 : CODESZ - 1) # The byte code.
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.

integer logl2i
integer getimm
integer pop

integer stack(STCKSZ)
integer data(0 : MAXVAR - 1)
integer sp # Stack pointer.

integer pc # Program counter.
integer ip # Instruction pointer.
equivalence (pc, ip) # LOL, use either name. :)

integer i, n
integer*1 opcode
logical done

sp = 1
ip = 0

done = .false.
while (!done)
{
if (ip < 0 || CODESZ <= ip)
{
write (*, '(''code address out of range'')')
stop
}
opcode = code(ip)
ip = ip + 1
if (opcode == OPADD)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) + stack(sp)
}
else if (opcode == OPSUB)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) - stack(sp)
}
else if (opcode == OPMUL)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) * stack(sp)
}
else if (opcode == OPDIV)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = stack (sp - 1) / stack(sp)
}
else if (opcode == OPMOD)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = mod (stack (sp - 1), stack(sp))
}
else if (opcode == OPLT)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) < stack(sp))
}
else if (opcode == OPGT)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) > stack(sp))
}
else if (opcode == OPLE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) <= stack(sp))
}
else if (opcode == OPGE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) >= stack(sp))
}
else if (opcode == OPEQ)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) == stack(sp))
}
else if (opcode == OPNE)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = logl2i (stack (sp - 1) != stack(sp))
}
else if (opcode == OPAND)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = _
logl2i (stack (sp - 1) != 0 && stack(sp) != 0)
}
else if (opcode == OPOR)
{
call stkbin (sp)
sp = sp - 1
stack(sp - 1) = _
logl2i (stack (sp - 1) != 0 || stack(sp) != 0)
}
else if (opcode == OPNEG)
{
call stkun (sp)
stack(sp - 1) = -stack(sp - 1)
}
else if (opcode == OPNOT)
{
call stkun (sp)
stack(sp - 1) = logl2i (stack(sp - 1) == 0)
}
else if (opcode == OPPRTC)
{
call wrtchr (outbuf, noutbf, char (pop (stack, sp)))
}
else if (opcode == OPPRTI)
{
call wrtint (outbuf, noutbf, pop (stack, sp), 0)
}
else if (opcode == OPPRTS)
{
i = pop (stack, sp)
if (i < 0 || MAXSTR <= i)
{
write (*, '(''string address out of range'')')
stop
}
n = strs(STRN, i)
i = strs(STRI, i)
call wrtstr (outbuf, noutbf, strngs, i, n)
}
else if (opcode == OPFTCH)
{
i = getimm (code, ip)
ip = ip + 4
if (i < 0 || MAXVAR <= i)
{
write (*, '(''data address out of range'')')
stop
}
call push (stack, sp, data(i))
}
else if (opcode == OPSTOR)
{
i = getimm (code, ip)
ip = ip + 4
if (i < 0 || MAXVAR <= i)
{
write (*, '(''data address out of range'')')
stop
}
data(i) = pop (stack, sp)
}
else if (opcode == OPPUSH)
{
call push (stack, sp, getimm (code, ip))
ip = ip + 4
}
else if (opcode == OPJMP)
{
ip = ip + getimm (code, ip)
}
else if (opcode == OPJZ)
{
if (pop (stack, sp) == 0)
ip = ip + getimm (code, ip)
else
ip = ip + 4
}
else
{
# Halt on OPHALT or any unrecognized code.
done = .true.
}
}
end

#---------------------------------------------------------------------

program vm

implicit none

integer strs(1:STRSZ, 0 : MAXSTR - 1)
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer*1 code(0 : CODESZ - 1) # The byte code.
character outbuf(OUTLSZ) # Output line buffer.
integer noutbf # Number of characters in outbuf.

integer j

istrng = 1
noutbf = 0

for (j = 0; j < CODESZ; j = j + 1)
code(j) = OPHALT

call rdcode (strs, strngs, istrng, code)
call rncode (strs, strngs, code, outbuf, noutbf)

if (noutbf != 0)
call flushl (outbuf, noutbf)
end

######################################################################</lang>






=={{header|Scala}}==
=={{header|Scala}}==
Retrieved from "https://rosettacode.org/wiki/Compiler/virtual_machine_interpreter"