MODULE XMEM ( IDENT = 'V1.3-21' %TITLE 'XPORT Dynamic Memory Manager' %BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) ) %BLISS36( ,ENTRY( XPO$ALLOC_MEM, XPO$FREE_MEM ),OTS='' ) ) = BEGIN ! ! COPYRIGHT (c) 1983, 1984 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 comprises the entire XPORT dynamic memory ! management package. ! ! ENVIRONMENT: User mode - multiple host operating/file systems ! ! AUTHORS: Ward Clark, CREATION DATE: 15 December 1978 ! Linda Duffell ! ! REVISION HISTORY: ! ! 2-Apr-1984 LYS In XPO$FREE_MEM added VMS only code ! to check if the memory element being ! freed is quadword aligned if LIB$FREE_VM ! is to be used to free the memory and to ! check if the memory is longword aligned ! if LIB$SFREE1_DD is to be used to free ! the memory. ! ! END OF REVISION HISTORY !-- ! ! TABLE OF CONTENTS: ! ! FORWARD ROUTINE ! XPO$ALLOC_MEM, ! XPORT allocate memory routine ! XPO$FREE_MEM; ! XPORT free memory routine ! ! INCLUDE FILES: ! LIBRARY 'XPORT' ; ! Public XPORT control block and macro definitions LIBRARY 'XPOSYS' ; ! Internal XPORT macro definitions $XPO_SYS_TEST( $TOPS10, $TOPS20, $VMS, $11M, $RSTS, $RT11 ) ! ! MACROS: ! ! ! EQUATED SYMBOLS: ! ! ! PSECT DECLARATIONS: ! $XPO_PSECTS ! Declare XPORT PSECT names and attributes ! ! OWN STORAGE: ! ! ! EXTERNAL REFERENCES: ! ! See specific routines. %TITLE 'XPO$ALLOC_MEM - XPORT Dynamic Memory Allocator' GLOBAL ROUTINE XPO$ALLOC_MEM( element_size, desc, fill_indicator, fill_value, success_action, failure_action ) = !++ ! ! FUNCTIONAL DESCRIPTION: ! ! FORMAL PARAMETERS: ! ! element_size - requested size of element ! desc - address of string/data descriptor which contains ! the requested memory element type and size ! fill_indicator - storage initialization indicator: ! XPO$K_DONT_FILL - don't fill element ! XPO$K_FILL_UNIT - fill binary units ! XPO$K_FILL_FULL - fill binary fullwords ! fill_value - storage initialization value ! success_action - address of success action routine ! failure_action - address of failure action routine ! ! IMPLICIT INPUTS: ! ! None ! ! IMPLICIT OUTPUTS: ! ! desc[STR$A_POINTER] = pointer to allocated character element ! desc[XPO$A_ADDRESS] = address of allocated binary element ! ! COMPLETION CODE: ! ! XPO$_NORMAL - storage was successfully allocated ! ! XPO$_BAD_DESC - invalid string/data descriptor ! (IOB$G_2ND_CODE = XPO$_BAD_DTYPE - invalid descriptor data type ! or XPO$_BAD_CLASS - invalid descriptor class ! or XPO$_BAD_ADDR - invalid descriptor address) ! XPO$_BAD_LOGIC - invalid request descriptor ! XPO$_FOREGROUND - this job is a foreground job (RT-11) ! XPO$_NO_MEMORY - insufficient dynamic memory to satisfy request (VMS) ! or if failure status from FUNCT. (TOPS-10/20 OTS). ! failure completion code from XPO$$ALLOC_MEM (non-VMS). ! ! SIDE EFFECTS: ! ! None ! !-- BEGIN MAP desc : REF $STR_DESCRIPTOR( CLASS=BOUNDED ); ! Redefine the descriptor parameter BIND string = desc : REF $STR_DESCRIPTOR( CLASS = BOUNDED ), data = desc : REF $XPO_DESCRIPTOR( CLASS = BOUNDED ); %IF $VMS %THEN EXTERNAL ROUTINE ! VAX/VMS dynamic memory routines: LIB$SGET1_DD : ADDRESSING_MODE(GENERAL), ! dynamic string allocation LIB$GET_VM : ADDRESSING_MODE(GENERAL); ! dynamic memory allocation EXTERNAL LITERAL LIB$_INSVIRMEM; ! RTL completion code %ELSE EXTERNAL ROUTINE XPO$$ALLOC_MEM; ! XPORT transportable heap storage allocator %FI %IF $RT11 %THEN EXTERNAL ROUTINE XRT$CHK_BACKGRD; ! Background job verification %FI %IF %BLISS(BLISS36) %THEN MACRO funct$ = %NAME ('funct.') %; ! BLISS doesn't allow "." character in names. EXTERNAL ROUTINE ! The FORTRAN OTS routine "FUNCT." on TOPS-10/20 or the funct$ : NOVALUE FORTRAN_SUB; ! XPORT routine to take the place of FORTRAN OTS routine ! whenever the user does not link with the FORTRAN OTS. LOCAL function : INITIAL (0), ! illegal code if real FUNCT. error : INITIAL (0), ! three letter error mnemonic status : INITIAL (0), ! Depends on requested function: ! Function = 0 (F.ILL) ! -1 if we're linked with OTS ! 0 if we're linked without OTS ! Function = 6 (F.GOT) or 7 (F.ROT) ! 0 if allocated (GOT) or deallocated (ROT) ok ! 1 if not enough memory (GOT) or never allocated (ROT) ! 3 if argument error mem_address : INITIAL (0), ! address of allocated memory mem_size : INITIAL (0); ! size to be allocated, in words %ELSE LOCAL status; ! Temporary routine completion code %FI ! ! XPORT routine initialization. ! $XPO_MAIN_BEGIN( GET_MEM ) ! Define the MAIN_BLOCK code block. %IF $RT11 %THEN ! ! Verify that this is a background job. ! IF NOT XRT$CHK_BACKGRD( ) THEN $XPO_QUIT( FOREGROUND ); %FI ! ! Verify that the request descriptor is valid. ! ! The descriptor is invalid if one or more of ! the following conditions exist: IF .data[XPO$B_DTYPE] NEQ XPO$K_DTYPE_BU AND ! the data type is not UNITS .string[STR$B_DTYPE] NEQ STR$K_DTYPE_T ! or CHARACTERS THEN $XPO_QUIT( BAD_DESC, BAD_DTYPE ); IF .string[STR$B_CLASS] NEQ STR$K_CLASS_D AND ! the descriptor is not a DYNAMIC descriptor .string[STR$B_CLASS] NEQ STR$K_CLASS_DB AND ! or a DYNAMIC_BOUNDED descriptor .string[STR$B_CLASS] NEQ STR$K_CLASS_XT ! or an XPORT_TEMPORARY descriptor THEN $XPO_QUIT( BAD_DESC, BAD_CLASS ); IF .string[STR$A_POINTER] NEQ 0 ! an element pointer/address was provided THEN $XPO_QUIT( BAD_DESC, BAD_ADDR ); ! ! Allocate the requested amount of dynamic memory. ! IF .element_size EQL 0 ! If no actual memory is requested, THEN ! $XPO_QUIT( NORMAL ); ! bypass memory allocation. %IF $VMS %THEN IF .string[STR$B_DTYPE] EQL STR$K_DTYPE_T THEN BEGIN LOCAL temp : $STR_DESCRIPTOR( CLASS = DYNAMIC ); $STR_DESC_INIT( DESCRIPTOR = temp, CLASS = DYNAMIC ); status = LIB$SGET1_DD( element_size, temp ); ! Allocate a dynamic string string[STR$A_POINTER] = .temp[STR$A_POINTER]; ! and save the allocated address. END ELSE ! Allocate a binary dynamic area. status = LIB$GET_VM( element_size, string[STR$A_POINTER] ); IF NOT .status ! If allocation fails, THEN ! IF .status EQL LIB$_INSVIRMEM ! return an appropriate error code to the caller. THEN $XPO_QUIT( NO_MEMORY ) ELSE $XPO_QUIT( BAD_LOGIC ); %ELSE %IF %BLISS(BLISS36) %THEN funct$ ( function, error, status ); ! test to see if we are linked standalone or with OTS IF .status EQLU -1 ! linked with object time system THEN BEGIN ! use FUNCT. memory management function = %o'6'; ! F.GOT (Get Object Time memory) IF .data[XPO$B_DTYPE] NEQ XPO$K_DTYPE_BU ! If this is a TOPS-10/TOPS-20 character element THEN ! request, BEGIN ! mem_size = (.element_size+4)/5; ! allocate enough words (5 characters/word). funct$ ( function, error, status, mem_address, ! address of allocated memory mem_size ); ! size to be allocated, in words string[STR$A_POINTER] = CH$PTR(.mem_address); END ELSE BEGIN mem_size = .element_size; ! Otherwise, allocate the requested number of units. funct$ ( function, error, status, mem_address, ! address of allocated memory mem_size ); ! size to be allocated, in words data[XPO$A_ADDRESS] = .mem_address; END; IF .status NEQU 0 ! Heap storage allocation failed, THEN ! status=1 if insufficient memory, status=3 if size > 256k $XPO_QUIT( NO_MEMORY ); ! either way, there's not enough. END ELSE ! Not linked with an OTS, so use XHEAP BEGIN IF .data[XPO$B_DTYPE] NEQ XPO$K_DTYPE_BU ! If this is a TOPS-10/TOPS-20 character element THEN ! request, BEGIN ! status = XPO$$ALLOC_MEM( (.element_size+4)/5, ! allocate enough words (5 characters/word). string[STR$A_POINTER] ); string[STR$A_POINTER] = CH$PTR(.string[STR$A_POINTER]); END ELSE status = XPO$$ALLOC_MEM( .element_size, ! Otherwise, allocate the requested number of units. data[XPO$A_ADDRESS] ); IF NOT .status ! If heap storage allocation failed, THEN ! $XPO_QUIT( (.status) ); ! return the XPO$$ALLOC_MEM error code to the caller. END; %ELSE status = XPO$$ALLOC_MEM( .element_size, ! Otherwise, allocate the requested number of units. data[XPO$A_ADDRESS] ); IF NOT .status ! If heap storage allocation failed, THEN ! $XPO_QUIT( (.status) ); ! return the XPO$$ALLOC_MEM error code to the caller. %FI %FI ! ! Fillin the length fields in the caller's descriptor. ! IF .string[STR$B_CLASS] EQL STR$K_CLASS_DB THEN BEGIN string[STR$H_LENGTH] = 0; string[STR$H_MAXLEN] = .element_size; END ELSE string[STR$H_LENGTH] = .element_size; ! ! Initialize the allocated memory element, if requested. ! IF .fill_indicator NEQ XPO$K_DONT_FILL ! Check to see if storage initialization is requested. THEN IF .data[XPO$B_DTYPE] NEQ XPO$K_DTYPE_BU THEN CH$FILL( .fill_value, .element_size, ! Character initialization .string[STR$A_POINTER] ) ELSE IF .fill_indicator EQL XPO$K_FILL_UNIT THEN CH$FILL( .fill_value, ! Addressable unit initialization .element_size, CH$PTR( .data[XPO$A_ADDRESS], 0, %BPUNIT ) ) ELSE BEGIN ! BLISS fullword initialization BIND fullwords = .data[XPO$A_ADDRESS] : VECTOR; INCR index FROM 0 TO (.element_size - 1) / %UPVAL DO fullwords[.index] = .fill_value; END; $XPO_QUIT( NORMAL ); ! Indicate successful storage allocation. ! ! XPORT routine termination. ! $XPO_MAIN_END; ! Terminate MAIN_BLOCK. IF NOT .primary_code ! If memory allocation failed, THEN ! string[STR$A_POINTER] = XPO$K_FAILURE; ! setup to return an invalid memory address. $XPO_ACTION_RTN( desc[$BASE] ); ! Call a success or failure action routine. ! ! Return to the caller. ! RETURN .primary_code ! Return the final completion code to the caller. END; $XPO_MODULE( XMEM1 ) %TITLE 'XPO$FREE_MEM - XPORT Dynamic Memory Deallocator' GLOBAL ROUTINE XPO$FREE_MEM( desc, fill_flag, fill_value, success_action, failure_action ) = !++ ! ! FUNCTIONAL DESCRIPTION: ! ! This routine releases a single element of dynamic memory. ! ! FORMAL PARAMETERS: ! ! desc - address of string/data descriptor which describes ! the character or binary memory element to be freed ! fill_flag - clear storage indicator ( 1 = yes, 0 = no ) ! fill_value - value to be used to clear storage ! success_action - address of success action routine ! failure_action - address of failure action routine ! ! IMPLICIT INPUTS: ! ! None ! ! IMPLICIT OUTPUTS: ! ! None ! ! COMPLETION CODE: ! ! XPO$_NORMAL - storage successfully freed ! ! XPO$_BAD_ADDR - storage to be freed is not in allocated dynamic memory (VMS) ! or if failure status from FUNCT. (TOPS-10/20 OTS). ! XPO$_BAD_ALIGN - storage to be freed is not fullword aligned (TOPS-10,TOPS-20) ! XPO$_BAD_DESC - string/data descriptor is invalid ! (IOB$G_2ND_CODE = XPO$_BAD_CLASS - invalid descriptor class ! or XPO$_BAD_ADDR - invalid descriptor address) ! XPO$_BAD_PTR - character pointer is not 7-bit ! XPO$_FOREGROUND - this is a foreground job (RT-11) ! failure completion code from XPO$$FREE_MEM (non-VMS) ! ! SIDE EFFECTS: ! ! None ! !-- BEGIN MAP desc : REF $STR_DESCRIPTOR( CLASS=BOUNDED ); ! Redefine the descriptor parameter BIND string = desc : REF $STR_DESCRIPTOR( CLASS = BOUNDED ), data = desc : REF $XPO_DESCRIPTOR( CLASS = BOUNDED ); %IF $VMS %THEN EXTERNAL ROUTINE ! VAX/VMS dynamic memory routines: LIB$SFREE1_DD : ADDRESSING_MODE(GENERAL), ! dynamic string deallocation LIB$FREE_VM : ADDRESSING_MODE(GENERAL); ! dynamic memory deallocation EXTERNAL LITERAL LIB$_INSVIRMEM; ! RTL completion code %ELSE EXTERNAL ROUTINE XPO$$FREE_MEM; ! XPORT transportable heap storage deallocator %FI %IF $RT11 %THEN EXTERNAL ROUTINE XRT$CHK_BACKGRD; ! Background job verification %FI %IF %BLISS(BLISS36) %THEN MACRO funct$ = %NAME ('funct.') %; ! BLISS doesn't allow "." character in names. EXTERNAL ROUTINE ! The FORTRAN OTS routine "FUNCT." on TOPS-10/20 or the funct$ : NOVALUE FORTRAN_SUB; ! XPORT routine to take the place of FORTRAN OTS routine ! whenever the user does not link with the FORTRAN OTS. LOCAL function : INITIAL (0), ! illegal code if real FUNCT. error : INITIAL (0), ! three letter error mnemonic status : INITIAL (0), ! Depends on requested function: ! Function = 0 (F.ILL) ! -1 if we're linked with OTS ! 0 if we're linked without OTS ! Function = 6 (F.GOT) or 7 (F.ROT) ! 0 if allocated (GOT) or deallocated (ROT) ok ! 1 if not enough memory (GOT) or never allocated (ROT) ! 3 if argument error mem_address : INITIAL (0), ! address of memory to be deallocated mem_size : INITIAL (0); ! size to be deallocated, in words LOCAL element_size, ! Size of the memory element to be freed element_addr; ! Address of the memory element to be freed %ELSE LOCAL element_size, ! Size of the memory element to be freed element_addr, ! Address of the memory element to be freed status; ! Temporary routine completion code %FI ! ! XPORT routine initialization. ! $XPO_MAIN_BEGIN( FREE_MEM ) ! Define the MAIN_BLOCK code block. IF .string[STR$B_DTYPE] NEQ XPO$K_DTYPE_BU ! If this is not a binary data descriptor, THEN ! make sure that it is a valid string descriptor. $STR_VALIDATE( string[$BASE], (XPO$_BAD_DESC) ); %IF $RT11 %THEN ! ! Verify that this is a background job. ! IF NOT XRT$CHK_BACKGRD( ) THEN $XPO_QUIT( FOREGROUND ); %FI ! ! Verify that the string/data descriptor is valid. ! SELECTONE .string[STR$B_CLASS] OF SET [ STR$K_CLASS_D, STR$K_CLASS_XT ] : ! DYNAMIC or XPORT_TEMPORARY descriptor: BEGIN ! element_size = .string[STR$H_LENGTH]; ! Pickup the element size element_addr = .string[STR$A_POINTER]; ! and the address of the element. END; [ STR$K_CLASS_DB ] : ! DYNAMIC_BOUNDED descriptor: BEGIN ! element_size = .string[STR$H_MAXLEN]; ! Pickup the element size IF .string[STR$B_DTYPE] EQL XPO$K_DTYPE_BU ! THEN ! element_addr = .data[XPO$A_ADDRESS] - ! and the address of the element .data[XPO$H_PFXLEN] ! ELSE ! element_addr = ! or a pointer to the element. CH$PLUS( .string[STR$A_POINTER], -.string[STR$H_PFXLEN] ); END; [ STR$K_CLASS_F, STR$K_CLASS_B ] : ! FIXED or BOUNDED descriptor: $XPO_QUIT( BAD_DESC, BAD_CLASS ); ! Return error codes to the caller. [ STR$K_CLASS_Z ] : ! UNDEFINED descriptor: IF .string[STR$H_LENGTH] EQL 0 ! If this is a null descriptor, THEN ! element_size = 0 ! let it pass. ELSE ! $XPO_QUIT( BAD_DESC, BAD_CLASS ); ! Otherwise, return error codes to the caller. [ OTHERWISE ] : ! Invalid descriptor class: $XPO_QUIT( BAD_DESC, BAD_CLASS ); ! Return error codes to the caller. TES; IF .element_size NEQ 0 ! If the element size is non-zero, THEN ! validate the memory element descriptor. BEGIN IF .element_addr EQL 0 ! If no element pointer/address was provided, THEN ! $XPO_QUIT( BAD_DESC, BAD_ADDR ); ! return error codes to the caller. %IF %BLISS(BLISS36) %THEN IF .string[STR$B_DTYPE] NEQ XPO$K_DTYPE_BU AND ! If a BLISS-36 character pointer is not ( (.element_addr AND %O'7777000000') ! a 7-bit pointer, NEQ %O'700000000' ) ! THEN ! $XPO_QUIT( BAD_PTR ); ! return an error completion code. IF .string[STR$B_DTYPE] NEQ XPO$K_DTYPE_BU AND ! If a BLISS-36 character pointer does not point to ( (.element_addr AND -1^18) ! a BLISS fullword boundary, NEQ %O'10700000000' ) ! THEN ! $XPO_QUIT( BAD_ALIGN ); ! return an error completion code. %FI END; ! NOTE: BLISS-16 alignment checking is performed by XPO$$FREE_MEM. ! ! Clear the storage element, if requested. ! IF .fill_flag ! If the caller wants the storage cleared, THEN ! IF .string[STR$B_DTYPE] ! use the descriptor data type to select NEQ XPO$K_DTYPE_BU ! to select appropriate clearing code. THEN ! Clear character string. CH$FILL( .fill_value, .element_size, .element_addr ) ELSE ! Clear binary data. CH$FILL( .fill_value, .element_size, CH$PTR( .element_addr, 0, %BPUNIT ) ); ! ! Release the requested dynamic memory element. ! IF .element_size NEQ 0 ! If this is a zero-length element, THEN ! don't attempt to free it. BEGIN %IF $VMS %THEN IF .string[STR$B_DTYPE] EQL STR$K_DTYPE_T THEN BEGIN LOCAL temp : $STR_DESCRIPTOR( CLASS = DYNAMIC ); $STR_DESC_INIT( DESCRIPTOR = temp, CLASS = DYNAMIC ); temp[STR$H_LENGTH] = .element_size; temp[STR$A_POINTER] = .element_addr; IF (.element_addr AND 3) NEQ 0 ! If the memory element is not 4-byte aligned, THEN ! (longword aligned) $XPO_QUIT( BAD_ALIGN ); ! return an error code to the caller. IF NOT LIB$SFREE1_DD( temp ) THEN $XPO_QUIT( BAD_ADDR ); ! Free a dynamic string. END ELSE BEGIN IF (.element_addr AND 7) NEQ 0 ! If the memory element is not 8-byte aligned, THEN ! (quadword aligned) $XPO_QUIT( BAD_ALIGN ); ! return an error code to the caller. IF NOT LIB$FREE_VM( element_size, element_addr ) ! Free binary dynamic memory. THEN $XPO_QUIT( BAD_ADDR ); END %ELSE %IF %BLISS(BLISS36) %THEN funct$ ( function, error, status ); ! test to see if we are linked standalone or with OTS IF .status EQLU -1 ! linked with object time system THEN BEGIN ! use FUNCT. memory management function = %o'7'; ! F.ROT (Return Object Time memory) IF .string[STR$B_DTYPE] NEQ XPO$K_DTYPE_BU ! If this is a TOPS-10/TOPS-20 character element THEN ! deallocation, BEGIN mem_size = (.element_size+4)/5; ! deallocate enough words (5 characters/word). mem_address = .element_addr<0,18,0> + 1; funct$ ( function, error, status, mem_address, ! address of allocated memory mem_size ); ! size to be deallocated, in words END ELSE BEGIN mem_size = .element_size; ! Otherwise, deallocate the specified number of mem_address = .element_addr; ! units. funct$ ( function, error, status, mem_address, ! address of allocated memory mem_size ); ! size to be deallocated, in words END; IF .status NEQU 0 ! Heap storage deallocation failed, THEN ! status=1 if wasn't allocated, status=3 if size or address > 256k $XPO_QUIT( BAD_ADDR ); ! either way, assume the address is bad. END ELSE ! Not linked with an OTS, so use XHEAP BEGIN IF .string[STR$B_DTYPE] NEQ XPO$K_DTYPE_BU ! If this is a TOPS-10/TOPS-20 character element THEN ! deallocation, status = XPO$$FREE_MEM( (.element_size+4)/5, ! deallocate enough words (5 characters/word). .element_addr<0,18,0> + 1 ) ELSE status = XPO$$FREE_MEM( .element_size, ! Otherwise, deallocate the specified number of units. .element_addr ); IF NOT .status ! If heap storage deallocation failed, THEN ! $XPO_QUIT( (.status) ); ! return the XPO$$FREE_MEM error code to the caller. END; %ELSE status = XPO$$FREE_MEM( .element_size, ! Otherwise, deallocate the specified number of units. .element_addr ); IF NOT .status ! If heap storage deallocation failed, THEN ! $XPO_QUIT( (.status) ); ! return the XPO$$FREE_MEM error code to the caller. %FI %FI END; ! ! Zero the descriptor length and pointer fields. ! ! Zero the following descriptor fields: string[STR$H_LENGTH] = 0; ! string/data length string[STR$A_POINTER] = 0; ! string pointer / data address IF .string[STR$B_CLASS] EQL STR$K_CLASS_B OR ! .string[STR$B_CLASS] EQL STR$K_CLASS_DB ! THEN ! BEGIN ! string[STR$H_MAXLEN] = 0; ! maximum string/data length string[STR$H_PFXLEN] = 0; ! prefix length END; $XPO_QUIT( NORMAL ); ! Indicate successful storage deallocation. ! ! XPORT routine termination. ! $XPO_MAIN_END; ! Terminate MAIN_BLOCK. $XPO_ACTION_RTN( desc[$BASE] ); ! Call a success or failure action routine. ! ! Return the final completion code to the caller. ! RETURN .primary_code ! Return the final completion code to the caller. END; END ELUDOM