#
#
#
#    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                       *
#      *                                                     *
#      *******************************************************
#
#
# define(DEBUG)
define(MacroWsrch)
define(CLASSES)

define(EOS,0)
define(setaux,{ if ($1 > maxaux) goto 10; aux($1) = $2 })
define(addchar,{ if (! addchr($1, aux, auxp, maxaux, litral)) goto 10 })
define(DELIMC,spcial(1))
define(WILDC,spcial(2))
define(ANYC,spcial(3))
define(ORC,spcial(4))
define(ANDC,spcial(5))
define(NOTC,spcial(6))
define(BOLC,spcial(7))
define(EOLC,spcial(8))
define(CONTROLC,spcial(9))
define(LITERALC,spcial(10))
define($BREAKC,spcial(11))
_ifdef(CLASSES)
define(ALPHAC,spcial(12))
define(NUMBERC,spcial(13))
_enddef
define(BEGIN_BRACKET,spcial(14))
define(END_BRACKET,spcial(15))
define(COLUMN_SEPARATOR,spcial(16))
define(WILD,-128)
define(ANY,-127)
define($BREAK,-126)
define(EOL,-125)
define(BOL,-124)
define(ALPHA,-123)
define(NUMBER,-122)
define(OR,0)
define(AND,2)
define(NOT,1)
define(COLUMNS,4)

# wpat - compile wild pattern
  integer function wpat(pat, patp, spcial, aux, maxaux)
  implicit integer (a-z)
  byte pat(1), aux(1), spcial(1),
    colb(4),
    cupper
  integer*2 locol, hicol
  logical litral, addchr
  equivalence (locol, colb), (hicol, colb(3))

  begpat = 1
  patp = patp-1
  litral = .false.
  pattyp = OR
  repeat {
    auxp = begpat+1
    patp = patp+1
    if (pat(patp) == BEGIN_BRACKET) {	# column range?
      patp = patp+1
      k = scan(pat, '1234567890', patp)
      if (pat(k) == COLUMN_SEPARATOR) {
	locol = 1
	if (k > patp)
	  decode(k-patp, (i<k-patp>), pat(patp), err=20) locol
	if (locol <= 0)
	  goto 20
	patp = k+1
	hicol = 32767
	k = scan(pat, '1234567890', patp)
	if (k > patp)
	  decode(k-patp, (i<k-patp>), pat(patp), err=20) hicol
  	if (locol > hicol)
	  goto 20
	locol = locol-1		# zero relative
	patp = k
	if (pat(patp) != END_BRACKET)
	  goto 20
	patp = patp+1
	pattyp = COLUMNS | pattyp
	}
      else {
	patp = k
	goto 20
	}
      }
    if (pat(patp) == NOTC) {		# negate pattern?
      pattyp = NOT | pattyp
      patp = patp+1
      }
    setaux(auxp, pattyp)
    auxp = auxp+1
    if ((pattyp & COLUMNS) != 0) {
      do k = 0, 3
	setaux(auxp+k, colb(k+1))
      auxp = auxp+4
      }
    bp = auxp
    if (pat(patp) == BOLC) {		# match beginning of line?
      patp = patp+1
      setaux(auxp, BOL)
      auxp = auxp+1
      }
    for ( ; pat(patp) != EOS ; patp = patp+1)
      if (pat(patp) == LITERALC) {
	if (pat(patp+1) != LITERALC | ! litral)
	  litral = ! litral
	else {
	  addchar(LITERALC)
	  patp = patp+1
	  }
	}
      else if (litral) {
	addchar(pat(patp))
	}
      else if (pat(patp) == DELIMC | pat(patp) == ORC | pat(patp) == ANDC) {
	break
	}
      else if (pat(patp) == WILDC) {
	if (auxp > bp &	aux(auxp-1) != WILD) {	# collapse multiple wild chars
	  setaux(auxp, WILD)
	  auxp = auxp+1
	  }
	}
      else if (pat(patp) == ANYC) {
	setaux(auxp, ANY)
	auxp = auxp+1
	}
      else if (pat(patp) == CONTROLC & pat(patp+1) != EOS) {
	patp = patp+1
	addchar(cupper(pat(patp)) - 8%100)
	}
      else if (pat(patp) == EOLC &
	  (pat(patp+1) == DELIMC | pat(patp+1) == ORC | pat(patp+1) == EOS |
	   pat(patp+1) == ANDC)) {
	setaux(auxp, EOL)
	auxp = auxp+1
	}
      else if (pat(patp) == $BREAKC) {
	setaux(auxp, $BREAK)
	auxp = auxp+1
	}
_ifdef(CLASSES)
      else if (pat(patp) == ALPHAC) {
	setaux(auxp, ALPHA)
	auxp = auxp+1
	}
      else if (pat(patp) == NUMBERC) {
	setaux(auxp, NUMBER)
	auxp = auxp+1
	}
_enddef
      else {
	addchar(pat(patp))
	}

    if (auxp > bp & aux(auxp-1) == WILD) 
      auxp = auxp-1			# delete wild char at end of pattern
    if (auxp-begpat > 255)
      goto 10
    setaux(begpat, auxp-begpat-128)
    begpat = auxp
    if (pat(patp) == ANDC)
      pattyp = AND
    else
      pattyp = OR
    } until (pat(patp) == DELIMC | pat(patp) == EOS)
  setaux(begpat, -128)
  if (pat(patp) != EOS)
    patp = patp+1
_ifdef(DEBUG)
  write(5,(1x,20o4)) (aux(i),i=1,auxp)
_enddef
  return(1)
 
10 continue				# pattern too long
  return(2)

20 continue				# bad column range
  return(4)
  end
 
# addchr - add a character to the aux array
  logical function addchr(char, aux, auxp, maxaux, litral)
  byte char, aux(1), c
  integer maxaux, auxp
  logical litral

  if (char >= 'A' & char <= 'Z' & !litral)
    c = char - 'A' + 'a'		# convert to lower case; ASCII only!
  else
    c = char
  setaux(auxp, c)
  if (c >= 'a' & c <= 'z' & !litral)
    setaux(auxp+1, 8%40)		# mask to convert text to lower case
  else
    setaux(auxp+1, 0)
  auxp = auxp+2
  return(.true.)
 
10 continue			# error exit
  return(.false.)
  end

 
_ifnotdef(MacroWsrch)

define(IsNegate,((flags & NOT) != 0))
define(IsAnd,((flags & AND) != 0))
define(HasColumns,((flags & COLUMNS) != 0))
define(BACKUP,101)
define(FAIL,103)
 
# wsrch - search text for wild pattern
  integer function wsrch(text, textl, pat)
  byte text(1), pat(1),
    colb(4), flags
  integer*2 locol, hicol
  integer textl, tp, pp, et, ep, bp, star, mark
  logical succes, t
# A-Z and a-z are alphabetic, 0-9 are numeric, rest are break characters
  byte ctype (256)
  data ctype /128*$BREAK,48*$BREAK,10*NUMBER,7*$BREAK,26*ALPHA,
	      6*$BREAK,26*ALPHA,5*$BREAK/
  equivalence (locol, colb), (hicol, colb(3))

  succes = .false.
  for (pp = 1; pat(pp) != -128; pp = ep) {
    ep = pp + pat(pp) + 128
    flags = pat(pp+1)
    pp = pp + 2
    bp = pp
    if (IsAnd) {				# and?
      if (! succes)
	next
      }
    else					# must be or
      if (succes)
	next
    tp = 1
    et = textl + 1
    if (HasColumns) {				# Column range specified?
      bp = bp+4
      for ( ; pp < bp; pp = pp+1)
	colb(pp-bp+5) = pat(pp)
      tp = tp+locol
      if (hicol < textl)
	et = hicol + 1
      }
    t = IsNegate
    star = pp
    mark = tp
    if (pp < ep)
      if (pat(pp) == $BREAK) {		# try to match break with line begin
	mark = tp-1
	pp = pp+1
	}
    while (pp < ep) {
      if (pat(pp) < 0)
	switch (pat(pp)) {

	  case WILD:
	    pp = pp+1
	    star = pp
	    mark = tp

	  case ANY:
            if (tp >= et)
	      goto FAIL
	    tp = tp+1
	    pp = pp+1

	  case EOL:
	    if (tp < et)
	      goto BACKUP
	    pp = pp+1

	  case BOL:
	    star = 0
	    pp = pp+1

	  default:
	    if (tp < et) {
	      if (ctype(text(tp) + 129) != pat(pp))
		goto BACKUP
	      tp = tp+1
	      pp = pp+1
	      }
	    else if (pat(pp) == $BREAK)	{	# match line end?
	      pp = pp+1
	      if (pp < ep)			# end of pattern?
		goto FAIL
	      }
	    else
	      goto FAIL

	  }
      else if (tp >= et) {
	goto FAIL
10	continue
	}
      else if (pat(pp) == (text(tp) | pat(pp+1))) {
        tp = tp+1
        pp = pp+2
        }
      else {					# match failed
BACKUP  if (star == 0)
	  goto FAIL
	pp = star
	mark = mark+1
        tp = mark
        }
      }
 
    t = ! t					# success!
 
FAIL
    if (IsAnd)
      succes = succes & t
    else
      succes = succes | t
    }
  if (succes)
    return(1)
  else
    return(0)
  end

_enddef

_ifdef(DEBUG)
  byte pat(80), buf(80), aux(80)
  integer wsrch
  integer wpat
  string spcial ' *?|&~%$^"`@@#<>,'
 
  spcial(1) = EOS
  repeat {
    read_prompt('$pat? ', (q,80a1), (np, pat))
    pat(np+1) = EOS
    i = 1
    if (wpat(pat, i, spcial, aux, 80) != 1)
      write(5, (' bad pattern'))
    else {
      read_prompt('$buf? ', (q,80a1), (nb, (buf(i), i=1, 80)))
_ifdef(VAX)
      call timrb
_enddef
      do j = 1, 15000
	i = wsrch(buf, nb, aux)
_ifdef(VAX)
      call timre
_enddef
      write(5, (' index = 'i5)) i
      }
    }
10  end
_enddef