1458 lines
40 KiB
Plaintext
1458 lines
40 KiB
Plaintext
######################################################################
|
|
#
|
|
# The Rosetta Code code generator in Ratfor 77.
|
|
#
|
|
#
|
|
# In FORTRAN 77 and therefore in Ratfor 77, there is no way to specify
|
|
# that a value should be put on a call stack. Therefore there is no
|
|
# way to implement recursive algorithms in Ratfor 77 (although see the
|
|
# Ratfor for the "syntax analyzer" task, where a recursive language is
|
|
# implemented *in* Ratfor). We are forced to use non-recursive
|
|
# algorithms.
|
|
#
|
|
# How to deal with FORTRAN 77 input is another 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 gen-in-ratfor.r > gen-in-ratfor.f
|
|
# f2c -C -Nc80 gen-in-ratfor.f
|
|
# cc gen-in-ratfor.c -lf2c
|
|
# ./a.out < compiler-tests/primes.ast
|
|
#
|
|
# With gfortran, a little differently:
|
|
#
|
|
# ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
|
|
# gfortran -fcheck=all -std=legacy gen-in-ratfor.f
|
|
# ./a.out < compiler-tests/primes.ast
|
|
#
|
|
#
|
|
# 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(NODSSZ, 4096) # Size of the nodes 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(NEWLIN, 10) # The Unix newline character (ASCII LF).
|
|
define(DQUOTE, 34) # The double quote character.
|
|
define(BACKSL, 92) # The backslash character.
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
define(NODESZ, 3)
|
|
define(NNEXTF, 1) # Index for next-free.
|
|
define(NTAG, 1) # Index for the tag.
|
|
# For an internal node --
|
|
define(NLEFT, 2) # Index for the left node.
|
|
define(NRIGHT, 3) # Index for the right node.
|
|
# For a leaf node --
|
|
define(NITV, 2) # Index for the string pool index.
|
|
define(NITN, 3) # Length of the value.
|
|
|
|
define(NIL, -1) # Nil node.
|
|
|
|
define(RGT, 10000)
|
|
define(STAGE2, 20000)
|
|
define(STAGE3, 30000)
|
|
define(STAGE4, 40000)
|
|
|
|
# The following all must be less than RGT.
|
|
define(NDID, 0)
|
|
define(NDSTR, 1)
|
|
define(NDINT, 2)
|
|
define(NDSEQ, 3)
|
|
define(NDIF, 4)
|
|
define(NDPRTC, 5)
|
|
define(NDPRTS, 6)
|
|
define(NDPRTI, 7)
|
|
define(NDWHIL, 8)
|
|
define(NDASGN, 9)
|
|
define(NDNEG, 10)
|
|
define(NDNOT, 11)
|
|
define(NDMUL, 12)
|
|
define(NDDIV, 13)
|
|
define(NDMOD, 14)
|
|
define(NDADD, 15)
|
|
define(NDSUB, 16)
|
|
define(NDLT, 17)
|
|
define(NDLE, 18)
|
|
define(NDGT, 19)
|
|
define(NDGE, 20)
|
|
define(NDEQ, 21)
|
|
define(NDNE, 22)
|
|
define(NDAND, 23)
|
|
define(NDOR, 24)
|
|
|
|
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 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
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine addstr (strngs, istrng, src, i0, n0, i, n)
|
|
|
|
# Add a 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
|
|
|
|
if (STRNSZ < istrng + (n0 - 1))
|
|
{
|
|
write (*, '(''string pool exhausted'')')
|
|
stop
|
|
}
|
|
if (n0 == 0)
|
|
{
|
|
i = 0
|
|
n = 0
|
|
}
|
|
else
|
|
{
|
|
for (j = 0; j < n0; j = j + 1)
|
|
strngs(istrng + j) = src(i0 + j)
|
|
i = istrng
|
|
n = n0
|
|
istrng = istrng + n0
|
|
}
|
|
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 initnd (nodes, frelst)
|
|
|
|
# Initialize the nodes pool.
|
|
|
|
implicit none
|
|
|
|
integer nodes (NODESZ, NODSSZ)
|
|
integer frelst # Head of the free list.
|
|
|
|
integer i
|
|
|
|
for (i = 1; i < NODSSZ; i = i + 1)
|
|
nodes(NNEXTF, i) = i + 1
|
|
nodes(NNEXTF, NODSSZ) = NIL
|
|
frelst = 1
|
|
end
|
|
|
|
subroutine newnod (nodes, frelst, i)
|
|
|
|
# Get the index for a new node taken from the free list.
|
|
|
|
integer nodes (NODESZ, NODSSZ)
|
|
integer frelst # Head of the free list.
|
|
integer i # Index of the new node.
|
|
|
|
integer j
|
|
|
|
if (frelst == NIL)
|
|
{
|
|
write (*, '(''nodes pool exhausted'')')
|
|
stop
|
|
}
|
|
i = frelst
|
|
frelst = nodes(NNEXTF, frelst)
|
|
for (j = 1; j <= NODESZ; j = j + 1)
|
|
nodes(j, i) = 0
|
|
end
|
|
|
|
subroutine frenod (nodes, frelst, i)
|
|
|
|
# Return a node to the free list.
|
|
|
|
integer nodes (NODESZ, NODSSZ)
|
|
integer frelst # Head of the free list.
|
|
integer i # Index of the node to free.
|
|
|
|
nodes(NNEXTF, i) = frelst
|
|
frelst = i
|
|
end
|
|
|
|
function strtag (str, i, n)
|
|
|
|
implicit none
|
|
|
|
character str(*)
|
|
integer i, n
|
|
integer strtag
|
|
|
|
character*16 s
|
|
integer j
|
|
|
|
for (j = 0; j < 16; j = j + 1)
|
|
if (j < n)
|
|
s(j + 1 : j + 1) = str(i + j)
|
|
else
|
|
s(j + 1 : j + 1) = ' '
|
|
|
|
if (s == "Identifier ")
|
|
strtag = NDID
|
|
else if (s == "String ")
|
|
strtag = NDSTR
|
|
else if (s == "Integer ")
|
|
strtag = NDINT
|
|
else if (s == "Sequence ")
|
|
strtag = NDSEQ
|
|
else if (s == "If ")
|
|
strtag = NDIF
|
|
else if (s == "Prtc ")
|
|
strtag = NDPRTC
|
|
else if (s == "Prts ")
|
|
strtag = NDPRTS
|
|
else if (s == "Prti ")
|
|
strtag = NDPRTI
|
|
else if (s == "While ")
|
|
strtag = NDWHIL
|
|
else if (s == "Assign ")
|
|
strtag = NDASGN
|
|
else if (s == "Negate ")
|
|
strtag = NDNEG
|
|
else if (s == "Not ")
|
|
strtag = NDNOT
|
|
else if (s == "Multiply ")
|
|
strtag = NDMUL
|
|
else if (s == "Divide ")
|
|
strtag = NDDIV
|
|
else if (s == "Mod ")
|
|
strtag = NDMOD
|
|
else if (s == "Add ")
|
|
strtag = NDADD
|
|
else if (s == "Subtract ")
|
|
strtag = NDSUB
|
|
else if (s == "Less ")
|
|
strtag = NDLT
|
|
else if (s == "LessEqual ")
|
|
strtag = NDLE
|
|
else if (s == "Greater ")
|
|
strtag = NDGT
|
|
else if (s == "GreaterEqual ")
|
|
strtag = NDGE
|
|
else if (s == "Equal ")
|
|
strtag = NDEQ
|
|
else if (s == "NotEqual ")
|
|
strtag = NDNE
|
|
else if (s == "And ")
|
|
strtag = NDAND
|
|
else if (s == "Or ")
|
|
strtag = NDOR
|
|
else if (s == "; ")
|
|
strtag = NIL
|
|
else
|
|
{
|
|
write (*, '(''unrecognized input line: '', A16)') s
|
|
stop
|
|
}
|
|
end
|
|
|
|
subroutine readln (strngs, istrng, tag, iarg, narg)
|
|
|
|
# Read a line of the AST input.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer tag # The node tag or NIL.
|
|
integer iarg # Index of an argument in the string pool.
|
|
integer narg # Length of an argument in the string pool.
|
|
|
|
integer trimrt
|
|
integer strtag
|
|
integer skipsp
|
|
integer skipns
|
|
|
|
character line(LINESZ)
|
|
character*20 fmt
|
|
integer i, j, n
|
|
|
|
# Read a line of text as an array of characters.
|
|
write (fmt, '(''('', I10, ''A)'')') LINESZ
|
|
read (*, fmt) line
|
|
|
|
n = trimrt (line, LINESZ)
|
|
|
|
i = skipsp (line, 1, n + 1)
|
|
j = skipns (line, i, n + 1)
|
|
tag = strtag (line, i, j - i)
|
|
|
|
i = skipsp (line, j, n + 1)
|
|
call addstr (strngs, istrng, line, i, (n + 1) - i, iarg, narg)
|
|
end
|
|
|
|
function hasarg (tag)
|
|
|
|
implicit none
|
|
|
|
integer tag
|
|
logical hasarg
|
|
|
|
hasarg = (tag == NDID || tag == NDINT || tag == NDSTR)
|
|
end
|
|
|
|
subroutine rdast (strngs, istrng, nodes, frelst, iast)
|
|
|
|
# Read in the AST. A non-recursive algorithm is used.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer nodes (NODESZ, NODSSZ) # Nodes pool.
|
|
integer frelst # Head of the free list.
|
|
integer iast # Index of root node of the AST.
|
|
|
|
integer nstack
|
|
integer pop
|
|
logical hasarg
|
|
|
|
integer stack(STCKSZ)
|
|
integer sp # Stack pointer.
|
|
integer tag, iarg, narg
|
|
integer i, j, k
|
|
|
|
sp = 1
|
|
|
|
call readln (strngs, istrng, tag, iarg, narg)
|
|
if (tag == NIL)
|
|
iast = NIL
|
|
else
|
|
{
|
|
call newnod (nodes, frelst, i)
|
|
iast = i
|
|
nodes(NTAG, i) = tag
|
|
nodes(NITV, i) = 0
|
|
nodes(NITN, i) = 0
|
|
if (hasarg (tag))
|
|
{
|
|
nodes(NITV, i) = iarg
|
|
nodes(NITN, i) = narg
|
|
}
|
|
else
|
|
{
|
|
call push (stack, sp, i + RGT)
|
|
call push (stack, sp, i)
|
|
while (nstack (sp) != 0)
|
|
{
|
|
j = pop (stack, sp)
|
|
k = mod (j, RGT)
|
|
call readln (strngs, istrng, tag, iarg, narg)
|
|
if (tag == NIL)
|
|
i = NIL
|
|
else
|
|
{
|
|
call newnod (nodes, frelst, i)
|
|
nodes(NTAG, i) = tag
|
|
if (hasarg (tag))
|
|
{
|
|
nodes(NITV, i) = iarg
|
|
nodes(NITN, i) = narg
|
|
}
|
|
else
|
|
{
|
|
call push (stack, sp, i + RGT)
|
|
call push (stack, sp, i)
|
|
}
|
|
}
|
|
if (j == k)
|
|
nodes(NLEFT, k) = i
|
|
else
|
|
nodes(NRIGHT, k) = i
|
|
}
|
|
}
|
|
}
|
|
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 a non-negative 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
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
define(VARSZ, 3)
|
|
define(VNAMEI, 1) # Variable name's index in the string pool.
|
|
define(VNAMEN, 2) # Length of the name.
|
|
define(VVALUE, 3) # Variable's number in the VM's data pool.
|
|
|
|
function fndvar (vars, numvar, strngs, istrng, i0, n0)
|
|
|
|
implicit none
|
|
|
|
integer vars(VARSZ, MAXVAR) # Variables.
|
|
integer numvar # Number of variables.
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer i0, n0 # Index and length in the string pool.
|
|
integer fndvar # The location of the variable.
|
|
|
|
integer j, k
|
|
integer i, n
|
|
logical done1
|
|
logical done2
|
|
|
|
j = 1
|
|
done1 = .false.
|
|
while (!done1)
|
|
if (j == numvar + 1)
|
|
done1 = .true.
|
|
else if (n0 == vars(VNAMEN, j))
|
|
{
|
|
k = 0
|
|
done2 = .false.
|
|
while (!done2)
|
|
if (n0 <= k)
|
|
done2 = .true.
|
|
else if (strngs(i0 + k) == strngs(vars(VNAMEI, j) + k))
|
|
k = k + 1
|
|
else
|
|
done2 = .true.
|
|
if (k < n0)
|
|
j = j + 1
|
|
else
|
|
{
|
|
done2 = .true.
|
|
done1 = .true.
|
|
}
|
|
}
|
|
else
|
|
j = j + 1
|
|
|
|
if (j == numvar + 1)
|
|
{
|
|
if (numvar == MAXVAR)
|
|
{
|
|
write (*, '(''too many variables'')')
|
|
stop
|
|
}
|
|
numvar = numvar + 1
|
|
call addstr (strngs, istrng, strngs, i0, n0, i, n)
|
|
vars(VNAMEI, numvar) = i
|
|
vars(VNAMEN, numvar) = n
|
|
vars(VVALUE, numvar) = numvar - 1
|
|
fndvar = numvar
|
|
}
|
|
else
|
|
fndvar = j
|
|
end
|
|
|
|
define(STRSZ, 3)
|
|
define(STRI, 1) # String's index in this program's string pool.
|
|
define(STRN, 2) # Length of the string.
|
|
define(STRNO, 3) # String's number in the VM's string pool.
|
|
|
|
function fndstr (strs, numstr, strngs, istrng, i0, n0)
|
|
|
|
implicit none
|
|
|
|
integer strs(STRSZ, MAXSTR) # Strings for the VM's string pool.
|
|
integer numstr # Number of such strings.
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer i0, n0 # Index and length in the string pool.
|
|
integer fndstr # The location of the string in the VM's string pool.
|
|
|
|
integer j, k
|
|
integer i, n
|
|
logical done1
|
|
logical done2
|
|
|
|
j = 1
|
|
done1 = .false.
|
|
while (!done1)
|
|
if (j == numstr + 1)
|
|
done1 = .true.
|
|
else if (n0 == strs(STRN, j))
|
|
{
|
|
k = 0
|
|
done2 = .false.
|
|
while (!done2)
|
|
if (n0 <= k)
|
|
done2 = .true.
|
|
else if (strngs(i0 + k) == strngs(strs(STRI, j) + k))
|
|
k = k + 1
|
|
else
|
|
done2 = .true.
|
|
if (k < n0)
|
|
j = j + 1
|
|
else
|
|
{
|
|
done2 = .true.
|
|
done1 = .true.
|
|
}
|
|
}
|
|
else
|
|
j = j + 1
|
|
|
|
if (j == numstr + 1)
|
|
{
|
|
if (numstr == MAXSTR)
|
|
{
|
|
write (*, '(''too many string literals'')')
|
|
stop
|
|
}
|
|
numstr = numstr + 1
|
|
call addstr (strngs, istrng, strngs, i0, n0, i, n)
|
|
strs(STRI, numstr) = i
|
|
strs(STRN, numstr) = n
|
|
strs(STRNO, numstr) = numstr - 1
|
|
fndstr = numstr
|
|
}
|
|
else
|
|
fndstr = j
|
|
end
|
|
|
|
function strint (strngs, i, n)
|
|
|
|
# Convert a string to a non-negative integer.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer i, n
|
|
integer strint
|
|
|
|
integer j
|
|
|
|
strint = 0
|
|
for (j = 0; j < n; j = j + 1)
|
|
strint = (10 * strint) + (ichar (strngs(i + j)) - ichar ('0'))
|
|
end
|
|
|
|
subroutine put1 (code, ncode, i, opcode)
|
|
|
|
# Store a 1-byte operation.
|
|
|
|
implicit none
|
|
|
|
integer code(0 : CODESZ - 1) # Generated code.
|
|
integer ncode # Number of VM bytes in the code.
|
|
integer i # Address to put the code at.
|
|
integer opcode
|
|
|
|
if (CODESZ - i < 1)
|
|
{
|
|
write (*, '(''address beyond the size of memory'')')
|
|
stop
|
|
}
|
|
code(i) = opcode
|
|
ncode = max (ncode, i + 1)
|
|
end
|
|
|
|
subroutine put5 (code, ncode, i, opcode, ival)
|
|
|
|
# Store a 5-byte operation.
|
|
|
|
implicit none
|
|
|
|
integer code(0 : CODESZ - 1) # Generated code.
|
|
integer ncode # Number of VM bytes in the code.
|
|
integer i # Address to put the code at.
|
|
integer opcode
|
|
integer ival # Immediate integer value.
|
|
|
|
if (CODESZ - i < 5)
|
|
{
|
|
write (*, '(''address beyond the size of memory'')')
|
|
stop
|
|
}
|
|
code(i) = opcode
|
|
code(i + 1) = ival # Do not bother to break the integer into bytes.
|
|
code(i + 2) = 0
|
|
code(i + 3) = 0
|
|
code(i + 4) = 0
|
|
ncode = max (ncode, i + 5)
|
|
end
|
|
|
|
subroutine compil (vars, numvar, _
|
|
strs, numstr, _
|
|
strngs, istrng, _
|
|
nodes, frelst, _
|
|
code, ncode, iast)
|
|
|
|
# Compile the AST to virtual machine code. The algorithm employed is
|
|
# non-recursive.
|
|
|
|
implicit none
|
|
|
|
integer vars(VARSZ, MAXVAR) # Variables.
|
|
integer numvar # Number of variables.
|
|
integer strs(STRSZ, MAXSTR) # Strings for the VM's string pool.
|
|
integer numstr # Number of such strings.
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer nodes (NODESZ, NODSSZ) # Nodes pool.
|
|
integer frelst # Head of the free list.
|
|
integer code(0 : CODESZ - 1) # Generated code.
|
|
integer ncode # Number of VM bytes in the code.
|
|
integer iast # Root node of the AST.
|
|
|
|
integer fndvar
|
|
integer fndstr
|
|
integer nstack
|
|
integer pop
|
|
integer strint
|
|
|
|
integer xstack(STCKSZ) # Node stack.
|
|
integer ixstck # Node stack pointer.
|
|
integer i
|
|
integer i0, n0
|
|
integer tag
|
|
integer ivar
|
|
integer inode1, inode2, inode3
|
|
integer addr1, addr2
|
|
|
|
ixstck = 1
|
|
call push (xstack, ixstck, iast)
|
|
while (nstack (ixstck) != 0)
|
|
{
|
|
i = pop (xstack, ixstck)
|
|
if (i == NIL)
|
|
tag = NIL
|
|
else
|
|
tag = nodes(NTAG, i)
|
|
if (tag == NIL)
|
|
continue
|
|
else if (tag < STAGE2)
|
|
{
|
|
if (tag == NDSEQ)
|
|
{
|
|
if (nodes(NRIGHT, i) != NIL)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
if (nodes(NLEFT, i) != NIL)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDID)
|
|
{
|
|
# Fetch the value of a variable.
|
|
i0 = nodes(NITV, i)
|
|
n0 = nodes(NITN, i)
|
|
ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
|
|
ivar = vars(VVALUE, ivar)
|
|
call put5 (code, ncode, ncode, OPFTCH, ivar)
|
|
}
|
|
else if (tag == NDINT)
|
|
{
|
|
# Push the value of an integer literal.
|
|
i0 = nodes(NITV, i)
|
|
n0 = nodes(NITN, i)
|
|
call put5 (code, ncode, ncode, OPPUSH, _
|
|
strint (strngs, i0, n0))
|
|
}
|
|
else if (tag == NDNEG)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDNEG + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDNOT)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDNOT + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDAND)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDAND + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDOR)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDOR + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDADD)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDADD + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDSUB)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDSUB + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDMUL)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDMUL + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDDIV)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDDIV + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDMOD)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDMOD + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDLT)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDLT + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDLE)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDLE + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDGT)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDGT + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDGE)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDGE + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDEQ)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDEQ + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDNE)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDNE + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDASGN)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDASGN + STAGE2
|
|
nodes(NITV, inode1) = nodes(NITV, nodes(NLEFT, i))
|
|
nodes(NITN, inode1) = nodes(NITN, nodes(NLEFT, i))
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NRIGHT, i))
|
|
}
|
|
else if (tag == NDPRTS)
|
|
{
|
|
i0 = nodes(NITV, nodes(NLEFT, i))
|
|
n0 = nodes(NITN, nodes(NLEFT, i))
|
|
ivar = fndstr (strs, numstr, strngs, istrng, i0, n0)
|
|
ivar = strs(STRNO, ivar)
|
|
call put5 (code, ncode, ncode, OPPUSH, ivar)
|
|
call put1 (code, ncode, ncode, OPPRTS)
|
|
}
|
|
else if (tag == NDPRTC)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDPRTC + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDPRTI)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDPRTI + STAGE2
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDWHIL)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDWHIL + STAGE2
|
|
nodes(NLEFT, inode1) = nodes(NRIGHT, i) # Loop body.
|
|
nodes(NRIGHT, inode1) = ncode # Addr. of top of loop.
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
else if (tag == NDIF)
|
|
{
|
|
call newnod (nodes, frelst, inode1)
|
|
nodes(NTAG, inode1) = NDIF + STAGE2
|
|
# The "then" and "else" clauses, respectively:
|
|
nodes(NLEFT, inode1) = nodes(NLEFT, nodes(NRIGHT, i))
|
|
nodes(NRIGHT, inode1) = nodes(NRIGHT, nodes(NRIGHT, i))
|
|
call push (xstack, ixstck, inode1)
|
|
call push (xstack, ixstck, nodes(NLEFT, i))
|
|
}
|
|
}
|
|
else
|
|
{
|
|
if (tag == NDNEG + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPNEG)
|
|
}
|
|
else if (tag == NDNOT + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPNOT)
|
|
}
|
|
else if (tag == NDAND + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPAND)
|
|
}
|
|
else if (tag == NDOR + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPOR)
|
|
}
|
|
else if (tag == NDADD + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPADD)
|
|
}
|
|
else if (tag == NDSUB + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPSUB)
|
|
}
|
|
else if (tag == NDMUL + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPMUL)
|
|
}
|
|
else if (tag == NDDIV + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPDIV)
|
|
}
|
|
else if (tag == NDMOD + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPMOD)
|
|
}
|
|
else if (tag == NDLT + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPLT)
|
|
}
|
|
else if (tag == NDLE + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPLE)
|
|
}
|
|
else if (tag == NDGT + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPGT)
|
|
}
|
|
else if (tag == NDGE + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPGE)
|
|
}
|
|
else if (tag == NDEQ + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPEQ)
|
|
}
|
|
else if (tag == NDNE + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPNE)
|
|
}
|
|
else if (tag == NDASGN + STAGE2)
|
|
{
|
|
i0 = nodes(NITV, i)
|
|
n0 = nodes(NITN, i)
|
|
call frenod (nodes, frelst, i)
|
|
ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
|
|
ivar = vars(VVALUE, ivar)
|
|
call put5 (code, ncode, ncode, OPSTOR, ivar)
|
|
}
|
|
else if (tag == NDPRTC + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPPRTC)
|
|
}
|
|
else if (tag == NDPRTI + STAGE2)
|
|
{
|
|
call frenod (nodes, frelst, i)
|
|
call put1 (code, ncode, ncode, OPPRTI)
|
|
}
|
|
else if (tag == NDWHIL + STAGE2)
|
|
{
|
|
inode1 = nodes(NLEFT, i) # Loop body.
|
|
addr1 = nodes(NRIGHT, i) # Addr. of top of loop.
|
|
call frenod (nodes, frelst, i)
|
|
call put5 (code, ncode, ncode, OPJZ, 0)
|
|
call newnod (nodes, frelst, inode2)
|
|
nodes(NTAG, inode2) = NDWHIL + STAGE3
|
|
nodes(NLEFT, inode2) = addr1 # Top of loop.
|
|
nodes(NRIGHT, inode2) = ncode - 4 # Fixup address.
|
|
call push (xstack, ixstck, inode2)
|
|
call push (xstack, ixstck, inode1)
|
|
}
|
|
else if (tag == NDWHIL + STAGE3)
|
|
{
|
|
addr1 = nodes(NLEFT, i) # Top of loop.
|
|
addr2 = nodes(NRIGHT, i) # Fixup address.
|
|
call frenod (nodes, frelst, i)
|
|
call put5 (code, ncode, ncode, OPJMP, addr1)
|
|
code(addr2) = ncode
|
|
}
|
|
else if (tag == NDIF + STAGE2)
|
|
{
|
|
inode1 = nodes(NLEFT, i) # "Then" clause.
|
|
inode2 = nodes(NRIGHT, i) # "Else" clause.
|
|
call frenod (nodes, frelst, i)
|
|
call put5 (code, ncode, ncode, OPJZ, 0)
|
|
call newnod (nodes, frelst, inode3)
|
|
nodes(NTAG, inode3) = NDIF + STAGE3
|
|
nodes(NLEFT, inode3) = ncode - 4 # Fixup address.
|
|
nodes(NRIGHT, inode3) = inode2 # "Else" clause.
|
|
call push (xstack, ixstck, inode3)
|
|
call push (xstack, ixstck, inode1)
|
|
}
|
|
else if (tag == NDIF + STAGE3)
|
|
{
|
|
addr1 = nodes(NLEFT, i) # Fixup address.
|
|
inode1 = nodes(NRIGHT, i) # "Else" clause.
|
|
call frenod (nodes, frelst, i)
|
|
if (inode2 == NIL)
|
|
code(addr1) = ncode
|
|
else
|
|
{
|
|
call put5 (code, ncode, ncode, OPJMP, 0)
|
|
addr2 = ncode - 4 # Another fixup address.
|
|
code(addr1) = ncode
|
|
call newnod (nodes, frelst, inode2)
|
|
nodes(NTAG, inode2) = NDIF + STAGE4
|
|
nodes(NLEFT, inode2) = addr2
|
|
call push (xstack, ixstck, inode2)
|
|
call push (xstack, ixstck, inode1)
|
|
}
|
|
}
|
|
else if (tag == NDIF + STAGE4)
|
|
{
|
|
addr1 = nodes(NLEFT, i) # Fixup address.
|
|
call frenod (nodes, frelst, i)
|
|
code(addr1) = ncode
|
|
}
|
|
}
|
|
}
|
|
call put1 (code, ncode, ncode, OPHALT)
|
|
end
|
|
|
|
function opname (opcode)
|
|
|
|
implicit none
|
|
|
|
integer opcode
|
|
character*8 opname
|
|
|
|
if (opcode == OPHALT)
|
|
opname = 'halt '
|
|
else if (opcode == OPADD)
|
|
opname = 'add '
|
|
else if (opcode == OPSUB)
|
|
opname = 'sub '
|
|
else if (opcode == OPMUL)
|
|
opname = 'mul '
|
|
else if (opcode == OPDIV)
|
|
opname = 'div '
|
|
else if (opcode == OPMOD)
|
|
opname = 'mod '
|
|
else if (opcode == OPLT)
|
|
opname = 'lt '
|
|
else if (opcode == OPGT)
|
|
opname = 'gt '
|
|
else if (opcode == OPLE)
|
|
opname = 'le '
|
|
else if (opcode == OPGE)
|
|
opname = 'ge '
|
|
else if (opcode == OPEQ)
|
|
opname = 'eq '
|
|
else if (opcode == OPNE)
|
|
opname = 'ne '
|
|
else if (opcode == OPAND)
|
|
opname = 'and '
|
|
else if (opcode == OPOR)
|
|
opname = 'or '
|
|
else if (opcode == OPNEG)
|
|
opname = 'neg '
|
|
else if (opcode == OPNOT)
|
|
opname = 'not '
|
|
else if (opcode == OPPRTC)
|
|
opname = 'prtc '
|
|
else if (opcode == OPPRTI)
|
|
opname = 'prti '
|
|
else if (opcode == OPPRTS)
|
|
opname = 'prts '
|
|
else if (opcode == OPFTCH)
|
|
opname = 'fetch '
|
|
else if (opcode == OPSTOR)
|
|
opname = 'store '
|
|
else if (opcode == OPPUSH)
|
|
opname = 'push '
|
|
else if (opcode == OPJMP)
|
|
opname = 'jmp '
|
|
else if (opcode == OPJZ)
|
|
opname = 'jz '
|
|
else
|
|
{
|
|
write (*, '(''Unrecognized opcode: '', I5)') opcode
|
|
stop
|
|
}
|
|
end
|
|
|
|
subroutine prprog (numvar, strs, numstr, strngs, istrng, _
|
|
code, ncode, outbuf, noutbf)
|
|
|
|
implicit none
|
|
|
|
integer numvar # Number of variables.
|
|
integer strs(STRSZ, MAXSTR) # Strings for the VM's string pool.
|
|
integer numstr # Number of such strings.
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer code(0 : CODESZ - 1) # Generated code.
|
|
integer ncode # Number of VM bytes in the code.
|
|
character outbuf(OUTLSZ) # Output line buffer.
|
|
integer noutbf # Number of characters in outbuf.
|
|
|
|
character*8 opname
|
|
|
|
integer i0, n0
|
|
integer i, j
|
|
integer opcode
|
|
character*8 name
|
|
|
|
character buf(20)
|
|
buf(1) = 'D'
|
|
buf(2) = 'a'
|
|
buf(3) = 't'
|
|
buf(4) = 'a'
|
|
buf(5) = 's'
|
|
buf(6) = 'i'
|
|
buf(7) = 'z'
|
|
buf(8) = 'e'
|
|
buf(9) = ':'
|
|
buf(10) = ' '
|
|
call wrtstr (outbuf, noutbf, buf, 1, 10)
|
|
call wrtint (outbuf, noutbf, numvar, 0)
|
|
buf(1) = ' '
|
|
buf(2) = 'S'
|
|
buf(3) = 't'
|
|
buf(4) = 'r'
|
|
buf(5) = 'i'
|
|
buf(6) = 'n'
|
|
buf(7) = 'g'
|
|
buf(8) = 's'
|
|
buf(9) = ':'
|
|
buf(10) = ' '
|
|
call wrtstr (outbuf, noutbf, buf, 1, 10)
|
|
call wrtint (outbuf, noutbf, numstr, 0)
|
|
call wrtchr (outbuf, noutbf, char (NEWLIN))
|
|
|
|
for (i = 1; i <= numstr; i = i + 1)
|
|
{
|
|
i0 = strs(STRI, i)
|
|
n0 = strs(STRN, i)
|
|
call wrtstr (outbuf, noutbf, strngs, i0, n0)
|
|
call wrtchr (outbuf, noutbf, char (NEWLIN))
|
|
}
|
|
|
|
i = 0
|
|
while (i != ncode)
|
|
{
|
|
opcode = code(i)
|
|
name = opname (opcode)
|
|
call wrtint (outbuf, noutbf, i, 10)
|
|
for (j = 1; j <= 2; j = j + 1)
|
|
call wrtchr (outbuf, noutbf, ' ')
|
|
for (j = 1; j <= 8; j = j + 1)
|
|
{
|
|
if (opcode == OPFTCH _
|
|
|| opcode == OPSTOR _
|
|
|| opcode == OPPUSH _
|
|
|| opcode == OPJMP _
|
|
|| opcode == OPJZ)
|
|
call wrtchr (outbuf, noutbf, name(j:j))
|
|
else if (name(j:j) != ' ')
|
|
call wrtchr (outbuf, noutbf, name(j:j))
|
|
}
|
|
if (opcode == OPPUSH)
|
|
{
|
|
call wrtint (outbuf, noutbf, code(i + 1), 0)
|
|
i = i + 5
|
|
}
|
|
else if (opcode == OPFTCH || opcode == OPSTOR)
|
|
{
|
|
call wrtchr (outbuf, noutbf, '[')
|
|
call wrtint (outbuf, noutbf, code(i + 1), 0)
|
|
call wrtchr (outbuf, noutbf, ']')
|
|
i = i + 5
|
|
}
|
|
else if (opcode == OPJMP || opcode == OPJZ)
|
|
{
|
|
call wrtchr (outbuf, noutbf, '(')
|
|
call wrtint (outbuf, noutbf, code(i + 1) - (i + 1), 0)
|
|
call wrtchr (outbuf, noutbf, ')')
|
|
call wrtchr (outbuf, noutbf, ' ')
|
|
call wrtint (outbuf, noutbf, code(i + 1), 0)
|
|
i = i + 5
|
|
}
|
|
else
|
|
i = i + 1
|
|
call wrtchr (outbuf, noutbf, char (NEWLIN))
|
|
}
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
program gen
|
|
|
|
implicit none
|
|
|
|
integer vars(VARSZ, MAXVAR) # Variables.
|
|
integer numvar # Number of variables.
|
|
integer strs(STRSZ, MAXSTR) # Strings for the VM's string pool.
|
|
integer numstr # Number of such strings.
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
integer nodes (NODESZ, NODSSZ) # Nodes pool.
|
|
integer frelst # Head of the free list.
|
|
character outbuf(OUTLSZ) # Output line buffer.
|
|
integer noutbf # Number of characters in outbuf.
|
|
integer code(0 : CODESZ - 1) # Generated code.
|
|
integer ncode # Number of VM bytes in the code.
|
|
integer iast # Root node of the AST.
|
|
|
|
numvar = 0
|
|
numstr = 0
|
|
istrng = 1
|
|
noutbf = 0
|
|
ncode = 0
|
|
|
|
call initnd (nodes, frelst)
|
|
call rdast (strngs, istrng, nodes, frelst, iast)
|
|
|
|
call compil (vars, numvar, strs, numstr, _
|
|
strngs, istrng, nodes, frelst, _
|
|
code, ncode, iast)
|
|
call prprog (numvar, strs, numstr, strngs, istrng, _
|
|
code, ncode, outbuf, noutbf)
|
|
|
|
if (noutbf != 0)
|
|
call flushl (outbuf, noutbf)
|
|
end
|
|
|
|
######################################################################
|