Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

	SEARCH	FORPRM
	TV	EXTEND	Calls routines with large arrays as arguments,7(0)
	SUBTTL	Alan H. Martin/AHM		1-Nov-82

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1982,1983

;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.

;This software is provided for informational purposes only, and is not
;supported by Digital.  Furthermore, Digital makes no claim that  this
;software will ever be supported in the future.

;                        ***** WARNING *****

;You must be running a KL  microcode later than version 275 (which  is
;the current field image  version for Tops-20 releases  5 and 5.1)  in
;order to use these routines; many instructions used by FOROTS rely on
;changes to the  microcode which will  only be available  in the  next
;release.  Unpredictable  results will  occur if  FOROTS is  run in  a
;non-zero section  with microcode  version 275.   Various routines  in
;FORLIB will exhibit  similar problems.  Some  features that may  have
;problems include formatted  I/O, character  data operations,  ENCODE,
;DECODE and internal files.

;Also, note that  EXTEND will only  work on an  Extended KL10  running
;TOPS-20, and that certain things  (particularly FORDDT, DBMS and  the
;DUMP subroutine) do not work with it.

	SALL			;Suppress nasty macro expansions
	.DIRECTIVE SFCOND	;Suppress listing of failing conditionals
	.DIRECTIVE FLBLST	;List first line of binary data only

COMMENT \

***** Begin Revision History *****

***** Begin Version 7 *****

0	AHM	1-Nov-82
	Create EXTEND

***** End Revision History *****

\

COMMENT |
EXTEND.HLP -- Help file for EXTEND Version 7		February 1983

        Routines for using large arrays from Fortran programs


Fortran programs can manipulate arrays containing more than 256K words
of data.  Such arrays (called "large" arrays) cannot be declared local
to program units, or declared in COMMON blocks.  They must be  created
by a system subroutine named EXTEND and passed as arguments to all  of
the subprograms that must manipulate them.  To call a subroutine which
requires large  arrays, you  must call  EXTEND with  an argument  list
which includes the name of your subroutine that you want to be invoked
with large arrays  as arguments.   EXTEND will create  the arrays  and
then call the subroutine.   When that routine  returns to EXTEND,  the
arrays are discarded and control returns to the caller of EXTEND.

Before you can use large arrays, you have to initialize the subroutine
package.  Do this by:

	CALL EXTINI

Also, if SORT is going  to be called after  the call to EXTINI,  there
must be a CALL SORT(' ') before  the call to EXTINI.  This makes  SORT
allocate a non-zero section for itself.

If your subroutine requires arguments in addition to the large arrays,
append them to the argument list for the call to EXTEND.  They will be
passed to the subroutine.  This is what a call to EXTEND looks like:

	CALL EXTEND(SUBRTN,N, SCALAR1,SIZE1,...,SCALARN,SIZEN, ARG1,...,ARGm)

is a call to the EXTEND routine with m+2N+2 arguments, where:

SUBRTN		Is the name of a Fortran subroutine to call using the N
		large arrays, N array sizes and m extra values (ARG1...ARGm)
		as arguments.  SUBRTN should be declared to be EXTERNAL.

N		Is the number of large arrays to generate.

SCALAR1, . . .	Are N scalar variables of the same type as the array elements
SCALARN,	in large array arguments to SUBRTN.  Note that a CHARACTER
		variable must be of the desired length for the elements of the
		corresponding array.

SIZE1, . . .	Are N scalars of type INTEGER which give the number of elements
SIZEN		in the large arrays.  These arguments are passed on to SUBRTN
		for use in adjustable array dimension declarations.

ARG1, . . .	Are "m" arguments of any type which are passed on to SUBRTN
ARGm		following the N large array arguments.

The EXTEND subroutine performs a call to SUBRTN that looks like this:

	CALL SUBRTN(ARRAY1,SIZE1,...,ARRAYN,SIZEN, ARG1,...,ARGm)


Consider the following program for example:

	PROGRAM BIG
	REAL A,XVEC(10)
	DOUBLE PRECISION B,EPS
	CHARACTER C*132,CARD*80
	EXTERNAL FOO
	CALL EXTINI
	CALL EXTEND(FOO,3, A,1000000,B,1000000,C,100000, XVEC,EPS,CARD)
	END

It will allocate an array of 1000000 real numbers (call it ARRAYA), an
array of 1000000  double precision  numbers (ARRAYB) and  an array  of
100000 132 character long  strings (ARRAYC).  It will  appear as if  a
Fortran subroutine named EXTEND was called which looks like this:

	SUBROUTINE EXTEND(XVEC,EPS,CARD)
	REAL ARRAYA(1000000),XVEC
	DOUBLE PRECISION ARRAYB(1000000),EPS
	CHARACTER ARRAYC(100000)*132,CARD*80
	CALL FOO(ARRAYA,1000000,ARRAYB,1000000,ARRAYC,100000,
	1 XVEC,EPS,CARD)
	END


Note that if the program is not started in a non-zero section,  FOROTS
may fail in an  unpredictable manner.  EXTEND  will abort the  program
rather than let execution continue.  One way to make the program start
in a non-zero section is to:

@LOAD FOO.FOR,EXTEND.REL	; Get a core image with code in section 0
@SAVE FOO.EXE			; Create .EXE file with code in section 0
@GET FOO.EXE/USE-SECTION:1	; Get a core image with code in section 1
@SAVE FOO.EXE			; Create .EXE file with code in section 1

If EXTEND is on a system area (say, SYS:), then the first command is:

@LOAD FOO.FOR,SYS:EXTEND.REL

See your system administrator to find out where EXTEND.REL is.

You must be running  a KL microcode later  than version 275 (which  is
the current field  image version for  Tops-20 releases 5  and 5.1)  in
order to use EXTEND.
|

	SUBTTL	Definitions

; Argument block offsets

; Offsets from the beginning of the arg block

	SUBRTN==0		;Address of routine to call
	N==1			;Number of generated arrays
	ARRAYS==2		;Beginning of 2N arguments that give the
				; types of the generated array elements

; Relative position of generated array types and sizes

	TYPE==0			;First item is the scalar for the type
	SIZE==1			;Second item is the integer size

; Private ACs

	I==U			;Pointer to indirect words
	LL==D			;Copy of incoming arg block pointer
	A==F			;Address of arg block being created

; Random symbols

	EXTERN	FUNCT.		;OTS core manager entry point
	EXTERN	ABORT.		;Subroutine to return control to
				; the operating system on errors

	SM%RWX==SM%RD!SM%WR!SM%EX ;Read, write and execute access to a whole
				 ; section - MONSYM should get this some day

	NSEC==40		;Number of sections to search.

	SUBTTL	Tops-10 error message code

IF10,<
	HELLO	(EXTINI)
	JRST	EXTFEH

	HELLO	(EXTEND)
EXTFEH:	PUSHJ	P,F.EN1		;We can't do anything on TOPS-10 - complain
	JRST	ABORT.		; and die

	$FERR (?,EN1,21,0,<EXTEND is not implemented on TOPS-10>)
> ; End of IF10

IF20,<
	SUBTTL	Variables

	SEGMENT	DATA		;Down to the low segment

; Note that starred (;*;) variables are stored on the stack around the
; call to the user's routine in case EXTEND is called recursively.

; Two tables describing chunks of free core

CHUNKS:	BLOCK	1		;Holds -# of chunks,,0
FREADR:	BLOCK	NSEC		;The number of words available in each chunk
FRESIZ:	BLOCK	NSEC		;Address of first free location in each chunk

; A table describing what sections were created and must be  discarded
; upon exit from EXTEND.

RETPTR:	BLOCK	1		;Pointer to first free entry in RETARG
RETORG:	BLOCK	1	;*;	;Contents of RETPTR at routine entry
RETARG:	BLOCK	NSEC		;SMAP% args to discard sections we create
				;(number of sections,,first section)

; Random scalars

ARGN:	BLOCK	1	;*;	;Number of pass along arguments
ARGLST:	BLOCK	1	;*;	;Holds the address of the argument list
				; being constructed
ROUTIN:	BLOCK	1		;Holds address of user's routine to call

; FUNCT. arguments

FNOPC:	BLOCK	1		;Holds opcode for FUNCT. calls
FNSTS:	BLOCK	1		;Holds status upon return fron FUNCT. calls
FNARG1:	BLOCK	1		;First argument for FUNCT.
FNARG2:	BLOCK	1		;Second argument for FUNCT.

	SEGMENT	CODE		;Up to the high segment

	SUBTTL	EXTINI - Global initialization entry point

; EXTINI - subroutine to initialize some global OWN variables
; Call:
;	XMOVEI	L,ZERARG
;	PUSHJ	P,EXTINI
; Return: always
; RETPTR/	Address of first free location in SMAP% argument save area
; FREADR through FREADR+NSEC-1/	Address of first free word in each chunk
; FRESIZ through FRESIZ+NSEC-1/	Number of free words in each chunk

	HELLO	(EXTINI)

	XMOVEI	T1,0		;Get the section local address of AC 0
	JUMPN	T1,EXTI.1	;Is it 1,,0 ?  If not, we are in section 0

; Note that CALL  EXTEND will not  work if FOROTS  was initialized  in
; section 0 because FOROTS stores addresses of some section local data
; structures as 30  bit numbers  and so can  get very  confused if  an
; address is stored with a section number of 0 and fetched when we are
; no longer running in section 0.

	PUSHJ	P,F.ES0		;No, complain
	JRST	ABORT.		; and die

	$FERR (?,ES0,21,0,<EXTINI called in section 0 - RUN /USE-SECTION:1>)

EXTI.1:	XMOVEI	T1,RETARG	;Point to the SMAP% return section arg table
	MOVEM	T1,RETPTR	;Save it for later use

; Set up the chunk tables.  First we look for a free section.

	MOVSI	T3,-NSEC	;Set up an AOBJN counter for the sections
	SETZ	T4,		;Point to the first chunk
EXTI.2:	MOVEI	T1,0(T3)	;Look at the next section
	HRLI	T1,.FHSLF	; in our fork
	RSMAP%			;Ask the monitor for info
	 $FJCAL	IJE,ABORT.	;Shouldn't happen
	AOJN	T1,EXTI.5	;Is this section free ?
	HRLZM	T3,FREADR(T4)	;Yes, save chunk origin

	MOVEI	T0,1		;At least one free section, look for more
EXTI.3:	AOBJP	T3,EXTI.4	;Is there a section after this one?
	MOVEI	T1,0(T3)	;Yes, look at it
	HRLI	T1,.FHSLF	; in our fork
	RSMAP%			;Ask the monitor for info
	 $FJCAL	IJE,ABORT.	;Shouldn't happen
	AOSN	T1		;Is it free ?
	 AOJA	T0,EXTI.3	;Yes, tally it and look at the next section

EXTI.4:	HRLZM	T0,FRESIZ(T4)	;No, save away the size of this chunk in words
	ADDI	T4,1		;Move chunk pointer
EXTI.5:	AOBJN	T3,EXTI.2	;No, go check the next section

	MOVN	T4,T4		;Get the negative number of chunks
	HRLZM	T4,CHUNKS	;Save away as an AOBJN pointer

; If section 1 is a data section, then we must ask for 20 locations to
; avoid using the ACs as part of  a large array.  Note that this  will
; prevent us from ever returning section 1 to the monitor.

	MOVEI	T1,20		;We may have to steal the non-zero section ACs
	MOVS	T2,FREADR+0	;Look at the first chunk
	CAIN	T2,1		;Does it start at 1,,0 ?
	 PUSHJ	P,GETWRD	;Yes, steal some core
	GOODBYE			;Done initializing things

	SUBTTL	Top level routine for EXTEND

	HELLO	(EXTEND)

	PUSHJ	P,INIT		;Set up ARGN, ARGLST, etc.

	PUSHJ	P,ALCARG	;Get SUBRTN's argument list from the heap

	PUSHJ	P,GENARY	;Generate all of the necessary large arrays

	PUSHJ	P,COPARG	;Copy over all of the pass along arguments

	PUSHJ	P,CALLEM	;Call the user's routine

	PUSHJ	P,RETCOR	;Free arg list, EFIWs and extra sections

	GOODBYE

	SUBTTL	INIT - subroutine to initialize ROUTIN, ARGN and RETORG

; INIT - subroutine to initialize ROUTIN, ARGN and RETORG
; Call:
;	PUSHJ	P,INIT
; Return: always
; ROUTIN/	Address of user routine to call with large array arguments
; ARGN/		Number of pass along arrays

INIT:	SKIPN	T1,RETPTR	;Get the first available location in RETARG
	 JRST	INIWRN		;CALL EXTINI sets RETPTR, too bad user didn't
	MOVEM	T1,RETORG	;Remember it for later
	XMOVEI	T1,@SUBRTN(L)	;Get the address of the user's routine
	MOVEM	T1,ROUTIN	;Save it for later use
	SKIPN	(T1)		;Is the first word of the routine non-zero ?
	 JRST	RERR		;No, user forgot his EXTERNAL declaration
	SKIPGE	T1,@N(L)	;Get the number of pass along args
	 JRST	NERR		;Negative number - yell at user
	MOVEM	T1,ARGN		;Save it away
	POPJ	P,

INIWRN:	PUSHJ	P,F.CEN		;Complain,
	FUNCT	(EXTINI,<>)	; initialize
	JRST	INIT		; and try again
	$FERR (%,CEN,21,0,<CALL EXTINI was not done before CALL EXTEND>)

NERR:	PUSHJ	P,F.NNA		;Complain,
	JRST	ABORT.		; and die
	$FERR (?,NNA,21,0,<Negative number of large arrays in CALL EXTEND>)

RERR:	PUSHJ	P,F.MED		;Complain,
	JRST	ABORT.		; and die
	$FERR (?,MED,21,0,<Missing EXTERNAL declaration in CALL to EXTEND>)

	SUBTTL	ALCARG - Get new arg list from the heap

; ALCARG - subroutine to allocate the argument list
; Call:
;	PUSHJ	P,ALCARG
; Return: always
; A, ARGLST/	Pointer to new argument list, complete with count word set up

ALCARG:

; First we compute M+2N so that we know how much core to allocate  for
; the arg list.

	HLRE	T1,-1(L)	;Get the negative of the total
				; number of our arguments
	MOVN	T1,T1		;Convert total to positive number
	SUBI	T1,2		;Exclude SUBRTN and N from the count

; Now figure out how big an argument list to dynamically allocate.  If
; there are any  arguments for SUBRTN,  we need a  word for each  pass
; along argument (M), a word for  each generated argument (N), a  word
; for each large array size (N) and  a word for the count, or  M+2N+1.
; If there are  no arguments, then  we need  two words -  one for  the
; count, and  one for  the  empty arg  block  which allows  people  to
; reference 0(L) without an ill mem ref.

	SKIPE	T3,T1		;Is M+2N equal to 0 ? (Stash it away for later)
	 AOSA	T1		;No, T1 gets M+2N+1
	  MOVEI	T1,2		;Yes, get room for count and idiot phantom arg
	MOVEM	T1,FNARG2	;Save the size for the call
	PUSHJ	P,ALLOC		;Go get some core
	AOS	A,FNARG1	;Fetch address+1
	MOVEM	A,ARGLST	;Save it away
	MOVN	T3,T3		;Negate the arg list's count word
	HRLZM	T3,-1(A)	; and save it away (-size,,0)
	POPJ	P,		;Done allocating the arg block

	SUBTTL	GENARY - Generate large arrays in the free sections

; GENARY - subroutine to generate large arrays in the free sections
; Call:
; A/	Address of first word in new argument list for generated arguments
; ARGN/	Number of large arrays to generate
;	PUSHJ	P,GENARY
; Return: always
; A/	Address of word in new arg list after generated arrays
; LL/	Address of word in old arg list after generated arrays
; Destroys I

GENARY:	MOVN	LL,ARGN		;Get the negative number of large arrays
	HRLZ	LL,LL		;Make an AOBJN pointer into the old arg block
	HRRI	LL,ARRAYS(L)	;Point to the beginning of the scalars
	JUMPGE	LL,GENXIT	;Are there any arrays to generate ?
				;Yes, allocate them

ARYLUP:	LDB	T2,[POINTR(TYPE(LL),ARGTYP)] ;Get this scalar's type
	MOVEI	T1,1		;Assume it is numeric - we need 1 indirect word
	CAIN	T2,TP%CHR	;Is it character?
	 MOVEI	T1,2		;Yes, need 2 word character descriptor
	MOVEM	T1,FNARG2	;Save the size for the call
	PUSHJ	P,ALLOC		;Go get some core
	HRRZ	I,FNARG1	;Fetch its address
	TXO	I,<IFIW>	;Make a local indirect and index word (heh heh)
	DPB	T2,[POINTR(I,ARGTYP)] ;Drop off the arg type
	CAIE	T2,TP%CHR	;Are we playing with characters?
	 JRST	NOTCHR		;No, go hack numerics

	XMOVEI	T2,@TYPE(LL)	;Get the address of the character descriptor
	SKIPG	T1,1(T2)	;Get the element length
	 JRST	BCAERR		;Not positive - bad character argument
	MOVEM	T1,1(I)		;Save it away
	SKIPG	T2,@SIZE(LL)	;Fetch the number of elements desired
	 JRST	INEERR		;Tell ninny he has illegal number of elements
	IMUL	T1,T2		;Multiply by number of elements
	ADDI	T1,4		;Round up ahead of time
	IDIVI	T1,5		;Convert from characters to words
	PUSHJ	P,GETWRD	;Find a place for the array
	TXO	T1,IFOWG	;Make the address into a OWGBP
	JRST	ARYFIN		;Go store it and set up the arg block word

NOTCHR:	SKIPG	T1,@SIZE(LL)	;Get the array size
	 JRST	INEERR		;Illegal number of elements
	TRNE	T2,10		;High order bit set in arg type ?
	 LSH	T1,1		;Yes, DP data type, multiply size by 2
	PUSHJ	P,GETWRD	;Find a place for the array
	TXO	I,<@>		;Numeric args use indirection

ARYFIN:	MOVEM	T1,0(I)		;Save the address away
	MOVEM	I,TYPE(A)	;Store the "array" argument word
	MOVE	T1,SIZE(LL)	;Get the arg block word for the size
	MOVEM	T1,SIZE(A)	;Copy it over
	ADDI	LL,1		;Allow for the fact that each large array
	ADDI	A,2		; takes two arguments to describe
	AOBJN	LL,ARYLUP	;Go back for more arguments

GENXIT:	POPJ	P,		;Done with the large arrays

BCAERR:	PUSHJ	P,F.BCA		;Complain,
	JRST	ABORT.		; and die

	$FERR (?,BCA,21,0,<Bad character argument in CALL EXTEND>)

INEERR:	PUSHJ	P,F.INE		;Complain,
	JRST	ABORT.		; and die

	$FERR (?,INE,21,0,<Illegal number of array elements in CALL EXTEND>)

	SUBTTL	COPARG - Copy over the pass along arguments to the new arg list

; COPARG - subroutine to copy over the pass along arguments to the new arg list
; Call:
; ARGN/	Number of generated arrays
; A/		Address of place to put first pass along argument in new list
; LL/		Address of first pass along argument in user's list
;	PUSHJ	P,COPARG
; Return: always

COPARG:	HLRE	T1,-1(L)	;Get the negative of our argument count
	MOVN	T1,T1		;Positivize it
	MOVE	T2,ARGN		;Get the number of generated arrays
	LSH	T2,1		;Generated arrays use two argumants each
	SUBI	T1,2(T2)	;Don't count generated arrays, "SUBRTN" and "N"
	JUMPE	T1,COPA.1	;Are there any generated arguments ?
				;Yes, set up for BLT

	HRRZ	T2,A		;Destination is our arg list
	ADD	T1,T2		;Compute end of args to copy
	HRL	T2,LL		;Source is the user's arg list
	BLT	T2,-1(T1)	;Move things around

COPA.1:	POPJ	P,		;Done with the pass along arguments

	SUBTTL	CALLEM - Call the user's routine

; CALLEM - subroutine to call the user's routine
; Call:
; ARGN/		Number of generated arrays
; ARGLST/	Address of first word in generated argument list
; ROUTIN/	Address of routine to call
;	PUSHJ	P,CALLEM
; Return: always, save the following variables in case of a recursive call:
; ARGN/		Number of generated arrays
; ARGLST/	Address of first word in generated argument list

CALLEM:	PUSH	P,ARGN		;Save the number of generated arrays
	PUSH	P,ARGLST	;Save the address of the user's arg list
	PUSH	P,RETORG	;Save the first location we used

	XMOVEI	L,@ARGLST	;Point to the arg list
	PUSHJ	P,@ROUTIN	;Call the user's routine

	POP	P,RETORG	;Restore our old RETARG origin
	POP	P,ARGLST	;Restore the address of the user's arg list
	POP	P,ARGN		;Restore the number of generated arrays
	POPJ	P,		;Return to the main line code

	SUBTTL	RETCOR - Return our arg list, indirect words and extra sections

; RETCOR - subroutine to return our arg list, indirect words and extra sections
; Call:
; ARGN/		Number of generated arrays
; ARGLST/	Address of first word in generated argument list
; RETPTR/	Address of first unused word in SMAP% argument save area
;	PUSHJ	P,RETCOR
; Return: always
; Destroys A

RETCOR:	MOVN	A,ARGN		;Get the negative number of generated arrays
	JUMPGE	A,RETC.2	;Any arrays?  If so, free up indirect words
	HRLZ	A,A		;No, put count in left half
	HRR	A,ARGLST	;Yes, there are, point to the arg list

RETC.1:	HRRZ	T1,0(A)		;Point to the indirect word
	MOVEM	T1,FNARG1	;Save it away for the call
	LDB	T2,[POINTR (TYPE(A),ARGTYP)] ;Get the data type
	MOVEI	T1,1		;Assume array is numeric and has an EFIW
	CAIN	T2,TP%CHR	;Is it type character ?
	 MOVEI	T1,2		;Yes, two word descriptor to return
	MOVEM	T1,FNARG2	;Save away the size
	PUSHJ	P,FREE		;Go return some core
	ADDI	A,1		;Account for the size arg
	AOBJN	A,RETC.1	;Loop back for the rest of the args

RETC.2:	SOS	T1,ARGLST	;Point to the start of the arg list
	HRRZM	T1,FNARG1	;Save it away for the call
	HLRE	T1,0(T1)	;Get the size word
	SKIPE	T1		;Is it zero length ?
	 SOSA	T1		;No, allow for the count word itself
	  MOVNI	T1,2		;Yes, it is actually two words long
	MOVNM	T1,FNARG2	;Save size for call
	PUSHJ	P,FREE		;Free up the arg list

	MOVE	T4,RETORG	;Point to start of table
	MOVE	T1,T4		;Make copy for storing
	SUB	T4,RETPTR	;Subtract first free to get negative count
	MOVEM	T1,RETPTR	;Restore our old limit
	JUMPE	T4,RETC.4	;Are there any sections to return ?
	HRLZ	T4,T4		;Yes, put AOBJN count in left half of AC
	HRR	T4,RETORG	;Point to the start of our arguments
	SETO	T1,		;Tell Tops-20 we want to destroy sections

RETC.3:	MOVE	T2,0(T4)	;Get count,,section number
	HLRZ	T3,T2		;Put count in right place
	HRLI	T2,.FHSLF	;Say we mean our fork
	SMAP%			;Return the sections
	 $FJCAL	IJE,ABORT.	;Should never happen
	AOBJN	T4,RETC.3	;Loop back for other sections
RETC.4:	POPJ	P,		;All done - return to main line code

	SUBTTL	GETWRD - Get n words of core, where n is large

; GETWRD - subroutine to search for free core
; Call:
; T1/	Number of words needed (can be bigger than a section)
;	PUSHJ	P,GETWRD
; Return: always
; T1/	Address of allocated core

; To allocate core, we first have to find the core in the chunk table.
; Just look for the first chunk with enough free words.

GETWRD:	MOVE	T4,CHUNKS	;Create AOBJN pointer for chunk table

GETW.1:	CAMG	T1,FRESIZ(T4)	;Does this chunk have enough free ?
	 JRST	GETW.2		;Yes, go take it
	AOBJN	T4,GETW.1	;No, try again
	PUSHJ	P,F.NFS		;No core left
	JRST	ABORT.
	$FERR (?,NFS,21,0,<Not enough free sections for CALL EXTEND>)

; T1/	Number of words needed
; T4/	-# chunks not ruled out,,# of chunk with enough space in it

; Now that we have found a  chunk with enough words available, we  may
; need to create some sections with an SMAP%.

GETW.2:	MOVS	T2,FREADR(T4)	;Get the section number of the first address
				; to be used into T2 (= lowest new section)
	TLZE	T2,-1		;Does it start on a section boundary ?
	 ADDI	T2,1		;No, round up

	MOVE	T3,T1		;Get amount needed in T3
	ADD	T3,FREADR(T4)	;Compute the last address used+1
	MOVS	T3,T3		;Get the section number in the right half of T3
	TLZE	T3,-1		;Ending on a section boundary ?
	 ADDI	T3,1		;No, round up

	SUB	T3,T2		;Get number of new sections (last-first)
	MOVN	T0,T1		;Save number of words needed, negate for later
	JUMPE	T3,GETW.3	;Don't SMAP% if there are no new sections

	MOVEM	T2,@RETPTR	;Save away the section number
	HRLM	T3,@RETPTR	; and the count
	AOS	RETPTR		;Point to the next location

	SETZ	T1,		;Say we have to create some sections
	HRLI	T2,.FHSLF	;Say that it is our process
	TXO	T3,SM%RWX	;Set our access attributes
	SMAP%			;Create some sections
	 $FJCAL	IJE,ABORT.	;Should never happen
	MOVN	T1,T0		;Restore the number of words needed

GETW.3:	ADDM	T0,FRESIZ(T4)	;Shrink the chunk
	EXCH	T1,FREADR(T4)	;Get chunk origin, save amount used
	ADDM	T1,FREADR(T4)	;Account for what was used
	POPJ	P,		;Return to the caller with address in T1

	SUBTTL	ALLOC - Hide the uglyness of calling FUNCT. to get core

; ALLOC - subroutine to get section local heap space from FOROTS
; Call:
; FNARG2/	Number of words needed
;	PUSHJ	P,ALLOC
; Return: core is available
; FNARG1/	Address of allocated core

ALLOC:	PUSH	P,L		;Save our arg pointer
	PUSH	P,[FN%GOT]	;Get opcode for getting OTS heap space
	POP	P,FNOPC		;Save it in the arg block
	XMOVEI	L,FNARGL	;Point to the FUNCT. arg list
	PUSHJ	P,FUNCT.	; and call it
	POP	P,L		;Restore the old arg pointer

	SKIPN	FNSTS		;Did the FUNCT. win ?
	 POPJ	P,		;Yes, return to caller

	PUSHJ	P,F.NEC		;No, complain
	JRST	ABORT.		; and die

	$FERR (?,NEC,21,0,<Not enough OTS core for CALL EXTEND>)

	-FNARGN,,0
FNARGL:	IFIW	TP%INT,FNOPC	;Address of opcode
	IFIW	TP%LIT,[ASCII |EXT|] ; ?EXTxxx should be printed for errors
	IFIW	TP%INT,FNSTS	;Address of status variable
	IFIW	TP%INT,FNARG1	;First real argument
	IFIW	TP%INT,FNARG2	;Second real argument
	FNARGN==.-FNARGL

	SUBTTL	FREE - Hide the uglyness of calling FUNCT. to return core

; FREE - subroutine to return section local heap space to FOROTS
; Call:
; FNARG1/	Address of core being returned
; FNARG2/	Number of words being returned
;	PUSHJ	P,FREE
; Return: core has been deallocated

FREE:	PUSH	P,L		;Save our arg pointer
	PUSH	P,[FN%ROT]	;Get opcode for returning OTS heap space
	POP	P,FNOPC		;Save it in the arg block
	XMOVEI	L,FNARGL	;Point to the FUNCT. arg list
	PUSHJ	P,FUNCT.	; and call it
	POP	P,L		;Restore the old arg pointer

	SKIPN	FNSTS		;Did the FUNCT. win ?
	 POPJ	P,		;Yes, return to caller

	PUSHJ	P,F.CRC		;No, complain
	JRST	ABORT.		; and die

	$FERR (?,CRC,21,0,<Can't return OTS core after CALL EXTEND>)

> ; End of IF20

	END