========== macro processors of chapter 8 ==========
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 /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 /cmacro/ cp, ep, evalst(EVALSIZE)
   integer cp         # current call stack pointer
   integer ep         # next free position in evalst
   character evalst      # evaluation stack
# block data for macro
   block data
   include cdefio
   data bp /0/
   end
# gettok - get alphanumeric string or single non-alpha for define
   character function gettok(token, toksiz)
   character ngetc, type
   integer i, toksiz
   character token(toksiz)
   for (i = 1; i < toksiz; i = i + 1) {
      gettok = type(ngetc(token(i)))
      if (gettok ~= LETTER & gettok ~= DIGIT)
         break
      $@$
   if (i >= toksiz)
      call error("token too long.")
   if (i > 1) {         # some alpha was seen
      call putbak(token(i))
      i = i - 1
      gettok = ALPHA
      $@$
   # else single character token
   token(i+1) = EOS
   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
# macro - expand macros with arguments
   character gettok
   character defn(MAXDEF), t, token(MAXTOK)
   integer lookup, push
   integer ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE)
   include cmacro
#   string balp "()"
   integer balp(3)
#   string defnam "define"
   integer defnam(7)
#   string incnam "incr"
   integer incnam(5)
#   string subnam "substr"
   integer subnam(7)
#   string ifnam "ifelse"
   integer ifnam(7)
   integer deftyp(2)
   integer inctyp(2)
   integer subtyp(2)
   integer iftyp(2)
   data balp(1) /LPAREN/, balp(2) /RPAREN/, balp(3) /EOS/
   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 incnam(1)/LETI/,incnam(2)/LETN/,incnam(3)/LETC/,incnam(4)/LETR/
   data incnam(5) /EOS/
   data subnam(1) /LETS/, subnam(2) /LETU/, subnam(3) /LETB/
   data subnam(4) /LETS/, subnam(5) /LETT/, subnam(6) /LETR/
   data subnam(7) /EOS/
   data ifnam(1) /LETI/, ifnam(2) /LETF/, ifnam(3) /LETE/
   data ifnam(4) /LETL/, ifnam(5) /LETS/, ifnam(6) /LETE/
   data ifnam(7) /EOS/
   data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/
   data inctyp(1) /INCTYPE/, inctyp(2) /EOS/
   data subtyp(1) /SUBTYPE/, subtyp(2) /EOS/
   data iftyp(1) /IFTYPE/, iftyp(2) /EOS/
   call instal(defnam, deftyp)
   call instal(incnam, inctyp)
   call instal(subnam, subtyp)
   call instal(ifnam, iftyp)
   cp = 0
   ap = 1
   ep = 1
   for (t=gettok(token, MAXTOK); t ~= EOF; t=gettok(token, MAXTOK)) {
      if (t == ALPHA) {
         if (lookup(token, defn) == NO)
            call puttok(token)
         else {            # defined; put it in eval stack
            cp = cp + 1
            if (cp > CALLSIZE)
               call error("call stack overflow.")
            callst(cp) = ap
            ap = push(ep, argstk, ap)
            call puttok(defn)   # stack definition
            call putchr(EOS)
            ap = push(ep, argstk, ap)
            call puttok(token)   # stack name
            call putchr(EOS)
            ap = push(ep, argstk, ap)
            t = gettok(token, MAXTOK)   # peek at next
            call pbstr(token)
            if (t ~= LPAREN)   # add ( ) if not present
               call pbstr(balp)
            plev(cp) = 0
            $@$
         $@$
      else if (t == LBRACK) {      # strip one level of [ ]
         nlb = 1
         repeat {
            t = gettok(token, MAXTOK)
            if (t == LBRACK)
               nlb = nlb + 1
            else if (t == RBRACK) {
               nlb = nlb - 1
               if (nlb == 0)
                  break
               $@$
            else if (t == EOF)
               call error("EOF in string.")
            call puttok(token)
            $@$
         $@$
      else if (cp == 0)         # not in a macro at all
         call puttok(token)
      else if (t == LPAREN) {
         if (plev(cp) > 0)
            call puttok(token)
         plev(cp) = plev(cp) + 1
         $@$
      else if (t == RPAREN) {
         plev(cp) = plev(cp) - 1
         if (plev(cp) > 0)
            call puttok(token)
         else {            # end of argument list
            call putchr(EOS)
            call eval(argstk, callst(cp), ap-1)
            ap = callst(cp)   # pop eval stack
            ep = argstk(ap)
            cp = cp - 1
            $@$
         $@$
      else if (t == COMMA & plev(cp) == 1) {   # new arg
         call putchr(EOS)
         ap = push(ep, argstk, ap)
         $@$
      else
         call puttok(token)      # just stack it
      $@$
   if (cp ~= 0)
      call error("unexpected EOF.")
   stop
   end
# push - push ep onto argstk, return new pointer ap
   integer function push(ep, argstk, ap)
   integer ap, argstk(ARGSIZE), ep
   if (ap > ARGSIZE)
      call error("arg stack overflow.")
   argstk(ap) = ep
   push = ap + 1
   return
   end
# puttok - put a token either on output or into evaluation stack
   subroutine puttok(str)
   character str(MAXTOK)
   integer i
   for (i = 1; str(i) ~= EOS; i = i + 1)
      call putchr(str(i))
   return
   end
# putchr - put single char on output or into evaluation stack
   subroutine putchr(c)
   character c
   include cmacro
   if (cp == 0)
      call putc(c)
   else {
      if (ep > EVALSIZE)
         call error("evaluation stack overflow.")
      evalst(ep) = c
      ep = ep + 1
      $@$
   return
   end
# eval - expand args i through j: evaluate builtin or push back defn
   subroutine eval(argstk, i, j)
   integer index, length
   integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td
   include cmacro
#   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/
   t = argstk(i)
   td = evalst(t)
   if (td == DEFTYPE)
      call dodef(argstk, i, j)
   else if (td == INCTYPE)
      call doincr(argstk, i, j)
   else if (td == SUBTYPE)
      call dosub(argstk, i, j)
   else if (td == IFTYPE)
      call doif(argstk, i, j)
   else {
      for (k = t+length(evalst(t))-1; k > t; k = k - 1)
         if (evalst(k-1) ~= ARGFLAG)
            call putbak(evalst(k))
         else {
            argno = index(digits, evalst(k)) - 1
            if (argno >= 0 & argno < j-i) {
               n = i + argno + 1
               m = argstk(n)
               call pbstr(evalst(m))
               $@$
            k = k - 1   # skip over $
            $@$
      if (k == t)         # do last character
         call putbak(evalst(k))
      $@$
   return
   end
# dodef - install definition in table
   subroutine dodef(argstk, i, j)
   integer a2, a3, argstk(ARGSIZE), i, j
   include cmacro
   if (j - i > 2) {
      a2 = argstk(i+2)
      a3 = argstk(i+3)
      call instal(evalst(a2), evalst(a3))   # subarrays
      $@$
   return
   end
# doincr - increment argument by 1
   subroutine doincr(argstk, i, j)
   integer ctoi
   integer argstk(ARGSIZE), i, j, k
   include cmacro
   k = argstk(i+2)
   call pbnum(ctoi(evalst, k)+1)
   return
   end
# pbnum - convert number to string, push back on input
   subroutine pbnum(n)
   integer mod
   integer m, n, num
#   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/
   num = n
   repeat {
      m = mod(num, 10)
      call putbak(digits(m+1))
      num = num / 10
      $@$ until (num == 0)
   return
   end
# dosub - select substring
   subroutine dosub(argstk, i, j)
   integer ctoi, length, max, min
   integer ap, argstk(ARGSIZE), fc, i, j, k, nc
   include cmacro
   if (j - i < 3)
      return
   if (j - i < 4)
      nc = MAXTOK
   else {
      k = argstk(i+4)
      nc = ctoi(evalst, k)      # number of characters
      $@$
   k = argstk(i+3)         # origin
   ap = argstk(i+2)         # target string
   fc = ap + ctoi(evalst, k) - 1   # first char of substring
   if (fc >= ap & fc < ap + length(evalst(ap))) {   # subarrays
      k = fc + min(nc, length(evalst(fc))) - 1
      for ( ; k >= fc; k = k - 1)
         call putbak(evalst(k))
      $@$
   return
   end
# doif - select one of two arguments
   subroutine doif(argstk, i, j)
   integer equal
   integer a2, a3, a4, a5, argstk(ARGSIZE), i, j
   include cmacro
   if (j - i < 5)
      return
   a2 = argstk(i+2)
   a3 = argstk(i+3)
   a4 = argstk(i+4)
   a5 = argstk(i+5)
   if (equal(evalst(a2), evalst(a3)) == YES)   # subarrays
      call pbstr(evalst(a4))
   else
      call pbstr(evalst(a5))
   return
   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
# 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
# define - simple string replacement macro processor
   character gettok
   character defn(MAXDEF), t, token(MAXTOK)
   integer lookup
#   string defnam "define"
   integer defnam(7)
   integer 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) /DEFTYPE/, deftyp(2) /EOS/
   call instal(defnam, deftyp)
   for (t = gettok(token, MAXTOK); t ~= EOF; t = gettok(token, MAXTOK))
      if (t ~= ALPHA)      # output non-alpha tokens
         call putlin(token, STDOUT)
      else if (lookup(token, defn) == NO)   # and undefined
         call putlin(token, STDOUT)
      else if (defn(1) == DEFTYPE) {      # get definition
         call getdef(token, MAXTOK, defn, MAXDEF)
         call instal(token, defn)
         $@$
      else
         call pbstr(defn)   # push replacement onto input
   stop
   end
# getdef (for no arguments) - get name and definition
   subroutine getdef(token, toksiz, defn, defsiz)
   character gettok, ngetc
   integer defsiz, i, nlpar, toksiz
   character c, defn(defsiz), token(toksiz)
   if (ngetc(c) ~= LPAREN)
      call error("missing left paren.")
   else if (gettok(token, toksiz) ~= ALPHA)
      call error("non-alphanumeric name.")
   else if (ngetc(c) ~= COMMA)
      call error("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 (ngetc(defn(i)) == 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
