#-h- io              1418  asc  07-may-82 07:56:23  tools (lblh csam sventek)
 ## io -- common block with VMS and IAS io info for tools
 # put on a file called 'io'
 # Used by osprim.r 
 
    common / io / lfn(NNFILES), lastc(NNFILES), fdb(NNFILES),
		  rawchn(NNFILES),
		  bcount(NNFILES),
		  chstat(NNFILES),
		  chtimo(NNFILES),
		  imp_ctrl(NNFILES),
		  mode(NNFILES), filacc(NNFILES),
		  fltype(NNFILES), chtype(NNFILES),
                  filenm(FILENAMESIZE, NNFILES),
		  buffer(MAXLINE, NNFILES),
                  new_versions
 
    integer lfn		# ascii device name; initialized to TI
    integer lastc	# pointer to last character in unit's buffer
			# initialized to 0 for output, MAXLINE for input
    integer fdb		# fdb address for unit; initialized in open subs
    integer rawchn	# VMS channel to use for raw IO
    integer bcount	# size of current record we are reading
    integer chstat	# status on unit
    integer chtimo	# timeout value for raw reads
    logical*1 imp_ctrl	# if implied carriage control is necessary YES/NO
    logical*1 mode	# array for mode of input - INPUTMODE/OUTPUTMOODE
    logical*1 filacc	# access used to open file
    logical*1 fltype	# type of file - BINARY/ASCII
    logical*1 chtype	# type of channel - RAW/COOKED
    character filenm	# file name associated with unit
    character buffer	# line buffer for unit
    integer new_versions # YES/NO whether to create a new version when
                         # creating a file at WRITE access
#-h- carg             164  asc  25-mar-82 09:05:01  v1.1 (sw-tools v1.1)
 ## carg common block
 # Put on a file called 'carg'
 # Used by osprim.r
 
 common /carg/ nbrarg, ptr(MAXARGS), arg(ARGBUFSIZE)
 integer nbrarg, ptr
 character arg
#-h- ctrmbx           364  asc  25-mar-82 09:05:02  v1.1 (sw-tools v1.1)
# common block ctrmbx - contains information used in VAX termination
#			mailbox scheme
# place on a file called ctrmbx
# used by osprim.r and spawn.r

 common / ctrmbx / termbx, iosb(2), termsg(TERMSGSIZE)
 
 integer termbx	# channel for termination mail box
 integer iosb	# io status block for process id
 integer termsg	# buffer to receive termination status
 
#-h- cexith           195  asc  25-mar-82 09:05:03  v1.1 (sw-tools v1.1)
# common block for exit handler on VAX/VMS
#
 common / cexith / desblk(4), reason

 integer desblk		# descriptor block argument for sys$dclexh
 integer reason		# integer to store reason for exit
#-h- cproc            564  asc  25-mar-82 09:05:05  v1.1 (sw-tools v1.1)
 common / cproc / n4grnd, spunit, pdone(NPROCESSES),
		  pmsg(TERMSGSIZE, NPROCESSES),
		  mbxchn(NPROCESSES),
		  pid(PIDSIZE, NPROCESSES),
		  pname(FILENAMESIZE, NPROCESSES)

 integer n4grnd		# number of active foreground tasks
 integer spunit		# unit for reporting status of background processes
 integer pdone		# is process done? YES/NO
 integer pmsg		# termination mailbox message goes here
 integer mbxchn		# channel for mailbox used for arguments
 character pid		# string with pid for this process
 character pname	# name of image which process is running
#-h- cquota           292  asc  25-mar-82 09:05:06  v1.1 (sw-tools v1.1)
 # common block to hold quota list for creprc system service
 
 common / cquota / b1, l1, b2, l2, b3, l3, b4, l4, b5, l5, b6, l6,
		   b7, l7, b8, l8, b9, l9, ba, la, bb, lb, b0
 
 character b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, b0
 integer   l1, l2, l3, l4, l5, l6, l7, l8, l9, la, lb
#-h- cdirec           285  asc  25-mar-82 09:05:08  v1.1 (sw-tools v1.1)
 common / cdirec / dfab(NDIRECTS),
		   dnam(FILENAMESIZE, NDIRECTS),
		   lfile(FILENAMESIZE, NDIRECTS)

 integer dfab		# fab address for directory manipulations
 character dnam		# DEC string for directory - used to get aux info
 character lfile	# last file string returned by gdrprm
#-h- prim.r         99405  asc  19-oct-83 12:49:57  tools (lblh csam sventek)
#-h- defns           3263  asc  02-aug-83 10:10:18  tools (lblh csam sventek)
# definitions for primitives in general (VAX/VMS)
 
define(NNFILES,MAXOFILES)
define(NEWREAD,99)		# flag for creating new file
define(SCRATCH,98)		# flag for scratch file
define(INPUTMODE,0)		# flag for mode of io
define(OUTPUTMODE,1)
define(CHARAC,0)		# definitions for openf calls
define(BINAR,1)
define(LISTCC,0)
define(FORTCC,1)
define(OLDAGE,-1)
define(UNKAGE,0)
define(NEWAGE,1)
define(NODEVICE,0)		# ratfor unit is not assigned
define(TTYDEVICE,1)		# unit is assigned to tty device
define(MBXDEVICE,2)		# unit is assigned to mailbox
define(OTHERDEVICE,3)		# unit is assigned to other device

define(MAX_TIMEOUT,31557600)	# default timeout == 1 year (dpm 8-Jun-81)

# definitions for spawn primitives

define(NTASKS,5)
define(SSWASCLR,1)
define(QIOW,sys$qiow)
define(QIO,sys$qio)
define(NFOREGROUND,5)
define(NPROCESSES,8)
define(JPITQLM,1040)
define(JPIBYTLM,794)
define(JPIPGFL,1038)
define(BYTLMMIN,1024)
define(FILLMMIN,6)
define(PGFLMIN,1024)
define(PRCLMLEV1,5)
define(PRCLMLEV2,2)
define(TQLMMIN,2)
define(pqlastlm,1)
define(pqlbiolm,2)
define(pqlbytlm,3)
define(pqlcpulm,4)
define(pqldiolm,5)
define(pqlfillm,6)
define(pqlpgflquota,7)
define(pqlprclm,8)
define(pqltqelm,9)
define(pqlwsquota,10)
define(pqlwsdefault,11)
define(pqllistend,0)
define(ASTLM,10)
define(BIOLM,6)
define(BYTLM,6000)
define(CPULM,0)
define(DIOLM,6)
define(FILLM,15)
define(PGFLQUOTA,1024)
define(PRCLM,2)
define(TQELM,8)
define(WSQUOTA,512)
define(WSDEFAULT,256)
define(BFILLM,45)
define(BPRCLM,10)
define(BTQELM,24)
define(BBYTLM,30720)
define(BPGFLQ,30000)
define(BACKPRIORITY,1)
define(TERMSGSIZEBYTE,84)
define(QUOTALISTSIZE,56)
define(MAXDEPTH,5)
define(jpilst,	J1($1)
	J2($1)
	J3($1))
define(J1,integer*2 $1(8))
define(J2,integer*4 $1a)
define(J3,equivalence ($1a,$1(3)))

# definitions for directory primitives
define(TCOLWIDTH,24)
define(BLOCKWIDTH,9)	# (dpm 6-Jul-81)
define(NDIRECTS,10)

# Note that in the following definitions all VMS names containing `$'
# characters have them replaced with `_' characters, except where this
# would cause two adjacent `_' characters.  In these cases the `$' is
# simply omitted. (dpm 16-Jun-81)

# VMS I/O function codes

define(IO_READLBLK,16%21)
define(IO_READVBLK,16%31)
define(IO_TTYREADALL,16%3A)
define(IO_WRITEVBLK,16%30)

# VMS I/O function modifier masks

define(IO_M_NOECHO,16%40)
define(IO_M_NOFILTER,16%200)
define(IO_M_NOFORMAT,16%100)
define(IO_M_NOW,16%40)
define(IO_M_TIMED,16%80)

define(IO_CTRLCAST,16%123)	# IO$_SETMODE | IO$M_CTRLCAST

# VMS Job/Process information request codes

define(JPI_AUTHPRIV,16%412)
define(JPI_CURPRIV,16%400)
define(JPI_IMAGPRIV,16%413)
define(JPI_PROCPRIV,16%204)
define(JPI_CPUTIM,16%407)
define(JPI_FILLM,16%40F)
define(JPI_IMAGNAME,16%207)
define(JPI_LOGINTIM,16%206)
define(JPI_OWNER,16%303)
define(JPI_PAGEFLTS,16%40A)
define(JPI_PID,16%319)
define(JPI_PRCLM,16%408)
define(JPI_PRCNAM,16%31C)
define(JPI_PRIB,16%309)
define(JPI_STATE,16%306)
define(JPI_UIC,16%304)
define(JPI_USERNAME,16%202)

# VMS system service return codes

define(SS_BUFFEROVF,16%601)
define(SS_CONTROLO,16%609)
define(SS_NORMAL,1)
define(SS_NOTRAN,16%629)
define(SS_SUPERCEDE,16%631)
define(SS_TIMEOUT,16%22C)

#
#	definitions to hide entry points
#
define(lookup,pr_lookup)
define(instal,pr_instal)
#-h- amove            994  asc  25-mar-82 08:56:56  v1.1 (sw-tools v1.1)
### AMove	Move (or rename) `file1' to `file2'.

integer    function amove( name1, name2)

character  name1(FILENAMESIZE), name2(FILENAMESIZE)
character  temp1(FILENAMESIZE), temp2(FILENAMESIZE)
integer    status, junk
integer    index, rename, remove # function(s)
filedes    old, new
filedes    create, open # function(s)

include    io

if( index( name1, '/') > 0 | index( name1, '\') > 0 )
  call mklocl( name1, temp1)
else
  call strcpy( name1, temp1)

if( index( name2, '/') > 0 | index( name2, '\') > 0 )
  call mklocl( name2, temp2)
else
  call strcpy( name2, temp2)

call upper(temp1)
call upper(temp2)

new = open( temp2, READ)
if( new != ERR )
{
  call close(new)
  junk = remove(temp2)
}

if( rename( temp1, temp2) == ERR )
{
  old = open( temp1, READ)
  if( old == ERR )
    return(ERR)

  new = create( temp2, WRITE)
  if( new == ERR )
  {
    call close(old)
    return(ERR)
  }
  call fcopy( old, new)
  call close(old)
  call close(new)
  junk = remove(temp1)
}

return(OK)
end
#-h- appred           351  asc  25-mar-82 08:56:59  v1.1 (sw-tools v1.1)
### AppRed	Process APPEND redirection for `spawn'.

subroutine appred( fd, c, file, buf)

filedes    fd
integer    i
integer    length # function(s)
character  buf(ARGBUFSIZE), c, file(FILENAMESIZE)

i = length(buf) + 1
call chcopy( ' ', buf, i)
call chcopy( c, buf, i)
call chcopy( c, buf, i)
call stcopy( file, 1, buf, i)
call close(fd)

return
end
#-h- appstr           210  asc  25-mar-82 08:57:00  v1.1 (sw-tools v1.1)
### AppStr	Append `str1' to `str2'.

subroutine appstr( str1, str2)

character  str1(ARB), str2(ARB)
integer    i
integer    length # function(s)

i = length(str2) + 1
call scopy( str1, 1, str2, i)

return
end
#-h- arggen           436  asc  25-mar-82 08:57:01  v1.1 (sw-tools v1.1)
### ArgGen	Generate name of arg mailbox for process `pname' into `bname'.

subroutine arggen( pname, bname)

character  pname(ARB), bname(ARB)
integer    i, j

string argstr "arg"

j = 1
call stcopy( argstr, 1, bname, j)
for( i = 1 ; pname(i) != EOS ; i = i + 1 )
{
  if( pname(i) == '&' )
    call chcopy( '_', bname, j)
  else if( pname(i) != '.' )
     call chcopy( pname(i), bname, j)
}
bname(j) = EOS
call upper(bname)

return
end
#-h- assign           330  asc  28-may-82 15:40:54  tools (lblh csam sventek)
### Assign	Associate file name with specific internal specifier.
integer    function assign( nam, fd, access)

character  nam(ARB)
filedes    fd
filedes    cre8at # function(s)
integer    access

include    io

assign = ERR
if( 0 < fd & fd <= NNFILES )
{
  call close(fd)
  assign = cre8at( nam, access, fd, UNKAGE)
}

return
end
#-h- auxfmt          3029  asc  25-mar-82 08:57:06  v1.1 (sw-tools v1.1)
### AuxFmt	Format `auxilliary' file information into `date'.

subroutine auxfmt( qdate, nam, fmt, grp, mem, prot, eof, free, typ, aux, date)

integer    qdate(2), grp, mem, prot, eof, free, typ
integer    auxndx, cnt, i, j, n, ondx, dsc(2), timlen
integer    ctoi, index, indexs, itoc, length # function(s)
character  aux(ARB), c, date(ARB), fmt(ARB), nam(ARB), temp(FILENAMESIZE)

string ascstr "asc"
string binstr "bin"
string dirstr "dir"
string objstr ".obj"

ondx = 1
call fold(fmt)
for( auxndx = 1 ; fmt(auxndx) != EOS ; auxndx = auxndx + 1 )
{
  while( fmt(auxndx) == ' ' | fmt(auxndx) == '@t' )
  {
    call chcopy( fmt(auxndx), aux, ondx)
    auxndx = auxndx + 1
  }
  cnt = ctoi( fmt, auxndx)
  if( cnt == 0 )
    cnt = 1
  c = fmt(auxndx)

  if( c == 'n' )			# File name.
  {
    call stcopy( nam, 1, aux, ondx)
    for( cnt = cnt - length(nam) ; cnt > 0 ; cnt = cnt - 1 )
      call chcopy( ' ', aux, ondx)
  }
  else if( c == 'c' )			# File size in characters.
  {
    j = 512 * eof + ( free - 512 )
    n = itoc( j, temp, cnt )
    for( j = cnt ; j > n ; j = j - 1 )
      call chcopy( ' ', aux, ondx)
    call stcopy( temp, 1, aux, ondx)
  }
  else if( c == 'b' )			# File size in blocks.
  {
    j = eof
    if( free > 0 )
      j = j + 1
    n = itoc( j, temp, cnt )
    for( j = cnt ; j > n ; j = j - 1 )
      call chcopy( ' ', aux, ondx)
    call stcopy( temp, 1, aux, ondx)
  }
  else if( c == 't' )			# File type (asc|bin|dir).
  {
    call strcpy( binstr, temp)
    if( typ == ASCII )
      if( indexs( nam, objstr) == 0 )
      {
        if( index( nam, '/') == length(nam) )
          call strcpy( dirstr, temp)
        else
          call strcpy( ascstr, temp)
      }
    call stcopy( temp, 1, aux, ondx)
  }
  else if( c == 'm' )			# Modification date & time.
  {
    dsc(1) = 24
    dsc(2) = %loc(temp)
    call sys$asctim( timlen, dsc, qdate, %val(0) ) # dd-mmm-yy hh:mm:ss:ff.
    j = index( temp, '.')
    temp(j) = EOS	# Strip fractions of seconds.
    call stcopy( temp, 1, aux, ondx)
  }
  else if( c == 'p' )			# Protection codes.
  {
    j = 1
    for( i = 1 ; i <= 16 ; i = i + 1 )
    {
      if( mod( prot, 2) == 1 )
        temp(j) = '-'
      else if( mod( i, 4) == 1 )
        temp(j) = 'r'
      else if( mod( i, 4) == 2 )
        temp(j) = 'w'
      else if( mod( i, 4) == 3 )
        temp(j) = 'e'
      else
        temp(j) = 'd'
    
      if( mod( i, 4) == 0 & i < 16 )
      {
        j = j + 1
        temp(j) = '|'
      }
      prot = prot / 2
      j = j + 1
    }
    temp(j) = EOS
    call stcopy( temp, 6, aux, ondx)	# Skip SYSTEM protection codes.
  }
  else if( c == 'o' )			# File owner's username.
  {
    call fmtuic( grp, mem, temp)
    call resuic( temp, date)
    call stcopy( date, 1, aux, ondx)
    for( cnt = cnt - length(date) ; cnt > 0 ; cnt = cnt - 1 )
      call chcopy( ' ', aux, ondx)
  }
  else					# Not a field specifier;
   call chcopy( c, aux, ondx)		#  just copy into output.
}
aux(ondx) = EOS
call fold(aux)
call srttim( qdate, date)
  
return
end
#-h- brdcst           498  asc  25-mar-82 08:57:09  v1.1 (sw-tools v1.1)
### BrdCst	Broadcast a message to one or all terminals.

integer		function brdcst( msg, dev)

character	dev(ARB), msg(ARB)
integer		msgdsc(2), devdsc(2)
integer		equal, sys$brdcst # function(s)
string		all "ALL"

if( dev(1) == EOS )
  return(ERR)

call dscbld( msgdsc, msg)
call upper(dev)
call dscbld( devdsc, dev)
if( equal( all, dev) == YES )
{
  if( sys$brdcst( msgdsc, ) != SS_NORMAL )
   return(ERR)
}
else
{
  if( sys$brdcst( msgdsc, devdsc) != SS_NORMAL )
    return(ERR)
}

return(OK)
end
#-h- closdr           240  asc  25-mar-82 08:57:11  v1.1 (sw-tools v1.1)
### ClosDr	Close directory file open on `desc'.
subroutine closdr(desc)

integer    desc

include    cdirec

if( 1 <= desc & desc <= NDIRECTS )
  andif( dfab(desc) != 0 )
  {
    call dclose( dfab(desc) )
    dfab(desc) = 0
  }

return
end
#-h- close            436  asc  09-aug-82 07:46:26  tools (lblh csam sventek)
### Close	Close file open on `fd'.

subroutine close(fd)

filedes    fd

include    io

if( 1 <= fd & fd <= NNFILES ) # Do NOTHING on bad fd.
{
  if( lfn(fd) == NODEVICE )
    return
  if( lastc(fd) > 0 & mode(fd) == OUTPUTMODE )
    call putch( '@n', fd) # flush last line if output
  call closef( fdb(fd) )
  if (rawchn(fd) != NODEVICE)
    call sys$dassgn(%val(rawchn(fd)))
  rawchn(fd) = NODEVICE
  lfn(fd) = NODEVICE
}

return
end
#-h- cmatch           245  asc  25-mar-82 08:57:14  v1.1 (sw-tools v1.1)
### CMatch	Return `c' if `c' is in `array', else return(EOS).

character  function cmatch(c, array)

character  c, array(ARB)
integer    i

for( i = 1 ; array(i) != EOS ; i = i + 1 )
  if( c == array(i) )
    break
cmatch = array(i)

return
end
#-h- copyit           274  asc  25-mar-82 08:57:15  v1.1 (sw-tools v1.1)
### CopyIt	Copy in(start) -> in(stop) into out with EOS terminator.
subroutine copyit( in, start, stop, out)

character  in(ARB), out(ARB)
integer    i, j, start, stop

j = 1
for( i = start ; i <= stop ; i = i + 1 )
{
  out(j) = in(i)
  j = j + 1
}
out(j) = EOS

return
end
#-h- cputim           299  asc  25-mar-82 08:57:16  v1.1 (sw-tools v1.1)
### CpuTim	Return the CPU time used since `start'.

integer    function cputim(start)

integer    start, cpubuf, cpu
integer*2  jpibuf(8)

equivalence( cpubuf, jpibuf(3) )

data jpibuf / 4, JPI_CPUTIM, 6*0 / 

cpubuf = %loc(cpu)
call sys$getjpi( , , , jpibuf, , , )
cputim = cpu - start

return
end
#-h- cre8at          1383  asc  28-may-82 15:40:56  tools (lblh csam sventek)
### Cre8At	Create file `fil' attached to `fd' with access mode `access'.

filedes    function cre8at( fil, access, fd, age)

character  buf(FILENAMESIZE), fil(ARB)
filedes    fd
filedes    opena, openn, openp, openr, opens, openw # function(s)
integer    access, cctype, devtyp, status, age
integer    index # function(s)

include    io

if( index( fil, '/') > 0 | index( fil, '\') > 0 )
  call mklocl( fil, buf)
else
  call strcpy( fil, buf)
call upper(buf) # convert file name to upper case

if( access == READ )
  status = openr( buf, fd, access)
else if( access == WRITE | access == READWRITE  | access == BINARY_WRITE )
  status = openw( buf, fd, access, age) # BINARY support; dpm 7-Sep-81
else if( access == APPEND )
  status = opena( buf, fd, access, age)
else if( access == NEWREAD )
  status = openn( buf, fd, access)
else if( access == SCRATCH )
  status = opens( buf, fd, access)
else if( access == PRINT )
  status = openp( buf, fd, access)
else
  status = ERR

if( status == ERR )
  cre8at = ERR
else
{
  call strcpy( buf, filenm( 1, fd) ) # variables
  filacc(fd) = access
  cre8at = fd
  if( status != CHARAC ) # set file type
    fltype(fd) = BINARY
  else
    fltype(fd) = ASCII
  rawchn(fd) = NODEVICE # (dpm 8-Jun-81)
  lfn(fd) = devtyp( fdb(fd) )
  chtype(fd) = COOKED # IO is cooked by default.
  imp_ctrl(fd) = cctype( fdb(fd)) # (dpm 16-Jul-81)
}

return
end
#-h- create           409  asc  28-may-82 15:40:57  tools (lblh csam sventek)
### Create	Associate file `fil' with internal descriptor at mode `access'.

filedes    function create( fil, access)

character  fil(ARB)
filedes    fd
filedes    cre8at, nxtlun # function(s)
integer    access, newacc

include    io

if( nxtlun(fd) == ERR )
  create = ERR
else
{
  if( access == READ )
    newacc = NEWREAD
  else
    newacc = access
  create = cre8at( fil, newacc, fd, UNKAGE)
}

return
end
#-h- crembx          1046  asc  25-mar-82 08:57:22  v1.1 (sw-tools v1.1)
### CreMbx	Create a (VMS) mailbox.
integer    function crembx(buf, uniqit, descr, unit)

character  buf(ARB), unqbuf(20), name(64)
integer*4  descr, status, sys$crembx, init, i, length, sys$getchn, uniqit
integer    lognm(2)
integer*2  unit, chunit
equivalence( chunit, name(13) )

data init / 0 / 

if( init == 0 )
{
  call unique(unqbuf)
  init = 1
}
i = 1
call stcopy( buf, 1, name, i)
if( uniqit == YES )
  call stcopy( unqbuf, 1, name, i)
name(i) = EOS
call upper(name)
call dscbld( lognm, name)
status = sys$crembx(	,			# Temporary mailbox
			descr,			# Receives channel #
			%val(ARGBUFSIZE),	# Max message size
			%val(ARGBUFSIZE),	# Max pool usage
			%val(0),		# No protection
			,			# Maximize access
			lognm)			# Logical name string
if( status != SS_NORMAL & status != SS_SUPERCEDE )
  crembx = ERR
else
{
  call scopy( name, 1, buf, 1)
  lognm(1) = 64
  status = sys$getchn( %val(descr), , lognm, , )
  if( status != SS_NORMAL & status != SS_BUFFEROVF )
    crembx = ERR
  else
  {
    unit = chunit
    crembx = OK
  }
}
return
end
#-h- ctoptr           197  asc  25-mar-82 08:57:24  v1.1 (sw-tools v1.1)
### CToPtr	Convert character string to pointer.
subroutine ctoptr( buf, i, ptr)

character  buf(ARB)
integer    i, ptr(2)
integer    ctoi

ptr(1) = ctoi( buf, i)
ptr(2) = ctoi( buf, i)

return
end
#-h- cvtdtop         1263  asc  25-mar-82 08:57:26  v1.1 (sw-tools v1.1)
### CvtDToP	Convert DEC filespec to pathname.
#
# correspondences
#
# string::	->	/@string
# string:	->	/string
# [string...]	->	/string[/...]
# [.string...]	->	string[/...]
# string	->	string
#
# in addition, if the user types [a.b.c]xyz with no device name, the
# current default device will be inserted
#
subroutine cvt_dtop( in, out)

character  in(FILENAMESIZE), out(FILENAMESIZE), host(FILENAMESIZE)
character  device(FILENAMESIZE), direct(FILENAMESIZE), file(FILENAMESIZE)
character  temp(FILENAMESIZE)
integer    i

string     slat "/@@"

call scopy( in, 1, out, 1)
call upper(out)
call explog( out, temp)
call parsef( temp, host, device, direct, file)
i = 1
if( host(1) != EOS )
{
  call stcopy(  slat, 1, out, i)
  call stcopy( host, 1, out, i)
}
if( device(1) != EOS )
{
  call chcopy( '/', out, i)
  call stcopy( device, 1, out, i)
}
if( direct(1) != EOS )
{
  if( direct(2) == '.' ) # permit [.x]
    call dirout( direct, out, i)
  else
  {
    if( device(1) == EOS )
    {
      call chcopy( '/', out, i)
      call gtddev(device)
      call stcopy( device, 1, out, i)
    }
    call dirout( direct, out, i)
  }
}
if (i > 1)
  call chcopy('/', out, i)
if( file(1) != EOS )
{
  call stcopy( file, 1, out, i)
}
out(i) = EOS
call fold(out)

return
end
#-h- cwdir            333  asc  25-mar-82 08:57:29  v1.1 (sw-tools v1.1)
### CWDir	Change working directory to `dir'.

integer    function cwdir(dir)

character  dir(FILENAMESIZE), path(FILENAMESIZE)
integer    desc
integer    opendr # function(s)

call mkpath( dir, path)
if( opendr( path, desc) != ERR ) # directory exists
{
  call closdr(desc)
  call stdpth(path)
  return(OK)
}
else
  return(ERR)

end
#-h- dclout           680  asc  22-dec-82 11:37:39  tools (lblh csam sventek)
integer    function dclout(lin, start, stop, args)

character  lin(ARB), args(ARB), qchar
integer    i, j, start, stop, junk
integer    getwrd

for( i = 1 ; lin(i) != '@n' & lin(i) != EOS ; i = i + 1 )
{
  if( lin(i) == ' ' )
  {
    call skipbl( lin, i)
    if( lin(i) == '>' )
    {
      start = i - 1
      for(  ; lin(i) == '>' ; i = i + 1 )
         ;
      junk = getwrd( lin, i, args)
      stop = i
      return(YES)
    }
    i = i - 1
  }
  else if( lin(i) == '@'' | lin(i) == '"' )
  {
    qchar = lin(i)
    
    repeat
      i = i + 1
    until( lin(i) == qchar | lin(i) == '@n' | lin(i) == EOS )
    
    if( lin(i) != qchar )
      i = i - 1
  }
}

return(NO)
end
#-h- defdir           264  asc  25-mar-82 08:57:33  v1.1 (sw-tools v1.1)
### DefDir	Return the DEC form of the current working directory [...]
subroutine defdir(direct)

integer    dsc(2)
character  direct(ARB)

dsc(1) = 64
dsc(2) = %loc(direct)
call sys$setddir( , dsc, dsc(1) )
direct( dsc(1) + 1 ) = EOS
call fold(direct)

return
end
#-h- delarg           306  asc  25-mar-82 08:57:34  v1.1 (sw-tools v1.1)
### DelArg	Delete reference to command line argument `n'.
# See comments in GetArg for how the arguments are stored.

subroutine delarg(n)
integer    i, n
include    carg

if( 0 <= n & n < nbrarg )
{
  for( i = n + 1 ; i < nbrarg ; i = i + 1 )
    ptr(i) = ptr( i + 1 )
  nbrarg = nbrarg - 1
}

return
end
#-h- dirfil          1395  asc  25-mar-82 08:57:35  v1.1 (sw-tools v1.1)
### DirFil	Generate directory filespec from pathname
subroutine dirfil( dpath, file, direc)

character  dpath(ARB), file(ARB), node(FILENAMESIZE)
character  device(FILENAMESIZE), temp(FILENAMESIZE), dnode(FILENAMESIZE)
character  direc(ARB), direct(FILENAMESIZE)
integer    i, junk, gtftok, depth, ptr(10), j, k, equal

string rootdr "[000000]" # (dpm 10-Jun-81)

i = 2
junk = gtftok( dpath, i, node)
if( node(1) == '@@' )
{
  call scopy( node, 2, node, 1)
  junk = gtftok( dpath, i, device)
  j = 3
}
else
{
  call strcpy( node, device)
  node(1) = EOS
  j = 2
}
call exppth( dpath, depth, ptr, temp)
if( depth == j )
  call strcpy( rootdr, direct)
else
{
  direct(1) = '['
  k = 2
  for(  ; j < depth ; j = j + 1 )
  {
    junk = gtftok( dpath, i, temp)
    call stcopy( temp, 1, direct, k)
    direct(k) = '.'
    k = k + 1
  }
  direct( k - 1 ) = ']'
  direct(k) = EOS
}
junk = gtftok( dpath, i, temp)
j = length(temp) + 1
call scopy(  ".dir", 1, temp, j)
call hostnm(dnode)
if( equal( dnode, node) == YES )
  node(1) = EOS
call fgenr8( node, device, direct, temp, file)
call upper(file)
if( equal( direct, rootdr) == YES )
  j = 2
else
{
  j = index( direct, ']')
  direct(j) = '.'
  j = j + 1
}
for( k = 1 ; temp(k) != '.' ; k = k + 1 )
{
  direct(j) = temp(k)
  j = j + 1
}
direct(j) = ']'
direct( j + 1 ) = EOS
call fgenr8( node, device, direct, EOS, direc)
call upper(direc)
return
end
#-h- dirout           573  asc  25-mar-82 08:57:37  v1.1 (sw-tools v1.1)
### DirOut	Convert DEC directory string to path format, incrementing i.
subroutine dirout( direct, out, i)

character  direct(ARB), out(ARB)
integer    i, j

if( direct(1) != '[' )
  return
if( direct(2) == '.' )
  j = 3
else
{
  call chcopy( '/', out, i)
  j = 2
}
while( direct(j) != ']' )
{
  if( direct(j) == '.' )
  {
    call chcopy( '/', out, i)
    j = j + 1
  }
  for(  ; direct(j) != '.' & direct(j) != ']' ; j = j + 1 )
  {
    if( direct(j) == EOS )
    {
      out(i) = EOS
      return
    }
    call chcopy( direct(j), out, i)
  }
}
out(i) = EOS

return
end
#-h- dscbld           198  asc  25-mar-82 08:57:38  v1.1 (sw-tools v1.1)
### DscBld	Build a VAX descriptor for `string' in `dsc'.
subroutine dscbld( dsc, string)

integer    dsc(2), length
character  string(ARB)

dsc(1) = length(string)
dsc(2) = %loc(string)

return
end
#-h- enbint           704  asc  21-dec-82 15:42:15  tools (lblh csam sventek)
### EnbInt	Enable ^C interrupts for process.
subroutine enbint

character  buf(FILENAMESIZE)
integer    chan, init, intok, mypid, ownid
integer    isatty, rtopen, sys$qiow # function(s)
external   intsrv

data init / YES / 

if( init == YES )
{
  call getpid(mypid)
  call getown( mypid, ownid)
  init = NO
  if( isatty(STDIN) == YES & ownid == 0 )
    intok = YES
  else
    intok = NO
  if( intok == YES )
  {
    if( rtopen(  "TT", chan) == ERR )
    {
      intok = NO
      call remark(  "Cannot assign channel for interrupts" )
    }
  }
}
if( intok == YES )
{
  if( .not.sys$qiow( , %val(chan), %val( IO_CTRLCAST ),,,, intsrv,,,,, ) )
    call error(  "Cannot enable ^C interrupt" )
}

return
end
#-h- endst            326  asc  25-mar-82 08:57:41  v1.1 (sw-tools v1.1)
### EndST	Close all files and exit with `status'.

subroutine endst(status)

filedes    fd
integer    status, exit_stat
include    io

for( fd = 1 ; fd <= NNFILES ; fd = fd + 1 )
  call close(fd)

if( status == OK )
  exit_stat = 1
else
  exit_stat = CHILD_ABORTED

call sys$exit( %val( exit_stat ) ) # Exit with status.

end
#-h- exetim           604  asc  25-mar-82 08:57:43  v1.1 (sw-tools v1.1)
### ExeTim	Return execution time accumulated since `start'.
integer    function exetim(start)

integer    start, time, login(2), logbuf, init
integer*2  timb(7), jpibuf(8), logtim(7)

equivalence( logbuf, jpibuf(3) )

data jpibuf / 8, JPI_LOGINTIM, 6*0 / 
data init / YES / 

if( init == YES )
{
  logbuf = %loc(login)
  call sys$getjpi( , , , jpibuf, , , )
  call sys$numtim( logtim, login)
  init = NO
}
call sys$numtim( timb, )
time = timb(4) - logtim(4)
time = 60 * time + timb(5) - logtim(5)
time = 60 * time + timb(6) - logtim(6)
time = 100 * time + timb(7) - logtim(7)
return( time - start )

end
#-h- exith            293  asc  25-mar-82 08:57:45  v1.1 (sw-tools v1.1)
### ExitH	VAX/VMS exit handler to clean up BYTLM for mailboxes.
#  This may not be necessary in future releases of VMS.

subroutine exith

include    ctrmbx
include    cexith

call sys$dassgn( %val(termbx) )	# Deassign channel to termination
				# mail-box to release bytlm quota.

return
end
#-h- explog           626  asc  25-mar-82 08:57:47  v1.1 (sw-tools v1.1)
### ExpLog	Iteratively resolve all logical names in file spec.
subroutine explog( in, out)

character  in(ARB), out(ARB)
character  node(FILENAMESIZE), device(FILENAMESIZE), direct(FILENAMESIZE)
character  file(FILENAMESIZE), temp(FILENAMESIZE), nnode(FILENAMESIZE)
character  ndev(FILENAMESIZE)

integer    trans, tran1

call strcpy( in, temp)
repeat
{
  trans = NO
  call parsef( temp, node, device, direct, file)
  if( tran1( node, nnode) == YES )
    trans = YES
  if( tran1( device, ndev) == YES )
    trans = YES
  call fgenr8( nnode, ndev, direct, file, temp)
}
until( trans == NO )
call strcpy( temp, out)

return
end
#-h- exppid           168  asc  25-mar-82 08:57:49  v1.1 (sw-tools v1.1)
### ExpPid	You figure it out.
subroutine exppid( in, out)

character  in(PIDSIZE), out(PIDSIZE)
integer    pid, htoi

pid = htoi(in)
call puthex( pid, out)

return
end
#-h- fgenr8           677  asc  25-mar-82 08:57:50  v1.1 (sw-tools v1.1)
### FGenr8	Generate DEC file spec given node, device, dir, and file string.

subroutine fgenr8( node, device, direct, file, out)

character  node(ARB), device(ARB), direct(ARB), file(ARB), out(ARB)
integer    i
integer    index, indexs

string rbrlbr "]["

i = 1
if( node(1) != EOS )
{
  call stcopy( node, 1, out, i)
  call stcopy(  "::", 1, out, i)
}
if( device(1) != EOS )
{
  call stcopy( device, 1, out, i)
  if( index( device, ':') == 0 )
    call chcopy( ':', out, i)
}
call stcopy( direct, 1, out, i)
call scopy( file, 1, out, i)
i = indexs(out, rbrlbr)			# see if ][ in string
if (i > 0)				# yes, have v3 goody
  call scopy(out, i+2, out, i)		# remove it

return
end
#-h- filnfo           327  asc  25-mar-82 08:57:52  v1.1 (sw-tools v1.1)
### FilNfo	Get name and access mode of file open on fd.
integer    function filnfo( fd, name, access)

integer    fd, access
character  name(ARB)

include    io

if( 1 <= fd & fd <= NNFILES )
  andif( lfn(fd) != NODEVICE )
  {
    call strcpy( filenm( 1, fd), name)
    access = filacc(fd)
    return(OK)
  }

return(ERR)

end
#-h- flfind           390  asc  25-mar-82 08:57:54  v1.1 (sw-tools v1.1)
### FlFind	Find file and retrieve its LOCAL filename and type.

integer    function flfind( infil, outfil, type)

character  infil(FILENAMESIZE), outfil(FILENAMESIZE)
filedes    fd
integer    type
integer    open, gettyp # function(s)

fd = open( infil, READ)
if( fd != ERR )
{
  type = gettyp( fd, type)
  call close(fd)
  call mklocl( infil, outfil)
  call fold(outfil)
}
return(fd)

end
#-h- fmttim           994  asc  25-mar-82 08:57:56  v1.1 (sw-tools v1.1)
### FmtTim	Format time into `buf'.

integer    function fmttim( string, intime, buf)

integer    time(4), n, itoc, j, k, intime
character  buf(ARB), string(ARB), temp(5)

time(3) = intime / 100
time(4) = intime - 100 * time(3)
time(2) = time(3) / 60
time(3) = time(3) - 60 * time(2)
time(1) = time(2) / 60
time(2) = time(2) - 60 * time(1)
j = 1
call stcopy( string, 1, buf, j)
n = 4 - itoc( time(1), temp, 5)
for( k = 1 ; k <= n ; k = k + 1 )
{
  buf(j) = ' '
  j = j + 1
}
call stcopy( temp, 1, buf, j)
buf(j) = ':'
j = j + 1
n = 2 - itoc( time(2), temp, 3)
for( k = 1 ; k <= n ; k = k + 1 )
{
  buf(j) = '0'
  j = j + 1
}
call stcopy( temp, 1, buf, j)
buf(j) = ':'
j = j + 1
n = 2 - itoc( time(3), temp, 3)
for( k = 1 ; k <= n ; k = k + 1 )
{
  buf(j) = '0'
  j = j + 1
}
call stcopy( temp, 1, buf, j)
buf(j) = '.'
j = j + 1
n = 2 - itoc( time(4), temp, 3)
for( k = 1 ; k <= n ; k = k + 1 )
{
  buf(j) = '0'
  j = j + 1
}
call stcopy( temp, 1, buf, j)
buf(j) = EOS
fmttim = j - 1

return
end
#-h- fmtuic           345  asc  25-mar-82 08:57:58  v1.1 (sw-tools v1.1)
### FmtUIC	Format UIC of `grp', `mem' into `uic' as `[ggg,mmm]'.

subroutine fmtuic( grp, mem, uic)

integer*2  grp, mem
integer    ctstr(2), outdsc(2)
character  uic(ARB)

string cstrng "[!OB,!OB]"

call dscbld( ctstr, cstrng)
outdsc(1) = 10
outdsc(2) = %loc(uic)
call sys$fao( ctstr, , outdsc, %val(grp), %val(mem) )
uic(10) = EOS

return
end
#-h- gdraux          1200  asc  30-jul-83 18:01:22  tools (lblh csam sventek)
### GDrAux	Get `auxilliary' (system-dependent) info about file.

subroutine gdraux( desc, file, aux, date, fmt)

integer    desc, qdate(2), grp, mem, prot, eof, free, i, ftype
integer    decnfo, index, length # function(s)
character  file(ARB), aux(ARB), date(ARB), fmt(ARB), temp(FILENAMESIZE)

include    cdirec

string cantrd "? Can't read information for file ``"
string qqdot "''"
string dot1 ".1"
string dotdot1 "..1"
string dotdir ".dir"

i = 1		# Build error message string
call stcopy( cantrd, 1, aux, i)
call stcopy( file, 1, aux, i)
call scopy( qqdot, 1, aux, i)

for( i = 1 ; i <= TCOLWIDTH ; i = i + 1 )
  date(i) = ' '
date(i) = EOS
if( desc < 1 | desc > NDIRECTS )
  return
if( dfab(desc) == 0 )
  return
call concat( dnam( 1, desc), file, temp)
i = index( file, '.') + 1
if( i == 1 )
{
  i = index( file, '/')
  if( i == 0 )
    call concat( temp, dotdot1, temp)
  else
  {
    i = length(temp)
    temp(i) = EOS
    call concat( temp, dotdir, temp)
  }
}
else if( index( file(i), '.') == 0 )
  call concat( temp, dot1, temp)
if( decnfo( temp, qdate, grp, mem, prot, eof, free, ftype) != ERR )
  call auxfmt( qdate, file, fmt, grp, mem, prot, eof, free, ftype, aux, date)

return
end
#-h- gdrprm          1261  asc  25-mar-82 08:58:01  v1.1 (sw-tools v1.1)
### GDrPrm	Get `primary' info (filename) of next entry in directory.

integer    function gdrprm( desc, file)

character  file(FILENAMESIZE), temp(4)
integer    i, desc, j, k
integer    index, dfind, equal

string dir "dir"

include    cdirec

repeat
{
  if( desc < 1 | desc > NDIRECTS )
    gdrprm = EOF
  else if( dfab(desc) == 0 )
    gdrprm = EOF
  else if( dfind( dfab(desc), file) == EOF )
    gdrprm = EOF
  else
  {
    i = index( file, ']') + 1
    if( i == 1 )
      i = index( file, ':') + 1
    call scopy( file, i, file, 1)
    call fold(file)
    if( equal( file, lfile( 1, desc) ) == YES )
      return(EOF) # seen this file on magtape before
    call scopy( file, 1, lfile( 1, desc), 1) # update last file seen
    i = index( file, ';')
    file(i) = '.'
    i = length(file)
    if( file(i) == '1' & file( i - 1 ) == '.' )
      file( i - 1 ) = EOS
    k = index( file, '.')
    i = k + 1
    for( j = 1 ; j < 4 ; j = j + 1 )
    {
      temp(j) = file(i)
      i = i + 1
    }
    temp(j) = EOS
    if( equal( temp, dir) == YES )
      call chcopy( '/', file, k)
    else if( temp(1) == EOS )
      file(k) = EOS
    if( equal( file,  "000000/" ) == YES )
      gdrprm = ERR
    else
      gdrprm = OK
  }
}
until( gdrprm != ERR )

return
end
#-h- gendir           852  asc  25-mar-82 08:58:04  v1.1 (sw-tools v1.1)
### GenDir	Generate DEC directory spec from full pathname.

subroutine gendir( path, out)

integer    i, junk, j, k
integer    gtftok # function(s)
character  path(ARB), out(ARB), node(FILENAMESIZE), device(FILENAMESIZE)
character  direct(FILENAMESIZE), temp(FILENAMESIZE)

string null ""
string zz "000000" # (dpm 10-Jun-81)

i = 2
junk = gtftok( path, i, device)
if( device(1) == '@@' )
{
  call scopy( device, 2, node, 1)
  junk = gtftok( path, i, device)
}
else
  node(1) = EOS
j = 1
call chcopy( '[', direct, j)
while( gtftok( path, i, temp) > 0 )
{
  if( j > 2 )
    call chcopy( '.', direct, j)
  if( temp(1) == '%' )	# Don't pass anchor character
    k = 2
  else
    k = 1
  call stcopy( temp, k, direct, j)
}
if( j == 2 )
  call stcopy( zz, 1, direct, j)
call chcopy( ']', direct, j)
call fgenr8( node, device, direct, null, out)

return
end
#-h- genpnm          1117  asc  25-mar-82 08:58:06  v1.1 (sw-tools v1.1)
### GenPNm	Generate subprocess name.

subroutine genpnm( proces, wait, offset)

character  wait, base(20), level(4), c, proces(ARB)
character  type
integer    n, i, j, junk
integer    index, ctoi, itoc, length # function(s)

string l1 ".1"

call getpnm(proces) # get this process's name
if( proces(1) == '$' ) # spawned by a tool?
{
  n = index( proces, '.') # find separator
  if( n > 0 )
  {
    i = n + 1
    j = ctoi( proces, i) + 1
    level(1) = '.'
    junk = itoc( j, level(2), 3)
    proces(n) = EOS
  }
  else
    call strcpy( l1, level)
  call strcpy( proces, base)
}
else
{
  base(1) = '$'
  j = 2
  for( i = 1 ; proces(i) != EOS ; i = i + 1 )
  {
    c = type( proces(i) )
    if( c == LETTER | c == DIGIT )
    {
      base(j) = proces(i)
      j = j + 1
    }
  }
  base(j) = EOS
  n = length(base)
  if( n > 8 ) # must truncate to 8 unique characters
    call scopy( base, n - 6, base, 2)
  call strcpy( l1, level)
}
i = 1
call stcopy( base, 1, proces, i)
if( wait == BACKGR )
{
  call chcopy( '&', proces, i)
  junk = itoc( offset, proces(i), 3)
}
else
  call scopy( level, 1, proces, i)

return
end
#-h- getarg           578  asc  22-dec-82 11:37:42  tools (lblh csam sventek)
### GetArg	Get specified command line argument.
#  arguments 0 -> nbrarg-1 are pointed to by ptr(1) -> ptr(nbrarg)
#  argument 0 is the name by which the utility was invoked

integer    function getarg( n, array, maxsiz)

character  array(ARB)
integer    n, maxsiz

include    carg

if( n >= nbrarg ) # no argument n
{
  array(1) = EOS
  getarg = EOF
  return
}

j = ptr( n + 1 )
if( arg(j) == '@'' | arg(j) == '"' )
  j = j + 1
for( i = 1 ; i <= maxsiz ; i = i + 1 )
{
  array(i) = arg(j)
  if( arg(j) == EOS )
    break
  j = j + 1
}
getarg = i - 1
array(i) = EOS

return
end
#-h- getast           147  asc  25-mar-82 08:58:10  v1.1 (sw-tools v1.1)
### GetAST	Read the value of the AST-received flag.

integer function getast(value)

integer value
include cast

value = gotast
return(gotast)
end
#-h- getbpr           191  asc  25-mar-82 08:58:11  v1.1 (sw-tools v1.1)
### GetBPr	Get base priority of current process.

subroutine getbpr(prio)

integer prio

jpilst(list)

data list/4, JPI_PRIB, 6*0/

lista = %loc(prio)
call sys$getjpi(,,,list,,,)

return
end
#-h- getch            835  asc  25-mar-82 08:58:12  v1.1 (sw-tools v1.1)
### GetCh	Get characters from file open on `fd'.
character  function getch(c, fd)

include    io

character  c
character  rgetch # function(s)
filedes    fd
integer    n, count
integer    gets, inmap # function(s)

chstat(fd) = OK # (dpm 8-Jun-81)
if( chtype(fd) != COOKED )
{
  getch = rgetch( c, fd) # changed channel argument (dpm 8-Jun-81)
  return
}
if( mode(fd) != INPUTMODE )
{
  lastc(fd) = 0
  bcount(fd) = 0
  mode(fd) = INPUTMODE
}
if( lastc(fd) >= bcount(fd) | lastc(fd) >= MAXLINE )
{
  count = gets( fdb(fd), buffer( 1, fd), MAXCARD)
  if( count < 0 )
  {
    c = EOF
    chstat(fd) = EOF # (dpm 8-Jun-81)
    return(c)
  }
  if( imp_ctrl(fd) > 0 )
  {
    count = count + 1
    buffer( count, fd) = '@n'
  }
  bcount(fd) = count
  lastc(fd) = 0
}
lastc(fd) = lastc(fd) + 1
n = lastc(fd)
c = buffer( n, fd)
return(c)
end
#-h- getdcl           314  asc  25-mar-82 08:58:14  v1.1 (sw-tools v1.1)
### GetDCL	Get command line from DCL.

integer function getdcl(lin)

character	lin(ARGBUFSIZE)
integer		desc(2), strlen, status
integer		lib$get_foreign

desc(1) = ARGBUFSIZE - 3	# Leave room for "* " and EOS.
desc(2) = %loc(lin)

status = lib$get_foreign( desc, , strlen)

lin(strlen+1) = EOS
return(strlen)

end
#-h- getdir          1145  asc  25-mar-82 08:58:16  v1.1 (sw-tools v1.1)
### GetDir	Get `known' directory name in LOCAL or PATH format.

subroutine getdir( key, type, buf)

integer    junk, key, type
integer    trnlog # function(s)
character  buf(ARB), temp(FILENAMESIZE)

string st_bin "ST_BIN"
string st_usr "ST_USR"
string st_tmp "ST_TMP"
string st_lpr "ST_LPR"
string st_msg "ST_MSG"
string st_src "ST_SRC"
string st_man "ST_MAN"
string st_inc "ST_INC"
string st_lib "ST_LIB"

if( key == BINDIRECTORY )
  junk = trnlog( st_bin, temp)
else if( key == USRDIRECTORY )
  junk = trnlog( st_usr, temp)
else if( key == TMPDIRECTORY )
  junk = trnlog( st_tmp, temp)
else if( key == LPRDIRECTORY )
  junk = trnlog( st_lpr, temp)
else if( key == MSGDIRECTORY )
  junk = trnlog( st_msg, temp)
else if( key == MANDIRECTORY )
  junk = trnlog( st_man, temp)
else if( key == SRCDIRECTORY ) # (dpm 8-Jun-81)
  junk = trnlog( st_src, temp)
else if( key == INCDIRECTORY ) # (dpm 24-Sep-81)
  junk = trnlog( st_inc, temp)
else if( key == LIBDIRECTORY ) # (dpm 24-Sep-81)
  junk = trnlog( st_lib, temp)
else
  temp(1) = EOS
call fold(temp)
if( type == PATH )
{
  call cvt_dtop( temp, buf)
}
else
  call strcpy( temp, buf)

return
end
#-h- getfdb           194  asc  25-mar-82 08:58:18  v1.1 (sw-tools v1.1)
### GetFDB	Get the "file descriptor block" for file descriptor "fd".
integer function getfdb(fd)

filedes fd

include io

if( 1 <= fd & fd <= NNFILES )
  return(fdb(fd))
else
  return(ERR)

end
#-h- getimg           427  asc  25-mar-82 08:58:19  v1.1 (sw-tools v1.1)
### GetImg	Get the image name the current process is executing.
subroutine getimg(image)

character image(ARB), local(FILENAMESIZE)
integer*2 jpibuf(8), length
integer addr, leng

equivalence (addr,jpibuf(3)), (leng, jpibuf(5))

data jpibuf /FILENAMESIZE, JPI_IMAGNAME, 6*0/

addr = %loc(local)
leng = %loc(length)
call sys$getjpi(,,,jpibuf,,,)
local(length+1) = EOS
call fold(local)
call scopy(local, 1, image, 1)

return
end
#-h- getlin          1110  asc  25-mar-82 08:58:21  v1.1 (sw-tools v1.1)
### GetLin	Get line `line' from file open on `fd'.

integer    function getlin(line, fd)

character  line(ARB)
filedes    fd
integer    i
integer    gets # function(s)
character  getch # function(s)

include    io

if( lastc(fd) != 0 & chtype(fd) == COOKED ) # GetCh's done on line.
{
  for( i = 1 ;  ; i = i + 1 )
  {
    if( getch( line(i), fd) == '@n' )
    {
      line( i + 1 ) = EOS
      getlin = i
      return
    }
    if( line(i) == EOF )
    {
      getlin = EOF
      line(i) = EOS
      chstat(fd) = EOF # (dpm 8-Jun-81)
      return
    }
    if( i >= MAXLINE - 1 )
    {
      line( i + 1 ) = EOS
      getlin = i
      return
    }
  }
}
else # get a record directly
{
  if( mode(fd) != INPUTMODE )
    mode(fd) = INPUTMODE
  lastc(fd) = 0
  bcount(fd) = 0
  i = gets( fdb(fd), line, MAXCARD)
  if( i < 0 )
  {
    line(1) = EOS
    getlin = EOF
    chstat(fd) = EOF
  }
  else if( i < MAXCARD )
  {
    if( imp_ctrl(fd) > 0 )
    {
      i = i + 1
      line(i) = '@n'
    }
    line( i + 1 ) = EOS
    getlin = i
  }
  else
  {
    line(MAXLINE) = EOS
    getlin = MAXCARD
  }
}

return
end
#-h- getmsg          1153  asc  25-mar-82 08:58:23  v1.1 (sw-tools v1.1)
### GetMsg	Get the command line from the shell or local CLI.
integer    function getmsg(buf)

filedes    fd
integer    done, i, junk, len
integer    equal, getdcl, getlin, length, open, trnlog # function(s)
character  buf(ARGBUFSIZE), pname(20), bname(20), lin(MAXLINE)

string dummy "* "
string dcltools "DCL_TOOLS"

data done / NO / 

if( done == YES )
{
  call strcpy( dummy, buf)
  return( length(buf) )
}
done = YES
call getpnm(pname) # get our process name
junk = trnlog( dcltools, buf) # see if invoked from DCL
if( pname(1) != '$' | equal( dcltools, buf) == NO )
{
  call getimg(lin)
  i = index(lin, ']') + 1
  call scopy(lin, i, buf, 1)
  i = index(buf, '.')
  call chcopy(' ', buf, i)
  junk = getdcl( buf(i) )
}
else
{
  call arggen( pname, bname) # generate mailbox name
  fd = open( bname, READ) # open for reading
  if( fd == ERR )
    call strcpy( dummy, buf)
  else
  {
#    i = 1
#    repeat
#    {
#      len = getlin( lin, fd)
#      if( ( len + i ) <= ARGBUFSIZE )
#        call stcopy( lin, 1, buf, i)
#    }
#    until( len < MAXCARD )
    i = getlin( buf, fd)
    call close(fd)
    buf(i) = EOS
  }
}
return( length(buf) )

end
#-h- getnow           230  asc  25-mar-82 08:58:24  v1.1 (sw-tools v1.1)
### GetNow	Get the current time (as an array of integer values) into `now'.

subroutine getnow(now)

integer   i, now(7)
integer*2 word(7)

call sys$numtim( word, )
for( i = 1 ; i <= 7 ; i = i + 1 )
  now(i) = word(i)

return
end
#-h- getown           231  asc  25-mar-82 08:58:26  v1.1 (sw-tools v1.1)
### GetOwn	Get the PID of this process' owner.

subroutine getown( mypid, ownid)

integer    mypid, ownid

jpilst(owner)

data owner / 4, JPI_OWNER, 6*0 / 

ownera = %loc(ownid)
call sys$getjpi( , mypid, , owner, , , )

return
end
#-h- getpdb           698  asc  25-mar-82 08:58:27  v1.1 (sw-tools v1.1)
### GetPdb	See if specified PDB exists.

integer    function getpdb( offset, wait)

integer    offset, start, stop, init, mypid, ownpid
character  wait

include    cproc

data init / YES / 

if( init == YES )
{
  call getpid(mypid)
  call getown( mypid, ownpid)
  init = NO
}
if( wait == BACKGR )
{
  start = NFOREGROUND + 1
  if( ownpid == 0 )
    stop = NPROCESSES
  else
    stop = start - 1
}
else
{
  start = 1
  stop = NFOREGROUND
}
call sys$setast( %val(0) ) # disable AST delivery
for( offset = start ;
     offset <= stop & pid( 1, offset) != EOS  ;
     offset = offset + 1 )
   ;
call sys$setast( %val(1) ) # enable AST delivery
if( offset <= stop )
  return(OK)
else
  return(ERR)

end
#-h- getpid           199  asc  25-mar-82 08:58:29  v1.1 (sw-tools v1.1)
### GetPID	Get the PID of the current process.

subroutine getpid(pid)

integer    pid

jpilst(list)

data list / 4, JPI_PID, 6*0 / 

lista = %loc(pid)
call sys$getjpi( , , , list, , , )

return
end
#-h- getpnm           412  asc  25-mar-82 08:58:30  v1.1 (sw-tools v1.1)
### GetPNm	Get the name of the current process.

subroutine getpnm(proces)

character  proces(ARB), local(16)
integer*2  jpibuf(8), length
integer    addr, leng

equivalence( addr, jpibuf(3) ), ( leng, jpibuf(5) )

data jpibuf / 15, JPI_PRCNAM, 6*0 / 

addr = %loc(local)
leng = %loc(length)
call sys$getjpi( , , , jpibuf, , , )
local( length + 1 ) = EOS
call fold(local)
call strcpy( local, proces)

return
end
#-h- getprv           368  asc  03-may-82 21:54:26  tools (lblh csam sventek)
### GetPrv	Get the privileges the current process is authorized to pass on.

subroutine getprv(priv)

integer    priv(2), junk
integer    sys$getjpi

jpilst(list)

data list / 8, JPI_PROCPRIV, 6*0 / 

lista = %loc(priv)
list(2) = JPI_PROCPRIV
if (.not. sys$getjpi( , , , list, , , ))
  {
  list(2) = JPI_AUTHPRIV
  junk = sys$getjpi( , , , list, , , )
  }

return
end
#-h- getrln           404  asc  25-mar-82 08:58:32  v1.1 (sw-tools v1.1)
### GetRLn	Get an unCOOKED line of input into `buf'.

character  function getrln( buf, fd, trmara)

character  buf(ARB), c, trmara(ARB), trmn8r
character  cmatch, getch # function(s)
filedes    fd
integer    i

for( i = 1 ; i < MAXLINE ; i = i + 1 )
{
  c = getch( buf(i), fd)
  trmn8r = cmatch( c, trmara)
  if( trmn8r != EOS )
    break
  else
    call putch( c, fd)
}
buf(i) = EOS
return(trmn8r)

end
#-h- gettyp           183  asc  25-mar-82 08:58:33  v1.1 (sw-tools v1.1)
### GetTyp	Return type (ASCII or BINARY) of file open on `fd'.

integer    function gettyp( fd, type)
filedes    fd
integer    type

include    io

type = fltype(fd)
return(type)
end
#-h- getuic           246  asc  25-mar-82 08:58:34  v1.1 (sw-tools v1.1)
### GetUIC	Get the UIC of the current process.

subroutine getuic(uic)

integer*4  uic, uica
integer*2  jpibuf(8)

equivalence( jpibuf(3), uica)

data jpibuf / 4, JPI_UIC, 6*0 / 

uica = %loc(uic)
call sys$getjpi( , , , jpibuf, , , )

return
end
#-h- gtddev           255  asc  25-mar-82 08:58:36  v1.1 (sw-tools v1.1)
### GtDDev	Get name of default device (without ':').

subroutine gtddev(device)

character  device(ARB), scrat(FILENAMESIZE), temp(FILENAMESIZE)

call explog( "SYS$DISK:", scrat)
call parsef( scrat, temp, device, temp, temp)
call fold(device)

return
end
#-h- gtdflt           641  asc  25-mar-82 08:58:38  v1.1 (sw-tools v1.1)
### GtDflt	Get default node, device and directory in LOCAL format.
#  The node and device will not have colons appended, while the
#  directory will be of the form `[a{.a}...]'.

subroutine gtdflt( node, device, direct)

character  node(ARB), device(ARB), direct(ARB), temp(FILENAMESIZE)
integer i
integer index

call defdir(direct)
call explog( "SYS$DISK:", temp)
i = index(temp, ']')
if (i > 0)			# have a v3 goody
  call scopy(direct, 2, temp, i)
else
  call concat(temp, direct, temp)
call parsef( temp, node, device, direct, temp)
if( node(1) == EOS )
  call hostnm(node)
call fold(node)
call fold(device)
call fold(direct)

return
end
#-h- gtdpth           550  asc  25-mar-82 08:58:40  v1.1 (sw-tools v1.1)
### GtDPth	Get the current working directory name in PATH format.

subroutine gtdpth(dir)

character  device(FILENAMESIZE), direct(FILENAMESIZE)
character  host(FILENAMESIZE), dir(ARB)
integer    i, j

call gtdflt( host, device, direct)
dir(1) = '/'
dir(2) = '@@'
j = 3
call stcopy( host, 1, dir, j)
dir(j) = '/'
j = j + 1
call stcopy( device, 1, dir, j)
for( i = 1 ; direct(i) != ']' & direct(i) != EOS ; i = i + 1 )
{
  if( direct(i) == '[' | direct(i) == '.' )
    dir(j) = '/'
  else
    dir(j) = direct(i)
  j = j + 1
}
dir(j) = EOS

return
end
#-h- gtmode           231  asc  25-mar-82 08:58:41  v1.1 (sw-tools v1.1)
### GtMode	Return the I/O mode {COOKED|RARE|RAW} of filedes "fd".
integer    function gtmode(fd)

filedes    fd
include    io

if( 1 <= fd & fd <= NNFILES )
  andif( lfn(fd) != NODEVICE )
    return( chtype(fd) )

return(ERR)

end
#-h- gtstat           177  asc  25-mar-82 08:58:43  v1.1 (sw-tools v1.1)
### GtStat	Return status on io channel `fd'.

integer function gtstat( fd)

include io

filedes fd

if( 1 <= fd & fd <= NNFILES )
  return( chstat( fd))
else
  return(ERR)

end
#-h- gtzone           351  asc  02-apr-82 13:34:22  v1.1 (sw-tools v1.1)
subroutine gtzone(buf)

character buf(ARB), temp(FILENAMESIZE)
integer equal, dstime
integer now(7)

string seed "ST_TIMEZONE"

call trnlog(seed, temp)
if (equal(seed, temp) == YES)
  buf(1) = 'P'
else
  buf(1) = temp(1)
call getnow(now)
if (dstime(now) == YES)
  buf(2) = 'D'
else
  buf(2) = 'S'
buf(3) = 'T'
buf(4) = EOS
call upper(buf)

return
end
#-h- gwdir            300  asc  31-jul-83 09:39:27  tools (lblh csam sventek)
### GWDir	Get the name of the current working directory in LOCAL format.

subroutine gwdir( buf, dtype)

character  buf(ARB), temp(FILENAMESIZE)
integer    dtype

call gtdpth(temp)
call concat(temp, "/", temp)
if( dtype == LOCAL )
  call mklocl( temp, buf)
else
  call mkpath( temp, buf)

return
end
#-h- homdir           888  asc  23-apr-82 11:40:50  j (sventek j)
### HomDir      Get the name of our home directory.

subroutine homdir(home, dtype)

character  sender(USERSIZE), home(ARB), buf(MAXLINE)
character  usrfil(FILENAMESIZE)
integer    junk, i, found, dtype
integer    openf, n, gets, rab, index
integer    equal, getwrd # function(s)

call mailid(sender) # get mailid
i = index( sender, ' ')
if( i > 0 )
  sender(i) = EOS
found = NO
call adrfil(usrfil)
call upper(usrfil)
if (openf(usrfil, 0, 0, READ, -1, rab) != ERR)
{
  repeat
  {
    n = gets(rab, buf, MAXCARD)
    if (n < 0)
      break
    buf(n+1) = EOS
    i = 1
    junk = getwrd(buf, i, home)
    if (equal(home, sender) == YES)
    {
      junk = getwrd(buf, i, usrfil)
      found = YES
      break
    }
  }
  call closef(rab)
}
if (found == NO)
  home(1) = EOS
else if (dtype == LOCAL)
  call strcpy(usrfil, home)
else
  call cvt_dtop(usrfil, home)
call fold(home)

return
end
#-h- hostnm           188  asc  27-apr-82 15:27:50  tools (lblh csam sventek)
### HostNm	Get name of current host.

subroutine hostnm(tstr)

character  tstr
integer    junk
integer    trnlog # function(s)

junk = trnlog( "ST_NODE", tstr)
call fold(tstr)

return
end
#-h- htoi             327  asc  25-mar-82 08:58:51  v1.1 (sw-tools v1.1)
### HToI	Return value of hex string contained in `buf'.

integer    function htoi(buf)

character  buf(ARB), temp(PIDSIZE)
integer    n, int
integer    length # function(s)

call strcpy( buf, temp)
call upper(temp)
n = length(temp)
if( .not.lib$cvt_htb( %val(n), %ref(temp), %ref(int) ) )
  return(ERR)
else
  return(int)

end
#-h- initst          1955  asc  07-may-82 07:47:00  tools (lblh csam sventek)
### InitST	Initialize runtime system for software tools VOS.

subroutine initst

character  buf(MAXLINE)
integer    done, i, junk
integer    getarg, assign, insub, outsub, open, trnlog, equal # function(s)
integer    outacc, erracc

include    carg

include    io

include    cexith # common block for VMS exit handler
external   exith

string input(FILENAMESIZE) "SYS$INPUT"
string output(FILENAMESIZE) "SYS$OUTPUT"
string errout(FILENAMESIZE) "SYS$ERROR"
string new_ver_log_nam "ST_NEW_VERSIONS"
string do_new_versions "YES"

data outacc / WRITE / 
data erracc / WRITE / 

data done / NO / 

if( done == YES ) #make sure routine executed only once
  return
done = YES

#initialize /carg/ common block
nbrarg = 0

#
# set up exit handler for all processes which spawn subtasks
#
desblk(2) = %loc(exith)
desblk(3) = 0
desblk(4) = %loc(reason)
# the following line was commented out due to FT2 bug!!!
# it was not needed anymore, anyways
#call sys$dclexh(desblk) # declare VMS exit handler

#	initialize /io/ common block variables

for( i = 1 ; i <= NNFILES ; i = i + 1 )
{
  lfn(i) = NODEVICE
  rawchn(i) = NODEVICE # (dpm 8-Jun-81)
  chstat(i) = OK # (dpm 8-Jun-81)
  chtimo(i) = MAX_TIMEOUT # (dpm 8-Jun-81)
}

# determine whether to create new versions

junk = trnlog(new_ver_log_nam, tbuf)
new_versions = equal(tbuf, do_new_versions)

#	set up list of command arguments
call makarg
#pick up file substitutions for standard files

for( i = 1 ; i < nbrarg ;  )
{
  j = ptr( i + 1 )
  call scopy( arg, j, buf, 1)
  if( ( insub( buf, input) == YES ) |
    ( outsub( '>', buf, output, outacc) == YES ) |
      ( outsub( '?', buf, errout, erracc) == YES ) )
    call delarg(i)
  else
    i = i + 1
}

#open files
if( assign( errout, ERROUT, erracc) == ERR )
{
%      type * ,  'Cannot open ERROUT.'
  call endst(ERR)
}
if( assign( input, STDIN, READ) == ERR )
  call cant(input)
if( assign( output, STDOUT, outacc) == ERR )
  call cant(output)

return
end
#-h- inmap            147  asc  25-mar-82 08:58:54  v1.1 (sw-tools v1.1)
### InMap	Map characters from local representation, if required.
#  This is only a stub.

character  function inmap(c)
character  c

return(c)
end
#-h- insub            235  asc  25-mar-82 08:58:56  v1.1 (sw-tools v1.1)
### InSub	Return whether `arg' is STDIN substitution.

integer    function insub( arg, file)

character  arg(ARB), file(ARB)


if( arg(1) == '<' & arg(2) != EOS )
{
  call scopy( arg, 2, file, 1)
  return(YES)
}
else
  return(NO)

end
#-h- intsrv           378  asc  25-mar-82 08:58:57  v1.1 (sw-tools v1.1)
### IntSrv	^C AST service routine; gun down all our foreground processes.

subroutine intsrv

integer    i, junk
integer    kill # function(s)

include    cproc

for( i = 1 ; i <= NFOREGROUND ; i = i + 1 )
  if( pid( 1, i) != EOS & pdone(i) == NO )
    junk = kill( pid( 1, i) )

call setast(YES)	# Indicate that an AST was received.
call enbint		# Reenable ^C AST.

return
end
#-h- isatty           193  asc  25-mar-82 08:58:59  v1.1 (sw-tools v1.1)
### IsATTY	Return whether file behaves like terminal (or printer).

integer    function isatty(fd)

filedes    fd
include    io

if( lfn(fd) == TTYDEVICE )
  return(YES)
else
  return(NO)

end
#-h- itoczf           387  asc  25-mar-82 08:59:00  v1.1 (sw-tools v1.1)
### IToCZF	Convert integer to character string with zero-fill.

subroutine itoczf( n, tbuf, width)

integer    i, m, n, width
integer    itoc # function(s)
character  tbuf(ARB), temp(10)

m = width - itoc( n, temp, 10)
if( m >= 0 )
{
  for( i = 1 ; i <= m ; i = i + 1 )
    tbuf(i) = '0'
  call scopy( temp, 1, tbuf, i)
}
else
{
  i = 1 - m
  call scopy( temp, i, tbuf, 1)
}

return
end
#-h- kill             326  asc  25-mar-82 08:59:01  v1.1 (sw-tools v1.1)
### Kill	Gun down process `prcid'.

integer    function kill(prcid)

character  prcid(PIDSIZE)
integer    exit_stat, pid, status
integer    htoi, sys$forcex # function(s)

data exit_stat / CHILD_ABORTED /

pid = htoi(prcid)
status = sys$forcex( pid, , %val(exit_stat) )
if( .not. status )
  return(ERR)
else
  return(OK)

end
#-h- loccom           943  asc  25-mar-82 08:59:02  v1.1 (sw-tools v1.1)
### LocCom	Locate command according to specified search path.

integer    function loccom( comand, spath, suffix, path)

character  comand(ARB), spath(ARB), path(ARB), temp(FILENAMESIZE)
character  suffix(ARB)
integer    i, j, n, type
integer    flfind, index, length # function(s)

#----- NOTE -----
# Do not write into 'path' until processing is completed, thus allowing loccom
# to be called with the same array for 'comand' and 'path' args.
#----------------

for( i = 1 ; spath(i) != '@n' ; i = i + length( spath(i) ) + 1 )
{
  call concat( spath(i), comand, temp)
  n = length(temp) + 1
  if( index( comand, '.') > 0 )
  {
    if( flfind( temp, path, type) != ERR )
      return(type)
  }
  else
  {
    for( j = 1 ; suffix(j) != '@n' ; j = j + length( suffix(j) ) + 1 )
    {
      call scopy( suffix, j, temp, n)
      if( flfind( temp, path, type) != ERR )
        return(type)
    }
  }
}
call strcpy( comand, path)

return(ERR)
end
#-h- mailid          1315  asc  05-apr-82 12:01:12  tools (lblh csam sventek)
### MailId	Get our username (used as our mailing address).

subroutine mailid(sender)

define(USERNAMESIZE,12)

character  sender(ARB)
character  buf(MAXLINE), out(FILENAMESIZE)
integer rab, n, junk
integer openf, gets, getwrd, equal, index, length
integer*2  jpibuf(8)
integer    i, usera

equivalence( usera, jpibuf(3) )

string blklp  " ("

data jpibuf / USERNAMESIZE, JPI_USERNAME, 6*0 / 

for( i = 1 ; i <= USERNAMESIZE ; i = i + 1 )
  sender(i) = ' '
usera = %loc(sender)
call sys$getjpi( , , , jpibuf, , , )
for( i = USERNAMESIZE ; i > 0 ; i = i - 1 )
  if( sender(i) != ' ' )
    break
sender( i + 1 ) = EOS
call fold(sender)
call adrfil(buf)
if (openf(buf, 0, 0, READ, -1, rab) != ERR)
  {
  repeat
    {
    n = gets(rab, buf, MAXCARD)
    if (n < 0)
      break
    buf(n+1) = EOS
    i = 1
    junk = getwrd(buf, i, out)
    if (equal(out, sender) == YES)		# found the record
      {
      i = index(buf, '"')			# find start of comment string
      if (i > 0)
        {
        n = length(sender) + 1
        call stcopy(blklp, 1, sender, n)
        for (i=i+1; buf(i) != EOS; i=i+1)
          {
          if (buf(i) == '"')
            break
          call chcopy(buf(i), sender, n)
          }
        call chcopy(')', sender, n)
        }
      break
      }
    }
  call closef(rab)
  }

return
end
#-h- makarg           581  asc  22-dec-82 11:37:45  tools (lblh csam sventek)
### MakArg	Get command line and construct array of pointers.

subroutine makarg

include    carg

integer    iend, j, tog
integer    getmsg # function(s)

iend = getmsg(arg)
nbrarg = 0
j = 1
for( i = 1 ; i <= MAXARGS ; i = i + 1 )
{
  if( j <= iend )
    call skipbl( arg, j)
  if( j > iend )
    break
  ptr(i) = j

  if( arg(j) == '@'' | arg(j) == '"' )
  {
    tog = arg(j)
    for( j = j + 1 ; arg(j) != tog & arg(j) != EOS ; j = j + 1 )
      ;
  }
  else
    while( arg(j) != ' ' & arg(j) != EOS )
      j = j + 1

  arg(j) = EOS
  j = j + 1
}
    
nbrarg = i - 1
return
end
#-h- mklocl           571  asc  25-mar-82 08:59:08  v1.1 (sw-tools v1.1)
### MkLocl	Convert from pathname to local (DEC) file spec.

subroutine mklocl( in, out)

integer    depth, i, junk, ptr(10)
integer    gtftok # function(s)
character  in(ARB), out(ARB), path(FILENAMESIZE), temp(FILENAMESIZE)
character  lstchr

call mkpath( in, path) # resolve to full path name
call exppth( path, depth, ptr, out)
if (lstchr(path) != '/')
{
  i = ptr(depth)
  path(i) = EOS
  ptr(depth) = ptr(depth) + 1
  call gendir( path, out)
  i = ptr(depth)
  junk = gtftok( path, i, temp)
  call concat( out, temp, out)
}
else
  call gendir(path, out)

return
end
#-h- mkpath           482  asc  25-mar-82 08:59:10  v1.1 (sw-tools v1.1)
### MkPath	Convert "in" string to fully resolved pathname in "path".
subroutine mkpath( in, path)

character in(ARB), path(ARB), temp(FILENAMESIZE)
integer   local, i
integer   index # function(s)

string decsep ":[]"

local = NO
for( i = 1 ; decsep(i) != EOS ; i = i + 1 )
  if( index( in, decsep(i)) > 0 )
  {
    local = YES
    break
  }
if( local == YES )
  call cvt_dtop( in, temp)
else
  call strcpy( in, temp)
call resdef( temp, path)
call str_host( path, temp)

return
end
#-h- note             251  asc  25-mar-82 08:59:12  v1.1 (sw-tools v1.1)
### Note	Get file address for next line.

integer function note(addr, fd)

filedes    fd
integer    addr(2)
include    io

ifdef( VAX_VMS )
call mark( fdb(fd), addr(1), addr(2) )
elsedef
call mark( fdb(fd), 0, addr(1), addr(2))
enddef

return(OK)
end
#-h- nxtlun           250  asc  25-mar-82 08:59:14  v1.1 (sw-tools v1.1)
### NxtLUN	Find next free logical unit (file descriptor).

integer    function nxtlun(fd)

filedes    fd

include    io

for( fd = 1 ; fd <= NNFILES ; fd = fd + 1 )
  if( lfn(fd) == NODEVICE )
    break
if( fd > NNFILES )
  fd = ERR

return(fd)
end

#-h- open             305  asc  28-may-82 15:41:08  tools (lblh csam sventek)
### Open	Associate file `fil' with descriptor at mode `access'.

filedes    function open( fil, access)

character  fil(ARB)
filedes    fd
filedes    cre8at, nxtlun # function(s)
integer    access

include    io

if( nxtlun(fd) == ERR )
  return(ERR)
else
  return( cre8at( fil, access, fd, OLDAGE))

end
#-h- opena            342  asc  28-may-82 15:41:09  tools (lblh csam sventek)
### OpenA	Open file `fil' on `fd' with APPEND access.

integer    function opena( fil, fd, access, age)

character  fil(ARB)
filedes    fd
filedes    openf # function(s)
integer    access, age

include    io

opena = openf( fil, CHARAC, LISTCC, APPEND, age, fdb(fd) )
if( opena != ERR )
{
  lastc(fd) = 0
  mode(fd) = OUTPUTMODE
}
return
end
#-h- opendr           877  asc  25-mar-82 08:59:19  v1.1 (sw-tools v1.1)
### OpenDr	Open directory file for reading with GdrPrm and GdrAux.

define( NDIRECTS, 10) # maximum number of open directories

integer    function opendr( direct, desc)

character  direct(FILENAMESIZE), temp(FILENAMESIZE)
filedes    desc
integer    n
integer    dopen, length # function(s)

external   dir_init

include    cdirec

string stars "*.*;*"

for( desc = 1 ; desc <= NDIRECTS ; desc = desc + 1 )
  if( dfab(desc) == 0 )
    break
if( desc > NDIRECTS )
  desc = ERR
else
{
  call mkpath( direct, temp)
  call gendir( temp, dnam( 1, desc) )
  call concat( dnam( 1, desc), stars, temp)
  call upper(temp)
  n = length(temp)
  if( dopen( temp, n, dfab(desc) ) == ERR )
  {
    dfab(desc) = 0
    desc = ERR
  }
  else
    lfile( 1, desc) = EOS # initialize last file seen string
}
return(desc)
end

block data dir_init

include    cdirec

data dfab / NDIRECTS*0 / 

end
#-h- openn            323  asc  25-mar-82 08:59:20  v1.1 (sw-tools v1.1)
### OpenN	Open new file `fil' on `fd'.

integer    function openn( fil, fd, access)

character  fil(ARB)
filedes    fd
integer    access
integer    openf # function(s)

include    io

openn = openf( fil, CHARAC, LISTCC, READWRITE, NEWAGE, fdb(fd) )
if( openn != ERR )
{
  lastc(fd) = 0
  mode(fd) = OUTPUTMODE
}
return
end
#-h- openp            364  asc  25-mar-82 08:59:22  v1.1 (sw-tools v1.1)
### OpenP	Open file `fil' on `fd' for printing (Fortran carriage control).

integer    function openp( fil, fd, access)

character  fil(FILENAMESIZE)
filedes    fd
integer    access
integer    openf # function(s)

include    io

openp = openf( fil, CHARAC, FORTCC, WRITE, NEWAGE, fdb(fd) )
if( openp != ERR )
{
  lastc(fd) = 0
  mode(fd) = OUTPUTMODE
}
return
end
#-h- openr            348  asc  25-mar-82 08:59:23  v1.1 (sw-tools v1.1)
### OpenR	Open file `fil' on `fd' with READ access.

integer    function openr( fil, fd, access)


character  fil(ARB)
filedes    fd
integer    access
integer    openf # function(s)

include    io

openr = openf( fil, CHARAC, LISTCC, READ, OLDAGE, fdb(fd) )
if( openr != ERR )
{
  lastc(fd) = 0
  bcount(fd) = 0
  mode(fd) = INPUTMODE
}
return
end
#-h- opens            340  asc  25-mar-82 08:59:25  v1.1 (sw-tools v1.1)
### OpenS	Open file `fil' on `fd' with READWRITE access.

integer    function opens(fil, fd, access)

character  fil(ARB)
filedes    fd
integer    access
integer    openf # function(s)

include    io

opens = openf( fil, CHARAC, LISTCC, READWRITE, UNKAGE, fdb(fd) )
if( opens != ERR )
{
  lastc(fd) = 0
  mode(fd) = OUTPUTMODE
}
return
end
#-h- openw            653  asc  28-may-82 15:41:12  tools (lblh csam sventek)
### OpenW	Open file `fil' on `fd' with WRITE/READWRITE access.

integer    function openw( fil, fd, access, age)

character  fil(ARB)
filedes    fd
integer    acc, access, filtyp, age, local_age
integer    openf # function(s)

include    io

if( access == BINARY_WRITE ) # (dpm 7-Sep-81)
{
  acc = WRITE
  filtyp = BINAR
}
else
{
  acc = access
  filtyp = CHARAC
}

if (age == UNKAGE & new_versions == YES & access != READWRITE)
  local_age = NEWAGE
else
  local_age = age
openw = openf( fil, filtyp, LISTCC, acc, local_age, fdb(fd) )
if( openw != ERR )
{
  lastc(fd) = 0
  mode(fd) = OUTPUTMODE
  if( acc == READWRITE )
    bcount(fd) = 0
}
return
end
#-h- outmap           154  asc  25-mar-82 08:59:28  v1.1 (sw-tools v1.1)
### OutMap	Map ASCII characters into local character set, if required.
#  This is only a stub.

character  function outmap(c)
character  c

return(c)
end
#-h- outsub           432  asc  25-mar-82 08:59:29  v1.1 (sw-tools v1.1)
### OutSub	Determine if argument is output file substitution.
integer    function outsub(c, arg, file, access)

character  arg(ARB), c, file(ARB)
integer    access, i

if( arg(1) == c )
  if( arg(2) == c )
  {
    if( arg(3) != EOS )
    {
      access = APPEND
      call scopy( arg, 3, file, 1)
      return(YES)
    }
  }
else if( arg(2) != EOS )
{
  access = WRITE
  call scopy( arg, 2, file, 1)
  return(YES)
}

return(NO)
end
#-h- parsef           818  asc  25-mar-82 08:59:30  v1.1 (sw-tools v1.1)
### ParseF	Parse DEC filespec into node, device, dir, and file strings.

subroutine parsef( in, node, device, direct, file)

character  in(ARB), node(ARB), device(ARB), direct(ARB), file(ARB)
integer    start, stop
integer    index # function(s)

start = 1
stop = start + index( in(start), ':') - 1
if( stop >= start & in( stop + 1 ) == ':' )
{
  call copyit( in, start, stop - 1, node)
  start = stop + 2
  stop = start + index( in(start), ':') - 1
}
else
  node(1) = EOS
if( stop >= start )
{
  call copyit( in, start, stop - 1, device)
  start = stop + 1
}
else
  device(1) = EOS
if( in(start) == '[' )
{
  stop = start + index( in(start), ']') - 1
  if( stop < start )
    stop = start
  call copyit( in, start, stop, direct)
  start = stop + 1
}
else
  direct(1) = EOS
call scopy( in, start, file, 1)

return
end
#-h- pgflts           308  asc  25-mar-82 08:59:32  v1.1 (sw-tools v1.1)
### PgFlts	Get the number of page faults incurred less `start'.

integer    function pgflts(start)

integer    pgf, pgfbuf, start
integer*2  jpibuf(8)

equivalence( pgfbuf, jpibuf(3) )

data jpibuf / 4, JPI_PAGEFLTS, 6*0 / 

pgfbuf = %loc(pgf)
call sys$getjpi( , , , jpibuf, , , )

return( pgf - start )
end
#-h- prcdon          1175  asc  30-jul-83 18:01:26  tools (lblh csam sventek)
### PrcDon	Display process termination status message.

subroutine prcdon

integer    j, ptr
integer    equal # function(s)
character  buf(PIDSIZE)

include    cproc
include    ctrmbx

ptr = 0
call puthex( iosb(2), buf)
for( j = 1 ; j <= NPROCESSES & ptr == 0 ; j = j + 1 )
  if( equal( pid( 1, j), buf) == YES )
    ptr = j
if( ptr != 0 )
{
  pdone(ptr) = YES
  for( j = 1 ; j <= TERMSGSIZE ; j = j + 1 )
    pmsg( j, ptr) = termsg(j)
  if( ptr <= NFOREGROUND & n4grnd > 0 )
    n4grnd = n4grnd - 1
}
if( n4grnd <= 0 )
  for( j = NFOREGROUND + 1 ; j <= NPROCESSES ; j = j + 1 )
    if( pdone(j) == YES & pid( 1, j) != EOS )
    {
      if (spunit != ERR)
        {
        call putlin(  "background process ", spunit)
        call putlin( pid( 1, j), spunit)
        call putlin(  " terminated", spunit)
        if( .not. pmsg( 2, j) & pmsg( 2, j) != 0 )
        {
          call putlin(  " abnormally. Return status = ", spunit)
          call puthex( pmsg( 2, j), buf)
          call putlin( buf, spunit)
        }
        else
          call putlin(  " successfully", spunit)
        call putch( '@n', spunit)
        }
      call putpdb(j)
    }
call rdtmbx

return
end
#-h- prompt          1180  asc  25-mar-82 08:59:36  v1.1 (sw-tools v1.1)
### Prompt	Read line from `in', prompting if a terminal.

integer    function prompt( pbuf, line, in)

character  buf(MAXLINE), line(ARB), pbuf(ARB)
filedes    in, out
integer    i, n
integer    create, getlin, length, rdpmpt # function(s)

include    io

string term TTY_NAME
string crlf "@r@l"
string under "_"

if( lfn(in) == TTYDEVICE & pbuf(1) != EOS )
{
  for( n = length(pbuf) ; n > 0 ; n = n - 1 )
    if( pbuf(n) == '@n' )
      break
  if( n > 0 ) # have a multi-line prompt
  {
    for( i = 1 ; i <= n ; i = i + 1 )
      buf(i) = pbuf(i)
    buf(i) = EOS
    out = create( term, WRITE)
    if( out != ERR )
    {
      call putlin( buf, out)
      call close(out)
    }
  }
  n = n + 1
  i = 1
  call stcopy( crlf, 1, buf, i)
  call strcpy( pbuf(n), buf(i) )
}
else
  buf(1) = EOS
n = 1
repeat
{
  if( buf(1) == EOS )
    i = getlin( line(n), in)
  else
  {
    i = rdpmpt( fdb(in), buf, length(buf), line(n), MAXCARD - n )
    buf(3) = pbuf(1)
    call strcpy( under, buf(4) )
  }
  if( i < 0 )
    return(EOF)
  n = n + i
  if( n <= 2 )
    break
  if( line( n - 2 ) != '@@' ) # not an escaped '@n'
    break
  n = n - 1
  line( n - 1 ) = ' '
}

return( n - 1 )
end
#-h- pstat            409  asc  25-mar-82 08:59:38  v1.1 (sw-tools v1.1)
### Pstat	Get status of specified process.

integer    function pstat(buf)

character  buf(PIDSIZE)
integer    astate, pid, state, status
integer    htoi, sys$getjpi # function(s)
integer*2  jpibuf(8)

equivalence( astate, jpibuf(3) )

data jpibuf / 4, JPI_STATE, 6*0 / 

astate = %loc(state)
pid = htoi(buf)
status = sys$getjpi( , pid, , jpibuf, , , )
if( .not. status )
  return(ERR)
else
  return(OK)

end
#-h- ptrcpy           171  asc  25-mar-82 08:59:40  v1.1 (sw-tools v1.1)
### PtrCpy	Copy pointer from `in' to `out'.

subroutine ptrcpy( in, out)

integer    in(2), out(2)

out(1) = in(1)
if( in(1) != NULLPOINTER )
  out(2) = in(2)

return
end
#-h- ptreq            264  asc  25-mar-82 08:59:41  v1.1 (sw-tools v1.1)
### PtrEq	Test `ptr1' and `ptr2' for equality.

integer    function ptreq( ptr1, ptr2)

integer    ptr1(2), ptr2(2)

if( ptr1(1) == ptr2(1) )
{
  if( ptr1(1) == NULLPOINTER )
    return(YES)
  else if( ptr1(2) == ptr2(2) )
    return(YES)
}
else
  return(NO)

end
#-h- ptrtoc           556  asc  25-mar-82 08:59:42  v1.1 (sw-tools v1.1)
### PtrToC	Convert pointer to character string.

integer    function ptrtoc( ptr, buf, size)

integer    i, j, junk, ptr(2), size
integer    addset, itoc, length # function(s)
character  buf(size), temp(7)

junk = itoc( ptr(1), temp, 7)
j = 1
for( i = 1 ; temp(i) != EOS ; i = i + 1 )
  junk = addset( temp(i), buf, j, size)
junk = addset( ' ', buf, j, size)
junk = itoc( ptr(2), temp, 7)
for( i = 1 ; temp(i) != EOS ; i = i + 1 )
  junk = addset( temp(i), buf, j, size)
if( addset( EOS, buf, j, size) == ERR )
  buf(size) = EOS
return( length(buf) )

end
#-h- putch            714  asc  19-oct-83 12:48:53  tools (lblh csam sventek)
### PutCh	Put character on file `fd'.

subroutine putch( c, fd)

character  c
character  outmap # function(s)
filedes    fd
integer    i, n
integer    puts # function(s)

include    io

chstat(fd) = OK
if( chtype(fd) != COOKED )
{
  call rputch( c, 1, fd) # (dpm 8-Jun-81)
  return
}
if( mode(fd) != OUTPUTMODE )
{
  mode(fd) = OUTPUTMODE
  lastc(fd) = 0
}
n = lastc(fd)
if( n >= MAXLINE | c == '@n' )
{
  chstat(fd) = puts( fdb(fd), buffer( 1, fd), n)
  lastc(fd) = 0
}
if( c != '@n' )
{
  lastc(fd) = lastc(fd) + 1
  n = lastc(fd)
  #	use the following line if the characters have to be mapped
  #	    buffer(n, fd) = outmap(c)
  #	use the following line if no mapping required
  buffer( n, fd) = c
}
return
end
#-h- puthex           300  asc  25-mar-82 08:59:44  v1.1 (sw-tools v1.1)
### PutHex	Format `n' into `buf' as a hexadecimal character string.

subroutine puthex( n, buf)

integer    n, fmt(2), out(2)
character  buf(ARB)

string fmtbuf "!XL"

call dscbld( fmt, fmtbuf)
out(1) = 9
out(2) = %loc(buf)
call sys$fao( fmt, , out, %val(n) )
buf(9) = EOS
call fold(buf)

return
end
#-h- putlin           363  asc  25-mar-82 08:59:45  v1.1 (sw-tools v1.1)
### PutLin	Output a line of text to `fd' by repeated calls to PutCh.

subroutine putlin( b, fd)

character  b(ARB)
filedes    fd
integer    i
integer    length # function(s)

include    io

if( chtype(fd) != COOKED )
{
  i = length(b)
  call rputch( b, i, fd) # (dpm 8-Jun-81)
}
else
  for( i = 1 ; b(i) != EOS ; i = i + 1 )
    call putch( b(i), fd)

return
end
#-h- putpdb           320  asc  25-mar-82 08:59:46  v1.1 (sw-tools v1.1)
### PutPDB	Mark process as nonexistant and deassign mailbox.

subroutine putpdb(offset)

integer    offset

include    cproc

call sys$setast( %val(0) ) # disable AST delivery
pid( 1, offset) = EOS
pdone(offset) = NO
call sys$dassgn( %val( mbxchn(offset) ) )
call sys$setast( %val(1) ) # enable AST delivery

return
end
#-h- pwait            767  asc  25-mar-82 08:59:47  v1.1 (sw-tools v1.1)
### PWait	Wait for completion of foreground process(es).
integer    function pwait( nprocs, pids, pinfo, lstpid, flag)

character  lstpid(PIDSIZE), pids( PIDSIZE, ARB)
integer    flag, i, j, k, nprocs, pinfo(TERMSGSIZE, ARB)
integer    equal # function(s)

include    cproc

for( i = 1 ; i <= nprocs ; i = i + 1 )
{
  for( j = 1 ;
       j <= NFOREGROUND & equal( pid( 1, j), pids( 1, i)) == NO ;
       j = j + 1 )
    if( j > NFOREGROUND )
      next
  while( pdone(j) != YES )
    call wtmsec(100) # wait 100 msec
  for( k = 1 ; k <= TERMSGSIZE ; k = k + 1 )
    pinfo( k, i) = pmsg( k, j)
  call strcpy( pids( 1, i), lstpid)
  call putpdb(j)
}

if( pinfo( 2, 1) == CHILD_ABORTED ) # return status of first process
  return( CHILD_ABORTED )
else
  return(OK)

end
#-h- quotas           701  asc  25-mar-82 08:59:49  v1.1 (sw-tools v1.1)
### Quotas	Set up VMS quotas for spawning subprocesses.

subroutine quotas(wait)

integer    fillm, fillma, mul
integer*2  qlist(8)
character  wait
equivalence( fillma, qlist(3) )

include    cquota

data qlist / 4, JPI_FILLM, 4*0, 2*0 / 

b1 = pqlastlm
l1 = ASTLM
b2 = pqlbiolm
l2 = BIOLM
b3 = pqlbytlm
b4 = pqlcpulm
l4 = CPULM
b5 = pqldiolm
l5 = DIOLM
b6 = pqlfillm
b7 = pqlpgflquota
b8 = pqlprclm
b9 = pqltqelm
ba = pqlwsquota
la = WSQUOTA
bb = pqlwsdefault
lb = WSDEFAULT
b0 = pqllistend

fillma = %loc(fillm)
call sys$getjpi( , , , qlist, , , )
mul = fillm / FILLM
if( mul > 1 )
  mul = mul - 1
l3 = mul * BYTLM
l6 = mul * FILLM
l7 = mul * PGFLQUOTA
l8 = mul * PRCLM
l9 = mul * TQELM

return
end
#-h- rdtmbx           253  asc  25-mar-82 08:59:50  v1.1 (sw-tools v1.1)
### RdTMbx	Post a read request from the termination mailbox.

subroutine rdtmbx

include    ctrmbx

external   prcdon

call sys$qio(	,
		%val(termbx),
		%val(IO_READVBLK),
		iosb,
		prcdon,
		,
		termsg,
		%val(TERMSGSIZEBYTE),
		,
		,
		,)

return
end
#-h- readf            349  asc  25-mar-82 08:59:51  v1.1 (sw-tools v1.1)
### ReadF	Read "n" bytes from "fd" into "buf".
integer    function readf( buf, n, fd)

character  buf(ARB)
filedes    fd
integer    count, n
integer    gets # function(s)

include    io

if( 1 <= fd & fd <= NNFILES )
  andif( lfn(fd) != NODEVICE )
  {
    count = gets( fdb(fd), buf, n)
    if( count >= 0 )
      return(count)
  }

return(EOF)
end
#-h- realdev          569  asc  25-mar-82 08:59:52  v1.1 (sw-tools v1.1)
### Real_device	Return whether 1st token of `path' is a device name.

integer    function real_device(path)

character  path(ARB), temp(FILENAMESIZE), temp1(FILENAMESIZE)
integer    dsc(2), i, junk, pbd(2), pbuf
integer    gtftok, sys$getdev, index, trnlog # function(s)

string colon ":"

i = 2
junk = gtftok( path, i, temp)
call upper(temp)
junk = trnlog( temp, temp1)
if( index( temp1, ':') == 0 )
  call concat( temp1, colon, temp1)
call dscbld( dsc, temp1)
pbd(1) = 4
pbd(2) = %loc(pbuf)
if( .not.sys$getdev( dsc, , pbd, , ) )
  return(NO)
else
  return(YES)

end
#-h- remark           283  asc  25-mar-82 08:59:54  v1.1 (sw-tools v1.1)
### Remark	Output message on ERROUT; assure '@n'.

subroutine remark(line)

character  line(ARB)

for( i = 1 ; line(i) != EOS ; i = i + 1 )
  call putch( line(i), ERROUT)
if (i == 1)
  call putch('@n', ERROUT)
else if( line( i - 1 ) != '@n' )
  call putch( '@n', ERROUT)

return
end
#-h- remove           310  asc  25-mar-82 08:59:55  v1.1 (sw-tools v1.1)
### Remove	Remove file `fil'.

integer function remove(fil)

character  fil(FILENAMESIZE)
filedes    fd
integer    fdel, open # function(s)
integer    status

include    io

status = OK
fd = open( fil, READ)
if( fd != ERR )
{
  if( fdel( fdb(fd) ) < 0 )
    status = ERR
  call close(fd)
}

return(status)
end
#-h- resdef          1077  asc  25-mar-82 08:59:56  v1.1 (sw-tools v1.1)
### ResDef	Resolve defaults, generating full from partial pathname.

subroutine resdef( cpath, dpath)

character  tpath(FILENAMESIZE), c
character  cpath(ARB), dpath(ARB), temp(FILENAMESIZE)
character  lstchr
integer    depth, i, j, level, ptr(MAXDIRECTS)
integer    equal, gtftok, real_device # function(s)

string backsl "\"
string dotdot ".."

call gtdpth(dpath)
call exppth( dpath, depth, ptr, temp)
c = lstchr(cpath)
call res_tilde( cpath, tpath)
if( tpath(1) == EOS )	# No such place (dpm 11-Jul-81)
{
  dpath(1) = EOS
  return
}
else if( tpath(1) == '/' )
{
  if( tpath(2) == '@@' )
    level = 1
  else if( real_device(tpath) == YES )
    level = 2
  else
    level = 3
}
else
  level = depth + 1
j = ptr(level)
i = 1
while( gtftok( tpath, i, temp) > 0 )
{
  if( equal( temp, dotdot) == YES | equal( temp, backsl) == YES )
  {
    level = level - 1
    j = ptr(level)
  }
  else
  {
    ptr(level) = j
    level = level + 1
    dpath(j) = '/'
    j = j + 1
    call stcopy( temp, 1, dpath, j)
  }
}
if (c == '/')
  call chcopy('/', dpath, j)
dpath(j) = EOS

return
end
#-h- restilde        2499  asc  24-nov-82 10:18:52  tools (lblh csam sventek)
### ResTilde	Resolve `~' prefixed pathnames.

subroutine res_tilde( path, out)

character  buf(MAXLINE), out(ARB), path(ARB), token(FILENAMESIZE)
integer    found, i, j, junk, key, n, rab
integer    equal, gets, getwrd, gtftok, length, openf # function(s)

string bin "bin"
string usr "usr"
string tmp "tmp"
string lpr "lpr"
string msg "msg"
string mail "mail"	# WARNING!!! Goes away on 1-Jan-83 (dpm 15-Dec-81)
string man "man"
string src "src"
string inc "inc"
string lib "lib"
string start "/st_"
string slashs "/"

if( path(1) != '~' )
{
  call strcpy( path, out)
  if (out(1) == '/' & out(2) == '\')
    out(2) = '@@'
  else if (out(1) == '.' & out(2) == '/')
    call scopy(out, 3, out, 1)
}
else
{
  found = YES
  i = 2
  key = ERR
  if( path(i) == '/' | path(i) == EOS )
  {
    call homdir(token, LOCAL) # bare '~' => home directory (dpm 16-Jun-81).
    key = OK
  }
  else
  {
    junk = gtftok( path, i, token)
    call fold(token)
    if( equal( token, bin) == YES )
      key = BINDIRECTORY
    else if( equal( token, usr) == YES )
      key = USRDIRECTORY
    else if( equal( token, tmp) == YES )
      key = TMPDIRECTORY
    else if( equal( token, lpr) == YES )
      key = LPRDIRECTORY
    else if( equal( token, msg) == YES )
      key = MSGDIRECTORY
    else if( equal( token, mail) == YES )	# WARNING!!! Goes away on
      key = MSGDIRECTORY			# 1-Jan-83 (dpm 15-Dec-81)
    else if( equal( token, man) == YES )
      key = MANDIRECTORY
    else if( equal( token, src) == YES ) # (dpm 8-Jun-81)
      key = SRCDIRECTORY
    else if( equal( token, inc) == YES ) # (dpm 24-Sep-81)
      key = INCDIRECTORY
    else if( equal( token, lib) == YES ) # (dpm 24-Sep-81)
      key = LIBDIRECTORY
    if( key != ERR )
      call getdir( key, LOCAL, token)
  }
  if( key == ERR )
  {
    call adrfil(buf)
    call upper(buf)
    found = NO
    if( openf( buf, 0, 0, READ,  -1, rab) != ERR )
    {
      repeat
      {
        n = gets( rab, buf, MAXCARD)
        if( n < 0 )
          break
        buf( n + 1 ) = EOS
        j = 1
        junk = getwrd( buf, j, out)
        if( equal( out, token) == YES )
        {
          junk = getwrd( buf, j, token)
          found = YES
          break
        }
      }
      call closef(rab)
    }
  }
  if( found == YES )
    call cvt_dtop( token, out)
  else
    {
    call concat(start, token, out)
    call concat(out, slashs, out)
    }
  j = length(out) + 1
  if (path(i) == '/')
    i = i + 1
  call scopy( path, i, out, j)
}

return
end
#-h- resuic           910  asc  02-aug-83 10:20:26  tools (lblh csam sventek)
### ResUIC	Resolve UIC into username.
define( MAX_PTR, 2500)		# maximum number of login names
define( MAX_TBL,arith(MAX_PTR,*,25))	# total storage needed

subroutine resuic( uic, value)

character  buf(MAXLINE), name(FILENAMESIZE), uic(ARB), value(ARB)
character  defn(FILENAMESIZE)
filedes    fd
integer    i, init, junk
integer    getlin, getwrd, length, open, lookup # function(s)

include clook

data init / YES / 

if( init == YES )
{
  lastp = 0
  lastt = 0
  call adrfil(name)
  fd = open( name, READ) # open address file
  if( fd == ERR )
    call remark(  "? Can't open user's file" )
  else
  {
    while( getlin( buf, fd) != EOF )
    {
      i = 1
      junk = getwrd( buf, i, defn)
      junk = getwrd( buf, i, name)
      junk = getwrd( buf, i, name)
      call instal( name, defn)
    }
    call close(fd)
  }
  init = NO
}
if( lookup( uic, value) == NO )
  call strcpy( uic, value)

return
end
#-h- resume           261  asc  25-mar-82 09:00:04  v1.1 (sw-tools v1.1)
### Resume	Resume suspended process.

integer    function resume(buf)

character  buf(PIDSIZE)
integer    pid, status
integer    htoi, sys$resume # function(s)

pid = htoi(buf)
status = sys$resume( pid, )
if( .not. status )
  return(ERR)
else
  return(OK)

end
#-h- rgetch          1137  asc  25-mar-82 09:00:06  v1.1 (sw-tools v1.1)
### RGetCh	Get a (RAW or RARE) character `c' from channel `chan'. (VMS)

character function rgetch(c, chan)

include io

character c
integer   chan, func, iostat, rawfn, rarefn
integer*2 iosb(4)
integer*4 sys$qiow

define(READ_MODIFIERS,arith(IO_M_NOECHO,+,IO_M_TIMED))

data rawfn  / arith(IO_TTYREADALL,+,READ_MODIFIERS) /
data rarefn / arith(arith(IO_READLBLK,+,IO_M_NOFILTER),+,READ_MODIFIERS) /

iostat = SS_NORMAL
if( chtype(chan) == RAW )
  func = rawfn
else if( chtype(chan) == RARE )
  func = rarefn
else
  iostat = (.not. SS_NORMAL)

if( iostat == SS_NORMAL )
  iostat = sys$qiow(	,			# event flag number
			%val(rawchn(chan)),	# channel number
			%val(func),		# function code
			iosb,			# io status block
			,			# AST address
			,			# AST parameter
			%ref(c),		# input buffer address
			%val(1),		# input buffer size
			%val(chtimo(chan)),	# timeout count
			,			# terminator block address
			,			# prompt buffer address
			,)			# prompt buffer size

if( iostat != SS_NORMAL | iosb(1) != SS_NORMAL )
{
  if( iosb(1) == SS_TIMEOUT )
    c = TMO
  else
    c = ERR
  chstat(chan) = c
}
else
  chstat(chan) = OK

return(c)

end
#-h- rputch           754  asc  25-mar-82 09:00:08  v1.1 (sw-tools v1.1)
### RPutCh	Output `n' characters on `chan'.

subroutine rputch(str, n, chan)

include io

character str(ARB)
integer chan, func, iostat, n
integer*4 sys$qiow
integer*2 iosb(4)

data func / arith(IO_WRITEVBLK,+,IO_M_NOFORMAT) /

iostat = sys$qiow(	,			# event flag number
			%val(rawchn(chan)),	# channel number
			%val(func),		# function code
			iosb,			# io status block
			,			# AST address
			,			# AST parameter
			%ref(str),		# output buffer address
			%val(n),		# output buffer size
			,			# p3 (ignored)
			,			# carriage control
			,			# p5 (ignored)
			,)			# p6 (ignored)

if( iostat != SS_NORMAL )
{
  chstat(chan) = ERR
  return
}

if( iosb(1) == SS_NORMAL | iosb(1) == SS_CONTROLO )
  chstat(chan) = OK
else
  chstat(chan) = ERR

return
end
#-h- rtopen           336  asc  25-mar-82 09:00:10  v1.1 (sw-tools v1.1)
### RTOpen	Open an unCOOKED terminal channel

integer    function rtopen( term, chan)
character  term(ARB)
character  buf(FILENAMESIZE)
integer    chan, dsc(2), junk
integer    sys$assign, trnlog # function(s)

junk = trnlog( term, buf)
call dscbld( dsc, buf)
if( .not. sys$assign( dsc, chan, , ) )
  return(ERR)
else
  return(OK)

end
#-h- scratf           601  asc  25-mar-82 09:00:12  v1.1 (sw-tools v1.1)
### Scratf	Generate scratch file name in `target', using `start' as seed.

subroutine scratf( start, target)

character  direc(FILENAMESIZE), start(ARB), target(ARB)
integer    i, init, j, n
integer    length # function(s)

data init / YES / 

if( init == YES )
{
  call getdir( TMPDIRECTORY, LOCAL, direc)
  i = length(direc) + 1
  call chcopy( 't', direc, i)
  call unique( direc(i) )
  init = NO
}
i = 1
call stcopy( direc, 1, target, i)
target(i) = '.'
i = i + 1
n = length(start)
n = min( n, 3)
for( j = 1 ; j <= n ; j = j + 1 )
{
  target(i) = start(j)
  i = i + 1
}
target(i) = EOS

return
end
#-h- seek             609  asc  25-mar-82 09:00:14  v1.1 (sw-tools v1.1)
### Seek	Position file open on `fd' at record `offset'.

subroutine seek( offset, fd)

character	c
character	getch # function(s)
filedes		fd
integer		offset(2), tmpoff(2)
include		io    

if( offset(1) == BEGINNING_OF_FILE )	# (dpm 2-Nov-81)
{
  tmpoff(1) = 0
  tmpoff(2) = 0
  call point( fdb(fd), tmpoff(1), tmpoff(2))
}
else if( offset(1) == END_OF_FILE )	# (dpm 2-Nov-81)
{
  tmpoff(1) = 0
  tmpoff(2) = 0
  call point( fdb(fd), tmpoff(1), tmpoff(2))
  while( getch( c, fd) != EOF )
    ;
}
else
  call point( fdb(fd), offset(1), offset(2))
#IAS  call point( fdb(fd), 0, offset(1), offset(2))

return
end
#-h- setast           171  asc  25-mar-82 09:00:15  v1.1 (sw-tools v1.1)
### SetAST	Change the value of the AST-received flag.

subroutine setast(state)

integer state
include cast

if( state == YES | state == NO )
  gotast = state

return
end
#-h- sleep           1223  asc  06-may-82 20:00:12  tools (lblh csam sventek)
### Sleep	Hibernate for a specified number of seconds.

subroutine sleep(secnds)

define( MAXSECONDS, 864000) # max is 10 days

integer    days, hours, i, junk, mins, secnds, secs, systim(2), tdesc(2)
integer    timer_efn
integer    lib$get_ef, sys$bintim # function(s)
character  tbuf(5), time(20)

data timer_efn / 0 / 

if( timer_efn == 0 )
  junk = lib$get_ef( timer_efn )
if( secnds <= 0 )
  return
days = 0
hours = 0
mins = 0
if( secnds > MAXSECONDS )
  secs = MAXSECONDS
else
  secs = secnds
if( secs >= 60 )
{
  mins = secs / 60
  secs = secs - 60 * mins
}
if( mins >= 60 )
{
  hours = mins / 60
  mins = mins - 60 * hours
}
if( hours >= 24 )
{
  days = hours / 24
  hours = hours - 24 * days
}
i = 1
call itoczf( days, tbuf, 4)
call stcopy( tbuf, 1, time, i)
call chcopy( ' ', time, i)
call itoczf( hours, tbuf, 2)
call stcopy( tbuf, 1, time, i)
call chcopy( ':', time, i)
call itoczf( mins, tbuf, 2)
call stcopy( tbuf, 1, time, i)
call chcopy( ':', time, i)
call itoczf( secs, tbuf, 2)
call stcopy( tbuf, 1, time, i)
call scopy(  ".00", 1, time, i)
call dscbld( tdesc, time)
if( sys$bintim( tdesc, systim) )
{
  call sys$setimr( %val( timer_efn ), systim, , )
  call sys$waitfr( %val( timer_efn ) )
}

return
end
#-h- spawn           6030  asc  30-jul-83 18:01:30  tools (lblh csam sventek)
### Spawn	Spawn process with arguments.

integer    function spawn( proces, args, desc, inwait)

character  proces(FILENAMESIZE), args(ARGBUFSIZE), desc(PIDSIZE)
character  inwait, wait, msg(ARGBUFSIZE), prname(20), bxname(20)
character  termnl(FILENAMESIZE), tty(FILENAMESIZE)
character  image(FILENAMESIZE), temp(FILENAMESIZE)
character  clower
character  outfil(FILENAMESIZE), errfil(FILENAMESIZE), c
integer    init, junk, i, terunt, n, boxunt, status, uic, prior, baspri
integer    stsflg, dcl, start, stop, j, inpdsc(2), outdsc(2), errdsc(2)
integer    imgdsc(2), prcdsc(2), prvadr(2), unit, lpid, offset, sys$creprc
integer    trm_info(TERMSGSIZE,1)	# only 1 process at a time for now.
integer    opnout, opnerr, outmod, ind
integer    filnfo, gtmode, indexs, stmode
integer    trnlog, crembx, open, getpdb, equal, pwait, dclout

include    cproc
include    ctrmbx
include    cquota

string blkgtr " >"
string blkqmk " ?"
string trmbox(20) "TRMBX"
string nuldev "NLA0:"
string login "sys$system:loginout.exe"
string dodcl "$@@st_bin:dodcl/output="
string nover "$set noverify@n"
string ass1 "$assign/user "
string ass2 " TT@n"
string ass3 "$assign "
string ass4 " SYS$COMMAND@n"

data init / YES /

if( init == YES )
{
  init = NO
  junk = trnlog(  "TT", tty)		# translate to TTXn:
  for( i = 1 ; i <= NPROCESSES ; i = i + 1 )
    call putpdb(i)			# initialize PDB array
  n4grnd = 0				# no foreground processes
  if( crembx( trmbox, YES, termbx, terunt) == ERR )
    call error(  "Cannot create termination mailbox" )
  spunit = open( tty, WRITE)		# establish unit for AST writes
  if( spunit == ERR )
    call remark(  "Cannot open tty unit for spawn AST writes" )
  call rdtmbx				# start asynch read loop of mbox
}
if( args(1) == EOS )
  return(ERR)				# must be some args
wait = clower(inwait)			# case makes no difference
if( getpdb( offset, wait) == ERR )
  return(ERR)				# no available PDB's
opnout = ERR
opnerr = ERR
outmod = ERR
call strcpy( proces, pname( 1, offset) )	# copy name into block
call strcpy( args, msg)			# copy arguments
call genpnm( prname, wait, offset - NFOREGROUND )	# generate p name
call arggen( prname, bxname)		# generate mailbox name
call getprv(prvadr)			# get privileges authorized to pass
call getbpr(baspri)			# Get our base priority. (dpm 9-Jun-81)
stsflg = 0
status = crembx( bxname, NO, mbxchn(offset), boxunt)
if( status != ERR )
{
  unit = open( bxname, READWRITE)
  if( unit == ERR )
    status = ERR
}
if( status != ERR )
{
  if( wait == BACKGR )
  {
    call getuic(uic)
    prior = baspri / 2
    call strcpy( nuldev, termnl)
  }
  else
  {
    uic = 0
    prior = baspri			# Use our base priority (dpm 9-Jun-81)
    call strcpy( tty, termnl)
  }
  call strcpy( proces, image)
  call fold(image)
  dcl = NO
  if( equal( image,  "local" ) == YES )
  {
    dcl = YES
    if (wait == BACKGR)
      stsflg = 64
    call strcpy( login, image)
    i = 1
    call stcopy( dodcl, 1, msg, i)
    call strcpy( termnl, temp)
    status = dclout( args, start, stop, temp)
    call stcopy( temp, 1, msg, i)
    call chcopy( ' ', msg, i)
    if( status == YES )
    {
      for( j = 1 ; j <= start ; j = j + 1 )
        call chcopy( args(j), msg, i)
      j = stop
    }
    else
      j = 1
    call scopy( args, j, msg, i)
    call dscbld( inpdsc, bxname)
    call dscbld( outdsc, nuldev)
  }
  else
  {
    call dscbld( inpdsc, termnl)
    call dscbld( outdsc, termnl)
    if( wait == WAIT )
    {
      if( indexs( msg, blkgtr) == 0 )
      {
        if( filnfo( STDOUT, outfil, junk) == OK )
        {
          opnout = STDOUT
          outmod = gtmode(STDOUT)
          call appred( STDOUT, '>', outfil, msg)
        }
      }
      ind = indexs( msg, blkqmk)
      if( ind != 0 )
      {
        c = msg( ind + 2 )
        if( c == ' ' | c == '@t' | c == EOS )
          ind = 0
      }
      if( ind == 0 )
      {
        if( filnfo( ERROUT, errfil, junk) == OK )
        {
          opnerr = ERROUT
          call appred( ERROUT, '?', errfil, msg)
        }
      }
    }
  }
  call dscbld( errdsc, termnl)
  call dscbld( imgdsc, image)
  call dscbld( prcdsc, prname)
  call upper(image)
  call quotas (wait)
#  call dspprv(JPI_CURPRIV)
#  call dspprv(JPI_PROCPRIV)
  call sys$setast( %val(0) )		# disable AST delivery
  status = sys$creprc(	lpid,			# created proc ID
			imgdsc,			# image name
			inpdsc,			# sys$input
			outdsc,			# sys$output
			errdsc,			# sys$error
			prvadr,			# privilege vector
			b1,			# quota list
			prcdsc,			# process name
			%val(prior),		# base priority
			%val(uic),		# UIC
			%val(terunt),		# termination mbox
			%val(stsflg) )		# status flag
  if( status != SS_NORMAL )
  {
    status = ERR
    call sys$setast( %val(1) )		# enable AST delivery
  }
  else
  {
    n = length(msg)
    if( dcl == YES )
    {
      call putlin( nover, unit)
      call putlin( ass1, unit)
      call putlin( tty, unit)
      call putlin( ass2, unit)
      call putlin( ass3, unit)
      call putlin( tty, unit)
      call putlin( ass4, unit)
      call putlin( msg, unit)
      call putch( '@n', unit)
    }
    else
    {
      i = IO_WRITEVBLK + IO_M_NOW
      call sys$qiow(	%val(1),		# event flag number
			%val( mbxchn(offset) ),	# channel number
			%val(i),		# function code
			,			# io status block
			,			# AST address
			,			# AST parameter
			msg,			# output buffer addr
			%val(n),		# output buffer size
			,			# p3 (ignored)
			,			# carriage control
			,			# p5 (ignored)
			,)			# p6 (ignored)
    }
    call close(unit)
    call puthex( lpid, desc)
    call strcpy( desc, pid( 1, offset) )
    if( wait != BACKGR )
      n4grnd = n4grnd + 1
    call sys$setast( %val(1) )		# enable AST delivery
    status = OK
    if( wait == WAIT )
      andif( pwait( 1, desc, trm_info(1,1), desc, ORWAIT) == CHILD_ABORTED )
        status = CHILD_ABORTED
  }
}
call sreset( opnout, outfil)
if( outmod != ERR )
  junk = stmode( STDOUT, outmod)
call sreset( opnerr, errfil)
if( status == ERR | status == CHILD_ABORTED )
  call putpdb(offset)
return(status)

end
#-h- sreset           222  asc  25-mar-82 09:00:24  v1.1 (sw-tools v1.1)
### SReset	Reset channel assignment.

subroutine sreset( unit, file)

integer    unit, junk
integer    assign # function(s)
character  file(FILENAMESIZE)

if( unit != ERR )
  junk = assign( file, unit, APPEND)

return
end
#-h- srttim           455  asc  25-mar-82 09:00:24  v1.1 (sw-tools v1.1)
### SrtTim	???

subroutine srttim( date, out)

character  out(ARB), temp(10)
integer    date(2), i, idate(2), j, k, n, x
integer    itoc # function(s)
integer*2  jdate(4), y

equivalence( idate(1), jdate(1) ), ( x, y)

idate(1) = date(1)
idate(2) = date(2)
x = 0
k = 1
for( i = 4 ; i > 0 ; i = i - 1 )
{
  y = jdate(i)
  n = itoc( x, temp, 10)
  for( j = 6 ; j > n ; j = j - 1 )
    call chcopy( ' ', out, k)
  call stcopy( temp, 1, out, k)
}

return
end
#-h- stdflt          1189  asc  25-mar-82 09:00:25  v1.1 (sw-tools v1.1)
### StDflt	Reset current working directory.

subroutine stdflt( host, device, direct)

character  host(ARB), device(ARB), direct(ARB), lhost(FILENAMESIZE)
character  tstr(FILENAMESIZE)
integer    eql(2), i, init, log(2), status
integer    crelogsup, equal, sys$crelog, sys$setddir # function(s)

data init / YES / 

if( init == YES )
{
  call hostnm(lhost)
  init = NO
}
call fold(host)
i = 1
if( equal( host, lhost) != YES & host(1) != EOS )
{
  call stcopy( host, 1, tstr, i)
  call stcopy(  "::", 1, tstr, i)
}
call stcopy( device, 1, tstr, i)
call scopy(  ":", 1, tstr, i)
call upper(tstr)
# call remark(tstr)
call dscbld( log, "SYS$DISK" )
call dscbld( eql, tstr)
status = crelogsup( log, eql) # Try supervisor mode (dpm 9-Nov-81)
if( .not. status )
{
  status = sys$crelog( %val(2), log, eql, )
  if( .not. status )
  {
    call puthex( status, tstr)
    call putlin(  "Error in assigning sys$disk: ", ERROUT)
    call remark(tstr)
  }
}
call upper(direct)
# call remark(direct)
call dscbld( log, direct)
status = sys$setddir( log, , )
if( .not. status )
{
  call puthex( status, tstr)
  call putlin( "Error in setting default directory: ", ERROUT)
  call remark(tstr)
}

return
end
#-h- stdpth           318  asc  25-mar-82 09:00:27  v1.1 (sw-tools v1.1)
### StDPth	Reset current working directory from pathname.

subroutine stdpth(path)

character  path(ARB), temp(FILENAMESIZE), node(FILENAMESIZE)
character  device(FILENAMESIZE), direct(FILENAMESIZE)

call gendir(path, temp)
call parsef( temp, node, device, direct, temp)
call stdflt( node, device, direct)

return
end
#-h- stmode           618  asc  25-mar-82 09:00:28  v1.1 (sw-tools v1.1)
### StMode	Set I/O mode {COOKED|RARE|RAW} on channel `fd'.

integer    function stmode( fd, type)

filedes    fd
integer    type, temp
integer    rtopen # function(s)

include    io

if( 1 <= fd & fd <= MAXOFILES )
{
  if( lfn(fd) == TTYDEVICE & type != COOKED )
  {
    if( rtopen( filenm( 1, fd), rawchn(fd) ) == ERR )
      temp = COOKED
    else
      temp = type
  }
  else
    temp = COOKED
  chtype(fd) = temp
  if( temp == COOKED & rawchn(fd) != NODEVICE ) # (dpm 8-Jun-81)
  {
    call sys$dassgn( %val( rawchn(fd) ) )
    rawchn(fd) = NODEVICE # (dpm 8-Jun-81)
  }
  return(temp)
}
else
  return(ERR)
  
end
#-h- strhost          441  asc  25-mar-82 09:00:30  v1.1 (sw-tools v1.1)
### StrHost	Strip host field from `buf' if same as current host.

subroutine str_host( buf, temp)

character  buf(ARB), temp(ARB), scrat(FILENAMESIZE)
integer    i, junk
integer    equal, gtftok # function(s)

if( buf(1) != '/' | buf(2) != '@@' )	# (dpm 6-Jul-81)
  return

i = 3
junk = gtftok( buf, i, temp)
call fold(temp)					# (dpm 20-Nov-81)
call hostnm(scrat)
if( equal( scrat, temp) == YES )
  call scopy( buf, i, buf, 1)

return
end
#-h- ststat           274  asc  25-mar-82 09:00:32  v1.1 (sw-tools v1.1)
### StStat	set status on io channel to ( OK | ERR | TMO )

integer function ststat( fd, stat)

include io

filedes fd
integer stat

if( 1 <= fd & fd <= NNFILES )
  andif( stat == OK | stat == ERR | stat == TMO )
  {
    chstat(fd) = stat
    return(OK)
  }

return(ERR)
end
#-h- sttimo           201  asc  25-mar-82 09:00:33  v1.1 (sw-tools v1.1)
### StTimo	Set timeout for RAW reads on io channel.

subroutine sttimo( fd, sec)

include io

filedes fd
integer sec

if( 1 <= fd & fd <= NNFILES )
  andif( sec >= 0 )
    chtimo(fd) = sec

return
end
#-h- suspnd           252  asc  25-mar-82 09:00:35  v1.1 (sw-tools v1.1)
### Suspnd	Suspend process.

integer    function suspnd(buf)

character  buf(PIDSIZE)
integer    pid, status
integer    htoi, sys$suspnd # function(s)

pid = htoi(buf)
status = sys$suspnd( pid, )
if( .not. status )
  return(ERR)
else
  return(OK)

end
#-h- tran1            727  asc  25-mar-82 09:00:37  v1.1 (sw-tools v1.1)
### Tran1	Perform 1 level of logical name translation.
#  Return YES if translation occurred, else NO.

integer    function tran1( in, out)

character  buf1(64), buf2(64), in(100), out(100)
integer    dsc1(2), dsc2(2), n, status
integer    index, length, sys$trnlog # function(s)

if( in(1) == EOS )
{
  out(1) = EOS
  return(NO)
}
dsc1(2) = %loc(buf1)
dsc2(2) = %loc(buf2)
call strcpy( in, buf1)
dsc1(1) = length(buf1)
dsc2(1) = 64
status = sys$trnlog( dsc1, dsc2(1), dsc2, , , )
buf2( dsc2(1) + 1 ) = 0
if( buf2(1) == 27 )
{
  dsc2(1) = dsc2(1) - 4
  call scopy( buf2, 5, buf2, 1)
}
n = length(buf2)
if( buf2(n) == ':' )
  buf2(n) = EOS
call strcpy( buf2, out)

if( status == SS_NOTRAN )
  return(NO)
else
  return(YES)

end
#-h- trmlst          1324  asc  30-jul-83 18:01:31  tools (lblh csam sventek)
### TrmLst	List terminals user is logged in on.

integer		function trmlst( user, tlist)

character	user(ARB), tlist(ARB)
character	image(FILENAMESIZE)
character	cmd(MAXLINE), pid(PIDSIZE), scrfil(FILENAMESIZE)
character	lin(MAXLINE), name(FILENAMESIZE), term(FILENAMESIZE)
filedes		fd
filedes		open # function(s)
integer		i, junk, tcnt, tndx
integer		equal, getlin, getwrd, loccom, spawn, remove # function(s)

string		path   STD_PATH
string		suffix IMAGE_SUFFIX
string		blkgtr " >"
string		whostr "who"

call scratf( whostr, scrfil)
junk = loccom( whostr, path, suffix, image)
i = 1
call stcopy( whostr, 1, cmd, i)
call chcopy( ' ', cmd, i)
call stcopy( user, 1, cmd, i)
call stcopy( blkgtr, 1, cmd, i)
call stcopy( scrfil, 1, cmd, i)
if( spawn( image, cmd, pid, WAIT) == ERR )
  call error("? Can't spawn ``who''")
else
{
  fd = open( scrfil, READ)
  if( fd == ERR )
    call error("? Can't read scratch file")

  tcnt = 0
  tndx = 1
  call fold(user)
  while( getlin( lin, fd) != EOF )
  {
    i = 1
    call fold(lin)
    junk = getwrd( lin, i, term)
    junk = getwrd( lin, i, name)
    if( equal( user, name) == YES )
    {
      if( tndx > 1 )
        call chcopy( ' ', tlist, tndx)
      call stcopy( term, 1, tlist, tndx)
      tcnt = tcnt + 1
    }
  }
  call close(fd)
  junk = remove(scrfil)
}

return(tcnt)
end
#-h- trnlog           592  asc  25-mar-82 09:00:41  v1.1 (sw-tools v1.1)
### TrnLog	Tranlate (VMS) logical name from "in" to "out".

integer    function trnlog( in, out)

character  buf1(64), buf2(64), in(100), out(100)
integer    d1(2), d2(2), n, status
integer    length, sys$trnlog # function(s)

d1(2) = %loc(buf1)
d2(2) = %loc(buf2)
call strcpy( in, buf1)
d1(1) = length(in)

repeat
{
  d2(1) = 64
  status = sys$trnlog( d1, n, d2, , , %val(0) )
  buf2( n + 1 ) = 0
  if( buf2(1) == 27 )
  {
    n = n - 4
    call scopy( buf2, 5, buf2, 1)
  }
  d1(1) = n
  call strcpy( buf2, buf1)
}
until( status == SS_NOTRAN )

call strcpy( buf1, out)

return( d1(1) )
end
#-h- unique           182  asc  25-mar-82 09:00:43  v1.1 (sw-tools v1.1)
### Unique	Get current process ID as character string in `buf'.

subroutine unique(buf)

character  buf(ARB)
integer    mypid

call getpid(mypid)
call puthex(mypid, buf)

return
end
#-h- writef           321  asc  25-mar-82 09:00:44  v1.1 (sw-tools v1.1)
### WriteF	Write "n" bytes from "buf" onto "fd".

integer    function writef( buf, n, fd)

character  buf(ARB)
filedes    fd
integer    n
integer    puts # function(s)

include    io

if( 1 <= fd & fd <= NNFILES )
  andif( lfn(fd) != NODEVICE )
    andif( puts( fdb(fd), buf, n) != ERR )
      return(n)

return(ERR)
end
#-h- wtmsec           465  asc  25-mar-82 09:00:45  v1.1 (sw-tools v1.1)
### WtMSec	Wait `n' milliseconds.

subroutine wtmsec(n)

define( MILLISECOND,  -10000)
define( MAXMILLISECONDS, 1000)

integer    junk, m, n, timer_efn
integer    lib$get_ef, systim(2) # function(s)

data systim(2) / -1 / , timer_efn / 0 / 

if( timer_efn == 0 )
  junk = lib$get_ef( timer_efn )
m = max( n, 1)
m = min( m, MAXMILLISECONDS)
systim(1) = m * MILLISECOND
call sys$setimr( %val( timer_efn ), systim, , )
call sys$waitfr( %val( timer_efn ) )

return
end
#-h- lstchr           133  asc  25-mar-82 09:00:47  v1.1 (sw-tools v1.1)
character function lstchr(buf)

character buf(ARB), c
integer i

c = EOS
for (i=1; buf(i) != EOS; i=i+1)
  c = buf(i)
return(c)

end
#-h- dspprv          1210  asc  30-jul-83 18:12:29  tools (lblh csam sventek)
subroutine dspprv(which_priv)

character buf(arith(64,*,20)), word(20), out(MAXLINE), arg(FILENAMESIZE)
integer pid, nxtcol, i, j, n, status, which_priv, k

integer get_priv

string blanks "                   "
string divide "                   ----------------------------------@n"

call getpid(pid)
if (get_priv(which_priv, pid, arg, buf) == ERR)
  {
  call putlin(arg, ERROUT)
  call remark(": Error getting priveleges for process")
  }
else
  {
  call inpack(nxtcol, 80, out, ERROUT)
  call putlin(blanks, ERROUT)
  call putstr(arg, -17, ERROUT)
  call puthex(pid, arg)
  call putlin(arg, ERROUT)
  call putch(' ', ERROUT)
  switch (which_priv)
    {
    case JPI_AUTHPRIV: call putlin("authpriv", ERROUT)
    case JPI_CURPRIV: call putlin("curpriv", ERROUT)
    case JPI_IMAGPRIV: call putlin("imagpriv", ERROUT)
    case JPI_PROCPRIV: call putlin("procpriv", ERROUT)
    }
  call putch('@n', ERROUT)
  call putlin(divide, ERROUT)
  for (i=1; buf(i) != '@n'; )
    {
    for (j=1; buf(i) != EOS; i=i+1)
      call chcopy(buf(i), word, j)
    word(j) = EOS
    i = i + 1
    call dopack(word, nxtcol, 80, out, ERROUT)
    }
  call flpack(nxtcol, 80, out, ERROUT)
  call putch('@n', ERROUT)
  }

return
end
#-h- instal           473  asc  02-aug-83 10:10:30  tools (lblh csam sventek)
subroutine instal(name, defn)

character defn(ARB), name(ARB)
integer length
integer dlen, nlen

include clook

nlen = length(name) + 1
dlen = length(defn) + 1
if (lastt + nlen + dlen > MAX_TBL | lastp >= MAX_PTR)
   {
   call putlin(name, ERROUT)
   call putlnl(": too many definitions", ERROUT)
   return
   }
lastp = lastp + 1
namptr(lastp) = lastt + 1
call scopy(name, 1, table, lastt+1)
call scopy(defn, 1, table, lastt+nlen+1)
lastt = lastt + nlen + dlen

return
end
#-h- lookup           357  asc  02-aug-83 10:10:31  tools (lblh csam sventek)
integer function lookup(name, defn)

character name(ARB), defn(ARB)
integer i, j, k

include clook

for (i = lastp; i > 0; i = i - 1)
   {
   j = namptr(i)
   for (k = 1; name(k) == table(j) & name(k) != EOS; k = k + 1)
      j = j + 1
   if (name(k) == table(j))
      {
      call scopy(table, j+1, defn, 1)
      return(YES)
      }
   }
return(NO)

end
#-h- prim.m         41140  asc  19-oct-83 13:19:26  tools (lblh csam sventek)
#-h- cctype.mar       910  asc  28-jul-83 00:15:53  tools (lblh csam sventek)
	.title	cctype
;
;	this routine implements the following interface
;
;	crg_ctrl = cctype(fdb)
;
;	where fdb is the integer RAB address returned by the getfdb call
;
;	the value returned is
;
;	none(0) if no implied carriage control for records
;	fort(1) if fortran type carriage control
;	list(2) if list carriage control
;	prn(3)  if print carriage control
;
rab=4
none=0
fort=1
list=2
prn=3
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	cctype	^m<>
	movl	@rab(ap),r0		; get RAB address
	movl	rab$l_fab(r0),r0	; have FAB address
	movzbl	fab$b_rat(r0),r1	; have recort attribute byte
	bbs	#fab$v_cr,r1,20$	; list carriage control
	bbs	#fab$v_ftn,r1,10$	; fortran carriage control
	bbs	#fab$v_prn,r1,30$	; print carriage control
	movl	#none,r0		; NONE
	brb	40$
10$:
	movl	#fort,r0		; FORT
	brb	40$
20$:
	movl	#list,r0		; LIST
	brb	40$
30$:
	movl	#prn,r0			; PRINT
40$:
	ret
	.end
#-h- chmod.mar       1186  asc  28-jul-83 00:15:53  tools (lblh csam sventek)
	.title	ChMod
;
;	Change the mode (protection codes) of a file.
;
;	SYNOPSIS
;
;	stat = chmod( name, mode)
;
;	character name	- zero byte terminated string with file name
;	integer mode	- desired mode (see RMS manual for format)
;
;	integer stat	- OK | ERR
;
;	local definitions
;
ok=0			; software tools OK return
err=-3			; software tools ERR return
name=4			; ap offset to name of file
mode=8
;
;	local data
;
	.psect	st_chmod_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
xpro:	$xabpro
mfab:	$fab	fna=buf,-
		fop=cif,-
		xab=xpro
;
buf:	.blkb	120
;
;	entry point
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	chmod	^m<>
	pushal	buf
	pushl	name(ap)
	calls	#2,mklocl	; convert to DEC format name
	pushal	buf
	calls	#1,upper	; crunch it to upper case
	pushal	buf
	calls	#1,length	; calculate length of string
	movl	r0,r1		; move length to safe place
	$fab_store	fab=mfab,fns=r1	; store length of string
	$create	fab=mfab	; open file
	blbc	r0,error	; low bit clear indicates error
	mcomw	@mode(ap),xab$w_pro+xpro	; set protection
	$close	fab=mfab
	blbc	r0,error	; low bit clear indicates error
	movl	#ok,r0
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- chown.mar       1231  asc  28-jul-83 00:15:54  tools (lblh csam sventek)
	.title	ChOwn
;
;	Change the owner and group of a file.
;
;	SYNOPSIS
;
;	stat = chown( name, owner, group)
;
;	character name	- zero byte terminated string with file name
;	integer owner	- integer for owner number
;	integer group	- integer for group number
;
;	integer stat	- OK | ERR
;
;	local definitions
;
ok=0			; software tools OK return
err=-3			; software tools ERR return
name=4			; ap offset to name of file
owner=8
group=12
;
;	local data
;
	.psect	st_chown_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
xpro:	$xabpro
mfab:	$fab	fna=buf,-
		fop=cif,-
		xab=xpro
;
buf:	.blkb	120
;
;	entry point
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	chown	^m<>
	pushal	buf
	pushl	name(ap)
	calls	#2,mklocl	; convert to DEC format name
	pushal	buf
	calls	#1,upper	; crunch it to upper case
	pushal	buf
	calls	#1,length	; calculate length of string
	movl	r0,r1		; move length to safe place
	$fab_store	fab=mfab,fns=r1	; store length of string
	$create	fab=mfab	; open file
	blbc	r0,error	; low bit clear indicates error
	movw	@group(ap),xab$w_grp+xpro	; set group number
	movw	@owner(ap),xab$w_mbm+xpro	; set member number
	$close	fab=mfab
	movl	#ok,r0
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- closef.mar       894  asc  28-jul-83 00:15:55  tools (lblh csam sventek)
	.title	closef
;
;	subroutine to close file opened with tools openf
;
;	call sequence:	call closef(rab)
;
;	where rab is the integer descriptor returned by openf
;
rab=4					; offset from ap for rab address
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	closef	^m<r2,r3>
	movl	@rab(ap),r2		; place rab address in r2
	movl	rab$l_fab(r2),r3	; fab address in r3
	blbc	rab$l_ctx(r2),10$	; lbc ==> do not truncate file
	bbs	#1,rab$l_ctx(r2),10$	; bit 1 set ==> put was done
	$find	rab=r2			; position to first record
	$truncate rab=r2		; truncate file
10$:
	clrl	rab$l_ctx(r2)		; clear context
	$disconnect	rab=r2		; disconnect record stream
	blbc	r0,error		; low bit clear in r0 => error
	$close	fab=r3			; close file
	blbc	r0,error		; again check for error
	pushl	r2			; place rab address on stack
	calls	#1,putrab		; return rab to linked list
	ret
error:
	ret
	.end
#-h- crelogsup.mar    312  asc  28-jul-83 00:15:55  tools (lblh csam sventek)
	.title	CreLogSup -- Create logical name in supervisor mode

crelogsup::
start:
	.word	^m<r2,r3>
	movl	4(ap),r2
	movl	8(ap),r3
	$cmexec_s	routin=setvar
	ret


setvar:
	.word	0
	pushl	#2	;acmode
	pushl	r3	;eqlnam
	pushl	r2	;lognam
	pushl	#2	;tblflg, 0 system, 1 group, 2 process
	calls	#4,g^sys$crelog
	ret
	.end
#-h- decnfo.mar      2226  asc  28-jul-83 00:15:56  tools (lblh csam sventek)
	.title	decnfo
;
;
;	subroutine to return information on a file for directory listings
;
;
;	invocation:
;
;	stat = decnfo(name, date, group, member, protection, eof, free, ftype)
;
;	character name	- zero byte terminated string with file name
;	integer date(2) - quadword for date
;	integer group	- integer for group number
;	integer member	- integer for member number
;	integer protect	- integer to hold protection mask
;	integer eof	- block number containing eof
;	integer free	- first free byte of eof block
;	integer ftype	- file type (ASCII | BINARY)
;
;	function return - OK | ERR
;
;
;	local definitions
;
ok=0			; software tools OK return
err=-3			; software tools ERR return
ascii=12		; software tools ASCII
binary=60		; software tools BINARY
name=4			; ap offset to name of file
date=8			; ap offset to date quadword
group=12
member=16
protection=20
eof=24
free=28
ftype=32
;	local data
;
	.psect	st_decnfo_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
xdat:	$xabdat	nxt=xpro
xpro:	$xabpro	nxt=xfhc
xfhc:	$xabfhc
mfab:	$fab	fac=get,-
		fna=buf,-
		shr=<get,upi>,-
		xab=xdat
buf:	.blkb	120
;
;	entry point
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	decnfo	^m<>
	pushal	buf
	pushl	name(ap)
	calls	#2,strcpy	; copy string into buf
	pushal	buf
	calls	#1,upper	; crunch it to upper case
	pushal	buf
	calls	#1,length	; calculate length of string
	movl	r0,r1		; move length to safe place
	$fab_store	fab=mfab,fns=r1	; store length of string
	$open	fab=mfab	; open file to get info
	blbc	r0,error	; low bit clear indicates error
	movq	xab$q_rdt+xdat,@date(ap)	; return revision date
	bneq	gotit
	movq	xab$q_cdt+xdat,@date(ap)	; return creation date
gotit:
	movzwl	xab$w_grp+xpro,@group(ap)	; return group number
	movzwl	xab$w_mbm+xpro,@member(ap)	; return member number
	movzwl	xab$w_pro+xpro,@protection(ap)	; return protection
	movl	xab$l_ebk+xfhc,@eof(ap)		; return eof block
	movzwl	xab$w_ffb+xfhc,@free(ap)	; return free byte
	movl	#ascii,@ftype(ap)		; assume ASCII file
	bitb	#fab$c_var,mfab+fab$b_rfm	; see if variable length recs
	bneq	ischar				; if !=, is ASCII file
	movl	#binary,@ftype(ap)
ischar:
	$close	fab=mfab
	movl	#ok,r0
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- devtyp.mar       540  asc  28-jul-83 00:15:57  tools (lblh csam sventek)
	.title	devtyp
;
;	function to return the the device type for the particular unit
;
;	calling sequence	type = devtyp(rab)
;
;		where rab is the integer  descriptor returned by openf
;
ttydevice=1
mbxdevice=2
otherdevice=3
rab=4
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	devtyp	^m<>
	movl	@rab(ap),r1
	movl	rab$l_fab(r1),r0
	movl	fab$l_dev(r0),r1
	bbc	#dev$v_trm,r1,10$
	movl	#ttydevice,r0
	brb	getout
10$:	bbc	#dev$v_mbx,r1,20$
	movl	#mbxdevice,r0
	brb	getout
20$:	movl	#otherdevice,r0
getout:
	ret
	.end
#-h- directory.mar   2687  asc  28-jul-83 00:15:57  tools (lblh csam sventek)
	.title	directory
ok=0
eof=-1
err=-3
;
;	linked list of FAB's for directory routines
;
next_fab=-4		; offset from FAB to pointer to next FAB
fab_10=0		; end of list
exp_str_size=100	; size of expanded string
;
;	free list listhead
;
	.psect	st_directory_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
free_fab:	.address	fab_0
		.address	fab_1
fab_0:		$fab	nam=nam_0
nam_0:		$nam	esa=esb_0,ess=exp_str_size
esb_0:		.blkb	exp_str_size
		.address	fab_2
fab_1:		$fab	nam=nam_1
nam_1:		$nam	esa=esb_1,ess=exp_str_size
esb_1:		.blkb	exp_str_size
		.address	fab_3
fab_2:		$fab	nam=nam_2
nam_2:		$nam	esa=esb_2,ess=exp_str_size
esb_2:		.blkb	exp_str_size
		.address	fab_4
fab_3:		$fab	nam=nam_3
nam_3:		$nam	esa=esb_3,ess=exp_str_size
esb_3:		.blkb	exp_str_size
		.address	fab_5
fab_4:		$fab	nam=nam_4
nam_4:		$nam	esa=esb_4,ess=exp_str_size
esb_4:		.blkb	exp_str_size
		.address	fab_6
fab_5:		$fab	nam=nam_5
nam_5:		$nam	esa=esb_5,ess=exp_str_size
esb_5:		.blkb	exp_str_size
		.address	fab_7
fab_6:		$fab	nam=nam_6
nam_6:		$nam	esa=esb_6,ess=exp_str_size
esb_6:		.blkb	exp_str_size
		.address	fab_8
fab_7:		$fab	nam=nam_7
nam_7:		$nam	esa=esb_7,ess=exp_str_size
esb_7:		.blkb	exp_str_size
		.address	fab_9
fab_8:		$fab	nam=nam_8
nam_8:		$nam	esa=esb_8,ess=exp_str_size
esb_8:		.blkb	exp_str_size
		.address	fab_10
fab_9:		$fab	nam=nam_9
nam_9:		$nam	esa=esb_9,ess=exp_str_size
esb_9:		.blkb	exp_str_size
;
;	start of code
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
;
;	integer function dopen(name, length, fab)
;
;	return(OK/ERR)
;
name=4
length=8
fab=12
;
	.entry	dopen	^m<r2>
	movl	free_fab,r2		; address of next free FAB
	beql	10$			; if == 0, none left
	movl	next_fab(r2),free_fab	; unlink FAB from list
	$fab_store	fab=r2,fna=@name(ap),fns=@length(ap)
	$parse		fab=r2
	blbc	r0,20$			; lbc => error
	movl	r2,@fab(ap)		; return FAB address
	movl	#ok,r0			; return(OK)
	ret
20$:
	movl	r2,free_fab		; link back into free list
10$:
	movl	#err,r0			; return(ERR)
	ret
;
;	subroutine dclose(fab)
;
fab=4
;
	.entry	dclose	^m<>
	movl	@fab(ap),r0		; FAB address
	movl	free_fab,next_fab(r0)	; link back into free list
	movl	r0,free_fab		; ...
	ret
;
;	integer function dfind(fab, buf)
;
;	return(OK/EOF)
;
fab=4
buf=8
;
	.entry	dfind	^m<r2,r3>
	movl	@fab(ap),r3		; FAB address
	movl	fab$l_nam(r3),r2	; NAM address
	$nam_store	nam=r2,rsa=@buf(ap),rss=#exp_str_size,rsl=#0
	$search		fab=r3		; find next file in directory
	blbc	r0,30$			; lbc => error
	movzbl	nam$b_rsl(r2),r0	; length of resultant string
	addl2	buf(ap),r0		; address of first free char
	clrb	(r0)			; terminate with EOS
	movl	#ok,r0			; return(OK)
	ret
30$:
	movl	#eof,r0			; return(EOF)
	ret
	.end
#-h- fdel.mar         670  asc  28-jul-83 00:15:58  tools (lblh csam sventek)
	.title	fdel
;
;	subroutine to delete a file opened by the software tools io
;	primitives
;
;	call sequence	status = fdel(rab)
;
;	where	rab is the integer descriptor from an openf call
;		status is OK(0) or ERR(-3)
;
rab=4
ok=0
err=-3
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	fdel	^m<r2,r3>
	movl	@rab(ap),r3		; rab address in r3
	movl	rab$l_fab(r3),r2	; fab address in r2
	pushal	@rab(ap)		; place address on stack
	calls	#1,closef		; make sure file is closed
	$erase	fab=r2			; delete file
	blbc	r0,error		; low bit clear => error
	movl	#ok,r0			; return success status
	ret
error:
	movl	#err,r0			; return error status
	ret
	.end
#-h- gets.mar        1232  asc  28-jul-83 00:15:59  tools (lblh csam sventek)
	.title	gets
;
;	function to read a record from a VMS file
;
;	call sequence	n = gets(rab, buffer, size)
;
;	where	rab is the integer descriptor from an openf call
;		buffer is a character buffer to receive the record
;		size is the size of the buffer
;
;	returns	-3(ERR) if error reading record
;		number of bytes read if successful
;
err=-3
rab=4					; offset from ap for rab address
buf=8					; offset from ap for buf address
siz=12					; offset from ap for size of buf
	.psect	st_gets_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
msg:	.ascid	"Record too large for buffer - truncated"
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	gets	^m<r2>
	movl	@rab(ap),r2		; rab address in r2
	movl	buf(ap),rab$l_ubf(r2)	; user buffer address in rab
	movw	@siz(ap),rab$w_usz(r2)	; size of buffer in rab
	$get	rab=r2
	blbs	r0,10$			; low bit set => success
	cmpl	r0,#rms$_rtb		; record too big?
	bneq	error			; no, real hard error
	pushal	msg			; report error to user
	calls	#1,g^lib$put_output	; ...
10$:
	movzwl	rab$w_rsz(r2),r0	; number of bytes in record returned
	movl	rab$w_rfa(r2),rab_l_curbl(r2)	; save current RFA
	movw	rab$w_rfa+4(r2),rab_l_curby(r2)	;
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- main.mar         252  asc  30-jul-83 17:20:30  tools (lblh csam sventek)
	.title	tools$main
;
;	this is the dummy main program to cause the tools run-time system
;	to be invoked
;
ok:	.long	0	; software tools OK status return
;
start:	.word	0
	calls	#0,g^initst
	calls	#0,g^main
	pushal	ok
	calls	#1,g^endst
	ret
	.end	start
#-h- mark.mar         530  asc  28-jul-83 00:16:00  tools (lblh csam sventek)
	.title	mark
;
;	subroutine to mark position of next record in file
;
;	call sequence	call mark(rab, adr1, adr2)
;
;	where	rab is the integer descriptor from an openf call
;		adr1 is the address to receive the first address field
;		adr2 is the address to receive the second address field
;
rab=4
adr1=8
adr2=12
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	mark	^m<r2>
	movl	@rab(ap),r2		; rab address in r2
	movl	rab_l_curbl(r2),@adr1(ap)	; return RFA
	movw	rab_l_curby(r2),@adr2(ap)	;
	ret
	.end
#-h- myopen.mar       896  asc  28-jul-83 00:16:01  tools (lblh csam sventek)
	.title	myopen
	$namdef
	.psect	st_myopen_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
myfab:	$fab	fna=myfna,nam=mynam
myfna:	.blkb	64
myesa:	.blkb	64
mynam:	$nam	esa=myesa,ess=64
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	myopen	^m<r2,r3,r4,r5,r6,r7,r8>
	moval	myfab,r3			; fab address in r3
	clrl	r2				; r2 is character counter
	movab	myfna,r1			; destination array
	movl	4(ap),r0			; source array
loop:
	cmpb	#0,(r0)
	beql	endstr
	movb	(r0)+,(r1)+
	incl	r2
	brb	loop
endstr:
	movb	r2,fab$b_fns(r3)
	$parse	fab=r3
	$search	fab=r3
	moval	mynam,r8			; address of nam in r8
	addl3	#nam$t_dvi,r8,r6		; source address in r6
	addl3	#18,8(ap),r7			; destination addr in r7
	movc3	#16,(r6),(r7)			; copy characters
	addl3	#nam$w_fid,r8,r6		;
	addl3	#34,8(ap),r7
	movc3	#6,(r6),(r7)
	addl3	#nam$w_did,r8,r6
	addl3	#40,8(ap),r7
	movc3	#6,(r6),(r7)
	ret
	.end
#-h- openf.mar       5057  asc  28-jul-83 00:44:09  tools (lblh csam sventek)
	.title	openf
;
;	function called from fortran to open rms files for
;	software tools
;
;	calling sequence:
;		status = openf(ext, ftype, ccontrol, access, age, rab)
;
;		character ext	 ; array with file name (assumed in upper case)
;		integer ftype	 ; file type -- character(0) or binary(1)
;		integer ccontrol ; list(0) or fort(1)
;		integer access	 ; read(1), write(2), readwrite(3), append(4)
;		integer age	 ; old(-1), unk(0), or new(1)
;		integer rab	 ; descriptor to be used with all file prims
;
;		status returned:	err	if error
;					ftype	if successful
;
;	necessary parameters (values of rat4 symbols)
;
err=-3
character=0
binary=1
ext=4
typ=8
cc=12
acc=16
age=20
rab=24
	$devdef		; Device chracteristics
	.psect	st_openf_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
name_block:	$nam	; name block for determining process-permanent files
;
;
;	start of code
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	openf	^m<r2,r3>
	calls	#0,getrab		; get a rab address
	movl	r0,r3			; move rab to non-volatile register
	bneq	10$
	brw	operr			; if 0, no rab's available
10$:
	movl	rab$l_fab(r3),r2	; fab address in r2
     $fab_store fab=r2,-		; runtime initialization of fab
		mrs=#0,-		; no maximum record size
		org=seq,-		; seqential organization
		alq=#0,-		; no initial alocation on new files
		fsz=#0,-		; no vfc fields on created files
		fop=tef,-		; truncate file upon closing
		shr=<get,upi>,-		; read sharing if writing file
		rfm=var			; assume character file
     $rab_store rab=r3,-		; runtime initialization of rab
		rac=seq			; sequential record access
	clrl	rab$l_rop(r3)		; clear record processing options
	pushl	ext(ap)			; address of file name on stack
	calls	#1,length		; calculate its length
	pushr	#^m<r0,r1,r2,r3,r4,r5>	; save registers affected by movc
	movc3	r0,@ext(ap),@fab$l_fna(r2) ; copy string into fna buffer
	popr	#^m<r0,r1,r2,r3,r4,r5>	; restore registers
	movb	r0,fab$b_fns(r2)	; size of filespec in fab
	blbc	@typ(ap),cctrl		; if lbc, character file
     $fab_store fab=r2,-		; set up fab for binary file
		rfm=fix,-		; fixed-length records
		mrs=#512		; 512 byte blocks
		brb	access		; skip carriage control stuff
cctrl:
	$fab_store	fab=r2,rat=cr	; assume list carriagecontrol
	blbc	@cc(ap),access		; list carriage control
     $fab_store fab=r2,rat=ftn		; fortran carriage control
access:
	casel	@acc(ap),#1,#4		; case on access mode
case1:	.word	read-case1		; READ
	.word	write-case1		; WRITE
	.word	readwr-case1		; READWRITE
	.word	append-case1		; APPEND
	brw	conerr			; out of range
read:
     $fab_store fab=r2,fac=<get,bro>,-	; read access
		shr=<get,put,upi>	; permit one writer, many readers
     $rab_store	rab=r3,rop=<rah>	; enable readahead
	brb	type
write:
     $fab_store fab=r2,fac=<put,trn,bro>; write access
     $rab_store	rab=r3,rop=<wbh,tpt>	; write behind and truncate
	brb	type
readwr:
     $fab_store	fab=r2,fac=<get,put,trn,bro>	; readwrite access
     $rab_store rab=r3,rop=<wbh,tpt>
	brb	type
append:
     $fab_store fab=r2,fac=<put,trn,bro> ; append access
     $rab_store rab=r3,rop=<tpt,eof,wbh> ; connect at EOF
type:
	moval	name_block,fab$l_nam(r2); fill in name block upon open
	addl3	#1,@age(ap),r0		; place age + 1 in r0
	casel	r0,#0,#2		; case on age + 1
case2:	.word	old-case2		; OLD file
	.word	unk-case2		; UNKNOWN file
	.word	new-case2		; NEW file
	brw	conerr			; out of range
old:
	$open	fab=r2
	brb	tsterr
unk:
     $fab_store fab=r2,fop=<cif,tef>	; create if
new:
	$create fab=r2
tsterr:
	clrl	fab$l_nam(r2)		; no longer need name block
	blbs	r0,25$			; low bit set ==> success
	brw	conerr			; ERROR
25$:
	bbs	#nam$v_ppf,name_block+nam$l_fnb,20$	; no delete if process
							; permanent file
	bbc	#dev$v_fod,fab$l_dev(r2),20$	; dont close non-FODs
	cmpl	@acc(ap),#2		; WRITE access?
	bneq	20$			; NO
	bbs	#fab$v_ftn,fab$b_rat(r2),20$	; no remove/create if cctrl
	bbs	#fab$v_cr,fab$b_rat(r2),20$	; ...
	$close	fab=r2			; close the file
	$erase	fab=r2			; delete the file
     $fab_store fab=r2,fop=tef		; truncate file upon closing
	bisb	#fab$m_cr,fab$b_rat(r2)	; set to LIST carriage control
30$:
	$create	fab=r2			; create new file
20$:
	movl	r3,@rab(ap)		; return rab address
       $connect rab=r3			; connect record stream
	blbc	r0,conerr		; lbc => ERROR
	clrl	rab$l_ctx(r3)		; 0 ==> do not truncate at close
	bbs	#nam$v_ppf,name_block+nam$l_fnb,40$ ; leave proc perm file alone
	bbc	#dev$v_fod,fab$l_dev(r2),40$	; as well as non-FODs
	cmpl	@acc(ap),#2		; WRITE access?
	bneq	40$			; NO
	bbs	#fab$v_ftn,fab$b_rat(r2),50$	; FTN carriage control?
	bisb	#fab$m_cr,fab$b_rat(r2)		; set to LIST carriage ctrl
50$:
;	$rewind	rab=r3			; find first record; guarantees tpt
	incl	rab$l_ctx(r3)		; 1 == > truncate file at close
40$:
	movl	#character,r0		; assume a character file
	bitb	#fab$c_var,fab$b_rfm(r2); check for file type
	bneq	done
	movl	#binary,r0		; have a binary file
done:
	ret
conerr:
	$close	fab=r2			; close file
	pushl	r3
	calls	#1,putrab		; return rab to linked list
operr:
	movl	#err,r0			; return error status
	ret
	.end
#-h- point.mar       1294  asc  28-jul-83 00:16:03  tools (lblh csam sventek)
	.title	point
;
;
;	subroutine which positions software tools file to a specific
;	disk address.
;
;	call sequence:	status = point(rab, addr1, addr2)
;
;	where
;		rab is the integer descriptor from the openf call
;		addr1,addr2 are the integers returned by a markl call
;
;	returns
;		OK(0) if successful
;		EOF(-1) if successful and at end of file
;		ERR(-3) if any error in positioning file
;
;
ok=0
eof=-1
err=-3
rab=4
adr1=8
adr2=12
;
;
;	local buffer for dummy reads
;
	.psect	st_point_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
buf:	.blkb	4
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	point	^m<r2>
	movl	@rab(ap),r2			; rab address in r2
	movl	@adr1(ap),rab$w_rfa(r2)		; copy block number
	beql	rewind				; if 0, rewind file
	movw	@adr2(ap),rab$w_rfa+4(r2)	; copy byte offset
	movb	rab$b_rac(r2),-(sp)		; save old rac
     $rab_store rab=r2,rac=rfa			; set to RFA
	$find	rab=r2				; position file
	movb	(sp)+,rab$b_rac(r2)		; restore rac field
	moval	buf,rab$l_ubf(r2)		; set up for dummy read
	movw	#4,rab$w_usz(r2)		;
	$get	rab=r2				; get sets up next record
	brb	retrn
rewind:
	$rewind	rab=r2				; rewind file to set next rec
retrn:
	movl	@adr1(ap),rab_l_curbl(r2)	; fill in current record
	movzwl	@adr2(ap),rab_l_curby(r2)	;
	ret
	.end
#-h- puts.mar        1227  asc  19-oct-83 13:18:18  tools (lblh csam sventek)
	.title	puts
;
;	subroutine to put a record to a VMS file
;
;	call sequence	status = puts(rab, buffer, n)
;
;	where	rab is the integer descriptor from an openf call
;		buffer is the buffer containing the record to be put
;		n is the number of bytes to put
;
;	status returned is OK or ERR
;
err=-3
ok=0
rab=4
buf=8
num=12
	.psect	st_puts_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
inpdsc:	.long	256
	.address	errbuf
outdsc:	.long	256
	.address	errbuf
errbuf:	.blkb	256
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.enabl	lsb
	.entry	puts	^m<r2,r3>
	movl	#1,r3			; initialize retry count
	movl	@rab(ap),r2		; rab address in r2
	movl	buf(ap),rab$l_rbf(r2)	; buffer address in rab
	movw	@num(ap),rab$w_rsz(r2)	; # of bytes to put
1$:
	$put	rab=r2
	blbc	r0,error		; low bit clear => error
	movl	rab$w_rfa(r2),rab_l_curbl(r2)	; save RFA
	movzwl	rab$w_rfa+4(r2),rab_l_curby(r2)	;
	bisl2	#2,rab$l_ctx(r2)	; set bit to indicate that put was done
	movl	#ok,r0
	ret
error:
	decl	r3			; decrement retry count
	beql	1$			; try it again
	$getmsg_s	rab$l_stv(r2),outdsc,inpdsc	; format message
	pushal	outdsc			; arg for lib$put_output
	calls	#1,g^lib$put_output	; tell the user
	movl	#err,r0
	ret
	.end
#-h- rablst.mar      2925  asc  28-jul-83 00:16:04  tools (lblh csam sventek)
	.title	rablst
;
;	functions to get and put rms data structures
;	used by openf and closef for software tools
;
;	calling sequences:
;		rab = getrab(0) ; argument is a dummy one
;		call putrab(rab)
;
;
;	linked list of rab's and fab's follow:
;
rab_l_next==-12
rab_l_curbl==-8
rab_l_curby==-4
	.psect	st_rablst_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
rabhd:	.address	rab1
	;rab1
	.address	rab2
	.blkl	1
	.blkl	1
rab1:	$rab	fab=fab1
fab1:	$fab	fna=fna1
fna1:	.blkb	104
	;rab2
	.address	rab3
	.blkl	1
	.blkl	1
rab2:	$rab	fab=fab2
fab2:	$fab	fna=fna2
fna2:	.blkb	104
	;rab3
	.address	rab4
	.blkl	1
	.blkl	1
rab3:	$rab	fab=fab3
fab3:	$fab	fna=fna3
fna3:	.blkb	104
	;rab4
	.address	rab5
	.blkl	1
	.blkl	1
rab4:	$rab	fab=fab4
fab4:	$fab	fna=fna4
fna4:	.blkb	104
	;rab5
	.address	rab6
	.blkl	1
	.blkl	1
rab5:	$rab	fab=fab5
fab5:	$fab	fna=fna5
fna5:	.blkb	104
	;rab6
	.address	rab7
	.blkl	1
	.blkl	1
rab6:	$rab	fab=fab6
fab6:	$fab	fna=fna6
fna6:	.blkb	104
	;rab7
	.address	rab8
	.blkl	1
	.blkl	1
rab7:	$rab	fab=fab7
fab7:	$fab	fna=fna7
fna7:	.blkb	104
	;rab8
	.address	rab9
	.blkl	1
	.blkl	1
rab8:	$rab	fab=fab8
fab8:	$fab	fna=fna8
fna8:	.blkb	104
	;rab9
	.address	raba
	.blkl	1
	.blkl	1
rab9:	$rab	fab=fab9
fab9:	$fab	fna=fna9
fna9:	.blkb	104
	;raba
	.address	rabb
	.blkl	1
	.blkl	1
raba:	$rab	fab=faba
faba:	$fab	fna=fnaa
fnaa:	.blkb	104
	;rabb
	.address	rabc
	.blkl	1
	.blkl	1
rabb:	$rab	fab=fabb
fabb:	$fab	fna=fnab
fnab:	.blkb	104
	;rabc
	.address	rabd
	.blkl	1
	.blkl	1
rabc:	$rab	fab=fabc
fabc:	$fab	fna=fnac
fnac:	.blkb	104
	;rabd
	.address	rabe
	.blkl	1
	.blkl	1
rabd:	$rab	fab=fabd
fabd:	$fab	fna=fnad
fnad:	.blkb	104
	;rabe
	.address	rabf
	.blkl	1
	.blkl	1
rabe:	$rab	fab=fabe
fabe:	$fab	fna=fnae
fnae:	.blkb	104
	;rabf
	.long	0
	.blkl	1
	.blkl	1
rabf:	$rab	fab=fabf
fabf:	$fab	fna=fnaf
fnaf:	.blkb	104
;
;
;	entry point for getrab
;
;		call sequence:	rab = getrab(0)
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	getrab	^m<>
	moval	rabhd,r1		; listhead in r1
	movl	(r1),r0			; address of free node in r0
	beql	retrn			; if 0, then no more free nodes
	movl	rab_l_next(r0),(r1)	; relink list
	clrl	rab_l_curbl(r0)		; initialize current block value
	clrl	rab_l_curby(r0)		; initialize current byte value
retrn:
	ret
;
;
;	entry point for putrab
;
;		call sequence	call putrab(%val(rab))
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	putrab	^m<>
	movl	4(ap),r0		; address of node to be returned
	movl	rabhd,r1		; address of first free node in r1
loop:
	tstl	r1
	beql	retok			; have reached end of linked list
	cmpl	r0,r1			; compare addresses of nodes
	beql	notok			; user trying to return node twice
	movl	rab_l_next(r1),r1	; address of next free node in r1
	brb	loop
retok:
	moval	rabhd,r1		; listhead in r1
	movl	(r1),rab_l_next(r0)	; returned node points to top node
	movl	r0,(r1)			; listhead now points to returned node
notok:
	ret
	.end
#-h- rdpmpt.mar      1465  asc  28-jul-83 00:16:05  tools (lblh csam sventek)
	.title	rdpmpt
;
;	function to read a record from a VMS file, prompting first
;
;	call sequence	n = rdpmpt(rab, prompt, psize, buffer, size)
;
;	where	rab is the integer descriptor from an openf call
;		prompt is the prompt string
;		psize is the length of the prompt string
;		buffer is a character buffer to receive the record
;		size is the size of the buffer
;
;	returns	-3(ERR) if error reading record
;		number of bytes read if successful
;
err=-3
rab=4					; offset from ap for rab address
pmt=8					; offset from ap for prompt address
psz=12					; offset from ap for prompt length
buf=16					; offset from ap for buf address
siz=20					; offset from ap for size of buf
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	rdpmpt	^m<r2>
	movl	@rab(ap),r2		; rab address in r2
	movl	buf(ap),rab$l_ubf(r2)	; user buffer address in rab
	movw	@siz(ap),rab$w_usz(r2)	; size of buffer in rab
	movl	pmt(ap),rab$l_pbf(r2)	; prompt buffer address in rab
	movb	@psz(ap),rab$b_psz(r2)	; length of prompt buffer in rab
	bisl	#rab$m_pmt,rab$l_rop(r2)	; set bit for prompting
	$get	rab=r2
	bicl	#rab$m_pmt,rab$l_rop(r2)	; turn off prompting
	blbc	r0,error		; low bit clear => error
	movzwl	rab$w_rsz(r2),r0	; number of bytes in record returned
	addl3	r0,buf(ap),r1		; address of first free byte
	movb	#10,(r1)+		; append NEWLINE character
	clrb	(r1)			; terminate with EOS
	incl	r0			; include NEWLINE in count
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- reads.mar       1090  asc  28-jul-83 00:16:05  tools (lblh csam sventek)
	.title	reads
;
;	function to read a block from a VMS file
;
;	call sequence	n = reads(rab, start, buffer, size)
;
;	where	rab is the integer descriptor from an openf call
;		start	is the starting virtual block number for read
;		buffer is a character buffer to receive the block
;		size is the size of the buffer
;
;	returns	-3(ERR) if error reading record
;		number of bytes read if successful
;
err=-3
eof=-1
rab=4					; offset from ap for rab address
start=8					; offset from ap for start VBN
buf=12					; offset from ap for buf address
siz=16					; offset from ap for size of buf
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	reads	^m<r2>
	movl	@rab(ap),r2		; rab address in r2
	movl	@start(ap),rab$l_bkt(r2); starting block number
	movl	buf(ap),rab$l_ubf(r2)	; user buffer address in rab
	movw	@siz(ap),rab$w_usz(r2)	; size of buffer in rab
	$read	rab=r2
	blbc	r0,error		; low bit clear => error
	movzwl	rab$w_rsz(r2),r0	; number of bytes in record returned
	ret
error:
	cmpl	r0,#rms$_eof
	bneq	iserr
	movl	#eof,r0
	ret
iserr:
	movl	#err,r0
	ret
	.end
#-h- rename.mar      1100  asc  28-jul-83 00:16:06  tools (lblh csam sventek)
	.title	rename
;
;
;	routine renames files using RMS
;
;	call sequence:	status = rename(name1, name2)
;
;	inputs:	name1, name2  are old and new names for file
;
;	outputs:	OK(0) if successful
;			ERR(-3) if error
;
;
esssize=104			; size of expanded string
name1=4				; ap offset of name1
name2=8
ok=0
err=-3
	.psect	st_rename_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
nam1:	$nam	esa=esa1,ess=esssize
nam2:	$nam	esa=esa2,ess=esssize
fab1:	$fab	nam=nam1
fab2:	$fab	nam=nam2
esa1:	.blkb	esssize
esa2:	.blkb	esssize
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	rename	^m<r2,r3>
	moval	fab1,r2				; oldfab in r2
	moval	fab2,r3				; newfab in r3
	movl	name1(ap),fab$l_fna(r2)		; place string address in fab
	pushl	name1(ap)
	calls	#1,length			; calculate length of filespec
	movb	r0,fab$b_fns(r2)		; length of filespec in fab
	movl	name2(ap),fab$l_fna(r3)		; same for new filespec
	pushl	name2(ap)
	calls	#1,length
	movb	r0,fab$b_fns(r3)
	$rename	oldfab=r2, newfab=r3
	blbc	r0,error			; low bit clear => ERROR
	movl	#ok,r0
	ret
error:
	movl	#err,r0
	ret
	.end
#-h- system.mar      6512  asc  28-jul-83 00:16:07  tools (lblh csam sventek)
	.title	system
	.sbttl	comments and symbol definitions
;+
;	integer function system(buffer)
;
;	character buffer(ARB)
;
;	return(0/1) if spawn failed/succeeded
;
;	the EOS-terminated command in buffer is spawned to the local
;	command interpreter (DCL).  If the spawn succeeded, a value of
;	1 is returned, else 0.  If buffer contains a null command, a
;	value of 1 is returned.
;
;	sys$system:loginout.exe is spawned as a sub-process reading
;	a mailbox for its input.  After some preliminary DCL commands
;	to force the environment to be correct, the command in buffer
;	is executed as
;
;	@st_bin:dodcl/out='term' 'command'
;
;	where 'term' is replaced by the translation of TT and 'command'
;	is the user specified command.  This command procedure is
;	designed to perform some more hacks to get the environment in
;	shape and to define the tools as foreign symbols.
;-
	$jpidef
	$dibdef
	$accdef
	$pqldef
	$devdef
buffer=4
	.page
	.sbttl	impure data
;
;	impure data
;
	.psect	st_system_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
pid:	.blkl	1		; our pid goes here
prib:	.blkl	1		; our base priority goes here
authpr:	.blkq	1		; our authorization privelege mask goes here
pidbuf:	.blkb	8		; buffer for formatted pid
trmbuf:	.ascii	"SYSTRM"	; name of termination mailbox
trmpid:	.blkb	8		; ...
argbuf:	.ascii	"SYSARG"	; name of argument mailbox
argpid:	.blkb	8		; ...
prcbuf:	.ascii	"SYS"		; sub-process name
prcpid:	.blkb	8		; ...
trmchn:	.blkw	1		; space for termination mailbox channel
trmunt:	.blkw	1		; space for termination mailbox unit
buf:	.blkb	512		; termporary buffer
ttybuf:	.blkb	64		; buffer for TT translation
dumdsc:	.blkq	1		; dummy descriptor
ttydsc:	.long	64		; resultant buffer for trnlog of TT
	.address	ttybuf		; ...
length:	.blkw	1		; location for length
cmddsc:	.blkq	1		; command descriptor
argchn:	.blkw	1		; location for argument mailbox channel
trmsts:	.blkb	acc$k_termlen	; termination mbox message buffer
	.page
	.sbttl	pure data
;
;	pure data
;
jpilst:	.word	4,jpi$_pid	; fetch our pid
	.address	pid	; ...
	.long		0	; ...
	.word	4,jpi$_prib	; fetch our base priority
	.address	prib	; ...
	.long	0		; ...
	.word	8,jpi$_authpriv	; fetch our auth privelege mask
	.address	authpr	; ...
	.long	0		; ...
	.long	0		; end of jpi list
pidfmt:	.ascid	"!XL"		; format string for pid format
trmdsc:	.long	14		; descriptor for termination mailbox
	.address	trmbuf		; ...
argdsc:	.long	14		; descriptor for argument mailbox
	.address	argbuf		; ...
prcdsc:	.long	11		; descriptor for process name
	.address	prcbuf		; ...
tt:	.ascid	"TT"		; descriptor for TT
nldsc:	.ascid	"NLA0:"		; descriptor for null device
imgdsc:	.ascid	"SYS$SYSTEM:LOGINOUT.EXE"	; image to run
nover:	.ascii	"$SET NOVERIFY"	; tell loginout not to mumble at user
noverl=.-nover
assfmt1: .ascid	"$ASSIGN !AS TT"	; format string for assign cmd
assfmt2: .ascid	"$ASSIGN !AS SYS$COMMAND"
cmdfmt:	.ascid	"$@ST_BIN:DODCL/OUT=!AS !AS"	; command format string
quotas:	.byte	pql$_astlm
	.long	10
	.byte	pql$_biolm
	.long	6
	.byte	pql$_bytlm
	.long	8192
	.byte	pql$_cpulm
	.long	0
	.byte	pql$_diolm
	.long	6
	.byte	pql$_fillm
	.long	15
	.byte	pql$_pgflquota
	.long	1024
	.byte	pql$_prclm
	.long	2
	.byte	pql$_tqelm
	.long	8
	.byte	pql$_wsdefault
	.long	300
	.byte	pql$_wsquota
	.long	750
	.byte	pql$_listend
	.page
	.sbttl	code
;
;	code
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	system	^m<r2,r3,r4,r5>
	tstw	trmchn			; initialized yet?
	beql	1$			; NO
	brw	10$			; continue
1$:
	$getjpi_s itmlst=jpilst		; fetch pid, base_prio and priv_mask
	blbs	r0,2$			; lbs => success
	brw	5$			; error
2$:
	movl	#8,dumdsc		; prepare descriptor for fao
	movab	pidbuf,dumdsc+4		; ...
	$fao_s	ctrstr=pidfmt,outbuf=dumdsc,p1=pid	; format pid
	blbs	r0,3$			; lbs => success
	brw	5$			; error
3$:
	movc3	#8,pidbuf,trmpid	; copy into name strings
	movc3	#8,pidbuf,argpid	; ...
	movc3	#8,pidbuf,prcpid	; ...
	$crembx_s ,trmchn,#100,,#0,,trmdsc ; create termination mailbox
	blbs	r0,6$			; lbs => success
	brw	5$			; error
6$:
	movl	#512,dumdsc		; prepare descriptor for getchn
	movab	buf,dumdsc+4		; ...
	$getchn_s trmchn,,dumdsc		; get channel information
	blbc	r0,4$			; lbc => error
	movw	buf+dib$w_unit,trmunt	; save unit number
	$trnlog_s tt,length,ttydsc	; translate TT
	movw	length,ttydsc		; copy length into descriptor
	cmpb	#^x1b,ttybuf		; process permanent file?
	bneq	12$			; NO
	addl2	#4,ttydsc+4		; revise descriptor for tty
	subl2	#4,ttydsc		; ...
12$:
	$getdev_s ttydsc,,dumdsc	; get device information
	blbc	r0,11$			; lbc => error, use nla0:
	bbs	#dev$v_trm,buf+dib$l_devchar,10$	; if term, OK
11$:
	movq	nldsc,ttydsc		; redefine tty to be null device
	brb	10$			; continue to hard stuff
4$:
	$dassgn_s trmchn			; deassign channel
5$:
	clrw	trmchn			; initialization not complete
	clrl	r0			; return(0)
	ret
10$:
	clrl	r0			; initialize length of buffer
	movl	buffer(ap),r1		; starting address
20$:
	tstb	(r1)+			; null character yet?
	beql	30$			; YES
	incl	r0			; increment length
	brb	20$			; try again
30$:
	movl	r0,cmddsc		; fill in command descriptor
	bneq	40$			; we have something to do
	brw	return_1		; null command => immediate success
40$:
	movl	buffer(ap),cmddsc+4	; complete command descriptor
	$crembx_s ,argchn,#512,,#0,,argdsc	; create argument mailbox
	blbs	r0,50$			; lbs => success
	brw	return_0		; error
50$:
	$creprc_s ,imgdsc,argdsc,nldsc,nldsc,authpr,quotas,prcdsc,prib,,trmunt
	blbs	r0,60$			; lbs => success
	$dassgn_s argchn		; deassign the channel
	brw	return_0		; error
60$:
	$output	argchn,#noverl,nover	; $ set noverify
	movl	#512,dumdsc		; initialize dummy descriptor
	movab	buf,dumdsc+4		; ...
	moval	ttydsc,r0		; fetch address of descriptor
	$fao_s	assfmt1,length,dumdsc,r0	; format string
	$output	argchn,length,buf	; $assign 'term' TT
	moval	ttydsc,r0		; fetch address of descriptor
	$fao_s	assfmt2,length,dumdsc,r0	; format string
	$output	argchn,length,buf	; $assign 'term' SYS$COMMAND
	moval	ttydsc,r0		; fetch address of descriptor
	moval	cmddsc,r1		; fetch address of descriptor
	$fao_s	cmdfmt,length,dumdsc,r0,r1	; format string
	$output	argchn,length,buf	; $@dodcl/out='term' 'command'
	$qiow_s	,argchn,#io$_writeof	; write EOF on mbox
	$dassgn_s argchn		; deassign channel
	$input	trmchn,#acc$k_termlen,trmsts	; read return message
	movl	trmsts+acc$l_finalsts,r1; fetch return status
	beql	return_1		; OK if status == 0
	blbs	r1,return_1		; OK if low bit set
return_0:
	clrl	r0			; return(0)
	ret
return_1:
	movl	#1,r0			; return(1)
	ret
	.end
#-h- writes.mar       533  asc  28-jul-83 00:16:08  tools (lblh csam sventek)
	.title	writes
;
;	subroutine to put a block to a VMS file
;
;	call sequence	call writes(rab, buffer, n)
;
;	where	rab is the integer descriptor from an openf call
;		buffer is the buffer containing the record to be put
;		n is the number of bytes to put
;
rab=4
buf=8
num=12
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	writes	^m<r2>
	movl	@rab(ap),r2		; rab address in r2
	movl	buf(ap),rab$l_rbf(r2)	; buffer address in rab
	movw	@num(ap),rab$w_rsz(r2)	; # of bytes to put
	$write	rab=r2
	ret
	.end
#-h- getpriv.mar     4577  asc  28-jul-83 00:16:08  tools (lblh csam sventek)
	.title	get_priv
;+
;	integer function get_priv(which_priv, pid, prcnam, buf)
;
;	return(OK/ERR)
;
;	fetches the which_priv mask with a getjpi and formats the
;	privelege names in buf as name@ename@ename@e...@e@n
;	the user must make sure that the buffer is large enough
;	the name of the process is returned as a 0-byte terminated string
;
;	valid values for which_priv are authpriv, curpriv, imagpriv, procpriv
;-
	$jpidef
	$prvdef
which_priv=4
pid=8
prcnam=12
buf=16
ok=0
err=-3
max_priv=prv$v_bypass		; as of version 2.x
	.psect	st_getpriv_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
jpi_list:
	.word	8		; size of buffer
cmd:	.word	jpi$_curpriv	; fetch current priveleges
	.address	priv_buf	; address of buffer
	.long	0		; no length desired
	.word	16		; buffer size for process name
	.word	jpi$_prcnam	; fetch process name
prc_buf:.long	0		; buffer address placed here
	.address	length		; address to receive length
	.long	0		; end of list
length:	.blkw	1		; word for length of process name
priv_buf:
	.blkq	1		; quadword for privelege mask
names:
	.address	name0
	.address	name1
	.address	name2
	.address	name3
	.address	name4
	.address	name5
	.address	name6
	.address	name7
	.address	name8
	.address	name9
	.address	name10
	.address	name11
	.address	name12
	.address	name13
	.address	name14
	.address	name15
	.address	name16
	.address	name17
	.address	name18
	.address	name19
	.address	name20
	.address	name21
	.address	name22
	.address	name23
	.address	name24
	.address	name25
	.address	name26
	.address	name27
	.address	name28
	.address	name29
	.address	name30
	.address	name31
	.address	name32
	.address	name33
	.address	name34
	.address	name35
	.address	name36
	.address	name37
	.address	name38
	.address	name39
	.address	name40
	.address	name41
	.address	name42
	.address	name43
	.address	name44
	.address	name45
	.address	name46
	.address	name47
	.address	name48
	.address	name49
	.address	name50
	.address	name51
	.address	name52
	.address	name53
	.address	name54
	.address	name55
	.address	name56
	.address	name57
	.address	name58
	.address	name59
	.address	name60
	.address	name61
	.address	name62
	.address	name63
name0:	.asciz	"cmkrnl"
name1:	.asciz	"cmexec"
name2:	.asciz	"sysnam"
name3:	.asciz	"grpnam"
name4:	.asciz	"allspool"
name5:	.asciz	"detach"
name6:	.asciz	"diagnose"
name7:	.asciz	"log_io"
name8:	.asciz	"group"
name9:	.asciz	"noacnt"
name10:	.asciz	"prmceb"
name11:	.asciz	"prmmbx"
name12:	.asciz	"pswapm"
name13:	.asciz	"altpri"
name14:	.asciz	"setprv"
name15:	.asciz	"tmpmbx"
name16:	.asciz	"world"
name17:	.asciz	"mount"
name18:	.asciz	"oper"
name19:	.asciz	"exquota"
name20:	.asciz	"netmbx"
name21:	.asciz	"volpro"
name22:	.asciz	"phy_io"
name23:	.asciz	"bugchk"
name24:	.asciz	"prmgbl"
name25:	.asciz	"sysgbl"
name26:	.asciz	"pfnmap"
name27:	.asciz	"shmem"
name28:	.asciz	"sysprv"
name29:	.asciz	"bypass"
name30:	.asciz	"syslck"
name31:	.asciz	"Priv_1F"
name32:	.asciz	"Priv_20"
name33:	.asciz	"Priv_21"
name34:	.asciz	"Priv_22"
name35:	.asciz	"Priv_23"
name36:	.asciz	"Priv_24"
name37:	.asciz	"Priv_25"
name38:	.asciz	"Priv_26"
name39:	.asciz	"Priv_27"
name40:	.asciz	"Priv_28"
name41:	.asciz	"Priv_29"
name42:	.asciz	"Priv_2A"
name43:	.asciz	"Priv_2B"
name44:	.asciz	"Priv_2C"
name45:	.asciz	"Priv_2D"
name46:	.asciz	"Priv_2E"
name47:	.asciz	"Priv_2F"
name48:	.asciz	"Priv_30"
name49:	.asciz	"Priv_31"
name50:	.asciz	"Priv_32"
name51:	.asciz	"Priv_33"
name52:	.asciz	"Priv_34"
name53:	.asciz	"Priv_35"
name54:	.asciz	"Priv_36"
name55:	.asciz	"Priv_37"
name56:	.asciz	"Priv_38"
name57:	.asciz	"Priv_39"
name58:	.asciz	"Priv_3A"
name59:	.asciz	"Priv_3B"
name60:	.asciz	"Priv_3C"
name61:	.asciz	"Priv_3D"
name62:	.asciz	"Priv_3E"
name63:	.asciz	"Priv_3F"
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	get_priv	^m<r2,r3>
	movw	@which_priv(ap),cmd		; which privilege mask to get
	movl	prcnam(ap),prc_buf		; store address for proc name
	$getjpi_s efn=#0,pidadr=@pid(ap),itmlst=jpi_list
	blbc	r0,10$				; error
	$waitfr_s efn=#0			; wait for completion
	movzwl	length,r0			; length of proc name
	addl2	prcnam(ap),r0			; address of EOS
	clrb	(r0)				; terminate it
	movl	buf(ap),r0			; output buffer address
	clrl	r2				; start at bit 0
	moval	names,r3			; start of pointers
5$:
	bbc	r2,priv_buf,7$			; if bit clear, try next
	movl	(r3)[r2],r1			; address of string
6$:
	movb	(r1)+,(r0)+			; copy character
	bneq	6$				; go again
7$:
	aobleq	#max_priv,r2,5$			; try next privelege bit
	movb	#10,(r0)			; terminate with newline
	movl	#ok,r0				; return(OK)
	ret
10$:
	movl	#err,r0				; return(ERR)
	ret
	.end
#-h- lib.r         139842  asc  03-aug-83 08:52:31  tools (lblh csam sventek)
#-h- arsubs.r        3247  asc  13-jan-83 16:54:36  sventek (joseph sventek)
#-h- adefns            22  asc  25-mar-82 06:46:38  v1.1 (sw-tools v1.1)
define(SEP_CHAR, '`')
#-h- afetch           282  asc  13-jan-83 16:52:51  sventek (joseph sventek)
integer		function afetch(buf, i, out)

integer		i, j
character	buf(ARB), out(ARB)

for( j = 1 ; buf(i) != EOS ; i = i + 1 , j = j + 1 )
  if( buf(i) == SEP_CHAR )
    break
  else
    out(j) = buf(i)

if( buf(i) != EOS )
  i = i + 1
out(j) = EOS
call fold(out)

return( j - 1 )
end
#-h- agetch           352  asc  25-mar-82 06:46:41  v1.1 (sw-tools v1.1)
character	function agetch(c, fd, size)

character	c
filedes		fd
integer		size(2)
character	getch # function(s)

if( size(1) <= 0 & size(2) <= 0 )
  c = EOF
else if( getch( c, fd) == EOF )
{
  size(1) = 0
  size(2) = 0
}
else
{
  size(2) = size(2) - 1
  if( size(2) < 0 )
  {
    size(1) = size(1) - 1
    size(2) = size(2) + 10000
  }
}

return(c)
end
#-h- agethd           561  asc  02-may-82 12:27:00  j (sventek j)
integer		function agethd(fd, buf, size, fsize)

filedes		fd
character	buf(MAXLINE)
integer		size(2), fsize(2)
integer		i
integer		agtlin, index # function(s)

string		hdr "#-h- "

if( agtlin( buf, fd, fsize) == EOF )
  return(EOF)

for( i = 1 ; hdr(i) != EOS ; i = i + 1 )
  if( buf(i) != hdr(i) )
    break

if( hdr(i) != EOS ) # bad format archive
  return(ERR)

call skipbl( buf, i) # skip to name of module
call scopy( buf, i, buf, 1)
i = index( buf, ' ')
buf(i) = EOS
call fold(buf)
i = i + 1
call ctodi( buf, i, size) # get size of module

return(OK)
end
#-h- agtlin           376  asc  25-mar-82 06:46:44  v1.1 (sw-tools v1.1)
integer		function agtlin(buf, fd, size)

character	buf(MAXLINE)
filedes		fd
integer		size(2), n
integer		getlin # function(s)

if( size(1) <= 0 & size(2) <= 0 )
  return(EOF)

n = getlin( buf, fd)
if( n == EOF )
{
  size(1) = 0
  size(2) = 0
}
else
{
  size(2) = size(2) - n
  if( size(2) < 0 )
  {
    size(1) = size(1) - 1
    size(2) = size(2) + 10000
  }
}

return(n)
end
#-h- aopen            814  asc  25-mar-82 06:46:46  v1.1 (sw-tools v1.1)
filedes function aopen( name, fd, size)

character	name(FILENAMESIZE), file(FILENAMESIZE), module(FILENAMESIZE), 
		buf(MAXLINE)
integer		i, fsize(2), size(2)
integer		afetch, agethd, equal # function(s)
filedes		fd
filedes		open # function(s)

i = 1
if( afetch( name, i, file) <= 0 ) # bad name
  return(ERR)

fd = open( file, READ) # open the main file
if( fd == ERR )
  return(ERR)

fsize(1) = MAX_INTEGER
fsize(2) = 0

if( afetch( name, i, module) <= 0)	# flat archive
{
  size(1) = MAX_INTEGER
  size(2) = 0
  return (fd)
}

while( agethd( fd, buf, size, fsize) == OK )
  if( equal( buf, module) == YES )
  {
    if( afetch( name, i, module) <= 0 )
      return(fd)
    fsize(1) = size(1)
    fsize(2) = size(2)
  }
  else
    call askip( fd, size, fsize)

call close(fd) # ERROR if get here

return(ERR)
end
#-h- askip            332  asc  25-mar-82 06:46:47  v1.1 (sw-tools v1.1)
subroutine askip( fd, size, fsize)

filedes		fd
integer		size(2), fsize(2)
character	c
character	agetch # function(s)

while( !( size(1) <= 0 & size(2) <= 0 ) )
{
  if( agetch( c, fd, fsize) == EOF )
    break
  size(2) = size(2) - 1
  if( size(2) < 0 )
  {
    size(1) = size(1) - 1
    size(2) = size(2) + 10000
  }
}

return
end
#-h- ds.r           11418  asc  16-jun-83 11:32:52  sventek (joseph sventek)
#-h- dsdef            748  asc  25-mar-82 06:46:54  v1.1 (sw-tools v1.1)
# Defines for support library routines

# Defines for memory management routines:
define(DS_MEMEND,1)     # pointer to end of memory
define(DS_AVAIL,2)      # start of available space list
define(DS_CLOSE,8)      # threshhold for close-fitting blocks
define(DS_LINK,1)       # link field of storage block
define(DS_SIZE,0)       # size field of storage block
define(DS_OHEAD,2)      # total words of overhead per block

# Defines for symbol table routines:
define(ST_LINK,0)       # offset of link field in symbol table node
define(ST_DATA,1)       # offset of data field in symbol table node
define(ST_HTABSIZE,29)  # should be a prime number
define(ST_SCANPOSN,arith(ST_HTABSIZE,+,1))	# offset to two word block
						# for context of table scan
#-h- dsinit           508  asc  16-jun-83 11:28:49  sventek (joseph sventek)
## DSInit -- initialize dynamic storage space to `w' words.

subroutine dsinit(w)
integer    w

DS_DECL( Mem, 1)

pointer t

if( w < 2 * DS_OHEAD + 2 )
  call error(  "in dsinit: unreasonably small memory size" )

# set up avail list:
t = DS_AVAIL
Mem( t + DS_SIZE ) = 0
Mem( t + DS_LINK ) = DS_AVAIL + DS_OHEAD

# set up first block of space:
t = DS_AVAIL + DS_OHEAD
Mem( t + DS_SIZE ) = w - DS_OHEAD - 1 # -1 for MEMEND
Mem( t + DS_LINK ) = LAMBDA

# record end of memory:
Mem( DS_MEMEND ) = w

return
end
#-h- dsfree           800  asc  16-jun-83 11:28:49  sventek (joseph sventek)
## DSFree -- return a block of storage to the available space list.

subroutine dsfree(block)
pointer    block

DS_DECL( Mem, 1)

pointer    p0, p, q
integer    n

p0 = block - DS_OHEAD
n = Mem( p0 + DS_SIZE )
q = DS_AVAIL

repeat
{
  p = Mem( q + DS_LINK )
  if( p == LAMBDA | p > p0 )
    break
  q = p
}
  
if( q + Mem( q + DS_SIZE ) > p0 )
{
  call remark(  "in dsfree:  attempt to free unallocated block" )
  return # do not attempt to free the block
}

if( p0 + n == p & p != LAMBDA )
{
  n = n + Mem( p + DS_SIZE )
  Mem( p0 + DS_LINK ) = Mem( p + DS_LINK )
}
else
  Mem( p0 + DS_LINK ) = p

if( q + Mem( q + DS_SIZE ) == p0 )
{
  Mem( q + DS_SIZE ) = Mem( q + DS_SIZE ) + n
  Mem( q + DS_LINK ) = Mem( p0 + DS_LINK )
}
else
{
  Mem( q + DS_LINK ) = p0
  Mem( p0 + DS_SIZE ) = n
}

return
end
#-h- dsget            516  asc  25-mar-82 06:46:59  v1.1 (sw-tools v1.1)
## DSGet-- Get pointer to block of at least `w' available words.

pointer    function dsget(w)
integer    w

DS_DECL( Mem, 1)

pointer    p, q, l
integer    n, k

n = w + DS_OHEAD
q = DS_AVAIL

repeat
{
  p = Mem( q + DS_LINK )
  if( p == LAMBDA )
    return(p)
  if( Mem( p + DS_SIZE ) >= n )
    break
  q = p
}

k = Mem( p + DS_SIZE ) - n
if( k >= DS_CLOSE )
{
  Mem( p + DS_SIZE ) = k
  l = p + k
  Mem( l + DS_SIZE ) = n
}
else
{
  Mem( q + DS_LINK ) = Mem( p + DS_LINK )
  l = p
}

return( l + DS_OHEAD )

end
#-h- dsdump           683  asc  16-jun-83 11:28:50  sventek (joseph sventek)
## DSDump -- Produce semi-readable dump of storage.

subroutine dsdump(form)
character  form

DS_DECL( Mem, 1)

pointer   p, t, q

t = DS_AVAIL

call remark(  "** DYNAMIC STORAGE DUMP **" )
call putint( 1, 5, ERROUT)
call putch( ' ', ERROUT)
call putint( DS_OHEAD + 1, 0, ERROUT)
call remark(  " words in use" )

p = Mem( t + DS_LINK )
while( p != LAMBDA )
{
  call putint( p, 5, ERROUT)
  call putch( ' ', ERROUT)
  call putint( Mem( p + DS_SIZE ), 0, ERROUT)
  call remark(  " words available" )
  q = p + Mem( p + DS_SIZE )
  while( q != Mem( p + DS_LINK ) & q < Mem( DS_MEMEND ) )
    call dsdbiu( q, form)
  p = Mem( p + DS_LINK )
}

call remark(  "** END DUMP **" )
return
end
#-h- dsdbiu           879  asc  16-jun-83 11:28:51  sventek (joseph sventek)
## DSDBIU -- Dump contents of block-in-use.

subroutine dsdbiu( b, form)
pointer    b
character  form

DS_DECL( Mem, 1)

integer    l, s, lmax, t, j

string blanks "          "

call putint( b, 5, ERROUT)
call putch( ' ', ERROUT)
call putint( Mem( b + DS_SIZE ), 0, ERROUT)
call remark(  " words in use" )

l = 0
s = b + Mem( b + DS_SIZE )
if( form == DIGIT )
  lmax = 5
else
  lmax = 50

for( b = b + DS_OHEAD ; b < s ; b = b + 1 )
{
  if( l == 0 )
    call putlin( blanks, ERROUT)
  if( form == DIGIT )
  {
    call putint( Mem(b), 10, ERROUT)
    l = l + 1
  }
  elif( form == LETTER )
  {
    t = cvt_to_cptr(b)
    for( j = 1 ; j <= CHAR_PER_INT ; j = j + 1 )
    {
      call putch( cMem(t), ERROUT)
      t = t + 1
    }
    l = l + CHAR_PER_INT
  }
  if( l >= lmax )
  {
    l = 0
    call putch( '@n', ERROUT)
  }
}

if( l != 0 )
  call putch( '@n', ERROUT)

return
end
#-h- mktabl           453  asc  25-mar-82 06:47:04  v1.1 (sw-tools v1.1)
## MkTabl -- Make a new (empty) symbol table.

pointer    function mktabl(nodsiz)
integer    nodsiz

DS_DECL( Mem, 1)

pointer    st
pointer    dsget

integer    i

st = dsget( ST_HTABSIZE + 3 )	# +3 for record of nodsiz
				# and 2-word block for scan context
mktabl = st
if( st != LAMBDA ) # allocation succeeded
{
  Mem(st) = nodsiz
  for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 )
  {
    st = st + 1
    Mem(st) = LAMBDA # null link
  }
}

return
end
#-h- rmtabl           405  asc  25-mar-82 06:47:06  v1.1 (sw-tools v1.1)
## RmTabl -- Remove a symbol table, deleting all entries.

subroutine rmtabl(st)
pointer    st

DS_DECL( Mem, 1)

integer    i

pointer    bucket, node, walker

bucket = st
for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 )
{
  bucket = bucket + 1
  walker = Mem(bucket)
  while( walker != LAMBDA )
  {
    node = walker
    walker = Mem( node + ST_LINK )
    call dsfree(node)
  }
}

call dsfree(st)
return
end
#-h- sctabl          1247  asc  25-mar-82 06:47:08  v1.1 (sw-tools v1.1)
## ScTabl - Scan symbol table, returning next entry or EOF.

integer    function sctabl(table, sym, info, posn)
pointer    posn, table
character  sym(ARB)
integer    info(ARB)

DS_DECL( Mem, 1)

pointer    bucket, walker

integer    nodsiz, i, j

if( posn == 0 )				# just starting scan?
{
  posn = table + ST_SCANPOSN		# index to 2-word scan context block
  Mem(posn) = 1				# get index of first bucket
  Mem( posn + 1 ) = Mem( table + 1 )	# get pointer to first chain
}

bucket = Mem(posn)			# recover previous position
walker = Mem( posn + 1 )
nodsiz = Mem(table)

repeat # until the next symbol, or none are left
{
  if( walker != LAMBDA ) # symbol available?
  {
    i = walker + ST_DATA + nodsiz
    i = cvt_to_cptr(i)
    j = 1
    while( cMem(i) != EOS )
    {
      sym(j) = cMem(i)
      i = i + 1
      j = j + 1
    }
    sym(j) = EOS
    j = walker + ST_DATA
    for( i = 1 ; i <= nodsiz ; i = i + 1 )
    {
      info(i) = Mem(j)
      j = j + 1
    }
    Mem(posn) = bucket # save position of next symbol
    Mem( posn + 1 ) = Mem( walker + ST_LINK )
    return(1)	# not EOF
  }
  else
  {
    bucket = bucket + 1
    if( bucket > ST_HTABSIZE )
      break
    j = table + bucket
    walker = Mem(j)
  }
}

posn = 0
return(EOF)
end
#-h- stlu             638  asc  25-mar-82 06:47:09  v1.1 (sw-tools v1.1)
## STLu -- Symbol table lookup primitive.

integer    function stlu( symbol, node, pred, st)
character  symbol(ARB)
pointer    node, pred, st

DS_DECL( Mem, 1)

integer    hash, i, j, nodsiz
integer    equal

nodsiz = Mem(st)

hash = 0
for( i = 1 ; symbol(i) != EOS ; i = i + 1 )
  hash = hash + symbol(i)
hash = mod( hash, ST_HTABSIZE ) + 1

pred = st + hash
node = Mem(pred)
while( node != LAMBDA )
{
  i = 1
  j = node + ST_DATA + nodsiz
  j = cvt_to_cptr(j)
  while( symbol(i) == cMem(j) )
  {
    if( symbol(i) == EOS )
      return(YES)
    i = i + 1
    j = j + 1
  }
  pred = node
  node = Mem( pred + ST_LINK )
}

return(NO)
end
#-h- delete           306  asc  25-mar-82 06:47:11  v1.1 (sw-tools v1.1)
## Delete -- Remove a symbol from the symbol table.

subroutine delete( symbol, st)
character  symbol(ARB)
pointer    st

DS_DECL( Mem, 1)

integer    stlu
pointer    node, pred

if( stlu( symbol, node, pred, st) == YES )
{
  Mem( pred + ST_LINK ) = Mem( node + ST_LINK )
  call dsfree(node)
}

return
end
#-h- lookup           454  asc  25-mar-82 06:47:13  v1.1 (sw-tools v1.1)
## Lookup -- Find a symbol in the symbol table, return its data.

integer    function lookup(symbol, info, st)
character  symbol(ARB)
integer    info(ARB)
pointer    st

DS_DECL( Mem, 1)

integer    i, nodsiz, kluge
integer    stlu
pointer    node, pred

if( stlu( symbol, node, pred, st) == NO )
  return(NO)

nodsiz = Mem(st)
kluge = node + ST_DATA
for( i = 1 ; i <= nodsiz ; i = i + 1 )
{
  info(i) = Mem(kluge)
  kluge = kluge + 1
}

return(YES)
end
#-h- enter            807  asc  25-mar-82 06:47:14  v1.1 (sw-tools v1.1)
## Enter -- Place a symbol in the symbol table, updating if already present.

integer    function enter(symbol, info, st)
character  symbol(ARB)
integer    info(ARB)
pointer    st

DS_DECL( Mem, 1)

integer    i, nodsiz, j
integer    stlu, length
pointer    node, pred
pointer    dsget

nodsiz = Mem(st)

if( stlu( symbol, node, pred, st) == NO )
{
  node = dsget( 1 + nodsiz + ( length(symbol) + CHAR_PER_INT ) / CHAR_PER_INT )
  if( node == LAMBDA )
    return(ERR)
  Mem( node + ST_LINK ) = LAMBDA
  Mem( pred + ST_LINK ) = node
  i = 1
  j = node + ST_DATA + nodsiz
  j = cvt_to_cptr(j)
  while( symbol(i) != EOS )
  {
    cMem(j) = symbol(i)
    i = i + 1
    j = j + 1
  }
  cMem(j) = EOS
}

j = node + ST_DATA
for( i = 1 ; i <= nodsiz ; i = i + 1 )
{
  Mem(j) = info(i)
  j = j + 1
}

return(OK)
end
#-h- sdupl            419  asc  25-mar-82 06:47:16  v1.1 (sw-tools v1.1)
## SDupl -- Duplicate a string in dynamic storage space.

pointer    function sdupl(str)
character  str(ARB)

DS_DECL( Mem, 1)

integer    i, k
integer    length
pointer    j
pointer    dsget

j = dsget( ( length(str) + CHAR_PER_INT ) / CHAR_PER_INT )
sdupl = j
if( j != LAMBDA )
{
  k = cvt_to_cptr(j)
  for( i = 1 ; str(i) != EOS ; i = i + 1 )
  {
    cMem(k) = str(i)
    k = k + 1
  }
  cMem(k) = EOS
}

return
end
#-h- entdef           548  asc  16-jun-83 11:28:54  sventek (joseph sventek)
## EntDef -- Enter a new symbol definition, discarding any old one.

subroutine entdef( name, defn, table)
character  name(ARB), defn(ARB)
pointer    table

integer    lookup, enter
pointer    text
pointer    sdupl

if( lookup( name, text, table) == YES )
  call dsfree(text)		# this is how to do UNDEFINE, by the way
text = sdupl(defn)		# store definition away
if( text != LAMBDA )		# succeeded
{
  if( enter( name, text, table) == OK )
    return
  else
    call dsfree(text)
}
call remark(  "in entdef: no room for new definition" )

return
end
#-h- ludef            444  asc  25-mar-82 06:47:19  v1.1 (sw-tools v1.1)
## LuDef -- Look up a defined identifier, return its definition.

integer    function ludef( id, defn, table)
character  id(ARB), defn(ARB)
pointer    table

DS_DECL( Mem, 1)

integer    i, j
integer    lookup
pointer    locn

ludef = lookup( id, locn, table)
if( ludef == YES )
{
  i = 1
  for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 )
  {
    defn(i) = cMem(j)
    i = i + 1
  }
  defn(i) = EOS
}
else
  defn(1) = EOS

return
end
#-h- rmdef            298  asc  05-aug-82 22:19:41  sventek (joseph sventek)
## Rmdef -- remove symbol and definition from a symbol table

subroutine rmdef(symbol, table)
character symbol(ARB)
pointer table

integer lookup
pointer text

if (lookup(symbol, text, table) == YES)		# remove (symbol,defn) pair
  {
  call dsfree(text)
  call delete(symbol, table)
  }

return
end
#-h- help.r          3249  asc  25-mar-82 06:52:36  v1.1 (sw-tools v1.1)
#-h- defns            344  asc  25-mar-82 06:47:28  v1.1 (sw-tools v1.1)
# common / chelp / size, name(FILENAMESIZE), buf(MAXLINE)
#
# integer size		# return size of entry from gethdr
# character name		# return name of entry from gethdr
# character buf		# buffer for reading help archive file
define(INCL_CHELP,common/chelp/size,name(FILENAMESIZE),buf(MAXLINE)
integer size; character name,buf)
define(gethdr,phelp0)
#-h- gethdr           451  asc  25-mar-82 06:47:30  v1.1 (sw-tools v1.1)
## GetHdr -- Get next archive header from file.

integer    function gethdr( fd, buf, name, size)

character  buf(MAXLINE), c, name(FILENAMESIZE)
integer    ctoi, equal, getlin, getwrd # function(s)
integer    fd, i, len, size

string hdr "#-h-"

if( getlin( buf, fd) == EOF )
  return(EOF)
i = 1
len = getwrd( buf, i, name)
if( equal( name, hdr) == NO )
  return(ERR)
len = getwrd( buf, i, name)
size = ctoi( buf, i)
call fold(name)

return(YES)
end
#-h- inihlp           586  asc  25-mar-82 06:47:32  v1.1 (sw-tools v1.1)
## IniHlp -- Initialize help system.

integer     function inihlp( file, ptrara, ptrsiz, fd)

filedes     fd
integer     i, ptrsiz, junk
linepointer ptrara(ptrsiz)
character   file(FILENAMESIZE)
integer     gethdr, open, note # function(s)

INCL_CHELP

call close(fd) # close it if previously opened
fd = open( file, READ)
if( fd != ERR )
{
  for( i = 1 ; i < ptrsiz ; i = i + 1 )
  {
    junk = note ( ptrara(i), fd )
    if( gethdr( fd, buf, name, size) != YES )
      break
    call fskip( fd, size)
  }
  call ptrcpy( NULLPOINTER, ptrara(i) )
  return(OK)
}
else
  return(ERR)

end
#-h- mrkhlp           770  asc  25-mar-82 06:47:33  v1.1 (sw-tools v1.1)
## MrkHlp -- Mark all header lines in help archive.
integer     function mrkhlp( fd, ptrara, key, outara)

filedes     fd
integer     j, i, junk, doall
integer     equal, gethdr, ptreq # function(s)
linepointer ptrara(ARB), outara(ARB)
character   key(ARB)

INCL_CHELP

string summar "%"
string all "?"

if( equal( key, summar) == YES | equal( key, all) == YES )
  doall = YES
else
  doall = NO
j = 1
for( i = 1 ; ptreq( ptrara(i), NULLPOINTER) == NO ; i = i + 1 )
{
  call seek( ptrara(i), fd)
  junk = gethdr( fd, buf, name, size)
  if( doall == YES | equal( name, key) == YES )
  {
    call ptrcpy( ptrara(i), outara(j) )
    j = j + 1
  }
  if( j > 1 & doall == NO )
    break
}
call ptrcpy( NULLPOINTER, outara(j) )
if( j > 1 )
  return(OK)
else
  return(ERR)

end
#-h- puthlp           733  asc  25-mar-82 06:47:35  v1.1 (sw-tools v1.1)
## PutHlp -- Output help message.

subroutine  puthlp( fd, outara, key, out, putout)

character   key(ARB)
filedes     fd
integer     dosumm, i, junk, out
integer     equal, gethdr, getlin, ptreq # function(s)
linepointer outara(ARB)
external    putout

INCL_CHELP

string summar "%"

dosumm = equal( key, summar)
for( i = 1 ; ptreq( outara(i), NULLPOINTER) == NO ; i = i + 1 )
{
  call seek( outara(i), fd)
  junk = gethdr( fd, buf, name, size)
  if( dosumm == YES )
  {
    junk = getlin( buf, fd)
    call putout( buf, out)
  }
  else
  {
    size = size - getlin( buf, fd)
    for( junk = getlin( buf, fd) ; size > 0 ; junk = getlin( buf, fd) )
    {
      call putout( buf, out)
      size = size - junk
    }
  }
}

return
end
#-h- hispmt.r       18950  asc  06-apr-82 15:09:03  j (sventek j)
#-h- defns           3203  asc  06-apr-82 14:53:56  j (sventek j)
### Defns	Symbol definitions for `logpmt'.

define(GLOBAL,'g') 
define(CURLINE,'.') 
define(PREVLINE,'-')
define(NEXTLINE,'+')
define(LASTLINE,'$') 
define(SCAN,'/') 
define(BACKSCAN,'\') 
define(LINE0,1) 
define(PREV,0) 
define(NEXT,1) 
define(MAX_ED_LINES,25)	# Maximum number of lines.
define(BUFENT,5) 	# Words in buffer needed/line.

# Now calculate size of buffer array = BUFENT * (MAX_ED_LINES + 2).
# The 2 is to account for dummy lines before and after real lines.
define(MAXBUF,arith(BUFENT,*,arith(MAX_ED_LINES,+,2)))

define(SEEKADR,3) 
define(LINEID,4) 
define(SCREENSIZE,22)
define(FORWARD,'+')
define(BACKWARD,'-')
define(LINE_NUMBER,0)
define(LEFT_HAND_SIDE,1)

# /clog00/ common block - formerly known as cbuf in the editor
# put on a file called 'clog00'
# Used only by logpmt

# common /clog00/ buf(MAXBUF), lastbf

# integer buf		# Data structures describing each line.
# integer lastbf	# Last entry in buf used.

define(I_CLOG00,common/clog00/buf(MAXBUF),lastbf
integer buf,lastbf)

# formerly known as clines
# /clog01/ - common block for logpmt; holds line flags
# put on a file called 'clog01'
# Used only by logpmt

# common /clog01/ line1, line2, nlines, curln, frstln, lastln,
#		 number
#   integer line1   # first line number
#   integer line2   # second line number
#   integer nlines  # number of line numbers specified
#   integer curln   # current line: value of dot
#   integer frstln  # first line of history
#   integer lastln  # last line: value of $
#   integer number  # next available line number

define(I_CLOG01,common/clog01/line1,line2,nlines,curln,frstln,lastln,number
integer line1,line2,nlines,curln,frstln,lastln,number)

# formerly known as cpat
# /clog02/ - common block for logpmt
# put on a file named 'clog02'
# Used only by the logpmt

# common /clog02/ pat(MAXPAT) 
#   character pat      # pattern 

define(I_CLOG02,common/clog02/pat(MAXPAT)
character pat)

# formerly known as cscrat
# /clog03/ - common block for logpmt; holds scratch file info
# put on a file called 'clog03'
# Used only by the logpmt

# common /clog03/ scr, scrend(2) , scrfil(FILENAMESIZE)
#    integer scr      # scratch file id 
#    integer scrend   # end of info on scratch file 
#    character scrfil # name of scratch file

define(I_CLOG03,common/clog03/scr,scrend(2),scrfil(FILENAMESIZE)
integer scr,scrend
character scrfil)

# formerly known as ctxt
# /clog04/ - common block for logpmt
# put on a file called 'clog04'
# Used only by the logpmt

# common /clog04/ txt(MAXLINE) 
#   character txt      # text line for matching and output 

define(I_CLOG04,common/clog04/txt(MAXLINE)
character txt)

# These definitions are used to avoid name collisions in `rlib'.

define(pmtfcn,plog00)
define(archiv,plog01)
define(dohist,plog03)
define(dolist,plog04)
#define(edline,plog05)
define(getb,plog06)
define(getind,plog07)
define(getlst,plog08)
define(getnum,plog09)
define(getone,plog10)
define(getrhs,plog11)
define(gettxt,plog12)
define(gtfndx,plog13)
define(inject,plog14)
#define(logend,plog02)
define(nextln,plog15)
define(optpat,plog16)
define(prevln,plog17)
define(ptscan,plog18)
define(relink,plog19)
define(setb,plog20)
define(setbuf,plog21)
define(subst,plog22)
#-h- logpmt           211  asc  06-apr-82 14:53:58  j (sventek j)
### LogPmt	prompt function with history
integer function logpmt(pstr, buf, fd)

character pstr(ARB), buf(ARB)
filedes fd
integer pmtfcn # function(s)
external prompt

return (pmtfcn (pstr, buf, fd, prompt))
end
#-h- ledpmt           234  asc  06-apr-82 14:53:58  j (sventek j)
### LedPmt	prompt function with history and intra-line editing
integer function ledpmt(pstr, buf, fd)

character pstr(ARB), buf(ARB)
filedes fd
integer pmtfcn # function(s)
external lnedit

return (pmtfcn (pstr, buf, fd, lnedit))
end
#-h- pmtfcn          1721  asc  06-apr-82 14:54:00  j (sventek j)
### PmtFcn	Prompt function with history mechanism.
###             pmtrtn is the function to be called to prompt for input
###             status = pmtrtn(pstr, buf, fd)
integer    function pmtfcn( pstr, lin, int, pmtrtn)

character  c, lin(ARB), pstr(ARB)
character  clower # function(s)
integer    access, i, int, junk, k, nofile
integer    dohist, edline, equal, index, pmtrtn # function(s)
external   pmtrtn

I_CLOG01

string null ""
string whites " @t@n"

data nofile / YES / 

if( nofile == YES )
{
  nofile = NO
  call setbuf
}
repeat
{
  k = pmtrtn( pstr, lin, int)
  if( k == EOF )
    call strcpy( null, lin)
  else if( lin(1) == '!' )
  {
    c = clower( lin(2) )
    if( c == 'h' | c == 'b' )
    {
      for( i = 3 ; IS_LETTER( lin(i) ) ; i = i + 1 )
         ;
      junk = dohist( lastln, lin, i)
      k = ERR
    }
    else if( c == 'w' )
    {
      for( i = 3 ; lin(i) != EOS ; i = i + 1 )
        if( index( whites, lin(i) ) > 0 )
          break
      call skipbl( lin, i)
      access = WRITE
      if( lin(i) == '>' )
      {
        i = i + 1
        if( lin(i) == '>' )
        {
          i = i + 1
          access = APPEND
        }
      }
      call scopy( lin, i, lin, 1)
      i = index( lin, '@n')
      if( i > 0 )
        lin(i) = EOS
      k = EOF
    }
    else if( c == 'q' )
    {
      call strcpy( null, lin)
      k = EOF
    }
    else
    {
      k = edline(lin)
      call putlin( pstr, ERROUT)
      call putlin( lin, ERROUT)
    }
  }
  else if( lin(1) == ESCAPE & lin(2) == '!' )
  {
    call scopy( lin, 2, lin, 1)
    k = k - 1
  }
}
until( k != ERR )
if( k != EOF )
  call archiv(lin)
else
{
  call logend( lin, access)
  nofile = YES # (dpm 13-Jun-81)
}

return(k)
end
#-h- archiv           209  asc  06-apr-82 14:54:01  j (sventek j)
### LP_Archiv	Archive lines. (LogPmt)
subroutine archiv(lin)

character  lin(ARB)
integer    junk
integer    inject # function(s)

if( lin(1) != '@n' ) # Don't log blank lins.
  junk = inject(lin)

return
end
#-h- dohist           567  asc  06-apr-82 14:54:02  j (sventek j)
### LP_DoHist	Perform history display. (LogPmt)
integer    function dohist( line, lin, i)

character  direc, lin(ARB)
integer    curscr, i, lin1, lin2, line, screen
integer    ctoi, dolist # function(s)

I_CLOG01

data screen, curscr / SCREENSIZE, SCREENSIZE / 

call skipbl( lin, i)
if( lin(i) == '@n' )
  screen = curscr
else
{
  screen = ctoi( lin, i) - 1
  if( screen <= 0 )
    screen = curscr
  else
    curscr = screen
}
lin1 = line - screen
lin2 = line
lin1 = max( frstln + 1, lin1)
lin2 = min( lin2, lastln)
dohist = dolist( lin1, lin2, lin(i) )

return
end
#-h- dolist           729  asc  06-apr-82 14:54:03  j (sventek j)
### LP_DoList	Print lines `from' through `to'. (LogPmt)
integer    function dolist( from, to, ch)
integer    gettxt # function(s)
integer    from, i, j, to, k, num, xpand
character  c, ch
I_CLOG01
I_CLOG04

xpand = NO
if( ch == 'l' | ch == 'L' )
  xpand = YES
for( i = from ; i <= to ; i = i + 1 )
{
  j = gettxt(i)
  call getb( j, LINEID, num)
  call putint( num, 3, STDOUT) # output line number
  call putch( ' ', STDOUT)
  for( k = 1 ; txt(k) != EOS ; k = k + 1 )
    if( txt(k) >= ' ' | txt(k) == '@n' )
      call putch( txt(k), STDOUT)
  else if( xpand == NO )
    call putch( txt(k), STDOUT)
  else
  {
    call putch( '^', STDOUT)
    c = txt(k) + '@@'
    call putch( c, STDOUT)
  }
}
curln = to
dolist = OK

return
end
#-h- edline           969  asc  06-apr-82 14:54:04  j (sventek j)
### LP_EdLine	Perform line-editor command. (LogPmt)
integer    function edline(lin)

character  lin(ARB), sub(MAXPAT)
integer    final, gflag, i, junk, linsts, status
integer    getlst, getrhs, gettxt, length, optpat, subst # function(s)

I_CLOG04
I_CLOG01

string badlin "# invalid lin number@n"
string badpat "# invalid substitution@n"

i = 2
status = OK
if( getlst( lin, i, linsts) == OK )
  if( line2 == frstln )
    linsts = ERR
else if( lin(i) == 's' | lin(i) == 'S' )
{
  status = ERR
  i = i + 1
  if( optpat( lin, i, LEFT_HAND_SIDE ) == OK )
    andif( getrhs( lin, i, sub, gflag) == OK )
    {
      junk = gettxt(line2)			# Fetch line.
      status = subst( txt, lin, sub, gflag)	# Modify line.
    }
}
else
{
  junk = gettxt(line2)
  call strcpy( txt, lin)
}
if( linsts == ERR )
{
  final = ERR
  call strcpy( badlin, lin)
}
else if( status == ERR )
{
  final = ERR
  call strcpy( badpat, lin)
}
else
  final = length(lin)
curln = lastln
return(final)

end
#-h- getb             407  asc  06-apr-82 14:54:06  j (sventek j)
### LP_GetB	Get `value' of `type' in `buf(index)' (LogPmt)
subroutine getb( index, type, value)

integer    index, type
integer    value(2)

I_CLOG00

if( type == PREV )
  value(1) = buf(index)
else if( type == NEXT )
  value(1) = buf( index + 1 )
else if( type == SEEKADR )
{
  value(1) = buf( index + 2 )
  value(2) = buf( index + 3 )
}
else if( type == LINEID )
  value(1) = buf( index + 4 )

return
end
#-h- getind           213  asc  06-apr-82 14:54:06  j (sventek j)
### LP_GetInd	Locate line index in buffer (LogPmt version)
integer    function getind(lin)
integer    lin, k, j

I_CLOG01

k = LINE0
for( j = frstln ; j < lin ; j = j + 1 )
  call getb( k, NEXT, k)

return(k)
end
#-h- getlst           584  asc  06-apr-82 14:54:07  j (sventek j)
### LP_GetLst	Collect line numbers at `lin(i)'; increment `i'. (LogPmt)
integer    function getlst( lin, i, status)
character  lin(MAXLINE)
integer    getone # function(s)
integer    i, num, status
I_CLOG01

line2 = 0
for( nlines = 0 ; getone( lin, i, num, status) == OK ;  )
{
  line1 = line2
  line2 = num
  nlines = nlines + 1
  if( lin(i) != ',' & lin(i) != ';' )
    break
  if( lin(i) == ';' )
    curln = num
  i = i + 1
}
nlines = min( nlines, 2)
if( nlines == 0 )
  line2 = curln
if( nlines <= 1 )
  line1 = line2
if( status != ERR )
  status = OK
getlst = status
return
end
#-h- getnum           952  asc  06-apr-82 14:54:08  j (sventek j)
### LP_GetNum	Convert one term to line number. (LogPmt)
integer    function getnum( lin, i, pnum, status)
character  lin(MAXLINE)
integer    ctoi, index, nextln, optpat, prevln, ptscan # function(s)
integer    i, pnum, status
I_CLOG01
I_CLOG02
string digits "0123456789"

getnum = OK
if( index( digits, lin(i) ) > 0 )
{
  pnum = ctoi( lin, i)
  i = i - 1 # move back; to be advanced at the end
}
else if( lin(i) == CURLINE )
  pnum = curln
else if( lin(i) == LASTLINE )
  pnum = lastln
else if( lin(i) == PREVLINE )
  pnum = prevln(curln)
else if( lin(i) == NEXTLINE )
  pnum = nextln(curln)
else if( lin(i) == SCAN | lin(i) == BACKSCAN )
{
  if( optpat( lin, i, LINE_NUMBER ) == ERR ) # build the pattern
    getnum = ERR
  else if( lin(i) == SCAN )
    getnum = ptscan( FORWARD, pnum)
  else
    getnum = ptscan( BACKWARD, pnum)
}
else
  getnum = EOF
if( getnum == OK )
  i = i + 1 # point at next character to be examined
status = getnum
return
end
#-h- getone           875  asc  06-apr-82 14:54:10  j (sventek j)
### LP_GetOne	Evaluate one line number expression. (LogPmt)
integer    function getone( lin, i, num, status)
character  lin(MAXLINE)
integer    getnum # function(s)
integer    i, istart, mul, num, pnum, status
I_CLOG01

istart = i
num = frstln
call skipbl( lin, i)
if( getnum( lin, i, num, status) == OK ) # first term
  repeat # + or - terms
  {
    call skipbl( lin, i)
    if( lin(i) != '+' & lin(i) != '-' )
    {
      status = EOF
      break
    }
    if( lin(i) == '+' )
      mul =  +1
    else
      mul =  -1
    i = i + 1
    call skipbl( lin, i)
    if( getnum( lin, i, pnum, status) == OK )
      num = num + mul * pnum
    if( status == EOF )
      status = ERR
  }
  until( status != OK )
if( num < frstln | num > lastln )
  status = ERR

if( status == ERR )
  getone = ERR
else if( i <= istart )
  getone = EOF
else
  getone = OK

status = getone
return
end
#-h- getrhs           675  asc  06-apr-82 14:54:11  j (sventek j)
### LP_GetRhs	Get substitution string for `s' command. (LogPmt)
integer    function getrhs( lin, i, sub, gflag)

character  lin(MAXLINE), sub(MAXPAT)
integer    index, length, maksub # function(s)
integer    gflag, i, j
character  clower # function(s)

getrhs = ERR
if( lin(i) == EOS )
  return
if( lin( i + 1 ) == EOS )
  return
if( index( lin( i + 1 ), lin(i) ) == 0 ) # insert missing delimiter
{
  j = length(lin)
  call chcopy( lin(i), lin, j)
  call chcopy( '@n', lin, j) # add trailing '@n'
}
i = maksub( lin, i + 1, lin(i), sub)
if( i == ERR )
  return
i = i + 1
if( clower( lin(i) ) == GLOBAL )
{
  i = i + 1
  gflag = YES
}
else
  gflag = NO
getrhs = OK
return
end
#-h- gettxt           442  asc  06-apr-82 14:54:12  j (sventek j)
### LP_GetTxt	Locate text for line, copy to `txt'. (LogPmt)
integer    function gettxt(lin)

integer    getind, getlin # function(s)
integer    lin, len, j, k, junk
integer    loc(2)
I_CLOG00
I_CLOG03
I_CLOG04
I_CLOG01

string null ""

if( lin > frstln & lin <= lastln )
{
  k = getind(lin)
  call getb( k, SEEKADR, loc)
  call seek( loc, scr)
  junk = getlin( txt, scr)
}
else
{
  k = LINE0
  call strcpy( null, txt)
}
gettxt = k
return
end
#-h- gtfndx           222  asc  06-apr-82 14:54:13  j (sventek j)
### LP_GtFNdx	Get index for next line. (LogPmt)
integer    function gtfndx(newind)

I_CLOG00

if( lastbf + BUFENT < MAXBUF )
{
  newind = lastbf
  lastbf = lastbf + BUFENT
}
else
  newind = ERR
gtfndx = newind

return
end
#-h- inject           790  asc  06-apr-82 14:54:14  j (sventek j)
### LP_Inject	Insert `lin' after `curln'; write scratch. (LogPmt)
integer    function inject(lin)

character  lin(MAXLINE)
integer    gtfndx, note # function(s)
integer    k1, newind, junk

I_CLOG01
I_CLOG03

if( gtfndx(newind) == ERR )
{
  call getb( LINE0, NEXT, newind)	# Get index of frstln.
  call getb( newind, NEXT, k1)		# Get index of second line.
  call relink( LINE0, k1, LINE0, k1)	# Unlink frstln.
  frstln = frstln + 1
}
call setb( newind, SEEKADR, scrend)
call seek( scrend, scr)
call putlin( lin, scr)
junk = note ( scrend, scr)
call setb( newind, LINEID, number)
number = number + 1
call getb( LINE0, PREV, k1)		# Get index of lastln.
call relink( k1, newind, newind, LINE0)
call relink( newind, LINE0, k1, newind)
lastln = lastln + 1
curln = lastln
inject = OK

return
end
#-h- nextln           171  asc  06-apr-82 14:54:15  j (sventek j)
### LP_NextLn	Get line after `lin'. (LogPmt)
integer    function nextln(lin)

integer    lin
I_CLOG01

nextln = lin + 1
if( nextln > lastln )
  nextln = frstln
return
end
#-h- optpat           734  asc  06-apr-82 14:54:16  j (sventek j)
### LP_OptPat	Make pattern if specified at `lin(i)'. (LogPmt)
integer    function optpat( lin, i, type)

character  lin(MAXLINE)
integer    index, length, makpat # function(s)
integer    i, j, type
I_CLOG02

if( lin(i) == EOS )
  i = ERR
else if( lin( i + 1 ) == EOS )
  i = ERR
else
{
  if( type == LINE_NUMBER )
    andif( index( lin( i + 1 ), lin(i) ) == 0 )	# Add missing delimiter.
    {
      j = length(lin)				# Location of '@n'.
      call chcopy( lin(i), lin, j)		# Add delimiter.
      call chcopy( '@n', lin, j)
    }
  if( lin( i + 1 ) == lin(i) )
    i = i + 1
  else
    i = makpat( lin, i + 1, lin(i), pat)
}
if( pat(1) == EOS )
  i = ERR
if( i == ERR )
{
  pat(1) = EOS
  optpat = ERR
}
else
  optpat = OK
return
end
#-h- prevln           172  asc  06-apr-82 14:54:17  j (sventek j)
### LP_PrevLn	Get line before `lin'. (LogPmt)
integer    function prevln(lin)

integer    lin
I_CLOG01

prevln = lin - 1
if( prevln < frstln )
  prevln = lastln
return
end
#-h- ptscan           405  asc  06-apr-82 14:54:18  j (sventek j)
### LP_PtScan	Scan for next occurrence of pattern. (LogPmt)
integer    function ptscan( way, num)

integer    k, num, way
integer    gettxt, match, nextln, prevln # function(s)
I_CLOG01
I_CLOG02
I_CLOG04

num = curln
repeat
{
  if( way == FORWARD )
    num = nextln(num)
  else
    num = prevln(num)
  k = gettxt(num)
  if( match( txt, pat) == YES )
    return(OK)
}
until( num == curln )
return(ERR)
end
#-h- relink           164  asc  06-apr-82 14:54:19  j (sventek j)
### LP_Relink	Rewrite two half line links. (LogPmt)
subroutine relink( a, x, y, b)

integer    a, b, x, y

call setb( x, PREV, a)
call setb( y, NEXT, b)
return
end
#-h- setb             408  asc  06-apr-82 14:54:20  j (sventek j)
### LP_SetB	Set `type' in `buf(index)' to `value'. (Logpmt)
subroutine setb( index, type, value)

integer    index, type
integer    value(2)

I_CLOG00

if( type == PREV )
  buf(index) = value(1)
else if( type == NEXT )
  buf( index + 1 ) = value(1)
else if( type == SEEKADR )
{
  buf( index + 2 ) = value(1)
  buf( index + 3 ) = value(2)
}
else if( type == LINEID )
  buf( index + 4 ) = value(1)

return
end
#-h- setbuf           607  asc  06-apr-82 14:54:21  j (sventek j)
### LP_SetBuf	Create scratch file, set up line 0. (LogPmt)
subroutine setbuf

filedes    create # function(s)
integer    gtfndx, note # function(s)
integer    junk, k

I_CLOG00
I_CLOG01
I_CLOG03

string fil "log"

call scratf( fil, scrfil) 		# Get unique name for scratch file.
scr = create( scrfil, READWRITE)
if( scr == ERR )
  call cant(scrfil)
junk = note ( scrend, scr)
lastbf = LINE0
junk = gtfndx(k)			# Get index of line 0.
call relink( k, k, k, k)		# Establish initial linked list.
frstln = 0				# Initialize first line.
curln = 0
lastln = 0
number = 1				# Next available line number.

return
end
#-h- subst            836  asc  06-apr-82 14:54:22  j (sventek j)
### LP_Subst	Substitute `sub' for occurrences of pattern. (LogPmt)
integer    function subst( old, new, sub, gflag)

character  new(MAXLINE), old(MAXLINE), sub(MAXPAT)
integer    addset, amatch # function(s)
integer    gflag, j, junk, k, lastm, m, subbed

I_CLOG01
I_CLOG02

j = 1
subbed = NO
lastm = 0
for( k = 1 ; old(k) != EOS ;  )
{
  if( gflag == YES | subbed == NO )
    m = amatch( old, k, pat)
  else
    m = 0
  if( m > 0 & lastm != m ) # replace matched text
  {
    subbed = YES
    call catsub( old, k, m, sub, new, j, MAXLINE)
    lastm = m
  }
  if( m == 0 | m == k ) # no match or null match
  {
    junk = addset( old(k), new, j, MAXLINE)
    k = k + 1
  }
  else # skip matched text
    k = m
}
if( addset( EOS, new, j, MAXLINE) == NO )
  subst = ERR
else if( subbed == NO )
  subst = ERR
else
  subst = OK

return
end
#-h- logend           734  asc  06-apr-82 14:54:23  j (sventek j)
### LP_ClrBuf	CLear buffer and gun scratch file. (LogPmt)
subroutine logend( fil, access)

character  c, fil(FILENAMESIZE)
character  getch # function(s)
filedes    create, open # function(s)
integer    access, out, junk
integer    remove # function(s)

I_CLOG03

call close(scr)
if( fil(1) != EOS )		# User wants file saved.
{
  scr = open( scrfil, READ)	# Reopen scrfil at beginning.
  if( scr != ERR )		# Better not be any errors.
  {
    out = create( fil, access)	# Open user's file at desired access.
    if( out != ERR )		# Hope there's no error.
    {
      while( getch( c, scr) != EOF )	# Copy the log file.
        call putch( c, out)
      call close(out)
    }
    call close(scr)
  }
}
junk = remove(scrfil)

return
end
#-h- imsort.r        4309  asc  25-mar-82 06:52:48  v1.1 (sw-tools v1.1)
#-h- imsym            295  asc  25-mar-82 06:48:36  v1.1 (sw-tools v1.1)
define(LAST_PUT,0)	# offset into Mem for last put pointer
define(LAST_GET,1)	#   "     "     "     "   "   get   "
define(LAST_PTR,2)	# offset into Mem for last pointer
define(START_DATA,3)	# offset into Mem for start of pointer array
define(LOGPTR,20)	# log base 2 of number of entries to sort
#-h- iminit           494  asc  25-mar-82 06:48:37  v1.1 (sw-tools v1.1)
## IMInit -- Initialize in-memory sorting array.

pointer    function iminit( memsiz, avetok)

integer    memsiz, avetok

DS_DECL( Mem, 1)

integer    ptrsiz
pointer    table
pointer    dsget

call dsinit(memsiz)
ptrsiz = START_DATA + ( memsiz / ( 1 + avetok / CHAR_PER_INT ) )
table = dsget(ptrsiz)
if( table != LAMBDA )
{
  Mem( table + LAST_PUT ) = table + START_DATA - 1
  Mem( table + LAST_GET ) = table + START_DATA - 1
  Mem( table + LAST_PTR ) = table + ptrsiz - 1
}

return(table)
end
#-h- imget            360  asc  25-mar-82 06:48:39  v1.1 (sw-tools v1.1)
## IMGet -- Get next token from in-memory sort area

integer    function imget( table, buf)

pointer    table
character  buf(ARB)

DS_DECL( Mem, 1)

integer    i

if( Mem( table + LAST_GET ) < Mem( table + LAST_PUT ) )
{
  i = Mem( table + LAST_GET ) + 1
  Mem( table + LAST_GET ) = i
  call scopy( cMem, Mem(i), buf, 1)
  return(OK)
}
else
  return(EOF)

end
#-h- imsort          1027  asc  25-mar-82 06:48:41  v1.1 (sw-tools v1.1)
## IMSort -- Quicksort for character lines.
subroutine imsort(table)

pointer    table

DS_DECL( Mem, 1)

integer    imcomp
integer   i, j, lv(LOGPTR), p, pivlin, uv(LOGPTR)

lv(1) = table + START_DATA
uv(1) = Mem( table + LAST_PUT )
p = 1
while( p > 0 )
  if( lv(p) >= uv(p) ) # only one element in this subset 
    p = p - 1 # pop stack 
else
{
  i = lv(p) - 1
  j = uv(p)
  pivlin = Mem(j) # pivot line 
  while( i < j )
  {
    for( i = i + 1 ; imcomp( Mem(i), pivlin, cMem) < 0 ; i = i + 1 )
       ;
    for( j = j - 1 ; j > i ; j = j - 1 )
      if( imcomp( Mem(j), pivlin, cMem) <= 0 )
        break
    if( i < j ) # out of order pair 
      call imexch( Mem(i), Mem(j), cMem)
  }
  j = uv(p) # move pivot to position i 
  call imexch( Mem(i), Mem(j), cMem)
  if( i - lv(p) < uv(p) - i ) # stack so shorter done first 
  {
    lv( p + 1 ) = lv(p)
    uv( p + 1 ) = i - 1
    lv(p) = i + 1
  }
  else
  {
    lv( p + 1 ) = i + 1
    uv( p + 1 ) = uv(p)
    uv(p) = i - 1
  }
  p = p + 1 # push onto stack 
}
return
end
#-h- imput            447  asc  25-mar-82 06:48:42  v1.1 (sw-tools v1.1)
## IMPut -- Put a token into the in-memory sort area.

integer    function imput( table, buf)

pointer    table
character  buf(ARB)

DS_DECL( Mem, 1)

pointer    text
pointer    sdupl
integer    i

imput = ERR
if( Mem( table + LAST_PUT ) < Mem( table + LAST_PTR ) )
{
  text = sdupl(buf)
  if( text != LAMBDA )
  {
    i = Mem( table + LAST_PUT ) + 1
    Mem( table + LAST_PUT ) = i
    Mem(i) = cvt_to_cptr(text)
    imput = OK
  }
}

return
end
#-h- imexch           175  asc  25-mar-82 06:48:44  v1.1 (sw-tools v1.1)
## IMExch -- Exchange linbuf(lp1) with linbuf(lp2) .

subroutine imexch( lp1, lp2, linbuf)
character  linbuf(ARB)
integer    k, lp1, lp2

k = lp1
lp1 = lp2
lp2 = k
return
end
#-h- imcomp           320  asc  25-mar-82 06:48:45  v1.1 (sw-tools v1.1)
## IMComp -- Compare two strings in in-memory sort area.

integer    function imcomp( i, j, lin)

integer    i, j, k, l
character  lin(ARB)

k = i
l = j
while( lin(k) == lin(l) )
{
  if( lin(k) == EOS )
    return(0) # strings are equal
  k = k + 1
  l = l + 1
}
if( lin(k) < lin(l) )
  return(-1)
else
  return(1)

end
#-h- imuniq           417  asc  25-mar-82 06:48:47  v1.1 (sw-tools v1.1)
subroutine imuniq(table)

pointer table

DS_DECL(Mem, 1)

integer imcomp
integer last, out, cur, next

last = Mem(table + LAST_PUT)
out = table + START_DATA
for (cur = table + START_DATA; cur <= last; cur = next)
  {
  for (next = cur + 1; next <= last; next = next + 1)
    if (imcomp(Mem(cur), Mem(next), cMem) != 0)
      break
  Mem(out) = Mem(cur)
  out = out + 1
  }
Mem(table + LAST_PUT) = out - 1

return
end
#-h- imrset           117  asc  25-mar-82 06:48:48  v1.1 (sw-tools v1.1)
subroutine imrset(table)

pointer table

DS_DECL(Mem,1)

Mem (table + LAST_GET) = table + START_DATA - 1

return
end
#-h- lnedit.w       43426  asc  02-aug-83 08:59:20  tools (lblh csam sventek)
#-h- cledit          1486  asc  25-mar-82 06:44:47  v1.1 (sw-tools v1.1)
## CLEdit - Common block for intra-line editing routines.

common /cledit/ hastab, lc1, nc, nmaxpc, npc, oc, omaxpc, opc, pc1, qp,
		tabs(MAXLINE), undcur,
		fl(MAXLINE), nl(MAXLINE), npl(MAXLINE), ol(MAXLINE),
		opl(MAXLINE), oq(MAXLINE), tmplin(MAXLINE),
		undlin(MAXLINE)

integer   hastab	# YES if output device has hardware tabs
integer   lc1		# First logical character after prompt
integer   nc		# New logical cursor position
integer   nmaxpc	# New maximum physical cursor position written
integer   npc		# New physical cursor position
integer   oc		# Old logical cursor position
integer   omaxpc	# Old maximum physical column written
integer   opc		# Old physical cursor position
integer   pc1		# First physical character after prompt
integer   qp		# Pointer to next char in output queue
integer   tabs		# Array of tab stops -- YES(set) | NO(reset)
integer   undcur	# Logical cursor postion of line in `undo' buffer

character fl		# Full logical line (with prompt)
character nl		# New logical line
character npl		# New physical line
character ol		# Old logical line
character opl		# Old physical line
character oq		# Output queue for line refreshing
character tmplin	# Scratch line buffer
character undlin	# Line in `undo' buffer

# Note: All the line editing routines expect to have `ol' and
#	`oc' set to the current state of the line on the screen
#	when they are invoked.  All routines are expected to export
#	`nl' and `nc' as the (desired) state of the line on the screen.
#-h- coldcm           204  asc  25-mar-82 06:44:48  v1.1 (sw-tools v1.1)
# /coldcm/ - common block holding `last command stack' for shell
# put on a file named `colccm'
# used only by the shell

common /coldcm/ oldcmd(MAXLINE)

character oldcmd	# just one line held for now...
#-h- lnedit.r       41331  asc  01-aug-83 16:55:54  tools (lblh csam sventek)
#-h- defns           1404  asc  01-aug-83 16:55:11  tools (lblh csam sventek)
## defns  - Definitions for intra-line editing.

define(APPENDPREV,1)	# ^A
define(DIRECTORYLIST,4)	# ^D
define(EDITLINE,5)	# ^E
define(ENDOFFILE,26)	# ^Z
define(LINEDELETE,21)	# ^U
define(RECOGNIZEFILE,6)	# ^F
define(RETYPELINE,18)	# ^R
define(WORDDELETE,23)	# ^W

define(PB_SIZE,512)	# push back buffer size

# The following definitions are required to avoid potential name
# conflicts in `rlib'.

define(alphan,le_alphan)
define(bckupc,le_bckupc)
define(d2eol,le_d2eol)
define(dnoise,le_dnoise)
define(ds,le_ds)
define(fclosd,le_fclosd)
define(fgdrpr,le_fgdrpr)
define(flushq,le_flushq)
define(fopend,le_fopend)
define(gthist,le_gthist)
define(insstr,le_insstr)
define(ledit,le_ledit)
define(leinit,le_leinit)
define(lerror,le_lerror)
define(ll2pl,le_ll2pl)
define(lngest,le_lngest)
define(mvcurq,le_mvcurq)
define(ngetch,le_ngetch)
define(ngtnum,le_ngtnum)
define(pbcmd,le_pbcmd)
define(pbinit,le_pbinit)
define(pbstr,le_pbstr)
define(putbak,le_putbak)
define(putchf,le_putchf)
define(putchq,le_putchq)
define(putstf,le_putstf)
define(putstq,le_putstq)
define(rawio,le_rawio)
define(rawtxt,le_rawtxt)
define(recogf,le_recogf)
define(saveln,le_saveln)
define(scn4ch,le_scn4ch)
define(scnbbw,le_scnbbw)
define(scnbck,le_scnbck)
define(scnblw,le_scnblw)
define(scnebw,le_scnebw)
define(scnelw,le_scnelw)
define(spawnd,le_spawnd)
define(spnbck,le_spnbck)
define(updlin,le_updlin)
define(whites,le_whites)
#-h- lnedit          4856  asc  25-mar-82 06:43:17  v1.1 (sw-tools v1.1)
## LnEdit - Prompt for command line, with unCOOKED editing.

integer function lnedit( pstr, lin, ichn)

include coldcm

integer   cmdnum, i, ichn, imode, j, junk, k, len, ochn, omode, savmod
integer   index, length, prompt, recogf, scnbck, spawn, spnbck, stmode, isatty
integer   gthist, rawio
character lin(ARB), pid(PIDSIZE), pstr(ARB), tmp(FILENAMESIZE)
character c
character ledit
character bsblbs(4), crlf(3), ctrlr(5), ctrlu(5), ctrlz(5)
character rubcmd(4), wrdrub(6)
character ngetch

string bol "%"
string dstr "d "
string pthtrm " /\"	# Terminator array for backscan
string filtrm " ,<>@@"	# Terminator string for filename
string fldtrm " /\@@~>"	# Terminator string for field of path

data bsblbs/BACKSPACE, ' ', BACKSPACE, EOS/
data crlf/CR, LF, EOS/
data ctrlr/'^', 'R', CR, LF, EOS/
data ctrlu/'^', 'U', CR, LF, EOS/
data ctrlz/'^', 'Z', CR, LF, EOS/
data rubcmd/EDITLINE, 'x', ENDOFFILE, EOS/
data wrdrub/' ', EDITLINE, 'B', 'D', ENDOFFILE, EOS/
data ochn /EOF/

if( rawio( ichn, ochn, savmod) == NO )	# Can't do unCOOKED io.
  return( prompt( pstr, lin, ichn))

i = 1
call putlin( crlf, ochn)
call putlin( pstr, ochn)
lin(1) = EOS
repeat
{
  c = ngetch( c, ichn)
  if( c == ENDOFFILE )
  {
    call putlin( ctrlz, ochn)
    lnedit = EOF
    lin(1) = EOS
    return
  }
  else if( c == CR ) # CARRIAGE_RETURN
    break
  else if( c == LF )
    call putch( LF, ochn)
  else if( c == BACKSPACE | c == RUBOUT )
  {
    if( i > 1 )
    {
      if( lin(i-1) == '@t' )
        call pbstr( rubcmd)
      else
      {
        call putlin(bsblbs, ochn)
        i = i - 1
        lin(i) = EOS
      }
    }
    else
      lin(i) = EOS
  }
  else if( c == LINEDELETE )
  {
    call putlin( ctrlu, ochn)
    call putlin( pstr, ochn)
    i = 1
    lin(i) = EOS
  }
  else if( c == RETYPELINE )
  {
    call putlin( ctrlr, ochn)
    lin(i) = EOS
    call putlin( pstr, ochn)
    call putlin( lin, ochn)
  }
  else if( c == WORDDELETE )
  {
     call pbstr( wrdrub)
#    i = spnbck( lin, i, bsblbs, ochn, fldtrm)
#    i = scnbck( lin, i, bsblbs, ochn, fldtrm)
#    lin(i) = EOS
  }
  else if( c == RECOGNIZEFILE | c == ESC )
  {
    lin(i) = EOS
    j = scnbck( lin, i, EOS, ochn, filtrm)
    call scopy( lin, j, tmp, 1)
    len = length(tmp)
    if( recogf(tmp) != ERR )
    {
      if( tmp(len+1) != EOS ) # Progress was made...
      {
        call scopy( tmp, len+1, lin, i)
        call putlin( lin(i), ochn)
        i = length(lin) + 1
      }
      else
      {
        j = scnbck( lin, i, EOS, ochn, filtrm)
        k = 1
        call stcopy( dstr, 1, tmp, k)
        call scopy( lin, j, tmp, k)
        j = scnbck( tmp(k), length(tmp(k))+1, EOS, ochn, pthtrm) + k - 1
        call insstr( bol, tmp, j)
        call putlin( crlf, ochn)
        call spawnd( tmp)
        call putlin( crlf, ochn)
        call putlin( pstr, ochn)
        lin(i) = EOS
        call putlin( lin, ochn)
      }
    }
    else
      call putch( BELL, ochn)
  }
  else if( c == DIRECTORYLIST )
  {
    call putlin( "^Directory", ochn)
    call putlin( crlf, ochn)
    call spawnd( dstr)
    call putlin( crlf, ochn)
    call putlin( pstr, ochn)
    lin(i) = EOS
    call putlin( lin, ochn)
  }
  else if( c == APPENDPREV )
  {
    if( lin(1) == '!' ) # Retrieve line from history.
      i = gthist( lin, i)
    else
    {
      i = 1
      call stcopy( oldcmd, 1, lin, i)
    }
    call putlin( "^Append", ochn)
    call putlin( crlf, ochn)
    call putlin( pstr, ochn)
    call putlin( lin, ochn)
  }
  else if( c == EDITLINE )
  {
    if( (i == 1 & lin(i) == EOS) | lin(1) == '!' )
    {
      if( lin(1) == '!' ) # Retrieve command from history.
      {
        i = gthist( lin, i)
        i = 1
        call putlin( crlf, ochn)
        call putlin( pstr, ochn)
      }
      else
        call strcpy( oldcmd, lin)	# Retrieve previous command.
      call putlin( lin, ochn)
      call putch( CR, ochn)
      call putlin( pstr, ochn)
    }
    else if( i > 1 )
    {
      i = i - 1
      call putch( BACKSPACE, ochn)
    }
    c = ledit( pstr, lin, i, ichn, ochn)
    if( lin(i) != EOS )
    {
      call putch( lin(i), ochn)
      i = i + 1
    }
    if( c == CR ) # CARRIAGE_RETURN
      break
  }
  else if( c == VT )		# Pump out 8 LFs for a Vertical '@t'.
    for( j = 1 ; j <= 8 ; j = j + 1 )
      call putch( LF, ochn)
  else if( c == FF )		# Pump out 24 LFs for a Form Feed.
    for( j = 1 ; j <= 24 ; j = j + 1 )
      call putch( LF, ochn)
  else if( c < ' ' & c != '@t' ) # No control chars, please...
   call putch( BELL, ochn)
  else
  {
    lin(i) = c
    i = i + 1
    lin(i) = EOS
    call putch( c, ochn)
  }
}

call putch( CR, ochn)
#call putlin( crlf, ochn)

if( lin(1) != EOS ) # Save command for reedit.
{
  lin(i) = EOS
  call strcpy( lin, oldcmd)
}

lin(i) = '@n'
lin(i+1) = EOS
savmod = stmode( ichn, savmod)	# reset mode on unit

return(i)
end
#-h- alphan           210  asc  25-mar-82 06:43:20  v1.1 (sw-tools v1.1)
## AlphaN - Return YES if c is a LETTER or DIGIT, NO otherwise.

integer function alphan(c)

character c
integer   type

if( type(c) == LETTER | type(c) == DIGIT )
  alphan = YES
else
  alphan = NO

return
end
#-h- bckupc           647  asc  25-mar-82 06:43:21  v1.1 (sw-tools v1.1)
## BckUpC - Back up a character position; erase char if `erase' == YES.

subroutine bckupc( ochn, erase)

character  c
integer    erase, i, ochn
integer    tabpos
include    cledit
character  bs(2), bsblbs(4), rubstr(4)
data       bs /BACKSPACE, EOS/
data       bsblbs /BACKSPACE, ' ', BACKSPACE, EOS/

if( erase == YES )
  call strcpy( bsblbs, rubstr)
else
  call strcpy( bs, rubstr)

c = opl(opc-1)
if( c == '@t' )
{
  call putstq( bs, ochn)
  i = opc
  for( ; tabpos( i, tabs) == NO & i > 1 & opl(i-1) == '@t' ; i = i - 1 )
    call putstq( bs, ochn)
}
else if( c == ' ' )
  call putstq( bs, ochn)
else
  call putstq( rubstr, ochn)

return
end
#-h- d2eol            272  asc  25-mar-82 06:43:23  v1.1 (sw-tools v1.1)
## D2EOL  - Delete to End-of-line (omaxpc) on `ochn'.

integer function d2eol( ochn)

integer i, i1, i2, ochn
include cledit

i1 = opc
i2 = omaxpc
for( i = i1 ; i <= i2 ; i = i + 1 )
  call putchq( ' ', ochn)

d2eol = i2 - i1 + 1 # Number of blanks we output.

return
end
#-h- dnoise           726  asc  25-mar-82 06:43:24  v1.1 (sw-tools v1.1)
## DNoise - Remove noise from filename `fil'.  Noise is defined as:
##	    version numbers of `1', trailing `.', and `.dir' extensions.
##	    Return YES/NO if `fil' is a `.dir' file.

integer function dnoise( fil)

character fil(ARB)
integer   i, isdir
integer   equal, length # function(s)

string dot1 ".1"
string dotdir ".dir"

i = length( fil)

if( i > 2 )
  if( equal( fil(i-1), dot1) ) # Remove trailing ".1"
  {
    i = i - 2
    fil(i+1) = EOS
  }

if( fil(i) == '.' & i != 1 ) # Remove trailing "."
{
  fil(i) = EOS
  i = i - 1
}

isdir = NO

if( i > 3 )
  if( equal( fil(i-3), dotdir) ) # Replace ".dir" with "/".
  {
    i = i - 3
    fil(i) = '/'
    fil(i+1) = EOS
    isdir = YES
  }

dnoise = isdir
return
end
#-h- ds              1077  asc  25-mar-82 06:43:26  v1.1 (sw-tools v1.1)
integer function ds( inpstr, outstr)

character buf(MAXLINE), name(FILENAMESIZE), direc(FILENAMESIZE)
character pat(MAXLINE), path(FILENAMESIZE), tmpnam(FILENAMESIZE)
character inpstr(ARB), outstr(ARB)
integer j, i, junk, gtftok, dirfid, dnoise
integer fgdrpr, fopend, found, length
integer depth, ptr(10)
integer len, equal, lngest, patlen

found = NO
len = length(inpstr)
if( len == 0 | inpstr(len) == '/' )
{
  inpstr(len+1) = '*'
  inpstr(len+2) = EOS
}
call fold(inpstr)
call resdef( inpstr, path)
call exppth(path, depth, ptr, buf)
j = ptr(depth)
pat(1) = EOS
junk = gtftok(path, j, pat)
j = ptr(depth)
path(j) = EOS
call dirfil(path, name, direc)
if( fopend( name, dirfid) == ERR )
{
  ds = NO
  return
}
patlen = length(pat)
while( fgdrpr( dirfid, name) == OK )
{
  call strcpy( name, tmpnam)
  tmpnam(patlen+1) = EOS
  if( equal( tmpnam, pat) == NO & pat(1) != '*' )
    next
  junk = dnoise( name)
  if( found == NO )
  {
    call strcpy( name, outstr)
    found = YES
  }
  i = lngest( name, outstr)
  outstr(i+1) = EOS
}
call fclosd( dirfid)

ds = found
return
end
#-h- fclosd           213  asc  25-mar-82 06:43:28  v1.1 (sw-tools v1.1)
## FClosD - (VMS) Close directory file opened as `fd'.
##	    Use this version until `fgdrpr' & co. are taught to use
##	    RMS $PARSE and $SEARCH.

subroutine fclosd( fd)

integer fd

call close(fd)

return
end
#-h- fgdrpr          1308  asc  25-mar-82 06:43:30  v1.1 (sw-tools v1.1)
## FGDrPr - (VMS) Get (next) filename `fil' from directory open on `fd'.
##	    This routine should probably be rewritten to use RMS
##	    $PARSE and $SEARCH directives.  If you change it, be sure
##	    to fix `fopend' and `fclosd' as well...
##
## Note: `j' & `n' are expected to retain their values between calls...

integer function fgdrpr( fd, fil)

character fil(ARB)
character buf(MAXLINE)
integer   fd
integer   count, fdb, i, j, junk, len, n
integer   getfdb, gets, itoc, length # function(s)

integer*4 vers
logical*1 tmp(4), low, high
equivalence (tmp(1),vers), (low,tmp(1)), (high,tmp(2))

data j /0/
data n /0/
data vers /0/

fdb = getfdb(fd)
if( j >= n ) # Read next record and extract filename.
{
  n = gets( fdb, buf, MAXLINE)
  if( n == ERR )
  {
    fgdrpr = ERR
    fil(1) = EOS
    return
  }
  count = buf(4) # Byte count of directory entry record.
  j = 5
  for( i = 1 ; i <= count ; i = i + 1 )
  {
    fil(i) = buf(j)
    j = j + 1
  }
  fil(i) = '.'
  i = i + 1
  if( mod( j, 2) == 0 ) # Align on even byte boundary.
    j = j + 1
  len = i # Save length of filename.
}

i = len
low = buf(j)
high = buf(j+1)
j = j + 8 # Point to next version number.
junk = itoc(vers, fil(i), 10) # Tack on the version number.
i = length(fil) + 1
fil(i) = EOS
call fold(fil)
fgdrpr = OK

return
end
#-h- flushq           158  asc  25-mar-82 06:43:31  v1.1 (sw-tools v1.1)
## Flushq - Flush `oq' to `ochn'.

subroutine flushq( ochn)

integer ochn
include cledit

oq(qp) = EOS
call putlin( oq, ochn)
qp = 1
oq(qp) = EOS

return
end
#-h- fopend           308  asc  25-mar-82 06:43:33  v1.1 (sw-tools v1.1)
## FOpenD - (VMS) Open directory file `fil' for reading; return `fd'.
##	    Use this version until `fgdrpr' & co. are taught to
##	    use RMS $PARSE and $SEARCH.

integer function fopend( fil, fd)

character fil(ARB)
filedes   fd
integer   open # Function(s)

fd = open( fil, READ)
fopend = fd

return
end
#-h- gthist           256  asc  25-mar-82 06:43:34  v1.1 (sw-tools v1.1)
### GtHist	Get a line from the history file for `lnedit'.

integer function gthist( lin, i)

character	lin(ARB)
integer		i, j
integer		edline # function(s)

lin(i) = '@n'
lin( i + 1 ) = EOS

j = edline(lin)

if( j < 1 )
  j = 1
lin(j) = EOS

return(j)
end
#-h- insstr           248  asc  25-mar-82 06:43:36  v1.1 (sw-tools v1.1)
## InsStr - Insert string `s1' at position `i' of string `s2'.

subroutine insstr( s1, s2, i)

character  s1(ARB), s2(ARB), t(MAXLINE)
integer    i, j

call scopy( s2, i, t, 1)
j = i
call stcopy( s1, 1, s2, j)
call stcopy( t, 1, s2, j)

return
end
#-h- ledit          10256  asc  13-jun-83 12:49:17  sventek (joseph sventek)
## LEdit  - perform character editing on `lin'.

character function ledit( pstr, lin, cur, ichn, ochn)

include    cledit
integer    cur, ichn, i, j, n, ochn, status
integer    addstr, index, ll2pl, length, max, min
integer    savcur, scn4ch, scnbbw, scnblw, scnebw, scnelw, type
character  c, lin(ARB), pstr(ARB), savlin(MAXLINE)
character  ctrlr(5), delstr(4), finstr(3)
data       ctrlr /'^', 'R', CR, LF, EOS/
data       delstr /'d', ' ', EOS, EOS/ # Default `delete' command.
data       finstr /'f', ' ', EOS/ # Default `find' command.
character  ngetch, ngtnum

hastab = NO #!!! Make this a switch
call leinit( pstr, lin, cur, ochn)
call strcpy( nl, savlin)
savcur = nc
call saveln( nl, nc)
call updlin( ochn)

repeat
{
  n = 0
  c = ngtnum(n, ichn) # Get num. prefix (if any) & next char.

  switch(c) # Dispatch on character
  {
    case 'u': # Restore line before last change.
    {
      call strcpy( undlin, nl)
      nc = undcur
      call saveln( ol, oc)
    }
  
    case 'U': # Restore line to state at entry.
    {
      call strcpy( savlin, nl)
      nc = savcur
      call saveln( ol, oc)
    }
  
    case RETYPELINE: # Redisplay prompt and line.
    {
      if( ol(oc) != EOS )
        call putchq( ol(oc), ochn)
      call putstf( ctrlr, ochn)
      ol(1) = EOS
      oc = 1
      call putstf( pstr, ochn)
    }
  
    case ' ': # Move -> <n> chars.
    {
      if( nc + n > length(ol) + 1 )
        n = length(ol) - nc + 1
      nc = nc + n
    }
  
    case BACKSPACE, 'h': # Move <- <n> chars.
    {
      if( n >= nc )
        n = nc - 1
      nc = nc - n
    }
  
    case '%', '0': # Move to beginning of line.
      nc = 1
  
    case '$': # Move to end of line
      nc = length(ol)
  
    # Move -> <n> words.
    case 'w':
      nc = scnblw( ol, oc, n)
    case 'W':
      nc = scnbbw( ol, oc, n)
    case 'e':
      nc = scnelw( ol, oc, n)
    case 'E':
      nc = scnebw( ol, oc, n)
  
    case 'f': # Move thru <n>th instance of char.
    {
      finstr(1) = c
      c = ngetch( c, ichn)
      if( (c >= ' ' | c == '@t') & ol(oc) != EOS )
      {
        finstr(2) = c
        nc = scn4ch( ol, oc, c, n)
      }
    }
  
    case 't': # Move to <n>th instance of char.
    {
      finstr(1) = c
      c = ngetch( c, ichn)
      if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 )
      {
        finstr(2) = c
        nc = scn4ch( ol, oc+1, c, n) - 1
      }
    }
  
    case 'F': # Move <- thru <n>th instance of char.
    {
      finstr(1) = c
      c = ngetch( c, ichn)
      i = index( ol, c)
      if( (c >= ' ' | c == '@t') & i > 0 & i < oc )
      {
        finstr(2) = c
        n = -n
        nc = scn4ch( ol, oc, c, n)
        n = -n
      }
    }
  
    case 'T': # Move <- to <n>th instance of char.
    {
      finstr(1) = c
      c = ngetch( c, ichn)
      i = index( ol, c)
      if( (c >= ' ' | c == '@t') & i > 0 & i < oc - 1 )
      {
        finstr(2) = c
        n = -n
        nc = scn4ch( ol, oc-2, c, n) + 1
        n = -n
      }
    }
  
    case ';': # ReQueue last `find' command.
      call pbcmd( EOS, n, finstr)
  
    case ',': # ReQueue last `find' in reverse.
    {
      if( finstr(1) == 'f' )
        finstr(1) = 'F'
      else if( finstr(1) == 'F' )
        finstr(1) = 'f'
      else if( finstr(1) == 't' )
        finstr(1) = 'T'
      else
        finstr(1) = 't'
      call pbcmd( EOS, n, finstr)
    }
  
    case 'd': # Delete text object(s).
    {
      call saveln( ol, oc)
      c = ngtnum( n, ichn) # Allow count to follow `d' cmd.
  
      switch(c) # Dispatch for DELETE command
      {
        case '$': # Delete from cursor thru EOL.
          nl(nc) = EOS # nc will be adjusted by `updlin'.
  
        case '%': # Delete from BOL thru cursor.
        {
          call scopy( ol, oc+1, nl, 1)
          nc = 1
        }
  
        case 'd': # Delete entire line.
        {
          delstr(2) = c
          delstr(3) = EOS
          nl(1) = EOS
          nc = 1
        }
  
        case ' ': # Delete -> <n> chars.
        {
          delstr(2) = c
          delstr(3) = EOS
          if( oc + n > length(ol) + 1 )
            n = length(ol) - oc + 1
          call scopy( ol, oc+n, nl, oc)
        }
  
        case 'w', 'W', 'e', 'E': # Delete -> <n> words.
        {
          delstr(2) = c
          delstr(3) = EOS
          if( c == 'w' )
            i = scnblw( ol, oc, n)
          else if( c == 'W' )
            i = scnbbw( ol, oc, n)
          else if( c == 'e' )
            i = scnelw( ol, oc, n)
          else
            i = scnebw( ol, oc, n)
          if( ol(i) != EOS & ol(i+1) != EOS &
              ( c == 'e' | c == 'E' ) )
            i = i + 1
          if( i == oc & ol(i+1) == EOS ) # Rubout last char.
            i = i + 1
          call scopy( ol, i, nl, nc)
        }
  
        case 'b', 'B': # Delete <- <n> words.
        {
          delstr(2) = c
          delstr(3) = EOS
          n = -n
          if( c == 'b' )
            nc = scnblw( ol, oc, n)
          else
            nc = scnbbw( ol, oc, n)
          n = -n
          if( nc == oc & (ol(oc) == EOS | ol(oc+1) == EOS) )
            nl(nc) = EOS
          else
            call scopy( ol, oc, nl, nc)
        }
  
        case 'f': # Delete -> thru <n>th instance of char.
        {
          delstr(2) = c
          c = ngetch( c, ichn)
          delstr(3) = c
          if( (c >= ' ' | c == '@t') & ol(oc) != EOS )
          {
            i = scn4ch( ol, oc, c, n)
            if( i > oc )
              call scopy( ol, i+1, nl, oc)
          }
        }
  
        case 't': # Delete -> to <n>th instance of char.
        {
          delstr(2) = c
          c = ngetch( c, ichn)
          delstr(3) = c
          if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 )
          {
            i = scn4ch( ol, oc+1, c, n)
            if( i > oc + 1 )
              call scopy( ol, i, nl, oc)
          }
        }
  
        case 'F': # Delete <- thru <n>th instance of char.
        {
          delstr(2) = c
          c = ngetch( c, ichn)
          delstr(3) = c
          i = index( ol, c)
          if( (c >= ' ' | c == '@t') & i > 0 & i < oc )
          {
            n = - n
            i = scn4ch( ol, oc, c, n)
            n = -n
            call scopy( ol, oc, nl, i)
          }
        }
  
        case 'T': # Delete <- to <n>th instance of char.
        {
          delstr(2) = c
          c = ngetch( c, ichn)
          delstr(3) = c
          i = index( ol, c)
          if( (c >= ' ' | c == '@t') &
              i > 0 & i < oc - 1 & oc > 2 )
          {
            n = -n
            nc = scn4ch( ol, oc-2, c, n) + 1
            n = -n
            call scopy( ol, oc, nl, nc)
          }
        }
  
        default: # Illegal object specified to `Delete' cmd.
          call lerror( 0, ochn)
      }
    }  

    case '.': # ReQueue last `delete' command.
      call pbcmd( EOS, n, delstr)
  
    case 'b', 'B': # Move cursor <- <n> words.
    {
      n = -n
      if( c == 'b' )
        nc = scnblw( ol, oc, n)
      else
        nc = scnbbw( ol, oc, n)
      n = -n
    }
  
    case 'r': # Replace character under cursor.
    {
      c = ngetch( c, ichn)
      call saveln( ol, oc)
      if( c >= ' ' | c == '@t' )
        nl(nc) = c
    }
  
    case 'x': # Queue a `d ' command.
      call pbcmd( EOS, n, "d ")
  
    case 'X': # Delete <- <n> chars.
    {
      call saveln( ol, oc)
      if( n >= oc )
        n = oc - 1
      call strcpy( nl, ol)
      nc = oc - n
      call scopy( ol, oc, nl, nc)
    }
  
    case 'D': # Queue a `d$' command
      call pbcmd( EOS, n, "d$")
  
    case 'A': # Queue a `$<n>a' command
      call pbcmd( "$", n, "a")
  
    case 'I': # Queue a `%<n>i' command
      call pbcmd( "%", n, "i")
  
    case 'C': # Queue a `c$' command.
      call pbcmd( EOS, n, "c$")
  
    case 'a': # Append text after cursor.
    {
      call saveln( ol, oc)
      if( ol(oc) != EOS )
      {
        call putchf( ol(oc), ochn)
        oc = oc + 1
      }
      call rawtxt( oc, oc, n, ichn, ochn)
    }
  
    case 'i': # Insert text before cursor.
    {
      call saveln( ol, oc)
      call rawtxt( oc, oc, n, ichn, ochn)
    }
  
    case 'R': # Replace (overwrite) text at cursor.
    {
      call saveln( ol, oc)
      call rawtxt( oc, 0, n, ichn, ochn)
    }
  
    case 's': # Substitute new text for next <n> chars.
    {
      call saveln( ol, oc)
      i = min( oc+n-1, length(ol))
      c = nl(i)
      nl(i) = '$' # Mark end of text to be replaced.
      call updlin( ochn)
      nl(i) = c
      n = 1
      call rawtxt( oc, i+1, n, ichn, ochn)
    }
  
    case 'c': # Change text object
    {
      c = ngtnum( n, ichn) # Allow count to follow `c' cmd.
      call saveln( ol, oc)
  
      switch(c) # Dispatch for Change
      {
        case '$': # Change text from cursor thru EOL.
        {
          call rawtxt( oc, length(ol)+1, n, ichn, ochn)
        }
  
        case '%': # Change text from BOL thru cursor.
        {
          c = nl(oc)
          nl(oc) = '$'
          nc = 1
          call updlin( ochn)
          nl(oc) = c
          call rawtxt( nc, oc+1, n, ichn, ochn)
        }
  
        # Change -> <n> words.
        case 'w', 'W', 'e', 'E':
        {
          if( c == 'w' )
            i = scnblw( ol, oc, n)
          else if( c == 'W' )
            i = scnbbw( ol, oc, n)
          else if( c == 'e' )
            i = scnelw( ol, oc, n)
          else
            i = scnebw( ol, oc, n)
          if( i > 1 & ol(i+1) != EOS &
              (c == 'w' | c == 'W') )
            i = i - 1
          c = nl(i)
          nl(i) = '$'
          call updlin( ochn)
          nl(i) = c
          call rawtxt( oc, i+1, n, ichn, ochn)
        }
  
        default: # Illegal object specified to `Change' cmd.
          call lerror( 0, ochn)
      }
    }
  
    case CR: # CARRIAGE_RETURN -> return to caller
      break
  
    case ENDOFFILE, EDITLINE: # Move cursor to EOL.
    {
      nc = length(nl)
      call updlin( ochn)
      if( c == EDITLINE ) # Force CARRIAGE_RETURN.
        c = CR
      break
    }
  
    default:
      call lerror( 0, ochn)
  
  }

  call updlin( ochn) # Refresh line.
  call strcpy( nl, ol)
  oc = nc

}

nl(nc+1) = EOS
call strcpy( nl, lin)
cur = nc

ledit = c
return
end
#-h- leinit           686  asc  25-mar-82 06:43:45  v1.1 (sw-tools v1.1)
## LEInit - Initialize intra-line editing variables.

subroutine leinit( pstr, lin, curpos, ochn)

character  pstr(ARB), lin(ARB)
integer    cur, curpos, len, ochn
integer    length, ll2pl, max
include    cledit

len = max( length( lin), 1)
for( cur = curpos ; cur > len ; cur = cur - 1 )
  call putch( BACKSPACE, ochn)
call settab( EOS, tabs)
lc1 = 1
call stcopy( pstr, 1, fl, lc1)
pc1 = lc1 - 1
pc1 = ll2pl( fl, lc1-1, npl, npc) + 1
call scopy( lin, 1, fl, lc1)
nmaxpc = ll2pl( fl, cur+lc1-1, npl, npc)
call strcpy( npl, opl)
omaxpc = nmaxpc
opc = npc
call strcpy( lin, nl)
call strcpy( nl, ol)
call strcpy( nl, undlin)
nc = cur
oc = cur
undcur = cur

qp = 1
oq(qp) = EOS

return
end
#-h- lerror           173  asc  25-mar-82 06:43:46  v1.1 (sw-tools v1.1)
## LError - Process errors for intra-line editor.

subroutine lerror( errcod, ochn)

integer errcod, ochn

# For now, just ring bell...

call putch( BELL, ochn)

return
end
#-h- ll2pl           1015  asc  25-mar-82 06:43:48  v1.1 (sw-tools v1.1)
## LL2PL	Convert logical line to physical line; compute cursor posn.
##		Set `pc' to physical position corresponding to logical `lc'.
##		Return the maximum physical column written.

integer function ll2pl( ll, lc, pl, pc)

character c, ll(ARB), pl(ARB)
integer   i, lc, maxpc, pc, savepc
integer   max, tabpos # Function(s).
include   cledit

pc = 1
maxpc = 1
savepc = 1

for( i = 1 ; ll(i) != EOS ; i = i + 1 )
{
  c = ll(i)

  if( c >= ' ' & c < RUBOUT ) #!!! Warning: ASCII assumed !!!
  {
    pl(pc) = c
    pc = pc + 1
  }
  else if( c == '@t' )
  {
    repeat
    {
      pl(pc) = '@t'
      pc = pc + 1
    }
    until( tabpos( pc, tabs) == YES )
  }
  else # Misc. control char; reserve 2 columns.
  {
    pl(pc) = c
    pl(pc+1) = c
    pc = pc + 2
  }

  maxpc = max( maxpc, pc)
  if( i == lc ) # Save this pc.
    savepc = pc

}

pl(maxpc) = EOS
if( savepc > 1 )
  pc = max( savepc-1, pc1)
else
  pc = max( maxpc, pc1)
maxpc = max( maxpc-1, pc1) # Point at last char. written.
ll2pl = maxpc

return
end
#-h- lngest           253  asc  25-mar-82 06:43:50  v1.1 (sw-tools v1.1)
## lngest - Return length of the longest substring common to two strings.

integer function lngest( s1, s2)

integer   i
character s1(ARB), s2(ARB)

for( i = 1 ; s1(i) == s2(i) & s1(i) != EOS & s2(i) != EOS ; i = i + 1 )
  ;

lngest = i - 1

return
end
#-h- mvcurq           930  asc  25-mar-82 06:43:52  v1.1 (sw-tools v1.1)
## MvCurQ - Queue chars to move cursor from `c1' to `c2'.

integer function mvcurq( bcklin, fwdlin, c1, c2, ochn)

character bcklin(ARB), fwdlin(ARB)
integer   c1, c2, i, ochn
integer   putchq # Function(s).
include   cledit

if( c1 <= c2 ) # Move cursor right.
{
  for( i = c1 ; i <= c2 ; )
  {
    if( fwdlin(i) == EOS )
    {
      i = i + putchq( ' ', ochn)
      break
    }
    i = i + putchq( fwdlin(i), ochn)
  }
  i = i + putchq( BACKSPACE, ochn)
}
else # Move cursor left.
{
  if( c1 - c2 < c2 + 2 )
  {
    for( i = c1 ; i > c2 ; i = i + putchq( BACKSPACE, ochn) )
      ;
  }
  else
  {
    call putchq( CR, ochn)
    for( i = 1 ; i < pc1 ; i = i + 1 )
      call putchq( fl(i), ochn)
    while( i <= c2 )
    {
      if( fwdlin(i) == EOS )
      {
        i = i + putchq( ' ', ochn)
        break
      }
      i = i + putchq( fwdlin(i), ochn)
    }
    i = i + putchq( BACKSPACE, ochn)
  }
}

mvcurq = i

return
end
#-h- ngtnum           520  asc  25-mar-82 06:43:53  v1.1 (sw-tools v1.1)
## NGtNum - Get numeric prefix (if any) for intra-line commands.

character function ngtnum(n, ichn)

character c, ngetch
character numstr(12)
integer   i, n, ichn
integer   ctoi, type

c = ngetch( c, ichn)
if( c != '0' ) # Leading zeroes get passed back to caller.
  for( i = 1 ; type(c) == DIGIT ; i = i + 1 )
  {
    numstr(i) = c
    c = ngetch( c, ichn)
  }
if( i > 1 ) # Convert to integer.
{
  numstr(i) = EOS
  i = 1
  n = ctoi( numstr, i)
}
else if( n == 0 ) # Set default count.
  n = 1

ngtnum = c
return
end
#-h- pbcmd            353  asc  25-mar-82 06:43:55  v1.1 (sw-tools v1.1)
## PBCmd  - Put back a command for the intra-line editor.

define(NUMSTRSIZE,11)

subroutine pbcmd( prefix, num, cmdstr)

character  cmdstr(ARB), numstr(NUMSTRSIZE), prefix(ARB)
integer    junk, num
integer    itoc

call pbstr( cmdstr)

junk = itoc( num, numstr, NUMSTRSIZE)
call pbstr( numstr)

if( prefix(1) != EOS )
  call pbstr( prefix)

return
end
#-h- putchf           166  asc  25-mar-82 06:43:56  v1.1 (sw-tools v1.1)
## PutChF - Put character on `ochn' and flush queue.

subroutine putchf( c, ochn)

character  c
integer    ochn

call putchq( c, ochn)
call flushq( ochn)

return
end
#-h- putchq          1026  asc  25-mar-82 06:43:58  v1.1 (sw-tools v1.1)
## PutChQ - Put character into output queue.  Flush queue if required.

integer function putchq( c, ochn)

character  c
integer    cnt, i, ochn
integer    max, tabpos
include    cledit

i = opc
cnt = 1
if( c == '@t' )
{
  opl(opc) = '@t'
  for( opc = opc + 1 ; tabpos( opc, tabs) == NO ; opc = opc + 1 )
  {
    opl(opc) = '@t'
    cnt = cnt + 1
  }
}
else if( c == CR ) # CARRIAGE_RETURN
  opc = 1
else if( c == BACKSPACE )
  opc = max( opc - 1, 1)
else if( c >= ' ' )
{
  opl(opc) = c
  opc = opc + 1
}
else if( c != '@n' )
{
  opl(opc) = c
  opl(opc+1) = c
  opc = opc + 2
  cnt = 2
}

if( qp + cnt >= MAXLINE ) # Queue overflow. Flush it.
  call flushq( ochn)

if( c == '@t' & hastab == NO )
  for( ; cnt > 0 ; cnt = cnt - 1 )
  {
    oq(qp) = ' '
    qp = qp + 1
  }
else if( c >= ' ' | c == BACKSPACE | c == CR | c == '@n' )
{
  oq(qp) = c
  qp = qp + 1
}
else
{
  oq(qp) = '^'
  oq(qp+1) = c + '@@' #!!! Warning: ASCII assumed !!!
  qp = qp + 2
}

putchq = opc - i # Number of physical columns we've moved.

return
end
#-h- putstf           180  asc  25-mar-82 06:44:00  v1.1 (sw-tools v1.1)
## PutStF - Put string into output queue; flush queue.

subroutine putstf( str, ochn)

character str(ARB)
integer   i, ochn

call putstq( str, ochn)
call flushq( ochn)

return
end
#-h- putstq           196  asc  25-mar-82 06:44:01  v1.1 (sw-tools v1.1)
## PutStQ - Put string into output queue.

subroutine putstq( str, ochn)

character  str(ARB)
integer    i, ochn

for( i = 1 ; str(i) != EOS ; i = i + 1 )
  call putchq( str(i), ochn)

return
end
#-h- rawio            586  asc  25-mar-82 06:44:03  v1.1 (sw-tools v1.1)
## rawio - determine if rawpmt can be used on unit

integer function rawio( in, out, savmod)

integer in, out, savmod
integer create, stmode, isatty, gtmode

string ttystr TTY_NAME

if( out == EOF )			# need to open echo unit
{
  out = create( ttystr, WRITE)
  if( out != ERR )
    if(  stmode(out, RARE) != RARE )
    {
      call close(out)
      out = ERR
    }
}
rawio = NO
if( isatty(in) == YES & out != ERR )
{
  savmod = gtmode(in)			# save current mode
  if( stmode( in, RARE) == RARE )	# can do rare mode
    rawio = YES
  else
    savmod = stmode( in, savmod)
  }

return
end
#-h- rawtxt          1731  asc  25-mar-82 06:44:05  v1.1 (sw-tools v1.1)
## Rawtxt - Get raw text for insert, append, change, and replace.

subroutine rawtxt( fstcol, lstcol, n, ichn, ochn)

integer   end, i, ichn, fstcol, lstcol, n, ochn, olen, start
integer   length, max, whites # Function(s).
character c, tail(MAXLINE)
character getch
include   cledit

start = fstcol
end   = lstcol
olen = length(ol)

if( end != 0 )
  call scopy( ol, end, tail, 1) # Save rest of line.
else
  call strcpy( ol, tail)

i = start
for( c = getch( c, ichn) ; c != ENDOFFILE & c != ESC ; c = getch( c, ichn) )
{
  if( c == EDITLINE )
  {
    call putbak( EDITLINE)
    break
  }
  if( c == CR ) # CARRIAGE_RETURN
  {
    call putbak( CR)
    break
  }
  if( c == RUBOUT | c == BACKSPACE )
  {
    if( i > start )
    {
      i = i - 1
      call bckupc( ochn, NO)
      call flushq( ochn)
    }
  }
  else if( c == WORDDELETE )
  {
    for( ; i > start & whites(nl(i-1)) == YES ; i = i - 1 )
      call bckupc( ochn, NO)
    for( ; i > start & whites(nl(i-1)) == NO ; i = i - 1 )
      call bckupc( ochn, YES)
    call flushq( ochn)
  }
  else if( c >= ' ' | c == '@t' )
  {
    nl(i) = c
    ol(i) = c
    call putchf( c, ochn)
    i = i + 1
    nl(i) = EOS
  }
  else
    call putch( BELL, ochn)
}

nl(i) = EOS
if( i > olen )
  ol(i) = EOS
oc = i

call scopy( nl, start, tmplin, 1) # Insert text <n> times.
if( (length(tmplin)*n + start) < MAXLINE ) # Everything fits.
  for( n = n - 1 ; n > 0 ; n = n - 1 )
    call stcopy( tmplin, 1, nl, i)

nc = max( i - 1, start)

if( end != 0 ) # Not overwrite mode.
  call strcpy( tail, tmplin)
else
  call scopy( tail, i, tmplin, 1)

if( (length(tmplin) + i) < MAXLINE ) # Everything fits.
  call stcopy( tmplin, 1, nl, i)
else
  call putc( BELL, ochn)

nl(i) = EOS

return
end
#-h- recogf           482  asc  25-mar-82 06:44:07  v1.1 (sw-tools v1.1)
## recogf - Recognize longest unique filename substring matching %`str'.
##	    complete the string in `str'.

integer function recogf(str)

integer   i, j
integer   ds, length
character outstr(FILENAMESIZE), str(ARB)

j = length(str)
i = j
if( i > 0 )
  repeat
  {
    if( str(i) == '/' | str(i) == '\' )
      break
    i = i - 1
  }
  until( i == 0 )

if( ds( str, outstr) == NO )
{
  recogf = ERR
  return
}
else
{
  call scopy( outstr, 1, str, i+1)
  recogf = OK
}

return
end
#-h- saveln           175  asc  25-mar-82 06:44:08  v1.1 (sw-tools v1.1)
## SaveLn - Save line state for `undo'

subroutine saveln( lin, cur)

character  lin(ARB)
integer    cur
include    cledit

call strcpy( lin, undlin)
undcur = cur

return
end
#-h- scn4ch           561  asc  25-mar-82 06:44:10  v1.1 (sw-tools v1.1)
## Scn4Ch - Scan for <n>th occurence of char <c>.  Update <n>.

integer function scn4ch( lin, i, c, n)

integer   i, j, k, n
integer   index # function(s)
character c, lin(ARB)

if( n > 0 )
{
  for( j = i ; index( lin(j+1), c) > 0 & n > 0 ; n = n - 1 )
  {
    if( lin(j) == c )
      j = j + 1
    for( ; lin(j) != c & lin(j) != EOS ; j = j + 1 )
      ;
  }
}
else if( n < 0 )
{
  k = index( lin, c)
  for( j = i ; k < j & n < 0 ; n = n + 1 )
  {
    if( lin(j) == c )
      j = j - 1
    for( ; lin(j) != c ; j = j - 1 )
      ;
  }
}

scn4ch = j
return
end
#-h- scnbbw           684  asc  25-mar-82 06:44:12  v1.1 (sw-tools v1.1)
## ScnBBW - Scan to beginning of <n>th (big) word.  Update <n>.

integer function scnbbw( lin, i, n)

integer   i, j, n
integer   whites
character lin(ARB)

if( n > 0 )
{
  for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 )
  {
    for( ; whites(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 )
      ;
    for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 )
      ;
  }
}
else if( n < 0 )
{
  for( j = i ; j > 1 & n < 0 ; n = n + 1 )
  {
    if( whites(lin(j-1)) == YES ) # At beginning of word.
      j = j - 1
    for( ; whites(lin(j)) == YES & j > 1 ; j = j - 1 )
      ;
    for( ; j > 1 ; j = j - 1)
      if( whites( lin(j-1)) == YES )
        break
  }
}

return(j)
end
#-h- scnbck           727  asc  25-mar-82 06:44:13  v1.1 (sw-tools v1.1)
## ScnBck - Scan backwards until a terminator or boundary is reached.
##	Return the index of the last character scanned before terminator.
##	Output string `rubstr' on `chn' as each char is scanned.

integer function scnbck( str, col, rubstr, chn, trmara)

integer   i, chn, col
integer   index
character rubstr(ARB), str(ARB), trmara(ARB)

if( col > 1 )
{
  i = col - 1	# Point to last char entered.
  for( ; index( trmara, str(i)) == 0 & i > 1 ; i = i - 1 )
    if( rubstr(1) != EOS )
      call putlin( rubstr, chn)
  if( i == 1 & index( trmara, str(i)) == 0 )
  {
    if( rubstr(1) != EOS )
      call putlin( rubstr, chn)
  }
  else
    i = i + 1 # Point to next char to be entered.
}
else
  i = 1

scnbck = i

return
end
#-h- scnblw          1065  asc  25-mar-82 06:44:15  v1.1 (sw-tools v1.1)
## ScnBLW - Scan to beginning of <n>th (little) word. Update <n>.

integer function scnblw( lin, i, n)

integer   i, j, n
integer   alphan, whites # function(s)
character lin(ARB)

if( n > 0 )
{
  for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 )
  {
    if( alphan(lin(j)) == YES )
      for( ; alphan(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 )
        ;
    else if( alphan(lin(j)) == NO & whites(lin(j)) == NO )
      for( ; alphan(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 )
        ;
    for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 )
      ;
  }
}
else if( n < 0 )
{
  for( j = i ; j > 1 & n < 0 ; n = n + 1 )
  {
    for( j = j - 1 ; j > 1 ; j = j - 1 )
      if( whites( lin(j)) == NO )
        break

    if( j > 1 )
      if( alphan( lin(j)) == YES )
        for( ; j > 1 ; j = j - 1 )
          if( alphan( lin(j-1)) == NO )
            break

    if( j > 1 )
      if( alphan( lin(j)) == NO )
        for( ; alphan(lin(j-1)) == NO & whites(lin(j-1)) == NO ; j = j - 1 )
          if( j <= 2 )
            break
  }
}

return(j)
end
#-h- scnebw           550  asc  25-mar-82 06:44:17  v1.1 (sw-tools v1.1)
#### WARNING! case where n<0 has not been implemented.
## ScnEBW - Scan to end of <n>th (big) word.  Update <n>.

integer function scnebw( lin, i, n)

integer   i, j, n
integer   whites
character lin(ARB)

if( n > 0 )
{
  for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 )
  {
    if( whites(lin(j+1)) == YES ) # At end of word.
      j = j + 1
    for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 )
      ;
    for( ; whites(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 )
      ;
  }
}
else if( n < 0 )
{
  j = i
}

scnebw = j
return
end
#-h- scnelw           763  asc  25-mar-82 06:44:19  v1.1 (sw-tools v1.1)
#### WARNING! case where n<0 has not been implemented.
## ScnELW - Scan to end of <n>th (little) word.  Update <n>.

integer function scnelw( lin, i, n)

integer   i, j, n
integer   alphan, whites
character lin(ARB)

if( n > 0 )
{
  for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 )
  {
    if( lin(j) != EOS & lin(j+1) != EOS )
      j = j + 1
    for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 )
      ;
    if( alphan(lin(j)) == YES )
    {
      if( alphan(lin(j+1)) == YES )
        for( ; alphan(lin(j+1)) == YES ; j = j + 1 )
          ;
    }
    else if( alphan(lin(j+1)) == NO & whites(lin(j+1)) == NO )
      for( ; alphan(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 )
        ;
  }
}
else if( n < 0 )
{
  j = i
}

scnelw = j
return
end
#-h- spawnd           410  asc  25-mar-82 06:44:20  v1.1 (sw-tools v1.1)
## SpawnD -- Spawn the directory lister with an argument string.

subroutine spawnd(args)

character args(ARB), image(FILENAMESIZE), pid(PIDSIZE)
integer   loccom, spawn
integer   junk, init

string d "d"
string spath "@e~usr/@e~bin/@e@n"
string suffix IMAGE_SUFFIX

data init /YES/

if( init == YES )
{
  init = NO
  junk = loccom( d, spath, suffix, image)
}
junk = spawn( image, args, pid, WAIT)

return
end
#-h- spnbck           661  asc  25-mar-82 06:44:22  v1.1 (sw-tools v1.1)
## SpnBck - Span backwards until a non-separator or boundry is reached.
##	Return the index of the last character scanned before separator.
##	Output string `rubstr' on `chn' as each char is scanned.

integer function spnbck( str, col, rubstr, chn, separa)

integer   i, chn, col
integer   index
character rubstr(ARB), str(ARB), separa(ARB)

if( col > 1 )
{
  i = col - 1	# Point to last char entered.
  for( ; index( separa, str(i)) > 0 & i > 1 ; i = i - 1 )
    if( rubstr(1) != EOS )
      call putlin( rubstr, chn)
  if( i == 1 )
  {
    if( rubstr(1) != EOS )
      call putlin( rubstr, chn)
  }
  else
    i = i + 1
}
else
  i = 1

spnbck = i

return
end
#-h- updlin          1197  asc  25-mar-82 06:44:24  v1.1 (sw-tools v1.1)
## UpdLin - Update line on screen.

subroutine updlin( ochn)

integer   ochn
integer   i, j, k
integer   d2eol, index, length, ll2pl, max, min, mvcurq, putchq # Function(s).
include   cledit

nc = max( min( nc, length(nl) ), 1) # Make sure  1 <= nc <= length(nl).

call scopy( ol, 1, fl, lc1)
omaxpc = ll2pl( fl, oc+lc1-1, opl, opc)
call scopy( nl, 1, fl, lc1)
nmaxpc = ll2pl( fl, nc+lc1-1, npl, npc) # Translate log. line to phy. line.

for( i = pc1 ; opl(i) == npl(i) ; i = i + 1 ) # Find 1st difference.
  if( opl(i) == EOS | npl(i) == EOS )
    break

if( npl(i) != opl(i) ) # Line has changed.
{
  i = mvcurq( opl, npl, opc, i, ochn) # Move cursor there.

  if( nmaxpc == omaxpc & index( ol, '@t') == 0 ) # Save some repainting.
  {
    for( j = nmaxpc ; j > i ; j = j - 1 )
      if( opl(j) != npl(j) )
        break
  }
  else
    j = nmaxpc

  for( k = i ; k <= j & npl(k) != EOS ; ) # Output new text.
    k = k + putchq( npl(k), ochn)

  if( nmaxpc < omaxpc ) # Delete to end-of-line.
    k = k + d2eol( ochn)

  npc = mvcurq( npl, npl, k, npc, ochn) # Move cursor to desired position.
}
else # Just move cursor.
  npc = mvcurq( npl, npl, opc, npc, ochn)

call flushq( ochn)

return
end
#-h- whites           168  asc  25-mar-82 06:44:26  v1.1 (sw-tools v1.1)
## WhiteS - Return yes if char is `whitespace' ('@t' | ' ').

integer function whites( c)

character c

if( c == '@t' | c == ' ' )
  return(YES)
else
  return(NO)

end
#-h- ngetch           339  asc  01-aug-83 16:55:17  tools (lblh csam sventek)
# ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd

   include clpb

   external pbinit
 
   if (pbp > 0) {
      c = pbbuf(pbp)
      pbp = pbp - 1
      }
   else if (fd == ERR)
      c = EOF
   else
      c = getch(c, fd)
   ngetch = c
   return
   end
#-h- pbinit            50  asc  01-aug-83 16:55:17  tools (lblh csam sventek)
block data pbinit

include clpb

data pbp/0/

end
#-h- pbstr            342  asc  01-aug-83 16:55:18  tools (lblh csam sventek)
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(ARB)
   integer length
   integer i

   include clpb
 
   for (i = length(in); i > 0; i = i - 1)
      {
      pbp = pbp + 1
      if (pbp > PB_SIZE)
         call error("pbstr - too many characters pushed back")
      pbbuf(pbp) = in(i)
      }

   return
   end
#-h- putbak           235  asc  01-aug-83 16:55:18  tools (lblh csam sventek)
# putbak - push character back onto input
   subroutine putbak(c)
   character c

   include clpb
 
   pbp = pbp + 1
   if (pbp > PB_SIZE)
      call error("putbak - too many characters pushed back")
   pbbuf(pbp) = c
   return
   end
#-h- clpb             103  asc  01-aug-83 16:56:02  tools (lblh csam sventek)
common / clpb / pbp, pbbuf(PB_SIZE)

integer pbp		# buffer pointer
character pbbuf		# push back buffer
#-h- misc.r         23084  asc  03-aug-83 08:50:00  tools (lblh csam sventek)
#-h- acopy            280  asc  06-apr-82 15:06:50  j (sventek j)
## ACopy -- Copy `size' characters from `ifd' to `ofd'.
subroutine acopy( ifd, ofd, size)
character  getch # function(s)
character  c
filedes    ifd, ofd
integer    i, size

for( i = 1 ; i <= size ; i = i + 1 )
{
  if( getch( c, ifd) != EOF )
    call putch( c, ofd)
}
return
end
#-h- addset           241  asc  06-apr-82 15:06:51  j (sventek j)
## AddSet -- Put `c' in `string(j)' if it fits; increment `j'.
integer    function addset( c, str, j, maxsiz)

integer    j, maxsiz
character  c, str(maxsiz)

if( j > maxsiz )
  return(NO)
else
{
  str(j) = c
  j = j + 1
  return(YES)
}
end
#-h- addstr           226  asc  06-apr-82 15:06:52  j (sventek j)
integer function addstr(s, str, j, maxsiz)

character s(ARB), str(ARB)
integer j, maxsiz, i
integer length

if ((length(s) + j) > maxsiz)
  return(NO)
for (i=1; s(i) != EOS; i=i+1)
  call chcopy(s(i), str, j)

return(YES)
end
#-h- adrfil           222  asc  06-apr-82 15:06:53  j (sventek j)
## AdrFil -- Get name of software tools user-info database.
subroutine adrfil(file)

character  file(FILENAMESIZE)

string addr "address"

call getdir( MSGDIRECTORY, LOCAL, file)
call concat( file, addr, file)

return
end
#-h- alldig           412  asc  02-aug-83 22:10:04  tools (lblh csam sventek)
# alldig - return YES if str is all digits

   integer function alldig (str)
   character str (ARB)

ifnotdef(IS_DIGIT)
   character type
enddef

   integer i

   alldig = NO
   if (str (1) == EOS)
      return
   for (i = 1; str (i) != EOS; i = i + 1)
ifdef(IS_DIGIT)
      if (!IS_DIGIT(str (i)))
         return
elsedef
      if (type(str(i)) != DIGIT)
         return
enddef
   alldig = YES
   return
   end
#-h- badarg           247  asc  06-apr-82 15:06:55  j (sventek j)
## BadArg -- Output `invalid argument' message.
subroutine badarg(arg)

character  arg(ARB)
string msg1 "? Ignoring invalid argument `"
string msg2 "'@n"

call putlin( msg1, ERROUT)
call putlin( arg, ERROUT)
call putlin( msg2, ERROUT)

return
end
#-h- bubble           307  asc  06-apr-82 15:06:56  j (sventek j)
## Bubble -- bubble sort v(1)...v(n) increasing.
subroutine bubble( v, n)
integer    i, j, k, n, v(ARB)

for( i = n ; i > 1 ; i = i - 1 )
  for( j = 1 ; j < i ; j = j + 1 )
    if( v(j) > v( j + 1 ) )	# compare
    {
      k = v(j)			# exchange
      v(j) = v( j + 1 )
      v( j + 1 ) = k
    }
return
end
#-h- cant             313  asc  30-jul-83 17:51:29  tools (lblh csam sventek)
## Can't -- Display the bad news that `file' can't be opened; then exit
subroutine cant(file)

character file(ARB)

string msg1 "? Can't open file named `"
string msg2 "'@n"

call putlin( msg1, ERROUT)
call putlin( file, ERROUT)
call putlin( msg2, ERROUT)
call endst(ERR)		# Indicate error to parent process.
end
#-h- chcopy           128  asc  06-apr-82 15:06:57  j (sventek j)
# subroutine chcopy(c, buf, i)
#
# character c, buf(ARB)
# integer i
#
# buf(i) = c
# i = i + 1
# buf(i) = EOS
#
# return
# end
#-h- clower           367  asc  06-apr-82 15:06:58  j (sventek j)
# ## clower - change letter to lower case
#        character function clower(c)
#
#        character c, k
#
#        if (c >= 'A' & c <= 'Z')
#                {               #avoid integer overflow in byte machines
#                k = 'a' - 'A'
#                clower = c + k
#                }
#        else
#            clower = c
#
#        return
#        end
#-h- concat           191  asc  06-apr-82 15:06:59  j (sventek j)
# subroutine concat(first, second, out)
#
# character first(ARB), second(ARB), out(ARB)
# integer i
#
# i = 1
# call stcopy(first, 1, out, i)
# call scopy(second, 1, out, i)
#
# return
# end
#-h- ctoc             263  asc  06-apr-82 15:07:00  j (sventek j)
### CToC	Convert EOS-terminated string to EOS-terminated string

integer		function ctoc(from, to, len)
integer		len
character	from(ARB), to(len)

integer		i

for( i = 1 ; i < len & from(i) != EOS ; i = i + 1 )
  to(i) = from(i)

to(i) = EOS

return( i - 1 )

end
#-h- ctodi            486  asc  06-apr-82 15:07:01  j (sventek j)
## CToDI -- Convert character string to pair of integers.
subroutine ctodi( buf, i, di)

character  buf(ARB), hi(10), lo(6), temp(MAXCHARS)
integer    di(2), i, j, len
integer    ctoi, getwrd # function(s)

len = getwrd( buf, i, temp)
if( len <= 4 )
{
  hi(1) = EOS
  call strcpy( temp, lo)
}
else
{
  len = len - 4
  for( j = 1 ; j <= len ; j = j + 1 )
    hi(j) = temp(j)
  hi(j) = EOS
  call scopy( temp, j, lo, 1)
}
j = 1
di(1) = ctoi( hi, j)
j = 1
di(2) = ctoi( lo, j)

return
end
#-h- ctoi             470  asc  06-apr-82 15:07:02  j (sventek j)
## CToI -- Convert string at `in(i)' to integer; increment `i'.
integer    function ctoi( in, i)
character  in(ARB)
integer    index # function(s)
integer    d, i, sign
string digits "0123456789"

while( in(i) == ' ' | in(i) == '@t' )
  i = i + 1
sign = 1
if( in(i) == '-' )
{
  sign =  -1
  i = i + 1
}
for( ctoi = 0 ; in(i) != EOS ; i = i + 1 )
{
  d = index( digits, in(i) )
  if( d == 0 ) # non-digit
    break
  ctoi = 10 * ctoi + d - 1
}
return( sign * ctoi )
end
#-h- cupper           370  asc  06-apr-82 15:07:03  j (sventek j)
# ## cupper - change letter to upper case
#        character function cupper(c)
#
#        character c, k
#
#        if (c >= 'a' & c <= 'z')
#                {               #avoid overflow with byte-oriented machines
#                k = 'A' - 'a'
#                cupper = c + k
#                }
#        else
#            cupper = c
#
#        return
#        end
#-h- disize           379  asc  03-aug-83 08:49:37  tools (lblh csam sventek)
## DiSize -- determine size of `file' in characters as a double integer
integer    function disize(file, di)

character  getch # function(s)
character  c, file(ARB)
integer    open # function(s)
integer    di(2)
filedes    fd

initdi(di)
fd = open( file, READ)
if( fd == ERR )
  return(ERR)
else
{
  while (getch( c, fd) != EOF )
    incrdi(di)
  call close(fd)
}
return(OK)
end
#-h- ditoc            515  asc  06-apr-82 15:07:05  j (sventek j)
## DIToC -- Convert a pair of integers to a character string.
integer    function ditoc( di, buf, size)

integer    di(2), i, j, n, size
integer    itoc # function(s)
character  buf(size), lo(5), temp(MAXCHARS)

n = itoc( di(2), lo, 5)
if( di(1) > 0 )
{
  i = itoc( di(1), temp, MAXCHARS) + 1
  for( j = n + 1 ; j <= 4 ; j = j + 1 )
    call chcopy( '0', temp, i)
}
else
  temp(1) = EOS
call concat( temp, lo, temp)
n = length(temp) + 1 - size
i = max( n, 1)
call scopy( temp, i, buf, 1)
return( length(buf) )

end
#-h- equal            340  asc  06-apr-82 15:07:06  j (sventek j)
# ## equal - compare str1 to str2;  return YES if equal, NO if not
# integer function equal (str1, str2)
# character str1(ARB), str2(ARB)
# integer i
# 
# for (i=1; str1(i) == str2(i); i=i+1)
#        if (str1(i) == EOS)
#                {
#                equal = YES
#                return
#                }
# equal = NO
# return
# end
#-h- error            136  asc  06-apr-82 15:07:07  j (sventek j)
## Error -- Print message and terminate execution.
subroutine error (line)

character line(ARB)

call remark (line)
call endst(ERR)
end
#-h- exppth           326  asc  06-apr-82 15:07:08  j (sventek j)
## ExpPth -- Pointers in `ptr' to fields of `path'.
subroutine exppth( path, depth, ptr, buf)

character  buf(ARB), path(ARB)
integer    depth, i, ptr(MAXDIRECTS)
integer    gtftok # function(s)

depth = 0
i = 1
repeat
{
  depth = depth + 1
  ptr(depth) = i
}
until( gtftok( path, i, buf) == 0 )
depth = depth - 1

return
end
#-h- fcopy            196  asc  06-apr-82 15:07:09  j (sventek j)
## FCopy -- Copy file `in' to file `out'.
subroutine fcopy( in, out)
character  c
character  getch # function(s)
filedes    in, out

while( getch( c, in) != EOF )
  call putch( c, out)
return
end
#-h- fmtdat          1500  asc  06-apr-82 15:07:10  j (sventek j)
## FmtDat -- Format date and time information.

subroutine fmtdat( date, time, now, form)

character  date(10), time(9), temp(3)
integer    now(7), form
integer    i, j, k
integer    itoc # function(s)

string months "JanFebMarAprMayJunJulAugSepOctNovDec"

# if form == DIGIT, return mm/dd/yy in date
# if form == LETTER, return dd-Mmm-yy in date
# return hh:mm:ss in time

k = 1
if( form == DIGIT )
{
  if( itoc( now(2), temp, 3) == 1 )
    call chcopy( '0', date, k)
  call stcopy( temp, 1, date, k)
  call chcopy( '/', date, k)
  if( itoc( now(3), temp, 3) == 1 )
    call chcopy( '0', date, k)
  call stcopy( temp, 1, date, k)
  call chcopy( '/', date, k)
  if( itoc( mod( now(1), 100), temp, 3) == 1 )
    call chcopy( '0', date, k)
  call stcopy( temp, 1, date, k)
}
else
{
  if( itoc( now(3), temp, 3) == 1 )
    call chcopy( '0', date, k)
  call stcopy( temp, 1, date, k)
  call chcopy( '-', date, k)
  for( j = 3 * ( now(2) - 1 ) + 1 ; k <= 6 ; j = j + 1 )
    call chcopy( months(j), date, k)
  call chcopy( '-', date, k)
  if( itoc( mod( now(1), 100), temp, 3) == 1 )
    call chcopy( '0', date, k)
  call stcopy( temp, 1, date, k)
}

k = 1
if( itoc( now(4), temp, 3) == 1 )
  call chcopy( '0', time, k)
call stcopy( temp, 1, time, k)
call chcopy( ':', time, k)
if( itoc( now(5), temp, 3) == 1 )
  call chcopy( '0', time, k)
call stcopy( temp, 1, time, k)
call chcopy( ':', time, k)
if( itoc( now(6), temp, 3) == 1 )
  call chcopy( '0', time, k)
call stcopy( temp, 1, time, k)

return
end
#-h- fold             203  asc  06-apr-82 15:07:11  j (sventek j)
# ## fold - fold all letters to lower case
# subroutine fold (token)
# character token(ARB), clower
# integer i
# 
# for (i=1; token(i) != EOS; i=i+1)
#        token(i) = clower(token(i))
# return
# end
#-h- fsize            344  asc  06-apr-82 15:07:12  j (sventek j)
## FSize -- Determine size of `file' in characters.
integer    function fsize(file)

character  getch # function(s)
character  c, file(ARB)
integer    open # function(s)
filedes    fd

fd = open( file, READ)
if( fd == ERR )
  fsize = ERR
else
{
  for( fsize = 0 ; getch( c, fd) != EOF ; fsize = fsize + 1 )
     ;
  call close(fd)
}
return
end
#-h- fskip            231  asc  06-apr-82 15:07:13  j (sventek j)
## FSkip -- Skip `n' characters on file `fd'.
subroutine fskip( fd, n)

character  getch # function(s)
character  c
filedes    fd
integer    i, n

for( i = 1 ; i <= n ; i = i + 1 )
  if( getch( c, fd) == EOF )
    break
return
end
#-h- getc             142  asc  06-apr-82 15:07:14  j (sventek j)
# ## getc - get character from STDIN
# character function getc(c)
#
# character c
# character getch
#
# getc = getch(c, STDIN)
# return
# end
#-h- getwrd           367  asc  06-apr-82 15:07:15  j (sventek j)
## GetWrd -- Get non-blank word from `in(i)' into `out'; increment `i'.
integer    function getwrd( in, i, out)
character  in(ARB), out(ARB)
integer    i, j

while( in(i) == ' ' | in(i) == '@t' )
  i = i + 1
j = 1
while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' )
{
  out(j) = in(i)
  i = i + 1
  j = j + 1
}
out(j) = EOS
getwrd = j - 1
return
end
#-h- gitocf           940  asc  06-apr-82 15:07:16  j (sventek j)
    integer function gitocf(int, str, size, base, width, fc)

    integer mod
    integer int, size, base, width
    character str(size), fc
    integer intval, b, i, d, j
    character k

    string digits "0123456789abcdefghijklmnopqrstuvwxyz"
 
    intval = abs(int)
    b = base
    if (b < 2 | b > 36)
        b = 10
    str(1) = EOS
    i = 1
    repeat {            # generate digits
       i = i + 1
       d = mod(intval, b) + 1
       str(i) = digits(d)
       intval = intval / b
       } until (intval == 0 | i >= size)
    if (int < 0 & i < size) {      # then sign
       i = i + 1
       str(i) = '-'
       }
    while (i <= width)
       if (i >= size)
          break
       else
          {
          i = i + 1
          str(i) = fc
          }
    gitocf = i - 1
    for (j = 1; j < i; j = j + 1) {   # then reverse
       k = str(i)
       str(i) = str(j)
       str(j) = k
       i = i - 1
       }
    return
    end
#-h- gtftok           329  asc  06-apr-82 15:07:17  j (sventek j)
# integer function gtftok(buf, i, token)
#
# character buf(ARB), token(ARB)
# integer i, j
#
# if (buf(i) == '/')
#    i = i + 1
# j = 1
# while (buf(i) != '/' & buf(i) != EOS)
#    {
#    token(j) = buf(i)
#    i = i + 1
#    j = j + 1
#    if (buf(i-1) == '\')
#	break
#    }
# token(j) = EOS
# gtftok = j - 1
#
# return
# end
#-h- impath           536  asc  13-jan-83 16:53:58  sventek (joseph sventek)
### impath - generate search path for standard images to be spawned
#subroutine impath(path)
#
#character path(ARB)
#integer i, j, n
#integer length
#
#string spath "~usr/@e~bin/@e@n"	# usr:bin
#
#call tooldr(path, PATH)			# get ~/tools/
#n = length(path) + 2			# move string up one location
#for (j=n, i=n-1; i > 0; i=i-1, j=j-1)
#  path(j) = path(i)
#path(1) = EOS				# search current directory first
#for (i=1, j=n+1; spath(i) != '@n'; i=i+1, j=j+1)
#  path(j) = spath(i)
#call chcopy('@n', path, j)		# terminate path
#
#return
#end
#-h- index            255  asc  06-apr-82 15:07:20  j (sventek j)
# ## index - find character  c  in string  str
#    integer function index(str, c)
#    character c, str(ARB)
# 
#    for (index = 1; str(index) != EOS; index = index + 1)
#       if (str(index) == c)
#          return
#    index = 0
#    return
#    end
#-h- indexs           428  asc  30-jul-83 17:51:31  tools (lblh csam sventek)
## IndexS -- Return index of `sub' in `str'.
integer function indexs( str, sub)

character str(ARB), sub(ARB)
integer   i, j, k

for( i = 1 ; str(i) != EOS ; i = i + 1 )
{
  j = i
  for( k = 1 ; ; k = k + 1 )
  {
    if( sub(k) == EOS )		# found it.
      return(i)
    else if( str(j) == EOS )	# ran out of string.
      return(0)
    else if( str(j) != sub(k) )	# try next posn.
      break
    j = j + 1
  }
}
return(0)

end
#-h- itoc             613  asc  06-apr-82 15:07:22  j (sventek j)
## IToC -- Convert integer `int' to character string in `str'.
integer    function itoc( int, str, size)
integer    mod # function(s)
integer    d, i, int, intval, j, k, size
character  str(size)
string digits "0123456789"

intval = abs(int)
str(1) = EOS
i = 1
repeat					# generate digits
{
  i = i + 1
  d = mod( intval, 10)
  str(i) = digits( d + 1 )
  intval = intval / 10
}
until( intval == 0 | i >= size )
if( int < 0 & i < size )		# then sign
{
  i = i + 1
  str(i) = '-'
}
itoc = i - 1
for( j = 1 ; j < i ; j = j + 1 )	# then reverse
{
  k = str(i)
  str(i) = str(j)
  str(j) = k
  i = i - 1
}
return
end
#-h- length           184  asc  06-apr-82 15:07:23  j (sventek j)
# ## length - compute length of string
# integer function length (str)
# 
# character str(ARB)
# 
# for (length=0; str(length+1) != EOS; length = length + 1)
#        ;
# return
# end
#-h- putc             118  asc  06-apr-82 15:07:23  j (sventek j)
# ## putc - put character onto STDOUT
# subroutine putc (c)
#
# character c
#
# call putch (c, STDOUT)
# return
# end
#-h- putdec           387  asc  06-apr-82 15:07:24  j (sventek j)
# ## putdec - put decimal integer n in field width >= w
#        subroutine putdec(n,w)
#        character chars(MAXCHARS)
#        integer itoc
#        integer i,n,nd,w
# 
#        nd = itoc(n,chars,MAXCHARS)
#        for(i = nd+1; i <= w; i = i+1)
#                call putc(' ')
#        for(i = 1; i <= nd; i = i+1)
#                call putc(chars(i))
#        return
#        end
#-h- putint           264  asc  06-apr-82 15:07:25  j (sventek j)
## PutInt -- Output integer `n' on `fd' in field `w' characters wide.
subroutine putint( n, w, fd)
character  chars(MAXCHARS)
filedes    fd
integer    itoc # function(s)
integer    junk, n, w

junk = itoc( n, chars, MAXCHARS)
call putstr( chars, w, fd)
return
end
#-h- putlnl           277  asc  30-jul-83 17:51:31  tools (lblh csam sventek)
## putlnl - putlin, then flush, if necessary
subroutine putlnl(buf, int)

character buf(ARB)
integer int, i

for (i=1; buf(i) != EOS; i=i+1)
  call putch(buf(i), int)
if (i > 1)
  {
  if (buf(i-1) != '@n')
    call putch('@n', int)
  }
else
  call putch('@n', int)

return
end
#-h- putptr           276  asc  06-apr-82 15:07:27  j (sventek j)
## PutPtr -- Output pointer `ptr' as a character string on `fd'.
subroutine putptr( ptr, fd)

linepointer ptr
filedes    fd
integer    junk
integer    ptrtoc # function(s)
character  temp(LINEPTRSIZE)

junk = ptrtoc( ptr, temp, LINEPTRSIZE)
call putlin( temp, fd)

return
end
#-h- putstr           397  asc  06-apr-82 15:07:28  j (sventek j)
## PutStr -- Output `str' on `fd' in field `w' characters wide.
subroutine putstr( str, w, fd)
character  str(ARB)
filedes    fd
integer    length # function(s)
integer    w

len = length(str)
for( i = len + 1 ; i <= w ; i = i + 1 )
  call putch( ' ', fd)
for( i = 1 ; i <= len ; i = i + 1 )
  call putch( str(i), fd)
for( i = (  -w ) - len ; i > 0 ; i = i - 1 )
  call putch( ' ', fd)
return
end
#-h- query            287  asc  06-apr-82 15:07:29  j (sventek j)
## Query -- Print usage message, if requested.

subroutine query(msg)
character  msg(ARB)

integer    getarg # function(s)

character  arg1(3), arg2(1)

if( getarg( 1, arg1, 3) != EOF & getarg( 2, arg2, 1) == EOF )
  if( arg1(1) == '?' & arg1(2) == EOS )
    call error(msg)

return
end
#-h- scopy            303  asc  06-apr-82 15:07:30  j (sventek j)
# ## scopy - copy string at from(i) to to(j)
#    subroutine scopy(from, i, to, j)
#    character from(ARB), to(ARB)
#    integer i, j, k1, k2
# 
#    k2 = j
#    for (k1 = i; from(k1) != EOS; k1 = k1 + 1) {
#       to(k2) = from(k1)
#       k2 = k2 + 1
#       }
#    to(k2) = EOS
#    return
#    end
#-h- sdrop            355  asc  06-apr-82 15:07:31  j (sventek j)
### SDrop	Drop characters from a string APL-style

integer function sdrop( from, to, chars)

character	from(ARB), to(ARB)
integer		chars

integer		len, start
integer		ctoc, length, min

len = length(from)
if( chars < 0 )
  return( ctoc( from, to, len + chars + 1))
else
{
  start = min( chars, len)
  return( ctoc( from( start + 1), to, len + 1 ))
}

end
#-h- shell            398  asc  06-apr-82 15:07:32  j (sventek j)
## Shell -- Shell sort v(1)...v(n) increasing.
subroutine shell( v, n)
integer    gap, i, j, jg, k, n, v(ARB)

for( gap = n / 2 ; gap > 0 ; gap = gap / 2 )
  for( i = gap + 1 ; i <= n ; i = i + 1 )
    for( j = i - gap ; j > 0 ; j = j - gap )
    {
      jg = j + gap
      if( v(j) <= v(jg) )	# compare
        break
      k = v(j)			# exchange
      v(j) = v(jg)
      v(jg) = k
    }
return
end
#-h- skipbl           171  asc  06-apr-82 15:07:33  j (sventek j)
## SkipBl -- Skip blanks and tabs at `lin(i)'.
subroutine skipbl( lin, i)
character  lin(ARB)
integer    i

while( lin(i) == ' ' | lin(i) == '@t' )
  i = i + 1
return
end
#-h- stake            352  asc  16-dec-82 11:15:37  sventek (joseph sventek)
### STake	take characters from a string APL-style

integer function stake( from, to, chars)

character	from(ARB), to(ARB)
integer		chars

integer		len, start
integer		ctoc, length, max

len = length(from)
if( chars < 0 )
{
  start = max( len + chars, 0)
  return( ctoc( from( start + 1), to, len + 1))
}
else
  return( ctoc( from, to, chars + 1))

end
#-h- stcopy           262  asc  06-apr-82 15:07:35  j (sventek j)
### stcopy - copy string at from(i) to to(j); increment j
# subroutine stcopy(from, i, to, j)
# character from(ARB), to(ARB)
# integer i, j, k
# 
# for (k=i; from(k) != EOS; k=k+1)
#    {
#    to(j) = from(k)
#    j = j + 1
#    }
# to(j) = EOS
#
# return
# end
#-h- strcmp           488  asc  06-apr-82 15:07:36  j (sventek j)
# ## strcmp - compare 2 strings
# 
# integer function strcmp (str1, str2)
# character str1(ARB), str2(ARB)
# integer i
# 
# for (i=1; str1(i) == str2(i); i=i+1)
#        {
#        if (str1(i) == EOS)
#                {
#                strcmp = 0
#                return
#                }
#        }
# if (str1(i) == EOS)
#        strcmp = -1
# else if (str2(i) == EOS)
#        strcmp = + 1
# else if (str1(i) < str2(i))
#        strcmp = -1
# else
#        strcmp = +1
# return
# end
#-h- strcpy           181  asc  06-apr-82 15:07:37  j (sventek j)
# subroutine strcpy(in, out)
#
# character in(ARB), out(ARB)
# integer i
#
# i = 0
# repeat
#    {
#    i = i + 1
#    out(i) = in(i)
#    }
# until (in(i) == EOS)
#
# return
# end
#-h- strim            257  asc  06-apr-82 15:07:38  j (sventek j)
### STrim	trim trailing blanks and tabs from a string

integer function strim(str)

character	str(ARB)

integer		i, lnb

lnb = 0
for( i = 1 ; str(i) != EOS ; i = i + 1 )
  if( str(i) != ' ' & str(i) != '@t' )
    lnb = i

str(lnb + 1) = EOS
return(lnb)
end
#-h- tooldr           393  asc  06-apr-82 15:07:39  j (sventek j)
subroutine tooldr(dir, dtype)

character dir(FILENAMESIZE)
integer dtype

ifdef(TREE_STRUCT_FILE_SYS)
  character temp(FILENAMESIZE)

  string suffix "tools/"
enddef

ifnotdef(TREE_STRUCT_FILE_SYS)
  call homdir(dir, dtype)
elsedef
  call homdir(temp, PATH)
  call concat(temp, suffix, temp)
  if (dtype == PATH)
    call strcpy(temp, dir)
  else
    call mklocl(temp, dir)
enddef

return
end
#-h- type             245  asc  06-apr-82 15:07:40  j (sventek j)
# ## type - determine type of character
# integer function type (c)
# 
# character c
#
# if ((c >= 'a' & c <= 'z') | (c >= 'A' & c <= 'Z'))
#    type = LETTER
# else if (c >= '0' & c <= '9')
#    type = DIGIT
# else
#    type = c
# return
# end
#-h- upper            207  asc  06-apr-82 15:07:40  j (sventek j)
# ## upper - fold all alphas to upper case
# subroutine upper (token)
# 
# character token(ARB), cupper
# integer i
# 
# for (i=1; token(i) != EOS; i=i+1)
#        token(i) = cupper(token(i))
# return
# end
#-h- wkday            340  asc  06-apr-82 15:07:41  j (sventek j)
# WkDay -- Get day-of-week corresponding to `month', `day', and `year'.
integer    function wkday( month, day, year)
integer    month, day, year
integer    lm, ld, ly

lm = month - 2
ld = day
ly = mod( year, 100)

if( lm <= 0 )
{
  lm = lm + 12
  ly = ly - 1
}

wkday = mod( ld + ( 26 * lm - 2 ) / 10 + ly + ly / 4 - 34, 7) + 1

return
end
#-h- dstime           927  asc  06-apr-82 15:07:42  j (sventek j)
# dstime - determine whether date is day-light savings time or not
#
# this routine uses the following algorithm:
#
#	if the month specified is > 4 (April) and < 10 (October), then YES
#	if the month specified is < 4 or > 10, then NO
#	if the month = 4, and the day is < the last Sunday, then NO
#							    else YES
#	if the month = 10, and the day is < the last Sunday, then YES
#							     else NO

integer function dstime(date)

integer date(7), i
integer wkday

if (date(2) > 4 & date(2) < 10)
  return(YES)
else if (date(2) == 4)			# April
  {
  for (i = 30; i > 0; i = i - 1)
    if (wkday(4, i, date(1)) == 1)	# found Sunday
      break
  if (date(3) < i)
    return(NO)
  else
    return(YES)
  }
else if (date(2) == 10)			# October
  {
  for (i = 31; i > 0; i = i - 1)
    if (wkday(10, i, date(1)) == 1)	# found Sunday
      break
  if (date(3) < i)
    return(YES)
  else
    return(NO)
  }
else
  return(NO)

end
#-h- packsub.r       1478  asc  25-mar-82 06:53:22  v1.1 (sw-tools v1.1)
#-h- inpack           182  asc  25-mar-82 06:50:26  v1.1 (sw-tools v1.1)
## InPack -- Initialze data for packing subroutines.
subroutine inpack( nxtcol, rightm, buf, fd)

filedes    fd
integer    nxtcol, rightm
character  buf(ARB)

nxtcol = 1

return
end
#-h- dopack           813  asc  25-mar-82 06:50:27  v1.1 (sw-tools v1.1)
## DoPack -- Pack words at TAB stops and flush lines as required.
subroutine dopack( word, nxtcol, rightm, buf, fd)

filedes    fd
integer    i, j, nxtcol, nxttab, rightm
integer    length # function(s)
character  buf(ARB), word(ARB)

if( nxtcol == 1 )		# must have at least one word/line
  call stcopy( word, 1, buf, nxtcol)
else
{
  i = length(buf) + 1		# next free array element
  nxttab = ( ( ( nxtcol - 1 ) / 16 + 1 ) * 16 ) + 1	# next tab stop
  j = nxttab + length(word) - 1	# last occupied column
  if( j > rightm )
  {
    call flpack( nxtcol, rightm, buf, fd)
    i = 1
    nxttab = nxtcol
    j = length(word)
  }
  if( ( nxttab - nxtcol ) > 8 )
    call chcopy( '@t', buf, i)
  if( ( nxttab - nxtcol ) > 0 )
    call chcopy( '@t', buf, i)
  call scopy( word, 1, buf, i)
  nxtcol = j + 1
}

return
end
#-h- flpack           264  asc  25-mar-82 06:50:29  v1.1 (sw-tools v1.1)
## FlPack -- Flush buffer of packed words.
subroutine flpack( nxtcol, rightm, buf, fd)

filedes    fd
integer    nxtcol, rightm
character  buf(ARB)

if( nxtcol > 1 )	# something to flush
{
  call putlin( buf, fd)
  call putch( '@n', fd)
  nxtcol = 1
}

return
end
#-h- pattern.r      14328  asc  02-aug-83 08:59:58  tools (lblh csam sventek)
#-h- patdef          1084  asc  02-aug-83 08:30:14  tools (lblh csam sventek)
 ## definitions for the pattern matching routines
 # put on a file named 'defns'
 # Used by pattern.r and ed & sedit tools
 
  define(ANY,'?') 
  define(BOL,'%') 
  define(BOT,'{')
  define(CCL,'[') 
  define(CCLEND,']') 
  define(CHAR,'a') 
  define(CLOSIZE,4) 
  define(CLOSURE,'*') 
  define(CLOSURE1,'+')	# closure of one or more occurrences
			# i.e. (pat)+ == (pat)(pat)*
  define(COUNT,1) 
  define(EOL,'$') 
  define(EOT,'}')
  define(MAXTAG,10)
  define(NCCL,'n') 
  define(PREVCL,2) 
  define(START,3) 

  define(DITTO,(-3))
  define(SECTION,(-4))
  define(NUMBER_REGISTER,(-5))	# code for number register

# /ctag/ - common block to hold section limits for ch
# put in a file called 'ctag'
# Used by find, ch, and ed

#common /ctag/ taglim(MAXTAG2)
#integer taglim

define(I_CTAG,common/ctag/taglim(arith(2,*,MAXTAG))
integer taglim)

# /cnoreg/ - common block to hold number register for editor
# put in a file called 'cnoreg'
# used by ch and ed

#common / cnoreg / noreg

#integer noreg		# number register for editor

define(I_CNOREG,common/cnoreg/noreg; integer noreg)
#-h- addint           256  asc  24-jul-83 10:08:18  sventek (joseph sventek)
### AddInt	Put int into intara if it fits, increment j
## works with an array of integers

integer function addint( int, intara, j, maxsiz)

integer		int, j, maxsiz, intara(maxsiz)

if( j > maxsiz )
  return(NO)

intara(j) = int
j = j + 1

return(YES)
end
#-h- amatch          1141  asc  06-apr-82 15:07:59  j (sventek j)
## AMatch -- Look for match starting at `lin(from)'. (non-recursive)
integer    function amatch( lin, from, pat)
character  lin(MAXLINE)
integer    omatch, patsiz # function(s)
integer    from, i, j, offset, pat(MAXPAT), stack

stack = 0
offset = from	# next unexamined input character 
for( j = 1 ; pat(j) != EOS ; j = j + patsiz( pat, j) )
{
  if( pat(j) == CLOSURE )	# a closure entry 
  {
    stack = j
    j = j + CLOSIZE	# step over CLOSURE 
    for( i = offset ; lin(i) != EOS ;  )	# match as many as 
      if( omatch( lin, i, pat, j) == NO )	# possible 
        break
    pat( stack + COUNT ) = i - offset
    pat( stack + START ) = offset
    offset = i	# character that made us fail 
  }
  else if( omatch( lin, offset, pat, j) == NO )	# non-closure 
  {
    for(  ; stack > 0 ; stack = pat( stack + PREVCL ) )
      if( pat( stack + COUNT ) > 0 )
        break
    if( stack <= 0 )	# stack is empty 
      return(0)		# return failure 
    pat( stack + COUNT ) = pat( stack + COUNT ) - 1
    j = stack + CLOSIZE
    offset = pat( stack + START ) + pat( stack + COUNT )
  }
}
# else omatch succeeded 
return(offset)	# success 
end
#-h- catsub          1265  asc  02-aug-83 08:30:14  tools (lblh csam sventek)
## CatSub -- Add replacement text to end of new. 

subroutine catsub( lin, from, to, sub, new, k, maxnew)
integer    addset, ctoi, itoc # function(s)
integer    from, i, j, junk, k, maxnew, to
character  c, lin(MAXLINE), new(maxnew), sub(MAXPAT)

I_CTAG # include tag common block
I_CNOREG # include noreg common block

for( i = 1 ; sub(i) != EOS ; i = i + 1 )
{
  if( sub(i) == DITTO )
    for( j = from ; j < to ; j = j + 1 )
      junk = addset( lin(j), new, k, maxnew)
  else if( sub(i) == SECTION )
  {
    i = i + 1
    n = sub(i)
    if( n <= 0 | n > MAXTAG )
      call error( "? In CatSub: illegal section" )
    for( j = taglim( 2 * n - 1 ) ; j < taglim( 2 * n ) ; j = j + 1 )
      junk = addset( lin(j), new, k, maxnew)
  }
  else if( sub(i) == NUMBER_REGISTER )
  {
    k = k + itoc( noreg, new(k), maxnew - k + 1 )
    i = i + 1
    c = sub(i)
    if( c == '+' | c == '-' )
    {
      i = i + 1
      if( sub(i) != ' ' & sub(i) != '@t' )
      {
        junk = ctoi( sub, i)
        if( junk == 0 )
          junk = 1
      }
      else
        junk = 1
      if( c == '+' )
        noreg = noreg + junk
      else
        noreg = noreg - junk
    }
    i = i - 1 # went one too far
  }
  else
    junk = addset( sub(i), new, k, maxnew)
}
return
end
#-h- dodash           450  asc  06-apr-82 15:08:01  j (sventek j)
## DoDash -- Expand array(i-1)-array(i+1) into set(j)... from valid .
subroutine dodash( valid, array, i, set, j, maxset)
character  esc # function(s)
integer    addset, index # function(s)
integer    i, j, junk, k, limit, maxset
character  array(ARB), set(maxset), valid(ARB)

i = i + 1
j = j - 1
limit = index( valid, esc( array, i) )
for( k = index( valid, set(j) ) ; k <= limit ; k = k + 1 )
  junk = addset( valid(k), set, j, maxset)
return
end
#-h- esc              802  asc  06-apr-82 15:08:02  j (sventek j)
## Esc -- Map `array(i)' into escaped character, if appropriate.
character  function esc( array, i)
character  array(ARB), c
character  clower # function(s)
integer    i, j

if( array(i) != ESCAPE )
  esc = array(i)
else if( array( i + 1 ) == EOS ) # ESCAPE not special at end 
  esc = ESCAPE
else
{
  i = i + 1
  c = clower( array(i) )
  if( c == 'n' )
    esc = '@n'
  else if( c == 't' )
    esc = '@t'
  else if( c == 'r' )
    esc = CR
  else if( c == 'b' )
    esc = BACKSPACE
  else if( c == 'e' )
    esc = EOS
  else if( c == 'f' )
    esc = FF
  else if( c == 'l' )
    esc = LF
  else if( c >= '0' & c <= '7' )
  {
    esc = 0
    for( j=i ; j < i+3 & ( array(j) >= '0' & array(j) <= '7' ) ; j=j+1 )
      esc = 8 * esc + ( array(j) - '0' )
    i = j - 1
  }
  else
    esc = c
}
return
end
#-h- filset          1037  asc  06-apr-82 15:08:04  j (sventek j)
## FilSet -- Expand set at `array(i)' into `set(j)'; stop at `delim'.
subroutine filset( delim, array, i, set, j, maxset)
character  esc # function(s)
integer    addset, index # function(s)
integer    i, j, junk, maxset
character  array(ARB), delim, set(maxset)
string digits "0123456789"
string lowalf "abcdefghijklmnopqrstuvwxyz"
string upalf  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

for(  ; array(i) != delim & array(i) != EOS ; i = i + 1 )
{
  if( array(i) == ESCAPE )
    junk = addset( esc( array, i), set, j, maxset)
  else if( array(i) != '-' )
    junk = addset( array(i), set, j, maxset)
  else if( j <= 1 | array( i + 1 ) == EOS ) # literal - 
    junk = addset( '-', set, j, maxset)
  else if( index( digits, set( j - 1 ) ) > 0 )
    call dodash( digits, array, i, set, j, maxset)
  else if( index( lowalf, set( j - 1 ) ) > 0 )
    call dodash( lowalf, array, i, set, j, maxset)
  else if( index( upalf, set( j - 1 ) ) > 0 )
    call dodash( upalf, array, i, set, j, maxset)
  else
    junk = addset( '-', set, j, maxset)
}
return
end
#-h- getccl           726  asc  22-jul-83 11:46:38  sventek (joseph sventek)
## GetCCl -- Expand character class at `arg(i)' into `pat(j)'.
integer    function getccl( arg, i, pat, j)
character  arg(MAXARG), tpat(MAXPAT)
integer    addint # function(s)
integer    i, j, jstart, junk, k, int, pat(MAXPAT)

i = i + 1	# skip over [ 
if( arg(i) == NOT )
{
  junk = addint( NCCL, pat, j, MAXPAT)
  i = i + 1
}
else
  junk = addint( CCL, pat, j, MAXPAT)
jstart = j
junk = addint( 0, pat, j, MAXPAT)	# leave room for count 
k = 1
call filset( CCLEND, arg, i, tpat, k, MAXPAT)
tpat(k) = EOS
for( k = 1 ; tpat(k) != EOS ; k = k + 1 )
  {
  int = tpat(k)					#cant pass char array
  junk = addint( int, pat, j, MAXPAT)
  }
pat(jstart) = j - jstart - 1

if( arg(i) == CCLEND )
  return(OK)
else
  return(ERR)

end
#-h- getpat           215  asc  06-apr-82 15:08:06  j (sventek j)
## GetPat -- Convert argument `arg' into pattern `pat'.
integer    function getpat( arg, pat)

character	arg(MAXARG)
integer		pat(MAXPAT)
integer		makpat # function(s)

getpat = makpat( arg, 1, EOS, pat)
return
end
#-h- getsub           203  asc  06-apr-82 15:08:07  j (sventek j)
## GetSub -- Get substitution pattern into `sub'.
integer    function getsub( arg, sub)
character  arg(MAXARG), sub(MAXPAT)
integer    maksub # function(s)

getsub = maksub( arg, 1, EOS, sub)
return
end
#-h- locate           319  asc  06-apr-82 15:08:08  j (sventek j)
## Locate -- Look for `c' in character class at `pat(offset)'.
integer    function locate( c, pat, offset)
character  c
integer    i, offset, pat(MAXPAT)

# size of class is at pat(offset), characters follow 

for( i = offset + pat(offset) ; i > offset ; i = i - 1 )
  if( c == pat(i) )
    return(YES)

return(NO)
end
#-h- makpat          2087  asc  24-jul-83 10:08:22  sventek (joseph sventek)
## MakPat -- Make pattern from `arg(from)', terminate at `delim'.
integer    function makpat( arg, from, delim, pat)
character  esc # function(s)
character  arg(MAXARG), delim
integer    addint, getccl, stclos # function(s)
integer    from, i, j, junk, lastcl, lastj, lj, pat(MAXPAT), int
integer    tagcnt, tagi, tagstk(MAXTAG)

j = 1	# pat index 
lastj = 1
lastcl = 0
tagi = 0
tagcnt = 0
for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 )
{
  lj = j
  if( arg(i) == ANY )
    junk = addint( ANY, pat, j, MAXPAT)
  else if( arg(i) == BOL & i == from )
    junk = addint( BOL, pat, j, MAXPAT)
  else if( arg(i) == EOL & arg( i + 1 ) == delim )
    junk = addint( EOL, pat, j, MAXPAT)
  else if( arg(i) == CCL )
  {
    if( getccl( arg, i, pat, j) == ERR )
      break
  }
  else if( ( arg(i) == CLOSURE | arg(i) == CLOSURE1 ) & i > from )
  {
    lj = lastj
    if( pat(lj) == BOL | pat(lj) == EOL | pat(lj) == CLOSURE |
        pat(lj) == CLOSURE1 )
      break	# error
    if( arg(i) == CLOSURE1 )	# duplicate last pattern
      for( lastj = j ; lj < lastj ; lj = lj + 1 )
        junk = addint( pat(lj), pat, j, MAXPAT)
    lastcl = stclos( pat, j, lastj, lastcl)
  }
  else if( arg(i) == BOT )
  {
    if( tagi > MAXTAG | tagcnt > MAXTAG )
    {
      # call remark("? Too many tags")
      break
    }
    tagcnt = tagcnt + 1
    tagi = tagi + 1
    tagstk(tagi) = tagcnt
    junk = addint( BOT, pat, j, MAXPAT)
    junk = addint( tagcnt, pat, j, MAXPAT)
  }
  else if( arg(i) == EOT )
  {
    if( tagi <= 0 )
    {
      # call remark("? Missing tag start symbol")
      break
    }
    n = tagstk(tagi)
    tagi = tagi - 1
    junk = addint( EOT, pat, j, MAXPAT)
    junk = addint( n, pat, j, MAXPAT)
  }
  else
  {
    junk = addint( CHAR, pat, j, MAXPAT)
    int = esc(arg, i)
    junk = addint( int, pat, j, MAXPAT)
  }
  lastj = lj
}

if( arg(i) != delim )	# terminated early 
  return(ERR)
else if( addint( EOS, pat, j, MAXPAT) == NO )	# no room 
  return(ERR)
else if( tagi > 0 )
{
  # call remark("? Missing tag end symbol")
  return(ERR)
}
else
  return(i)
end
#-h- maksub           937  asc  02-aug-83 08:30:16  tools (lblh csam sventek)
## MakSub -- Make substitution string in `sub'.

integer    function maksub( arg, from, delim, sub)
character  esc # function(s)
character  arg(MAXARG), delim, sub(MAXPAT)
integer    addset, ctoi, type # function(s)
integer    from, i, j, junk

j = 1
for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 )
{
  if( arg(i) == AND )
    junk = addset( DITTO, sub, j, MAXPAT)
  else if( arg(i) == '$' & type( arg( i + 1 ) ) == DIGIT )
  {
    i = i + 1
    n = ctoi( arg, i)
    junk = addset( SECTION, sub, j, MAXPAT)
    junk = addset( n, sub, j, MAXPAT)
    i = i - 1
  }
  else if( arg(i) == '$' & ( arg(i+1) == 'n' | arg(i+1) == 'N' ) )
  {
    i = i + 1
    junk = addset( NUMBER_REGISTER, sub, j, MAXPAT)
  }
  else
    junk = addset( esc( arg, i), sub, j, MAXPAT)
}

if( arg(i) != delim ) # missing delimiter 
  maksub = ERR
else if( addset( EOS, sub, j, MAXPAT) == NO ) # no room 
  maksub = ERR
else
  maksub = i
return
end
#-h- match            268  asc  06-apr-82 15:08:12  j (sventek j)
## Match -- Find match anywhere on line .
integer    function match( lin, pat)
character  lin(MAXLINE)
integer    amatch # function(s)
integer    i, pat(MAXPAT)

for( i = 1 ; lin(i) != EOS ; i = i + 1 )
  if( amatch( lin, i, pat) > 0 )
    return(YES)

return(NO)
end
#-h- omatch          1001  asc  16-jun-83 11:30:48  sventek (joseph sventek)
## OMaTch -- try to match a single pattern at `pat(j)'. 
integer    function omatch( lin, i, pat, j)
character  lin(MAXLINE)
integer    locate # function(s)
integer    bump, i, j, pat(MAXPAT)

I_CTAG # include ctag common block

omatch = NO
if( lin(i) == EOS )
  return
bump =  -1
if( pat(j) == CHAR )
{
  if( lin(i) == pat( j + 1 ) )
    bump = 1
}
else if( pat(j) == BOL )
{
  if( i == 1 )
    bump = 0
}
else if( pat(j) == ANY )
{
  if( lin(i) != '@n' )
    bump = 1
}
else if( pat(j) == EOL )
{
  if( lin(i) == '@n' )
    bump = 0
}
else if( pat(j) == CCL )
{
  if( locate( lin(i), pat, j + 1 ) == YES )
    bump = 1
}
else if( pat(j) == NCCL )
{
  if( lin(i) != '@n' & locate( lin(i), pat, j + 1 ) == NO )
    bump = 1
}
else if( pat(j) == BOT )
{
  n = pat( j + 1 )
  taglim( 2 * n - 1 ) = i
  bump = 0
}
else if( pat(j) == EOT )
{
  n = pat( j + 1 )
  taglim( 2 * n ) = i
  bump = 0
}
else
  call error( "? In omatch: cant happen" )
if( bump >= 0 )
{
  i = i + bump
  omatch = YES
}
return
end
#-h- patsiz           443  asc  16-jun-83 11:30:49  sventek (joseph sventek)
## PatSiz -- Return size of pattern entry at `pat(n)'. 
integer    function patsiz( pat, n)

integer		n, pat(MAXPAT)

if( pat(n) == CHAR | pat(n) == BOT | pat(n) == EOT )
  patsiz = 2
else if( pat(n) == BOL | pat(n) == EOL | pat(n) == ANY )
  patsiz = 1
else if( pat(n) == CCL | pat(n) == NCCL )
  patsiz = pat( n + 1 ) + 2
else if( pat(n) == CLOSURE ) # optional 
  patsiz = CLOSIZE
else
  call error( "? In patsiz: cant happen" )
return
end
#-h- stclos           571  asc  06-apr-82 15:08:15  j (sventek j)
## StClos -- Insert closure entry at `pat(j)'. 
integer    function stclos( pat, j, lastj, lastcl)
integer    addint # function(s)
integer    j, jp, jt, junk, lastcl, lastj, pat(MAXPAT)

for( jp = j - 1 ; jp >= lastj ; jp = jp - 1 )	# make a hole 
{
  jt = jp + CLOSIZE
  junk = addint( pat(jp), pat, jt, MAXPAT)
}
j = j + CLOSIZE
stclos = lastj
junk = addint( CLOSURE, pat, lastj, MAXPAT)	# put closure in it 
junk = addint( 0, pat, lastj, MAXPAT)		# COUNT 
junk = addint( lastcl, pat, lastj, MAXPAT)	# PREVCL 
junk = addint( 0, pat, lastj, MAXPAT)		# START 
return
end
#-h- gnoreg            77  asc  02-aug-83 08:30:17  tools (lblh csam sventek)
subroutine gnoreg(value)

integer value

I_CNOREG

value = noreg

return
end
#-h- snoreg            77  asc  02-aug-83 08:30:17  tools (lblh csam sventek)
subroutine snoreg(value)

integer value

I_CNOREG

noreg = value

return
end
#-h- pb.r            1273  asc  16-jun-83 11:33:40  sventek (joseph sventek)
#-h- ngetch           317  asc  25-mar-82 06:51:12  v1.1 (sw-tools v1.1)
# ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd

   PB_DECL(1)
 
   if (pbp > 0) {
      c = pbbuf(pbp)
      pbp = pbp - 1
      }
   else if (fd == ERR)
      c = EOF
   else
      c = getch(c, fd)
   ngetch = c
   return
   end
#-h- pbinit            85  asc  25-mar-82 06:51:13  v1.1 (sw-tools v1.1)
subroutine pbinit(size)

integer size

PB_DECL(1)

pbp = 0
pbsize = size

return
end
#-h- putbak           232  asc  16-jun-83 11:31:48  sventek (joseph sventek)
# putbak - push character back onto input
   subroutine putbak(c)
   character c

   PB_DECL(1)
 
   pbp = pbp + 1
   if (pbp > pbsize)
      call error("putbak - too many characters pushed back")
   pbbuf(pbp) = c
   return
   end
#-h- pbstr            339  asc  16-jun-83 11:31:49  sventek (joseph sventek)
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(ARB)
   integer length
   integer i

   PB_DECL(1)
 
   for (i = length(in); i > 0; i = i - 1)
      {
      pbp = pbp + 1
      if (pbp > pbsize)
         call error("pbstr - too many characters pushed back")
      pbbuf(pbp) = in(i)
      }

   return
   end
#-h- rawpmt.r       10316  asc  25-mar-82 06:53:32  v1.1 (sw-tools v1.1)
#-h- defns            660  asc  25-mar-82 06:51:23  v1.1 (sw-tools v1.1)
 define(BELL,7)			# ^G
 define(CARRIAGERETURN,13)	# CR
 define(ENDOFFILE,26)		# ^Z
 define(ESC,27)			# ASCII ESC
 define(RETYPELINE,18)		# ^R
 define(VERIFYLINE,22)		# ^V
 define(LINEDELETE,21)		# ^U
 define(RUBOUT,127)		# DEL | RUB
 define(WORDDELETE,23)		# ^W
 define(DIRECTORYLIST,4)	# ^D
 define(RECOGNIZEFILE,6)	# ^F
 define(EXPAND,YES)
 define(NO_EXPAND,NO)
#
# the following definitions are to prevent overloading the global name space
#
define(ds,praw01)
define(insstr,praw02)
define(lngest,praw03)
define(rawio,praw04)
define(recogf,praw05)
define(redisp,praw06)
define(rwpmpt,praw07)
define(scnbck,praw08)
define(spawnd,praw09)
define(spnbck,praw10)
#-h- rawpmt           433  asc  25-mar-82 06:51:24  v1.1 (sw-tools v1.1)
integer function rawpmt(pstr, lin, in)

character pstr(ARB), lin(MAXLINE), tmp(MAXLINE)
integer in, n
integer rwpmpt

string altpst " _"

altpst(1) = pstr(1)
n = rwpmpt(pstr, lin, in)
if (n == EOF | n == 1)
  return(n)
while (lin(n) == '@n' & lin(n-1) == ESCAPE)
  {
  lin(n-1) = ' '		# @'@n' => ' '
  if (rwpmpt(altpst, tmp, in) == EOF)
    return(EOF)
  call stcopy(tmp, 1, lin, n)
  n = n - 1			# point at '@n'
  }
return(n)

end
#-h- ds               976  asc  25-mar-82 06:51:26  v1.1 (sw-tools v1.1)
## ds - perform directory search for longest string matching `inpstr'.

integer function ds(inpstr, outstr)

integer found, len, depth, ptr(MAXDIRECTS), j, junk, desc
integer length, gtftok, opendr, gdrprm, equal, lngest
character inpstr(ARB), outstr(ARB), path(FILENAMESIZE), pat(FILENAMESIZE), c

string star "*"

found = 0
len = length(inpstr)
if (len == 0 | inpstr(len) == '/')
  call concat(inpstr, star, pat)
else
  call strcpy(inpstr, pat)
call mkpath(pat, path)
call fold(path)
call exppth(path, depth, ptr, pat)
j = ptr(depth)
pat(1) = EOS
junk = gtftok(path, j, pat)
j = ptr(depth)
path(j) = EOS
if (opendr(path, desc) == ERR)
  return(found)
len = length(pat) + 1
while (gdrprm(desc, path) != EOF)
  {
  c = path(len)
  path(len) = EOS
  if (equal(path, pat) == NO & pat(1) != '*')
    next
  path(len) = c
  if (found == 0)
    call strcpy(path, outstr)
  found = found + 1
  j = lngest(path, outstr) + 1
  outstr(j) = EOS
  }
call closdr(desc)

return(found)
end
#-h- insstr           326  asc  25-mar-82 06:51:28  v1.1 (sw-tools v1.1)
## insstr - insert string `s1' at position `i' of string `s2'.

subroutine insstr(s1, s2, i)

character s1(ARB), s2(ARB)
integer i, j, k, l
integer length

k = length(s2) + 1
for (j=k+length(s1); k >= i; k=k-1)
  {
  s2(j) = s2(k)
  j = j - 1
  }
l = 1
for (k=i; k <= j; k=k+1)
  {
  s2(k) = s1(l)
  l = l + 1
  }

return
end
#-h- lngest           240  asc  25-mar-82 06:51:29  v1.1 (sw-tools v1.1)
## lngest - return length of the longest substring common to two strings

integer function lngest(s1, s2)

integer i
character s1(ARB), s2(ARB)

for (i=1; s1(i) == s2(i); i=i+1)
  if (s1(i) == EOS | s2(i) == EOS)
    break
return(i-1)

end
#-h- rawio            585  asc  25-mar-82 06:51:33  v1.1 (sw-tools v1.1)
## rawio - determine if rawpmt can be used on unit

integer function rawio(in, out, savmod)

integer in, out, savmod
integer create, stmode, isatty, gtmode

string ttystr TTY_NAME

if (out == EOF)			# need to open echo unit
  {
  out = create(ttystr, WRITE)
  if (out != ERR)
    if (stmode(out, RARE) != RARE)
      {
      call close(out)
      out = ERR
      }
  }
rawio = NO
if (isatty(in) == YES & out != ERR)
  {
  savmod = gtmode(in)		# save current mode
  if (stmode(in, RARE) == RARE)	# can do rare mode
    rawio = YES
  else
    savmod = stmode(in, savmod)
  }

return
end
#-h- recogf           426  asc  25-mar-82 06:51:34  v1.1 (sw-tools v1.1)
## recogf - recognize longest unique filename substring matching %`str'.
##	complete the string in `str'.

integer function recogf(str)

integer i
integer ds, length
character str(ARB), outstr(FILENAMESIZE)

i = length(str)
if (i > 0)
  repeat
    {
    if (str(i) == '/' | str(i) == '\')
      break
    i = i - 1
    }
  until (i == 0)
recogf = ds(str, outstr)
if (recogf != 0)
  call scopy(outstr, 1, str, i+1)

return
end
#-h- redisp           761  asc  25-mar-82 06:51:37  v1.1 (sw-tools v1.1)
## redisp - redisplay prompt and line on int, expanding control characters
##	as required

subroutine redisp(pstr, lin, int, temp, ifexpd)

character pstr(ARB), lin(ARB), temp(ARB)
integer int, ifexpd, i, j

string crlf "@r@l"

i = 1
while (pstr(i) != EOS)
  {
  for (j=1; pstr(i) != '@n' & pstr(i) != EOS; j=j+1)
    {
    temp(j) = pstr(i)
    i = i + 1
    }
  if (pstr(i) == '@n')
    {
    call scopy(crlf, 1, temp, j)
    i = i + 1
    }
  else
    temp(j) = EOS
  call putlin(temp, int)
  }
j = 1
for (i=1; lin(i) != EOS; i=i+1)
  {
  if (lin(i) < ' ')
    {
    call chcopy('^', temp, j)
    if (ifexpd == EXPAND)
      call chcopy(lin(i)+'@@', temp, j)
    }
  else
    call chcopy(lin(i), temp, j)
  }
temp(j) = EOS
call putlin(temp, int)

return
end
#-h- rwpmpt          3331  asc  25-mar-82 06:51:39  v1.1 (sw-tools v1.1)
integer function rwpmpt(pstr, lin, in)

character pstr(ARB), lin(MAXLINE), c, tmp(MAXLINE)
character getch
integer in, i, j, k, l, out, savmod
integer prompt, scnbck, spnbck, length, recogf, index, rawio, stmode

string bol "%"
string dstr "fd "
string bsblbs "@b @b"
string crlf "@r@l"
string ctrld "^Directory list@r"
string ctrlr "^Retype line@r@l"
string ctrlu "^Undo line@r@l"
string ctrlv "^Verify line@r@l"
string ctrlz "^Z@r"
string fldtrm " @t/\@@<>"	# terminator string for field of pathname
string filtrm " <>@@"		# terminator string for filenames
string pthtrm " /\"		# terminator string for pathnames
string valctl "@f@t"		# valid control characters

data out /EOF/

if (rawio(in, out, savmod) == NO)
  return(prompt(pstr, lin, in))
i = 1
call putlin(crlf, out)
call redisp(pstr, EOS, out, tmp, NO_EXPAND)
lin(1) = EOS
repeat
  {
  c = getch(c, in)
  if (c == ENDOFFILE)
    {
    call putlin(ctrlz, out)
    lin(1) = EOS
    return(EOF)
    }
  else if (c == CARRIAGERETURN)
    break
  else if (c == BACKSPACE | c == RUBOUT)
    {
    if (i > 1)
      {
      call putlin(bsblbs, out)
      i = i - 1
      lin(i) = EOS
      }
    else
      lin(i) = EOS
    }
  else if (c == LINEDELETE)
    {
    call putlin(ctrlu, out)
    call redisp(pstr, EOS, out, tmp, NO_EXPAND)
    i = 1
    lin(i) = EOS
    }
  else if (c == RETYPELINE)
    {
    call putlin(ctrlr, out)
    call redisp(pstr, lin, out, tmp, NO_EXPAND)
    }
  else if (c == VERIFYLINE)
    {
    call putlin(ctrlv, out)
    call redisp(pstr, lin, out, tmp, EXPAND)
    call putlin(crlf, out)
    call redisp(pstr, lin, out, tmp, NO_EXPAND)
    }
  else if (c == WORDDELETE)
    {
    i = spnbck(lin, i, bsblbs, out, fldtrm)
    i = scnbck(lin, i, bsblbs, out, fldtrm)
    lin(i) = EOS
    }
  else if (c == DIRECTORYLIST)
    {
    call putlin(ctrld, out)
    call spawnd(dstr)
    call putlin(crlf, out)
    call redisp(pstr, lin, out, tmp, NO_EXPAND)
    }
  else if (c == RECOGNIZEFILE)
    {
    lin(i) = EOS
    j = scnbck(lin, i, EOS, out, filtrm)
    call scopy(lin, j, tmp, 1)
    k = length(tmp) + 1
    l = recogf(tmp)
    if (l != 0)
      {
      if (tmp(k) != EOS | l == 1)                # Progress was made
        {
        if (tmp(k) != EOS)
          call scopy(tmp, k, lin, i)
        else
          {
          lin(i) = ' '
          lin(i+1) = EOS
          }
        call putlin(lin(i), out)
        i = length(lin) + 1
        }
      else
        {
        k = 1
        call stcopy(dstr, 1, tmp, k)
        call scopy(lin, j, tmp, k)
        j = scnbck(tmp(k), length(tmp(k))+1, EOS, out, pthtrm) + k - 1
        call insstr(bol, tmp, j)
        call putlin(crlf, out)
        call putch('#', out)
        call putlin(tmp, out)
        call putch(CARRIAGERETURN, out)
        call spawnd(tmp)
        call putlin(crlf, out)
        call redisp(pstr, lin, out, tmp, NO_EXPAND)
        }
      }
    else
      call putch(BELL, out)
    }
  else if (c < ' ' & index(valctl, c) == 0)
    call putch(BELL, out)
  else
    {
    lin(i) = c
    i = i + 1
    lin(i) = EOS
    if (index(valctl, c) == 0)
      call putch(c, out)
    else
      call putch('^', out)	# all characters occupy one column
    }
  }
call putch(CARRIAGERETURN, out)
lin(i) = '@n'
lin(i+1) = EOS
savmod = stmode(in, savmod)	# reset mode on unit

return(i)
end
#-h- scnbck           684  asc  25-mar-82 06:51:42  v1.1 (sw-tools v1.1)
## scnbck - scan backwards until a terminator or boundary is reached.
##	return the index of the last character scanned before terminator.
##	output string `rubstr' on `chn' as each character is scanned.

 integer function scnbck(str, col, rubstr, chn, trmara)

 integer i, chn, col
 integer index
 character rubstr(ARB), str(ARB), trmara(ARB)

 if (col > 1)
    {
    i = col - 1			# point to last char entered.
    for ( ; index(trmara, str(i)) == 0 & i > 1; i=i-1)
	if (rubstr(1) != EOS)
	    call putlin(rubstr, chn)
    if (i == 1 & index(trmara, str(i)) == 0)
	{
	if (rubstr(1) != EOS)
	    call putlin(rubstr, chn)
	}
    else
	i = i + 1
    }
 else
    i = 1

 return(i)
 end
#-h- spawnd           362  asc  25-mar-82 06:51:43  v1.1 (sw-tools v1.1)
 subroutine spawnd(args)

 character args(ARB), image(FILENAMESIZE), pid(PIDSIZE)
 integer loccom, spawn
 integer junk, init

 string d "fd"
 string spath "@e~usr/@e~bin/@e@n"
 string suffix IMAGE_SUFFIX

 data init /YES/

 if (init == YES)
    {
    init = NO
    junk = loccom(d, spath, suffix, image)
    }
 junk = spawn(image, args, pid, WAIT)

 return
 end
#-h- spnbck           656  asc  25-mar-82 06:51:45  v1.1 (sw-tools v1.1)
## spnbck - span backwards until a non-separator or boundary is reached.
##	return the index of the last character scanned before separator,
##	output string `rubstr' on `chn' as each character is scanned.

 integer function spnbck(str, col, rubstr, chn, separa)

 integer i, chn, col
 integer index
 character rubstr(ARB), str(ARB), separa(ARB)

 if (col > 1)
    {
    i = col - 1			# point to last char entered.
    for ( ; index(separa, str(i)) > 0 & i > 1; i=i-1)
	if (rubstr(1) != EOS)
	    call putlin(rubstr, chn)
    if (i == 1)
	{
	if (rubstr(1) != EOS)
	    call putlin(rubstr, chn)
	}
    else
	i = i + 1
    }
 else
    i = 1

 return(i)
 end
#-h- tabsubs.r       2220  asc  25-mar-82 06:53:36  v1.1 (sw-tools v1.1)
#-h- argtab           401  asc  25-mar-82 06:51:54  v1.1 (sw-tools v1.1)
## ArgTab -- Fetch tab information from argument list.
subroutine argtab(buf)

character  buf(MAXLINE), n(4)
integer    i, j, k
integer    getarg, alldig # function(s)

i = 1
for( j = 1 ; getarg( j, n, 4) != EOF ; j = j + 1 )
{
  k = 1
  if( n(1) == '+' )
    k = k + 1
  if( alldig( n(k) ) == YES )
  {
    if( i > 1 )
      call chcopy( ' ', buf, i)
    call stcopy( n, 1, buf, i)
  }
}

return
end
#-h- gtword           623  asc  25-mar-82 06:51:56  v1.1 (sw-tools v1.1)
## GtWord -- Get next word from `in(i)' into `out'; incr `i' to `size' chars.
integer    function gtword( in, i, out, size)

character  in(ARB), out(ARB)
integer    i, size, j, overfl

while( in(i) == ' ' | in(i) == '@t' )
  i = i + 1
overfl = YES # assume word too big
for( j = 1 ; j <= size ; j = j + 1 )
{
  if( in(i) == EOS | in(i) == ' ' | in(i) == '@t' | in(i) == '@n' )
  {
    overfl = NO
    break
  }
  else
  {
    out(j) = in(i)
    i = i + 1
  }
}
out(j) = EOS
if( overfl == YES ) # skip extra characters
  while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' )
    i = i + 1
return( j - 1 )
end
#-h- settab           711  asc  25-mar-82 06:51:58  v1.1 (sw-tools v1.1)
## SetTab -- Set initial tab stops.
subroutine settab( buf, tabs)
integer    i, j, k, l, m, p, ptr, tabs(MAXLINE)
integer    alldig, ctoi, gtword # function(s)
character  n(4), buf(MAXLINE)

p = 0
for( i = 1 ; i <= MAXLINE ; i = i + 1 )
  tabs(i) = NO
ptr = 1
for( j = 1 ; gtword( buf, ptr, n, 4) > 0 ; j = j + 1 )
{
  k = 1
  if( n(1) == '+' )
    k = k + 1
  if( alldig( n(k) ) == NO )
    next
  l = ctoi( n, k)
  if( l <= 0 | l > MAXLINE )
    next
  if( n(1) != '+' )
  {
    p = l
    tabs(p) = YES
  }
  else
  {
    if( p == 0 )
      p = l + 1
    for( m = p ; m <= MAXLINE ; m = m + l )
      tabs(m) = YES
  }
}
if( p == 0 )
{
  for( i = 9 ; i <= MAXLINE ; i = i + 8 )
    tabs(i) = YES
}
return
end
#-h- tabpos           193  asc  25-mar-82 06:51:59  v1.1 (sw-tools v1.1)
## TabPos -- Return YES if `col' is a tab stop.
integer    function tabpos( col, tabs)
integer    col, i, tabs(MAXLINE)

if( col > MAXLINE )
  tabpos = YES
else
  tabpos = tabs(col)
return
end
#-h- tb.r            1571  asc  16-jun-83 11:33:46  sventek (joseph sventek)
#-h- tbsym             51  asc  25-mar-82 06:52:05  v1.1 (sw-tools v1.1)
define(INCLUDE_CTB,common/ctb/table
pointer table)
#-h- tbinit           231  asc  25-mar-82 06:52:07  v1.1 (sw-tools v1.1)
## TbInit -- Initialize simple lookup table.
subroutine tbinit(size)

integer size

INCLUDE_CTB

pointer mktabl

call dsinit(size)	# initialize dynamic storage
table = mktabl(1)	# create symbol table in dynamic storage

return
end
#-h- tbinst           544  asc  16-jun-83 11:32:25  sventek (joseph sventek)
## TbInst -- Enter a new symbol definition, discarding any old one.

subroutine tbinst( name, defn)
character  name(ARB), defn(ARB)

INCLUDE_CTB

integer    lookup, enter # function(s)

pointer text
pointer sdupl

if( lookup( name, text, table) == YES )
  call dsfree(text)	# this is how to do UNDEFINE, by the way
text = sdupl(defn)	# store definition away
if( text != LAMBDA )	# succeeded
{
  if( enter( name, text, table) == OK )
    return
  else
    call dsfree(text)
}
call remark( "? In tbinst: no room for new definition" )

return
end
#-h- tblook           449  asc  25-mar-82 06:52:10  v1.1 (sw-tools v1.1)
## TbLook -- Look up a defined identifier, return its definition.

integer    function tblook( id, defn)
character  id(ARB), defn(ARB)

INCLUDE_CTB

DS_DECL( Mem, 1)

integer    i, j
integer    lookup # function(s)

pointer locn

tblook = lookup( id, locn, table)
if( tblook == YES )
{
  i = 1
  for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 )
  {
    defn(i) = cMem(j)
    i = i + 1
  }
  defn(i) = EOS
}
else
  defn(1) = EOS

return
end
#-h- lib.m           9977  asc  30-jul-83 18:04:15  tools (lblh csam sventek)
#-h- chcopy.mar       442  asc  28-jul-83 00:15:18  tools (lblh csam sventek)
	.title	chcopy
;
;	this routine implements the following interface
;
;	call chcopy(c, out, j)
;
;	after the copy, j is incremented and out is EOS-terminated
;
c=4
out=8
j=12
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	chcopy	^m<>
	addl3	out(ap),@j(ap),r0		; address of out(j)
	decl	r0				;
	movb	@c(ap),(r0)+			; copy character
	clrb	(r0)				; write EOS into out(j+1)
	incl	@j(ap)				; increment j
	ret
	.end
#-h- clower.mar       365  asc  28-jul-83 00:15:18  tools (lblh csam sventek)
	.title	clower
;+
;	character function clower(x)
;-
x=4
biga=65
bigz=90
leta=97
letz=122
dif=leta-biga
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	clower	^m<>
	movzbl	@x(ap),r0		; fetch character
	cmpb	r0,#biga		; >= A?
	blss	10$			; NO
	cmpb	r0,#bigz		; <= Z?
	bgtr	10$			; NO
	addl2	#dif,r0			; make it lower case
10$:
	ret
	.end
#-h- concat.mar       589  asc  28-jul-83 00:15:18  tools (lblh csam sventek)
	.title	concat
;
;	this routine implements the following interface
;
;	call concat(a, b, c)
;
;	a and b are EOS-terminated strings.  a and b will be concatenated
;	into c.  a and c may be the same variable.
;
a=4
b=8
c=12
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	concat	^m<>
	movl	a(ap),r0		; source address
	movl	c(ap),r1		; destination address
10$:
	movb	(r0)+,(r1)+		; copy character
	bneq	10$			; until EOS
	tstb	-(r1)			; went one too far
	movl	b(ap),r0		; source address
20$:
	movb	(r0)+,(r1)+		; copy character
	bneq	20$			; until EOS
	ret
	.end
#-h- cupper.mar       365  asc  28-jul-83 00:15:19  tools (lblh csam sventek)
	.title	cupper
;+
;	character function cupper(x)
;-
x=4
biga=65
bigz=90
leta=97
letz=122
dif=leta-biga
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	cupper	^m<>
	movzbl	@x(ap),r0		; fetch character
	cmpb	r0,#leta		; >= a?
	blss	10$			; NO
	cmpb	r0,#letz		; <= z?
	bgtr	10$			; NO
	subl2	#dif,r0			; make it upper case
10$:
	ret
	.end
#-h- equal.mar        576  asc  28-jul-83 00:44:00  tools (lblh csam sventek)
	.title	equal
;
;	this routine implements the following interface
;
;	status = equal(a, b)
;
;	a and b are EOS-terminated strings
;	if equal, return(YES[1]) else return(NO[0])
;
a=4
b=8
yes=1
no=0
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	equal	^m<r2>
	movl	a(ap),r1		; address of a(1)
	movl	b(ap),r2		; address of b(1)
	movl	#no,r0			; assume not equal
10$:
	cmpb	(r1)+,(r2)		; compare next character
	bneq	20$			; not equal, return
	tstb	(r2)+			; is this EOS (0)?
	bneq	10$			; no, try again
	movl	#yes,r0			; return(YES)
20$:
	ret
	.end
#-h- fold.mar         625  asc  28-jul-83 00:15:20  tools (lblh csam sventek)
	.title	fold
;+
;	subroutine fold(buf)
;
;	character buf(ARB)
;
;	any characters found in the range A-Z are folded to the corresponding
;	lower case character
;-
buf=4
biga=65
bigz=90
leta=97
letz=122
dif=leta-biga
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	fold	^m<>
	movl	buf(ap),r1		; address of buf(1)
10$:
	movzbl	(r1),r0			; fetch next character
	beql	20$			; if == 0, done
	cmpb	r0,#biga		; >= A?
	blss	30$			; NO
	cmpb	r0,#bigz		; <= Z?
	bgtr	30$			; NO
	addl2	#dif,r0			; make lower case
30$:
	movb	r0,(r1)+		; copy character back into string
	brb	10$			; try again
20$:
	ret
	.end
#-h- gtftok.mar       813  asc  28-jul-83 00:15:20  tools (lblh csam sventek)
	.title	gtftok
;+
;	integer function gtftok(buf, i, token)
;-
buf=4
i=8
token=12
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	gtftok	^m<r2,r3>
	movl	buf(ap),r1		; address of buf(1)
	movl	i(ap),r3		; address of i
	decl	(r3)			; i = i - 1
	addl2	(r3),r1			; address of buf(i)
	movl	token(ap),r2		; address of token(1)
	clrl	r0			; initialize return count
	incl	(r3)			; i = i + 1
	cmpb	(r1),#^a"/"		; buf(i) == SLASH?
	bneq	10$			; NO
	incl	(r3)			; i = i + 1
	incl	r1			; address of buf(i)
10$:
	movb	(r1)+,(r2)		; copy character
	beql	30$			; if == 0, done
	cmpb	(r2),#^a"/"		; SLASH?
	beql	20$			; YES
	incl	r0			; increment count
	incl	(r3)			; i = i + 1
	cmpb	(r2)+,#^a"\"		; BACKSLASH?
	bneq	10$			; NO, do next character
20$:
	clrb	(r2)			; terminate with EOS
30$:
	ret
	.end
#-h- impath.mar       802  asc  28-jul-83 00:15:21  tools (lblh csam sventek)
	.title	impath
;+
;	subroutine impath(buf)
;-
	.psect	st_impath_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
spath:
	.asciz	"~usr/"
	.asciz	"~bin/"
	.byte	10,0
spathl=.-spath
buf=4
path=5				; same as PATH in ~bin/symbols
dtype:	.long	path		; desire tooldr in pathname format
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	impath	^m<r2>
	movl	buf(ap),r2		; destination address
	clrb	(r2)+			; EOS => search cwd first
	pushal	dtype			; desire pathname format
	pushl	r2			; buffer for tooldr
	calls	#2,tooldr		; fetch tools directory info
20$:
	tstb	(r2)+			; at end of tools directory yet?
	bneq	20$			; NO
	moval	spath,r1		; source array address
	movl	#spathl,r0		; length of array
10$:
	movb	(r1)+,(r2)+		; copy character
	sobgtr	r0,10$			; do again
	ret
	.end
#-h- index.mar        676  asc  28-jul-83 00:15:21  tools (lblh csam sventek)
	.title	indexx
;
;	this routine provides the following interface
;
;	i = indexx(buf, char)
;
;	where buf is an EOS-terminated string
;	if found, return(i) such that buf(i) == char
;	else return(0)
;
buf=4
char=8
eos=0
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	indexx	^m<r2>
	movl	buf(ap),r1		; address of buf(1)
	movzbl	@char(ap),r2		; character to find
	clrl	r0			; initialize character position
10$:
	incl	r0			; increment to current character pos
	tstb	(r1)			; see if at EOS
	beql	20$			; YES
	cmpb	(r1)+,r2		; is this the character?
	beql	30$			; YES, return
	brb	10$			; try again
20$:
	clrl	r0			; character not found
30$:
	ret
	.end
#-h- length.mar       435  asc  28-jul-83 00:15:22  tools (lblh csam sventek)
	.title	length
;
;	function to return the length of an EOS-terminated string
;
;	n = length(str)
;
;	where str is the address of the string
;
eos=0
str=4
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	length	^m<>
	movl	str(ap),r1		; address of string
	clrl	r0			; initialize length
10$:
	incl	r0			; increment length
	tstb	(r1)+			; see if at EOS
	bneq	10$			; NO
	decl	r0			; went one too far
	ret
	.end
#-h- scopy.mar        433  asc  28-jul-83 00:15:22  tools (lblh csam sventek)
	.title	scopy
;
;	this routine implements the following interface
;
;	call scopy(in, i, out, j)
;
;	where in is an EOS-terminated string
;
in=4
i=8
out=12
j=16
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	scopy	^m<>
	addl3	in(ap),@i(ap),r0
	decl	r0			; address of in(i)
	addl3	out(ap),@j(ap),r1
	decl	r1			; address of out(j)
10$:
	movb	(r0)+,(r1)+		; copy character
	bneq	10$			; go again
	ret
	.end
#-h- stcopy.mar       559  asc  28-jul-83 00:15:22  tools (lblh csam sventek)
	.title	stcopy
;
;	this routine provides the following interface
;
;	call stcopy(in, i, out, j)
;
;	in is an EOS-terminated string, j is incremented
;	out is EOS-terminated
;
in=4
i=8
out=12
j=16
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	stcopy	^m<r2>
	addl3	in(ap),@i(ap),r0
	decl	r0			; address of in(i)
	movl	j(ap),r2		; address of j
	decl	(r2)			; back j up one
	addl3	out(ap),(r2),r1		; address of out(j)
10$:
	incl	(r2)			; increment j
	movb	(r0)+,(r1)+		; copy character
	bneq	10$			; if != 0, do next one
	ret
	.end
#-h- strcmp.mar       565  asc  28-jul-83 00:15:23  tools (lblh csam sventek)
	.title	strcmp
;+
;	integer function strcmp(str1, str2)
;-
str1=4
str2=8
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	strcmp	^m<r2>
	movl	str1(ap),r1		; start of str1
	movl	str2(ap),r2		; start of str2
	clrl	r0			; assume equal
10$:
	cmpb	(r1),(r2)		; characters equal?
	bneq	20$			; NO
	tstb	(r1)+			; at EOS?
	beql	100$			; YES
	incl	r2			; bump address to next character
	brb	10$
20$:
	movl	#-1,r0			; assume str1 < str2
	cmpb	(r1),(r2)		; compare characters
	blss	100$			; str1 < str2
	movl	#1,r0			; return(+1)
100$:
	ret
	.end
#-h- strcpy.mar       309  asc  28-jul-83 00:15:23  tools (lblh csam sventek)
	.title	strcpy
;+
;	subroutine strcpy(in, out)
;-
in=4
out=8
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	strcpy	^m<>
	movl	in(ap),r0		; source address
	movl	out(ap),r1		; destination address
10$:
	movb	(r0)+,(r1)+		; copy character
	bneq	10$			; if not 0, do again
	ret
	.end
#-h- type.mar         546  asc  28-jul-83 00:15:24  tools (lblh csam sventek)
	.title	type
;+
;	integer function type(c)
;-
c=4
letter=1
digit=2
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	type	^m<>
	movb	@c(ap),r0		; character being typed
	cmpb	r0,#^a"0"		; digit?
	blss	20$			; NO
	cmpb	r0,#^a"9"		; digit?
	bgtr	10$			; NO
	movl	#digit,r0		; return(DIGIT)
	brb	30$
10$:
	bicb	#^x20,r0		; make upper case
	cmpb	#^a"A",r0		; letter?
	bgtr	20$			; NO
	cmpb	#^a"Z",r0		; letter?
	blss	20$			; NO
	movl	#letter,r0		; return(LETTER)
	brb	30$
20$:
	movzbl	@c(ap),r0		; return(c)
30$:
	ret
	.end
#-h- upper.mar        629  asc  28-jul-83 00:15:24  tools (lblh csam sventek)
	.title	upper
;+
;	subroutine upper(buf)
;
;	character buf(ARB)
;
;	any characters found in the range A-Z are changed to the corresponding
;	upper case character
;-
buf=4
biga=65
bigz=90
leta=97
letz=122
dif=leta-biga
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	upper	^m<>
	movl	buf(ap),r1		; address of buf(1)
10$:
	movzbl	(r1),r0			; fetch next character
	beql	20$			; if == 0, done
	cmpb	r0,#leta		; >= a?
	blss	30$			; NO
	cmpb	r0,#letz		; <= z?
	bgtr	30$			; NO
	subl2	#dif,r0			; make upper case
30$:
	movb	r0,(r1)+		; copy character back into string
	brb	10$			; try again
20$:
	ret
	.end
#-h- cast             105  asc  25-mar-82 09:09:45  v1.1 (sw-tools v1.1)
## CAST -- Common block for ^C AST flag.

common / cast / gotast

integer gotast		# YES => AST received.
#-h- clook            248  asc  02-aug-83 11:16:19  tools (lblh csam sventek)
common / pr_clook / lastp, lastt, namptr(MAX_PTR), table(MAX_TBL)

integer lastp			# last used pointer, init=0
integer lastt			# last used table, init=0
integer namptr			# pointers to name/defn pairs
character table			# storage for name/defn pairs