========== Ratfor in ratfor ==========
# block data - initialize global variables
   block data
   include commonblocks
   # include coutln
   # include cline
   # include cdefio
   # include cfor
   # include clook
   # include ckeywd
   # include cchar
   # output character pointer:
   data outp /0/
   # file control:
   data level /1/
   data linect(1) /1/
   data infile(1) /STDIN/
   # pushback buffer pointer:
   data bp /0/
   # depth of for stack:
   data fordep /0/
   # pointers for table lookup code:
   data lastp /0/
   data lastt /0/
   # keywords:
   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/
   data sfor(1), sfor(2), sfor(3), sfor(4) /LETF,
      LETO, LETR, EOS/
   data vfor(1), vfor(2) /LEXFOR, EOS/
   data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6),
      srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/
   data vrept(1), vrept(2) /LEXREPEAT, EOS/
   data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5),
      suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/
   data vuntil(1), vuntil(2) /LEXUNTIL, EOS/
   # character set definitions:
   data extblk /' '/, intblk /BLANK/
   data extdig(1) /'0'/, intdig(1) /DIG0/
   data extdig(2) /'1'/, intdig(2) /DIG1/
   data extdig(3) /'2'/, intdig(3) /DIG2/
   data extdig(4) /'3'/, intdig(4) /DIG3/
   data extdig(5) /'4'/, intdig(5) /DIG4/
   data extdig(6) /'5'/, intdig(6) /DIG5/
   data extdig(7) /'6'/, intdig(7) /DIG6/
   data extdig(8) /'7'/, intdig(8) /DIG7/
   data extdig(9) /'8'/, intdig(9) /DIG8/
   data extdig(10) /'9'/, intdig(10) /DIG9/
   # normal case of letters
   data extlet(1) /'a'/, intlet(1) /LETA/
   data extlet(2) /'b'/, intlet(2) /LETB/
   data extlet(3) /'c'/, intlet(3) /LETC/
   data extlet(4) /'d'/, intlet(4) /LETD/
   data extlet(5) /'e'/, intlet(5) /LETE/
   data extlet(6) /'f'/, intlet(6) /LETF/
   data extlet(7) /'g'/, intlet(7) /LETG/
   data extlet(8) /'h'/, intlet(8) /LETH/
   data extlet(9) /'i'/, intlet(9) /LETI/
   data extlet(10) /'j'/, intlet(10) /LETJ/
   data extlet(11) /'k'/, intlet(11) /LETK/
   data extlet(12) /'l'/, intlet(12) /LETL/
   data extlet(13) /'m'/, intlet(13) /LETM/
   data extlet(14) /'n'/, intlet(14) /LETN/
   data extlet(15) /'o'/, intlet(15) /LETO/
   data extlet(16) /'p'/, intlet(16) /LETP/
   data extlet(17) /'q'/, intlet(17) /LETQ/
   data extlet(18) /'r'/, intlet(18) /LETR/
   data extlet(19) /'s'/, intlet(19) /LETS/
   data extlet(20) /'t'/, intlet(20) /LETT/
   data extlet(21) /'u'/, intlet(21) /LETU/
   data extlet(22) /'v'/, intlet(22) /LETV/
   data extlet(23) /'w'/, intlet(23) /LETW/
   data extlet(24) /'x'/, intlet(24) /LETX/
   data extlet(25) /'y'/, intlet(25) /LETY/
   data extlet(26) /'z'/, intlet(26) /LETZ/
   # upper case of letters
   data extbig(1) /'A'/, intbig(1) /BIGA/
   data extbig(2) /'B'/, intbig(2) /BIGB/
   data extbig(3) /'C'/, intbig(3) /BIGC/
   data extbig(4) /'D'/, intbig(4) /BIGD/
   data extbig(5) /'E'/, intbig(5) /BIGE/
   data extbig(6) /'F'/, intbig(6) /BIGF/
   data extbig(7) /'G'/, intbig(7) /BIGG/
   data extbig(8) /'H'/, intbig(8) /BIGH/
   data extbig(9) /'I'/, intbig(9) /BIGI/
   data extbig(10) /'J'/, intbig(10) /BIGJ/
   data extbig(11) /'K'/, intbig(11) /BIGK/
   data extbig(12) /'L'/, intbig(12) /BIGL/
   data extbig(13) /'M'/, intbig(13) /BIGM/
   data extbig(14) /'N'/, intbig(14) /BIGN/
   data extbig(15) /'O'/, intbig(15) /BIGO/
   data extbig(16) /'P'/, intbig(16) /BIGP/
   data extbig(17) /'Q'/, intbig(17) /BIGQ/
   data extbig(18) /'R'/, intbig(18) /BIGR/
   data extbig(19) /'S'/, intbig(19) /BIGS/
   data extbig(20) /'T'/, intbig(20) /BIGT/
   data extbig(21) /'U'/, intbig(21) /BIGU/
   data extbig(22) /'V'/, intbig(22) /BIGV/
   data extbig(23) /'W'/, intbig(23) /BIGW/
   data extbig(24) /'X'/, intbig(24) /BIGX/
   data extbig(25) /'Y'/, intbig(25) /BIGY/
   data extbig(26) /'Z'/, intbig(26) /BIGZ/
   # special characters. some of these may
   # change for your machine
   data extchr(1) /'!'/, intchr(1) /NOT/   # use exclam for not-sign
   data extchr(2) /'"'/, intchr(2) /DQUOTE/
   data extchr(3) /"#"/, intchr(3) /SHARP/
   data extchr(4) /'$'/, intchr(4) /DOLLAR/
   data extchr(5) /'%'/, intchr(5) /PERCENT/
   data extchr(6) /'&'/, intchr(6) /AMPER/
   data extchr(7) /"'"/, intchr(7) /SQUOTE/
   data extchr(8) /'('/, intchr(8) /LPAREN/
   data extchr(9) /')'/, intchr(9) /RPAREN/
   data extchr(10) /'*'/, intchr(10) /STAR/
   data extchr(11) /'+'/, intchr(11) /PLUS/
   data extchr(12) /','/, intchr(12) /COMMA/
   data extchr(13) /'-'/, intchr(13) /MINUS/
   data extchr(14) /'.'/, intchr(14) /PERIOD/
   data extchr(15) /'/'/, intchr(15) /SLASH/
   data extchr(16) /':'/, intchr(16) /COLON/
   data extchr(17) /';'/, intchr(17) /SEMICOL/
   data extchr(18) /'<'/, intchr(18) /LESS/
   data extchr(19) /'='/, intchr(19) /EQUALS/
   data extchr(20) /'>'/, intchr(20) /GREATER/
   data extchr(21) /'?'/, intchr(21) /QMARK/
   data extchr(22) /'@'/, intchr(22) /ATSIGN/
   data extchr(23) /'['/, intchr(23) /LBRACK/
   data extchr(24) /'\'/, intchr(24) /BACKSLASH/
   data extchr(25) /']'/, intchr(25) /RBRACK/
   data extchr(26) /'_'/, intchr(26) /UNDERLINE/
   data extchr(27) /'{'/, intchr(27) /LBRACE/
   data extchr(28) /'|'/, intchr(28) /BAR/
   data extchr(29) /'`'/, intchr(29) /RBRACE/
   data extchr(30) /''/, intchr(30) /BACKSPACE/
	data extchr(31) /'	'/, intchr(31) /TAB/
   data extchr(32) /'~'/, intchr(32) /NOT/   # use caret for not-sign
   data extchr(33) /'^'/, intchr(33) /NOT/   # use tilde for not-sign
   # NCHARS is last subscript in this array
   end
# ratfor - main program for Ratfor
   call parse
   stop
   end
# 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
# 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
        | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) {
         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
# close - exceedingly temporary version for gettok
   subroutine close(fd)
   integer fd
   rewind fd
   return
   end
# ctoi - convert string at in(i) to integer, increment i
   integer function ctoi(in, i)
   character in(ARB)
   integer index
   integer d, i
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/
   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   for (ctoi = 0; in(i) ~= EOS; i = i + 1) {
      d = index(digits, in(i))
      if (d == 0)      # non-digit
         break
      ctoi = 10 * ctoi + d - 1
      $)
   return
   end
# deftok - get token; process macro calls and invocations
   character function deftok(token, toksiz, fd)
   character gtok
   integer fd, toksiz
   character defn(MAXDEF), t, token(toksiz)
   integer lookup
   for (t=gtok(token, toksiz, fd); t~=EOF; t=gtok(token, toksiz, fd)) {
      if (t ~= ALPHA)   # non-alpha
         break
      if (lookup(token, defn) == NO)   # undefined
         break
      if (defn(1) == DEFTYPE) {   # get definition
         call getdef(token, toksiz, defn, MAXDEF, fd)
         call instal(token, defn)
         $)
      else
         call pbstr(defn)   # push replacement onto input
      $)
   deftok = t
   if (deftok == ALPHA)   # convert to single case
      call fold(token)
   return
   end
# fold - convert alphabetic token to single case
   subroutine fold(token)
   character token(ARB)
   integer i
   # WARNING - this routine depends heavily on the
   # fact that letters have been mapped into internal
   # right-adjusted ascii. god help you if you
   # have subverted this mechanism.
   for (i = 1; token(i) ~= EOS; i = i + 1)
      if (token(i) >= BIGA & token(i) <= BIGZ)
         token(i) = token(i) - BIGA + LETA
   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 | t == UNDERLINE) {
         if (gettok(ptoken, MAXTOK) ~= NEWLINE)
            call pbstr(ptoken)
         if (t == UNDERLINE)
            token(1) = EOS
         $)
      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
# equal - compare str1 to str2; return YES if equal, NO if not
   integer function equal(str1, str2)
   character str1(ARB), str2(ARB)
   integer i
   for (i = 1; str1(i) == str2(i); i = i + 1)
      if (str1(i) == EOS) {
         equal = YES
         return
         $)
   equal = NO
   return
   end
# error - print fatal error message, then die
   subroutine error(buf)
   integer buf(ARB)
   call remark(buf)
   stop
   end
# forcod - beginning of for statement
   subroutine forcod(lab)
   character gettok
   character t, token(MAXTOK)
   integer length, labgen
   integer i, j, lab, nlpar
   include commonblocks
   # include cfor
#   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/
   lab = labgen(3)
   call outcon(0)
   if (gettok(token, MAXTOK) ~= LPAREN) {
      call synerr("missing left paren.")
      return
      $)
   if (gettok(token, MAXTOK) ~= SEMICOL) {   # real init clause
      call pbstr(token)
      call outtab
      call eatup
      call outdon
      $)
   if (gettok(token, MAXTOK) == SEMICOL)   # empty condition
      call outcon(lab)
   else {   # non-empty condition
      call pbstr(token)
      call outnum(lab)
      call outtab
      call outstr(ifnot)
      call outch(LPAREN)
      nlpar = 0
      while (nlpar >= 0) {
         t = gettok(token, MAXTOK)
         if (t == SEMICOL)
            break
         if (t == LPAREN)
            nlpar = nlpar + 1
         else if (t == RPAREN)
            nlpar = nlpar - 1
         if (t ~= NEWLINE & t ~= UNDERLINE)
            call outstr(token)
         $)
      call outch(RPAREN)
      call outch(RPAREN)
      call outgo(lab+2)
      if (nlpar < 0)
         call synerr("invalid for clause.")
      $)
   fordep = fordep + 1   # stack reinit clause
   j = 1
   for (i = 1; i < fordep; i = i + 1)   # find end
      j = j + length(forstk(j)) + 1
   forstk(j) = EOS   # null, in case no reinit
   nlpar = 0
   while (nlpar >= 0) {
      t = gettok(token, MAXTOK)
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (nlpar >= 0 & t ~= NEWLINE & t ~= UNDERLINE) {
         call scopy(token, 1, forstk, j)
         j = j + length(token)
         $)
      $)
   lab = lab + 1   # label for next's
   return
   end
# fors - process end of for statement
   subroutine fors(lab)
   integer length
   integer i, j, lab
   include commonblocks
   # include cfor
   call outnum(lab)
   j = 1
   for (i = 1; i < fordep; i = i + 1)
      j = j + length(forstk(j)) + 1
   if (length(forstk(j)) > 0) {
      call outtab
      call outstr(forstk(j))
      call outdon
      $)
   call outgo(lab-1)
   call outcon(lab+1)
   fordep = fordep - 1
   return
   end
# getch - get characters from file
   integer function getch(c, f)
   character inmap
   character buf(MAXLINE), c
   integer f, i, lastc
   data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/
   # note: MAXLINE = MAXCARD + 1
   if (buf(lastc) == NEWLINE | lastc >= MAXLINE) {
      read(f, 1, end=10) (buf(i), i = 1, MAXCARD)
         1 format(MAXCARD a1)
      for (i = 1; i <= MAXCARD; i = i + 1)
         buf(i) = inmap(buf(i))
      for (i = MAXCARD; i > 0; i = i - 1)
         if (buf(i) ~= BLANK)
            break
      buf(i+1) = NEWLINE
      lastc = 0
      $)
   lastc = lastc + 1
   c = buf(lastc)
   getch = c
   return
 10   c = EOF
   getch = EOF
   return
   end
# getdef (for no arguments) - get name and definition
   subroutine getdef(token, toksiz, defn, defsiz, fd)
   character gtok, ngetch
   integer defsiz, fd, i, nlpar, toksiz
   character c, defn(defsiz), token(toksiz)
   if (ngetch(c, fd) ~= LPAREN)
      call remark("missing left paren.")
   if (gtok(token, toksiz, fd) ~= ALPHA)
      call remark("non-alphanumeric name.")
   else if (ngetch(c, fd) ~= COMMA)
      call remark("missing comma in define.")
   # else got (name,
   nlpar = 0
   for (i = 1; nlpar >= 0; i = i + 1)
      if (i > defsiz)
         call error("definition too long.")
      else if (ngetch(defn(i), fd) == EOF)
         call error("missing right paren.")
      else if (defn(i) == LPAREN)
         nlpar = nlpar + 1
      else if (defn(i) == RPAREN)
         nlpar = nlpar - 1
      # else normal character in defn(i)
   defn(i-1) = EOS
   return
   end
# gettok - get token. handles file inclusion and line numbers
   character function gettok(token, toksiz)
   integer equal, open
   integer junk, toksiz
   character deftok
   character name(MAXNAME), token(toksiz)
   include commonblocks
   # include cline
#   string incl "include"
   integer incl(8)
   data incl(1) /LETI/
   data incl(2) /LETN/
   data incl(3) /LETC/
   data incl(4) /LETL/
   data incl(5) /LETU/
   data incl(6) /LETD/
   data incl(7) /LETE/
   data incl(8) /EOS/
   for ( ; level > 0; level = level - 1) {
      for (gettok = deftok(token, toksiz, infile(level)); gettok ~= EOF;
         gettok = deftok(token, toksiz, infile(level))) {
         if (equal(token, incl) == NO)
            return
         junk = deftok(name, MAXNAME, infile(level))
         if (level >= NFILES)
            call synerr("includes nested too deeply.")
         else {
            infile(level+1) = open(name, READONLY)
            linect(level+1) = 1
            if (infile(level+1) == ERR)
               call synerr("can't open include.")
            else
               level = level + 1
            $)
         $)
      if (level > 1)
         call close(infile(level))
      $)
   gettok = EOF
   return
   end
# gtok - get token for Ratfor
   character function gtok(lexstr, toksiz, fd)
   character ngetch, type
   integer fd, i, toksiz
   character c, lexstr(toksiz)
   include commonblocks
   # include cline
   while (ngetch(c, fd) ~= EOF)
      if (c ~= BLANK & c ~= TAB)
         break
   call putbak(c)
   for (i = 1; i < toksiz-1; i = i + 1) {
      gtok = type(ngetch(lexstr(i), fd))
      if (gtok ~= LETTER & gtok ~= 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
      gtok = ALPHA
      $)
   else if (lexstr(1) == DOLLAR) {   # allow $( and $) for { and $)
      if (ngetch(lexstr(2), fd) == LPAREN) {
         lexstr(1) = LBRACE
         gtok = LBRACE
         $)
      else if (lexstr(2) == RPAREN) {
         lexstr(1) = RBRACE
         gtok = RBRACE
         $)
      else
         call putbak(lexstr(2))
      $)
   else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) {
      for (i = 2; ngetch(lexstr(i), fd) ~= 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 (ngetch(lexstr(1), fd) ~= NEWLINE)
         ;
      gtok = NEWLINE
      $)
   else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT
      | lexstr(1) == EQUALS | lexstr(1) == AMPER | lexstr(1) == BAR)
      call relate(lexstr, i, fd)
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect(level) = linect(level) + 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
# index - find character  c  in string  str
   integer function index(str, c)
   character c, str(ARB)
   for (index = 1; str(index) ~= EOS; index = index + 1)
      if (str(index) == c)
         return
   index = 0
   return
   end
# initkw - install keyword "define" in table
   subroutine initkw
#   string defnam "define"
   integer defnam(7), deftyp(2)
   data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/
   data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/
   data defnam(7) /EOS/
   data deftyp(1), deftyp(2) /DEFTYPE, EOS/
   call instal(defnam, deftyp)
   return
   end
# inmap - convert left adjusted external rep to right adj ascii
   integer function inmap(inchar)
   integer i, inchar
   include commonblocks
   # include cchar
   if (inchar == extblk) {
      inmap = intblk
      return
      $)
   do i = 1, 10
      if (inchar == extdig(i)) {
         inmap = intdig(i)
         return
         $)
   do i = 1, 26
      if (inchar == extlet(i)) {
         inmap = intlet(i)
         return
         $)
   do i = 1, 26
      if (inchar == extbig(i)) {
         inmap = intbig(i)
         return
         $)
   do i = 1, NCHARS
      if (inchar == extchr(i)) {
         inmap = intchr(i)
         return
         $)
   inmap = inchar
   return
   end
# instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer length
   integer dlen, nlen
   include commonblocks
   # 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
# itoc - convert integer  int  to char string in  str
   integer function itoc(int, str, size)
   integer abs, mod
   integer d, i, int, intval, j, k, size
   character str(size)
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/
   intval = abs(int)
   str(1) = EOS
   i = 1
   repeat {            # generate digits
      i = i + 1
      d = mod(intval, 10)
      str(i) = digits(d+1)
      intval = intval / 10
      $) until (intval == 0 | i >= size)
   if (int < 0 & i < size) {      # then sign
      i = i + 1
      str(i) = MINUS
      $)
   itoc = i - 1
   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str(i)
      str(i) = str(j)
      str(j) = k
      i = i - 1
      $)
   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
# length - compute length of string
   integer function length(str)
   integer str(ARB)
   for (length = 0; str(length+1) ~= EOS; length = length + 1)
      ;
   return
   end
# lex - return lexical type of token
   integer function lex(lexstr)
   character gettok
   character lexstr(MAXTOK)
   integer alldig, equal
   include commonblocks
   # include ckeywd
   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 (equal(lexstr, sif) == YES)
      lex = vif(1)
   else if (equal(lexstr, selse) == YES)
      lex = velse(1)
   else if (equal(lexstr, swhile) == YES)
      lex = vwhile(1)
   else if (equal(lexstr, sdo) == YES)
      lex = vdo(1)
   else if (equal(lexstr, sbreak) == YES)
      lex = vbreak(1)
   else if (equal(lexstr, snext) == YES)
      lex = vnext(1)
   else if (equal(lexstr, sfor) == YES)
      lex = vfor(1)
   else if (equal(lexstr, srept) == YES)
      lex = vrept(1)
   else if (equal(lexstr, suntil) == YES)
      lex = vuntil(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 commonblocks
   # 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
# ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd
   include commonblocks
   # include cdefio
   if (bp > 0)
      c = buf(bp)
   else {
      bp = 1
      buf(bp) = getch(c, fd)
      $)
   bp = bp - 1
   ngetch = c
   return
   end
# open - exceedingly temporary version for gettok
   integer function open(name, mode)
   character name(MAXNAME)
   integer ctoi
   integer i, mode
   i = 1
   open = ctoi(name, i)
   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 commonblocks
   # 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 commonblocks
   # 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
# outmap - convert right adj ascii to left adjusted external rep
   integer function outmap(inchar)
   integer i, inchar
   include commonblocks
   # include cchar
   if (inchar == intblk) {
      outmap = extblk
      return
      $)
   do i = 1, 10
      if (inchar == intdig(i)) {
         outmap = extdig(i)
         return
         $)
   do i = 1, 26
      if (inchar == intlet(i)) {
         outmap = extlet(i)
         return
         $)
   do i = 1, 26
      if (inchar == intbig(i)) {
         outmap = extbig(i)
         return
         $)
   do i = 1, NCHARS
      if (inchar == intchr(i)) {
         outmap = extchr(i)
         return
         $)
   outmap = inchar
   return
   end
# 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 commonblocks
   # 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 == LEXFOR)
         call forcod(lab)
      else if (token == LEXREPEAT)
         call repcod(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==LEXFOR | token==LEXREPEAT
        | 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(ARB)
   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 commonblocks
   # include cdefio
   bp = bp + 1
   if (bp > BUFSIZE)
      call error("too many characters pushed back.")
   buf(bp) = c
   return
   end
# putch (interim version)  put characters
   subroutine putch(c, f)
   integer buf(MAXLINE), c
   integer outmap
   integer f, i, lastc
   data lastc /0/
   if (lastc >= MAXLINE | c == NEWLINE) {
      if ( lastc <= 0 ) {
         write(f,2)
         2 format(/)
         $)
      else {
         write(f, 1) (buf(i), i = 1, lastc)
         1 format(MAXCARD a1)
         $)
      lastc = 0
      $)
   if (c ~= NEWLINE) {
      lastc = lastc + 1
      buf(lastc) = outmap(c)
      $)
   return
   end
# putlin - put out line by repeated calls to putch
   subroutine putlin(b, f)
   character b(ARB)
   integer f, i
   for (i = 1; b(i) ~= EOS; i = i + 1)
      call putch(b(i), f)
   return
   end
# relate - convert relational shorthands into long form
   subroutine relate(token, last, fd)
   character ngetch
   character token(ARB)
   integer length
   integer fd, last
#   string dotge ".ge."
#   string dotgt ".gt."
#   string dotlt ".lt."
#   string dotle ".le."
#   string dotne ".ne."
#   string dotnot ".not."
#   string doteq ".eq."
#   string dotand ".and."
#   string dotor ".or."
   integer dotge(5), dotgt(5), dotlt(5), dotle(5)
   integer dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5)
   data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD,
      LETG, LETE, PERIOD, EOS/
   data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD,
      LETG, LETT, PERIOD, EOS/
   data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD,
      LETL, LETE, PERIOD, EOS/
   data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD,
      LETL, LETT, PERIOD, EOS/
   data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD,
      LETN, LETE, PERIOD, EOS/
   data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD,
      LETE, LETQ, PERIOD, EOS/
   data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD,
      LETO, LETR, PERIOD, EOS/
   data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5),
      dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/
   data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5),
      dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/
   if (ngetch(token(2), fd) ~= EQUALS)
      call putbak(token(2))
   if (token(1) == GREATER) {
      if (token(2) == EQUALS)
         call scopy(dotge, 1, token, 1)
      else
         call scopy(dotgt, 1, token, 1)
      $)
   else if (token(1) == LESS) {
      if (token(2) == EQUALS)
         call scopy(dotle, 1, token, 1)
      else
         call scopy(dotlt, 1, token, 1)
      $)
   else if (token(1) == NOT) {
      if (token(2) == EQUALS)
         call scopy(dotne, 1, token, 1)
      else
         call scopy(dotnot, 1, token, 1)
      $)
   else if (token(1) == EQUALS) {
      if (token(2) == EQUALS)
         call scopy(doteq, 1, token, 1)
      else
         token(2) = EOS
      $)
   else if (token(1) == AMPER)
      call scopy(dotand, 1, token, 1)
   else if (token(1) == BAR)
      call scopy(dotor, 1, token, 1)
   else   # can't happen
      token(2) = EOS
   last = length(token)
   return
   end
# remark - print warning message
   # this version is intentionally crude, and should be replaced
   # instantaneously by something tuned for your
   # specific environment.
   subroutine remark(buf)
   integer buf(ARB), i
   write(ERROUT, 10) (buf(i), i = 1, 5)
      10 format(5a4)
   return
   end
# repcod - generate code for beginning of repeat
   subroutine repcod(lab)
   integer labgen
   integer lab
   call outcon(0)   # in case there was a label
   lab = labgen(3)
   call outcon(lab)
   lab = lab + 1   # label to go on next's
   return
   end
# scopy - copy string at from(i) to to(j)
   subroutine scopy(from, i, to, j)
   character from(ARB), to(ARB)
   integer i, j, k1, k2
   k2 = j
   for (k1 = i; from(k1) ~= EOS; k1 = k1 + 1) {
      to(k2) = from(k1)
      k2 = k2 + 1
      $)
   to(k2) = EOS
   return
   end
# synerr - report Ratfor syntax error
   subroutine synerr(msg)
   character lc(MAXLINE), msg(MAXLINE)
   integer itoc
   integer i, junk
   include commonblocks
   # include cline
   call remark("error at line.")
   for (i = 1; i <= level; i = i + 1) {
      call putch(BLANK, ERROUT)
      junk = itoc(linect(i), lc, MAXLINE)
      call putlin(lc, ERROUT)
      $)
   call putch(COLON, ERROUT)
   call putch(NEWLINE, ERROUT)
   call remark(msg)
   return
   end
# type - return LETTER, DIGIT or character
   # this one works with ascii alphabet
   integer function type(c)
   integer c
   if( c >= DIG0 & c <= DIG9 )
      type = DIGIT
   else if( c >= LETA & c <= LETZ )
      type = LETTER
   else if( c >= BIGA & c <= BIGZ )
      type = LETTER
   else
      type = c
   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))
      else if (lextyp(sp) == LEXFOR)
         call fors(labval(sp))
      else if (lextyp(sp) == LEXREPEAT)
         call untils(labval(sp), token)
      $)
   return
   end
# untils - generate code for until or end of repeat
   subroutine untils(lab, token)
   character ptoken(MAXTOK)
   integer lex
   integer junk, lab, token
   call outnum(lab)
   if (token == LEXUNTIL) {
      junk = lex(ptoken)
      call ifgo(lab-1)
      $)
   else
      call outgo(lab-1)
   call outcon(lab+1)
   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
