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

# wpat - compile wild pattern

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(WILD,-128)
define(ANY,-127)
define($BREAK,-126)
define(ALPHA,-124)
define(NUMBER,-122)
define(OR,0)
define(AND,2)
define(NOT,1)

  logical function wpat(pat, patp, spcial, aux, maxaux)
  implicit integer (a-z)
  byte pat(1), aux(1), spcial(1), cupper
  logical eol, litral, addchr

  lastor = 1
  patp = patp-1
  litral = .false.
  pattyp = OR
  repeat {
    auxp = lastor+1
    eol = .false.
    patp = patp+1
    if (pat(patp) == NOTC) {		# negate pattern?
      setaux(auxp, NOT | pattyp)
      patp = patp+1
      }
    else
      setaux(auxp, pattyp)
    auxp = auxp+1
    if (pat(patp) == BOLC)		# match beginning of line?
      patp = patp+1
    else {
      setaux(auxp, WILD)
      auxp = auxp+1
      }
    for ( ; pat(patp) != EOS ; patp = patp+1)
      if (litral & pat(patp) != LITERALC) {
	addchar(pat(patp))
	}
      else if (pat(patp) == LITERALC) {
	if (pat(patp+1) != LITERALC)
	  litral = ! litral
	else {
	  addchar(LITERALC)
	  patp = patp+1
	  }
	}
      else if (pat(patp) == DELIMC | pat(patp) == ORC | pat(patp) == ANDC) {
	break
	}
      else if (pat(patp) == WILDC) {
	if (auxp-1 > maxaux)
	  goto 10
	if (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)) {
	eol = .true.
	}
      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 (! eol) {
      if (auxp-1 > maxaux)
	goto 10
      if (aux(auxp-1) != WILD) {	# collapse multiple wild chars
	setaux(auxp, WILD)
	auxp = auxp+1
	}
      }
    if (auxp-lastor > 127)
      goto 10
    setaux(lastor, auxp-lastor)
    lastor = auxp
    if (pat(patp) == ANDC)
      pattyp = AND
    else
      pattyp = OR
    } until (pat(patp) == DELIMC | pat(patp) == EOS)
  setaux(lastor, 0)
  if (pat(patp) != EOS)
    patp = patp+1
_ifdef(DEBUG)
  write(5,(1x,20o4)) (aux(i),i=1,auxp)
_enddef
  return(.true.)
 
10 continue				# error exit
  return(.false.)
  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 upper case
  else
    setaux(auxp+1, 0)
  auxp = auxp+2
  return(.true.)
 
10 continue			# error exit
  return(.false.)
  end
 
_ifndef(MacroWsrch)
define(PatOffset,2)
define(Negate,((pat(bp+1) & NOT) != 0))
define(IsAnd,((pat(bp+1) & AND) != 0))
 
# wsrch - search text for wild pattern
  integer function wsrch(text, textl, pat)
  byte text(1), pat(1)
  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/

  succes = .false.
  et = textl + 1
  for (pp = 1; pat(pp) != 0; pp = ep) {
    bp = pp
    ep = pp + pat(pp)
    pp = pp + PatOffset
    tp = 1
    star = 0
    t = Negate
    while (tp < et & pp < ep)
      if (pat(pp) < 0)
	switch (pat(pp)) {

	  case WILD:
	    pp = pp+1
	    star = pp
	    if (pp == bp+PatOffset+1 & pp < ep & pat(pp) == $BREAK) {
	      pp = pp+1			# try to match from line beginning
	      mark = tp-1
	      }
	    else
	      mark = tp

	  case ANY:
	    tp = tp+1
	    pp = pp+1

	  default:
	    if (ctype(text(tp) + 129) == pat(pp)) {
	      tp = tp+1
	      pp = pp+1
	      }
	    else
	      goto 5

	  }
      else if (pat(pp) == (text(tp) | pat(pp+1))) {
        tp = tp+1
        pp = pp+2
        }
      else {					# match failed
5       if (star == 0)
	  break
10	pp = star
	mark = mark+1
        tp = mark
        }
    if (tp == et & pp == ep)			# matched to end?
      t = ! t
    else if (ep-PatOffset == bp)		# null pattern?
      ;
    else if (pat(ep-1) == WILD & pp >= ep-1)	# matched to end wild?
      t = ! t
    else if (pp < ep & tp == et) {		# $BREAK at EOL?
      if (pat(pp) == $BREAK & pp == ep-2 & pat(ep-1) == WILD)
	t = ! t
      }
    else if (tp < et & star != 0)		# matched pat but not at end 
      goto 10
    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
  logical 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))
      write(5, (' bad pattern'))
    else {
      read_prompt('$buf? ', (q,80a1), (nb, buf))
      do j = 1, 2000
	i = wsrch(buf, nb, aux)
      write(5, (' index = 'i5)) i
      }
    }
10  end
_enddef