MODULE XHEAP (	IDENT = 'V1.2-11'		%TITLE 'XPORT Heap Storage Allocator/Deallocator'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XPO$$ALLOC_MEM, XPO$$FREE_MEM ),OTS='' )
		) =
BEGIN

!
!			  COPYRIGHT (c) 1983 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
! ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
! COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
! AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!

!++
!
! FACILITY:  BLISS Library
!
! ABSTRACT:
!
!	This module is a transportable heap storage manager used by XMEM
!	in all environments except VAX/VMS.
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHORS:  Ward Clark,			CREATION DATE:  7 November 1979
!	    Linda Duffell
!
!--

!
! TABLE OF CONTENTS:
!

! FORWARD ROUTINE
!   XPO$$ALLOC_MEM,					! Heap storage allocator
!   XPO$$FREE_MEM;					! Heap storage deallocator

!
! INCLUDE FILES:
!

LIBRARY  'XPORT' ;					! Public XPORT control block and macro definitions
LIBRARY  'XPOSYS' ;					! Internal XPORT macro definitions

    $XPO_SYS_TEST( $TOPS10, $TOPS20, $11M, $RSTS, $RT11 )

%IF $TOPS10 %THEN
REQUIRE  'XT10' ;					! TOPS-10 interface definitions
%FI

%IF $TOPS20 %THEN
REQUIRE  'XT20' ;					! TOPS-20 interface definitions
%FI

%IF $11M %THEN
REQUIRE 'XRSX' ;					! XPORT-specific RSX-11M and FCS interface definitions
%FI

%IF $RSTS %THEN
REQUIRE 'XRSTS' ;
%FI

%IF $RT11 %THEN
REQUIRE 'RT11' ;					! RT-11 interface definitions
%FI

!
! MACROS:
!

%IF %BLISS(BLISS36) %THEN
MACRO
    $JBFF =						! Local name for .JBFF
	%NAME( '.JBFF' ) %,

    $JBREL =						! Local name for .JBREL
	%NAME( '.JBREL' ) %;
%FI

%IF $TOPS20 %THEN
MACRO
    $JBHRL =
	%NAME( '.JBHRL' ) %;				! Local name for .JBHRL
%FI

!
! EQUATED SYMBOLS:
!

LITERAL
    yes = 1,						! Used to turn an indicator on
    no = 0;						! Used to turn an indicator off

%IF $TOPS20 %THEN
LITERAL
    page_size = 512;					! Length of one page
%FI

%IF $RT11 %THEN
LITERAL
    usrloc = %O'266',					! Start of USR area.
    top_user_addr = %O'50';				! Highest memory address user can use.
%FI

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes

!
! OWN STORAGE:
!

!
! EXTERNAL REFERENCES:
!

EXTERNAL
    XPO$ELEMENT0 :  $XPO_FREE_ELEMENT;			! Dummy free element descriptor to head free storage chain

%IF $11M OR $RSTS OR $RT11 %THEN
EXTERNAL
    XPO$POOL_ALLOC;					! 1 = dynamic memory pool has been allocated
%FI

%IF %BLISS(BLISS36) %THEN
EXTERNAL
    $JBFF,						! Address of 1st free word after task image
    $JBREL;						! Current size of the task image
%FI

%IF $TOPS20 %THEN
EXTERNAL
    $JBHRL;						! High segment information
%FI

%IF $11M %THEN
EXTERNAL
    XPO$LOHI :  VECTOR[2],				! RSX-11 task image information
    $DSW;						! RSX-11M directive status word
%FI

%IF $RSTS %THEN
EXTERNAL
    XPO$LOHI :  VECTOR[2];				! RSTS task image information
%FI

%TITLE 'XPO$$ALLOC_MEM - XPORT Heap Storage Allocator'

GLOBAL ROUTINE XPO$$ALLOC_MEM( requested_size, result ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine allocates a single element of heap storage, extending the
!	current task image size if necessary.
!
! FORMAL PARAMETERS:
!
!	requested_size - size of the requested memory element (in addressable units)
!	result - address where the allocated memory address is returned
!
! IMPLICIT INPUTS:
!
!	XPO$ELEMENT0 - free storage chain head (dummy free element descriptor)
!
! IMPLICIT OUTPUTS:
!
!	all or part of an element is removed from the free storage chain
!
! COMPLETION CODES:
!
!	XPO$_NORMAL - memory element successfully allocated
!
!	XPO$_BAD_LOGIC - internal XPORT logic error
!	XPO$_BAD_MEMORY - the free storage chain is invalid
!	XPO$_NO_MEMORY - insufficient memory to satisfy request
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    LOCAL
	previous :  REF $XPO_FREE_ELEMENT,		! Address of previous free storage element
	current :  REF $XPO_FREE_ELEMENT,		! Address of current free storage element
	two_back;					! Address of element before the previous element

    BIND
	new = .result :  REF $XPO_FREE_ELEMENT;		! Address of newly allocated free storage element

%IF %BLISS(BLISS16) %THEN
    LOCAL
	size;						! Requested element size (rounded up to double word)

    size = ((.requested_size + 3) / 4) * 4;		! Round requested size up to double word quantity
%ELSE
    BIND
	size = requested_size;				! Requested element size (no rounding necessary)
%FI

!
! Setup to search the free storage chain.
!

    previous = XPO$ELEMENT0;				! Point to the free chain header (dummy element descriptor).

!
! Find the first free storage element which is big enough to satisfy the memory request.
!

    WHILE 1 DO						! Loop until the requested element is allocated
	BEGIN						! or all available memory has been exhausted.

	WHILE (current = .previous[XPO$A_FREE_LINK])	! Loop to the end of the free storage chain.
					NEQ 0 DO

	    BEGIN					! Check for one of the following free chain errors:
	    IF .current LEQA .previous +		!    current element is not past the previous element
			.previous[XPO$H_FREE_SIZE]	!
%IF $TOPS20 %THEN
	    AND .previous NEQ XPO$ELEMENT0		!     
%FI
		OR .current[XPO$H_FREE_SIZE] EQL 0	!    current element is zero length
%IF %BLISS(BLISS16) %THEN				!
		OR .current<0,2> NEQ 0			!    current element is not on double-word boundary
		OR .(current[XPO$H_FREE_SIZE])<0,2>	!    size is not an integral number of double-words
					NEQ 0
%FI
	    THEN					! If the free storage chain is invalid (corrupted),
		RETURN XPO$_BAD_MEMORY;			! return an error code to the caller.

	    IF .current[XPO$H_FREE_SIZE] LSSU .size	! If this element is too small,
	    THEN					!
		BEGIN					!
		two_back = .previous;			!
		previous = .current;			! link to the next free element and try again.
		END

!
! Remove the newly allocated memory element from the free storage chain.
!

	    ELSE
		BEGIN
		new = .current;				! Return the address of the new element.

		IF .current[XPO$H_FREE_SIZE] EQL .size	! If an entire free element is being allocated,
		THEN					!
		    previous[XPO$A_FREE_LINK] =		! simply remove the element from the free chain.
			.current[XPO$A_FREE_LINK]
		ELSE					! Otherwise, adjust the location and size of the
		    BEGIN				! current free storage element.
		    current = .current + .size;
		    current[XPO$H_FREE_SIZE] = .new[XPO$H_FREE_SIZE] - .size;
		    current[XPO$A_FREE_LINK] = .new[XPO$A_FREE_LINK];
		    previous[XPO$A_FREE_LINK] = .current;
		    END;

		RETURN XPO$_NORMAL;			! Return to the caller indicating successful allocation.
		END
	    END;					! End of free chain search loop

!
! Allocate additional free storage and loop back to reattempt allocation.
!

!+
!
!	System-specific memory allocation processing follows.
!
!-

%IF $TOPS10 %THEN

!+
!
!	TOPS-10 Dynamic Storage Expansion
!
!-

	BEGIN
	LOCAL
	    new :  REF $XPO_FREE_ELEMENT;		! Address of new memory element

	IF .$JBREL + 1 - .$JBFF LSS .size		! If there is not enough free space at the end of the image
	THEN						! (will always fail after 1st time thru this code),
	    IF NOT $T10_CORE( .$JBREL +			! expand the task image by "nK" (where nK GEQ .size).
			1024 * ((.size + 1023) / 1024) )
	    THEN					! If the image cannot be extended,
		RETURN XPO$_NO_MEMORY;			! return an error code to the caller.

	new = .$JBFF;					! Point to the first word past the current TOPS-10 image
	$JBFF = .$JBREL + 1;				! and then adjust the TOPS-10 "first free word" pointer.

	IF .previous + .previous[XPO$H_FREE_SIZE]	! If the new dynamic memory is adjacent
					EQLA .new	! to the last free element,
	THEN						!
	    BEGIN					!
	    previous[XPO$H_FREE_SIZE] =			! simply increase the size of the previous element
	    .previous[XPO$H_FREE_SIZE] + .$JBFF - .new;	!
	    previous = .two_back;			! and reset the previous element pointer.
	    END
	ELSE
	    BEGIN
	    new[XPO$H_FREE_SIZE] = .$JBFF - .new;	! Otherwise, setup the new free storage element
	    new[XPO$A_FREE_LINK] = 0;			!
	    previous[XPO$A_FREE_LINK] = .new;		! and add it to the free storage chain.
	    END;
	END;
	END						! End of free chain search loop

!+
!
!	End of TOPS-10 Dynamic Storage Expansion
!
!-

%FI

%IF $TOPS20 %THEN

!+
!
!	TOPS-20 Dynamic Storage Expansion
!
!-

	BEGIN
	LOCAL
	    page_number,				! Page number of next possible free page
 	    access_bits;				! Storage area for the page access information

	page_number = (.$JBREL+1) ^-9;			! Get the page number of the next possible free page.

	WHILE 1 DO					! Search until enough contiguous free space is found.
	    BEGIN
	    WHILE 1 DO					! Search until a free page is located.
		BEGIN
		IF .$JBHRL NEQ 0			! If a high-segment exists
		THEN					! and we're pointing to the start of it

!++
! NOTE to future XPORT developers: 
!
!   The IF...THEN...; code as it currently exists below seems to be in error.  I believe that it should be
!   replaced by the statement that is now commented out.  However, I have not been able to verify and test
!   it to my satisfaction.  Some comments (by a TOPS-20 developer) on the proposed change are included in 
!   hopes that they will be helpful in verifying it's correctness.  -- egf.
!
!   existing code:

		    IF .page_number EQL			! then bypass this segment.
		    ( (.$JBHRL AND X20$K_RIGHT_HLF) -
			((.$JBHRL AND X20$K_LEFT_HLF)-1 OR %O'777')^-9 )
		    THEN
			page_number = ( (.$JBHRL AND X20$K_RIGHT_HLF)+1 ) ^-9;

!   proposed code:
!
!		    IF .page_number EQL			! then bypass this segment.
!		    ( 
!		    (.$JBHRL AND X20$K_RIGHT_HLF)		! high segment high address
!		    - ((.$JBHRL AND X20$K_LEFT_HLF) ^-18)	! - high segment length
!		    + 1						! + 1 = high segement low address
!			^-9 )					! make it a get page number
!		    THEN
!			page_number = ( (.$JBHRL AND X20$K_RIGHT_HLF) ^-9 ) +1 ;
!

!   comments by TOPS-20 developer (Peter Mierswa):
!
!   From:	KL2137::MIERSWA   13-JUL-1982 11:38  
!    
!   I agree with your changes, however, the comments
!   could be misleading. The expression you evaluate is not the high
!   seg low address, but an address somewhere in the first page of the
!   high segment. This happens because the length in .JBHRL is the
!   actually used length, but the last address in .JBHRL is the last
!   address in the last page, not the last used address. You may want to
!   add another couple of comments: The memory between .JBFF and .JBREL
!   is unused by the XPORT algorithm. The first free page in the low seg
!   is (.JBREL+1)^-9 only if the contents of JBREL always ends in 777.
!   The free memory in the last existing page in the high seg is unused.
!   Since pages can be protected in funny ways on TOPS-20 it is correct
!   to not use this free space.
!   	I looked into large OWN blocks. When first linked, the pages
!   exist. After saving and getting again, they do not. If these own
!   variable lie within the bounds of the low segment or high segment,
!   the algorithm that you employ for memory management will retain
!   their integrity even if the pages don't exist. However, I don't know
!   what link does if you have multiple psects. If JBHRL contains all
!   psects, there is no problem. If jbhrl does not know about multiple
!   psects, then the xport algorithm will allocate pieces of large own
!   arrays. So, I think the algorithm as it stands is fairly good.
!   The only class of bugs to examine seems to be the use of multiple
!   PSECTS.
!
!--

		IF NOT $T20_RMAP(			! Get the accessibility of the page:
				    $FHSLF,		!    this process
				    .page_number,	!    page number
				    access_bits )	!    access information returned here
		THEN
		    RETURN XPO$_NO_MEMORY;		! Page number illegal - no more free space
		IF (.access_bits AND RM_PEX) EQL 0	! If the page does not exist,
		THEN					!
		    EXITLOOP;				! a free page has been found.
		page_number = .page_number + 1;		! Look at the next page

		END;

	    IF .previous + .previous[XPO$H_FREE_SIZE]	! If the free page is adjacent to the
				EQLA .page_number ^9	! previous free page then
	    THEN					!
		BEGIN					!
		previous[XPO$H_FREE_SIZE] =		! increase the previous segment size.
		    .previous[XPO$H_FREE_SIZE] + page_size;
		.page_number ^9 = 0;			! Write into the page to make it exist.
		END
	    ELSE					! Otherwise, a non-adjacent free page has been found.
		BEGIN
		LOCAL
		    new_page :  REF $XPO_FREE_ELEMENT;	! Address of newly allocated free storage element
		new_page = .page_number ^9;		! Point to the address of the newly found free page.
		new_page[XPO$H_FREE_SIZE] = page_size;	! Save the length of the free space
		new_page[XPO$A_FREE_LINK] = 0;		
		previous[XPO$A_FREE_LINK] = .new_page;	! Add it to the free storage chain.
		two_back = .previous;
		previous = .new_page;
		END;

	    IF .previous[XPO$H_FREE_SIZE] GEQ .size	! If the free space is large enough then
	    THEN					!
		EXITLOOP;				! stop searching for more free elements.
	    END;

	previous = .two_back;				! Return with previous[XPO$A_FREE_LINK] pointing to the new free storage area.
	$JBFF = (.page_number+1) ^9;			! Update ".JBFF" with the new free address.
	$JBREL = .$JBFF - 1;				! Update ".JBREL" with the correct address.
	END;
	END

!+
!
!	End of TOPS-20 Dynamic Storage Expansion
!
!-

%FI


%IF $11M %THEN

!+
!
!	RSX-11M Dynamic Storage Setup
!
!-

	BEGIN
	LOCAL
	    new :  REF $XPO_FREE_ELEMENT,		! Address of new memory element
	    task_parms :  BLOCK[16],
	    partition_parms :  BLOCK[3];

	IF .XPO$POOL_ALLOC				! If the task image has already been expanded,
	THEN						!
	    RETURN XPO$_NO_MEMORY;			! return an error code to the caller.

	IF NOT GTSK$S( task_parms )			! Obtain RSX-11 task parameters.
	THEN
	    RETURN XPO$_BAD_LOGIC;

	IF NOT GPRT$S( ,partition_parms )		! Obtain RSX-11 partition parameters.
	THEN
	    RETURN XPO$_BAD_LOGIC;

	new = .XPO$LOHI[1];				! Setup the new free storage element.
	new[XPO$H_FREE_SIZE] = .$DSW +			!    size = partition base address (from GPRT$S call) +
				.task_parms[G$TSTS] -	!	task window size (from GTSK$S call) -
				.new;			!	address of 1st byte past task image
	new[XPO$A_FREE_LINK] = 0;			!    link = 0

	XPO$POOL_ALLOC = yes;				! Indicate that the task image has been expanded.

	XPO$ELEMENT0[XPO$A_FREE_LINK] = .new;		! Setup the initial free storage chain (1 element).
	END;						
	END						! End of free chain search loop

!+
!
!	End of RSX-11M Dynamic Storage Setup
!
!-

%FI

%IF $RSTS %THEN

!+
!
!	RSTS Dynamic Storage Setup
!
!-

	BEGIN
	LOCAL
	    new :  REF $XPO_FREE_ELEMENT,		! Address of new memory element
    	    image_size;					! Size of available free memory in K units
 
	IF .XPO$POOL_ALLOC				! If the task image has already been expanded,
	THEN						!
	    RETURN XPO$_NO_MEMORY;			! return an error code to the caller.

    	$XRSTS_INI_XRB;					! Initialize the XRB.
    	$STAT;						! Obtain the maximum size of the user job image,
    	image_size = .$XRSTS_XRB[XRLOC];		! and save it.

    	$XRSTS_INI_XRB;					! Initialize the XRB.
    	$XRSTS_INI_FIRQB;				! Initialize the FIRQB.
    	$XRSTS_XRB[XRLEN] = .image_size;			
    	$CORE;						! Expand the user job image by the max.
    	IF .$XRSTS_FIRQB[FQIOSTS] NEQ 0
	THEN
	    RETURN XPO$_BAD_LOGIC;

	new = .XPO$LOHI[1];				! Setup the new free storage element.
	new[XPO$H_FREE_SIZE] = (.image_size * %O'4000')	!   free_size = highest address -
    					- .new;		!	address of 1st byte past task image
	new[XPO$A_FREE_LINK] = 0;			!    link = 0

	XPO$POOL_ALLOC = yes;				! Indicate that the task image has been expanded.

	XPO$ELEMENT0[XPO$A_FREE_LINK] = .new;		! Setup the initial free storage chain (1 element).
	END;						
	END						! End of free chain search loop

!+
!
!	End of RSTS Dynamic Storage Setup
!
!-

%FI

%IF $RT11 %THEN

!+
!
!	RT-11 Dynamic Storage Setup
!
!-

	BEGIN
	LOCAL
	    new :  REF $XPO_FREE_ELEMENT,		! Address of new memory element
	    first_free,					! Starting address offree space
	    upper_limit;				! Highest available address.

	IF .XPO$POOL_ALLOC				! If all the memory has been allocated,
	THEN						!
	    RETURN XPO$_NO_MEMORY;			! return an error code to the caller.

	first_free = (.top_user_addr +			! Get the starting address of the available free space 
				((2 * %UPVAL)-1) ) AND	! and make sure it starts on a double-word boundary.	
			%X'FFFC';

	upper_limit = ($SETTOP($GVAL(usrloc)) AND	! Get the starting address of the USR.
				%X'FFFC') ;

	IF  .first_free GEQA .upper_limit		! If there isn't any free space available
	THEN
	    RETURN XPO$_NO_MEMORY;			! return an error code to the caller.

	new = .first_free;				! Setup the new free storage element.
	new[XPO$H_FREE_SIZE] = .upper_limit - .new;
	new[XPO$A_FREE_LINK] = 0;
	
	XPO$POOL_ALLOC = yes;				! Indicate that the memory has been expanded.

	XPO$ELEMENT0[XPO$A_FREE_LINK] = .new;		! Setup the initial free storage chain (1 element).
	END;
	END						! End of free chain search loop

!+
!
!	End of RT-11 Dynamic Storage Setup
!
!-

%FI

    END;						! End of XPO$$ALLOC_MEM

$XPO_MODULE( XHEAP1 )

%TITLE 'XPO$$FREE_MEM - XPORT Heap Storage Deallocator'

GLOBAL ROUTINE XPO$$FREE_MEM( actual_size, address ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine adds a single storage element to the free storage chain.
!	If the element being freed is adjacent to an existing free element, the
!	the two (or three) element are combined into a single free element.
!
! FORMAL PARAMETERS:
!
!	actual_size - size of the element being freed (addressable units)
!	address - address of the element being freed
!
! IMPLICIT INPUTS:
!
!	XPO$ELEMENT0 - free storage chain head (dummy free element descriptor)
!
! IMPLICIT OUTPUTS:
!
!	element is added to the free storage chain
!
! COMPLETION CODES:
!
!	XPO$_NORMAL
!
!	XPO$_BAD_ADDR - the element begins within an existing free element
!	XPO$_BAD_ALIGN - the element does not begin on a double-word boundary (BLISS-16 only)
!	XPO$_BAD_LENGTH - the element overlaps an existing free element
!	XPO$_BAD_MEMORY - the free storage chain is invalid
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    LOCAL
	previous :  REF $XPO_FREE_ELEMENT,		! Address of previous free storage element
	next :  REF $XPO_FREE_ELEMENT;			! Address of next higher free storage element

    BIND
	current = address :  REF $XPO_FREE_ELEMENT;	! Address of the element being freed

    EXTERNAL
	XPO$ELEMENT0 :  $XPO_FREE_ELEMENT;		! Dummy free element descriptor to head free storage chain

%IF %BLISS(BLISS16) %THEN
    LOCAL
	size;						! Actual element size (rounded up to double word)

    size = ((.actual_size + 3) / 4) * 4;		! Round actual size up to double word quantity.
%ELSE
    BIND
	size = actual_size;				! Actual element size (no rounding necessary)
%FI

!
! Verify that the element address is valid.
!

%IF %BLISS(BLISS16) %THEN
    IF .current<0,2> NEQ 0				! If the element does not begin on a double-word boundary,
    THEN						!
	RETURN XPO$_BAD_ALIGN;				! return an error code to the caller.
%FI

!
! Setup to search the free storage chain.
!

    previous = XPO$ELEMENT0;				! Point to the free chain header (dummy element descriptor).

!
! Search up the free storage chain to find where the current element fits.
!

    WHILE ( next = .previous[XPO$A_FREE_LINK] ) NEQ 0	! Search to the end of the chain.
	DO
	BEGIN						! Check for one of the following free chain errors:
	IF .next LEQA .previous +			!    next element is not past the previous element
			    .previous[XPO$H_FREE_SIZE]
%IF $TOPS20 %THEN
		AND .previous NEQ XPO$ELEMENT0
%FI
	    OR .next[XPO$H_FREE_SIZE] EQL 0		!    next element is zero length
%IF %BLISS(BLISS16) %THEN
	    OR .next<0,2> NEQ 0				!    next element is not on double-word boundary
	    OR .(next[XPO$H_FREE_SIZE])<0,2> NEQ 0	!    size is not an integral number of double-words
%FI
	THEN
	    RETURN XPO$_BAD_MEMORY;

	IF .next LSSA .current				! If the next free element is lower in memory
	THEN						! than the current element,
	    previous = .next				! point to the next free element.
	ELSE
	    BEGIN
%IF $TOPS20 %THEN
	    IF .previous NEQ XPO$ELEMENT0
	    THEN
%FI
	    IF .previous + .previous[XPO$H_FREE_SIZE]	! Otherwise, verify that the current element does not
					GTRA .current	! overlap the previous free element
	    THEN					!
		RETURN XPO$_BAD_ADDR;			!
							!
	    IF .current + .size GTRA .next		! and that it does not overlap the next free element.
	    THEN
		RETURN XPO$_BAD_LENGTH;

	    EXITLOOP;					! Then exit the free chain search loop.
	    END;
	END;

!
! Add the current element to the free storage chain, combining it with
! adjacent free elements.
!

    IF .current + .size EQLA .next			! If the next free element is adjacent
    THEN						! to the current element,
	BEGIN						! combine the two elements.
	current[XPO$H_FREE_SIZE] = .size + .next[XPO$H_FREE_SIZE];
	current[XPO$A_FREE_LINK] = .next[XPO$A_FREE_LINK];
	END
    ELSE
	BEGIN
	current[XPO$H_FREE_SIZE] = .size;		! Otherwise, simply setup the current
	current[XPO$A_FREE_LINK] = .next;		! free element descriptor.
	END;

    IF .previous + .previous[XPO$H_FREE_SIZE]		! If the previous free element is adjacent
				EQLA .current		! to the current element,
    THEN						!
	BEGIN						!
	previous[XPO$H_FREE_SIZE] =			! combine the two elements.
	    .previous[XPO$H_FREE_SIZE] + .current[XPO$H_FREE_SIZE];
	previous[XPO$A_FREE_LINK] = .current[XPO$A_FREE_LINK];
	END
    ELSE
	previous[XPO$A_FREE_LINK] = .current;		! Otherwise, simply have the previous element
							! point to the current element.

!
! Return to the caller.
!

    RETURN XPO$_NORMAL					! Return a success code to the caller.

    END;
END
ELUDOM