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

# parse - return first arg in comand and delete it from comand
  subroutine parse(comand, arg)
  byte comand(1), arg(1)
  integer j
  byte cupper
  logical litral

  for ([litral = .false.; j = 1];
	    comand(j) != EOS & (litral | (comand(j) != ' ' &
	    (j == 1 | comand(1) != '/' | comand(j) != '/')));
	j = j+1) {
    if (comand(j) == '"')
      if (comand(j+1) == '"') {
	arg(j) = '"'
	j = j+1
	}
      else
	litral = !litral
    if (litral)
      arg(j) = comand(j)
    else
      arg(j) = cupper(comand(j))
    }
  arg(j) = EOS
  if (comand(j) == ' ')
    j = j+1
  call scopy(comand, j, comand, 1)
  return
  end
 
define(islower,($1 >= 'a' & $1 <= 'z'))

# matswi - match a switch
  logical function matswi(swtch, templ, ler, errmsg, n, cbuf, csize)
  byte swtch(1), templ(1), errmsg(1), cbuf(1),
    cupper
  integer*4 n,
    ntmp
  integer csize,
    bs, es, i, j
  logical ler

  for ([i = 1; j = 1]; templ(j) != EOS & templ(j) != '='; j = j+1)
    if (cupper(swtch(i)) == cupper(templ(j)) & i == j)
      i = i+1
    else if (! islower(templ(j)))
      return(.false.)

  if (templ(j) == EOS)
    if (swtch(i) == EOS)
      return(.true.)
    else if (swtch(i) == '=') {
      call err(swtch, i, "No switch argument expected.")
      ler = .true.
      return(.false.)
      }
  if (swtch(i) != '=') {
    if (swtch(i) != EOS)
      return(.false.)
    if (errmsg(1) != EOS)
      call err(swtch, i, "Switch argument expected.")
    ler = .true.
    return(.false.)
    }

  bs = i+1
  es = length(swtch) + 1

  switch (templ(j+1)) {
    case '#':
      decode(es-bs, (i<es-bs>), swtch(bs), err=10) ntmp

    case '"':
      if (swtch(bs) != '"')
	goto 10
      for([i = bs+1; j = 1]; swtch(i) != EOS & j <= csize; [i = i+1; j = j+1]){
	if (swtch(i) == '"') {
	  i = i+1
	  if (swtch(i) != '"')
	    break
	  }
	cbuf(j) = swtch(i)
	}
      if (swtch(i) != EOS | j > csize | j <= 1)
	goto 10
      cbuf(j) = EOS
      ntmp = j-1

    default:
	goto 10
1	continue
    }

  n = ntmp
  return(.true.)

10
  if (errmsg(1) != EOS)
    call err(swtch, bs, errmsg)
  ler = .true.
  return(.false.)
  end


define(open_write,
	open(unit=$1, name=$2, type=$3,
_ifdef(VAX)
	     useropen=gpcre8,
_enddef
	     carriagecontrol=$5, err=$6, shared _
	     _ifelse($4, 'append', `, `access='append'))
	)

# redir - redirect output from LIST
  integer function redir(fout, comand, stat)
  integer fout, stat,
    j
  byte comand(1)
  logical chscan
_ifdef(VAX)
  external gpcre8
_enddef
  include "clist.cmn"

  j = 1
  stat = REDIRECT$NONE
  if (chscan(comand, j, REDIRECT)) {			# file redirection
    set(stat, REDIRECT$REDIRECT)
    if (comand(j+1) == REDIRECT) {
      set(stat, REDIRECT$APPEND)
      j = j+1
      }
    if (fout == FILE$OUT) {			# fout already redirected?
      call err(comand, j, 'Output is already redirected.')
      return(ERROR)
      }
    call gofn(comand(j+1), stat)

    if (isset(stat, REDIRECT$APPEND)) {
				# need 3 open statements to get the proper
			  	# carriagecontrol when file is nonexistent.
      if (cc == LIST)
	open_write(FILE$OUT, comand(j+1), 'unknown', 'append', 'list', 10)
      else if (cc == FORTRAN)
	open_write(FILE$OUT, comand(j+1), 'unknown', 'append', 'fortran', 10)
      else
	open_write(FILE$OUT, comand(j+1), 'unknown', 'append', 'none', 10)
      comand(j-1) = EOS
      }
    else {
      if (cc == LIST)
	open_write(FILE$OUT, comand(j+1), 'new', , 'list', 10)
      else if (cc == FORTRAN)
	open_write(FILE$OUT, comand(j+1), 'new', , 'fortran', 10)
      else
	open_write(FILE$OUT, comand(j+1), 'new', , 'none', 10)
      comand(j) = EOS
      }
    fout = FILE$OUT
    call gcctyp(fout, outcc)
    }
  return(YES)

10 continue
  call err(comand, j+1, "Can't open file.")
  return(ERROR)
  end
 
# gofn - get output file name for file redirection
  subroutine gofn(file, stat)
  byte file(1)
  integer stat,
    indexq
  include "files.cmn"

  if (file(1) == EOS)				# use last file name
    call scopy(lfile, 1, file, 1)
  else {
    lfile(1) = EOS
    call concat(lfile, file, FILENAMESIZE)	# set last file
    }
  if (indexq(file, '*') != 0) {	# replace asterisks with input file fields
    call fparse(file, cnode, cdev, cuic, cname, cext, cver, .false., .true.)
    set(stat, REDIRECT$WILD)
    }
  call defnam(file, EOS, DEFAULT$DISK, EOS, 'LIST', DEFAULT$EXT, .false.)
  return
  end
 
define(HDRSIZE,_arith(FILENAMESIZE,+,83))
# puthdr - put out LIST file name header to output file
  subroutine puthdr(f, file)
  integer f, l1, l2, i
  byte file(1), hdr(HDRSIZE)
  byte listcc(2), fortcc(2), nonecc(4)
  integer concat
  byte cupper
  include "clist.cmn"
  data listcc/FF, EOS/,
       fortcc/'1', EOS/,
       nonecc/CR,
	      LF,
	      FF,
	      EOS/

  hdr(1) = EOS
  if (outcc == LIST)
    l1 = concat(hdr, listcc, HDRSIZE)
  else if (outcc == 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+49; 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) = CR; hdr(i+20) = LF
  call put(f, hdr, i+20, 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"
  include "clist.cmn"

  j = mod(cp-1, scrwid) + 1
  l = length(comand)
  k = min0(cp + scrwid - j, l)
  call ttput(comand, k)
  encode(j, (t<j>,'^'), comand)
  call ttput(comand, j)
  if (k < l)
    call ttput(comand(k+1), l - k)
  call ttput(msg, 0)
  comand(cp) = ERROR
  xstat = EXIT_ERROR
  return
  end

# ttput - put a line with carriagecontrol to the standard output file
#       - inefficient version for error messages, etc.
  subroutine ttput(buf, nch)
  include "clist.cmn"
  integer nch, ier, len,
    length
  byte buf(1), crlf(2)
  data crlf /CR, LF/

  ier = 0
  if (nch == 0)
    len = length(buf)
  else
    len = nch
  if (ttcc == NONE)
    call put(TT$OUT, crlf, 2, ier, .true.)
  if (ier == 0)
    call put(TT$OUT, buf, len, ier, .true.)
  return
  end