#
#
#
#    LIST File Listing Utility
#    =========================
#
#         Author:  William Wood
#
#         Address: Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 2.0
#
#         Date:    December 1, 1980
#
#
#
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DEVELOPED WITH SUPPORT       *
#      *      FROM THE NATIONAL INSTITUTES OF HEALTH:        *
#      *         NIH CA06927                                 *
#      *         NIH CA22780                                 *
#      *                                                     *
#      *      DIRECT INQUIRIES TO:                           *
#      *            COMPUTER CENTER                          *
#      *            THE INSTITUTE FOR CANCER RESEARCH        *
#      *            7701 BURHOLME AVENUE                     *
#      *            PHILADELPHIA, PENNSYLVANIA   19111       *
#      *                                                     *
#      *      NO WARRANTY OR REPRESENTATION, EXPRESS OR      *
#      *      IMPLIED, IS MADE WITH RESPECT TO THE           *
#      *      CORRECTNESS, COMPLETENESS, OR USEFULNESS       *
#      *      OF THIS SOFTWARE, NOR THAT USE OF THIS         *
#      *      SOFTWARE MIGHT NOT INFRINGE PRIVATELY          *
#      *      OWNED RIGHTS.                                  *
#      *                                                     *
#      *      NO LIABILITY IS ASSUMED WITH RESPECT TO        *
#      *      THE USE OF, OR FOR DAMAGES RESULTING FROM      *
#      *      THE USE OF THIS SOFTWARE                       *
#      *                                                     *
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DESIGNED FOR USE ON A        *
#      *      PDP-11/70 OPERATING UNDER IAS V3.0 USING       *
#      *      THE FORTRAN-IV PLUS COMPILER.                  *
#      *                                                     *
#      *******************************************************
#
#
#
include symbols.rat

# list - driver program for LIST file listing facility
program list
byte comand(MAXLINE+FILENAMESIZE), file(MAXLINE), ans(2)
integer nc, source, stdout, nfile, ftmp, ier
logical hdr
integer redir
logical opndef, eq, getfil
 
ftmp = TERM
%
      open(unit=ftmp, name='TI:', carriagecontrol='LIST')
%
ftmp = NONETERM
%
      open(unit=ftmp, name='TI:', carriagecontrol='NONE',
     *     recordsize=524)
%
call errset(29,.true.,.false.,.true.,.false.,15)  # no such file
call errset(30,.true.,.false.,.true.,.false.,15)  # open failure
call errset(43,.true.,.false.,.false.,.false.,15) # file name specification
call errset(64,.true.,.false.,.true.,.false.,15)  # input conversion error
call errset(68,.true.,.false.,.true.,.false.,15)  # variable format exp err
call gttyp(TERM)
stdout = NONETERM
 
repeat {
  call gcmd(TERM, 'FILE? ', comand, nc, MAXLINE, source)
  if (nc <= 0)
    break
 
  ans(1) = 'N'
  hdr = .false.
  repeat {
    call parse(comand, file)
    if (eq(file, '/GO'))
      ans(1) = 'G'
    else if (eq(file, '/HD'))
      hdr = .true.
    else
      break
    }
 
  nfile = 0
  while (getfil(file, ans, nfile, .true.))
    if (opndef(FILEIN, file))
      if (redir(stdout, comand) ~= ERROR) {
        if (hdr)
          call puthdr(stdout, file)
        call listit(FILEIN, stdout, comand)
RECORDIO         close(unit = FILEIN)
BLOCKIO          call bclose(FILEIN)
        }
      else {
RECORDIO         close(unit = FILEIN)
BLOCKIO          call bclose(FILEIN)
        break
        }
 
  if (stdout ~= NONETERM) {
    close(unit = stdout)
    stdout = NONETERM
    }
  } until(source < 0)				# command line was from MCR
call put(NONETERM, CR, 1, ier)
call tabbak(TERM)
end
 
# listit - list the file
subroutine listit(f, stdout, comnd)
byte comnd(1), comand(2*MAXLINE), cmnd, macro(2*MAXLINE), last(2*MAXLINE),
     inbuf(BUFSIZ), qbuf(BUFSIZ+8)
integer f, stdout, fout, fold, blen, cp, nlnum, j, k, ier
DT80 integer ffchar
biginteger nprint, ntoprt, line1, line2, num, save1, save2, eofln, mxsrch,
           hlddot, tmpdot
logical print, prmmod, bsfail, noprnt
DT80 logical vmode
integer rcmd, getinp, typlin, getnum, chscan, replac, redir
biginteger ptscan
byte cupper
include clist.cmn
include term.cmn
include pat.cmn
DT80 include qiofn.cmn
equivalence (qbuf(9), inbuf(1))
data prmmod/.true./				# normal prompt mode
DT80 data vmode/.false./			# copy mode off
data macro(1), macro(2), macro(3), macro(4), macro(5), macro(6) /' ',
     '1', 'S', 'N', 'P', EOS/	# default puts you in line-by-line mode
data last(1) /EOS/

call scopy(comnd, 1, comand, 1)
fout = stdout
call initio(f, fout)

repeat {
  cp = 1		# cp points to current command in command buffer
  if (redir(fout, comand) == ERROR)			# do file redirection
    comand(cp) = ERROR
							# do last replacement
  else if (replac('L', last, comand, 2*MAXLINE, cp) ~= YES)
    call err(comand, cp, 'Command too long.')
 
  else {
    j = cp
    if (chscan(comand, j, '[') == YES) {		# define macro
      k = j+1
      ier = chscan(comand, k, ']')
      comand(k) = EOS
      call scopy(comand, j+1, macro, 1)
      comand(j) = ' '		# the null comand
      if (ier == YES)
        call scopy(comand, k+1, comand, j+1)
      else
        comand(j+1) = EOS
      }
							# do macro replacement
    if (replac('M', macro, comand, 2*MAXLINE, cp) ~= YES)
      call err(comand, cp, 'Command too long.')
    }
 
  odot = dot
  repeat {
    print = .false.
    ntoprt = 0
    nprint = 0
    nlnum = 0
    line2 = dot
    hlddot = dot
    save2 = dot
    noprnt = .false.
    repeat {
      if (comand(cp) == ',') {
        noprnt = .false.
        cp = cp + 1
        nlnum = 2
        line1 = line2
        save1 = save2
        }
      bsfail = .false.
      tmpdot = dot
      if (getnum(f, comand, cp, inbuf, blen, num, bsfail) ~= YES)
        break
      noprnt = bsfail
      if (nlnum == 0)
        nlnum = 1
      save2 = num
      line2 = min0(fmax+1, max0(1, num))
      dot = line2
      if (nlnum <= 1)
        hlddot = tmpdot
      }
 
    cmnd = cupper(comand(cp))
    if (cmnd == EOS  |  cmnd == 'P'  |  cmnd == ESC) {
      print = .true.
      if (cmnd == EOS)
        cp = cp-1					# will add 1 later
      if (nlnum <= 1  &  cmnd == ESC) {
        dot = dot-2*scrsiz
        if (dot < 1) {
          if ((topscr == 1  &  nlnum == 0)  |  line2 == 1)
            print = .false.
          dot = 1
          }
        }
      else if (nlnum >= 2) {
        if (line2 < line1)
          print = .false.
        else
          ntoprt = (line2 - line1) + 1
        dot = line1
        }
      }
    else if (cmnd == ' ')
      ;
    else if (cmnd == 'G') {
      print = .true.
      if (nlnum <= 1)
        ntoprt = 1
      else {
        if (line2 < line1)
          print = .false.
        else
          ntoprt = (line2 - line1) + 1
        dot = line1
        }
      }
    else if (cmnd == 'S') {
      dot = hlddot
      if (nlnum == 0)
        scrsiz = SCRLENGTH
      else if (nlnum == 1)
        scrsiz = max0(1, save2)
      else
        scrsiz = max0(1, (line2 - line1) + 1)
      }
    else if (cmnd == 'C') {
      lstred = 0
      dot = hlddot
      if (nlnum == 0) {
        lowc = 1
        highc = BUFSIZ
        }
      else if (nlnum == 1) {
        lowc = 1
        highc = max0(1, save2)
        }
      else {
        lowc = max0(1, save1)
        highc = max0(lowc, save2)
        }
      }
#
# the W command is installation dependent because the screen width
# value returned from the system is different on M systems than IAS.
# Fix it if you like.
#
WIDTH else if (cmnd == 'W') {
WIDTH   dot = hlddot
WIDTH   if (nlnum == 0)
WIDTH     scrwid = syswid
WIDTH   else
WIDTH     scrwid = max0(1, save2)
WIDTH   call setwid(TERM, scrwid)
WIDTH   }
    else if (cmnd == 'N') {
      prmmod = ~prmmod
      }
    else if (cmnd == 'F') {
      if (nlnum == 0) {
        foff = 0
        fmax = MAXINT - 1
        }
      else if (nlnum == 1) {
        foff = foff + hlddot - 1
        fmax = min0((fmax - hlddot) + 1, line2)
        }
      else {
        foff = foff + line1 - 1
        fmax = max0(0, (min0(line2, fmax) - line1) + 1)
        }
      dot = 1
      }
    else if (cmnd == 'R') {
      scrsiz = SCRLENGTH
      scrwid = syswid
      lowc = 1; highc = BUFSIZ
      foff = 0; fmax = MAXINT - 1
      prmmod = .true.
      }
    else if (cmnd == 'X')
      break
DT80 else if (cmnd == 'V') {
DT80   if (~vmode  &  fout == NONETERM) {
DT80     call setwid(TERM, 132)			# print 132 columns
DT80     call escseq(fout, '[5i')		# turn printer on
DT80     call qiofn(TERM, SFGMC, TCHFF, ffchar, ier)  # save FF characteristic
DT80     call qiofn(TERM, SFSMC, TCHFF, 1, ier)	      # set HFF on
DT80     }
DT80   vmode = fout == NONETERM
DT80   }
     else if (cmnd == 'H') {
HELP   call runsys('LIS LB:[1,2]LIST.HLP 24SP', 25, ier)
HELP   call waitsy
NOHELP call err(comand, cp, 'Help is not available yet.')
       }
    else if (cmnd == '=')
      savdot = dot
    else if (cmnd == '?') {
      if (slen == 0)
        call err(comand, cp, 'Current search string is null.')
      else {
        print = .true.
        eofln = 1
        mxsrch = fmax
        if (nlnum >= 2) {
          dot = line1
          if (line2 < line1)
            print = .false.
          else {
            eofln = line1
            mxsrch = line2
            ntoprt = (line2 - line1) + 1
            }
          }
        }
      }
    else if (comand(cp) ~= ERROR) {
HELP   call err(comand, cp, 'Illegal command. Type H for help.')
NOHELP call err(comand, cp, 'Illegal command.')
       }
 
    call posit(f, dot)
    if (comand(cp) ~= ERROR)
      cp = cp+1
   
    if (print)
      topscr = dot
    if (print  &  ~noprnt) {
      if (cmnd == '?') {
        repeat {
          if (ptscan(f, inbuf, blen, mxsrch) == EOF) {
            dot = eofln
            break
            }
          if (nprint == 0)
            topscr = dot
          encode(8, 10, qbuf) dot
            10 format(i7,'>')
          } until (typlin(fout, qbuf, blen+8, nprint, ntoprt, .true.) == NO)
        }
      else {
        repeat {
          if (getinp(f, inbuf, blen) == EOF)
            break
          } until (typlin(fout, inbuf, blen, nprint, ntoprt, .false.) == NO)
        if (cmnd == 'G')
          dot = topscr
        }
      }
    } until (comand(cp) == EOS  |  comand(cp) == ERROR)
  if (comand(cp) ~= ERROR)
    call scopy(comand, 1, last, 1)			# save command buffer
 
DT80 if (vmode) {
DT80   vmode = .false.
DT80   call escseq(fout, '[4i')			# turn printer off
DT80   call setwid(TERM, scrwid)
DT80   call qiofn(TERM,SFSMC,TCHFF,ffchar,ier) # restore old FF characteristic
DT80   }
  fold = fout
  if (fout ~= stdout) {
    close(unit = fout)
    fout = stdout
    call gftyp(fout, outcc)
    }
  if (cmnd == 'X')
    break
  } until (rcmd(comand, dot, prmmod | nprint == 0 | fold ~= NONETERM) == EOF)
if (fout == NONETERM)			# then put trailing CR
  call put(fout, CR, 1, ier)
return
end