#
#
#
#    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.1
#
#         Date:    December 2, 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"

define(ERROR_FORMAT,_ifdef(VAX) '%x'z8.8 _elsedef i10 _enddef)

# gcmd - get command line from MCR or terminal
define(MCR,-2)
define(TERMINAL,0)
  subroutine gcmd(lun, prompt, buf, len, maxlen, source)
  byte prompt(1), buf(1), termc
  integer lun, len, maxlen, source, i, j
  logical first
  data first/.true./

  len = 0
  if (first) {
    first = .false.
    call getmcr(buf, len)
    if (len > 0) {
      source = MCR
_ifndef(VAX)
      for (i = 1; i < len; i = i+1)
	if (buf(i) == ' ' | buf(i+1) == '/')
	  break
      j = i
      for (i = i+1; i <= len; i = i+1)
	buf(i-j) = buf(i)
      len = len - j
_enddef
      }
    }

  if (len <= 0) {
    source = TERMINAL
    repeat
      call readpr(lun, prompt, buf, len, maxlen-2, termc)
      until(len >= 0  |  len == EOF)
    if (len >= 0  &  termc == ESC) {		# ESC as terminator?
      len = len+1
      buf(len) = ESC
      }
    }

  buf(max0(1, min0(maxlen, len+1))) = EOS
  return
  end

_ifdef(VAX)
# getmcr - get foreign command line for VAX
  subroutine getmcr(buf, len)
  byte buf(MAXLINE)
  integer len, lib$get_foreign
  real*8 icr_stdescr
  logical first
  data first /.true./

  if (first) {
    first = .false.
    if (lib$get_foreign(icr_stdescr(%descr(buf), MAXLINE-1), , len))
      if (len > 0)
        return
    }
  len = -80
  return
  end
_enddef

# rcmd - get the next list command
  integer function rcmd(buf, dot, prmflg)
  byte buf(MAXLINE), promp(12)
  biginteger dot
  integer nc, j, source
  integer scan
  logical prmflg
  data promp(11) /'>'/, promp(12) /EOS/

  if (prmflg) {
    encode(10, (i10), promp) dot
    j = scan(promp, ' ', 1)
    }
  else {
    j = 1
    promp(1) = EOS
    }
  call gcmd(TT$IN, promp(j), buf, nc, MAXLINE, source)
  rcmd = nc
  return
  end

# initio - initialize the io variables
  subroutine initio(f, fout)
  integer f, fout
  include "clist.cmn"

  dot = 1
  nxtrec = 1
  topscr = 1
  markp = -1
  mrkint = 4
  lstred = 0
  savdot = 1
  foff = 0
  fmax = MAXINT-1
  lowc = 1
  highc = BUFSIZ+1     # when highc > BUFSIZ, list flags record too long errors
  if (cc == NONE)
    call vinit(f)				# initialize virtual io
  return
  end

# getinp - get next record, increment nxtrec, mark every mrkint lines
  integer function getinp(f, inbuf, blen)
  integer f, blen,
    i, getsta,
    vget
RECORDIO integer get
BLOCKIO  integer bget
  biginteger rdot
  byte inbuf(BUFSIZ)
  include "clist.cmn"
 
  rdot = dot+foff
  if (dot > fmax)
    getinp = EOF
  else if (rdot == lstred)
    getinp = blen
  else {
    if (mod(nxtrec-1, mrkint) == 0)
      if ((nxtrec-1)/mrkint > markp)
	call markit(f)
    if (cc == NONE)
      getsta = vget(f, inbuf, BUFSIZ, getinp)
    else {
RECORDIO     getsta = get(f, inbuf, BUFSIZ, getinp)
BLOCKIO      getsta = bget(f, inbuf, BUFSIZ, getinp)
      }
    if (getinp >= 0) {
10    blen = max0(0, min0(highc, getinp)-lowc+1)
      if (lowc != 1  &  blen > 0)
	do i = 1, blen
	  inbuf(i) = inbuf(i-1+lowc)	# shift proper byte range to inbuf(1)
      if (flags(TRIM))
	for ( ; blen > 0; blen = blen-1)
	  if (inbuf(blen) != ' ' & inbuf(blen) != TAB)
	    break
      getinp = blen
      lstred = nxtrec
      nxtrec = nxtrec + 1
      }
    else if (getinp == RECORDTOOLONG) {
      if (highc > BUFSIZ) {
	encode(44,
          ('LIST -- Record number ',i10,' is too long'), errbuf) dot
	call ttput(errbuf, 44)
        xstat = EXIT_ERROR
	}
      getinp = BUFSIZ
      goto 10
11    continue
      }
    else if (getinp == EOF) {
      if (! randac) {	# don't try to read more records if not random access
	foff = 0
	fmax = 0
	nxtrec = 1
	lstred = 0
	}
      }
    else {
      call reaerr(getsta, getinp, 0)
      getinp = EOF
      lstred = 0
      }
    }
  return
  end

# typlin - type line if room is left on screen or (lastpr >= dot & lastpr != 0)
  logical function typlin(f, buf, blen, nprint, lastpr, ignrff)
  byte buf(1),
    ccbuf(_arith(QBUFSIZ,+,2)), copyb(QBUFSIZ)
  integer f, blen,
    nlines, ier, putsta,
    put
  biginteger nprint, lastpr
  logical ignrff,
    ffflag
  include "clist.cmn"
  include "term.cmn"
  equivalence (copyb(1), ccbuf(3))
  data ccbuf(1), ccbuf(2) /CR,			# Carriagereturn
			   LF/			# Line Feed

  typlin = .true.
  if (lastpr <= 0) {				# normal print mode
    call numlin(buf, copyb, blen, ffflag, nlines)
    if (nprint > 0 & (nprint+nlines > scrsiz | (ffflag & !ignrff)))
      return (.false.)
    if (outcc == NONE)			# output to terminal or NONE file
      putsta = put(f, ccbuf, blen+2, ier)
    else				# output to LIST or FORTRAN file
      putsta = put(f, copyb, blen, ier)
    }
  else if (lastpr >= dot) {
    nlines = 1			# n1,n2 Print mode; leave funny chars in buf
    if (outcc == NONE) {		# output to terminal or NONE file
      do i = 1, blen
        copyb(i) = buf(i)
      putsta = put(f, ccbuf, blen+2, ier)
      }
    else				# output to LIST or FORTRAN file
      putsta = put(f, buf, blen, ier)
    }
  else
    return (.false.)

  if (ier != 0) {
    encode(61,
      ('LIST -- Error number ', ERROR_FORMAT,
	' occurred while writing record'),
      errbuf) putsta
    call ttput(errbuf, 61)
    xstat = EXIT_ERROR
    typlin = .false.
    }
  nprint = nprint+nlines
  dot = dot+1
  return
  end

# posit - position file to read record number "dot"
  subroutine posit(f)
  integer f,
    skpsta, ier,
    skip, vskip
  biginteger rdot, markl, markp4
  integer*4 n4, nr4
  include "clist.cmn"

  dot = max0(1, min0(fmax+1, dot))
  rdot = foff + dot
  if (rdot == nxtrec)
    return
  if (rdot == lstred)
    if (nxtrec == rdot+1)
      return
    else
      lstred = 0
  markp4 = markp
  markl = min0((rdot-1)/mrkint, markp4)
  if (markl > (nxtrec-1)/mrkint  |  nxtrec > rdot) {
    if (! randac) {
      call ttput(_
	'LIST -- Cannot position backwards on non-random access device', 0)
      dot = max0(1, nxtrec-foff)
      xstat = EXIT_ERROR
      return
      }
    if (cc == NONE)
      call vpoint(f, markb(1, markl))
    else
      call pointr(f, markb(1, markl))
    nxtrec = markl*mrkint+1
    }

  repeat {
    if ((nxtrec-1)/mrkint != (rdot-1)/mrkint)
      n4 = (((nxtrec-1)/mrkint)*mrkint+mrkint+1) - nxtrec
    else
      n4 = rdot-nxtrec
    if (mod(nxtrec-1, mrkint) == 0)
      if ((nxtrec-1)/mrkint > markp)
	call markit(f)
    if (cc == NONE)
      skpsta = vskip(f, n4, nr4, ier)
    else
      skpsta = skip(f, n4, nr4, ier)
    nxtrec = nr4+nxtrec
    } until (nxtrec == rdot  |  nr4 != n4)

  dot = max0(1, nxtrec-foff)
  if (nr4 != n4) {
    if (ier != EOF)
      call reaerr(skpsta, ier, 0)
    if (! randac) {
      foff = 0
      fmax = 0
      nxtrec = 1
      lstred = 0
      }
    }
  return
  end
 
# markit - mark a line for later access
  subroutine markit(f)
  integer f, i, j
  include "clist.cmn"
 
  if (! randac)
    return
  markp = markp + 1
  if (cc == NONE)
    call vmark(f, markb(1, markp))
  else
    call markr(f, markb(1, markp))
  if (markp >= MAXMARK) {	# compress mark buffer, double mark interval
    do i = 0, MAXMARK/2
      do j = 1, MARKSIZE
	markb(j, i) = markb(j, i*2)
    markp = MAXMARK/2
    mrkint = 2*mrkint
    }
  return
  end

# reaerr - output a read error message
  subroutine reaerr(msgn, ier, offset)
  integer msgn, ier,
    i
  biginteger offset
  include "clist.cmn"

	if (ier == BUFFEROVERFLOW) {
	  i = 73
	  encode(i,
	    ('LIST -- Internal buffer overflowed while reading record number ',
              i10),
	    errbuf) max0(1, nxtrec-foff) + offset
	  }
BLOCKIO else if (ier == FILECORRUPT) {
BLOCKIO   i = 59
BLOCKIO   encode(i,
BLOCKIO     ('LIST -- Record number 'i10' has a negative record size'),
BLOCKIO     errbuf) max0(1, nxtrec-foff) + offset
BLOCKIO   }
	else {
	  i = 79
	  encode(i,
	    ('LIST -- Error number ', ERROR_FORMAT,
	      ' occurred while reading record number ', i10),
	    errbuf) msgn, max0(1, nxtrec-foff) + offset
	    }
	call ttput(errbuf, i)
  	xstat = EXIT_ERROR
  return
  end