Compiler/virtual machine interpreter: Difference between revisions
Compiler/virtual machine interpreter (view source)
Revision as of 20:26, 28 April 2022
, 2 years ago→{{header|Scala}}
Line 12,054:
count is: 8
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}}==
| |||