#
#
#
#    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

# parse - return first arg in comand and delete it from comand
subroutine parse(comand, arg)
byte comand(1), arg(1)
integer j
byte cupper
 
j = 1
while (comand(j) ~= ' '  &  comand(j) ~= EOS  &
       (comand(j) ~= '/'  |  j == 1  |  comand(1) ~= '/')) {
  arg(j) = cupper(comand(j))
  j = j+1
  }
arg(j) = EOS
if (comand(j) == ' ')
  j = j+1
call scopy(comand, j, comand, 1)
return
end
 
# getfil - return selected file names one at a time from a list of file specs
#          separated by commas.
#          File specs may be a simple file name, or they may reference
#          an indirect file if @<indirect file> is specified, or
#          if the SRD option is in use, file names may be selected by
#          an SRD pattern.
define(SIMPLENAME,0)
define(SRDNAME,1)
define(INDIRECTNAME,2)
logical function getfil(file, ans, nselec, prompt)
byte file(1), ans(2), termc, tfile(MAXLINE), filist(MAXLINE)
integer nselec, nc, name, ip, j, i, nfile
logical prompt, islist, inbrak
integer bkscan, length
byte cupper
 
if (nselec == 0) {
  ip = 0
  call scopy(file, 1, filist, 1)
  nfile = 0
  islist = .false.
  }
repeat {
  if (nfile == 0) {
    inbrak = .false.
    for (j = ip+1; filist(j) ~= EOS  &  (inbrak | filist(j) ~= ','); j = j+1)
      if (filist(j) == '[')
        inbrak = .true.
      else if (filist(j) == ']')
        inbrak = .false.
    if (filist(j) == ',')
      islist = .true.			# this is a list of file names
    do i = ip+1, j
      file(i-ip) = filist(i)
    file(j-ip) = EOS
    ip = j
    name = SIMPLENAME
    if (file(1) == '@')  			     # Indirect file name?
      name = INDIRECTNAME
    else if (file(bkscan(file, '/*?', 1)) ~= EOS) {  # SRD wild card or switch?
SRD   name = SRDNAME
      }
    }
  nc = 0
  if (name == SIMPLENAME  &  ~islist)
    nfile = 1 - nfile
  else {
    repeat {
      if (name == SRDNAME) {
SRD     call fndfil(FINDFILE, file, tfile, nfile)
        }
      else if (name == INDIRECTNAME)
        call readf(FINDFILE, file, tfile, nfile)
      else {
        nfile = 1 - nfile
        call scopy(file, 1, tfile, 1)
        }
      if (nfile > 0) {
        call scopy(tfile, 1, file, 1)
        if (prompt)
          if (ans(1) ~= 'G') {
            repeat {
              call readpr(TERM, file, ans, nc, 2, termc)
              } until (nc == EOF  |  nc >= 0)
            ans(1) = cupper(ans(1))
            }
          else
            call put(TERM, file, length(file), ier)
        }
      } until (nfile <= 0  |  nc == EOF  |  ans(1) == 'G'  |
               (nc > 0  &  ans(1) == 'Y')  |  ~prompt)
    }
  } until (nfile > 0  |  filist(ip) == EOS  |  nc == EOF)
getfil = nfile > 0  &  nc ~= EOF
if (getfil)
  nselec = nselec + 1
if (nc == EOF)
  close(unit=FINDFILE)
return
end
 
# readf - read in file names from indirect file
subroutine readf(f, file, outfil, nselec)
integer f, nselec, nc
byte file(1), outfil(1)
 
if (nselec == 0) {
  call defnam(file(2), EOS, 'SY:', EOS, EOS, '.', .false.)
  close(unit=f)
%
      open(unit=f, name=file(2), type='old', readonly, shared, err=10)
%
  }
repeat
  call get(f, outfile, MAXLINE-1, nc)
  until (nc ~= 0)
if (nc < 0) {
  nselec = 0
  close(unit=f)
  }
else {
  nselec = nselec+1
  outfil(nc+1) = EOS
  }
return
 
10 continue
call err(file, 2, "Can't open file.")
return
end
 
# opndef - open file for reading using defaults in file name
logical function opndef(lun, file)
integer lun, i, ier
byte file(1), file1(MAXLINE)
byte node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE)
integer concat
include clist.cmn
data node(1)/EOS/
data dev(1), dev(2), dev(3), dev(4) /'S', 'Y', ':', EOS/
data uic(1)/EOS/
data name(1)/EOS/
data ext(1), ext(2), ext(3), ext(4), ext(5) /'.', 'L', 'S', 'T', EOS/
 
# try default file name first
   opndef = .true.
   call scopy(file, 1, file1, 1)
   call defnam(file1, node, dev, uic, name, ext, .true.)
RECORDIO    open(unit=lun, name=file1, type='old', readonly, shared, err=10,
RECORDIO         buffercount=4)
BLOCKIO     call bopen(lun, file1, 'R', ier)
BLOCKIO     if (ier ~= 0)
BLOCKIO       goto 10
   call scopy(file1, 1, file, 1)		# return full file name
   goto 30
 
# now try file name as is, with SY: and . as default device and extension
10 continue
   call defnam(file, EOS, 'SY:', EOS, EOS, '.', .false.)
RECORDIO    open(unit=lun, name=file, type='old', readonly, shared, err=20,
RECORDIO         buffercount=4)
BLOCKIO     call bopen(lun, file, 'R', ier)
BLOCKIO     if (ier ~= 0)
BLOCKIO       goto 20
   node(1) = EOS; dev(1) = EOS; uic(1) = EOS; name(1) = EOS; ext(1) = EOS
   call defnam(file, node, dev, uic, name, ext, .true.)   # reset defaults
   goto 30
 
# here if unable to open file
20 continue
   opndef = .false.
   call scopy('LIST -- ERROR OPENING ', 1, file, 1)
   i = concat(file, file1, MAXLINE)
   call put(TERM, file, i, ier)
   return
 
30 continue
   call gftyp(lun, cc)
   return
end
 
# redir - redirect output from LIST
integer function redir(fout, comand)
integer fout, j, ftmp
integer chscan
byte comand(1)
byte node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE)
logical append
include clist.cmn
data node(1)/EOS/, dev(1)/EOS/, uic(1)/EOS/, name(1)/EOS/, ext(1)/EOS/
 
j = 1
if (chscan(comand, j, REDIRECT) == YES) {		# file redirection
  append = .false.
  ftmp = FILEOUT
  if (comand(j+1) == REDIRECT) {
    append = .true.
    j = j+1
    }
  if (fout == ftmp) {			# fout already redirected?
    call err(comand, j, 'Output is already redirected.')
    return(ERROR)
    }
  if (comand(j+1) == EOS) {
    if (dev(1) == EOS) goto 10
    call defnam(comand(j+1), node, dev, uic, name, ext, .false.)
    }
  else
    call defnam(comand(j+1), EOS, 'SY:', EOS, EOS, '.', .false.)
  if (append) {	 	# need three open statements to get the proper
			# carriagecontrol when file is nonexistent.
    if (cc == LIST)
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            buffercount=2,
           carriagecontrol='list', recordsize=524, err=10)
    else if (cc == FORTRAN)
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            buffercount=2,
           carriagecontrol='fortran', recordsize=524, err=10)
    else
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            buffercount=2,
           carriagecontrol='none', recordsize=524, err=10)
    comand(j-1) = EOS
    }
  else {
    if (cc == LIST)
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            buffercount=2,
           carriagecontrol='list', recordsize=524, err=10)
    else if (cc == FORTRAN)
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            buffercount=2,
           carriagecontrol='fortran', recordsize=524, err=10)
    else
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            buffercount=2,
           carriagecontrol='none', recordsize=524, err=10)
    comand(j) = EOS
    }
  fout = ftmp
  call gftyp(fout, outcc)
  call defnam(comand(j+1), node, dev, uic, name, ext, .true.)	#reset defaults
  }
return(YES)
 
10 continue
call err(comand, j+1, "Can't open file.")
return(ERROR)
end
 
define(HDRSIZE,FILENAMESIZE+32)
# puthdr - put out LIST file name header to output file
subroutine puthdr(f, file)
integer f, fcc, l1, l2, i
byte file(1), hdr(HDRSIZE)
byte listcc(2), fortcc(2), nonecc(4)
integer concat
byte cupper
data listcc/FF, EOS/,
     fortcc/'1', EOS/,
     nonecc/CR,
            LF,
            FF,
            EOS/
 
call gftyp(f, fcc)		# get carriagecontrol type
hdr(1) = EOS
if (fcc == LIST)
  l1 = concat(hdr, listcc, HDRSIZE)
else if (fcc == FORTRAN)
  l1 = concat(hdr, fortcc, HDRSIZE)
else
  l1 = concat(hdr, nonecc, HDRSIZE)
l1 = concat(hdr, '# LIST  ', HDRSIZE)
l2 = concat(hdr, file, HDRSIZE)
do i = l1, l2
  hdr(i) = cupper(hdr(i))
for (i = l2+1; i <= l1+33; i = i+1)
  hdr(i) = ' '
hdr(i) = ' '; hdr(i+1) = ' '
i = i+2
call date(hdr(i))
hdr(i+9) = ' '; hdr(i+10) = ' ';
call time(hdr(i+11))
hdr(i+19) = LF
call put(f, hdr, i+19, ier)
return
end
 
# err - put out error message
subroutine err(comand, cp, msg)
integer cp, ier, j, k, l
integer length
byte comand(1), msg(1)
include term.cmn
 
j = mod(cp-1, scrwid) + 1
l = length(comand)
k = min0(cp + scrwid - j, l)
call put(TERM, comand, k, ier)
encode(j, 10, comand)
%
10    format(t<j>,'^')
%
call put(TERM, comand, j, ier)
if (k < l)
  call put(TERM, comand(k+1), l - k, ier)
call put(TERM, msg, length(msg), ier)
comand(cp) = ERROR
return
end