#-h-  memlb.all                 24161  ascii   05Jan84  08:10:24
#-h-  memlb.doc                  4707  ascii   04Jan84  11:24:05
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^memlb(2)^%^memlb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
memlb - ratfor dynamic memory allocation routines
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
sts = memalloc( index, size, type )
sts = memeput (index, element, position)
sts = memeget (index, element, position)
sts = memput (index, array, size, position)
sts = memget (index, array, size, position)
sts = memfree (index)
sts = memcop( index1, offset1, index2, offset2, size )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
Memlb is a collection of routines that allow manipulation
of dynamically allocated memory.
The dynamic memory is accessed through a machine-dependent pointer,
'index'. This pointer has type and word size equivalent to integer
and to the memlb type MEMINTEGER.
The routines are:
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memalloc
allocates memory dynamically for an array
of dimension 'size' and of type 'type'.
The types currently recognized are
MEMINTEGER, MEMCHARACTER, MEMLOGICAL,
MEMREAL, MEMCOMPLEX, and MEMDOUBLEPRECISION.
.sp
'Index' is used by the other
dynamic memory allocation routines to reference the memory space.
If not enough memory is available, index is set to
INSUFFICIENTMEMORY and ERR is returned, otherwise OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memfree
frees memory allocated dynamically by memalloc.
.sp
'Index' is the index of the memory area, returned by memalloc.
If 'index' was set to INSUFFICIENTMEMORY by memalloc, ERR
is returned, otherwise OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memget
gets an array of elements stored in the dynamic memory space
given by 'index'
and returns it into 'array', an array
of size no less than 'size' and of the same type that was specified
when the memory area was allocated.
.sp
The elements are retrieved from the dynamic memory area starting
with the 'position'th element.
If an attempt is made to retrieve more elements than exist in the dynamic
memory area, memget only copies as many elements as exist.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned, otherwise
OK is.
Note that the contents of the memory area will be unpredictable
unless information is put in it first with memput or memeput.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memput
stores a copy of the array 'array'
into the dynamically allocated memory area 'index'.
'Array' should be an array of size no less than 'size',
and of the same type that was specified when the memory
area was allocated.
.sp
The elements are stored into the dynamic memory area starting
at the 'position'th element.
If an attempt is made to store elements past the end of the
dynamic memory area, memput will stop storing elements
at the end of memory area.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memeget
gets the position'th element of the array stored
in the dynamic memory space
given by 'index'
and returns it into 'element', an item
of the same type that was specified
when the memory area was allocated.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
Note that the contents of the memory area will be unpredictable
unless information is put in it first with memput or memeput.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memeput
stores 'element', an item
of the same type that was specified when the memory
area was allocated by a call to memalloc,
into the position'th element of the array stored
in the memory area 'index'.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memcop
copies a segment of memory from one dynamic segment to another dynamic
segment.
.sp
'Index1' is the address of the first dynamic memory segment, and 'offset1'
is its displacement. The destinintion of the copy is represented by 'index2'
and its displacement by 'offset2'. 'Size' corresponds to the number of
elements to be moved to the destination segment.
.sp
If 'index1' or 'index2' is INSUFFICIENTMEMORY, or if either 'offset1' or
'offset2' is not within the range of the dynamic memory, ERR is returned.
Otherwise OK is returned.
.sp
.in -6
.sp
.ne 2
.fi
.ti -5
FILES
.br
/usr/incl/memsym.  Include file containing the
symbols mentioned herein.
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
tbllb(2)
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Todd Hammond

#-t-  memlb.doc                  4707  ascii   04Jan84  11:24:05
#-h-  memlb.inc                  2483  ascii   04Jan84  11:24:06
#-h-  memsym                     1879  ascii   04Jan84  11:23:36
## memsym - symbols definitions for memory allocation
#nolist

# revision history
#
# 01e 08Nov83 mam .Removed the data types(word,pointer).
# 01d 12jul83 jc  .Ratfixed
# 01c 09aug82 th  .Changed INSUFFICIENTMEMORY to 0 on the vax
#                  (this is what an uninitialized variable is likely to have
#                  in it)
#                 .Added definitions for PDP_10
# 01b 05Nov81 cal .Added revision history and turned off listing

# portability note:
#   dmlb.t assumes that the minimum unit is a character,
#   and that all the 'MEMWORD', ...., definitions are in terms of
#   characters

ifdef (VAX)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,4)
    define(MEMINTEGER,4)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,4)
    define(MEMREAL,4)
    define(MEMDOUBLEPRECISION,8)
    define(MEMCOMPLEX,8)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef
ifdef (MODCOMP)
  
  
    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,1)
    define(MEMREAL,2)
    define(MEMDOUBLEPRECISION,4)
    define(MEMCOMPLEX,4)
  
    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,-1)

enddef
ifdef (PDP_10)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)

    # MEMCHARACTER could probably be -7 except for rat4sym, which
    # tries to store things larger than seven bits in a character.
    define(MEMCHARACTER,1)

    define(MEMLOGICAL,1)
    define(MEMREAL,1)
    define(MEMDOUBLEPRECISION,2)
    define(MEMCOMPLEX,2)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef

#list
#-t-  memsym                     1879  ascii   04Jan84  11:23:36
#-h-  memcom                      344  ascii   04Jan84  11:23:37
## memcom - common for memory allocation routines
#nolist

# revision history
#
# 01a 09Nov83 mam .Changed data type 'word' to 'character'.

common /memcom/ memory(SCRATCH_MEMORY_SIZE),
    		firstfreeblock

character memory		# array of 'dynamically' allocated memory
pointer firstfreeblock	# first free block of memory in a linked list

#list
#-t-  memcom                      344  ascii   04Jan84  11:23:37
#-t-  memlb.inc                  2483  ascii   04Jan84  11:24:06
#-h-  memlb                     16581  ascii   04Jan84  11:24:07
# memlb.t - memory allocation routines

# modification history
#
# 02d 09Nov83 mam changed data type 'word' to 'character'
# 02c 09Aug83 jic ratfixed
# 02b 17may83 pw  placed machine independent by those routines listed
#                 twice in xref.lis
# 02a 19apr82 tb  changed all mem routines to return status. Changed
#                 memput and memget to have a position parameter
# 01d 23jul81 ah  formatted to meet ratfor coding standards
# 01c 06jul81 vp  renamed memlb
# 01b 12may81 th  modified so lines not too long
# 01a 21apr81 th  written

# the following routines are user visible:
#   memalloc - allocate memory
#   memfree - deallocate memory
#   memget - read dynamically allocated block
#   memput - write dynamically allocated block
#   memeget - read element in dynamically allocated block
#   memeput - write element in dynamically allocated block

# to implement these routines:
#
# 1. modify the definitions of the following items in memsym
#    1. word - should be the smallest possible allocatable unit
#       on the computer it is implemented in
#    2. pointer - should be a variable type large enough to
#       hold an address
#    3. the MEM<type> definitions: these should be defined as
#       the number of 'word's in the type specified
#       1. MEMWORD (always 1)
#       2. MEMPOINTER
#       3. MEMINTEGER
#       4. MEMCHARACTER
#       5. MEMLOGICAL
#       6. MEMREAL
#       7. MEMDOUBLEPRECISION
#       8. MEMCOMPLEX
#       9. MEMLOGICAL
# 3. SCRATCH_MEMORY_SIZE is the size of the scratch array that
#    is used to simulate dynamic memory allocation
# 4. MINIMUM_BLOCK should be set to maximum of values given in
#    the comments.  If MEMINTEGER < 2 * MEMPOINTER, the second must
#    be used.  If 2 * MEMPOINTER < MEMINTEGER, the first must be used.

include memsym

# the size of the scratch memory array
define(SCRATCH_MEMORY_SIZE,10000)

# for all blocks
define(LAST_BLOCK_START_OFFSET,(-MEMPOINTER))  # type MEMPOINTER
define(REAL_SIZE_OFFSET,0)  # type MEMINTEGER
define(TYPE_OFFSET,arith(REAL_SIZE_OFFSET,+,MEMINTEGER))  # type MEMINTEGER
    define(NOT_ALLOCATED,-1)  # type set to this if block not allocated

# for allocated blocks only
define(SIZE_OFFSET,arith(TYPE_OFFSET,+,MEMINTEGER))  # type MEMINTEGER
define(DATA_OFFSET,arith(SIZE_OFFSET,+,MEMINTEGER))  # type MEMINTEGER

# for unallocated blocks
define(LAST_BLOCK_OFFSET,arith(TYPE_OFFSET,+,MEMINTEGER))  # type MEMPOINTER
define(NEXT_BLOCK_OFFSET,arith(LAST_BLOCK_OFFSET,+,MEMPOINTER))  # MEMPOINTER

# MINIMUM_BLOCK should be the greater of following
#   define(MINIMUM_BLOCK,arith(DATA_OFFSET,+,MEMPOINTER))
#   define(MINIMUM_BLOCK,arith(arith(NEXT_BLOCK_OFFSET,+,MEMPOINTER),+,
#   MEMPOINTER))
define(MINIMUM_BLOCK,arith(arith(NEXT_BLOCK_OFFSET,+,MEMPOINTER),+,
MEMPOINTER))

# SLOP is the minimum size a block must have over the size wanted
# before it is split.
# It must be greater that MINIMUM_BLOCK
define(SLOP,arith(MINIMUM_BLOCK,+,20))

### blkmove - move block of memory     (machine indep)
#
# synopsis
#   call blkmove (a, words, b)
#
# description
#   moves the first 'words' words of a to b
#
# passed
#   a - contains the words to move
#   words - the number of words to move
#
# returned
#   b - will contain the first 'words' words of a

subroutine blkmove (a, words, b)
character a(ARB)
integer words
character b(ARB)

    integer i

    for (i=1; i<=words; i=i+1)
    	b(i) = a(i)

    return

end

### cutblock - cut block out of linked list of free blocks
#
# synopsis
#   call cutblock (index)
#
# description
#   removes block from linked list of free blocks
#   index must not be the only block in the linked list
#
# passed
#   index - the block to remove from the linked list

subroutine cutblock (index)
pointer index

    pointer lblock  # last block in linked list
    pointer nblock  # next block in linked list

    include memcom

    call blkmove (memory(index + LAST_BLOCK_OFFSET), MEMPOINTER, lblock)
    call blkmove (memory(index + NEXT_BLOCK_OFFSET), MEMPOINTER, nblock)
    call linkblocks (lblock, nblock)

    # now, index might very well have been firstfreeblock
    # to take care of this possibility, we change firstfreeblock
    # to the block following index

    firstfreeblock = nblock

    return

end

### linkblocks - connect two blocks together
#
# synopsis
#   call linkblocks (a, b)
#
# description
#   links block a to block b, so that the block following a is b,
#   and the block preceeding b is a
#
# passed
#   a, b - blocks to link together

subroutine linkblocks (a, b)
pointer a
pointer b

    include memcom


    call blkmove (b, MEMPOINTER, memory(a + NEXT_BLOCK_OFFSET))
    call blkmove (a, MEMPOINTER, memory(b + LAST_BLOCK_OFFSET))

    return

end

### memalloc - allocate memory     (machine indep)
#
# synopsis
#   sts = memalloc (index, size, type)
#
# description
#   allocates space for array of size 'size' and type 'type'
#
# passed
#   size - the number of elements of type 'type' to allocate
#   type - the type of element to allocate (i.e. MEMINTEGER)
#
# returned
#   index (type pointer)  - a value used by other memory
#	allocation routines
#    sts  - ERR if insufficient memory for allocation

integer function memalloc (index, size, type)
pointer index
integer size
integer type

    integer reqdsize
    pointer lastblock
    pointer block
    integer blocksize
    pointer nextblock
    pointer newblock

    include memcom

    call meminit

    reqdsize = max (MINIMUM_BLOCK,
	DATA_OFFSET + size * type + MEMPOINTER)
    block = firstfreeblock

    repeat
	{

	# get its size
	call blkmove (memory(block + REAL_SIZE_OFFSET), MEMINTEGER,
			blocksize)

	if (blocksize >= reqdsize)
	    {

	    # we found a free block which is big enough for us to use

	    call blkmove (memory(block + LAST_BLOCK_OFFSET),
			MEMPOINTER, lastblock)
	    call blkmove (memory(block + NEXT_BLOCK_OFFSET),
			MEMPOINTER, nextblock)

	    if (blocksize >= reqdsize + SLOP)
		{

		# split block

		newblock = block
		block = block + blocksize - reqdsize

		# the blocks are split like this so that it this block
		# is firstfreeblock, firstfreeblock won't have to be
		# changed

		# we can't cut the block out of the linked list as below,
		# because 'block' may very well be the only free block

		call setupblock (newblock,
			blocksize - reqdsize, NOT_ALLOCATED)
		call setupblock (block,
			reqdsize, NOT_ALLOCATED)

		call linkblocks (lastblock, newblock)
		call linkblocks (newblock, nextblock)

		}

	    else if (block == nextblock)
		{
		# this is the last block, and it can't be split
		# we must always have at least one entry in the linked
		# list, so don't allocate

		index = INSUFFICIENTMEMORY
                memalloc = ERR
		break
		}

	    else
		{
		# don't split block
		call cutblock (block)
		}

            index = block
            memalloc = OK
	    break

	    }

	# try next block in linked list
	call blkmove (memory(block + NEXT_BLOCK_OFFSET),
			MEMPOINTER, block)

	} until (block == firstfreeblock)


    if (index != INSUFFICIENTMEMORY)
    	{

	call blkmove (size, MEMINTEGER,
			memory(index + SIZE_OFFSET))
	call blkmove (type, MEMINTEGER,
			memory(index + TYPE_OFFSET))
	}

    return

end

### memeget - read element in dynamically allocated block     (machine indep)
#
# synopsis
#   sts = memeget (index, element, number)
#
# description
#   gets the 'number'th element of the dynamically
#   allocated array referenced by 'index', and puts it
#   in 'element'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   number - the number of the element to get
#
# returned
#   element - the element of the array
#   sts     - ERR if position or index is invalid

integer function memeget (index, element, number)
pointer index
character element(ARB)
integer number

    integer size
    integer type

    include memcom

    memeget = ERR
    call meminit

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove (memory(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove (memory(index + TYPE_OFFSET), MEMINTEGER, type)

    	if (number <= size)
            {

    	    call blkmove (memory(index  +  DATA_OFFSET  +
                          type * (number - 1)), type, element)
            memeget = OK
            
            }

	}

    return

end

### memeput - write element in dynamically allocated block     (machine indep)
#
# synopsis
#   sts = memeput (index, element, number)
#
# description
#   writes 'element' in the 'number'th position of the
#   dynamically allocated array referenced by 'index'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   element - the element to write in the memory area
#   number - the position of the element to write in the memory area
#
# returned
#   sts - ERR if position or index is invalid

integer function memeput (index, element, number)
pointer index
character element(ARB)
integer number

    integer size
    integer type

    include memcom

    memeput = ERR
    call meminit

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove (memory(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove (memory(index + TYPE_OFFSET), MEMINTEGER, type)

    	if (number <= size)
            {

            call blkmove (element, type, memory(index +
                          DATA_OFFSET + type * (number - 1)))
            memeput = OK
 
            }

	}


    return

end

### memfree - free memory     (machine indep)
#
# synopsis
#   sts = memfree (index)
#
# description
#   frees the memory area referenced by index
#
# passed
#   index (type pointer) - the memory area to free
#
# returned
#   sts - ERR if index is INSUFFICIENTMEMORY

integer function memfree (index)
pointer index

    pointer lastblock	# start of block physically preceeding index
    integer lasttype	# type of physically preceeding block
    integer blksize	# size of block at index
    pointer nextblock	# start of block physically following index
    integer nexttype	# type of physically following block
    pointer nblock	# next block in linked list

    include memcom

    memfree = OK
    call meminit

    if (index == INSUFFICIENTMEMORY)
        memfree = ERR

    else
    	{

	# mark block as deallocated

	call blkmove (NOT_ALLOCATED, MEMINTEGER,
		memory(index + TYPE_OFFSET))


	# add block to be freed to linked list: change
	#
	# firstfreeblock -> a
	#
	# to
	#
	# firstfreeblock -> index -> a

	call blkmove (memory(firstfreeblock + NEXT_BLOCK_OFFSET),
		MEMPOINTER, nblock)

	call linkblocks (firstfreeblock, index)
	call linkblocks (index, nblock)


	call blkmove (memory(index + REAL_SIZE_OFFSET),
		MEMPOINTER, blksize)

	call blkmove (memory(index + LAST_BLOCK_START_OFFSET),
		MEMPOINTER, lastblock)
	nextblock = index + blksize

	call blkmove (memory(nextblock + TYPE_OFFSET),
			MEMINTEGER, nexttype)
        call blkmove (memory(lastblock + TYPE_OFFSET),
			MEMINTEGER, lasttype)

	# try to merge with next block

	if (nexttype == NOT_ALLOCATED)
	    {
	    call mergeblocks (index, nextblock)
	    }

	# try to merge with last block

	if (lasttype == NOT_ALLOCATED)
	    {
	    call mergeblocks (lastblock, index)
	    }

	}

    return

end

### memget - read dynamically  allocated block     (machine indep)
#
# synopsis
#   sts = memget (index, array, number, position)
#
# description
#   gets 'number' elements from the dynamically
#   allocated array referenced by 'index', beginning with
#   the 'position'th element and puts them in 'array'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   number - the number of elements to get
#
# returned
#   array - the array to put the elements in
#   sts - ERR if position or index is invalid

integer function memget (index, array, number, position)
pointer index
character array(ARB)
integer number, position

    integer truenumber
    integer size
    integer truesize           #number of elements after 'position'
    integer type

    include memcom

    memget = ERR
    call meminit

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove (memory(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove (memory(index + TYPE_OFFSET), MEMINTEGER, type)

        if (position <= size)                   #within memory bounds
            {

            memget = OK
            truesize = (size - position) + 1    #elements after position

            if (number <= truesize)             #wants less than available
	        truenumber = number
            else                                #wants more than available
                truenumber = truesize

            call blkmove (memory(index + DATA_OFFSET + type *
                          (position - 1)), truenumber * type, array)

            }
	}

    return

end

### meminit - initialize memory allocator
#
# synopsis
#   call meminit
#
# description
#   initializes memory allocator

subroutine meminit

    pointer head
    pointer freeblock
    pointer tail

    include memcom

    integer initialized
    data initialized /NO/

    if (initialized == NO)
    	{

	head = 1
	freeblock = 1 + MINIMUM_BLOCK
	tail = 1 + SCRATCH_MEMORY_SIZE - MINIMUM_BLOCK

	call setupblock (head, MINIMUM_BLOCK, MEMWORD)
	call setupblock (freeblock, SCRATCH_MEMORY_SIZE -
    		2 * MINIMUM_BLOCK, NOT_ALLOCATED)
	call setupblock (tail, MINIMUM_BLOCK, MEMWORD)

	call linkblocks (freeblock, freeblock)

	firstfreeblock = freeblock

	initialized = YES

    	}

    return

end

### memput - write dynamically  allocated block     (machine indep)
#
# synopsis
#   sts = memput (index, array, number, position)
#
# description
#   writes 'number' elements of the array 'array'
#   into the dynamically allocated array referenced by
#   'index', starting with the 'position'th element
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   array - the array of elements to write in the memory area
#   number - the number of elements to put
#
# returned
#   sts - ERR if position or index invalid

integer function memput (index, array, number, position)
pointer index
character array(ARB)
integer number, position

    integer truenumber
    integer size
    integer truesize         #number of elements in memory after position
    integer type

    include memcom

    memput = ERR
    call meminit

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove (memory(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove (memory(index + TYPE_OFFSET), MEMINTEGER, type)

        if (position <= size)             #within memory bounds
            {

            memput = OK
            truesize = (size - position) + 1   #elements after position

            if (number <= truesize)            #wants less than available
                truenumber = number
            else                               #wants more than available
                truenumber = truesize

            call blkmove (array, truenumber * type, memory(index +
                          DATA_OFFSET + type * (position - 1)))

            }

	}


    return

end

### mergeblocks - merge two contiguous blocks
#
# synopsis
#   call mergeblocks (a, b)
#
# description
#   merges free blocks a and b, where a is the block
#   physically preceeding b
#
# passed
#   a - block which should have b appended to it
#   b - block which should have a prepended to it

subroutine mergeblocks (a, b)
pointer a
pointer b

    integer bsize

    include memcom


    # it changes
    #
    # ... -> alast -> a -> anext -> ... -> blast -> b -> bnext -> ...
    #
    # to
    #
    # ... -> alast -> a & b -> anext -> ... -> blast -> bnext -> ...

    call cutblock (b)
    call blkmove (memory(b + REAL_SIZE_OFFSET), MEMINTEGER, bsize)
    call setupblock (a, b - a + bsize, NOT_ALLOCATED)

    return

end

### setupblock - initialize a block
#
# synopsis
#   call setupblock (start, realsize, type)
#
# description
#   sets up a block starting at 'start' with real size 'realsize'
#   and type 'type'
#
# passed
#   start - the starting position of the block (a pointer)
#   realsize - the size of the block
#   type - the type of the block

subroutine setupblock (start, realsize, type)
pointer start
integer realsize
integer type

    include memcom

    call blkmove (realsize, MEMINTEGER, memory(start + REAL_SIZE_OFFSET))
    call blkmove (type, MEMINTEGER, memory(start + TYPE_OFFSET))
    call blkmove (start, MEMPOINTER, memory(start + realsize +
	    LAST_BLOCK_START_OFFSET))

    return

end
#-t-  memlb                     16581  ascii   04Jan84  11:24:07
#-t-  memlb.all                 24161  ascii   05Jan84  08:10:24
#-h-  vmemlb.all                18396  ascii   05Jan84  08:10:27
#-h-  vmemlb.doc                 4707  ascii   05Jan84  07:58:49
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^memlb(2)^%^memlb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
memlb - ratfor dynamic memory allocation routines
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
sts = memalloc( index, size, type )
sts = memeput (index, element, position)
sts = memeget (index, element, position)
sts = memput (index, array, size, position)
sts = memget (index, array, size, position)
sts = memfree (index)
sts = memcop( index1, offset1, index2, offset2, size )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
Memlb is a collection of routines that allow manipulation
of dynamically allocated memory.
The dynamic memory is accessed through a machine-dependent pointer,
'index'. This pointer has type and word size equivalent to integer
and to the memlb type MEMINTEGER.
The routines are:
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memalloc
allocates memory dynamically for an array
of dimension 'size' and of type 'type'.
The types currently recognized are
MEMINTEGER, MEMCHARACTER, MEMLOGICAL,
MEMREAL, MEMCOMPLEX, and MEMDOUBLEPRECISION.
.sp
'Index' is used by the other
dynamic memory allocation routines to reference the memory space.
If not enough memory is available, index is set to
INSUFFICIENTMEMORY and ERR is returned, otherwise OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memfree
frees memory allocated dynamically by memalloc.
.sp
'Index' is the index of the memory area, returned by memalloc.
If 'index' was set to INSUFFICIENTMEMORY by memalloc, ERR
is returned, otherwise OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memget
gets an array of elements stored in the dynamic memory space
given by 'index'
and returns it into 'array', an array
of size no less than 'size' and of the same type that was specified
when the memory area was allocated.
.sp
The elements are retrieved from the dynamic memory area starting
with the 'position'th element.
If an attempt is made to retrieve more elements than exist in the dynamic
memory area, memget only copies as many elements as exist.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned, otherwise
OK is.
Note that the contents of the memory area will be unpredictable
unless information is put in it first with memput or memeput.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memput
stores a copy of the array 'array'
into the dynamically allocated memory area 'index'.
'Array' should be an array of size no less than 'size',
and of the same type that was specified when the memory
area was allocated.
.sp
The elements are stored into the dynamic memory area starting
at the 'position'th element.
If an attempt is made to store elements past the end of the
dynamic memory area, memput will stop storing elements
at the end of memory area.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memeget
gets the position'th element of the array stored
in the dynamic memory space
given by 'index'
and returns it into 'element', an item
of the same type that was specified
when the memory area was allocated.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
Note that the contents of the memory area will be unpredictable
unless information is put in it first with memput or memeput.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memeput
stores 'element', an item
of the same type that was specified when the memory
area was allocated by a call to memalloc,
into the position'th element of the array stored
in the memory area 'index'.
.sp
If 'position' is not within the range of the dynamic memory area,
or if 'index' is INSUFFICIENTMEMORY, ERR is returned. Otherwise
OK is returned.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Memcop
copies a segment of memory from one dynamic segment to another dynamic
segment.
.sp
'Index1' is the address of the first dynamic memory segment, and 'offset1'
is its displacement. The destinintion of the copy is represented by 'index2'
and its displacement by 'offset2'. 'Size' corresponds to the number of
elements to be moved to the destination segment.
.sp
If 'index1' or 'index2' is INSUFFICIENTMEMORY, or if either 'offset1' or
'offset2' is not within the range of the dynamic memory, ERR is returned.
Otherwise OK is returned.
.sp
.in -6
.sp
.ne 2
.fi
.ti -5
FILES
.br
/usr/incl/memsym.  Include file containing the
symbols mentioned herein.
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
tbllb(2)
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Todd Hammond

#-t-  vmemlb.doc                 4707  ascii   05Jan84  07:58:49
#-h-  vmemlb.inc                 2009  ascii   05Jan84  07:58:50
#-h-  memsym                     1879  ascii   05Jan84  07:57:35
## memsym - symbols definitions for memory allocation
#nolist

# revision history
#
# 01e 08Nov83 mam .Removed the data types(word,pointer).
# 01d 12jul83 jc  .Ratfixed
# 01c 09aug82 th  .Changed INSUFFICIENTMEMORY to 0 on the vax
#                  (this is what an uninitialized variable is likely to have
#                  in it)
#                 .Added definitions for PDP_10
# 01b 05Nov81 cal .Added revision history and turned off listing

# portability note:
#   dmlb.t assumes that the minimum unit is a character,
#   and that all the 'MEMWORD', ...., definitions are in terms of
#   characters

ifdef (VAX)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,4)
    define(MEMINTEGER,4)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,4)
    define(MEMREAL,4)
    define(MEMDOUBLEPRECISION,8)
    define(MEMCOMPLEX,8)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef
ifdef (MODCOMP)
  
  
    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,1)
    define(MEMREAL,2)
    define(MEMDOUBLEPRECISION,4)
    define(MEMCOMPLEX,4)
  
    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,-1)

enddef
ifdef (PDP_10)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)

    # MEMCHARACTER could probably be -7 except for rat4sym, which
    # tries to store things larger than seven bits in a character.
    define(MEMCHARACTER,1)

    define(MEMLOGICAL,1)
    define(MEMREAL,1)
    define(MEMDOUBLEPRECISION,2)
    define(MEMCOMPLEX,2)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef

#list
#-t-  memsym                     1879  ascii   05Jan84  07:57:35
#-t-  vmemlb.inc                 2009  ascii   05Jan84  07:58:50
#-h-  vmemlb                    11290  ascii   05Jan84  07:58:50
#### memlb - memory allocation routines

# modification history
#
# 02g 05Dec83 jpl+rc  Fixed bug in debug code of memcop.
# 02f 09Nov83 mam Changed data type 'word' to 'character'.
# 02e 05Aug83  rc Added routine 'memcop' (written by John Lynch) to copy
#                 segments of dynamic memory.
# 02d 15Jul83 jic Ratfixed.
# 02c 02Jun83 cal Replaced the subroutine blkmove with a macro that
#                 uses lib$movc3 to speed up block moves.
# 02b 17may83 pw  placed vax version by those routines listed
#                 twice in xref.lis
# 02a 20Apr82 tb  changed all mem routines to return status. changed
#                 memput and memget to have a position parameter.
# 01c 06jul81 vp  renamed memlb
# 01b 29jun81 th  put headers in
# 01a 21apr81 th  written

# the following routines are user visible:
#   memalloc - allocate memory
#   memfree - deallocate memory
#   memget - read dynamically allocated block
#   memput - write dynamically allocated block
#   memeget - read element in dynamically allocated block
#   memeput - write element in dynamically allocated block
#   memcop - copy segment of dynamic memory from one location to another

# to implement these routines:
#
# 1. modify the definitions of the following items in memsym
#    1. word - should be the smallest possible allocatable unit
#       on the computer it is implemented in
#    2. pointer - should be a variable type large enough to
#       hold an address
#    3. the MEM<type> definitions: these should be defined as
#       the number of 'word's in the type specified
#       1. MEMWORD (always 1)
#       2. MEMCHARACTER
#       3. MEMINTEGER
#       4. MEMREAL
#       5. MEMDOUBLEPRECISION
#       6. MEMCOMPLEX
#       7. MEMLOGICAL
#       8. MEMPOINTER

include memsym

define(SIZE_OFFSET,0)  # size is MEMINTEGER
define(TYPE_OFFSET,arith(SIZE_OFFSET,+,MEMINTEGER))  # size is MEMINTEGER
define(DATA_OFFSET,arith(TYPE_OFFSET,+,MEMINTEGER))  # start of data


# ## blkmove- move block of memory     (vax version)
#
# synopsis
#   call blkmove(a, words, b)
#
# description
#   moves the first 'words' words of a to b
#
# passed
#   a - contains the words to move
#   words - the number of words to move
#
# returned
#   b - will contain the first 'words' words of a
#
# note:
#   "word" and "byte" must be the same size in order to use
#   lib$movc3; also, there is a limit of 65535 bytes that may
#   be transfered.
#
#   The operation of lib$movc3 is such that overlap of the
#   source and destination items does not affect the result.
#
define(blkmove,lib$movc3($2,$1,$3))

### memalloc - allocate memory     (vax version)
#
# synopsis
#   sts = memalloc (index, size, type)
#
# description
#   allocates space for array of size 'size' and type 'type'
#
# passed
#   size - the number of elements of type 'type' to allocate
#   type - the type of element to allocate (i.e. MEMINTEGER)
#
# returned
#   index (type pointer)  - a value used by other memory allocation
#                        routines
#   sts                   - ERR if insufficient memory for allocation

integer function memalloc (index, size, type)
integer size
integer type
pointer index


    if (! lib$get_vm (DATA_OFFSET  +  size * type, index))
        {
        memalloc = ERR
    	index = INSUFFICIENTMEMORY
        }

    else
    	{
	# store relevant information about block

	call blkmove(size, MEMINTEGER,
			%val(index + SIZE_OFFSET))
	call blkmove(type, MEMINTEGER,
			%val(index + TYPE_OFFSET))
        memalloc = OK
	}

    return

end

### memfree - free memory     (vax version)
#
# synopsis
#   sts = memfree (index)
#
# description
#   frees the memory area referenced by index
#
# passed
#   index (type pointer) - the memory area to free
# returned
#   sts  - ERR if index is invalid

integer function memfree (index)
pointer index

    integer size
    integer type

    memfree = ERR

    if (index != INSUFFICIENTMEMORY)
    	{
	# get relevant information about the block to be deleted

    	call blkmove(%val(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove(%val(index + TYPE_OFFSET), MEMINTEGER, type)

    	call lib$free_vm (DATA_OFFSET  +  size * type, index)

        memfree = OK
    	}

    return

end

### memget - read dynamically  allocated block     (vax version)
#
# synopsis
#   sts = memget (index, array, number, position)
#
# description
#   gets 'number' elements from the dynamically
#   allocated array referenced by 'index', beginning
#   with the 'position'th element, and puts them
#   in 'array'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   number - the number of elements to get
#   position - where to start getting elements from the memory area
#
# returned
#   array - the array to put the elements in
#   sts   - ERR if index or position is invalid

integer function memget (index, array, number, position)
pointer index
character array(ARB)
integer number
integer position

    integer truenumber
    integer size
    integer truesize             #number of elements in memory after 'position'
    integer type

    memget = ERR

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove(%val(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove(%val(index + TYPE_OFFSET), MEMINTEGER, type)

        if ( position <= size )                 #position is in memory bounds
            {

            memget = OK
            truesize = (size - position) + 1    #memory size after position

            if (number <= truesize)             #wants less than available
                truenumber = number
            else
                truenumber = truesize           #wants more than available

            call blkmove(%val(index + DATA_OFFSET + type *
                          (position - 1)), truenumber * type,  array)

             }
	}

    return

end

### memput - write dynamically  allocated block     (vax version)
#
# synopsis
#   sts = memput (index, array, number, position)
#
# description
#   writes 'number' elements of the array 'array'
#   into the dynamically allocated array referenced by
#   'index', starting with the 'position'th element.
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   array - the array of elements to write in the memory area
#   number - the number of elements to put
#   position - where to start putting elements into memory area
#
# returned
#   sts - ERR if position or index is invalid

integer function memput (index, array, number, position)
pointer index
character array(ARB)
integer number, position

    integer truenumber
    integer size
    integer truesize             #number of elements in memory after position
    integer type

    memput = ERR

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove(%val(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove(%val(index + TYPE_OFFSET), MEMINTEGER, type)

        if ( position <= size )               #position in memory bounds
            {

            memput = OK
            truesize = (size - position) + 1  #elements after position

            if (number <= truesize)           #wants less than available
                truenumber = number
            else                              #wants more than's available
                truenumber = truesize

	    call blkmove(array, truenumber * type, %val(index + 
                          DATA_OFFSET + type * (position - 1)))
            }

	}


    return

end

### memeget - read element in dynamically allocated block     (vax version)
#
# synopsis
#   sts = memeget (index, element, number)
#
# description
#   gets the 'number'th element of the dynamically
#   allocated array referenced by 'index', and puts it
#   in 'element'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   number - the number of the element to get
#
# returned
#   element - will contain the requested element of the array
#   sts     - ERR if position or index is invalid

integer function memeget (index, element, number)
pointer index
character element(ARB)
integer number

    integer size
    integer type

    memeget = ERR

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove(%val(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove(%val(index + TYPE_OFFSET), MEMINTEGER, type)

    	if (number <= size)
            {
            
            memeget = OK
    	    call blkmove(%val(index  +  DATA_OFFSET  +  type * (number - 1)),
    		          type, element)
            }

	}

    return

end

### memeput - write element in dynamically allocated block     (vax version)
#
# synopsis
#   sts = memeput (index, element, number)
#
# description
#   writes 'element' in the 'number'th position of the
#   dynamically allocated array referenced by 'index'
#
# passed
#   index (type pointer) - the index of the memory area
#	(obtained from memalloc)
#   element - the element to write in the memory area
#   number - the position of the element to write in the memory area
#
# returned
#   sts - ERR if position or index is invalid

integer function memeput (index, element, number)
pointer index
character element(ARB)
integer number

    integer size
    integer type

    memeput = ERR

    if (index != INSUFFICIENTMEMORY)
    	{

    	call blkmove(%val(index + SIZE_OFFSET), MEMINTEGER, size)
    	call blkmove(%val(index + TYPE_OFFSET), MEMINTEGER, type)

    	if (number <= size)
            {

            memeput = OK
    	    call blkmove(element, type,
          		%val(index  +  DATA_OFFSET  +  type * (number - 1)))
            
            }

	}


    return

end


### memcop - routine to copy dynamic memory
#
#  status = memcop( index1, offset1, index2, offset2, size )
#
#  given:
#      index1      - address of dynamic memory segment
#      offset1     - displacement in index1 of memory to copy
#      index2      - address of destination of copy
#      offset2     - displacement in index2 of destination
#      size        - number of elements to move
#
#  returned:
#      status      - OK | ERR ; error status
#
#   this routine copies a segment of memory from one dynamic
#   segment to another dynamic segment

integer function memcop( index1, ofset1, index2, ofset2, size )

    integer index1
    integer ofset1
    integer index2
    integer ofset2
    integer size
    integer size1
    integer size2

    integer type1       # length in "words" of elements in index1
    integer type2       # length in "words" of elements in index2

    define(DEBUG,)
    ifdef( DEBUG )

	if ( (index1 == INSUFFICIENTMEMORY) | (index2 == INSUFFICIENTMEMORY) )
	    return( ERR )

    enddef

    call blkmove( %val( index1 + TYPE_OFFSET ), MEMINTEGER, type1 )
    call blkmove( %val( index2 + TYPE_OFFSET ), MEMINTEGER, type2 )

    ifdef( DEBUG )

	call blkmove( %val( index1 + SIZE_OFFSET ), MEMINTEGER, size1 )
	call blkmove( %val( index2 + SIZE_OFFSET ), MEMINTEGER, size2 )

	if ( ((ofset1 + size - 1 ) > size1) | ((ofset2 + size - 1 ) > size2) )
	    return( ERR )

    enddef

    call blkmove( %val( index1 + DATA_OFFSET + (( ofset1 - 1 ) * type1 )),
                  size * type1,
                  %val( index2 + DATA_OFFSET + (( ofset2 - 1 ) * type2 )) )

    return( OK )
end
#-t-  vmemlb                    11290  ascii   05Jan84  07:58:50
#-t-  vmemlb.all                18396  ascii   05Jan84  08:10:27
#-h-  tbllb.all                 22601  ascii   05Jan84  08:10:30
#-h-  tbllb.doc                  5278  ascii   05Jan84  08:01:50
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^tbllb(2)^%^tbllb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
tbllb - symbol table routines
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
call instal(name, def)
status = lookup(name, def)
status = nmuninstall(name)

ind = nmfind(name)
call nmadd(name, def)
call nmcopy(ind, def)
call nmdel(ind)
nchar = nmdsiz(ind)
call nmncopy(ind, name)
nchar = nmnsiz(ind)

status = nmgtnt(ind)
call nmigtnt
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
"Tbllb" is a collection of routines used to maintain symbol tables. 
The routines are used by tools like "macro", "roff" and "rat4".  In
general, access to the package is via
.bd
"instal", "nmuninstall",
and
.bd
"lookup"
but these routines are constructed from more primitive routines
which can be called directly if necessary. 
.ne 3
.sp
The following conventions apply to all routine descriptions:
.bd
"Name"
is a
.ul
string
giving the name to be looked up or added.
.bd
"Def"
is a
.ul
string
giving the definition associated with a name or index.
.bd
"Ind"
is an integer identifying an entry to the table routines.  It has
meaning only to the table routines. 
.ne 3
.sp
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Instal
adds a name and definition to the symbol table.  It is called as
.sp
.nf
.in +4
call instal(name, def)
.sp
.fi
.in -4
If "name" is already in the symbol table, the old definition is first
deleted. 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Lookup
searches the symbol table for a name and, if it is found, copies the
associated definition to an array.  It is called as
.sp
.nf
.in +4
status = lookup(name, def)
.sp
.fi
.in -4
Status has the value "YES" if the name was found and "NO" otherwise.  "Def"
must be long enough to hold the definition of "name". 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmuninstall
removes the (most recent) definition of the name 'name'.
It is called as
.sp
.nf
.in +4
status = nmuninstall(name)
.sp
.fi
.in -4
If there is no definition for the name 'name',
nmuninstall returns NO.
Otherwise, nmuninstall returns YES.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmfind
is the primitive which looks up a name in the symbol table.  It is called
as
.sp
.nf
.in +4
ind = nmfind(name)
.sp
.fi
.in -4
"Ind" is the definition index
(used by nmcopy, nmdel, nmdsiz, nmncopoy, nmnsiz, and nmgtnt.)
If the name isn't in the table, "ind" will be zero. 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmadd
is the primitive which adds a new name and definition to the symbol table. 
It is called as:
.sp
.nf
.in +4
call nmadd
(name, def)
.sp
.fi
.in -4
If "name" is already in the table, nmadd will
.ul
not
delete it.  However, nmfind will always return the most recent definition
of a name so the old definition will be inaccessible until the new one
is deleted (except though use of it's index number.) 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmdel
is the primitive which deletes a name and definition from the symbol
table.  It is called as:
.sp
.nf
.in +4
call nmdel(ind)
.sp
.fi
.in -4
If "ind" does not refer to something in the symbol table, bizarre
program behavior is to be expected. 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmcopy
is the primitive which copies the text of a definition from the
symbol table to a local array.  It is called as:
.sp
.nf
.in +4
call nmcopy(ind, def)
.sp
.fi
.in -4
If "ind" doesn't refer to a symbol table entry or if "def" isn't
long enough to hold the definition, the program won't work well. 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmdsiz
is a primitive which returns the size (in characters, including the
EOS) of the definition
part of a symbol table entry.  It is called as:
.sp
.nf
.in +4
nchars = nmdsiz(ind)
.sp
.fi
.in -4
"Ind" should refer to a symbol table entry. 
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmncopy
is the primitive which copies the text of a 
.bd
"name"
to which the
.bd
"ind"
identifies from the symbol table to a local array.  It is called as:
.sp
.nf
.in +4
call nmncopy(ind, name)
.sp
.fi
.in -4
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmnsiz
is the primitive which returns the size (in characters, including the
EOS) of the
.bd
"name"
part of a symbol table entry. It is called as:
.sp
.nf
.in +4
nchar = nmnsiz(ind)
.sp
.fi
.in -4
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmgtnt
is the primitive which gets and returns the index number of the next
symbol definition in the symbol table. Status returns are OK and EOF;
EOF is returned if there are no more entries. It should be noted that
though all of the definitions will be produced by this routine, the
order in which they are returned is undefined.
.bd
Important:
It is required that the symbol table not be modified while nmgtnt
is being used. If it is desired to modify the symbol table, nmigtnt
must be called before nmgtnt can be used.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
.bd
Nmigtnt
is the primitive which resets
.bd
nmgtnt
to the beginning of the symbol table.
.in -6
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
roff(1), macro(1), rat4(1)
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Vern Paxton and Van Jacobson
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
On all machines, users of tbllb must link with "tbllb". However, on
the Modcomp, users writing BCPL programs must link with "tbllib".

#-t-  tbllb.doc                  5278  ascii   05Jan84  08:01:50
#-h-  tbllb.inc                  2243  ascii   05Jan84  08:01:52
#-h-  memsym                     1879  ascii   05Jan84  08:01:19
## memsym - symbols definitions for memory allocation
#nolist

# revision history
#
# 01e 08Nov83 mam .Removed the data types(word,pointer).
# 01d 12jul83 jc  .Ratfixed
# 01c 09aug82 th  .Changed INSUFFICIENTMEMORY to 0 on the vax
#                  (this is what an uninitialized variable is likely to have
#                  in it)
#                 .Added definitions for PDP_10
# 01b 05Nov81 cal .Added revision history and turned off listing

# portability note:
#   dmlb.t assumes that the minimum unit is a character,
#   and that all the 'MEMWORD', ...., definitions are in terms of
#   characters

ifdef (VAX)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,4)
    define(MEMINTEGER,4)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,4)
    define(MEMREAL,4)
    define(MEMDOUBLEPRECISION,8)
    define(MEMCOMPLEX,8)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef
ifdef (MODCOMP)
  
  
    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,1)
    define(MEMREAL,2)
    define(MEMDOUBLEPRECISION,4)
    define(MEMCOMPLEX,4)
  
    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,-1)

enddef
ifdef (PDP_10)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)

    # MEMCHARACTER could probably be -7 except for rat4sym, which
    # tries to store things larger than seven bits in a character.
    define(MEMCHARACTER,1)

    define(MEMLOGICAL,1)
    define(MEMREAL,1)
    define(MEMDOUBLEPRECISION,2)
    define(MEMCOMPLEX,2)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef

#list
#-t-  memsym                     1879  ascii   05Jan84  08:01:19
#-h-  ctblhsh                     104  ascii   05Jan84  08:01:21
## ctblhsh - hash table for tbllib
#nolist

integer hshtbl(HASHTABLESIZE)
common /tblcom/ hshtbl

#list
#-t-  ctblhsh                     104  ascii   05Jan84  08:01:21
#-t-  tbllb.inc                  2243  ascii   05Jan84  08:01:52
#-h-  tbllb                     14690  ascii   05Jan84  08:01:53
#### tbllb - symbol table package
#
# revision history
#
# 03b 18Jul83 jic .ratfixed.
# 03a 25May82 cal .added nmncopy, nmnsiz, nmgtnt, and nmigtnt; changed
#                  error messages into strings
# 02a 20apr82 tb  .changed all routines that call memlb routines
#                  to check status and abort if err. See v2a of
#                  memlb. The routines changed were nmequal, nmdel
#                  nmcopy, nmdsiz, nmlookup, and nminstall
# 01g 07jan82 tb  .fixed initialization loop in 'hashname' to be
#                  called 1 less time, so as not to overwrite the
#                  hshtbl array
# 01f 12nov81 th  .changed name of uninstall to nmuninstall
# 01e 04sep81 th  .added uninstall
# 01d 23jul81 ah  .alphabetized & added ### to headers
# 01c 06jul81 vp  .renamed tbllb
# 01b 23jun81 th  .modified hashname so it wouldn't cause
#                  integer overflows
# 01a 06Jun81 vp  .written.  Ratfor code based on bcpl version
#
#  These routines are part of a symbol table package used by
# various software tools (macro, roff, rat4, etc.)
#
#  Routines in the package are:
#     call instal(name,def)      define a name
#     status = lookup(name,def)  retrieve a definition (YES if found)
#     ind = nmfind(name)         lookup a name
#     call nmadd(name, def)      add a name and its definition
#     call nmcopy(ind, def)      copy the definition of a name
#     call nmncopy(ind, name)    copy the key of a name
#     call nmdel(ind)            delete a name
#     nchar = nmdsiz(ind)        returns the size of a definition
#     nchar = nmnsiz(ind)        returns the size of a key
#     status = nmuninstall(name) remove refinition of name (YES if existed)
#     status = nmgtnt(ind)       get index of next table entry
#     call nmigtnt               reset nmgtnt to beginning of symbol table
#
#  All names and definitions are ratfor strings.  All indices are
# addresses returned from the dynamic memory allocation routines,
# and are therefore meaningless to the user.
#
#  The names are hashed and strung in a singly linked list from the
# hash table entries.  The entry for each name is in the form:
#    - next entry with same hash value (=ENDOFLIST if none)
#    - length of name
#    - length of definition
#    - index of name
#    - index of definition
# where the name and definition indices are values returned from
# the dynamic memory routines for the locations where the name
# and definition strings are stored.
#
# implementation problems:
#  Hashname will have to be changed if the machine does not allow
# the user to mix character data type with integer data type
#  Note that since this data structure mixes pointer types with
# integers, it WILL NOT WORK if the 'pointer' data type is ever
# changed from being 'integer'.

 include memsym

 define(ENDOFLIST,0)
 define(ELINK,1)
 define(ENAMESIZE,2)
 define(EDEFSIZE,3)
 define(ENAMEPTR,4)
 define(EDEFPTR,5)
 define(HASHTABLESIZE,229)	# should be prime
 define(ESIZE,5)
 define(MAXNAMESIZE,100)
 define(BIG_NUMBER,8192)	# should be <= maximum integer / 2 - 256

### hashname - returns hash index for given name with given length
#
# synopsis
#
#   i = hashname(name, len)
#
#	name - character string containing name to hash
#	len - length of name
#	i - hash index
#
integer function hashname(name, len)
character name(ARB)
integer len

    integer hash, i, init
    include ctblhsh
    data init /YES/

    hash = 0
    if (init == YES)
	{
	for (i = 1; i <= HASHTABLESIZE; i = i + 1)
	    hshtbl(i) = ENDOFLIST
	init = NO
	}

    for (i = 1; i <= len; i = i + 1)
	{
	# prevents integer overflow
	hash = mod((hash * 2) + name(i), BIG_NUMBER)
	}

    hash = mod(hash, HASHTABLESIZE)

    if (hash < 0)
	hash = -hash
    return hash + 1	# 0 is not a legal value for Fortran array indices
end

### instal - add a name and definition
#
# synopsis
#
#   call instal(name,def)
#
#	name - name use as key
#	def - definition of key
#
subroutine instal(name, def)
character name(ARB), def(ARB)

    integer ind, nmfind

    # check if the name is defined and delete the old copy if so.
    ind = nmfind(name)
    if (ind != ENDOFLIST)
	call nmdel(ind)

    call nmadd(name, def)
    return
end

### lookup - returns a name's definition in passed string; function
#
# synopsis
#
#   status = lookup(name, def)
#
#	name - character string containing name to look up
#	def - returned character string containing defintion
#	status - return status; YES if the name was in the table, else NO
#
integer function lookup(name, def)
character name(ARB), def(ARB)

    integer ind, nmfind

    ind = nmfind(name)

    if (ind == ENDOFLIST)
	return NO

    call nmcopy(ind, def)
    return YES
end

### nmadd - add a name and its definition
#
# synopsis
#
#   call nmadd(name, def)
#
#	name - character string containing name to use as key
#	def - character string containing definition
#
#   1 is added to the strings' lengths so that the EOS is
#   stored along with the rest of the string
subroutine nmadd(name, def)
character name(ARB), def(ARB)

    integer length

    call nminstall(name, length(name) + 1, def, length(def) + 1)
    return
end

### nmcopy - copy definition at index into passed string
#
# synopsis
#
#   call nmcopy(ind, def)
#
#	ind - index of defintion to get
#	def - character string to recieve definition
#
subroutine nmcopy(ind, def)
integer ind
character def(ARB)

    integer defptr			# index of definition entry
    integer ds				# size of definition entry
    integer memeget			# gets an element from entry
    integer memget			# gets an entry froom dynamic mem
    string dserr "tbllb$nmcopy: Failed to get definition size."
    string dptrerr "tbllb$nmcopy: Failed to get definition ptr."
    string deferr "tbllb$nmcopy: Failed to get definition from symbol table."

    if (memeget(ind, defptr, EDEFPTR) == ERR)
        call error(dptrerr)
    if (memeget(ind, ds, EDEFSIZE) == ERR)
        call error(dserr)
    if (memget(defptr, def, ds, 1) == ERR)
        call error(deferr)
    return
end

### nmncopy - copy name of key
#
# synopsis
#
#   call nmncopy(ind, def)
#
#	ind - index of key name to get
#	def - character string to recieve key name
#
subroutine nmncopy(ind, name)
integer ind
character name(ARB)

    integer namptr			# index of key entry
    integer ds				# size of key entry
    integer memeget, memget
    string dserr "tbllb$nmncopy: Failed to get key size."
    string dptrerr "tbllb$nmncopy: Failed to get key ptr."
    string keyerr "tbllb$nmncopy: Failed to get key from symbol table."

    if (memeget(ind, namptr, ENAMEPTR) == ERR)
        call error(dptrerr)
    if (memeget(ind, ds, ENAMESIZE) == ERR)
        call error(dserr)
    if (memget(namptr, name, ds, 1) == ERR)
        call error(keyerr)
    return
end

### nmdel - deletes table entry of given index
#
# synopsis
#
#   call nmdel(ind)
#
#	ind - index number of entry to delete
#
subroutine nmdel(ind)
integer ind

    integer hshind		# hash of name in symbol table entry, 'ind'
    integer hashname		# hashes name in sym tbl entry
    integer entry(ESIZE)	# symbol table entry for 'ind'
    integer lstind		# last index checked in linked list
    integer ind2		# next index in linked list
    character name(MAXNAMESIZE)	# name found in sym tbl entry 'ind'
    integer memeget, memget, memfree
    string gtderr "tbllb$nmdel: Failed to get symbol table entry to delete."
    string gtnerr "tbllb$nmdel: Failed to get symbol table entry for name."
    string gtlerr "tbllb$nmdel: Failed to get linked symbol table entry."
    string fdterr "tbllb$nmdel: Failed link symbol table entries."
    string ffterr "tbllb$nmdel: Failed to free symbol table entry space."
    string ffserr "tbllb$nmdel: Failed to free symbol table name space."
    string ffderr "tbllb$nmdel: Failed to free symbol table definition space."

    include ctblhsh

    if (ind != ENDOFLIST)
        {
        if (memget(ind, entry, ESIZE, 1) == ERR)
	    call error(gtderr)

        if (memget(entry(ENAMEPTR), name, entry(ENAMESIZE), 1) == ERR)
	    call error(gtnerr)

        hshind = hashname(name, entry(ENAMESIZE))	# hash name

        if (hshtbl(hshind) == ind)			# found entry already
            hshtbl(hshind) = entry(ELINK)		# link around 'ind'

        else
            {
            ind2 = hshtbl(hshind)

            while (ind2 != ind)
                {
                lstind = ind2
                if (memeget(ind2, ind2, ELINK) == ERR)
		    call error(gtlerr)
                }

            if (memeput(lstind, entry(ELINK), ELINK) == ERR)
		call error(fdterr)
            }

        if (memfree(ind) == ERR)
	    call error(ffterr)

        if (memfree(entry(ENAMEPTR)) == ERR)
	    call error(ffserr)

        if (memfree(entry(EDEFPTR)) == ERR)
	    call error(ffderr)
        }
    return
end

### nmdsiz - returns the size of the definition of an index
#
integer function nmdsiz(ind)
integer ind

    integer memeget
    string memerr "tbllb$nmdsiz: Failed to get definition size."

    if (memeget(ind, nmdsiz, EDEFSIZE) == ERR)
        call error(memerr)
    return
end

### nmnsiz - returns the size of a key
#
integer function nmnsiz(ind)
integer ind

    integer memeget
    string memerr "tbllb$nmnsiz: Failed to get definition size."

    if (memeget(ind, nmnsiz, ENAMESIZE) == ERR)
        call error(memerr)
    return
end

### nmigtnt - reset nmgtnt to start of symbol table
### nmgtnt - get next index number from symbol table
#
# synopsis
#
#   status = nmgtnt(ind)
#   call tnigtnt
#
#	ind - index number of next entry in the symbol table
#	status - EOF if at end of symbol table, else OK
#
integer function nmgtnt(ind)
integer ind, dummy

    integer hindex, mindex
    include ctblhsh
    string memerr "tbllb$nmgtnt: Failed to memeget pointer."
    data hindex /1/		# index first entry in hash table
    data mindex /ENDOFLIST/	# memlb pointer to entry

    for (ind = ENDOFLIST; hindex <= HASHTABLESIZE; hindex = hindex + 1)
	{
	if ((hshtbl(hindex) == ENDOFLIST) & (mindex == ENDOFLIST))
	    next		# try next hash table element
	if (mindex == ENDOFLIST)
	    {
	    mindex = hshtbl(hindex) # first time with this element
	    ind = mindex
	    break
	    }
	if (memeget(mindex, mindex, ELINK) == ERR)
	    call error(memerr)
	if (mindex != ENDOFLIST)
	    {
	    ind = mindex
	    break
	    }
	}
    if (ind == ENDOFLIST)
	return EOF
    ind = mindex
    return OK

entry nmigtnt(dummy)

    hindex = 1
    mindex = ENDOFLIST
    return
end

### nmequal - returns YES if the name corresponding to a given index
#          is equivalent to a given name with a given length
# synopsis
#
#	ind - symbol table entry index
#	name - name to check
#	len - length of name to check
#
integer function nmequal(ind, name, len)
integer ind
character name(ARB)
integer len

    integer equal			# checks names for equality
    integer entry(ESIZE)		# sym tbl entry for 'ind'
    integer memget			# gets sym tbl entries
    character tmp(MAXNAMESIZE)		# name in sym tbl
    string symerr "tbllb$nmequal: Failed to get symbol table entry."
    string namerr "tbllb$nmequal: Failed to get symbol table entry name."

    nmequal = NO

    if (memget(ind, entry, ESIZE, 1) == ERR)
	call error(symerr)

    if (entry(ENAMESIZE) == len)
        {
        if (memget(entry(ENAMEPTR), tmp, len, 1) == ERR)
            call error(namerr)
        nmequal = equal(tmp, name)
        }
    return 
end

### nmfind - returns index of given string
#
integer function nmfind(str)
character str(ARB)

    integer nmlookup, length

    return nmlookup(str, length(str) + 1)	# add 1 to length so EOS
						# is included in name
end

### nminstall - installs a name of given length and its
#             corresponding definition string of given length
#
subroutine nminstall(name, ns, def, ds)
character name(ARB)			# name to install
integer ns				# size of name to install
character def(ARB)			# definition of name
integer ds				# size of definition

    integer hashname			# hashes name
    integer hshind			# hash of name
    integer memalloc			# allocates dynamic memory for install
    integer memput			# puts info in dynamic memory space
    integer tmp(ESIZE)			# temporary sym tbl entry
    string memmsg "tbllb$nminstall: Dynamic table space overflowed."
    string tmperr "tbllb$nminstall: Failed to install new symbol table entry."
    string nmerr "tbllb$nminstall: Failed to put name in symbol table."
    string dferr "tbllb$nminstall: Failed to put definition in symbol table."

    include ctblhsh

    if (ns != 0)
        {
        hshind = hashname(name, ns)
        tmp(ELINK) = hshtbl(hshind)             # don't lose linked list

        if (memalloc(hshtbl(hshind), ESIZE, MEMINTEGER) == ERR)
            call panic(memmsg)

        tmp(ENAMESIZE) = ns
        tmp(EDEFSIZE) = ds

        if (memalloc(tmp(ENAMEPTR), ns, MEMCHARACTER) == ERR)
            call panic(memmsg)

        if (memalloc(tmp(EDEFPTR), ds, MEMCHARACTER) == ERR)
            call panic(memmsg)

        if (memput(hshtbl(hshind), tmp, ESIZE, 1) == ERR)
            call error(tmperr)

        if (memput(tmp(ENAMEPTR), name, ns, 1) == ERR)
            call error(nmerr)

        if (memput(tmp(EDEFPTR), def, ds, 1) == ERR)
            call error(dferr)
        }
     return
 end

### nmlookup - returns the index of a name definition with given length
#
integer function nmlookup(name, len)
character name(ARB)                 # name to look up
integer len                         # length of name to look up

    integer ind                     # index of symbol table entry
    integer hashname                # hashes name
    integer nmequal                 # checks if names are equal
    integer memeget                 # gets next index in linked list
    string linkerr "tbllb$nmlookup: Failed to get linked symbol table entry."

    include ctblhsh

    ind = ENDOFLIST

    if (len != 0)
        {
        ind = hshtbl(hashname(name, len))

        while (ind != ENDOFLIST)
            {
            if (nmequal(ind, name, len) == YES)
                break

            if (memeget(ind, ind, ELINK) == ERR)
                call error(linkerr)
            }
        }
     return ind
end

### nmuninstall - remove definition of symbol
#
# status = nmuninstall (name)
#
# description
#   removes (most recent) definition of symbol 'name'
#
# passed
#   name - symbol to remove
#
# returned
#   status - YES if there was such a symbol, NO if not
#
integer function nmuninstall(name)
character name(ARB)

    integer nmfind
    integer ind

    ind = nmfind (name)

    if (ind == ENDOFLIST)
	nmuninstall = NO
    else
	{
	nmuninstall = YES
	call nmdel (ind)
	}
    return
end
#-t-  tbllb                     14690  ascii   05Jan84  08:01:53
#-t-  tbllb.all                 22601  ascii   05Jan84  08:10:30
#-h-  evalb.all                 11992  ascii   05Jan84  08:10:32
#-h-  evalb.doc                  2913  ascii   05Jan84  08:03:43
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^evalb(2)^%^evalb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
evalb - expression evaluation routine library
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
   status = bsep( ptr )
   call cpush( opr, ptr )
   status = evalexpr( exp, result )
   status = lprnp( ptr )
   call putreal( number, minwid )
   value = rev( arg1, opr, arg2 )
   call rpush( r4, ptr )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
Evalb is the standard software tools expression evaluation library.
The routines it contains are used by such tools as macro, roff, rofmac,
etc.
.ne 3
.sp
In the following section, each routine is described.
.sp
.nf
.bd
bsep - whether 'ptr' is at the beginning of a
   sub-expression or not if ptr is zero, or if it points to a 
   left paren, then bsep returns .true.; otherwise, it is 
   .false.
passed
   ptr - integer, assumed to be a pointer into
   cstk or typstk.
returned
   status - .true. or .false.

.bd
cpush - push an operator onto the stack
   pushes the operator 'opr' onto the stack 'cstk' at
   'ptr', and the value OP onto the stack 'typstk' at
   'ptr'.
passed
   opr - the operator to be pushed onto 'cstk'
   ptr - integer, assumed to be a pointer into 'cstk'
         and 'typstk'

.bd
evalexpr - evaluate an arithmetic expression
   in a string evaluates the arithmetic expression in the
   string 'exp' and returns the resulting value
   in the real 'result'.  If all went well, evalexpr
   itself returns .true.;  if not, it returns .false.
   and 'result' is not set. Valid operators are PLUS,
   MINUS, STAR, SLASH, and CARET.
passed
   exp - the string to be evaluated as an arithmetic
         expression
returned
   result - the value of 'exp' (real)
   status - .true. or .false.

.bd
lprnp - whether ptr points to a left paren or not
   if typstk(ptr) is not equal to OP, or if cstk(ptr)
   is not a left paren, lprnp is .false.; otherwise,
   it is .true.
passed
   ptr - integer, assumed to be a pointer into
          typstk and cstk.
returned
   status - .true. or .false.

.bd
putreal - output a real number
   outputs the real number 'number', in a field of
   minimum width 'minwid', onto SDTOUT.
passed
   number - real number to be output
   minwid - the minimum size of the field in which
            'number' is to be output
.bd
rev - evaluate real binomial
   evaluates the expression
          arg1 opr arg2
passed
   arg1, arg2 - real
   opr - character, representing the operation
         to be performed
returned
   value - real

.bd
rpush - push a real onto the stack.
   pushes the real 'r4' onto the stack 'rstk' at 'ptr',
   and the value RL onto the stack 'typstk' at 'ptr'.
passed
   r4 -  real, to be pushed onto the stack
   ptr -  integer, assumed to be a pointer into
          rstk and typstk
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
roff(1), macro(1), rofmac(1) (tools which use these routines)

#-t-  evalb.doc                  2913  ascii   05Jan84  08:03:43
#-h-  evalb.inc                   373  ascii   05Jan84  08:03:45
#-h-  evalcomn                    243  ascii   05Jan84  08:03:19
## evalcomn - unknown include file
#nolist

    integer*4 istk(STACKSIZE)
    real*4    rstk(STACKSIZE)
    integer*4 cstk(STACKSIZE)

    integer typstk(STACKSIZE)

    common /expstk/ istk, typstk

    equivalence ( istk, rstk, cstk )
#list
#-t-  evalcomn                    243  ascii   05Jan84  08:03:19
#-t-  evalb.inc                   373  ascii   05Jan84  08:03:45
#-h-  evalb                      8316  ascii   05Jan84  08:03:46
# evalb - expression evaluation routine library.
#
# (used by macro, roff, rofmac, etc.)
#
#
# Modifications
#
#   v01j 09dec83 sd  removed define for NOIMPLICIT, already defined in ratp1
#		     declared lprnp as logical in BSEP module
#   v01i 15jul83 jic ratfixed
#   v01h 25may82 njd changed type to character
#   v01g 23Sep82 rc  moved ctor and rtoc to fttlb
#   v01f 19Nov81 cal added fudge factor in rtoc to correct rounding errors
#   v01e 11sep81 ah  moved ctoi to fttlb
#   v01d 25aug81 vp  replaced rtoc with portable version written by vj
#
#   v01c 17jul81 ah  moved putspaces to fttlb
#                    changed name to evalb
#
#   v01b 05oct80 vj  changed from include to library.
#                    changed include stmts for new ratfor.
#
#   v01a 01jul80 jp&vj written.


define(STACKSIZE,30)
define(OP,0)
define(INT,1)
define(RL,2)

### bsep - Whether ptr is at the beginning of a sub-expression or not.
#
# synopsis
#   status = bsep ( ptr )
#
# description
#   if ptr is zero, or if it points to a left paren, then bsep
#   returns .true.; otherwise, it is .false.
#
# passed
#   ptr - integer, assumed to be a pointer into cstk or typstk.
#
# returned
#   status - .true. or .false.

logical function bsep ( ptr )
NOIMPLICIT
integer ptr
logical lprnp

    include evalcomn

    if ( ptr == 0 )
        bsep = .true.
    else
        bsep = lprnp ( ptr )

    return
end

### cpush - push an operator onto the stack.
#
# synopsis
#   call cpush ( opr, ptr )
#
# description
#   pushes the operator 'opr' onto the stack 'cstk' at 'ptr', and
#   the value OP onto the stack 'typstk' at 'ptr'.
#
# passed
#   opr - the operator to be pushed onto 'cstk'
#   ptr - integer, assumed to be a pointer into 'cstk' and 'typstk'

subroutine cpush ( opr, ptr )
NOIMPLICIT
integer opr
integer ptr

    include evalcomn

    if ( ptr >= STACKSIZE )
        call error ( "  stack overflow." )
    ptr = ptr + 1
    cstk ( ptr ) = opr
    typstk ( ptr ) = OP

    return
end

### evalexpr - Evaluate an arithmetic expression in a string.
#
# synopsis
#   status = evalexpr ( exp, result )
#
# description
#   evaluates the arithmetic expression in the string 'exp' and
#   returns the resulting value in the real 'result'.  If all
#   went well, evalexpr itself returns .true.;  if not,
#   it returns .false. and 'result' is not set.
#   Valid operators are PLUS, MINUS, STAR, SLASH, and CARET.
#
# passed
#   exp - the string to be evaluated as an arithmetic expression
#
# returned
#   result - the value of 'exp' (real)
#   status - .true. or .false.

logical function evalexpr ( exp, result )
NOIMPLICIT
character exp(ARB)
real result

    character type, c
    integer idx, ptr
    real r4, ctor, rev
    logical bsep, lprnp

    include evalcomn

    evalexpr = .false.
    ptr = 0
    idx = 1

    while ( exp(idx) != EOS )
        {
        c = exp(idx)
        if ( ( type ( c ) == DIGIT ) |
             ( c == '.' & type( exp(idx+1) ) == DIGIT ) |
             ( c == '-' & idx == 1 ) |
             ( c == '-' & typstk(ptr) == OP ) )
            {
            r4 = ctor ( exp, idx )
            if ( bsep ( ptr ) )
                call rpush ( r4, ptr )
            else if ( typstk(ptr) != OP )
                call error ( " missing operator." )
            else
                {
                if ( ptr <= 1 )
                    call error ( "  no first operand." )
                if ( typstk(ptr-1) == OP )
                    call error ( "  two operators." )
                rstk(ptr-1) = rev ( rstk(ptr-1), cstk(ptr), r4 )
                ptr = ptr - 1
                }
            }
        else if ( c=='+' | c=='-' | c=='*' |
                  c=='/' | c=='^' )
            {
            if ( bsep ( ptr ) )
                call error ( " missing first operand." )
            if ( typstk(ptr) == OP )
                {
                call error ( " two operators in a row." )
                }
            call cpush ( c, ptr )
            idx = idx + 1
            }
        else if ( c == '(' )
            {
            if ( ! bsep ( ptr ) )
                if ( typstk(ptr) != OP )
                    {
                    call error(" left paren illegal after operand." )
                    }
            call cpush ( c, ptr )
            idx = idx + 1
            }
        else if ( c == ')' )
            {
            if ( bsep ( ptr ) )
                {
                call error ( " empty sub-expression." )
                }
            if ( typstk(ptr) == OP )
                {
                call error ( " missing second operand." )
                }
            if ( ptr <= 1 )
                {
                call error ( " too many right parens." )
                }
            if ( ! lprnp ( ptr-1 ) )
                call error ( "  left paren lost." )
            if ( bsep ( ptr-2 ) )
                {
                rstk(ptr-1) = rstk(ptr)
                typstk(ptr-1) = RL
                ptr = ptr - 1
                }
            else
                if ( typstk(ptr-2) != OP )
                    call error ( "  bad left paren." )
                else if ( ptr <= 3 )
                    call error ( "  no first operand." )
                else
                    {
                    rstk(ptr-3) = rev(rstk(ptr-3),cstk(ptr-2),rstk(ptr))
                    ptr = ptr - 3
                    }
            idx = idx + 1
            }
        else if ( c == ' ' )
            {
            idx = idx + 1
            }
        else
            break
        }

    if ( ptr != 1 | typstk(1) == OP )
        call error ( " badly terminated expression." )

    else
        if ( typstk(1) == RL )
            {
            result = rstk(1)
            evalexpr = .true.
            }
        else
            call error ( "  unknown type on stack." )

    return
end

### lprnp - Whether ptr points to a left paren or not.
#
# synopsis
#   status = lprnp ( ptr )
#
# description
#   if typstk(ptr) is not equal to OP, or if cstk(ptr) is not a left paren,
#   lprnp is .false.; otherwise, it is .true.
#
# passed
#   ptr - integer, assumed to be a pointer into typstk and cstk.
#
# returned
#   status - .true. or .false.

logical function lprnp ( ptr )
NOIMPLICIT
integer ptr

    include evalcomn

    if ( typstk(ptr) != OP )
        lprnp = .false.
    else
        if ( cstk(ptr) == '(' )
            lprnp = .true.
        else
            lprnp = .false.

    return
end

### putreal - Output a real number.
#
# synopsis
#   call putreal ( number, minwid )
#
#  DESCRIPTION:
#   outputs the real number 'number', in a field of minimum width
#   'minwid', onto SDTOUT.
#
# passed
#   number - real number to be output
#   minwid - the minimum size of the field in which 'number' is
#            to be output

subroutine putreal ( number, minwid )
NOIMPLICIT
real number
integer minwid

    character chars(MAXLINE)
    integer rtoc, i, numc

    numc = rtoc ( number, chars, MAXLINE )
    call putspaces ( minwid - (numc-1) )
    call putlin ( chars, STDOUT )

    return
end

### rev - evaluate real binomial
#
# synopsis
#   value = rev ( arg1, opr, arg2 )
#
# description
#   evaluates the expression
#          arg1 opr arg2
#
# passed
#   arg1, arg2 - real
#   opr - character, representing the operation to be performed
#
# returned
#   value - real

real function rev ( arg1, opr, arg2 )
NOIMPLICIT
real arg1, arg2
integer*4 opr

    if ( opr == '+' )
        rev = arg1 + arg2
    else if ( opr == '-' )
        rev = arg1 - arg2
    else if ( opr == '*' )
        rev = arg1 * arg2
    else if ( opr == '/' )
        rev = arg1 / arg2
    else if ( opr == '^' )
        rev = arg1 ** arg2
    else
        call error ( "  unknown operator." )

    return
end

### rpush - push a real onto the stack.
#
# synopsis
#   call rpush ( r4, ptr )
#
# description
#   pushes the real 'r4' onto the stack 'rstk' at 'ptr', and the value RL
#   onto the stack 'typstk' at 'ptr'.
#
# passed
#   r4 -  real, to be pushed onto the stack
#   ptr -  integer, assumed to be a pointer into rstk and typstk

subroutine rpush ( r4, ptr )
NOIMPLICIT
real r4
integer ptr

    include evalcomn

    if ( ptr >= STACKSIZE )
        call error ( "  stack overflow." )
    ptr = ptr + 1
    rstk ( ptr ) = r4
    typstk ( ptr ) = RL

    return
end

#-t-  evalb                      8316  ascii   05Jan84  08:03:46
#-t-  evalb.all                 11992  ascii   05Jan84  08:10:32
#-h-  bslb.all                  35966  ascii   05Jan84  08:10:35
#-h-  bslb.doc                  11244  ascii   05Jan84  08:05:50
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^bslb(2)^%^bslb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
bslb - bit-string package
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
include "bsdef"
integer bsp, bsp1, bsp2, bsp3, bitnum, bsindx, numints, bwnum
integer bitword, numbits, val, bit
integer bsvec1(MAX_BS_SIZE), bsvec2(MAX_BS_SIZE)

integer bsloopinit, bsnumbits, bsnumints
logical bsareq, bsbtnc, bsbtst, bsempty, bsequal, bsnext
logical bstestbit

call bsand( bsp1, bsp2, bsp3 )
bitarrays_are_equal = bsareq( bsvec1, bsvec2, numints )
call bsbclr( bsp, bitnum )
call bsbset( bsp, bitnum )
bit_was_set = bsbtnc( bsp, bitnum )
bit_is_set = bsbtst( bsp, bitnum )
call bscomp( bsp )
call bscopy( bsp1, bsp2 )
call bsdestroy( bsp )
bitstring_is_empty = bsempty( bsp )
call bsendloop( bsindx )
bitstrings_are_equal = bsequal( bsp1, bsp2 )
call bsgetbs( bsp1, bsvec1, numints )
call bsgetword( bsp, bwnum, bitword )
call bsinit( bsp, numbits )
call bslbinit
bsindx = bsloopinit( bsp )
call bslppos( bsindx, bitnum )
call bsmkcopy( bsp1, bsp2 )
another_element_found = bsnext( bsindx, val )
numbits = bsnumbits( bsp )
numints = bsnumints( bsp )
call bsor( bsp1, bsp2, bsp3 )
call bsputbs( bsp1, bsvec1, numints )
call bsputword( bsp, bwnum, bitword )
call bsresetbit( bitword, bit )
call bssetbit( bitword, bit )
call bsstats
bit_set = bstestbit( bitword, bit )
call bsxor( bsp1, bsp2, bsp3 )
call bszero( bsp )
BS_BITNUM_DECOMP( bitnum, bitword, bit )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
.ne 3
.sp
These routines implement a relatively fast set package based on
bit strings.  Bit strings are sets in which potential set elements have
associated with them a non-negative integer.  If the bit corresponding
to a given potential set element is set in a bit string, then the potential set
element is considered to be present in the set.  If the bit is reset, then the
potential set element is considered to not be in the set.
.ne 3
.sp
To use this package, the routine
.bd
bslbinit
must be called. 
Two types of bit strings may be used, and they
are referred to in this document as
.bd
bitstrings
and
.bd
bitarrays.
.bd
Bitstrings
are dynamic objects created by calls to
.bd
bsinit
by specifying how large a bitstring is desired (in bits). 
A "bitstring pointer" (an integer type) is returned which can
be passed to other routines in the package to do various operations
on the bitstring.
.bd
Bitarrays
are (presumably) static objects which
are declared as integer arrays.  The array can be passed to various
routines to have bit operations done on its contents.  Conversion
between these two representations is facilitated by the
.bd
bsgetbs
and
.bd
bsputbs
routines.  Bitarrays are not fully supported, and should only be
used when fast, simple operations are desired.
.ne 3
.sp
The include file
.bd
bsdef
declares the macro
.bd
BS_BITNUM_DECOMP
(see below) for use with bitarrays.
The file also contains three defines of user-interest:
.bd
BITS_IN_INTEGER
is the number of bits which can be stored in an integer value. 
.bd
MAX_BS_SIZE
is the largest size (in integer words) that a
.bd
bitstring
can be (there is no limit on the size of
.bd
bitarrays).
Arrays used in calls to
.bd
bsgetbs
and
.bd
bsputbs
should be declared to be this size.  Finally,
.bd
BS_MAX_LOOP_NESTING
is the greatest level to which bitstring loops can be nested (see
.bd
bsloopinit
below).  The file need not be included if these defines are not needed.
.ne 3
.sp
The routines and their functions:
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsand	Produces the bit-wise "and" (intersection) of bitstrings bsp1 and bsp2
in bitstring bsp3.  All bitstrings must have been previously initialized, must
be the same size,
and can all be the same bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsareq	Returns true if two bitarrays, whose size in integer words is given by
the numints parameter, are equal, false otherwise.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsbclr	Clears a bit in a bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsbset	Sets a bit in a bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsbtnc	Returns true if a specified bit is set in a bitstring, false otherwise.
In any case, the bit is reset.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsbtst	Returns true if a specified bit is set in a bitstring, false otherwise.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bscomp	Complements all the bits in a bit string (set negation).
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bscopy	Copies bitstring bsp1 into bitstring bsp2, which must have already been
initialized.  The bitstrings must contain the same number of bits.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsdestroy	Deallocates the storage for a bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsempty	Returns true if a bitstring is empty, false otherwise.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsendloop	Terminates a sorted search through a bitstring.  Used in conjunction
with
.bd
bsloopinit
and
.bd
bsnext.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsequal	Returns true if two bitstrings are equal, false otherwise.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsgetbs	Returns the bitarray representation of a given bitstring, and the
number of integer words the bitarray is in size.  Companion routine
with
.bd
bsputbs.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsgetword	Returns the specified bitword from a given bitstring.  Used in conjunction
with
.bd
BS_BITNUM_DECOMP.
Companion routine with
.bd
bsputword.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsinit	Creates a bitstring large enough to hold the specified number of bits. 
A pointer to the bitstring is returned in bsp.  The bitstring is initially
empty (all bits reset).  Enough room is allocated for bits numbered from
zero to numbits (thus, for example, if "numbits" is 10, space is allocated
for bits 0 thru 10, and the bitstring set can hold 11 distinct elements).
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bslbinit	Initializes the bit string library.  Must be called before any other
routines.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsloopinit	Prepares for a sorted loop through a bitstring.  An index is returned as
the function value.  This index is repeatedly passed to
.bd
bsnext
to return the bit positions of set bits in the bitstring, from the lowest
numbered bit to the highest, starting with bit 0.  Loops should be terminated
by calls to
.bd
bsendloop
with the index as argument.  Up to BS_MAX_LOOP_NESTING bitstring loops
may be active at one time.  The loops needn't be nested (i.e. calls
to
.bd
bsnext
may be made with different indices interspersed), but optimal speed
results when bitstring loops are nested.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bslppos	Sets a bit position for the next call to
.bd
bsnext
to begin at.  For example,
.sp
.nf
.in +4
call bslppos( setindx, 24 )
.sp
.fi
.in -4
would set things up so that the next time "setindx" was passed in a
call to
.bd
bsnext,
the routine would begin searching for a set bit starting with bit
24.  If bit 24 was reset, it would then test bit 25, 26, ...  If
all subsequent bits were reset,
.bd
bsnext
would fail (return false).  It would
.ul
not
search bits numbered lower than 24.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsmkcopy	Creates a copy of a bitstring.  bsp2 should
.ul
not
already be initalized.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsnext	Returns in val the position of the next bit set in the bitstring associated
with bsindx by a previous call to
.bd
bsloopinit.
Returns true if there was another set bit, false otherwise.  For example,
.sp
.nf
.in +4
for ( i = bsloopinit( dataset );
      bsnext( i, dataval ); )
    call printf( "%d@n", dataval )
.sp
.fi
.in -4
will write out, in increasing order, the numbers of all the elements in dataset.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsnumbits	Returns the number of bits allocated in a bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsnumints	Returns the number of integer words allocated for storage of a bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsor	Produces the bit-wise "or" (union) of bitstrings bsp1 and bsp2 in
bitstring bsp3.  All bitstrings must have already been initialized, must
be the same size, and
they can all be physically the same bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsputbs	Assigns bitstring bsp1 to the corresponding bitarray bsvec1, which
contains numints integer words.  No error checking is done to see if
the bitarray is too large.  Companion routine with
.bd
bsgetbs.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsputword	Assigns a given bitword in the specified bitstring to the integer passed.
Used in conjunction with
.bd
BS_BITNUM_DECOMP.
Companion routine with
.bd
bsgetword.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsresetbit	Resets a specified bit of a given bitword.  Used in conjunction with
.bd
BS_BITNUM_DECOMP.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bssetbit	Sets a specified bit of a given bitword.  Used in conjunction with
.bd
BS_BITNUM_DECOMP.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsstats	Writes bitstring usage statistics to error output.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bstestbit	Returns true if a specified bit of a given bitword is set, false otherwise.
Used in conjunction with
.bd
BS_BITNUM_DECOMP.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bsxor	Produces the bit-wise "exclusive or" of bitstrings bsp1 and bsp2 in
bitstring bsp3.  All three bitstrings must have previously been initialized,
must be the same size,
and can be the same physical bitstring.
.in -13
.ne 3
.sp
.in +13
.ta 13
.ti -13
bszero	Resets all the bits in a given bitstring.
.in -13
.ne 3
.sp
BS_BITNUM_DECOMP is a macro which takes as an argument an integer representing
a bit position in a bitarray.  It assigns to its second argument the word
number (starting at zero)
in which that bit position would be found in the bitarray, and it
assigns to its third argument the bit number corresponding to where the
bit position would be found in the bit word.  For example, if
.sp
.nf
.in +4
BS_BITNUM_DECOMP( 37, bitword, bit )
.sp
.fi
.in -4
assigned bitword = 2 and bit = 5, then the 37th bit position of any
bitarray would be the 5th bit of the bitword #2 (remember that bitwords
are numbered starting at zero).
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
quelb(2)
.sp
.ne 2
.fi
.ti -5
DIAGNOSTICS
.br
.bd
"error in memget", "error in memput", etc.
usually means that a routine was passed a bitstring pointer which was
not initialized.
.ne 3
.sp
.bd
"loops nested too deeply"
usually means that you forgot to call
.bd
bsendloop
at the termination of a bitstring search.
.ne 3
.sp
.bd
"bit number out of range"
means that an attempt was made to reference a bit position in a bitstring
which was beyond the upper limit established when the bitstring was initialized
by
.bd
bsinit.
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Vern Paxson
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
Bitstrings may have at most 5000 elements.
.ne 3
.sp
Most operations (e.g. bit-wise "and") are available only for bitstrings,
and not bitarrays.
.ne 3
.sp
Little or no error-checking is done in the low-level routines.
.ne 3
.sp
The library relies on intrinsic Fortran functions "iand", "not",
"ishft", "ior", and "ieor", and thus is quite non-portable.

#-t-  bslb.doc                  11244  ascii   05Jan84  08:05:50
#-h-  bslb.inc                   4874  ascii   05Jan84  08:05:55
#-h-  memsym                     1879  ascii   05Jan84  08:05:24
## memsym - symbols definitions for memory allocation
#nolist

# revision history
#
# 01e 08Nov83 mam .Removed the data types(word,pointer).
# 01d 12jul83 jc  .Ratfixed
# 01c 09aug82 th  .Changed INSUFFICIENTMEMORY to 0 on the vax
#                  (this is what an uninitialized variable is likely to have
#                  in it)
#                 .Added definitions for PDP_10
# 01b 05Nov81 cal .Added revision history and turned off listing

# portability note:
#   dmlb.t assumes that the minimum unit is a character,
#   and that all the 'MEMWORD', ...., definitions are in terms of
#   characters

ifdef (VAX)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,4)
    define(MEMINTEGER,4)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,4)
    define(MEMREAL,4)
    define(MEMDOUBLEPRECISION,8)
    define(MEMCOMPLEX,8)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef
ifdef (MODCOMP)
  
  
    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,1)
    define(MEMREAL,2)
    define(MEMDOUBLEPRECISION,4)
    define(MEMCOMPLEX,4)
  
    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,-1)

enddef
ifdef (PDP_10)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)

    # MEMCHARACTER could probably be -7 except for rat4sym, which
    # tries to store things larger than seven bits in a character.
    define(MEMCHARACTER,1)

    define(MEMLOGICAL,1)
    define(MEMREAL,1)
    define(MEMDOUBLEPRECISION,2)
    define(MEMCOMPLEX,2)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef

#list
#-t-  memsym                     1879  ascii   05Jan84  08:05:24
#-h-  bsdef                      1107  ascii   05Jan84  08:05:25
# bsdef - defines for bslb
#nolist

define(BS_NUMBITS_OFFSET,1)
define(BS_NUMINTS_OFFSET,2)	# number of integer words in bit string
define(BS_BITS_OFFSET,3)
define(BS_EXTRASIZE,2)

define(BS_MAX_LOOP_NESTING,10)

ifdef(VAX)
	define(BITS_IN_INTEGER,32)
	define(BS_NIL,0)  # not a possible value returned from memalloc
enddef

ifdef(MODCOMP)
	define(BITS_IN_INTEGER,16)
	define(BS_NIL,-1)
enddef

ifdef(PDP10)
	define(BITS_IN_INTEGER,36)
	define(BS_NIL,0)
enddef

# maximum number of integer words in bit string; enough for 5000 bits
define(MAX_BS_SIZE,arith(arith(5000,/,BITS_IN_INTEGER),+,1))

# must include "bscom" and call bslbinit to use the following macro
define(BS_WORD_FROM_BITPOS,bwmap(($1)+1)) # generates a bitword with bit $1 set

# must include "bscom" to use the following macro
# if the passed argument corresponds to the cache, invalidate the cache
define(BS_STOP_CACHE,{
	if ( curlvl != 0 )
	    if ( bsptr(curlvl) == $1 )
	        cacheinvalid = .true.
	})

define(BS_BITNUM_DECOMP,{
	$2 = ($1) / BITS_IN_INTEGER
	$3 = mod($1,BITS_IN_INTEGER)
	})	# returns bitword and bit positions
#list
#-t-  bsdef                      1107  ascii   05Jan84  08:05:25
#-h-  bscom                      1498  ascii   05Jan84  08:05:26
# bscom - common data for bslb
#nolist

# many of the following variables are used for looping through bitstrings.
# The structures are somewhat non-trivial because nested bitstring loops
# are allowed.  Each array is indexed by a value given to the user by a
# call to bsloopinit( bsp ).

integer loopnumbits(BS_MAX_LOOP_NESTING)	# number of bits in bitstring
integer loopnints(BS_MAX_LOOP_NESTING)	# number of integer words in bitstring
integer bsptr(BS_MAX_LOOP_NESTING)	# pointer to bitstring
integer bitindx(BS_MAX_LOOP_NESTING)	# last bit position examined in
					# bitstring
integer posindx(BS_MAX_LOOP_NESTING)	# last bit position examined in bitword
integer wordindx(BS_MAX_LOOP_NESTING)	# last bitword examined

integer looplvl		# the highest loop index yet allocated; kept around
			# only for error checking

integer curlvl		# the current loop index (i.e. the loop index whose
			# bitstring currently resides in bs1)

logical cacheinvalid	# if true, bs1 is invalid

integer bs1(MAX_BS_SIZE)	# cache for bitstring currently being loop
				# through

integer bwmap(BITS_IN_INTEGER)	# indexed by bit position; converts a bit
				# position to a bitword (e.g. bwmap(4) = 8,
				# bwmap(5) = 16)

integer ialloc	# number of integer words allocated for bitstring storage
integer bsalloc	# number of bitstrings allocated

common /bscom/ loopnumbits, loopnints, bsptr, bitindx,
               posindx, wordindx, looplvl, curlvl, cacheinvalid, bs1,
               bwmap, ialloc, bsalloc
#list
#-t-  bscom                      1498  ascii   05Jan84  08:05:26
#-t-  bslb.inc                   4874  ascii   05Jan84  08:05:55
#-h-  bslb                      19458  ascii   05Jan84  08:05:58
###############################################################################
#
#                                  B S L B
#
#                           A bit-string package.
#
###############################################################################
#
# version date initials remarks
# ------- ---- -------- -------------------------------------------------------
#
#   01a  03sep82  vp    written
#

ifdef(VAX)
    define(NOIMPLICIT,implicit none)
enddef

ifnotdef(VAX)
    define(NOIMPLICIT,)
enddef

include memsym
include "bsdef"


### bsand - "and" two bit strings into a third bit string
#
#  SYNOPSIS
#    integer bsp1, bsp2, bsp3
#    call bsand( bsp1, bsp2, bsp3 )
#
#  NOTE
#    This routine assumes that bsp3 IS initialized.
#    bsp1, bsp2, and bsp3 can all be the same bitstring
#
subroutine bsand( bsp1, bsp2, bsp3 )
NOIMPLICIT
integer bsp1, bsp2, bsp3

    integer num1bits, num2bits, num3bits, bsnumbits, numints
    integer bsvec1(MAX_BS_SIZE), bsvec2(MAX_BS_SIZE)
    integer i

    num1bits = bsnumbits( bsp1 )
    num2bits = bsnumbits( bsp2 )
    num3bits = bsnumbits( bsp3 )

    if ( num1bits != num2bits )
	call error( "bsand: the two source bit strings are not _
		     the same length" )

    if ( num1bits != num3bits )
	call error( "bsand: destination string is not the same _
		     length as the sources" )

    call bsgetbs( bsp1, bsvec1, numints )
    call bsgetbs( bsp2, bsvec2, numints )

    for ( i=1; i <= numints; i=i+1 )
	call bsputword( bsp3, i-1, iand(bsvec1(i), bsvec2(i)) )
    return
end


### bsareq - returns true if two bitstring arrays are identical
#
#  SYNOPSIS
#    integer bsvec1, bsvec2, numints
#    logical bitstringsareequal, bsareq
#    bitstringsareequal = bsareq( bsvec1, bsvec2, numints )
#
#  DESCRIPTION
#    the bitstrings are compared on a bitword by bitword basis
#
logical function bsareq( bsvec1, bsvec2, numints )
NOIMPLICIT
integer bsvec1(ARB), bsvec2(ARB), numints

    integer i

    bsareq = .false.

    for ( i=1; i <= numints; i=i+1 )
	if ( bsvec1(i) != bsvec2(i) )
	    return

    bsareq = .true.
    return
end


### bsbclr - clear a bit in a bit string
#
#  SYNOPSIS
#    integer bsp, bitnum
#    call bsbclr( bsp, bitnum )
#
subroutine bsbclr( bsp, bitnum )
NOIMPLICIT
integer bsp, bitnum, bwnum, bit, bitword

    integer bsnumbits

    if ( bitnum < 0 | bitnum > bsnumbits( bsp ) )
	call error( "bsbclr: bit number out of range" )

    BS_BITNUM_DECOMP( bitnum, bwnum, bit )

    call bsgetword( bsp, bwnum, bitword )
    call bsresetbit( bitword, bit )
    call bsputword( bsp, bwnum, bitword )

    return
end


### bsbset - set a bit in a bit string
#
#  SYNOPSIS
#    integer bsp, bitnum
#    call bsbset( bsp, bitnum )
#
subroutine bsbset( bsp, bitnum )
NOIMPLICIT
integer bsp, bitnum, bwnum, bit, bitword

    integer bsnumbits

    if ( bitnum < 0 | bitnum > bsnumbits( bsp ) )
	call error( "bsbset: bit number out of range" )

    BS_BITNUM_DECOMP( bitnum, bwnum, bit )

    call bsgetword( bsp, bwnum, bitword )
    call bssetbit( bitword, bit )
    call bsputword( bsp, bwnum, bitword )

    return
end


### bsbtnc - test 'n clear a bit in a bitstring
#
#  SYNOPSIS
#    integer bsp, bitnum
#    logical bsbtnc
#    bitwasset = bsbtnc( bsp, bitnum )
#
logical function bsbtnc( bsp, bitnum )
NOIMPLICIT
integer bsp, bitnum, bwnum, bit, bitword

    integer bsnumbits
    logical bstestbit

    if ( bitnum < 0 | bitnum > bsnumbits( bsp ) )
	call error( "bsbtnc: bit number out of range" )

    BS_BITNUM_DECOMP( bitnum, bwnum, bit )

    call bsgetword( bsp, bwnum, bitword )
    bsbtnc = bstestbit( bitword, bit )
    call bsresetbit( bitword, bit )
    call bsputword( bsp, bwnum, bitword )

    return
end


### bsbtst - test a bit in a bit string
#
#  SYNOPSIS
#    logical bit, bsbtst
#    integer bsp, bitnum
#    bit = bsbtst( bsp, bitnum )
#
logical function bsbtst( bsp, bitnum )
NOIMPLICIT
integer bsp, bitnum, bwnum, bit, bitword

    integer bsnumbits
    logical bstestbit

    if ( bitnum < 0 | bitnum > bsnumbits( bsp ) )
	call error( "bsbtst: bit number out of range" )

    BS_BITNUM_DECOMP( bitnum, bwnum, bit )

    call bsgetword( bsp, bwnum, bitword )
    return ( bstestbit( bitword, bit ) )
end


### bscomp - complement all the bits in a bit string
#
#  SYNOPSIS
#    integer bsp
#    call bscomp( bsp )
#
subroutine bscomp( bsp )
NOIMPLICIT
integer bsp

    integer numints, i, bsvec(MAX_BS_SIZE)

    call bsgetbs( bsp, bsvec, numints )

    for ( i=1; i <= numints; i=i+1 )
	bsvec(i) = not(bsvec(i))

    call bsputbs( bsp, bsvec, numints )
    return
end


### bscopy - copy a bit string to an existing bit string
#
#  SYNOPSIS
#    integer bspsrc, bspdest
#    call bscopy( bspsrc, bspdest )
#
#  DESCRIPTION
#    This routine assumes that bspdest IS initialized.
#
subroutine bscopy( bspsrc, bspdest )
NOIMPLICIT
integer bspsrc, bspdest

    integer numints, numbits, bsnumbits
    integer bsvec(MAX_BS_SIZE)

    numbits = bsnumbits( bspsrc )

    if ( numbits != bsnumbits( bspdest ) )
	call error( "bscopy: bit strings are not the same size" )

    call bsgetbs( bspsrc, bsvec, numints )
    call bsputbs( bspdest, bsvec, numints )

    return
end


### bsdestroy - deallocate the storage for a bit string
#
#  SYNOPSIS
#    integer bsp
#    call bsdestroy( bsp )
#
subroutine bsdestroy( bsp )
NOIMPLICIT
integer bsp

    integer memfree

    if ( memfree( bsp ) != OK )
        call error( "bsdestroy: error in memfree" )
    bsp = BS_NIL

    return
end


### bsempty - returns true if bitstring has no set elements
#
#  SYNOPSIS
#    integer bsp
#    logical bitstringisempty, bsempty
#    bitstringisempty = bsempty( bsp )
#
#  DESCRIPTION
#    the bitstring is check for any non-zero bitwords
#
logical function bsempty( bsp )
NOIMPLICIT
integer bsp, numints
integer bsvec(MAX_BS_SIZE)

    integer i

    bsempty = .false.

    call bsgetbs( bsp, bsvec, numints )

    for ( i=1; i <= numints; i=i+1 )
	if ( bsvec(i) != 0 )
	    return

    bsempty = .true.
    return
end


### bsendloop - terminate a sorted search through bitstring
#
#  SYNOPSIS
#    integer bsindx
#    call bsendloop( bsindx )
#
#  DESCRIPTION
#    reclaims the stack space needed for a sorted search through a
#    bitstring
#
subroutine bsendloop( bsindx )
NOIMPLICIT
integer bsindx
include "bscom"

    if ( bsindx == looplvl )
	looplvl = looplvl - 1

    if ( looplvl < 0 )
	call error( "bsendloop: no loops are active" )

    if ( bsindx == curlvl )
	curlvl = 0	# invalidate curlvl

    bsptr(bsindx) = BS_NIL	# invalidate the bitstring pointer slot

    return
end


### bsequal - returns true if two bitstrings are identical
#
#  SYNOPSIS
#    integer bsp1, bsp2
#    logical bitstringsareequal, bsequal
#    bitstringsareequal = bsequal( bsp1, bsp2 )
#
#  DESCRIPTION
#    the bitstrings are compared on a bitword by bitword basis
#
logical function bsequal( bsp1, bsp2 )
NOIMPLICIT
integer bsp1, bsp2, num1bits, num2bits, bsnumbits, numints
integer bsvec1(MAX_BS_SIZE), bsvec2(MAX_BS_SIZE)
logical bsareq

    integer i

    num1bits = bsnumbits( bsp1 )
    num2bits = bsnumbits( bsp2 )

    if ( num1bits != num2bits )
	return

    call bsgetbs( bsp1, bsvec1, numints )
    call bsgetbs( bsp2, bsvec2, numints )

    bsequal = bsareq( bsvec1, bsvec2, numints )
    return
end


### bsgetbs - return a bitstring in a passed array
#
#  SYNOPSIS
#    integer bsp, bsvec(size of bitstring in integer words), numints
#    call bsgetbs( bsp, bsvec, numints )
#
#  DESCRIPTION
#    Returns the bitstring indexed by bsp, and the number of integers
#  allocated for the bitstring in numints
#
subroutine bsgetbs( bsp, bsvec, numints )
NOIMPLICIT
integer bsp, bsvec(ARB), numints

    integer memget, bsnumints

    numints = bsnumints(bsp)

    if ( memget( bsp, bsvec, numints, BS_BITS_OFFSET ) != OK )
	call error( "bsgetbs: error in memget" )

    return
end


### bsgetword - return a bitword from a bitstring
#
#  SYNOPSIS
#    integer bsp, bwnum, bitword
#    call bsgetword( bsp, bwnum, bitword )
#
#  DESCRIPTION
#    gets the bwnum'th bitword from the bitstring indexed by bsp
#
subroutine bsgetword( bsp, bwnum, bitword )
NOIMPLICIT
integer bsp, bwnum, bitword

    integer memeget

    if ( memeget( bsp, bitword, BS_BITS_OFFSET + bwnum ) != OK )
	call error( "bsgetword: error in memeget" )

    return
end


### bsinit - initialize a bit string with a specified number of bits
#
#  SYNOPSIS
#    integer bsp, numbits
#    call bsinit( bsp, numbits )
#
#  NOTE
#    actually, bits number 0 - numbit are allocated
#
subroutine bsinit( bsp, numbits )
NOIMPLICIT
integer bsp, numbits, numints
include "bscom"

    integer memalloc, memeput

    numints = numbits / BITS_IN_INTEGER + 1

    if ( numints > MAX_BS_SIZE )
	call error( "bsinit: bit string too large" )

    if ( memalloc( bsp, BS_EXTRASIZE+numints, MEMINTEGER ) != OK )
	call error( "bsinit: insufficient memory" )
    else
	{
	ialloc = ialloc + numints
	bsalloc = bsalloc + 1

	if ( memeput( bsp, numbits, BS_NUMBITS_OFFSET ) != OK )
	    call error( "bsinit: error in memeput" )
	if ( memeput( bsp, numints, BS_NUMINTS_OFFSET ) != OK )
	    call error( "bsinit: error in memeput" )
	call bszero( bsp )
	}

    return
end


### bslbinit - initialize bit string library
#
#  SYNOPSIS
#    call bslbinit
#
subroutine bslbinit
NOIMPLICIT
integer i, j
include "bscom"

    for ( i=1; i <= BS_MAX_LOOP_NESTING; i=i+1 )
	bsptr(i) = BS_NIL

    j = 1

    for ( i=1; i <= BITS_IN_INTEGER; i=i+1 )
	{
	bwmap(i) = j
	j = ishft(j,1)
	}

    ialloc = 0
    bsalloc = 0

    looplvl = 0
    curlvl = 0
    cacheinvalid = .true.
    return
end


### bsloopinit - prepare for sorted loop through bit string
#
#  SYNOPSIS
#    integer bsp, bsindx, bsloopinit
#    bsindx = bsloopinit( bsp )
#
#  DESCRIPTION
#    Returns an index which can be later passed to calls to bsnext
#  in order to retrieve bit strings elements one at a time in sorted
#  order.
#
#  NOTE
#    Bitstring loops can be nested BS_MAX_LOOP_NESTING levels
#
integer function bsloopinit( bsp )
NOIMPLICIT
integer bsp, bsnumbits, numints, bsnumints, bsindx
include "bscom"

    for ( bsindx=1; bsptr(bsindx) != BS_NIL & bsindx <= looplvl;
	  bsindx=bsindx+1 )
	;

    if ( bsindx > looplvl )
	{
	looplvl = looplvl + 1

	if ( looplvl > BS_MAX_LOOP_NESTING )
	    call error( "bsloopinit: loops nested too deeply" )

	bsindx = looplvl
	}

    loopnumbits(bsindx) = bsnumbits( bsp )
    loopnints(bsindx) = bsnumints( bsp )

    bsptr(bsindx) = bsp

    call bslppos( bsindx, 0 )	# so when bsnext increments the bit index the
				# first time, it will correspond to bit
				# zero of the bitstring

    return ( bsindx )

end


### bslppos - set bit position for next bsnext to start at
#
#  SYNOPSIS
#    integer bsindx, bitpos
#    call bslppos( bsindx, bitpos )
#
#  DESCRIPTION
#    modifies the common data kept for the bitstring indexed by bsindx
#  so that the next call to bsnext will begin with the `bitpos'th bit
#  rather than the bit after the bit returned by the last call to bsnext.
#
subroutine bslppos( bsindx, bitpos )
NOIMPLICIT
integer bsindx, bitpos
include "bscom"

    bitindx(bsindx) = bitpos
    BS_BITNUM_DECOMP( bitpos, wordindx(bsindx), posindx(bsindx) )

    BS_STOP_CACHE( bsptr(bsindx) )	# need to stop the cache because
				# repositioning might back up over elements
				# in the cache which have been zeroed
    return
end


### bsmkcopy - make a copy of a bit string
#
#  SYNOPSIS
#    integer oldbsp, newbsp
#    call bsmkcopy( oldbsp, newbsp )
#
#  DESCRIPTION
#    This routine assumes that newbsp is NOT initialized.
#
subroutine bsmkcopy( oldbsp, newbsp )
NOIMPLICIT
integer oldbsp, newbsp

    integer numints, numbits, bsnumbits
    integer bsvec(MAX_BS_SIZE)

    numbits = bsnumbits( oldbsp )
    call bsgetbs( oldbsp, bsvec, numints )

    call bsinit( newbsp, numbits )

    call bsputbs( newbsp, bsvec, numints )

    return
end


### bsnext - get next element in sorted search through bitstring
#
#  SYNOPSIS
#    integer bsindx, val
#    logical bsnext, anotherelement
#    anotherelement = bsnext( bsindx, val )
#
#  DESCRIPTION
#    The bitstring to be searched is stored in a common array.  bsnext
#    scans through the array starting at bitindx(bsindx) and returns the
#    bit number of the next set bit it encounters.  Subsequent calls
#    return increasing bit numbers.
#
logical function bsnext( bsindx, val )
NOIMPLICIT
integer bsindx, val, bitword, bitpos, bitnum, wordnum, numbits
logical bstestbit
include "bscom"

    integer memget

    bsnext = .false.

    if ( curlvl != bsindx  |  cacheinvalid )
	{ # cache the bitstring
	if ( memget( bsptr(bsindx), bs1, loopnints(bsindx),
	              BS_BITS_OFFSET ) != OK )
	    call error( "bsnext: error in memget" )
	curlvl = bsindx
	cacheinvalid = .false.
	}

    # get array elements in local variables to cut down on time
    # spent indexing

    numbits = loopnumbits(curlvl)	# number of bits in bitstring
    wordnum = wordindx(curlvl)	# number of bitword we are looking at
    bitnum = bitindx(curlvl)	# number of bit in bitstring
    bitpos = posindx(curlvl)	# number of bit in bitword

    for ( ; bitnum <= numbits; wordnum=wordnum+1 )
	{
	bitword = bs1(wordnum+1)

	if ( bitword != 0 )
	    {
	    for ( ; bitpos < BITS_IN_INTEGER; bitpos=bitpos+1 )
		{
		if ( bstestbit( bitword, bitpos ) )
		    { # found a set bit
		    val = bitnum
		    bsnext = .true.

		    # clear it out of the local copy
		    call bsresetbit( bs1(wordnum+1), bitpos )

		    break 2
		    }
		bitnum = bitnum + 1
		}
	    }

	else
	    bitnum = bitnum + BITS_IN_INTEGER - bitpos

	bitpos = 0
	}

    wordindx(curlvl) = wordnum
    posindx(curlvl) = bitpos + 1  # we don't need to check for boundary
				  # conditions because the loop's structure
				  # takes care of them
    bitindx(curlvl) = bitnum + 1

    return
end


### bsnumbits - return the number of bits allocated in a bitstring
#
#  SYNOPSIS
#    integer numbits, bsnumbits, bsp
#    numbits = bsnumbits( bsp )
#
integer function bsnumbits( bsp )
NOIMPLICIT
integer bsp

    integer numbits, memeget

    if ( memeget( bsp, numbits, BS_NUMBITS_OFFSET ) != OK )
        call error( "bsnumbits: error in memeget" )
    bsnumbits = numbits

    return
end


### bsnumints - return the number of integer words allocated for a bitstring
#
#  SYNOPSIS
#    integer numints, bsnumints, bsp
#    numints = bsnumints( bsp )
#
integer function bsnumints( bsp )
NOIMPLICIT
integer bsp

    integer numints, memeget

    if ( memeget( bsp, numints, BS_NUMINTS_OFFSET ) != OK )
        call error( "bsnumints: error in memeget" )
    bsnumints = numints

    return
end


### bsor - "or" two bit strings into a third bit string
#
#  SYNOPSIS
#    integer bsp1, bsp2, bsp3
#    call bsor( bsp1, bsp2, bsp3 )
#
#  NOTE
#    This routine assumes that bsp3 IS initialized.
#    bsp1, bsp2, and bsp3 can all be the same bitstring
#
subroutine bsor( bsp1, bsp2, bsp3 )
NOIMPLICIT
integer bsp1, bsp2, bsp3

    integer num1bits, num2bits, num3bits, bsnumbits, numints
    integer bsvec1(MAX_BS_SIZE), bsvec2(MAX_BS_SIZE)
    integer i

    num1bits = bsnumbits( bsp1 )
    num2bits = bsnumbits( bsp2 )
    num3bits = bsnumbits( bsp3 )

    if ( num1bits != num2bits )
	call error( "bsor: the two source bit strings _
		     are not the same length" )

    if ( num1bits != num3bits )
	call error( "bsor: destination string is not the _
		     same length as the sources" )

    call bsgetbs( bsp1, bsvec1, numints )
    call bsgetbs( bsp2, bsvec2, numints )

    for ( i=1; i <= numints; i=i+1 )
	call bsputword( bsp3, i-1, ior(bsvec1(i), bsvec2(i)) )
    return
end


### bsputbs - modify a bitstring to passed array
#
#  SYNOPSIS
#    integer bsp, bsvec(size of bitstring in integer words), numints
#    call bsputbs( bsp, bsvec, numints )
#
#  DESCRIPTION
#    copies numints words from bsvec into the bitstring indexed by bsp
#
subroutine bsputbs( bsp, bsvec, numints )
NOIMPLICIT
integer bsp, bsvec(ARB), numints
include "bscom"

    integer memput

    if ( memput( bsp, bsvec, numints, BS_BITS_OFFSET ) != OK )
	call error( "bsputbs: error in memput" )

    BS_STOP_CACHE( bsp )
    return
end


### bsputword - set a bitword in a bitstring
#
#  SYNOPSIS
#    integer bsp, bwnum, bitword
#    call bsputword( bsp, bwnum, bitword )
#
#  DESCRIPTION
#    sets the bwnum'th bitword in the bitstring indexed by bsp to bitword
#
subroutine bsputword( bsp, bwnum, bitword )
NOIMPLICIT
integer bsp, bwnum, bitword
include "bscom"

    integer memeput

    if ( memeput( bsp, bitword, BS_BITS_OFFSET + bwnum ) != OK )
	call error( "bsputword: error in memeput" )

    BS_STOP_CACHE( bsp )
    return
end


### bsresetbit - reset a given bit of a given bitword
#
#  SYNOPSIS
#    integer bitword, bit
#    call bsresetbit( bitword, bit )
#
subroutine bsresetbit( bitword, bit )
NOIMPLICIT
integer bitword, bit, tbit
include "bscom"

    tbit = BS_WORD_FROM_BITPOS( bit )

    bitword = iand(bitword, not(tbit))
    return
end


### bssetbit - set a given bit of a given bitword
#
#  SYNOPSIS
#    integer bitword, bit
#    call bssetbit( bitword, bit )
#
subroutine bssetbit( bitword, bit )
NOIMPLICIT
integer bitword, bit, tbit
include "bscom"

    tbit = BS_WORD_FROM_BITPOS( bit )

    bitword = ior(bitword, tbit)
    return
end


### bsstats - dumps bitstring usage statistics
#
#  SYNOPSIS
#    call bsstats
#
subroutine bsstats
NOIMPLICIT
include "bscom"

    call remark( "Bitstring usage statistics:" )
    call fprintf( ERROUT, "  bit strings allocated: %d@n", bsalloc )
    call fprintf( ERROUT, "  integer words allocated for string storage: %d@n",
		  ialloc )
    return
end


### bstestbit - returns .true. if a given bit is set in a given bitword, 
#               .false. if not
#
#  SYNOPSIS
#    integer bitword, bit
#    logical bitisset, testbit
#    bitisset = testbit( bitword, bit )
#
logical function bstestbit( bitword, bit )
NOIMPLICIT
integer bitword, bit, tbit
include "bscom"

    tbit = BS_WORD_FROM_BITPOS( bit )

    if( iand(bitword, tbit) == tbit )
	return ( .true. )
    else
	return ( .false. )
end


### bsxor - "xor" two bit strings into a third bit string
#
#  SYNOPSIS
#    integer bsp1, bsp2, bsp3
#    call bsxor( bsp1, bsp2, bsp3 )
#
#  NOTE
#    This routine assumes that bsp3 IS initialized.
#    bsp1, bsp2, and bsp3 can all be the same bitstring
#
subroutine bsxor( bsp1, bsp2, bsp3 )
NOIMPLICIT
integer bsp1, bsp2, bsp3

    integer num1bits, num2bits, num3bits, bsnumbits, numints
    integer bsvec1(MAX_BS_SIZE), bsvec2(MAX_BS_SIZE)
    integer i

    num1bits = bsnumbits( bsp1 )
    num2bits = bsnumbits( bsp2 )
    num3bits = bsnumbits( bsp3 )

    if ( num1bits != num2bits )
	call error( "bsxor: the two source bit strings _
		     are not the same length" )

    if ( num1bits != num3bits )
	call error( "bsxor: destination string is not the _
		     same length as the sources" )

    call bsgetbs( bsp1, bsvec1, numints )
    call bsgetbs( bsp2, bsvec2, numints )

    for ( i=1; i <= numints; i=i+1 )
	call bsputword( bsp3, i-1, ieor(bsvec1(i), bsvec2(i)) )
    return
end


### bszero - zero all the bits in a bit string
#
#  SYNOPSIS
#    integer bsp
#    call bszero( bsp )
#
subroutine bszero( bsp )
NOIMPLICIT
integer bsp

    integer numints, i, bsvec(MAX_BS_SIZE)

    call bsgetbs( bsp, bsvec, numints )

    for ( i=1; i <= numints; i=i+1 )
	bsvec(i) = 0

    call bsputbs( bsp, bsvec, numints )
    return
end
#-t-  bslb                      19458  ascii   05Jan84  08:05:58
#-t-  bslb.all                  35966  ascii   05Jan84  08:10:35
#-h-  quelb.all                 26027  ascii   05Jan84  08:10:39
#-h-  quelb.doc                  7155  ascii   05Jan84  08:07:56
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^quelb(2)^%^quelb(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
quelb - integer queue and stack library
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
    integer qp, int, qlp, sp
    logical isempty, queempty, another, quenext, stkempty
    integer quefremove, quebremove, quefront, queback, queloopinit
    integer stkpop, stktop

    call queinit ( qp )
    call queclear ( qp )
    call quedestroy ( qp )
    isempty = queempty ( qp )
    call quefinsert ( qp, int )
    call quebinsert ( qp, int )
    int = quefremove ( qp )
    int = quebremove ( qp )
    int = quefront ( qp )
    int = queback ( qp )
    qlp = queloopinit ( qp )
    another = quenext ( qlp, int )

    call stkinit ( sp )
    call stkclear ( sp )
    call stkdestroy ( sp )
    isempty = stkempty ( sp )
    call stkpush ( sp, int )
    int = stkpop ( sp )
    int = stktop ( sp )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
.ne 3
.sp
These routines implement a simple double-ended queue package.
A double-ended queue is a sequence of items.
Only the items on the two ends can be examined or modified.
.ne 3
.sp
In this package, the items stored are integers.
If you want to store other types of items in a queue, you can store
pointers to them, since pointers are integers.
.ne 3
.sp
.in +12
.ta 12
.ti -12
queinit	initialize a queue.
This routine creates a new, empty queue, and gives you a pointer to it.
The pointer is used by all of the other queue routines.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
queclear	clear a queue.
This routine removes all of the integers from a queue and throws them away.
The queue still exists, but it is empty.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quedestroy	deallocate the storage for a queue.
This routine not only removes all of the integers from a queue, it also
destroys the queue itself and sets the pointer you passed it to NIL.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
queempty	tell whether a queue is empty or not.
If the queue has any integers in it, queempty returns .false.;
if there are no integers, it returns .true..
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quefinsert	insert an integer onto the front of a queue.
You pass this routine a queue pointer and an integer, and it places
the integer on the front end of the queue.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quebinsert	insert an integer onto the back of a queue.
You pass this routine a queue pointer and an integer, and it places
the integer on the back end of the queue.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quefremove	remove an integer from the front of a queue.
This routine gets the integer on the front end of a queue, removes it,
and returns it to the caller.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quebremove	remove an integer from the back of a queue.
This routine gets the integer on the back end of a queue, removes it,
and returns it to the caller.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quefront	examine the integer on the front of a queue without disturbing it.
This routine gets the integer on the front end of a queue and returns
it to the caller.
The integer is NOT removed.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
queback	examine the integer on the back of a queue without disturbing it.
This routine gets the integer on the back end of a queue and returns
it to the caller.
The integer is NOT removed.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
queloopinit	prepare for a loop through the elements of a queue.
This routine is used to initialize a for-loop through the
elements of a queue.
quenext is used to do the actual looping.
.in -12
.ne 3
.sp
.in +12
.ta 12
.ti -12
quenext	generate the next element in a queue loop.
This routine is used to get the next element in a loop through the elements
of a queue.
The loop pointer must have been initialized by queloopinit.
If there is another element, quenext gets it and returns .true.;
if there are no more elements, quenext returns .false.
The intended use of queloopinit and quenext is:
.sp
.nf
.in +4
for(qlp=queloopinit(qp);quenext(qlp,int);)
    { ... }
.sp
.fi
.in -4
.in -12
.ne 3
.sp
In addition to the queue routines, there are the following routines
to manipulate stacks.
A stack is a restricted queue - only the item on the top
can be examined or modified.
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkinit	initialize a stack.
This routine creates a new, empty stack, and gives you a pointer to it.
The pointer is used by all of the other stack routines.
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkclear	clear a stack.
This routine removes all of the integers from a stack and throws them away.
The stack still exists, but it is empty.
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkdestroy	deallocate the storage for a stack.
This routine not only removes all of the integers from a stack, it also
destroys the stack itself and sets the pointer you passed it to NIL.
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkempty	tell whether a stack is empty or not.
If the stack has any integers in it, stkempty returns .false.;
if there are no integers, it returns .true..
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkpush	push an integer onto a stack.
You pass this routine a stack pointer and an integer, and it places
the integer on the top of the stack.
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stkpop	pop an integer off of a stack.
This routine gets the integer on the top of a stack, removes it,
and returns it to the caller.
.in -11
.ne 3
.sp
.in +11
.ta 11
.ti -11
stktop	return the value on top of a stack without popping it.
This routine gets the integer on the top of a stack and returns
it to the caller.  The integer is NOT popped.
.in -11
.ne 3
.sp
Quelb also has an optional statistics-gathering feature.
It keeps a count of the number of queue headers and nodes allocated
and freed.
If you suspect your program is forgetting to free some of its
queues, and therefore running out of memory, this feature can
be very useful.
.ne 3
.sp
The statistics-gathering code is conditionally-compiled out
of the installed quelb.  To use it, copy the source of quelb into
your space, change the definition of STATISTICS from NO to YES, and
compile it.
Then add a call to questats to your program where you want the
statistics printed.
They will be written to ERROUT.
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Jef Poskanzer
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
.ne 3
.sp
The usage statistics code is slightly non-portable.
It assumes a local variable is static.
.sp
.ne 2
.fi
.ti -5
DIAGNOSTICS
.br
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
insufficient memory.
The dynamic memory allocation routine (memalloc) failed.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
non-existant queue.
The queue pointer that you passed to the routines did not in fact
point to a queue.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
internal error - inconsistant queue detected.
This should never happen.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
attempt to remove item from empty queue.
The queue that you tried to remove an item from was empty.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
attempt to get item from empty queue.
The queue that you tried to look at an end of was empty.

#-t-  quelb.doc                  7155  ascii   05Jan84  08:07:56
#-h-  quelb.inc                  2393  ascii   05Jan84  08:07:57
#-h-  memsym                     1879  ascii   05Jan84  08:07:43
## memsym - symbols definitions for memory allocation
#nolist

# revision history
#
# 01e 08Nov83 mam .Removed the data types(word,pointer).
# 01d 12jul83 jc  .Ratfixed
# 01c 09aug82 th  .Changed INSUFFICIENTMEMORY to 0 on the vax
#                  (this is what an uninitialized variable is likely to have
#                  in it)
#                 .Added definitions for PDP_10
# 01b 05Nov81 cal .Added revision history and turned off listing

# portability note:
#   dmlb.t assumes that the minimum unit is a character,
#   and that all the 'MEMWORD', ...., definitions are in terms of
#   characters

ifdef (VAX)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,4)
    define(MEMINTEGER,4)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,4)
    define(MEMREAL,4)
    define(MEMDOUBLEPRECISION,8)
    define(MEMCOMPLEX,8)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef
ifdef (MODCOMP)
  
  
    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)
    define(MEMCHARACTER,1)
    define(MEMLOGICAL,1)
    define(MEMREAL,2)
    define(MEMDOUBLEPRECISION,4)
    define(MEMCOMPLEX,4)
  
    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,-1)

enddef
ifdef (PDP_10)


    # these are defined as the number of 'words' in the given item
    define(MEMWORD,1)
    define(MEMPOINTER,1)
    define(MEMINTEGER,1)

    # MEMCHARACTER could probably be -7 except for rat4sym, which
    # tries to store things larger than seven bits in a character.
    define(MEMCHARACTER,1)

    define(MEMLOGICAL,1)
    define(MEMREAL,1)
    define(MEMDOUBLEPRECISION,2)
    define(MEMCOMPLEX,2)

    # returned if there is not enough memory
    define(INSUFFICIENTMEMORY,0)

enddef

#list
#-t-  memsym                     1879  ascii   05Jan84  08:07:43
#-h-  quelb.c                     254  ascii   05Jan84  08:07:44
   # common block for quelb

    integer head(HEAD_SIZE), node(NODE_SIZE)
    common /quecom/ head, node

ifdef (STATISTICS)
    integer cheadalloc, cheadfree, cnodealloc, cnodefree
    common /quecnt/ cheadalloc, cheadfree, cnodealloc, cnodefree
enddef
#-t-  quelb.c                     254  ascii   05Jan84  08:07:44
#-t-  quelb.inc                  2393  ascii   05Jan84  08:07:57
#-h-  quelb                     16089  ascii   05Jan84  08:07:58
###############################################################################
#
#                                Q U E L B
#
#                   An integer double-ended queue package.
#
###############################################################################
#
# version date initials remarks
# ------- ---- -------- -------------------------------------------------------
#   04B  13Jul83  cal   Restored from the January Vax savtools backup tape.
#                       Ratfixed.
#   04A  16jun82  JP    Changed name from dqlb to quelb.
#                       Included stklb.
#                       Speeded up by consolidating memegets and memeputs
#                         into memgets and memputs.
#                       Added queloopinit and quenext.
#                       Added optional statistics keeping.
#
#   03A  10may82  tab   changed all routines which call the new dynamic memory
#                       routines to check status and return ERR or call error.
#
#   02B  05apr82  JP    Changed name from idqlb to dqlb.
#
#   02A  07jan82  JP    Removed status returns.  They turned out to be
#			  counterproductive.
#
#   01A  30sep81  JP    First written.
#        through
#        01oct81
#
###############################################################################

include "memsym"

#define(STATISTICS,)		# uncomment if you want usage statistics

define(NIL,INSUFFICIENTMEMORY)

define(HEAD_FRONT_POINTER_OFFSET,1)
define(HEAD_BACK_POINTER_OFFSET,2)
define(HEAD_SIZE,2)

define(NODE_VALUE_OFFSET,1)
define(NODE_NEXT_POINTER_OFFSET,2)
define(NODE_PREV_POINTER_OFFSET,3)
define(NODE_SIZE,3)


###############################################################################
#
###  queinit - initialize a queue
#
#  SYNOPSIS
#    integer qp
#    call queinit ( qp )
#
subroutine queinit ( qp )
integer qp

    integer memalloc, memput
    include "quelb.c"
ifdef (STATISTICS)
    logical firstcall		# Warning - NON-PORTABLE!!!  Assumes static,
    data firstcall / .true. /	# but locals are not guaranteed to be static.

    if ( firstcall )
	{
	firstcall = .false.
        cheadalloc = 0
        cheadfree = 0
        cnodealloc = 0
        cnodefree = 0
	}
enddef

    if ( memalloc ( qp, HEAD_SIZE, MEMINTEGER ) != OK )
	call error ( "queinit: insufficient memory" )
ifdef (STATISTICS)
    cheadalloc = cheadalloc + 1
enddef
    head(HEAD_FRONT_POINTER_OFFSET) = NIL
    head(HEAD_BACK_POINTER_OFFSET) = NIL
    if ( memput ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ("queinit: couldn't write header" )

    return
end


###############################################################################
#
###  queclear - clear a queue
#
#  SYNOPSIS
#    integer qp
#    call queclear ( qp )
#
subroutine queclear ( qp )
integer qp

    logical queempty
    integer x, quefremove

    if ( qp == NIL )
	call error ( "queclear: non-existant queue" )
    while ( ! queempty ( qp ) )
	x = quefremove ( qp )

    return
end


###############################################################################
#
###  quedestroy - deallocate the storage for a queue
#
#  SYNOPSIS
#    integer qp
#    call quedestroy ( qp )
#
subroutine quedestroy ( qp )
integer qp

    integer memfree
    include "quelb.c"

    if ( qp == NIL )
	call error ( "quedestroy: non-existant queue" )
    call queclear ( qp )
    if ( memfree ( qp ) != OK )
        call error ( "quedestroy: couldn't destroy queue" )
ifdef (STATISTICS)
    cheadfree = cheadfree + 1
enddef
    qp = NIL

    return
end


###############################################################################
#
###  queempty - tell whether a queue is empty or not
#
#  SYNOPSIS
#    logical isempty, queempty
#    integer qp
#    isempty = queempty ( qp )
#
logical function queempty ( qp )
integer qp

    integer frontp, memeget

    if ( qp == NIL )
	call error ( "queempty: non-existant queue" )
    if ( memeget ( qp, frontp, HEAD_FRONT_POINTER_OFFSET ) != OK )
        call error( "queempty: couldn't read from header" )
    if ( frontp == NIL )
	queempty = .true.
    else
	queempty = .false.

    return
end


###############################################################################
#
###  quefinsert - insert an integer to the front of a queue
#
#  SYNOPSIS
#    integer qp, int
#    call quefinsert ( qp, int )
#
subroutine quefinsert ( qp, int )
integer qp, int

    integer newfp, memalloc, oldfp, memget, memput, memeput
    include "quelb.c"

    if ( qp == NIL )
	call error ( "quefinsert: non-existant queue" )
    if ( memget ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quefinsert: couldn't read header")
    oldfp = head(HEAD_FRONT_POINTER_OFFSET)
    if ( memalloc ( newfp, NODE_SIZE, MEMINTEGER ) != OK )
	call error ( "quefinsert: insufficient memory" )
ifdef (STATISTICS)
    cnodealloc = cnodealloc + 1
enddef
    node(NODE_VALUE_OFFSET) = int
    node(NODE_PREV_POINTER_OFFSET) = NIL
    if ( oldfp == NIL )
	{ #  The queue is currently empty.
	node(NODE_NEXT_POINTER_OFFSET) = NIL
	head(HEAD_FRONT_POINTER_OFFSET) = newfp
	head(HEAD_BACK_POINTER_OFFSET) = newfp
	}
    else
	{ #  The queue has some elements in it already.
	node(NODE_NEXT_POINTER_OFFSET) = oldfp
	if ( memeput ( oldfp, newfp, NODE_PREV_POINTER_OFFSET ) != OK )
            call error ( "quefinsert: couldn't write to old node" )
	head(HEAD_FRONT_POINTER_OFFSET) = newfp
	}
    if ( memput ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quefinsert: couldn't write header" )
    if ( memput ( newfp, node, NODE_SIZE, 1 ) != OK )
        call error ( "quefinsert: couldn't write new node" )

    return
end


###############################################################################
#
###  quebinsert - insert an integer to the back of a queue
#
#  SYNOPSIS
#    integer qp, int
#    call quebinsert ( qp, int )
#
subroutine quebinsert ( qp, int )
integer qp, int

    integer newbp, memalloc, oldbp, memget, memput, memeput
    include "quelb.c"

    if ( qp == NIL )
	call error ( "quebinsert: non-existant queue" )
    if ( memget ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quebinsert: couldn't read header")
    oldbp = head(HEAD_BACK_POINTER_OFFSET)
    if ( memalloc( newbp, NODE_SIZE, MEMINTEGER ) != OK )
	call error ( "quebinsert: insufficient memory" )
ifdef (STATISTICS)
    cnodealloc = cnodealloc + 1
enddef
    node(NODE_VALUE_OFFSET) = int
    node(NODE_NEXT_POINTER_OFFSET) = NIL
    if ( oldbp == NIL )
	{ #  The queue is currently empty.
	node(NODE_PREV_POINTER_OFFSET) = NIL
	head(HEAD_FRONT_POINTER_OFFSET) = newbp
	head(HEAD_BACK_POINTER_OFFSET) = newbp
	}
    else
	{ #  The queue has some elements in it already.
	node(NODE_PREV_POINTER_OFFSET) = oldbp
	if ( memeput ( oldbp, newbp, NODE_NEXT_POINTER_OFFSET ) != OK )
            call error ( "quebinsert: couldn't write to old node" )
	head(HEAD_BACK_POINTER_OFFSET) = newbp
	}
    if ( memput ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quebinsert: couldn't write header" )
    if ( memput ( newbp, node, NODE_SIZE, 1 ) != OK )
        call error ( "quebinsert: couldn't write new node" )

    return
end


###############################################################################
#
###  quefremove - remove an integer from the front of a queue
#
#  SYNOPSIS
#    integer qp, int, quefremove
#    int = quefremove ( qp )
#
integer function quefremove ( qp )
integer qp

    integer oldfp, newfp
    integer memget, memput, memeput, memfree
    include "quelb.c"

    if ( qp == NIL )
	call error ( "quefremove: non-existant queue" )
    if ( memget ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quefremove: couldn't read header" )
    oldfp = head(HEAD_FRONT_POINTER_OFFSET)
    if ( oldfp == NIL )
	call error ( "quefremove: attempt to remove item from empty queue" )
    if ( memget ( oldfp, node, NODE_SIZE, 1 ) != OK )
        call error ( "quefremove: couldn't read node" )
    if ( memfree ( oldfp ) != OK )
        call error ( "quefremove: couldn't free node" )
ifdef (STATISTICS)
    cnodefree = cnodefree + 1
enddef
    quefremove = node(NODE_VALUE_OFFSET)
    newfp = node(NODE_NEXT_POINTER_OFFSET)
    if ( newfp == NIL ) 
	{ #  Queue only had one item left.
	head(HEAD_FRONT_POINTER_OFFSET) = NIL
	head(HEAD_BACK_POINTER_OFFSET) = NIL
	}
    else
	{ #  Queue had more than one item left.
	head(HEAD_FRONT_POINTER_OFFSET) = newfp
	if ( memeput ( newfp, NIL, NODE_PREV_POINTER_OFFSET ) != OK )
            call error ( "quefremove: couldn't write to node" )
	}
    if ( memput ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quefremove: couldn't write header" )

    return
end


###############################################################################
#
###  quebremove - remove an integer from the back of a queue
#
#  SYNOPSIS
#    integer qp, int, quebremove
#    int = quebremove ( qp )
#
integer function quebremove ( qp )
integer qp

    integer oldbp, newbp
    integer memget, memput, memeput, memfree
    include "quelb.c"

    if ( qp == NIL )
	call error ( "quebremove: non-existant queue" )
    if ( memget ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quebremove: couldn't read header" )
    oldbp = head(HEAD_BACK_POINTER_OFFSET)
    if ( oldbp == NIL )
	call error ( "quebremove: attempt to remove item from empty queue" )
    if ( memget ( oldbp, node, NODE_SIZE, 1 ) != OK )
        call error ( "quebremove: couldn't read node" )
    if ( memfree ( oldbp ) != OK )
        call error ( "quebremove: couldn't free node" )
ifdef (STATISTICS)
    cnodefree = cnodefree + 1
enddef
    quebremove = node(NODE_VALUE_OFFSET)
    newbp = node(NODE_PREV_POINTER_OFFSET)
    if ( newbp == NIL ) 
	{ #  Queue only had one item left.
	head(HEAD_FRONT_POINTER_OFFSET) = NIL
	head(HEAD_BACK_POINTER_OFFSET) = NIL
	}
    else
	{ #  Queue had more than one item left.
	head(HEAD_BACK_POINTER_OFFSET) = newbp
	if ( memeput ( newbp, NIL, NODE_NEXT_POINTER_OFFSET ) != OK )
            call error ( "quebremove: couldn't write to node" )
	}
    if ( memput ( qp, head, HEAD_SIZE, 1 ) != OK )
        call error ( "quebremove: couldn't write header" )

    return
end


###############################################################################
#
###  quefront - examine the integer on the front of a queue without disturbing it
#
#  SYNOPSIS
#    integer qp, int, quefront
#    int = quefront ( qp )
#
integer function quefront ( qp )
integer qp

    integer fp, int, memeget

    if ( qp == NIL )
	call error ( "quefront: non-existant queue" )
    if ( memeget ( qp, fp, HEAD_FRONT_POINTER_OFFSET ) != OK )
        call error ( "quefront: couldn't read from header" )
    if ( fp == NIL )
	call error ( "quefront: attempt to get item from empty queue" )
    if ( memeget ( fp, int, NODE_VALUE_OFFSET ) != OK )
        call error ( "quefront: couldn't read from node" )
    quefront = int

    return
end


###############################################################################
#
###  queback - examine the integer on the back of a queue without disturbing it
#
#  SYNOPSIS
#    integer qp, int, queback
#    int = queback ( qp )
#
integer function queback ( qp )
integer qp

    integer bp, int, memeget

    if ( qp == NIL )
	call error ( "queback: non-existant queue" )
    if ( memeget ( qp, bp, HEAD_BACK_POINTER_OFFSET ) != OK )
        call error ( "queback: couldn't read from header" )
    if ( bp == NIL )
	call error ( "queback: attempt to get item from empty queue" )
    if ( memeget ( bp, int, NODE_VALUE_OFFSET ) != OK )
        call error ( "queback: couldn't read from node" )
    queback = int

    return
end


###############################################################################
#
###  queloopinit - prepare for a loop through the elements of a queue
#
#  SYNOPSIS
#    integer qlp, queloopinit, qp
#    qlp = queloopinit ( qp )
#
integer function queloopinit ( qp )
integer qp

    integer frontp, memeget

    if ( qp == NIL )
	call error ( "queloopinit: non-existant queue" )
    if ( memeget ( qp, frontp, HEAD_FRONT_POINTER_OFFSET ) != OK )
        call error( "queloopinit: couldn't read from header" )
    queloopinit = frontp

    return
end


###############################################################################
#
###  quenext - generate the next element in a queue loop
#
#  SYNOPSIS
#    integer qlp, int
#    logical anotherelement, quenext
#    anotherelement = quenext ( qlp, int )
#
logical function quenext ( qlp, int )
integer qlp, int

    integer memget
    include "quelb.c"

    if ( qlp == NIL )
	quenext = .false.
    else
	{
	if ( memget ( qlp, node, NODE_SIZE, 1 ) != OK )
	    call error ( "quenext: couldn't read node" )
	int = node(NODE_VALUE_OFFSET)
	qlp = node(NODE_NEXT_POINTER_OFFSET)
	quenext = .true.
	}

    return
end


###############################################################################
#                                                                             #
#                              Stack routines.                                #
#                                                                             #
###############################################################################


###############################################################################
#
###  stkinit - initialize a stack
#
#  SYNOPSIS
#    integer sp
#    call stkinit ( sp )
#
subroutine stkinit ( sp )
integer sp

    call queinit ( sp )

    return
end


###############################################################################
#
###  stkclear - clear a stack
#
#  SYNOPSIS
#    integer sp
#    call stkclear ( sp )
#
subroutine stkclear ( sp )
integer sp

    call queclear ( sp )

    return
end


###############################################################################
#
###  stkdestroy - deallocate the storage for a stack
#
#  SYNOPSIS
#    integer sp
#    call stkdestroy ( sp )
#
subroutine stkdestroy ( sp )
integer sp

    call quedestroy ( sp )

    return
end


###############################################################################
#
###  stkempty - tell whether a stack is empty or not
#
#  SYNOPSIS
#    logical isempty, stkempty
#    integer sp
#    isempty = stkempty ( sp )
#
logical function stkempty ( sp )
integer sp

    logical queempty

    return ( queempty ( sp ) )

end


###############################################################################
#
###  stkpush - push an integer onto a stack
#
#  SYNOPSIS
#    integer sp, int
#    call stkpush ( sp, int )
#
subroutine stkpush ( sp, int )
integer sp, int

    call quefinsert ( sp, int )

    return
end


###############################################################################
#
###  stkpop - pop an integer off of a stack
#
#  SYNOPSIS
#    integer sp, int, stkpop
#    int = stkpop ( sp )
#
integer function stkpop ( sp )
integer sp

    integer quefremove

    return ( quefremove ( sp ) )

end


###############################################################################
#
###  stktop - return the value on top of a stack without popping it
#
#  SYNOPSIS
#    integer sp, int, stktop
#    int = stktop ( sp )
#
integer function stktop ( sp )
integer sp

    integer quefront

    return ( quefront ( sp ) )

end


ifdef (STATISTICS)
###############################################################################
#
###  questats - write usage statistics to ERROUT
#
#  SYNOPSIS
#    call questats
#
subroutine questats

    include "quelb.c"

    call putlin ( "Queue usage statistics:", ERROUT )
    call putch ( '@n', ERROUT )
    call putlin ( "  queue headers allocated:", ERROUT )
    call putint ( cheadalloc, 10, ERROUT )
    call putch ( '@n', ERROUT )
    call putlin ( "  queue headers freed:    ", ERROUT )
    call putint ( cheadfree, 10, ERROUT )
    call putch ( '@n', ERROUT )
    call putlin ( "  queue nodes allocated:  ", ERROUT )
    call putint ( cnodealloc, 10, ERROUT )
    call putch ( '@n', ERROUT )
    call putlin ( "  queue nodes freed:      ", ERROUT )
    call putint ( cnodefree, 10, ERROUT )
    call putch ( '@n', ERROUT )

    return
end
enddef
#-t-  quelb                     16089  ascii   05Jan84  08:07:58
#-t-  quelb.all                 26027  ascii   05Jan84  08:10:39
#-h-  prilb.all                 20877  ascii   05Jan84  08:10:42
#-h-  printf.doc                 2370  ascii   04Jan84  11:18:53
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^printf(2)^%^printf(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
printf - formatted output to STDOUT
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
call printf( fmt, arg1, arg2, ... )
.sp
character fmt(ARB)
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
.bd
Printf
converts, formats, and prints its arguments under
control of a format specification, and writes them to
standard output (STDOUT). It allows the user to specify
a format string,
.bd
'fmt',
to control the output,
and a number of items to be output :
.bd
arg1, arg2, etc.
.ne 3
.sp
The format string contains literal characters to be printed, as
well as formatting control structures. Formatting control structures
consist of a percent sign,
.bd
'%',
followed by characters describing the
action to be performed on the next argument in the argument list.
Characters in the format string that are not associated with a format
control structure are output to the file without change.
.ne 3
.sp
The format string is described in detail in the manual entry for
.bd
prints(2).
.ne 3
.sp
EXAMPLES
.ne 3
.sp
To print a string, followed by a new line ("@n") :
.sp
.nf
.in +4
call printf( '%s@n', str )
.sp
.fi
.in -4
To print two real numbers, the first in a field of five (5) with precision
two (2), and the second in a standard field, along with some text
for identification, followed by NEWLINE :
.sp
.nf
.in +4
call printf( 'x = %5.2g, y = %g@n', xcoord, ycoord )
.sp
.fi
.in -4
.sp
.ne 2
.fi
.ti -5
FILES
.br
None
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
fprintf(2), prints(2)
.sp
.ne 2
.fi
.ti -5
DIAGNOSTICS
.br
None
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Rick Corona
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
The format string may be a ratfor string or, a quoted or hollerith
string. For example, use of quoted or hollerith strings will work on a
Vax, but not on the Modcomp. It is recommended that hollerith strings
not be used if programs are to be truly portable.
.ne 3
.sp
There can be no whitespace between the routine name and the left
parenthesis of the parameter list. This is due to the fact that macro
pre-processing does not allow spaces between the macro name and the
definition following it.
.ne 3
.sp
There is a limited number of arguments that can be formatted, depending on
the machine being used. The current RTSG machines limit is 7 arguments.

#-t-  printf.doc                 2370  ascii   04Jan84  11:18:53
#-h-  prints.doc                 5913  ascii   04Jan84  11:18:53
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^prints(2)^%^prints(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
prints - formatted conversion into a character array
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
character dest(), fmt()
.sp
call prints( dest, fmt, arg1, arg2, ... )
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
.bd
Prints
converts and formats its arguments under
control of a format specification. It allows the user to
specify an array on which to write the arguments, a format to
control the output, and any number of items to be printed.
In
.bd
prints, 'dest'
refers to a character array onto which the items should be appended,
.bd
'fmt'
is a format string (discussed below), and the remaining arguments
(zero or more) are items to be output according to format control.
.ne 3
.sp
The format string contains literal characters to be printed, as
well as formatting control structures. Formatting control structures
consist of a percent sign
.bd
'%',
followed by characters describing the
action to be performed on the next argument in the argument list.
Characters in the format string that are not associated with a format
control structure are output to the file without change.
.ne 3
.sp
Following the
.bd
%,
there may be:
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
An optional minus sign which signifies left adjustment of the
converted argument in its field.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
An optional digit string specifying a minimum field width. The
converted number will be printed in a field at least this wide
and wider if necessary. If the converted argument has fewer characters
than the field width it will be padded on the left (or right if
the left adjustment indicator has been given) to make up the
field width. The padding character is usually a blank; however if
the field with is specified with a leading zero, the padding character
will be the digit zero.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
An optional period which separates the field width from the next optional
digit string - the precision. If a precision is specified, the period is
required. Precision specifies the maximum number of characters to be
printed from a string, or the number of digits to be printed to the
right of the decimal point.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
An optional digit string specifiying the precision. (To be used for
real number notation and character strings.) For reals, the precision
specifies the maximum number of digits to be output following the decimal
point; for character strings, the precision specifies the maximum number
of characters to be printed from a given string.
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	-
A character which indicates the type of conversion to be applied.
.in -6
.ne 3
.sp
The conversion characters and their meanings are :
.bd
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	d
The argument is taken as an integer and is converted to decimal notation.
.bd
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	o
The argument is taken as an integer and is converted to octal notation.
.bd
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	x
The argument is taken as an integer and is converted to hexadecimal notation.
.bd
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	c
The argument is taken to be a single character.
.bd
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	s
The argument is taken to be a character string; characters from
the string are printed until an EOS is found or until the number
of characters indicated by the precision specification is reached.
.bd
.in -6
.ne 3
.sp
.in +6
.ta 5r
.ti -6
	g
The argument is taken to be a real number. Decimal or scientific notation,
depending on the magnitude of the number, will be used; non-significant zeros
are not printed. (Refer to manual entry for rtoc(2).)
.in -6
.ne 3
.sp
If the character after the
.bd
%
is not a conversion character, then all of the characters from the
.bd
%
character to the invalid conversion character are
simply copied to the output string.
The
.bd
%
character may be printed by the format specification
.bd
%%.
.ne 3
.sp
In no case does a non-existent or small field width cause truncation
of a field; padding takes place only if the specified field width exceeds
the actual width.
.ne 3
.sp
EXAMPLES
.ne 3
.sp
To append a string, 'str' followed by a new line ("@n") onto a character
array :
.sp
.nf
.in +4
call prints( buf, '%s@n', str )
.sp
.fi
.in -4
To output one real number in a field of five (5) characters with a precision
of two (2), and a second real number, along with some text
for identification, followed by NEWLINE :
.sp
.nf
.in +4
call prints( buf, 'x = %5.2g, y = %g@n', xcoord, ycoord )
.sp
.fi
.in -4
To convert an integer to characters and save it in an array
(the array will be terminated by an EOS) :
.sp
.nf
.in +4
call prints( array, '%d', int)
.sp
.fi
.in -4
.sp
.ne 2
.fi
.ti -5
FILES
.br
None
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
fprintf(2), printf(2)
.sp
.ne 2
.fi
.ti -5
DIAGNOSTICS
.br
None
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Rick Corona
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
The format string may be a ratfor string or, on some systems, may also
be a quoted or hollerith string. For example, use of hollerith strings
will work on a Vax, but not on the Modcomp. It is recommended that hollerith
strings not be used if programs are to be truly portable.
.ne 3
.sp
There can be no whitespace between the routine name and the left
paranthesis of the parameter list. This is due to the fact that macro
pre-processing does not allow spaces between the macro name and the definition
following it.
.ne 3
.sp
There is a limit to the number of arguments to be formatted, depending on
the machine being used. The current RTSG machines limit is six(6) arguments.
.ne 3
.sp
The Unix "printf" "%f" spec for floating point numbers is currently
unimplemented.
.ne 3
.sp
Precision is ignored for the "%g" format.
.ne 3
.sp
This package cannot handle double precision arguments.

#-t-  prints.doc                 5913  ascii   04Jan84  11:18:53
#-h-  fprintf.doc                2322  ascii   04Jan84  11:18:55
.pl 64
.m1 2
.m2 3
.m3 3
.m4 3
.po 10
.rm 62
.bp 1
.in 0
.he ^fprintf(2)^%^fprintf(2)^
.fo ^^- # -^^
.in 5
.sp
.ne 2
.fi
.ti -5
NAME
.br
fprintf - formatted output to a file
.sp
.ne 2
.fi
.ti -5
SYNOPSIS
.br
.nf
call fprintf( fd, fmt, arg1, arg2, ... )
.sp
integer fd
character fmt(MAXLINE)
.sp
.ne 2
.fi
.ti -5
DESCRIPTION
.br
.bd
Fprintf
converts, formats, and prints its arguments under
control of a format specification. It allows the user to
specify a file to write to, a format to
control the output, and a number of items to be printed.
In
.bd
fprintf, 'fd'
is the rfi of the file to be used for output,
.bd
'fmt' 
is a format string (discussed below), and the remaining arguments 
(zero or more) are items to be output according to format control.
.ne 3
.sp
The options available in a format string are discussed in the manual
entry for
.bd
prints(2).  
.ne 3
.sp
EXAMPLES
.ne 3
.sp
To write a string, followed by a new line ("@n") onto a file ('fd') :
.sp
.nf
.in +4
call fprintf( fd, "%s@n", string )
.sp
.fi
.in -4
To write two real numbers, the first in a field of five (5) with a precision
of two (2), and the second in a standard format, along with some text
for identification, followed by NEWLINE :
.sp
.nf
.in +4
call fprintf( fd, 'x = %f5.2, y = %f@n', xcoord, ycoord )
.sp
.fi
.in -4
To convert an integer to characters :
.sp
.nf
.in +4
call fprintf( fd, '%d', int)
.sp
.fi
.in -4
.sp
.ne 2
.fi
.ti -5
FILES
.br
None
.sp
.ne 2
.fi
.ti -5
SEE ALSO
.br
.nf
prints(2), printf(2)
.sp
.ne 2
.fi
.ti -5
DIAGNOSTICS
.br
None
.sp
.ne 2
.fi
.ti -5
AUTHOR(S)
.br
Rick Corona
.sp
.ne 2
.fi
.ti -5
BUGS/DEFICIENCIES
.br
The format string may be a ratfor string or, on some systems, may also
be a quoted or hollerith string. For example, use of quoted or hollerith
strings will work on a Vax, but not on the Modcomp. It is recommended that
hollerith strings not be used in programs if they are to be truly portable.
.ne 3
.sp
There can be no whitespace between the routine name and the left parenthesis
of the parameter list. This is due to the fact that macro pre-processing
does not allow spaces between the macro name and the defintion following it.
.ne 3
.sp
There is a limit to the number of arguments that can be formatted, depending
on the machine being used. The current RTSG machines limit is 7 arguments.

#-t-  fprintf.doc                2322  ascii   04Jan84  11:18:55
#-h-  prilb                      9752  ascii   04Jan84  11:18:55
### prilb - formatted output routines printf, prints and fprintf.
#
# Modifications.
# --------------
# 02g 19Jul83  CAL .Ratfix. Modified to not call esc() since the new
#                   handles all escape sequences.
# 02f 12Jul83  JIC .CHanged all references to itob() to gitoc().
# 02e 05Jul83  ANT .Changed all references to fesc() to esc().
# 02d 16Jun83  ANT .Changed all references to esc() to fesc().
# 02c 21May83  CAL .Fixed bugs with format character doubling and
#                   string precision.
# 02b 07May83  CAL .Modified pridft() to not call error() when the format
#                   string is botched; instead we ingore the special
#                   properties of the format character.
#                  .Removed precision handling code from the 'g' type
#                   since rtoc just isn't smart enough.
#                  .Recoded to be more efficient.
#                  .Modified so that string precision works.
# 02a 29Apr83  CAL .Modified pridft() to conform to the manual entry;
#                   specifically, capabilities were added to provide
#                   for padding, left justified padding, and adjustable
#                   precision. Also, 1200 characters of temporary storage
#                   were removed.
# 01b 12Nov82  RC  .Fixed format '%x' to convert to base 16, and corrected
#                   erraneous coding. Both changes occurred in pridft.
# 01a 17Oct82  RC  .Written.
#
define(FMTCHAR,'%')
define(NUMERICSIZE,128)


### pritf - formatted output to STDOUT
#
# synopsis
#   call pritf( fmt, X1, X2, ... )
#
# description
#   takes a format string and an arbitrary number of arguments, formats
#   the arguments as specified by the format string, and writes them to
#   standard output.
#
# passed
#   fmt - format string
#   X1, X2, ... - arguments to be formatted
#
# returned
#   formatted line(s) to standard output
#
subroutine pritf( fmt, X1, X2, X3, X4, X5, X6, X7, X8, X9 )
character fmt(ARB)
integer X1, X2, X3, X4, X5, X6, X7, X8, X9

    call priftf( STDOUT, fmt, X1, X2, X3, X4, X5, X6, X7, X8, X9 )

    return

end


### priftf - format output to a file
#
# synopsis
#   call priftf( fd, fmt, X1, X2, ... )
#
# description
#   takes a file descriptor for a file on which to write, a format
#   string, and an arbitrary number of arguments; appends the arguments
#   onto the file as specified by the format given.
#
# passed
#   fd - file descriptor for file on which to write
#   fmt - format string
#   X1, X2, ... - arguments to be formatted
#
# returned
#   formatted line(s) of output
#
subroutine priftf( fd, fmt, X1, X2, X3, X4, X5, X6, X7, X8, X9 )
integer fd
character fmt(ARB)
integer X1, X2, X3, X4, X5, X6, X7, X8, X9

    character buf(MAXLINE)

    call prits( buf, fmt, X1, X2, X3, X4, X5, X6, X7, X8, X9 )
    call putlin( buf, fd )

    return

end


### prits - format output
#
# synopsis
#   call prits( dst, fmt, X1, X2, ... )
#
# description
#   takes an array on which to write, a format string, and
#   an arbitrary number of arguments; appends the arguments
#   onto the array as specified by the format given.
#
# passed
#   dst - character array on which to write
#   fmt - format string
#   X1, X2, ... - arguments to be formatted
#
# returned
#   formatted line(s) of output
#
subroutine prits( dst, fmt, X1, X2, X3, X4, X5, X6, X7, X8, X9 )
character dst(ARB), fmt(ARB)
integer X1, X2, X3, X4, X5, X6, X7, X8, X9

    integer dstptr, fmtptr

    fmtptr = 1
    dstptr = 1
    dst(dstptr) = EOS		# we start out with an empty string

    call prifft( fmt, fmtptr, dst, dstptr )

    # Only look for a new format character if we have format left...
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X1, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X2, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X3, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X4, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X5, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X6, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X7, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X8, dst, dstptr )
    if ( fmt(fmtptr) == EOS )
	return
    call prifmt( fmt, fmtptr, X9, dst, dstptr )

    return

end


### prifft - append characters until format character is found
#
# description
#   Scans the format string, appending characters, until a format
#   character or EOS is found; upon exit, fmtptr either points one
#   character after a format character or to the EOS.
#
# passed
#   fmt - format string
#   fmtptr - pointer to character position in format string
#   dst - character array on which to append
#   dstptr - pointer to character position in output string
#
subroutine prifft( fmt, fmtptr, dst, dstptr )
character fmt(ARB)
integer fmtptr
character dst(ARB)
integer dstptr

    while ( fmt(fmtptr) != EOS )
	{
	if ( fmt(fmtptr) == FMTCHAR )
	    {
	    fmtptr = fmtptr + 1
	    if ( fmt(fmtptr) != FMTCHAR & fmt(fmtptr) != EOS )
		break
	    else
		if ( fmt(fmtptr) == EOS )
		    fmtptr = fmtptr - 1
	    }
	dst(dstptr) = fmt ( fmtptr )
	dstptr = dstptr + 1
	fmtptr = fmtptr + 1
	}

    dst(dstptr) = EOS

    return

end


### prifmt - format arguments and search for additional format specifiers
#
# description
#   Converts argument 'Xn' according to the format control specification
#   found at fmt(fmtptr), and appends trailing non-format characters until
#   a new format specification is found. A pointer to the new specifier
#   is returned.
#
# passed
#   fmt - format string
#   fmtptr - pointer to character position in format string
#   arg - argument to be converted according to format specification
#   dst - character array on which to append
#   dstptr - pointer to character position in output string
#
subroutine prifmt( fmt, fmtptr, arg, dst, dstptr )
character fmt(ARB)
integer fmtptr, arg
character dst(ARB)
integer dstptr

    call pridft( fmt, fmtptr, arg, dst, dstptr )

    # Look for another format character.
    if ( fmt(fmtptr) != EOS )
        call prifft( fmt, fmtptr, dst, dstptr )

    return

end


### pridft - process format specifications
#
# description
#   converts arguments as specifed by format, adds justification, precision,
#   and field width, and appends encoded string to 'dst'; returns new
#   'fmtptr'
#
# passed
#   fmt - format string
#   fmtptr - pointer to character position in format string
#   arg - argument argument to be converted according to format specification
#   dst - character array on which to append
#   dstptr - pointer to character position in output string
#
subroutine pridft( fmt, fmtptr, arg, dst, dstptr )
character fmt(ARB)
integer fmtptr, arg
character dst(ARB)
integer dstptr

    integer i, j, lastptr, fldwth, precis, index, length, rtoc, ctoi
    logical leftjust, copystr
    character clower, type, padchar, buf(NUMERICSIZE)

    # Remember where the format character is in case we need it later.
    lastptr = fmtptr - 1

    # Leading MINUS means left justify.
    if (fmt(fmtptr) == '-')
	{
	fmtptr = fmtptr + 1
	leftjust = .true.
	}
    else
	leftjust = .false.

    # Decode field width and padding character.
    fldwth = 0
    padchar = ' '
    if (type( fmt(fmtptr) ) == DIGIT)
	{
	if (fmt(fmtptr) == '0')
	    padchar = '0'

	fldwth = ctoi( fmt, fmtptr )
	}

    # Decode precision, if necessary.
    if (fmt(fmtptr) == '.')
	{
	fmtptr = fmtptr + 1
	precis = ctoi( fmt, fmtptr )
	}
    else
	precis = -1			# default to no precision

    # Convert argument to a string.
    buf(1) = EOS
    copystr = .false.
    switch ( clower( fmt(fmtptr) ) )
	{
	case 'd':
	    call gitoc( arg, buf, NUMERICSIZE, 10 )

	case 'o':
	    call gitoc( arg, buf, NUMERICSIZE, 8 )

	case 'x':
	    call gitoc( arg, buf, NUMERICSIZE, 16 )

	case 'c':
	    call appchr( arg, buf )

	case 's':
	    copystr = .true.

#	case LETF:
#	    i = rtocf( arg, buf, MAXLINE )
#	    if ( precis >= 0 )
#		{
#		i = index ( buf, PERIOD )
#		if ( i > 0 )
#		    if ( precis == 0 )
#			buf(i) = EOS
#		    else
#			buf(i + precis + 1) = EOS
#		}

	case 'g':
	    i = rtoc( arg, buf, MAXLINE )	# should handle precision
	
	default:
	    # Invalid format specifier, so do a GIGO.
	    call scopy ( fmt, lastptr, dst, dstptr )
	    dstptr = dstptr + fmtptr - lastptr + 1
	    fmtptr = fmtptr + 1
	    dst(dstptr) = EOS

	    return

	}

    # By now, the thing we want to format is either in buf or arg.
    # Calculate the amount of padding desired. Precision in a string
    # is a special case.
    if ( ! copystr )
	j = length ( buf )
    else
	{
	if ( precis >= 0 )
	    {
	    j = min ( length ( arg ), precis )
	    precis = j
	    }
	else
	    j = length ( arg )
	}
    i = fldwth - j
    if ( i < 0 )
	i = 0
    
    # Handle right justification.
    if ( ( ! leftjust ) & ( i > 0 ) )
	for ( ; i > 0; i = i - 1 )
	    {
	    dst(dstptr) = padchar
	    dstptr = dstptr + 1
	    }

    # Append the argument to the output string. If the argument
    # was a string, append it using the precision (if necessary).
    if ( ! copystr )
	call stcopy( buf, 1, dst, dstptr )
    else
	if ( precis < 0 )
	    call stcopy( arg, 1, dst, dstptr )
	else
	    {
	    # Precision for a string.
	    call scopy( arg, 1, dst, dstptr )
	    dstptr = dstptr + precis
	    }

    # Handle left justification.
    if ( ( leftjust ) & ( i > 0 ) )
	for ( ; i > 0; i = i - 1 )
	    {
	    dst(dstptr) = padchar
	    dstptr = dstptr + 1
	    }
    dst(dstptr) = EOS

    # Step over the format specifier.
    fmtptr = fmtptr + 1

    return

end
#-t-  prilb                      9752  ascii   04Jan84  11:18:55
#-t-  prilb.all                 20877  ascii   05Jan84  08:10:42
