1231 lines
31 KiB
Text
1231 lines
31 KiB
Text
######################################################################
|
|
#
|
|
# The Rosetta Code scanner in Ratfor 77.
|
|
#
|
|
#
|
|
# 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 lex-in-ratfor.r > lex-in-ratfor.f
|
|
# f2c -C -Nc40 lex-in-ratfor.f
|
|
# cc -O lex-in-ratfor.c -lf2c
|
|
# ./a.out < compiler-tests/primes.t
|
|
#
|
|
# With gfortran, a little differently:
|
|
#
|
|
# ratfor77 lex-in-ratfor.r > lex-in-ratfor.f
|
|
# gfortran -O2 -fcheck=all -std=legacy lex-in-ratfor.f
|
|
# ./a.out < compiler-tests/primes.t
|
|
#
|
|
#
|
|
# 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 with to modify.
|
|
|
|
define(LINESZ, 256) # Size of an input line.
|
|
define(OUTLSZ, 512) # Size of an output line.
|
|
define(PSHBSZ, 10) # Size of the character pushback buffer.
|
|
define(STRNSZ, 4096) # Size of the string pool.
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
define(EOF, -1)
|
|
define(NEWLIN, 10) # Unix newline (the LF control character).
|
|
define(BACKSL, 92) # ASCII backslash.
|
|
|
|
define(ILINNO, 1) # Line number's index.
|
|
define(ICOLNO, 2) # Column number's index.
|
|
|
|
define(CHRSZ, 3) # See ILINNO and ICOLNO above.
|
|
define(ICHRCD, 3) # Character code's index.
|
|
|
|
define(TOKSZ, 5) # See ILINNO and ICOLNO above.
|
|
define(ITOKNO, 3) # Token number's index.
|
|
define(IARGIX, 4) # Index of the string pool index.
|
|
define(IARGLN, 5) # Index of the string length.
|
|
|
|
define(TKELSE, 0)
|
|
define(TKIF, 1)
|
|
define(TKPRNT, 2)
|
|
define(TKPUTC, 3)
|
|
define(TKWHIL, 4)
|
|
define(TKMUL, 5)
|
|
define(TKDIV, 6)
|
|
define(TKMOD, 7)
|
|
define(TKADD, 8)
|
|
define(TKSUB, 9)
|
|
define(TKNEG, 10)
|
|
define(TKLT, 11)
|
|
define(TKLE, 12)
|
|
define(TKGT, 13)
|
|
define(TKGE, 14)
|
|
define(TKEQ, 15)
|
|
define(TKNE, 16)
|
|
define(TKNOT, 17)
|
|
define(TKASGN, 18)
|
|
define(TKAND, 19)
|
|
define(TKOR, 20)
|
|
define(TKLPAR, 21)
|
|
define(TKRPAR, 22)
|
|
define(TKLBRC, 23)
|
|
define(TKRBRC, 24)
|
|
define(TKSEMI, 25)
|
|
define(TKCMMA, 26)
|
|
define(TKID, 27)
|
|
define(TKINT, 28)
|
|
define(TKSTR, 29)
|
|
define(TKEOI, 30)
|
|
|
|
define(LOC10, 1) # Location of "10" in the string pool.
|
|
define(LOC92, 3) # Location of "92" in the string pool.
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
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
|
|
}
|
|
for (j = 0; j < n0; j = j + 1)
|
|
strngs(istrng + j) = src(i0 + j)
|
|
i = istrng
|
|
n = n0
|
|
istrng = istrng + n0
|
|
end
|
|
|
|
subroutine cpystr (strngs, i, n, dst, i0)
|
|
|
|
# Copy a string from the string pool to an output string.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer i, n # Index and length in string pool.
|
|
character dst(OUTLSZ) # Destination string.
|
|
integer i0 # Index within destination string.
|
|
|
|
integer j
|
|
|
|
if (i0 < 1 || OUTLSZ < i0 + (n - 1))
|
|
{
|
|
write (*, '(''string boundary exceeded'')')
|
|
stop
|
|
}
|
|
for (j = 0; j < n; j = j + 1)
|
|
dst(i0 + j) = strngs(i + j)
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
|
|
# Get a character, with its line number and column number.
|
|
|
|
implicit none
|
|
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer chr(CHRSZ)
|
|
|
|
# End of file is indicated (as in C) by a negative "char code"
|
|
# called "EOF".
|
|
|
|
character*20 fmt
|
|
integer stat
|
|
integer chr1(CHRSZ)
|
|
|
|
if (0 < npshbk)
|
|
{
|
|
chr(ICHRCD) = pushbk(ICHRCD, npshbk)
|
|
chr(ILINNO) = pushbk(ILINNO, npshbk)
|
|
chr(ICOLNO) = pushbk(ICOLNO, npshbk)
|
|
npshbk = npshbk - 1
|
|
}
|
|
else if (colno <= LINESZ)
|
|
{
|
|
chr(ICHRCD) = ichar (line(colno))
|
|
chr(ILINNO) = linno
|
|
chr(ICOLNO) = colno
|
|
colno = colno + 1
|
|
}
|
|
else
|
|
{
|
|
# Return a newline character.
|
|
chr(ICHRCD) = NEWLIN
|
|
chr(ILINNO) = linno
|
|
chr(ICOLNO) = colno
|
|
|
|
# Fetch a new line.
|
|
linno = linno + 1
|
|
colno = 1
|
|
|
|
# Read a line of text as an array of characters.
|
|
write (fmt, '(''('', I10, ''A1)'')') LINESZ
|
|
read (*, fmt, iostat = stat) line
|
|
|
|
if (stat != 0)
|
|
{
|
|
# If end of file has been reached, push an EOF.
|
|
chr1(ICHRCD) = EOF
|
|
chr1(ILINNO) = linno
|
|
chr1(ICOLNO) = colno
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
}
|
|
}
|
|
end
|
|
|
|
subroutine pshchr (pushbk, npshbk, chr)
|
|
|
|
# Push back a character.
|
|
|
|
implicit none
|
|
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer chr(CHRSZ)
|
|
|
|
if (PSHBSZ <= npshbk)
|
|
{
|
|
write (*, '(''pushback buffer overfull'')')
|
|
stop
|
|
}
|
|
npshbk = npshbk + 1
|
|
pushbk(ICHRCD, npshbk) = chr(ICHRCD)
|
|
pushbk(ILINNO, npshbk) = chr(ILINNO)
|
|
pushbk(ICOLNO, npshbk) = chr(ICOLNO)
|
|
end
|
|
|
|
subroutine getpos (line, linno, colno, pushbk, npshbk, ln, cn)
|
|
|
|
# Get the position of the next character.
|
|
|
|
implicit none
|
|
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer ln, cn # The line and column nos. returned.
|
|
|
|
integer chr(CHRSZ)
|
|
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
ln = chr(ILINNO)
|
|
cn = chr(ICOLNO)
|
|
call pshchr (pushbk, npshbk, chr)
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
function isspc (c)
|
|
|
|
# Is c character code for a space?
|
|
|
|
implicit none
|
|
|
|
integer c
|
|
logical isspc
|
|
|
|
#
|
|
# The following is correct for ASCII: 32 is the SPACE character, and
|
|
# 9 to 13 are control characters commonly regarded as spaces.
|
|
#
|
|
# In Unicode these are all code points for spaces, but so are others
|
|
# besides.
|
|
#
|
|
isspc = (c == 32 || (9 <= c && c <= 13))
|
|
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 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 isid0 (c)
|
|
|
|
# Is c character code for the start of an identifier?
|
|
|
|
implicit none
|
|
|
|
integer c
|
|
logical isid0
|
|
|
|
logical isalph
|
|
|
|
isid0 = isalph (c) || c == ichar ('_')
|
|
end
|
|
|
|
function isid1 (c)
|
|
|
|
# Is c character code for the continuation of an identifier?
|
|
|
|
implicit none
|
|
|
|
integer c
|
|
logical isid1
|
|
|
|
logical isalph
|
|
logical isdgt
|
|
|
|
isid1 = isalph (c) || isdgt (c) || c == ichar ('_')
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
function trimlf (str, n)
|
|
|
|
# "Trim left" leading spaces.
|
|
|
|
implicit none
|
|
|
|
character str(*) # The string to "trim".
|
|
integer n # The length.
|
|
integer trimlf # The index of the first non-space
|
|
# character, or n + 1.
|
|
|
|
logical isspc
|
|
|
|
integer j
|
|
logical done
|
|
|
|
j = 1
|
|
done = .false.
|
|
while (!done)
|
|
{
|
|
if (j == n + 1)
|
|
done = .true.
|
|
else if (!isspc (ichar (str(j))))
|
|
done = .true.
|
|
else
|
|
j = j + 1
|
|
}
|
|
trimlf = j
|
|
end
|
|
|
|
function trimrt (str, n)
|
|
|
|
# "Trim right" trailing spaces.
|
|
|
|
implicit none
|
|
|
|
character str(*) # The string to "trim".
|
|
integer n # The length including trailing spaces.
|
|
integer trimrt # The length without trailing spaces.
|
|
|
|
logical isspc
|
|
|
|
integer j
|
|
logical done
|
|
|
|
j = n
|
|
done = .false.
|
|
while (!done)
|
|
{
|
|
if (j == 0)
|
|
done = .true.
|
|
else if (!isspc (ichar (str(j))))
|
|
done = .true.
|
|
else
|
|
j = j - 1
|
|
}
|
|
trimrt = j
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine toknam (tokno, str, i)
|
|
|
|
# Copy a token name to the character array str, starting at i.
|
|
|
|
implicit none
|
|
|
|
integer tokno
|
|
character str(*)
|
|
integer i
|
|
integer j
|
|
|
|
character*16 names(0:30)
|
|
character*16 nm
|
|
|
|
data names / "Keyword_else ", _
|
|
"Keyword_if ", _
|
|
"Keyword_print ", _
|
|
"Keyword_putc ", _
|
|
"Keyword_while ", _
|
|
"Op_multiply ", _
|
|
"Op_divide ", _
|
|
"Op_mod ", _
|
|
"Op_add ", _
|
|
"Op_subtract ", _
|
|
"Op_negate ", _
|
|
"Op_less ", _
|
|
"Op_lessequal ", _
|
|
"Op_greater ", _
|
|
"Op_greaterequal ", _
|
|
"Op_equal ", _
|
|
"Op_notequal ", _
|
|
"Op_not ", _
|
|
"Op_assign ", _
|
|
"Op_and ", _
|
|
"Op_or ", _
|
|
"LeftParen ", _
|
|
"RightParen ", _
|
|
"LeftBrace ", _
|
|
"RightBrace ", _
|
|
"Semicolon ", _
|
|
"Comma ", _
|
|
"Identifier ", _
|
|
"Integer ", _
|
|
"String ", _
|
|
"End_of_input " /
|
|
|
|
nm = names(tokno)
|
|
for (j = 0; j < 16; j = j + 1)
|
|
str(i + j) = nm(1 + j : 1 + j)
|
|
end
|
|
|
|
subroutine intstr (str, i, n, x)
|
|
|
|
# Convert a positive integer to a substring.
|
|
|
|
implicit none
|
|
|
|
character str(*) # Destination string.
|
|
integer i, n # Index and length of the field.
|
|
integer x # The positive integer to represent.
|
|
|
|
integer j
|
|
integer y
|
|
|
|
if (x == 0)
|
|
{
|
|
for (j = 0; j < n - 1; j = j + 1)
|
|
str(i + j) = ' '
|
|
str(i + j) = '0'
|
|
}
|
|
else
|
|
{
|
|
y = x
|
|
for (j = n - 1; 0 <= j; j = j - 1)
|
|
{
|
|
if (y == 0)
|
|
str(i + j) = ' '
|
|
else
|
|
{
|
|
str(i + j) = char (mod (y, 10) + ichar ('0'))
|
|
y = y / 10
|
|
}
|
|
}
|
|
}
|
|
end
|
|
|
|
subroutine prttok (strngs, tok)
|
|
|
|
# Print a token.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer tok(TOKSZ) # The token.
|
|
|
|
integer trimrt
|
|
|
|
character line(OUTLSZ)
|
|
character*20 fmt
|
|
integer i, n
|
|
integer tokno
|
|
|
|
for (i = 1; i <= OUTLSZ; i = i + 1)
|
|
line(i) = ' '
|
|
|
|
call intstr (line, 1, 10, tok(ILINNO))
|
|
call intstr (line, 12, 10, tok(ICOLNO))
|
|
|
|
tokno = tok(ITOKNO)
|
|
call toknam (tokno, line, 25)
|
|
if (tokno == TKID || tokno == TKINT || tokno == TKSTR)
|
|
{
|
|
i = tok(IARGIX)
|
|
n = tok(IARGLN)
|
|
call cpystr (strngs, i, n, line, 45)
|
|
}
|
|
|
|
n = trimrt (line, OUTLSZ)
|
|
write (fmt, '(''('', I10, ''A)'')') n
|
|
write (*, fmt) (line(i), i = 1, n)
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine wrtpos (ln, cn)
|
|
|
|
implicit none
|
|
|
|
integer ln, cn
|
|
|
|
write (*, 1000) ln, cn
|
|
1000 format ('At line ', I5, ', column ' I5)
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine utcmnt (ln, cn)
|
|
|
|
implicit none
|
|
|
|
integer ln, cn
|
|
|
|
call wrtpos (ln, cn)
|
|
write (*, '(''Unterminated comment'')')
|
|
stop
|
|
end
|
|
|
|
subroutine skpcmt (line, linno, colno, pushbk, npshbk, ln, cn)
|
|
|
|
# Skip to the end of a comment.
|
|
|
|
implicit none
|
|
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer ln, cn # Line and column of start of comment.
|
|
|
|
integer chr(CHRSZ)
|
|
logical done
|
|
|
|
done = .false.
|
|
while (!done)
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
if (chr(ICHRCD) == ichar ('*'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
if (chr(ICHRCD) == ichar ('/'))
|
|
done = .true.
|
|
else if (chr(ICHRCD) == EOF)
|
|
call utcmnt (ln, cn)
|
|
}
|
|
else if (chr(ICHRCD) == EOF)
|
|
call utcmnt (ln, cn)
|
|
}
|
|
end
|
|
|
|
subroutine skpspc (line, linno, colno, pushbk, npshbk)
|
|
|
|
# Skip spaces and comments.
|
|
|
|
implicit none
|
|
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
|
|
logical isspc
|
|
|
|
integer chr(CHRSZ)
|
|
integer chr1(CHRSZ)
|
|
integer ln, cn
|
|
logical done
|
|
|
|
done = .false.
|
|
while (!done)
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
if (!isspc (chr(ICHRCD)))
|
|
{
|
|
if (chr(ICHRCD) != ichar ('/'))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
done = .true.
|
|
}
|
|
else
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) != ichar ('*'))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
call pshchr (pushbk, npshbk, chr)
|
|
done = .true.
|
|
}
|
|
else
|
|
{
|
|
ln = chr(ILINNO)
|
|
cn = chr(ICOLNO)
|
|
call skpcmt (line, linno, colno, pushbk, npshbk, _
|
|
ln, cn)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
subroutine rwdlkp (strngs, istrng, src, i0, n0, ln, cn, tok)
|
|
|
|
# Reserved word lookup
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character src(*) # The source string.
|
|
integer i0, n0 # Index and length of the substring.
|
|
integer ln, cn # Line and column number
|
|
# to associate with the token.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
integer tokno
|
|
integer i, n
|
|
|
|
tokno = TKID
|
|
|
|
if (n0 == 2)
|
|
{
|
|
if (src(i0) == 'i' && src(i0 + 1) == 'f')
|
|
tokno = TKIF
|
|
}
|
|
else if (n0 == 4)
|
|
{
|
|
if (src(i0) == 'e' && src(i0 + 1) == 'l' _
|
|
&& src(i0 + 2) == 's' && src(i0 + 3) == 'e')
|
|
tokno = TKELSE
|
|
else if (src(i0) == 'p' && src(i0 + 1) == 'u' _
|
|
&& src(i0 + 2) == 't' && src(i0 + 3) == 'c')
|
|
tokno = TKPUTC
|
|
}
|
|
else if (n0 == 5)
|
|
{
|
|
if (src(i0) == 'p' && src(i0 + 1) == 'r' _
|
|
&& src(i0 + 2) == 'i' && src(i0 + 3) == 'n' _
|
|
&& src(i0 + 4) == 't')
|
|
tokno = TKPRNT
|
|
else if (src(i0) == 'w' && src(i0 + 1) == 'h' _
|
|
&& src(i0 + 2) == 'i' && src(i0 + 3) == 'l' _
|
|
&& src(i0 + 4) == 'e')
|
|
tokno = TKWHIL
|
|
}
|
|
|
|
i = 0
|
|
n = 0
|
|
if (tokno == TKID)
|
|
call addstr (strngs, istrng, src, i0, n0, i, n)
|
|
|
|
tok(ITOKNO) = tokno
|
|
tok(IARGIX) = i
|
|
tok(IARGLN) = n
|
|
tok(ILINNO) = ln
|
|
tok(ICOLNO) = cn
|
|
end
|
|
|
|
subroutine scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n)
|
|
|
|
# Scan characters that may represent an identifier, reserved word,
|
|
# or integer literal.
|
|
|
|
implicit none
|
|
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer ln, cn # Line and column number of the start.
|
|
character buf(LINESZ) # The output buffer.
|
|
integer n # The length of the string collected.
|
|
|
|
logical isid1
|
|
|
|
integer chr(CHRSZ)
|
|
|
|
n = 0
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
ln = chr(ILINNO)
|
|
cn = chr(ICOLNO)
|
|
while (isid1 (chr(ICHRCD)))
|
|
{
|
|
n = n + 1
|
|
buf(n) = char (chr(ICHRCD))
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
}
|
|
call pshchr (pushbk, npshbk, chr)
|
|
end
|
|
|
|
subroutine scnidr (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan an identifier or reserved word.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer ln, cn # Line and column number of the start.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
character buf(LINESZ)
|
|
integer n
|
|
|
|
call scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n)
|
|
call rwdlkp (strngs, istrng, buf, 1, n, ln, cn, tok)
|
|
end
|
|
|
|
subroutine scnint (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan a positive integer literal.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer ln, cn # Line and column number of the start.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
logical isdgt
|
|
|
|
character buf(LINESZ)
|
|
integer n0, n
|
|
integer i, j, k
|
|
character*80 fmt
|
|
|
|
call scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n0)
|
|
for (j = 1; j <= n0; j = j + 1)
|
|
if (!isdgt (ichar (buf(j))))
|
|
{
|
|
call wrtpos (ln, cn)
|
|
write (fmt, 1000) n0
|
|
1000 format ('(''Not a legal word: "''', I10, 'A, ''"'')')
|
|
write (*, fmt) (buf(k), k = 1, n0)
|
|
stop
|
|
}
|
|
|
|
call addstr (strngs, istrng, buf, 1, n0, i, n)
|
|
|
|
tok(ITOKNO) = TKINT
|
|
tok(IARGIX) = i
|
|
tok(IARGLN) = n
|
|
tok(ILINNO) = ln
|
|
tok(ICOLNO) = cn
|
|
end
|
|
|
|
subroutine utclit (ln, cn)
|
|
|
|
implicit none
|
|
|
|
integer ln, cn
|
|
|
|
call wrtpos (ln, cn)
|
|
write (*, '(''Unterminated character literal'')')
|
|
stop
|
|
end
|
|
|
|
subroutine scnch1 (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan a character literal, without yet checking that the literal
|
|
# ends correctly.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
integer trimlf
|
|
|
|
integer bufsz
|
|
parameter (bufsz = 40)
|
|
|
|
integer chr(CHRSZ)
|
|
integer chr1(CHRSZ)
|
|
integer chr2(CHRSZ)
|
|
integer ln, cn
|
|
character buf(bufsz)
|
|
integer i, j, n
|
|
|
|
# Refetch the opening quote.
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
ln = chr(ILINNO)
|
|
cn = chr(ICOLNO)
|
|
|
|
tok(ITOKNO) = TKINT
|
|
tok(ILINNO) = ln
|
|
tok(ICOLNO) = cn
|
|
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == EOF)
|
|
call utclit (ln, cn)
|
|
if (chr1(ICHRCD) == BACKSL)
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr2)
|
|
if (chr2(ICHRCD) == EOF)
|
|
call utclit (ln, cn)
|
|
else if (chr2(ICHRCD) == ichar ('n'))
|
|
{
|
|
tok(IARGIX) = LOC10 # "10" = code for Unix newline
|
|
tok(IARGLN) = 2
|
|
}
|
|
else if (chr2(ICHRCD) == BACKSL)
|
|
{
|
|
tok(IARGIX) = LOC92 # "92" = code for backslash
|
|
tok(IARGLN) = 2
|
|
}
|
|
else
|
|
{
|
|
call wrtpos (ln, cn)
|
|
write (*, '(''Unsupported escape: '', 1A)') _
|
|
char (chr2(ICHRCD))
|
|
stop
|
|
}
|
|
}
|
|
else
|
|
{
|
|
# Character codes are non-negative, so we can use intstr.
|
|
call intstr (buf, 1, bufsz, chr1(ICHRCD))
|
|
|
|
j = trimlf (buf, bufsz)
|
|
call addstr (strngs, istrng, buf, j, bufsz - (j - 1), i, n)
|
|
tok(IARGIX) = i
|
|
tok(IARGLN) = n
|
|
}
|
|
end
|
|
|
|
subroutine scnch (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan a character literal.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
integer ln, cn
|
|
integer chr(CHRSZ)
|
|
|
|
call getpos (line, linno, colno, pushbk, npshbk, ln, cn)
|
|
call scnch1 (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
if (chr(ICHRCD) != ichar (''''))
|
|
{
|
|
while (.true.)
|
|
{
|
|
if (chr(ICHRCD) == EOF)
|
|
{
|
|
call utclit (ln, cn)
|
|
stop
|
|
}
|
|
else if (chr(ICHRCD) == ichar (''''))
|
|
{
|
|
call wrtpos (ln, cn)
|
|
write (*, '(''Unsupported multicharacter literal'')')
|
|
stop
|
|
}
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
}
|
|
}
|
|
end
|
|
|
|
subroutine scnstr (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan a string literal.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
integer ln, cn
|
|
integer chr1(CHRSZ)
|
|
integer chr2(CHRSZ)
|
|
character buf(LINESZ + 10) # Enough space, with some room to spare.
|
|
integer n0
|
|
integer i, n
|
|
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
ln = chr1(ILINNO)
|
|
cn = chr1(ICOLNO)
|
|
|
|
tok(ITOKNO) = TKSTR
|
|
tok(ILINNO) = ln
|
|
tok(ICOLNO) = cn
|
|
|
|
n0 = 1
|
|
buf(n0) = '"'
|
|
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
while (chr1(ICHRCD) != ichar ('"'))
|
|
{
|
|
# Our input method always puts a NEWLIN before EOF, and so this
|
|
# test is redundant, unless someone changes the input method.
|
|
if (chr1(ICHRCD) == EOF || chr1(ICHRCD) == NEWLIN)
|
|
{
|
|
call wrtpos (ln, cn)
|
|
write (*, '(''Unterminated string literal'')')
|
|
stop
|
|
}
|
|
if (chr1(ICHRCD) == BACKSL)
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr2)
|
|
if (chr2(ICHRCD) == ichar ('n'))
|
|
{
|
|
n0 = n0 + 1
|
|
buf(n0) = char (BACKSL)
|
|
n0 = n0 + 1
|
|
buf(n0) = 'n'
|
|
}
|
|
else if (chr2(ICHRCD) == BACKSL)
|
|
{
|
|
n0 = n0 + 1
|
|
buf(n0) = char (BACKSL)
|
|
n0 = n0 + 1
|
|
buf(n0) = char (BACKSL)
|
|
}
|
|
else
|
|
{
|
|
call wrtpos (chr1(ILINNO), chr1(ICOLNO))
|
|
write (*, '(''Unsupported escape sequence'')')
|
|
stop
|
|
}
|
|
}
|
|
else
|
|
{
|
|
n0 = n0 + 1
|
|
buf(n0) = char (chr1(ICHRCD))
|
|
}
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
}
|
|
n0 = n0 + 1
|
|
buf(n0) = '"'
|
|
|
|
call addstr (strngs, istrng, buf, 1, n0, i, n)
|
|
tok(IARGIX) = i
|
|
tok(IARGLN) = n
|
|
end
|
|
|
|
subroutine unxchr (chr)
|
|
|
|
implicit none
|
|
|
|
integer chr(CHRSZ)
|
|
|
|
call wrtpos (chr(ILINNO), chr(ICOLNO))
|
|
write (*, 1000) char (chr(ICHRCD))
|
|
1000 format ('Unexpected character ''', A1, '''')
|
|
stop
|
|
end
|
|
|
|
subroutine scntok (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
|
|
# Scan a token.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
integer tok(TOKSZ) # The output token.
|
|
|
|
logical isdgt
|
|
logical isid0
|
|
|
|
integer chr(CHRSZ)
|
|
integer chr1(CHRSZ)
|
|
integer ln, cn
|
|
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
ln = chr(ILINNO)
|
|
cn = chr(ICOLNO)
|
|
tok(ILINNO) = ln
|
|
tok(ICOLNO) = cn
|
|
tok(IARGIX) = 0
|
|
tok(IARGLN) = 0
|
|
if (chr(ICHRCD) == ichar (','))
|
|
tok(ITOKNO) = TKCMMA
|
|
else if (chr(ICHRCD) == ichar (';'))
|
|
tok(ITOKNO) = TKSEMI
|
|
else if (chr(ICHRCD) == ichar ('('))
|
|
tok(ITOKNO) = TKLPAR
|
|
else if (chr(ICHRCD) == ichar (')'))
|
|
tok(ITOKNO) = TKRPAR
|
|
else if (chr(ICHRCD) == ichar ('{'))
|
|
tok(ITOKNO) = TKLBRC
|
|
else if (chr(ICHRCD) == ichar ('}'))
|
|
tok(ITOKNO) = TKRBRC
|
|
else if (chr(ICHRCD) == ichar ('*'))
|
|
tok(ITOKNO) = TKMUL
|
|
else if (chr(ICHRCD) == ichar ('/'))
|
|
tok(ITOKNO) = TKDIV
|
|
else if (chr(ICHRCD) == ichar ('%'))
|
|
tok(ITOKNO) = TKMOD
|
|
else if (chr(ICHRCD) == ichar ('+'))
|
|
tok(ITOKNO) = TKADD
|
|
else if (chr(ICHRCD) == ichar ('-'))
|
|
tok(ITOKNO) = TKSUB
|
|
else if (chr(ICHRCD) == ichar ('<'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('='))
|
|
tok(ITOKNO) = TKLE
|
|
else
|
|
{
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
tok(ITOKNO) = TKLT
|
|
}
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('>'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('='))
|
|
tok(ITOKNO) = TKGE
|
|
else
|
|
{
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
tok(ITOKNO) = TKGT
|
|
}
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('='))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('='))
|
|
tok(ITOKNO) = TKEQ
|
|
else
|
|
{
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
tok(ITOKNO) = TKASGN
|
|
}
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('!'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('='))
|
|
tok(ITOKNO) = TKNE
|
|
else
|
|
{
|
|
call pshchr (pushbk, npshbk, chr1)
|
|
tok(ITOKNO) = TKNOT
|
|
}
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('&'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('&'))
|
|
tok(ITOKNO) = TKAND
|
|
else
|
|
call unxchr (chr)
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('|'))
|
|
{
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr1)
|
|
if (chr1(ICHRCD) == ichar ('|'))
|
|
tok(ITOKNO) = TKOR
|
|
else
|
|
call unxchr (chr)
|
|
}
|
|
else if (chr(ICHRCD) == ichar ('"'))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
call scnstr (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
}
|
|
else if (chr(ICHRCD) == ichar (''''))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
call scnch (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
}
|
|
else if (isdgt (chr(ICHRCD)))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
call scnint (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
}
|
|
else if (isid0 (chr(ICHRCD)))
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
call scnidr (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
}
|
|
else
|
|
call unxchr (chr)
|
|
end
|
|
|
|
subroutine scntxt (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk)
|
|
|
|
# Scan the text and print the token stream.
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
|
|
integer chr(CHRSZ)
|
|
integer tok(TOKSZ)
|
|
|
|
chr(ICHRCD) = ichar ('x')
|
|
while (chr(ICHRCD) != EOF)
|
|
{
|
|
call skpspc (line, linno, colno, pushbk, npshbk)
|
|
call getchr (line, linno, colno, pushbk, npshbk, chr)
|
|
if (chr(ICHRCD) != EOF)
|
|
{
|
|
call pshchr (pushbk, npshbk, chr)
|
|
call scntok (strngs, istrng, _
|
|
line, linno, colno, pushbk, npshbk, _
|
|
tok)
|
|
call prttok (strngs, tok)
|
|
}
|
|
}
|
|
tok(ITOKNO) = TKEOI
|
|
tok(ILINNO) = chr(ILINNO)
|
|
tok(ICOLNO) = chr(ICOLNO)
|
|
tok(IARGIX) = 0
|
|
tok(IARGLN) = 0
|
|
call prttok (strngs, tok)
|
|
end
|
|
|
|
#---------------------------------------------------------------------
|
|
|
|
program lex
|
|
|
|
implicit none
|
|
|
|
character strngs(STRNSZ) # String pool.
|
|
integer istrng # String pool's next slot.
|
|
character line(LINESZ) # Input buffer.
|
|
integer linno, colno # Current line and column numbers.
|
|
integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
|
|
integer npshbk # Number of characters pushed back.
|
|
|
|
integer i, n
|
|
|
|
istrng = 1
|
|
|
|
# Locate "10" (newline) at 1 in the string pool.
|
|
line(1) = '1'
|
|
line(2) = '0'
|
|
call addstr (strngs, istrng, line, 1, 2, i, n)
|
|
if (i != 1 && n != 2)
|
|
{
|
|
write (*, '(''internal error'')')
|
|
stop
|
|
}
|
|
|
|
# Locate "92" (backslash) at 3 in the string pool.
|
|
line(1) = '9'
|
|
line(2) = '2'
|
|
call addstr (strngs, istrng, line, 1, 2, i, n)
|
|
if (i != 3 && n != 2)
|
|
{
|
|
write (*, '(''internal error'')')
|
|
stop
|
|
}
|
|
|
|
linno = 0
|
|
colno = LINESZ + 1 # This will trigger a READ.
|
|
npshbk = 0
|
|
|
|
call scntxt (strngs, istrng, line, linno, colno, pushbk, npshbk)
|
|
end
|
|
|
|
######################################################################
|