#
#
#
#    LIST File Listing Utility
#    =========================
#
#         Author:  William P. Wood, Jr.
#
#         Address: Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 3.0
#
#         Date:    March 26, 1982
#
#
#
#      *******************************************************
#      *                                                     *
#      *      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                       *
#      *                                                     *
#      *******************************************************
#
#
include "symbols.rat"

# list - driver program for LIST file listing facility
  program list
  byte comand(_arith(MAXLINE,+,FILENAMESIZE)), file(MAXLINE), ans(4)
  integer nc, nans, source, junk, stdout, prompt, nfile, ier, rstat
  logical ler
  integer redir
  logical opndef, matswi
  include "clist.cmn"

_ifdef(VAX)

  logical istrm
  include "gpkey.cmn"
  string keybad "Invalid key value."
  external gpcre8, gpopen

  open(unit=TT$IN, name=STD$IN, type='OLD', useropen=gpopen)
  open(unit=TT$OUT, name=STD$OUT, carriagecontrol='LIST', type='NEW',
       useropen=gpcre8)
  if (istrm(TT$OUT)) {				# then reopen with cc=NONE
    close(unit=TT$OUT)
    open(unit=TT$OUT, name=STD$OUT, carriagecontrol='NONE', type='NEW',
	 useropen=gpcre8)
    }

_elsedef

  open(unit=TT$IN, name=STD$IN, type='OLD')
  open(unit=TT$OUT, name=STD$OUT, carriagecontrol='NONE', type='NEW')
  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

_enddef

  stdout = TT$OUT
  call gcctyp(TT$OUT, ttcc)
  outcc = ttcc
  call gttyp(TT$OUT)


  repeat {
    call gcmd(TT$IN, 'File? ', comand, nc, MAXLINE, source)
    if (nc <= 0)
      break

    prompt = DEFAULT_PROMPT
    flags(HEADER) = .false.
    flags(NUMBERS) = .true.
    flags(TRIM) = .false.
    flags(DELETE) = .false.

_ifdef(VAX)

    keyref = 0
    keymat = KEY$NOMATCH
    keytyp = KEY$NUMERIC
    keylen = 0

_enddef

    repeat {
      call parse(comand, file)
      ler = .false.
      if (file(1) == '/')
	if (matswi(file, '/Prompt', ler))
	  prompt = DO_PROMPT
	else if (matswi(file, '/Go', ler) | matswi(file, '/NOPrompt', ler))
	  prompt = NO_PROMPT
	else if (matswi(file, '/HD', ler) | matswi(file, '/Header', ler))
	  flags(HEADER) = .true.
	else if (matswi(file, '/NOHeader', ler))
	  flags(HEADER) = .false.
	else if (matswi(file, '/NUmbers', ler))
	  flags(NUMBERS) = .true.
	else if (matswi(file, '/NONumbers', ler))
	  flags(NUMBERS) = .false.
	else if (matswi(file, '/Trim', ler))
	  flags(TRIM) = .true.
	else if (matswi(file, '/NOTrim', ler))
	  flags(TRIM) = .false.
	else if (matswi(file, '/Delete', ler))
	  flags(DELETE) = .true.
	else if (matswi(file, '/NODelete', ler))
	  flags(DELETE) = .false.

_ifdef(VAX)

	else if (matswi(file, '/Key=#', ler, 'Invalid key number.', keyref))
	  ;
	else if (matswi(file, '/KEYEQ="', ler, EOS, keylen, keybuf, 256)) {
	  keymat = KEY$EQ
	  keytyp = KEY$CHARACTER
	  }
	else if (matswi(file, '/KEYEQ=#', ler, keybad, keyint))
	  keymat = KEY$EQ
	else if (matswi(file, '/KEYGE="', ler, EOS, keylen, keybuf, 256)) {
	  keymat = KEY$GE
	  keytyp = KEY$CHARACTER
	  }
	else if (matswi(file, '/KEYGE=#', ler, keybad, keyint))
	  keymat = KEY$GE
	else if (matswi(file, '/KEYGT="', ler, EOS, keylen, keybuf, 256)) {
	  keymat = KEY$GT
	  keytyp = KEY$CHARACTER
	  }
	else if (matswi(file, '/KEYGT=#', ler, keybad, keyint))
	  keymat = KEY$GT

_enddef

	else {
	  if (! ler)
	    call err(file, 2, "Invalid switch.")
	  next 2
	  }
      else
	break
      }

    nfile = 0
    while (opndef(FILE$IN, file, prompt, nfile))
      if (redir(stdout, comand, rstat) != ERROR) {
	if (flags(HEADER))
	  call puthdr(stdout, file)
	call listit(FILE$IN, stdout, comand)
	if (flags(DELETE)) {
	  call gcmd(TT$IN, 'Delete? ', ans, nans, 4, junk)
	  if (nans < 0) {
RECORDIO    close(unit = FILE$IN)
BLOCKIO     call bclose(FILE$IN, 'S', junk)
	    break
	    }
	  if (matswi(ans, 'Yes', ler)) {
RECORDIO    close(unit = FILE$IN, dispose = 'delete')
BLOCKIO     call bclose(FILE$IN, 'D', junk)
	    }
	  else {
RECORDIO    close(unit = FILE$IN)
BLOCKIO     call bclose(FILE$IN, 'S', junk)
	    }
	  }
	else {
RECORDIO  close(unit = FILE$IN)
BLOCKIO   call bclose(FILE$IN, 'S', junk)
	  }
	if (isset(rstat, REDIRECT$WILD)) {	# redirected to wild file?
	  close(unit = stdout)
	  stdout = TT$OUT
	  outcc = ttcc
	  call concat(comand, REDIRECT, MAXLINE+FILENAMESIZE) # redirect last
	  if (isset(rstat, REDIRECT$APPEND))
	    call concat(comand, REDIRECT, MAXLINE+FILENAMESIZE)
	  }
	}
      else {
RECORDIO  close(unit = FILE$IN)
BLOCKIO   call bclose(FILE$IN, 'S', junk)
	break
	}

    if (stdout != TT$OUT) {
      close(unit = stdout)
      stdout = TT$OUT
      outcc = ttcc
      }
    } until(source < 0)				# command line was from MCR

_ifndef(VAX)

  call put(TT$OUT, CR, 1, ier)

_enddef

  call tabbak(TT$OUT)
  call exit(xstat)
  end

# listit - list the file
  subroutine listit(f, stdout, comnd)
  byte comnd(1), comand(_arith(2,*,MAXLINE)), cmnd,
    inbuf(BUFSIZ), qbuf(QBUFSIZ)
  integer f, stdout, fout, fold, blen, cp, nlnum, j, k, ier, rstat, sstat,
    ffchar, dummy
  biginteger nprint, lastpr, line1, line2, num, eofln, mxsrch, hlddot, tmphld
  biginteger pcount(NPAREN)
  integer pmark(NPAREN), pend(NPAREN), plevel
  logical print, prmmod, noprnt, gotbrk, findrp, dtmode

  integer rcmd, getinp, redir
  biginteger ptscan
  byte cupper
  logical getnum, chscan, replac, typlin

  include "clist.cmn"
  include "term.cmn"
  include "pat.cmn"
  include "qiofn.cmn"

				# default macro puts you in line-by-line mode
  string macro(_arith(2,*,MAXLINE)) " 1SNP"
  string last(_arith(2,*,MAXLINE)) ""
  data prmmod/.true./				# normal prompt mode
  data dtmode/.false./				# DT80 print mode off
  equivalence (qbuf(9), inbuf(1)),
  	      (qbuf(1), dummy)			# integer aligned

  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, rstat) == ERROR)		# do file redirection
      comand(cp) = ERROR
							# do last replacement
    else if (! replac('L', last, comand, 2*MAXLINE, cp))
      call err(comand, cp, 'Command too long.')

    else {
      j = cp
      if (chscan(comand, j, '[')) {			# define macro
	k = j+1
	gotbrk = chscan(comand, k, ']')
	comand(k) = EOS
	call scopy(comand, j+1, macro, 1)
	comand(j) = ' '					# the null comand
	if (gotbrk)
	  call scopy(comand, k+1, comand, j+1)
	else
	  comand(j+1) = EOS
	}
							# do macro replacement
      if (! replac('M', macro, comand, 2*MAXLINE, cp))
	call err(comand, cp, 'Command too long.')
      }

    plevel = 0
    bcldot = dot
    repeat {
      print = .false.
      noprnt = .false.
      lastpr = 0
      nprint = 0
      nlnum = 0
      hlddot = dot
      line2 = dot
      repeat {
	if (comand(cp) == ',') {
	  noprnt = .false.
	  cp = cp + 1
	  nlnum = 2
	  line1 = line2
	  }
	tmphld = dot
	if (! getnum(f, comand, cp, inbuf, blen, num, sstat))
	  break
	if (plevel > 0 & isset(sstat, SEARCH$FORWARDFAIL | SEARCH$BACKFAIL)) {
	  cp = pend(plevel)
	  pcount(plevel) = 0
	  break
	  }
	noprnt = isset(sstat, SEARCH$BACKFAIL)
	if (nlnum == 0)
	  nlnum = 1
	line2 = num
	dot = num
	if (nlnum <= 1)
	  hlddot = tmphld
	}

      cmnd = cupper(comand(cp))
      if (cmnd == EOS  |  cmnd == 'P'  |  cmnd == ESC) {
	print = .true.
	if (nlnum <= 1  &  cmnd == ESC) {
	  dot = dot-scrsiz-scrsiz
	  if (dot < 1) {
	    if ((topscr == 1  &  nlnum == 0)  |  line2 <= 1)
	      print = .false.
	    dot = 1
	    }
	  }
	else if (nlnum >= 2) {
	  if (line2 < 1)
	    print = .false.
	  else
	    lastpr = line2
	  dot = line1
	  }
	}
      else if (cmnd == '(') {
	dot = hlddot
	if (plevel >= NPAREN)
	  call err(comand, cp, 'Too many parenthesis levels.')
	else if (! findrp(comand, cp, pend(plevel+1)))
	  call err(comand,pend(plevel+1), 'Matching end parenthesis expected.')
	else {
	  plevel = plevel+1
	  pmark(plevel) = cp
	  if (nlnum == 0)
	    pcount(plevel) = -1
	  else if (nlnum == 1)
	    pcount(plevel) = max0(0, line2)
	  else
	    pcount(plevel) = max0(0, (line2 - line1) + 1)
	  if (pcount(plevel) == 0) {
	    cp = pend(plevel)
	    plevel = plevel - 1
	    }
	  }
	}
      else if (cmnd == ')') {
	if (plevel < 1)
	  call err(comand, cp, 'Unexpected right parenthesis.')
	else {
	  if (pcount(plevel) > 0)
	    pcount(plevel) = pcount(plevel)-1
	  if (pcount(plevel) != 0)
	    cp = pmark(plevel)
	  else
	    plevel = plevel-1
	  }
	}
      else if (cmnd == ' ')
	;
      else if (cmnd == 'G') {
	print = .true.
	if (nlnum <= 1)
	  lastpr = dot
	else {
	  if (line2 < 1)
	    print = .false.
	  else
	    lastpr = line2
	  dot = line1
	  }
	}
      else if (cmnd == 'S') {
	dot = hlddot
	if (nlnum == 0)
	  scrsiz = SCRLENGTH
	else if (nlnum == 1)
	  scrsiz = max0(1, line2)
	else
	  scrsiz = max0(1, (line2 - line1) + 1)
	}
      else if (cmnd == 'C') {
	lstred = 0
	dot = hlddot
	if (nlnum == 0) {
	  lowc = 1
	  highc = BUFSIZ+1
	  }
	else if (nlnum == 1) {
	  lowc = 1
	  highc = max0(1, min0(BUFSIZ+1, line2))
	  }
	else {
	  lowc = max0(1, min0(BUFSIZ+1, line1))
	  highc = max0(lowc, min0(BUFSIZ+1, line2))
	  }
	}
      else if (cmnd == 'W') {
        dot = hlddot
        if (nlnum == 0)
          scrwid = syswid
        else
          scrwid = max0(1, line2)
        call setwid(TT$OUT, scrwid)
        }
      else if (cmnd == 'N') {
	prmmod = !prmmod
	}
      else if (cmnd == 'F') {
	if (nlnum == 0) {
	  foff = 0
	  fmax = MAXINT - 1
	  }
	else if (nlnum == 1) {
	  foff = foff + max0(1, min0(fmax+1, hlddot)) - 1
	  fmax = max0(0, min0((fmax - max0(1, min0(fmax+1, hlddot))) + 1,
  			      line2))
	  }
	else {
	  foff = foff + max0(1, min0(fmax+1, line1)) - 1
	  fmax = max0(0, (max0(0, min0(fmax, line2)) -
  			  max0(1, min0(fmax+1, line1))) + 1)
	  }
	dot = 1
	}
      else if (cmnd == 'R') {
	lstred = 0
  	dot = 1
	scrsiz = SCRLENGTH
	scrwid = syswid; call setwid(TT$OUT, scrwid)
	lowc = 1; highc = BUFSIZ+1
	foff = 0; fmax = MAXINT - 1
	prmmod = .true.
	}
      else if (cmnd == 'X')
	break
      else if (cmnd == 'V') {
        if (!dtmode) {
          call escseq(fout, '[5i')			# turn printer on

_ifdef(VAX)

	  if (qio_ok & fout == TT$OUT) {
	    call setwid(fout, 132)			# print 132 columns
	    ffchar = ttchar & tt$m_mechform		# save FF status
	    set(ttchar, tt$m_mechform)			# set HFF on
	    call sys$qiow( , %val(channel), %val(io$_setmode), , , ,
			  characteristics, , , , , )
	    }

_elsedef

  	  if (fout == TT$OUT) {
	    call setwid(TT$OUT, 132)			# print 132 columns
	    call qiofn(TT$OUT, SFGMC, TCHFF, ffchar, ier) # save FF status
	    call qiofn(TT$OUT, SFSMC, TCHFF, 1, ier)	# set HFF on
  	    }

_enddef

	  dtmode = .true.
          }
        }
      else if (cmnd == '=')
	savdot = dot
      else if (cmnd == '?') {
	if (snull)
	  call err(comand, cp, 'Current search string is null.')
	else {
	  print = .true.
	  eofln = 1
	  mxsrch = MAXINT-1
	  if (nlnum >= 2) {
	    dot = line1
	    if (line2 < 1)
	      print = .false.
	    else {
	      eofln = line1
	      mxsrch = line2
	      lastpr = line2
	      }
	    }
	  }
	}
      else if (comand(cp) != ERROR) {
        call err(comand, cp, 'Illegal command.')
        }

      call posit(f)
      if (comand(cp) != EOS & comand(cp) != ERROR)
	cp = cp+1

      if (print)
	topscr = dot
      if (print  &  !noprnt) {
	if (cmnd == '?') {
	  repeat {
	    if (ptscan(f, inbuf, blen, mxsrch) == EOF) {
	      dot = max0(1, min0(eofln, dot))
	      break
	      }
	    if (nprint == 0)
	      topscr = dot
	    if (flags(NUMBERS)) {
	      encode(8, (i7, '>'), qbuf) dot
	      if (! typlin(fout, qbuf, blen+8, nprint, lastpr, .true.))
		break
	      }
	    else {
	      if (! typlin(fout, inbuf, blen, nprint, lastpr, .true.))
		break
	      }
	    }
	  }
	else {
	  repeat {
	    if (getinp(f, inbuf, blen) == EOF)
	      break
	    } until (! typlin(fout, inbuf, blen, nprint, lastpr, .false.))
	  if (cmnd == 'G')
	    dot = topscr
	  }
	}
      } until (comand(cp) == EOS  |  comand(cp) == ERROR)

    if (comand(cp) != ERROR)
      call scopy(comand, 1, last, 1)		# set last command buffer

    if (dtmode) {
      dtmode = .false.
      call escseq(fout, '[4i')			# turn printer off

_ifdef(VAX)

      if (qio_ok & fout == TT$OUT) {
	call setwid(TT$OUT, scrwid)
	ttchar = ffchar | (ttchar & !tt$m_mechform)  # restore old FF charac.
	call sys$qiow( , %val(channel), %val(io$_setmode), , , ,
		      characteristics, , , , , )
	}

_elsedef

      if (fout == TT$OUT) {
	call setwid(TT$OUT, scrwid)
	call qiofn(TT$OUT,SFSMC,TCHFF,ffchar,ier) # restore old FF charac.
  	}

_enddef

      }

    fold = fout
    if (fout != stdout) {
      close(unit = fout)
      fout = stdout
      call gcctyp(fout, outcc)
      }

    if (cmnd == 'X')
      break

    } until (rcmd(comand, dot, prmmod | nprint == 0 | fold != TT$OUT) == EOF)

_ifndef(VAX)

  if (fout == TT$OUT)				# then put trailing CR
    call put(fout, CR, 1, ier)

_enddef

  return
  end