#
#
#
#    RATFIV structured Fortran compiler
#    ==================================
#
#         Authors: Original by B. Kernighan and P. J. Plauger,
#                  with rewrites and enhancements by David Hanson and
#                  friends (U. of Arizona), Joe Sventek and Debbie
#                  Scherrer (Lawrence Berkely Laboratory), and
#                  William Wood (Institute For Cancer Research).
#
#         Address: William Wood
#                  Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 1.0
#
#         Date:   May 14, 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.                  *
#      *                                                     *
#      *******************************************************
#
# cmdget - get a line with prompt from CMDIN
   integer function cmdget(buf, prompt, source)
   character buf(ARB), prompt(ARB)
   integer nc, source
   repeat {
      call gcmdln(CMDIN, 0, prompt, buf, nc, MAXLINE-1, source)
      if (nc < 0  &  nc != -10)
         call remark('error reading command line.')
      else
        break
      }
   if (nc == -10) {
      cmdget = EOF
      buf(1) = EOF
      buf(2) = EOS
      }
   else {
      cmdget = nc+1
      buf(cmdget) = NEWLINE
      buf(cmdget+1) = EOS
      }
   return
   end
# gclin -- prompt user for arguments, redirect standard files
   subroutine gclin(prompt, source)
   character prompt(ARB)
   integer cmdget, nc, source
   include argcom.rat
 
   noread = .false.
   repeat {
      nc = cmdget(argstr, prompt, source)
      if (nc == EOF | nc == 1) break
      call doredr
      } until (argstr(1) != NEWLINE)
   return
   end
 
# garg - get an argument with prompt from CMDIN
   integer function garg(prompt, narg, buf, buflen)
   character prompt(ARB), buf(ARB)
   integer narg, buflen, gtarg2, source
   logical eofflg
   data eofflg/.false./
   if (eofflg  &  narg == 0) {
      garg = EOF
      buf(1) = EOF
      return
      }
   if (narg == 0) goto 10
   garg = gtarg2(narg, buf, buflen)
   if (garg != EOF)
      narg = narg+1
   else if (buf(1) == NEWLINE)  # really was a NEWLINE, not EOF
  10  if (prompt(1) != EOS) {
         call gclin(prompt, source)
         garg = gtarg2(1, buf, buflen)
         if (garg != EOF)
            narg = 2
         else if (narg != 0  &  source < 0  &  buf(1) != NEWLINE)  {
            eofflg = .true.   # don't reprompt when narg = 0 next time
            goto 10           # get past fake EOF on second gclin
            }
         }
   return
   end
 
# getarg -- interface to gtarg2 with read if none done already
  integer function getarg(n, strng, size)
  integer n, size
  character strng(ARB)
  integer gtarg2
  include argcom.rat
 
  if (noread) {
    call gclin('> ', source)
    }
  getarg = gtarg2(n, strng, size)
  return
  end
 
# gcmd - get command line from MCR, TS, or terminal
#        This routine may be used by programs wishing to receive a
#        time sharing message (command line) from XEQ, a
#        command line from MCR, or a command line from the terminal
#        directly using a prompt.
#
#        By William Wood, Sept 1980
#
define(MCR,-2)
define(MESSAGE,-1)
define(TERMINAL,0)
define(EOS,0)
define(EOF,-10)
subroutine gcmd(lun, prompt, buf, len, maxlen, source)
byte prompt(1), buf(1)
integer lun, len, maxlen, source
integer i, j, junk
logical first
data first/.true./
 
len = 0
if (first) {
  first = .false.
  call getmcr(buf, len)
  if (len > 0) {
    source = MCR
    for (i = 1; i < len; i = i+1)
      if (buf(i) == ' ')
        break
    j = i
    for (i = i+1; i <= len; i = i+1)
      buf(i-j) = buf(i)
    len = len - j
    }
  else {
    call reccml(buf, len)
    source = MESSAGE
    }
  }
 
if (len <= 0) {
  source = TERMINAL
  if (lun == 0)
    len = EOF
  else {
    repeat
      call readpr(lun, prompt, buf, len, maxlen-1, junk)
      until(len >= 0  |  len == EOF)
    }
  }
 
buf(max0(1, min0(maxlen, len+1))) = EOS
return
end
 
# garg2 - get an argument with prompt
   integer function garg2(prompt, narg, buf, buflen, lun)
   character prompt(ARB), buf(ARB)
   integer narg, buflen, gtarg2, source, lun, nc, i
   logical eofflg
   include argcom.rat
   data eofflg/.false./
 
   garg2 = EOF
   if (eofflg  &  narg == 0) {
      buf(1) = EOF
      return
      }
   if (narg != 0) {
      garg2 = gtarg2(narg, buf, buflen)
      narg = narg+1
      }
   if ((prompt(1) != EOS  |  narg == 0)  &  garg2 == EOF) {
      call gcmd(lun, prompt, argstr, nc, MAXLINE-1, source)
      if (source < 0)
         eofflg = .true.		# there was input from the command line
      if (nc >= 0)
        i = nc+1
      else
        i = 1
      argstr(i) = NEWLINE
      argstr(i+1) = EOS
      garg2 = gtarg2(1, buf, buflen)
      narg = 2
      }
   return
   end
 
define(min,min0)
# gtarg2 -- get the n-th argument and return its length or EOF
   integer function gtarg2 (n, strng, size)
   integer n, size, source
   character strng (ARB)
   integer i, j, k, m
   logical lb
   include argcom.rat
 
   j = 0
   i = 1
   lb = .false.
   while (j < n) {
      while (argstr(i) == ' '   |   argstr(i) == TAB
             |   argstr(i) == ',') i = i+1
      if (argstr(i) == EOF  |  argstr(i) == NEWLINE) {
         strng(1) = argstr(i)
         gtarg2 = EOF
         return
         }
      if (argstr(i) == '/') {
         strng(1) = '/'
         k = 1
         }
      else k = 0
      repeat {
         k = k+1
         m = i+k-1
         if (k < size) strng(k) = argstr(m)
         if (argstr(m) == LBRACK) lb = .true.
         else if (argstr(m) == RBRACK) lb = .false.
         } until (!lb & (argstr(m) == ' ' | argstr(m) == TAB |
                  argstr(m) == NEWLINE | argstr(m) == ',' | argstr(m) == '/'))
      strng(min(k, size)) = EOS
      i = m
      j = j+1
      }
   gtarg2 = min(k, size)
   if (upflag)
     call upper(strng)
   return
   end
# delarg - delete the nth argument in the command line
   subroutine delarg (n)
   integer i, j, begstr, n
   logical lb
   include argcom.rat
   j = 0
   i = 1
   lb = .false.
   while (j < n) {
      begstr = i
      while (argstr(i) == ' '   |   argstr(i) == TAB
             |   argstr(i) == ',') i = i+1
      if (argstr(i) == EOF  |  argstr(i) == NEWLINE)
         return
      repeat {
         if (argstr(i) == LBRACK) lb = .true.
         else if (argstr(i) == RBRACK) lb = .false.
         i = i+1
         } until (!lb & (argstr(i) == ' ' | argstr(i) == TAB |
                  argstr(i) == NEWLINE | argstr(i) == ',' | argstr(i) == '/'))
      j = j+1
      }
   if (begstr == 1 & argstr(i) != '/' & argstr(i) != NEWLINE) i = i+1
   call scopy(argstr, i, argstr, begstr)
   return
   end
# chkarg - put out error message if spurious argument on cmd line
   subroutine chkarg(n)
   integer n, gtarg2, i, length
   include argcom.rat
   do i = 1, n-1
      call delarg(1)
   if (gtarg2(1, i, 1) != EOF) {
      argstr(length(argstr)) = EOS
      call putlin(argstr, ERROUT)
      call remark(': ignored')
      }
   return
   end
# savarg - save current command line
   subroutine savarg(buf)
   character buf(ARB)
   include argcom.rat
   call scopy(argstr, 1, buf, 1)
   return
   end
# rstarg - restore current command line
   subroutine rstarg(buf)
   character buf(ARB)
   include argcom.rat
   call scopy(buf, 1, argstr, 1)
   return
   end
# upcmd - reset fold commands to upper case flag
   subroutine upcmd(flag)
   logical flag
   include argcom.rat
   upflag = flag
   return
   end
# doredr -- do any redirection of std files required
   subroutine doredr
   character buf(MAXLINE), opntyp
   integer i, k, ier
   integer gtarg2, index
   include argcom.rat
   call scopy(argstr, 1, buf, 1)
   k = 1
   for (i = 1; buf(i) != EOS; i = i+1) {
      if (k > MAXLINE-3) call error('command line overflow in doredr.')
      if (index('<>?', buf(i)) != 0) {
         argstr(k) = ' '
         k = k+1
         if ((buf(i) == '>' & buf(i+1) == '>') |
             (buf(i) == '?' & buf(i+1) == '?')) {
            argstr(k) = buf(i)
            k = k+1
            i = i+1
            }
         }
      argstr(k) = buf(i)
      k = k+1
      }
   argstr(k) = EOS
   for (i = 1; gtarg2(i, buf, MAXLINE) != EOF; ) {
      if (buf(1) == '<')  {
         call scopy(buf, 2, buf, 1)
         call opnstd(buf, STDIN, READONLY, 'TI:', FORTRAN)
         call delarg(i)
         }
      else if (buf(1) == '>')  {
         k = 2
         opntyp = WRITE
         if (buf(2) == '>')  {
            k = 3
            opntyp = EXTEND
            }
         call scopy (buf, k, buf, 1)
         call opnstd(buf, STDOUT, opntyp, 'TI:', WRITE)
         call delarg(i)
         }
      else if (buf(1) == '?') {
         k = 2
         opntyp = WRITE
         if (buf(2) == '?')  {
            k = 3
            opntyp = EXTEND
            }
         call scopy (buf, k, buf, 1)
         call opnstd(buf, ERROUT, opntyp, 'TI:', WRITE)
         call delarg (i)
         }
      else     # no redirection, bump counter
         i = i + 1
      }
   return
   end
# opnstd - close and reopen standard files
   subroutine opnstd(buf, unit, access, stdfil, stdacc)
   character buf(ARB), stdfil(ARB), access, stdacc
   integer unit, closec, ier
   include iocom.rat
   if (closec(unit, SAVEF) != ERR) {
      if (buf(1) == EOS) {		# redirect back to standard file
         call opn(unit, stdfil, stdacc, ier)
         if (ier != 0) {
            call putlin(stdfil, ERROUT)
            call error(": can't open in opnstd.")
            }
         else if (unit == STDIN) tiin = .true.	# reading from terminal
         }
      else {
         call defnam(buf, EOS, 'SY:', EOS, EOS, '.', .false.)
         call opn(unit, buf, access, ier)
         if (ier != 0) {
            call opn(unit, stdfil, stdacc, ier)
            if (ier != 0) {
               call putlin(stdfil, ERROUT)
               call error(": can't open in opnstd.")
               }
            else if (unit == STDIN) tiin = .true.	# reading from terminal
            call putlin(buf, ERROUT)
            call error(": can't open.")
            }
         else if (unit == STDIN) tiin = .false.	# not reading from terminal
         }
      }
   return
   end
# gcmdln - export version of gcmdln with no indirect command files
  subroutine gcmdln(lun, idum, prompt, buf, len, maxl, source)
  integer lun, idum, len, maxl, source, ier
  byte prompt(1), buf(1)
  common /gcmd01/ first
  logical first
  data first /.true./

  if (first) {
    first = .false.
    call opn(lun, 'TI:', 'R', ier)
    if (ier != 0)
      call error("can't open CMDIN.")
    }
  call gcmd(lun, prompt, buf, len, maxl, source)
  return
  end
# reccml - stub for IAS specific receive timesharing message
  subroutine reccml(buf, len)
  byte buf(1)
  integer len

  len = -80
  return
  end