========== ratfor of chapter 9 ==========
define(MAXSTACK,10)
define(LEXDIGITS,-260)
define(LEXIF,-261)
define(LEXELSE,-262)
define(LEXWHILE,-263)
define(LEXBREAK,-264)
define(LEXNEXT,-265)
define(LEXDO,-266)
define(LEXOTHER,-267)
define(ALPHA,-100)
define(MAXTOK,10)
define(ALPHA,-100)
define(MAXTBL,500)
define(MAXPTR,50)
define(CALLSIZE,20)
define(ARGSIZE,100)
define(MAXDEF,200)
define(MAXTOK,200)
define(ARGFLAG,DOLLAR)
define(DEFTYPE,-10)
define(IFTYPE,-11)
define(INCTYPE,-12)
define(SUBTYPE,-13)
define(EVALSIZE,500)
define(BUFSIZE,500)
common /cdefio/ bp, buf(BUFSIZE)
   integer bp      # next available character; init = 0
   character buf   # pushed-back characters
common /cline/ linect
   integer linect   # line count on input file; init = 1
common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL)
   integer lastp      # last used in namptr; init = 0
   integer lastt      # last used in table; init = 0
   integer namptr      # name pointers
   character table      # actual text of names and defns
common /coutln/ outp, outbuf(MAXLINE)
   integer outp      # last position filled in outbuf; init = 0
   character outbuf      # output lines collected here
# alldig - return YES if str is all digits
   integer function alldig(str)
   character type
   character str(ARB)
   integer i
   alldig = NO
   if (str(1) == EOS)
      return
   for (i = 1; str(i) ~= EOS; i = i + 1)
      if (type(str(i)) ~= DIGIT)
         return
   alldig = YES
   return
   end
# balpar - copy balanced paren string
   subroutine balpar
   character gettok
   character t, token(MAXTOK)
   integer nlpar
   if (gettok(token, MAXTOK) ~= LPAREN) {
      call synerr("missing left paren.")
      return
      $@$
   call outstr(token)
   nlpar = 1
   repeat {
      t = gettok(token, MAXTOK)
      if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) {
         call pbstr(token)
         break
         $@$
      if (t == NEWLINE)      # delete newlines
         token(1) = EOS
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      # else nothing special
      call outstr(token)
      $@$ until (nlpar <= 0)
   if (nlpar ~= 0)
      call synerr("missing parenthesis in condition.")
   return
   end
#block data
   block data
   include coutln
   include cline
   include cdefio
   data outp /0/
   data linect/1/
   data bp /0/
   end
# brknxt - generate code for break and next
   subroutine brknxt(sp, lextyp, labval, token)
   integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token
   for (i = sp; i > 0; i = i - 1)
      if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO) {
         if (token == LEXBREAK)
            call outgo(labval(i)+1)
         else
            call outgo(labval(i))
         return
         $@$
   if (token == LEXBREAK)
      call synerr("illegal break.")
   else
      call synerr("illegal next.")
   return
   end
# docode - generate code for beginning of do
   subroutine docode(lab)
   integer labgen
   integer lab
#   string dostr "do"
   integer dostr(4)
   data dostr(1), dostr(2), dostr(3),
   dostr(4)/LETD, LETO, BLANK, EOS/
   call outtab
   call outstr(dostr)
   lab = labgen(2)
   call outnum(lab)
   call eatup
   call outdon
   return
   end
# dostat - generate code for end of do statement
   subroutine dostat(lab)
   integer lab
   call outcon(lab)
   call outcon(lab+1)
   return
   end
# eatup - process rest of statement; interpret continuations
   subroutine eatup
   character gettok
   character ptoken(MAXTOK), t, token(MAXTOK)
   integer nlpar
   nlpar = 0
   repeat {
      t = gettok(token, MAXTOK)
      if (t == SEMICOL | t == NEWLINE)
         break
      if (t == RBRACE) {
         call pbstr(token)
         break
         $@$
      if (t == LBRACE | t == EOF) {
         call synerr("unexpected brace or EOF.")
         call pbstr(token)
         break
         $@$
      if (t == COMMA) {
         if (gettok(ptoken, MAXTOK) ~= NEWLINE)
            call pbstr(ptoken)
         $@$
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      call outstr(token)
      $@$ until (nlpar < 0)
   if (nlpar ~= 0)
      call synerr("unbalanced parentheses.")
   return
   end
# elseif - generate code for end of if before else
   subroutine elseif(lab)
   integer lab
   call outgo(lab+1)
   call outcon(lab)
   return
   end
# gettok - get token for Ratfor
   character function gettok(lexstr, toksiz)
   character ngetc, type
   integer i, toksiz
   character c, lexstr(toksiz)
   include cline
   while (ngetc(c) ~= EOF)
      if (c ~= BLANK & c ~= TAB)
         break
   call putbak(c)
   for (i = 1; i < toksiz-1; i = i + 1) {
      gettok = type(ngetc(lexstr(i)))
      if (gettok ~= LETTER & gettok ~= DIGIT)
         break
      $@$
   if (i >= toksiz-1)
      call synerr("token too long.")
   if (i > 1) {            # some alpha seen
      call putbak(lexstr(i))      # went one too far
      lexstr(i) = EOS
      gettok = ALPHA
      $@$
   else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) {
      for (i = 2; ngetc(lexstr(i)) ~= lexstr(1); i = i + 1)
         if (lexstr(i) == NEWLINE | i >= toksiz-1) {
            call synerr("missing quote.")
            lexstr(i) = lexstr(1)
            call putbak(NEWLINE)
            break
            $@$
      $@$
   else if (lexstr(1) == SHARP) {   # strip comments
      while (ngetc(lexstr(1)) ~= NEWLINE)
         ;
      gettok = NEWLINE
      $@$
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect = linect + 1
   return
   end
# ifcode - generate initial code for if
   subroutine ifcode(lab)
   integer labgen
   integer lab
   lab = labgen(2)
   call ifgo(lab)
   return
   end
# ifgo - generate "if(.not.(...))goto lab"
   subroutine ifgo(lab)
   integer lab
#   string ifnot "if(.not."
   integer ifnot(9)
      data ifnot(1) /LETI/
      data ifnot(2) /LETF/
      data ifnot(3) /LPAREN/
      data ifnot(4) /PERIOD/
      data ifnot(5) /LETN/
      data ifnot(6) /LETO/
      data ifnot(7) /LETT/
      data ifnot(8) /PERIOD/
      data ifnot(9) /EOS/
   call outtab         # get to column 7
   call outstr(ifnot)      # " if(.not. "
   call balpar         # collect and output condition
   call outch(RPAREN)      # " ) "
   call outgo(lab)      # " goto lab "
   return
   end
# initkw - initialize keyword tables
   subroutine initkw
   integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5)
   integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2)
   data sdo(1),sdo(2),sdo(3) /LETD,LETO,EOS/
   data vdo(1),vdo(2) /LEXDO,EOS/
   data sif(1),sif(2),sif(3) /LETI,LETF,EOS/
   data vif(1),vif(2) /LEXIF,EOS/
   data selse(1),selse(2),selse(3),selse(4),selse(5) /LETE,
      LETL,LETS,LETE,EOS/
   data velse(1),velse(2) /LEXELSE,EOS/
   data swhile(1),swhile(2),swhile(3),swhile(4),swhile(5),
      swhile(6) /LETW,LETH,LETI,LETL,LETE,EOS/
   data vwhile(1),vwhile(2) /LEXWHILE,EOS/
   data sbreak(1),sbreak(2),sbreak(3),sbreak(4),sbreak(5),
      sbreak(6) /LETB,LETR,LETE,LETA,LETK,EOS/
   data vbreak(1),vbreak(2) /LEXBREAK,EOS/
   data snext(1),snext(2),snext(3),snext(4),snext(5) /LETN,
      LETE,LETX,LETT,EOS/
   data vnext(1),vnext(2) /LEXNEXT,EOS/
   call instal(sdo,vdo)
   call instal(sif,vif)
   call instal(selse,velse)
   call instal(swhile,vwhile)
   call instal(sbreak,vbreak)
   call instal(snext,vnext)
   return
   end
# labelc - output statement number
   subroutine labelc(lexstr)
   character lexstr(ARB)
   integer length
   if (length(lexstr) == 5)   # warn about 23xxx labels
      if (lexstr(1) == DIG2 & lexstr(2) == DIG3)
         call synerr("warning: possible label conflict.")
   call outstr(lexstr)
   call outtab
   return
   end
# labgen - generate  n  consecutive labels, return first one
   integer function labgen(n)
   integer label, n
   data label /23000/
   labgen = label
   label = label + n
   return
   end
# lex - return lexical type of token
   integer function lex(lexstr)
   character gettok
   character lexstr(MAXTOK)
   integer alldig, lookup
   integer ltype(2)
   while (gettok(lexstr, MAXTOK) == NEWLINE)
      ;
   lex = lexstr(1)
   if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE)
      return
   if (alldig(lexstr) == YES)
      lex = LEXDIGITS
   else if (lookup(lexstr, ltype) == YES)
      lex = ltype(1)
   else
      lex = LEXOTHER
   return
   end
# lookup - locate name, extract definition from table
   integer function lookup(name, defn)
   character defn(MAXDEF), name(MAXTOK)
   integer i, j, k
   include clook
   for (i = lastp; i > 0; i = i - 1) {
      j = namptr(i)
      for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1)
         j = j + 1
      if (name(k) == table(j)) {      # got one
         call scopy(table, j+1, defn, 1)
         lookup = YES
         return
         $@$
      $@$
   lookup = NO
   return
   end
# instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer length
   integer dlen, nlen
   include clook
   nlen = length(name) + 1
   dlen = length(defn) + 1
   if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) {
      call putlin(name, ERROUT)
      call remark(": too many definitions.")
      $@$
   lastp = lastp + 1
   namptr(lastp) = lastt + 1
   call scopy(name, 1, table, lastt + 1)
   call scopy(defn, 1, table, lastt + nlen + 1)
   lastt = lastt + nlen + dlen
   return
   end
#block data
   block data
   include clook
   data lastp /0/
   data lastt /0/
   end
# ngetc - get a (possibly pushed back) character
   character function ngetc(c)
   character getc
   character c
   include cdefio
   if (bp > 0)
      c = buf(bp)
   else {
      bp = 1
      buf(bp) = getc(c)
      $@$
   if (c ~= EOF)
      bp = bp - 1
   ngetc = c
   return
   end
# otherc - output ordinary Fortran statement
   subroutine otherc(lexstr)
   character lexstr(ARB)
   call outtab
   call outstr(lexstr)
   call eatup
   call outdon
   return
   end
# outch - put one character into output buffer
   subroutine outch(c)
   character c
   integer i
   include coutln
   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf(i) = BLANK
      outbuf(6) = STAR
      outp = 6
      $@$
   outp = outp + 1
   outbuf(outp) = c
   return
   end
# outcon - output "n   continue"
   subroutine outcon(n)
   integer n
#   string contin "continue"
   integer contin(9)
      data contin(1) /LETC/
      data contin(2) /LETO/
      data contin(3) /LETN/
      data contin(4) /LETT/
      data contin(5) /LETI/
      data contin(6) /LETN/
      data contin(7) /LETU/
      data contin(8) /LETE/
      data contin(9) /EOS/
   if (n > 0)
      call outnum(n)
   call outtab
   call outstr(contin)
   call outdon
   return
   end
# outdon - finish off an output line
   subroutine outdon
   include coutln
   outbuf(outp+1) = NEWLINE
   outbuf(outp+2) = EOS
   call putlin(outbuf, STDOUT)
   outp = 0
   return
   end
# outgo - output "goto  n"
   subroutine outgo(n)
   integer n
#   string goto "goto"
   integer goto(6)
      data goto(1) /LETG/
      data goto(2) /LETO/
      data goto(3) /LETT/
      data goto(4) /LETO/
      data goto(5) /BLANK/
      data goto(6) /EOS/
   call outtab
   call outstr(goto)
   call outnum(n)
   call outdon
   return
   end
define(MAXCHARS,10)
# outnum - output decimal number
   subroutine outnum(n)
   character chars(MAXCHARS)
   integer itoc
   integer i, len, n
   len = itoc(n, chars, MAXCHARS)
   for (i = 1; i <= len; i = i + 1)
      call outch(chars(i))
   return
   end
# outstr - output string
   subroutine outstr(str)
   character c, str(ARB)
   integer i, j
   for (i = 1; str(i) ~= EOS; i = i + 1) {
      c = str(i)
      if (c ~= SQUOTE & c ~= DQUOTE)
         call outch(c)
      else {
         i = i + 1
         for (j = i; str(j) ~= c; j = j + 1)   # find end
            ;
         call outnum(j-i)
         call outch(LETH)
         for ( ; i < j; i = i + 1)
            call outch(str(i))
         $@$
      $@$
   return
   end
# outtab - get past column 6
   subroutine outtab
   include coutln
   while (outp < 6)
      call outch(BLANK)
   return
   end
# parse - parse Ratfor source program
   subroutine parse
   character lexstr(MAXTOK)
   integer lex
   integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token
   call initkw   # install keywords in table
   sp = 1
   lextyp(1) = EOF
   for (token = lex(lexstr); token ~= EOF; token = lex(lexstr)) {
      if (token == LEXIF)
         call ifcode(lab)
      else if (token == LEXDO)
         call docode(lab)
      else if (token == LEXWHILE)
         call whilec(lab)
      else if (token == LEXDIGITS)
         call labelc(lexstr)
      else if (token == LEXELSE) {
         if (lextyp(sp) == LEXIF)
            call elseif(labval(sp))
         else
            call synerr("illegal else.")
         $@$
      if (token==LEXIF | token==LEXELSE | token==LEXWHILE
        | token==LEXDO | token==LEXDIGITS | token==LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call error("stack overflow in parser.")
         lextyp(sp) = token      # stack type and value
         labval(sp) = lab
         $@$
      else {      # end of statement - prepare to unstack
         if (token == RBRACE) {
            if (lextyp(sp) == LBRACE)
               sp = sp - 1
            else
               call synerr("illegal right brace.")
            $@$
         else if (token == LEXOTHER)
            call otherc(lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt(sp, lextyp, labval, token)
         token = lex(lexstr)      # peek at next token
         call pbstr(lexstr)
         call unstak(sp, lextyp, labval, token)
         $@$
      $@$
   if (sp ~= 1)
      call synerr("unexpected EOF.")
   return
   end
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(MAXLINE)
   integer length
   integer i
   for (i = length(in); i > 0; i = i - 1)
      call putbak(in(i))
   return
   end
# putbak - push character back onto input
   subroutine putbak(c)
   character c
   include cdefio
   bp = bp + 1
   if (bp > BUFSIZE)
      call error("too many characters pushed back.")
   buf(bp) = c
   return
   end
# ratfor - main program for Ratfor
   call parse
   stop
   end
# synerr - report Ratfor syntax error
   subroutine synerr(msg)
   character lc(MAXLINE), msg(MAXLINE)
   integer itoc
   integer junk
   include cline
   call remark("error at line .")
   junk = itoc(linect, lc, MAXLINE)
   call putlin(lc, ERROUT)
   call putch(COLON, ERROUT)
   call remark(msg)
   return
   end
# unstak - unstack at end of statement
   subroutine unstak(sp, lextyp, labval, token)
   integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token
   for ( ; sp > 1; sp = sp - 1) {
      if (lextyp(sp) == LBRACE)
         break
      if (lextyp(sp) == LEXIF & token == LEXELSE)
         break
      if (lextyp(sp) == LEXIF)
         call outcon(labval(sp))
      else if (lextyp(sp) == LEXELSE) {
         if (sp > 2)
            sp = sp - 1
         call outcon(labval(sp)+1)
         $@$
      else if (lextyp(sp) == LEXDO)
         call dostat(labval(sp))
      else if (lextyp(sp) == LEXWHILE)
         call whiles(labval(sp))
      $@$
   return
   end
# whilec - generate code for beginning of while
   subroutine whilec(lab)
   integer labgen
   integer lab
   call outcon(0)    # unlabeled continue, in case there was a label
   lab = labgen(2)
   call outnum(lab)
   call ifgo(lab+1)
   return
   end
# whiles - generate code for end of while
   subroutine whiles(lab)
   integer lab
   call outgo(lab)
   call outcon(lab+1)
   return
   end