#
#
#
#    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:    December 29, 1981
#
#
#
#      *******************************************************
#      *                                                     *
#      *      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

# 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)
integer lun, len, maxlen, source
integer i, j, junk
logical first
data first/.true./
 
len = 0
if (first) {
  first = .false.
_ifdef(VAX)
  call getdcl(buf, len)
_elsedef
  call getmcr(buf, len)
_enddef
  if (len > 0) {
    source = MCR
    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
    }
  }
 
if (len <= 0) {
  source = TERMINAL
  repeat
    call readpr(lun, prompt, buf, len, maxlen-1, junk)
    until(len >= 0  |  len == EOF)
  }
 
buf(max0(1, min0(maxlen, len+1))) = EOS
return
end
 
_ifdef(VAX)
# getdcl - emulate pdp11 getmcr subroutine, except return dummy routine name
#	   and buffer should be MAXLINE bytes long.
  subroutine getdcl(buf, len)
  byte buf(MAXLINE), tbuf(MAXLINE - 4)
  integer len, i, j, lib$get_foreign
  real*8 icr_stdescr
  logical first
  data first /.true./
 
  if (first) {
    first = .false.
    if (lib$get_foreign(icr_stdescr(%descr(tbuf)), , len))
      if (len > 0) {
        buf(1) = 'D'
        buf(2) = 'U'
        buf(3) = 'M'
        buf(4) = ' '
	j = 4
	for (i = 1; i <= len; i = i+1) {
	  j = j+1
	  buf(j) = tbuf(i)
	  }
        len = j
        return
        }
    }
  len = -80
  return
  end
_enddef
 
# rcmd - get the next list command
integer function rcmd(buf, dot, prmflg)
integer nc, j
biginteger dot
integer scan
byte buf(1), promp(13), termc
logical prmflg
data promp(12) /'>'/, promp(13) /EOS/
 
if (prmflg) {
  encode(11, 10, promp) dot
    10 format(1x, i10)
  j = scan(promp, ' ', 1)
  }
else {
  j = 1
  promp(j) = EOS
  }
repeat
  call readpr(TT$IN, promp(j), buf, nc, MAXLINE-2, termc)
  until(nc >= 0  |  nc == EOF)
rcmd = nc
if (rcmd >= 0  &  termc == ESC) {		# ESC as terminator?
    rcmd = rcmd+1
    buf(rcmd) = ESC
    }
buf(max0(1, rcmd+1)) = EOS
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
lstred = 0
savdot = 1
foff = 0
fmax = MAXINT-1
lowc = 1
highc = BUFSIZ
call gftyp(f, cc)
call gftyp(fout, outcc)
if (cc == NONE)
  call vinit(f)				# initialize virtual io
return
end
 
# getinp - get next record, increment nxtrec, mark every 100 lines
integer function getinp(f, inbuf, blen)
integer f, blen, ier, i
biginteger rdot
byte inbuf(BUFSIZ), errbuf(80)
include clist.cmn
 
rdot = dot+foff
if (dot > fmax)
  getinp = EOF
else if (rdot == lstred)
  getinp = blen
else {
  if (mod(nxtrec-1, 100) == 0)
    if ((nxtrec-1)/100 > markp  &  markp < MAXMARK) {
      markp = markp+1
      if (cc == NONE)
        call vmark(f, markb(1, markp))
      else
        call markr(f, markb(1, markp))
      }
  if (cc == NONE)
    call vget(f, inbuf, BUFSIZ, getinp)
  else {
RECORDIO     call get(f, inbuf, BUFSIZ, getinp)
BLOCKIO      call bget(f, inbuf, BUFSIZ, getinp)
    }
  if (getinp >= 0) {
    getinp = max0(0, min0(highc, getinp)-lowc+1)
    blen = getinp
    if (lowc ~= 1  &  blen > 0)
      do i = 1, blen
        inbuf(i) = inbuf(i-1+lowc)	# shift proper byte range to inbuf(1)
    lstred = nxtrec
    nxtrec = nxtrec + 1
    }
  else if (getinp == RECORDTOOLONG) {
    encode(41, 10, errbuf) nxtrec
10    format('LIST -- RECORD NUMBER ',i7,' IS TOO LONG')
    call ttput(errbuf, 41)
    getinp = 0
    blen = getinp
    lstred = 0
    nxtrec = nxtrec + 1
    }
  else if (getinp ~= EOF) {
    encode(69, 20, errbuf) getinp, nxtrec
20   format('LIST -- ERROR NUMBER 'i3,' OCCURRED WHILE READING RECORD NUMBER ',
             i7)
    call ttput(errbuf, 69)
    getinp = EOF
    }
  }
return
end
 
# typlin - type line if room is left on screen or ntoprt > 0
integer function typlin(f, buf, blen, nprint, ntoprt, ignrff)
byte buf(1), ccbuf(_arith(QBUFSIZ,+,2)), copyb(QBUFSIZ)
integer f, blen, nlines, ier
biginteger nprint, ntoprt
logical ffflag, ignrff
include clist.cmn
include term.cmn
equivalence (copyb(1), ccbuf(3))
data ccbuf(1), ccbuf(2) /CR,			# Carriagereturn
                         LF/			# Line Feed
 
typlin = NO
if (ntoprt <= 0) {				# normal print mode
  call numlin(buf, copyb, blen, ffflag, nlines)
  if (nprint > 0 & (nprint+nlines > scrsiz | (ffflag & ~ignrff)))
    return
  }
else {
  nlines = 1			# n1,n2 Print mode; leave funny chars in buf
  do i = 1, blen
    copyb(i) = buf(i)
  }
 
if (outcc == NONE)			# output to terminal or NONE file
  call put(f, ccbuf, blen+2, ier)
else					# output to LIST or FORTRAN file
  call put(f, copyb, blen, ier)
nprint = nprint+nlines
dot = dot+1
ntoprt = ntoprt-1
if (ntoprt ~= 0)
  typlin = YES
return
end
 
# posit - position file to read record number "newdot"
subroutine posit(f, newdot)
integer f
biginteger newdot, rdot, markl, markp4
integer*4 n4, nr4
include clist.cmn
 
rdot = foff + newdot
if (rdot == nxtrec)
  return
if (rdot == lstred)
  if (nxtrec == rdot+1)
    return
  else
    lstred = 0
markp4 = markp
markl = min0((rdot-1)/100, markp4)
if (markl > (nxtrec-1)/100  |  nxtrec > rdot) {
  if (cc == NONE)
    call vpoint(f, markb(1, markl))
  else
    call pointr(f, markb(1, markl))
  nxtrec = markl*100+1
  }
 
repeat {
  if ((nxtrec-1)/100 ~= (rdot-1)/100)
    n4 = ((nxtrec-1)/100*100+101) - nxtrec
  else
    n4 = rdot-nxtrec
  if (mod(nxtrec-1, 100) == 0)
    if ((nxtrec-1)/100 > markp  &  markp < MAXMARK) {
      markp = markp+1
      if (cc == NONE)
        call vmark(f, markb(1, markp))
      else
        call markr(f, markb(1, markp))
      }
  if (cc == NONE)
    call vskip(f, n4, nr4)
  else
    call skip(f, n4, nr4)
  nxtrec = nr4+nxtrec
  } until (nxtrec == rdot  |  nr4 ~= n4)
newdot = max0(1, nxtrec-foff)
return
end