1234 lines
26 KiB
Plaintext
1234 lines
26 KiB
Plaintext
######################################################################
|
|
#
|
|
# 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
|
|
|
|
######################################################################
|