Trailing-Edge
-
PDP-10 Archives
-
fortv11
-
extend.mac
There are 2 other files named extend.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV EXTEND Calls routines with large arrays as arguments,11(2)
SUBTTL Alan H. Martin/Thomas G. Speer 15-Sep-86
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1982,1987
;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 *****************************
;* *
;* MOST USES OF EXTENDED ADDRESSING APPLICATIONS *
;* WILL REQUIRE A SUBSTANTIAL INCREASE IN SWAPPING *
;* SPACE ALLOCATION. *
;* *
;* FORDDT WILL NOT WORK IN NON-ZERO SECTIONS OR WHEN *
;* USED WITH A PROGRAM LOADED WITH EXTEND.REL. SUCH *
;* USES OF FORDDT ARE NOT SUPPORTED. *
;* *
;* NON-SECTION-ZERO CALLS TO SORT OR DBMS WILL NOT WORK *
;* AND ARE NOT SUPPORTED. *
;* *
;*********************************************************************
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 V7 Development *****
1 TGS 28-Jun-83
PURGE F.MED so it won't conflict with ERRSET in FORMSC if loaded
with EXTEND.REL
***** Begin V11 Development *****
2 TGS 1-Sep-86
Create TOPS-10 version of EXTEND
***** End Revision History *****
\
COMMENT |
EXTEND.HLP -- Help file for EXTEND Version 11 September 1986
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
This routine builds a map of available free sections for use by the
large arrays allocated in the call to EXTEND. Thus any application
which intends to reserve non-zero sections for other purposes must do
so before a call to EXTINI.
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
To load a program which calls EXTEND:
.LOAD FOO.FOR,SYS:EXTEND.REL
See your system administrator to find out where EXTEND.REL is.
|
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
MINARG==4 ;Minimum # of args in call to EXTEND
; 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
INTERN %EXTND ;FOROTS 0-to-1 section map switch
%EXTND==-1 ;Force non-zero OTS
NSEC==40 ;Number of sections to search.
SUBTTL TOPS-20 error message
IF20,<
HELLO (EXTINI)
JRST EXTNN2
HELLO (EXTEND)
EXTNN2: PUSHJ P,F.EN2 ;Use /EXTEND on TOPS-20
JRST ABORT.
$FERR (?,EN2,21,0,<Use /EXTEND on TOPS-20>)
> ;End IF20
IF10,<
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 ;PAGE. args to discard sections we create
;(number of pages,,first page)
RETEND==.-1
PAGBLK: BLOCK 2 ;PAGE. UUO argument block
VRTUAL: BLOCK 1 ;Set when we go virtual
; 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 PAGE. 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 PAGE. 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
LSH T1,^D9 ;Make a page number in that section
TLO T1,.PAGCA ;Page-access code
PAGE. T1, ;See if page/section exists
JRST PAGERR
TXNN T1,PA.GSN ;Does section exist?
JRST EXTI.5 ;Yes
HRLZM T3,FREADR(T4) ;No, 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
LSH T1,^D9 ;Make page number in section
TLO T1,.PAGCA
PAGE. T1,
JRST PAGERR
TXNE T1,PA.GSN ;Section exist?
AOJA T0,EXTI.3 ;No, 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
;If N.GE.0, there must be at least 4 arguments in the EXTEND call.
HLRE T1,-1(L) ;Get EXTEND arg count
MOVN T1,T1 ;Positive
CAIL T1,MINARG ;At least the minimum args?
POPJ P, ;Yes, OK
PUSHJ P,F.BXL ;No. Bad arglist for EXTEND
JRST ABORT.
$FERR (?,BXL,21,0,<Too few arguments in CALL EXTEND>)
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>)
IF2,< PURGE F.MED > ;[1]
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 PAGE. 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
RETC.3: HLRZ T1,(T4) ;Get total # pages in this chunk
MOVNM T1,PAGBLK ;Negative page count for PAGE.
HRRZ T1,(T4) ;Get first page # to destroy
MOVEM T1,PAGBLK+1 ;Tell PAGE. about it
MOVSI T1,(PA.GAF) ;Kill pages bit
HLLM T1,PAGBLK+1
MOVE T1,[.PAGCD,,PAGBLK]
PAGE. T1, ;Try to kill them
JRST PAGERR ;Should not fail
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
; need to pre-allocate some pages with a PAGE. UUO.
GETW.2: MOVE T2,FREADR(T4) ;Get 1st free location in this chunk
TRNE T2,777 ;Start on page boundary?
ADDI T2,1000 ;No, round up
LSH T2,-^D9 ;Get 1st page #
MOVE T3,T1 ;Get words needed in T3
ADD T3,FREADR(T4) ;Compute last address used+1
TRNE T3,777 ;Start on page boundary?
ADDI T3,1000 ;No, round up
LSH T3,-^D9 ;Get last page #
SUB T3,T2 ;Get number of new pages (last-first)
MOVN T0,T1 ;Save number of words needed, negate for later
JUMPE T3,GETW.3 ;Don't PAGE. if no new pages needed
HRLM T3,@RETPTR ;Save total # pages needed
MOVNM T3,PAGBLK ;and as negative count for PAGE.
HRRM T2,@RETPTR ;Save starting page #
MOVEM T2,PAGBLK+1
AOS T1,RETPTR ;Point to the next location for next time
MOVEI T1,(T1)
CAILE T1,RETEND ;Too many recursive levels?
JRST TOODEP ;Yes
CREPAG: MOVE T1,VRTUAL ;Get virtual bit (or 0)
HLLM T1,PAGBLK+1
MOVE T1,[.PAGCD,,PAGBLK]
PAGE. T1, ;Create the pages
JRST TRYVRT ;Can't, try to go virtual
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
TRYVRT: CAIN T1,PAGNX% ;Any privs to go virtual
JRST PAGERR ;No, give up
CAIE T1,PAGLE% ;"Core limit exceeded"?
JRST PAGERR ;No, something fatal
SKIPE VRTUAL ;Already went virtual?
JRST PAGERR ;Yes, page can't be created
MOVSI T1,(PA.GCD) ;Get virtual bit
MOVEM T1,VRTUAL ;Set for future calls
JRST CREPAG ;Go try again
;Here when too many recursive calls to EXTEND
TOODEP: PUSHJ P,F.TRC
JRST ABORT.
$FERR (?,TRC,21,0,<Too many recursive calls to EXTEND>)
SUBTTL - PAGE. UUO failure
;PAGERR - Come here to die when PAGE. fails
PAGERR: MOVE T1,PGERTB(T1) ;Translate the PAGE. error code
PUSHJ P,F.PGF ;Do the error
JRST ABORT.
$FERR (?,PGF,21,0,<PAGE. UUO failure - $A>,<T1>)
PGERTB: [ASCIZ/Function not implemented/] ;0
[ASCIZ/Illegal argument/] ;1
[ASCIZ/Illegal page number/] ;2
[ASCIZ/Page should not exist, but does/] ;3
[ASCIZ/Page should exist, but does not/] ;4
[ASCIZ/Page should be in core, but is not/] ;5
[ASCIZ/Page should not be in core, but is/] ;6
[ASCIZ/Page is in sharable high segment/] ;7
[ASCIZ@Paging I/O error@] ;10
[ASCIZ/No swapping space available/] ;11
[ASCIZ/Core limit exceeded/] ;12
[ASCIZ/Function illegal if page locked/] ;13
[ASCIZ/Cannot allocate 0 page with virtual limit 0/] ;14
[ASCIZ/Not enough privileges/] ;15
[ASCIZ/Section should not exist, but does/] ;16
[ASCIZ/Section should exist, but does not/] ;17
[ASCIZ/Illegal section/] ;20
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 IF10
END