========== edit program from chapter 6 ==========
define(MAXPAT,128)
define(andif,if)
define(GLOBAL,LETG)
define(PRINT,LETP)
define(MARKED,LETY)
define(NOMARK,LETN)
define(FORWARD,0)
define(BACKWARD,-1)
define(EXCLUDE,LETX)
define(APPENDCOM,LETA)
define(CHANGE,LETC)
define(DELCOM,LETD)
define(ENTER,LETE)
define(PRINTFIL,LETF)
define(READCOM,LETR)
define(WRITECOM,LETW)
define(INSERT,LETI)
define(PRINTCUR,EQUALS)
define(MOVECOM,LETM)
define(QUIT,LETQ)
define(SUBSTITUTE,LETS)
define(CURLINE,PERIOD)
define(LASTLINE,DOLLAR)
define(SCAN,SLASH)
define(BACKSCAN,BACKSLASH)
define(NOSTATUS,1)
define(LINE0,1)
define(PREV,0)
define(NEXT,1)
define(MARK,2)
define(TEXT,3)
define(MAXBUF,1000)
common /cbuf/ buf(MAXBUF), lastbf
   character buf      # buffer for pointers plus text
   integer lastbf      # last element used in buf
common /clines/ line1, line2, nlines, curln, lastln
   integer line1   # first line number
   integer line2   # second line number
   integer nlines   # number of line numbers specified
   integer curln   # current line: value of dot
   integer lastln   # last line: value of $
common /cpat/ pat(MAXPAT)
   character pat      # pattern
common /ctxt/ txt(MAXLINE)
   character txt      # text line for matching and output
common /cfile/ savfil(MAXLINE)
   character savfil   # remembered file name
# append - append lines after "line"
   integer function append(line, glob)
   character lin(MAXLINE)
   integer getlin, inject
   integer line, glob
   include clines
   if (glob == YES)
      append = ERR
   else {
      curln = line
      for (append = NOSTATUS; append == NOSTATUS; )
         if (getlin(lin, STDIN) == EOF)
            append = EOF
         else if (lin(1) == PERIOD & lin(2) == NEWLINE)
            append = OK
         else if (inject(lin) == ERR)
            append = ERR
      $@$
   return
   end
# ckglob - if global prefix, mark lines to be affected
   integer function ckglob(lin, i, status)
   character lin(MAXLINE)
   integer defalt, getind, gettxt, match, nextln, optpat
   integer gflag, i, k, line, status
   include cbuf
   include clines
   include cpat
   include ctxt
   if (lin(i) ~= GLOBAL & lin(i) ~= EXCLUDE)
      status = EOF
   else {
      if (lin(i) == GLOBAL)
         gflag = YES
      else
         gflag = NO
      i = i + 1
      if (optpat(lin, i) == ERR | defalt(1, lastln, status) == ERR)
         status = ERR
      else {
         i = i + 1
         for (line = line1; line <= line2; line = line + 1) {
            k = gettxt(line)
            if (match(txt, pat) == gflag)
               buf(k+MARK) = YES
            else
               buf(k+MARK) = NO
            $@$
         for (line=nextln(line2); line~=line1; line=nextln(line)) {
            k = getind(line)
            buf(k+MARK) = NO
            $@$
         status = OK
         $@$
      $@$
   ckglob = status
   return
   end
# ckp - check for "p" after command
   integer function ckp(lin, i, pflag, status)
   character lin(MAXLINE)
   integer i, j, pflag, status
   j = i
   if (lin(j) == PRINT) {
      j = j + 1
      pflag = YES
      $@$
   else
      pflag = NO
   if (lin(j) == NEWLINE)
      status = OK
   else
      status = ERR
   ckp = status
   return
   end
# clrbuf  (in memory) - initialize for new file
   subroutine clrbuf
   return      # nothing to do
   end
# defalt - set defaulted line numbers
   integer function defalt(def1, def2, status)
   integer def1, def2, status
   include clines
   if (nlines == 0) {
      line1 = def1
      line2 = def2
      $@$
   if (line1 > line2 | line1 <= 0)
      status = ERR
   else
      status = OK
   defalt = status
   return
   end
# delete - delete lines from through to
   integer function delete(from, to, status)
   integer getind, nextln, prevln
   integer from, k1, k2, status, to
   include clines
   if (from <= 0)
      status = ERR
   else {
      k1 = getind(prevln(from))
      k2 = getind(nextln(to))
      lastln = lastln - (to - from + 1)
      curln = prevln(from)
      call relink(k1, k2, k1, k2)
      status = OK
      $@$
   delete = status
   return
   end
# docmd - handle all commands except globals
   integer function docmd(lin, i, glob, status)
   character file(MAXLINE), lin(MAXLINE), sub(MAXPAT)
   integer append, delete, doprnt, doread, dowrit, move, subst
   integer ckp, defalt, getfn, getone, getrhs, nextln, optpat, prevln
   integer gflag, glob, i, line3, pflag, status
   include cfile
   include clines
   include cpat
   pflag = NO      # may be set by d, m, s
   status = ERR
   if (lin(i) == APPENDCOM) {
      if (lin(i + 1) == NEWLINE)
         status = append(line2, glob)
      $@$
   else if (lin(i) == CHANGE) {
      if (lin(i + 1) == NEWLINE)
        andif (defalt(curln, curln, status) == OK)
        andif (delete(line1, line2, status) == OK)
         status = append(prevln(line1), glob)
      $@$
   else if (lin(i) == DELCOM) {
      if (ckp(lin, i + 1, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
        andif (delete(line1, line2, status) == OK)
        andif (nextln(curln) ~= 0)
         curln = nextln(curln)
      $@$
   else if (lin(i) == INSERT) {
      if (lin(i + 1) == NEWLINE)
         status = append(prevln(line2), glob)
      $@$
   else if (lin(i) == PRINTCUR) {
      if (ckp(lin, i + 1, pflag, status) == OK) {
         call putdec(line2, 1)
         call putc(NEWLINE)
         $@$
      $@$
   else if (lin(i) == MOVECOM) {
      i = i + 1
      if (getone(lin, i, line3, status) == EOF)
         status = ERR
      if (status == OK)
        andif (ckp(lin, i, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
         status = move(line3)
      $@$
   else if (lin(i) == SUBSTITUTE) {
      i = i + 1
      if (optpat(lin, i) == OK)
        andif (getrhs(lin, i, sub, gflag) == OK)
        andif (ckp(lin, i + 1, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
         status = subst(sub, gflag)
      $@$
   else if (lin(i) == ENTER) {
      if (nlines == 0)
        andif (getfn(lin, i, file) == OK) {
         call scopy(file, 1, savfil, 1)
         call clrbuf
         call setbuf
         status = doread(0, file)
         $@$
      $@$
   else if (lin(i) == PRINTFIL) {
      if (nlines == 0)
        andif (getfn(lin, i, file) == OK) {
         call scopy(file, 1, savfil, 1)
         call putlin(savfil, STDOUT)
         call putc(NEWLINE)
         status = OK
         $@$
      $@$
   else if (lin(i) == READCOM) {
      if (getfn(lin, i, file) == OK)
         status = doread(line2, file)
      $@$
   else if (lin(i) == WRITECOM) {
      if (getfn(lin, i, file) == OK)
        andif (defalt(1, lastln, status) == OK)
         status = dowrit(line1, line2, file)
      $@$
   else if (lin(i) == PRINT) {
      if (lin(i + 1) == NEWLINE)
        andif (defalt(curln, curln, status) == OK)
         status = doprnt(line1, line2)
      $@$
   else if (lin(i) == NEWLINE) {
      if (nlines == 0)
         line2 = nextln(curln)
      status = doprnt(line2, line2)
      $@$
   else if (lin(i) == QUIT) {
      if (lin(i + 1) == NEWLINE & nlines == 0 & glob == NO)
         status = EOF
      $@$
   # else status is ERR
   if (status == OK & pflag == YES)
      status = doprnt(curln, curln)
   docmd = status
   return
   end
# doglob - do command at lin(i) on all marked lines
   integer function doglob(lin, i, cursav, status)
   character lin(MAXLINE)
   integer docmd, getind, getlst, nextln
   integer count, cursav, i, istart, k, line, status
   include cbuf
   include clines
   status = OK
   count = 0
   line = line1
   istart = i
   repeat {
      k = getind(line)
      if (buf(k+MARK) == YES) {
         buf(k+MARK) = NO
         curln = line
         cursav = curln
         i = istart
         if (getlst(lin, i, status) == OK)
           andif (docmd(lin, i, YES, status) == OK)
            count = 0
         $@$
      else {
         line = nextln(line)
         count = count + 1
         $@$
      $@$ until (count > lastln | status ~= OK)
   doglob = status
   return
   end
# doprnt - print lines from through to
   integer function doprnt(from, to)
   integer gettxt
   integer from, i, j, to
   include clines
   include ctxt
   if (from <= 0)
      doprnt = ERR
   else {
      for (i = from; i <= to; i = i + 1) {
         j = gettxt(i)
         call putlin(txt, STDOUT)
         $@$
      curln = to
      doprnt = OK
      $@$
   return
   end
# doread - read "file" after "line"
   integer function doread(line, file)
   character file(MAXLINE), lin(MAXLINE)
   integer getlin, inject, open
   integer count, fd, line
   include clines
   fd = open(file, READ)
   if (fd == ERR)
      doread = ERR
   else {
      curln = line
      doread = OK
      for (count = 0; getlin(lin, fd) ~= EOF; count = count + 1) {
         doread = inject(lin)
         if (doread == ERR)
            break
         $@$
      call close(fd)
      call putdec(count, 1)
      call putc(NEWLINE)
      $@$
   return
   end
# dowrit - write "from" through "to" into file
   integer function dowrit(from, to, file)
   character file(MAXLINE)
   integer create, gettxt
   integer fd, from, k, line, to
   include ctxt
   fd = create(file, WRITE)
   if (fd == ERR)
      dowrit = ERR
   else {
      for (line = from; line <= to; line = line + 1) {
         k = gettxt(line)
         call putlin(txt, fd)
         $@$
      call close(fd)
      call putdec(to-from+1, 1)
      call putc(NEWLINE)
      dowrit = OK
      $@$
   return
   end
# edit - main routine
   character lin(MAXLINE)
   integer ckglob, docmd, doglob, doread, getarg, getlin, getlst
   integer cursav, i, status
   include cfile
   include clines
   include cpat
   call setbuf
   pat(1) = EOS
   savfil(1) = EOS
   if (getarg(1, savfil, MAXLINE) ~= EOF)
      if (doread(0, savfil) == ERR)
         call remark("?.")
   while (getlin(lin, STDIN) ~= EOF) {
      i = 1
      cursav = curln
      if (getlst(lin, i, status) == OK) {
         if (ckglob(lin, i, status) == OK)
            status = doglob(lin, i, cursav, status)
         else if (status ~= ERR)
            status = docmd(lin, i, NO, status)
         # else error, do nothing
         $@$
      if (status == ERR) {
         call remark("?.")
         curln = cursav
         $@$
      else if (status == EOF)
         break
      # else OK, loop
      $@$
   call clrbuf
   stop
   end
# getfn - get file name from lin(i)...
   integer function getfn(lin, i, file)
   character lin(MAXLINE), file(MAXLINE)
   integer i, j, k
   include cfile
   getfn = ERR
   if (lin(i + 1) == BLANK) {
      j = i + 2      # get new file name
      call skipbl(lin, j)
      for (k = 1; lin(j) ~= NEWLINE; k = k + 1) {
         file(k) = lin(j)
         j = j + 1
         $@$
      file(k) = EOS
      if (k > 1)
         getfn = OK
      $@$
   else if (lin(i + 1) == NEWLINE & savfil(1) ~= EOS) {
      call scopy(savfil, 1, file, 1)   # or old name
      getfn = OK
      $@$
   # else error
   if (getfn == OK & savfil(1) == EOS)
      call scopy(file, 1, savfil, 1)   # save if no old one
   return
   end
# getind - locate line index in buffer
   integer function getind(line)
   integer j, k, line
   include cbuf
   k = LINE0
   for (j = 0; j < line; j = j + 1)
      k = buf(k + NEXT)
   getind = k
   return
   end
# getlst - collect line numbers (if any) at lin(i), increment i
   integer function getlst(lin, i, status)
   character lin(MAXLINE)
   integer getone, min
   integer i, num, status
   include clines
   line2 = 0
   for (nlines = 0; getone(lin, i, num, status) == OK; ) {
      line1 = line2
      line2 = num
      nlines = nlines + 1
      if (lin(i) ~= COMMA & lin(i) ~= SEMICOL)
         break
      if (lin(i) == SEMICOL)
         curln = num
      i = i + 1
      $@$
   nlines = min(nlines, 2)
   if (nlines == 0)
      line2 = curln
   if (nlines <= 1)
      line1 = line2
   if (status ~= ERR)
      status = OK
   getlst = status
   return
   end
# getnum - convert one term to line number
   integer function getnum(lin, i, pnum, status)
   character lin(MAXLINE)
   integer ctoi, index, optpat, ptscan
   integer i, pnum, status
   include clines
   include cpat
#   string digits "0123456789"
   integer digits(11)
   data digits(01)/DIG0/
   data digits(02)/DIG1/
   data digits(03)/DIG2/
   data digits(04)/DIG3/
   data digits(05)/DIG4/
   data digits(06)/DIG5/
   data digits(07)/DIG6/
   data digits(08)/DIG7/
   data digits(09)/DIG8/
   data digits(10)/DIG9/
   data digits(11)/EOS/
   getnum = OK
   if (index(digits, lin(i)) > 0) {
      pnum = ctoi(lin, i)
      i = i - 1   # move back; to be advanced at the end
      $@$
   else if (lin(i) == CURLINE)
      pnum = curln
   else if (lin(i) == LASTLINE)
      pnum = lastln
   else if (lin(i) == SCAN | lin(i) == BACKSCAN) {
      if (optpat(lin, i) == ERR)   # build the pattern
         getnum = ERR
      else if (lin(i) == SCAN)
         getnum = ptscan(FORWARD, pnum)
      else
         getnum = ptscan(BACKWARD, pnum)
      $@$
   else
      getnum = EOF
   if (getnum == OK)
      i = i + 1   # point at next character to be examined
   status = getnum
   return
   end
# getone - evaluate one line number expression
   integer function getone(lin, i, num, status)
   character lin(MAXLINE)
   integer getnum
   integer i, istart, mul, num, pnum, status
   include clines
   istart = i
   num = 0
   call skipbl(lin, i)
   if (getnum(lin, i, num, status) == OK)   # first term
      repeat {            # + or - terms
         call skipbl(lin, i)
         if (lin(i) ~= PLUS & lin(i) ~= MINUS) {
            status = EOF
            break
            $@$
         if (lin(i) == PLUS)
            mul = +1
         else
            mul = -1
         i = i + 1
         call skipbl(lin, i)
         if (getnum(lin, i, pnum, status) == OK)
            num = num + mul * pnum
         if (status == EOF)
            status = ERR
         $@$ until (status ~= OK)
   if (num < 0 | num > lastln)
      status = ERR
   if (status == ERR)
      getone = ERR
   else if (i <= istart)
      getone = EOF
   else
      getone = OK
   status = getone
   return
   end
# getrhs - get substitution string for "s" command
   integer function getrhs(lin, i, sub, gflag)
   character lin(MAXLINE), sub(MAXPAT)
   integer maksub
   integer gflag, i
   getrhs = ERR
   if (lin(i) == EOS)
      return
   if (lin(i + 1) == EOS)
      return
   i = maksub(lin, i + 1, lin(i), sub)
   if (i == ERR)
      return
   if (lin(i + 1) == GLOBAL) {
      i = i + 1
      gflag = YES
      $@$
   else
      gflag = NO
   getrhs = OK
   return
   end
# gettxt  (in memory) - locate text for line and make available
   integer function gettxt(line)
   integer getind
   integer line
   include cbuf
   include ctxt
   gettxt = getind(line)
   call scopy(buf, gettxt + TEXT, txt, 1)
   return
   end
# inject  (in memory) - put text from lin after curln
   integer function inject(lin)
   character lin(MAXLINE)
   integer addset, getind, nextln
   integer i, junk, k1, k2, k3
   include cbuf
   include clines
   for (i = 1; lin(i) ~= EOS; ) {
      k3 = lastbf
      lastbf = lastbf + TEXT
      while (lin(i) ~= EOS) {
         junk = addset(lin(i), buf, lastbf, MAXBUF)
         i = i + 1
         if (lin(i - 1) == NEWLINE)
            break
         $@$
      if (addset(EOS, buf, lastbf, MAXBUF) == NO) {
         inject = ERR
         break
         $@$
      k1 = getind(curln)
      k2 = getind(nextln(curln))
      call relink(k1, k3, k3, k2)
      call relink(k3, k2, k1, k3)
      curln = curln + 1
      lastln = lastln + 1
      inject = OK
      $@$
   return
   end
# move - move line1 through line2 after line3
   integer function move(line3)
   integer getind, nextln, prevln
   integer k0, k1, k2, k3, k4, k5, line3
   include clines
   if (line1 <= 0 | (line1 <= line3 & line3 <= line2))
      move = ERR
   else {
      k0 = getind(prevln(line1))
      k3 = getind(nextln(line2))
      k1 = getind(line1)
      k2 = getind(line2)
      call relink(k0, k3, k0, k3)
      if (line3 > line1) {
         curln = line3
         line3 = line3 - (line2 - line1 + 1)
         $@$
      else
         curln = line3 + (line2 - line1 + 1)
      k4 = getind(line3)
      k5 = getind(nextln(line3))
      call relink(k4, k1, k2, k5)
      call relink(k2, k5, k4, k1)
      move = OK
      $@$
   return
   end
# nextln - get line after "line"
   integer function nextln(line)
   integer line
   include clines
   nextln = line + 1
   if (nextln > lastln)
      nextln = 0
   return
   end
# optpat - make pattern if specified at lin(i)
   integer function optpat(lin, i)
   character lin(MAXLINE)
   integer makpat
   integer i
   include cpat
   if (lin(i) == EOS)
      i = ERR
   else if (lin(i + 1) == EOS)
      i = ERR
   else if (lin(i + 1) == lin(i))   # repeated delimiter
      i = i + 1         # leave existing pattern alone
   else
      i = makpat(lin, i + 1, lin(i), pat)
   if (pat(1) == EOS)
      i = ERR
   if (i == ERR) {
      pat(1) = EOS
      optpat = ERR
      $@$
   else
      optpat = OK
   return
   end
# prevln - get line before "line"
   integer function prevln(line)
   integer line
   include clines
   prevln = line - 1
   if (prevln < 0)
      prevln = lastln
   return
   end
# ptscan - scan for next occurrence of pattern
   integer function ptscan(way, num)
   integer gettxt, match, nextln, prevln
   integer k, num, way
   include clines
   include cpat
   include ctxt
   num = curln
   repeat {
      if (way == FORWARD)
         num = nextln(num)
      else
         num = prevln(num)
      k = gettxt(num)
      if (match(txt, pat) == YES) {
         ptscan = OK
         return
         $@$
      $@$ until (num == curln)
   ptscan = ERR
   return
   end
# relink - rewrite two half links
   subroutine relink(a, x, y, b)
   integer a, b, x, y
   include cbuf
   buf(x + PREV) = a
   buf(y + NEXT) = b
   return
   end
# setbuf (in memory) - initialize line storage buffer
   subroutine setbuf
   integer addset
   integer junk
   include cbuf
   include clines
   call relink(LINE0, LINE0, LINE0, LINE0)
   lastbf = LINE0 + TEXT
   junk = addset(EOS, buf, lastbf, MAXBUF)
   curln = 0
   lastln = 0
   return
   end
# skipbl - skip blanks and tabs at lin(i)...
   subroutine skipbl(lin, i)
   character lin(ARB)
   integer i
   while (lin(i) == BLANK | lin(i) == TAB)
      i = i + 1
   return
   end
# subst - substitute "sub" for occurrences of pattern
   integer function subst(sub, gflag)
   character new(MAXLINE), sub(MAXPAT)
   integer addset, amatch, gettxt, inject
   integer gflag, j, junk, k, lastm, line, m, status, subbed
   include clines
   include cpat
   include ctxt
   subst = ERR
   if (line1 <= 0)
      return
   for (line = line1; line <= line2; line = line + 1) {
      j = 1
      subbed = NO
      junk = gettxt(line)
      lastm = 0
      for (k = 1; txt(k) ~= EOS; ) {
         if (gflag == YES | subbed == NO)
            m = amatch(txt, k, pat)
         else
            m = 0
         if (m > 0 & lastm ~= m) {   # replace matched text
            subbed = YES
            call catsub(txt, k, m, sub, new, j, MAXLINE)
            lastm = m
            $@$
         if (m == 0 | m == k) {   # no match or null match
            junk = addset(txt(k), new, j, MAXLINE)
            k = k + 1
            $@$
         else            # skip matched text
            k = m
         $@$
      if (subbed == YES) {
         if (addset(EOS, new, j, MAXLINE) == NO) {
            subst = ERR
            break
            $@$
         call delete(line, line, status)   # remembers dot
         subst = inject(new)
         if (subst == ERR)
            break
         subst = OK
         $@$
      $@$
   return
   end