#
#
#
#                  XEQ
#                  ===
#
#
#         Author:  William Wood
#                  Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 1.0
#
#         Date:    June 2, 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                       *
#      *                                                     *
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DESIGNED FOR USE ON A        *
#      *      PDP-11/70 OPERATING UNDER IAS V3.0 USING       *
#      *      THE FORTRAN-IV PLUS COMPILER.                  *
#      *                                                     *
#      *******************************************************
#
  program xeq
  character prog(MAXLINE)
  integer i
  integer pmatch, gcmd, gtarg2, equal
#$  integer length

  call initr4
  if (gcmd() == EOF)
    call endr4
  if (gtarg2(1, prog, MAXLINE) == EOF)
    call endr4
  call upper(prog)				# convert to upper case
  if (pmatch(prog, '/SET_DEFAULTS') == YES) {
    call whozon(prog, EOS, 0, 0)
    call iniusr(prog, 2, .true.)
    call listd
    }
  else if (pmatch(prog, '/APPEND') == YES) {
    call whozon(prog, EOS, 0, 0)
    call iniusr(prog, 2, .false.)
    call listd
    }
#$  else if (equal(prog, '/UPDATE') == YES) {
#$    if (gtarg2(2, prog, 13) ~= EOF) {
#$      do i = length(prog)+1, 13
#$        prog(i) = EOS
#$      call iniusr(prog, 3, .true.)
#$      }
#$    }
#$  else if (equal(prog, '/UPDATE_APPEND') == YES) {
#$    if (gtarg2(2, prog, 13) ~= EOF) {
#$      do i = length(prog)+1, 13
#$        prog(i) = EOS
#$      call iniusr(prog, 3, .false.)
#$      }
#$    }
  else if (pmatch(prog, '/LIST') == YES)
    call listd
  else if (equal(prog, '/PEEK') == YES)
    call peek
  else
    call runprg(prog)
  call endr4
  end
 
# runprg - search for and run the program
  subroutine runprg(prog)
  character prog(ARB), tsk(MAXLINE), user(12), args(MAXLINE)
  integer isfile, maktsk, length, lookup
  integer i, usrind
  include xeqcom.com
 
  call delarg(1)
  call savarg(args)
  args(length(args)) = EOS			# delete NEWLINE
  call defnam(prog, EOS, EOS, EOS, EOS, '.TSK', .false.)
  call whozon(user, EOS, 0, 0)
  usrind = lookup(user)
  for (i = dlist(usrind); maktsk(prog, tsk, i) == YES; i = dlist(i))
    if (isfile(tsk) == YES) {
      call chainr(tsk, args)
      return
      }
  call putlin(prog, ERROUT)
  call error(': can''t run.')
  return
  end
 
# iniusr - insert new search directories
  subroutine iniusr(user, nn, flag)
  character user(12), dir(MAXLINE)
  integer dirind, usrind, n, j, nn, dsave
  integer gtarg2, initd, lookup
  logical flag
  include xeqcom.com
 
  usrind = lookup(user)
  if (flag) {
    for (dirind = dlist(usrind); dirind ~= NIL; dirind = dsave) {
      dsave = dlist(dirind)
      dlist(dirind) = EMPTY
      }
    dlist(usrind) = NIL
    dirind = usrind
    }
  else
    for (dsave = usrind; dsave ~= NIL; dsave = dlist(dsave))
      dirind = dsave
  for (n = nn; gtarg2(n, dir, MAXLINE) ~= EOF; n = n+1)
    if (initd(dir, dlist(dirind)) ~= ERR)
      dirind = dlist(dirind)
  return
  end
 
# listd - list the default directories for this user
  subroutine listd
  character user(12), dir(15)
  integer usrind, dirind
  integer lookup
  include xeqcom.com
 
  call whozon(user, EOS, 0, 0)
  usrind = lookup(user)
  for (dirind = dlist(usrind); dirind ~= NIL; dirind = dlist(dirind)) {
    call getdir(dir, dirind)
    call outlin(dir, STDOUT)
    }
  return
  end
 
# peek - see what's what in XEQCOM
  subroutine peek
  character dir(15), usrnum(4), user(13), outfil(FILENAMESIZE)
  integer usrind, dirind, i, f
  integer itocrj, openc, gtarg2
  include xeqcom.com
 
  if (gtarg2(2, outfil, FILENAMESIZE) == EOF)
    f = STDOUT
  else {
    f = openc(outfil, WRITE)
    if (f == ERR)
      return
    }
  do usrind = 1, MAXUSERS
    if (users(1, usrind) ~= EOS) {
      i = itocrj(usrind, usrnum, 4)
      call putlin(usrnum, f)
      call putlin('> ', f)
      do i = 1, 12
        user(i) = users(i, usrind)
      user(13) = EOS
      call putlin(user, f)
      for (dirind = dlist(usrind); dirind ~= NIL; dirind = dlist(dirind)) {
        call getdir(dir, dirind)
        call putlin(' ', f)
        call putlin(dir, f)
        }
      call putch(NEWLINE, f)
      }
  if (f ~= STDOUT)
    call closec(f, SAVEF)
  return
  end
 
# lookup - lookup user's search path index
  integer function lookup(user)
  character user(12), offset
  integer i, start, j
  integer initd
  include xeqcom.com
  data offset /'A'/
 
  start = user(1) - offset
  start = 10*start + 1
  i = start
  repeat {
    for (j = 1; j <= 12; j = j+1)
      if (user(j) ~= users(j, i))
        break
    if (j > 12) {
      lookup = i
      return
      }
    i = mod(i, MAXUSERS) + 1
    } until (i == start)
  repeat {					# user not found - new user
    if (users(1, i) == EOS)
      break
    i = mod(i, MAXUSERS) + 1
    if (i == start)
      call error('XEQ -- MAXIMUM NUMBER OF USERS EXCEEDED - CONTACT SYSTEM MANAGER!!')
    }
  do j = 1,12					# insert user in XEQCOM
    users(j, i) = user(j)
  j = initd('SY:', dlist(i))
  j = initd('LB:[22,2]', dlist(dlist(i)))
  lookup = i
  return
  end
 
# maktsk - build up a task name
  integer function maktsk(prog, tsk, dirind)
  character prog(ARB), tsk(ARB)
  integer dirind, i
  integer concat, index
  logical first
  include xeqcom.com
  data first/.true./
 
  maktsk = NO
  if (index(prog, ':') ~= 0) {
    if (first) {
      call scopy(prog, 1, tsk, 1)
      maktsk = YES
      }
    }
  else if (dirind == NIL)
    ;
  else {
    call getdir(tsk, dirind)
    i = concat(tsk, prog, MAXLINE)
    maktsk = YES
    }
  first = .false.
  return
  end
 
# initd - insert new search directory in XEQCOM
  integer function initd(dir, dirind)
  character dir(ARB), tdir(15)
  integer dirind, i
  integer ascw50, length
  integer*2 w50dir(5)
  include xeqcom.com
 
  dirind = NIL
  i = length(dir)
  if (i > 14) {
    call putlin(dir, ERROUT)
    call remark(': search directory too long.')
    initd = ERR
    return
    }
  call scopy(dir, 1, tdir, 1)
  call upper(tdir)
  for (i = i+1; i <= 14; i = i+1)		# pad with ','
    tdir(i) = ','
  if (ascw50(14, tdir, w50dir) == ERR) {
    call putlin(dir, ERROUT)
    call remark(': illegal character in search directory.')
    initd = ERR
    }
  else {
    for (dirind = MAXUSERS+1; dirind <= MAXDIRECTORIES+MAXUSERS; dirind = dirind+1)
      if (dlist(dirind) == EMPTY)
        break
    if (dirind > MAXDIRECTORIES+MAXUSERS) {
      dirind = NIL
      call error('XEQ -- TOO MANY DIRECTORY ENTRIES - CONTACT SYSTEM MANAGER!!')
      }
    do i = 1,5
      direct(i, dirind-MAXUSERS) = w50dir(i)
    dlist(dirind) = NIL
    initd = YES
    }
  return
  end
 
# getdir - get a directory entry
  subroutine getdir(dir, dirind)
  character dir(ARB)
  integer dirind, i
  integer w50asc
  include xeqcom.com
 
  if (w50asc(14, direct(1, dirind-MAXUSERS), dir) == ERR)
    call error('XEQ -- BAD DIRECTORY ENTRY')
  for (i = 14; i > 0; i = i-1)			# unpad
    if (dir(i) ~= ',')
      break
  dir(i+1) = EOS
  return
  end
 
#
#  the restricted char set used here is:
#     A-Z
#     0-9
#     :[],
#
# ascw50 - convert from ascii to restricted char set
  integer function ascw50(n, ascbuf, w50buf)
  character ascbuf(ARB), asc
  integer n, nw50, iasc, iw50, i
  integer*2 int2, w50buf(ARB), w50i2
  integer*4 int4, exp50(3)
  equivalence (int2, int4)
  data exp50 /1600, 40, 1/
 
  nw50 = (n+2)/3
  if (nw50 <= 0)
    ascw50 = ERR
  else {
    iasc = 0
    do iw50 = 1, nw50 {
      int4 = 0
      do i = 1,3 {
        if (i+iasc > n)
          break
        asc = ascbuf(i + iasc)
        if (asc >= 'A' & asc <= 'Z')
          w50i2 = asc - 'A'
        else if (asc >= '0' & asc <= '9')
          w50i2 = (asc - '0') + 26
        else if (asc == ',')
          w50i2 = 36
        else if (asc == ':')
          w50i2 = 37
        else if (asc == '[')
          w50i2 = 38
        else if (asc == ']')
          w50i2 = 39
        else {
          ascw50 = ERR
          return
          }
        int4 = int4 + (w50i2*exp50(i))
        }
      w50buf(iw50) = int2
      iasc = iasc + 3
      }
    ascw50 = YES
    }
  return
  end
 
# w50asc - convert from restricted char set to ascii
  integer function w50asc(n, w50buf, ascbuf)
  character ascbuf(ARB), chrbuf(4)
  integer n, nw50, iasc, iw50, i
  integer*2 w50buf(ARB), int2, w50i2
  integer*4 int4, exp50(3)
  equivalence (int2, int4)
  data exp50 /1600, 40, 1/
  data chrbuf /',', ':', '[', ']'/
 
  nw50 = (n+2)/3
  if (nw50 <= 0)
    w50asc = ERR
  else {
    iasc = 0
    do iw50 = 1, nw50 {
      int4 = 0
      int2 = w50buf(iw50)
      if (int4 >= 64000) {
        w50asc = ERR
        return
        }
      do i = 1, 3 {
        if (i+iasc > n)
          break
        w50i2 = int4/exp50(i)
        int4 = int4 - (w50i2*exp50(i))
        if (w50i2 >= 0 & w50i2 <= 25)
          ascbuf(i + iasc) = w50i2 + 'A'
        else if (w50i2 >= 26 & w50i2 <= 35)
          ascbuf(i + iasc) = (w50i2 - 26) + '0'
        else
          ascbuf(i + iasc) = chrbuf(w50i2-35)
        }
      iasc = iasc + 3
      }
    w50asc = YES
    }
  return
  end
 
# chainr - chain to tsk, sending msg to chained task
  subroutine chainr(tsk, msg)
  character tsk(1), msg(1)
  character ttsk(MAXLINE), tmsg(MAXLINE), bmsg(3), btsk(2)
  integer length
  integer*2 mlen
  equivalence (tmsg(1), bmsg(3)), (mlen, bmsg(1))
  equivalence (ttsk(1), btsk(2))
  data btsk(1) /' '/
  call scopy(tsk, 1, ttsk, 1)
  call scopy(msg, 1, tmsg, 1)
  mlen = length(msg)
  if (mlen == 0)
    call chain(btsk)
  else
    call chain(btsk, bmsg)
  return
  end
 
# isfile - see if file exists
  integer function isfile(file)
  character file(ARB)
  integer open, closel
  integer junk, f
  f = open(file, READ)
  if (f ~= ERR) {
    junk = closel(f, SAVEF)
    isfile = YES
    }
  else
    isfile = NO
  return
  end
 
# gcmd - get a command line
  integer function gcmd()
  character cmdlin(MAXLINE)
  integer nc, i
  integer index
  gcmd = EOF
  call getmcr(cmdlin, nc)
  if (nc >= 0) {
    cmdlin(nc+1) = NEWLINE
    cmdlin(nc+2) = EOS
    i = index(cmdlin, ' ')
    if (i ~= 0) {
      call rstarg(cmdlin(i+1))
      gcmd = YES
      }
    }
  return
  end