Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50403/alloe.mac
There are no other files named alloe.mac in the archive.
TITLE ALLOC (Dynamic Core Allocation for Fortran Arrays) Raffa Edwards
SUBTTL Accumulator & Compile Definitions
; A COLGATE UNIVERSITY REWRITE OF DECUS 10-120 DYNAM JAN, 1975
;
T0=0
T1=1
ARY=3
CNT=4
WRD=5
CK=6
DP=7
SVDP=10
FUNCT=11
N=16
P=17
LFHALF=777777
ENTRY DYNDIM,SETJFF,DESTRY,SETLNK,LINK
EXTERN .JBFF,.JBREL,.JBHRL,.JBSA
IFDEF %ARG,<DYNDSK=%ARG>
IFNDEF DYNSTK,<DYNSTK=^D50>
IFNDEF FORTYP,<FORTYP=0>
; -1 - FORTRAN-40
; 1 - FORTRAN-10
; 0 - BOTH
IFNDEF FORSE,<FORSE=0>
; 0 - FOROTS AND OLD FORSE HIGH SEGMENTS
; 1 - FOROTS HIGH SEGMENT ONLY
IFDEF %VAR,<CORERR=1>
IFNDEF CORERR,<CORERR=0>
; 0 - OUTPUT CORE ERROR MESSAGE
; 1 - RETURN NEGATIVE # FREE WORDS
IF1 <
IFGE FORTYP,<
PRINTX FORTRAN-10
>
IFLE FORTYP,<
PRINTX FORTRAN-40
>
IFN FORSE,<
PRINTX FOROTS HIGH SEGMENT ONLY
>>
SUBTTL Macro Definitions and Data
SALL
DEFINE .HI.,<
IFL FORTYP,<
Z
>
IFE FORTYP,<
CAIA
PUSH P,CEXIT
>>
DEFINE .BYE.,<
IFL FORTYP,<
JRA N,(N)
>
IFGE FORTYP,<
POPJ P,
>>
DEFINE .HELLO.,<
IFL FORTYP,<
Z
PUSHJ P,JSAENT
>
IFE FORTYP,<
PUSHJ P,PSHENT
PUSHJ P,JSAENT
>
IFG FORTYP,<
PUSHJ P,PSHENT
>>
FREG: Z ;ARGUMENT STACK POINTER
IFGE FORTYP,<
ARGCNT: Z ;ARGUMENT COUNT
>
SUBTTL DYNDIM (Core Allocation)
COMMENT %
CALLING SEQUENCE:--
CALL DYNDIM(VARABL,WORDS,ERRFLG,ZERCOR)
VARABL ::= ADDRESS OF DYNAMIC ARRAY
WORDS ::= NUMBER OF WORDS FOR ARRAY
ERRFLG ::= ERROR FLAG (0 IF SUCCESSFUL)
ZERCOR ::= OPTIONAL CORE ZEROING CONTROL
(IF ISN'T PRESENT OR EQUAL TO ZERO
ARRAY WILL BE ZEROED)
%
DYNDIM::
.HI. ;ENTRY
SKIPG WRD,@1(N) ;GET NUMBER WORDS AND CHECK ARGUMENT
JRST ILLSPC ; -- NEGATIVE OR ZERO ARGUMENT!
MOVE ARY,.JBFF## ;SAVE .JBFF
PUSHJ P,GETCOR ;GET CORE FOR DYNAMIC ARRAY
JRST NOCORE ; -- CAN'T GET IT!
MOVEM ARY,@(N) ;RETURN ADDRESS OF ARRAY
SETZM @2(N) ;CLEAR ERRFLG
MOVE CK,3(N) ;IS THERE AN
PUSHJ P,CHKARG ; ARGUMENT FOR ZERCOR ?
JRST CLEAR ; -- NO ZERO ARRAY SPACE
SKIPE (CK) ; -- YES, IS IT ZERO ?
.BYE. ; -- NO, RETURN!
CLEAR: SETZM (ARY) ;ZERO
HRLS ARY ; ARRAY
AOJ ARY, ; SPACE
BLT ARY,@.JBFF##
.BYE. ;RETURN
SUBTTL DYNDIM Error Handling
ILLSPC: TTCALL 3,[ASCIZ/
? DYNDIM ERROR (Zero or Negative Word Count)
/] ;OUTPUT ERROR MESSAGE
MOVEI T0,1 ;SET ERROR
MOVEM T0,@2(N) ; FLAG
.BYE. ;RETURN
NOCORE: SETOM @2(N) ;SET ERROR FLAG
IFE CORERR,<
TTCALL 3,[ASCIZ/
? DYNDIM ERROR (Insufficient Core Available)
/] ;OUTPUT ERROR MESSAGE
>
IFN CORERR,<
HRRZ T1,.JBHRL## ;IS THERE A HIGH SEGMENT ?
JUMPE T1,NCORE ; -- NO, CONTINUE WITH CALCULATIONS
SUBI T1,377777 ; -- YES, CALCULATE
LSH T1,-12 ; IT'S CORE SIZE
SUB T0,T1 ; -- SUBTRACT IT FROM AVAILABLE CORE
NCORE: LSH T0,12 ;CONVERT K TO WORDS
SUB T0,.JBFF## ;SUBTRACT NUMBER OF USED WORDS
SOJ T0, ;RESCALE (WE START AT ZERO)
SKIPE T0 ;IF ZERO FORGET IT
MOVNM T0,@2(N) ;RETURN NEGATIVE NUMBER OF FREE WORDS
>
.BYE. ;RETURN
SUBTTL SETJFF (Saving and Restoring of .JBFF)
COMMENT %
CALLING SEQUENCE:--
CALL SETJFF(NCOR,IRES)
NCOR ::= .JBFF SAVING (RESETING) VARIABLE
IRES ::= OPTIONAL CORE CONTROL
(IF ISN'T PRESENT OR EQUAL TO ZERO
CORE SIZE WILL BE REDUCED ACCORDING)
%
SETJFF::
.HI. ;ENTRY
SKIPE T1,@(N) ;GET FIRST ARGUMENT
JRST RESET ;IF NOT ZERO RESET .JBFF
MOVE T1,.JBFF## ;GET FIRST FREE LOCATION
MOVEM T1,@(N) ;SAVE IT
.BYE. ;RETURN
RESET: MOVEM T1,.JBFF## ;RESET .JBFF (FIRST FREE LOCATION)
MOVE CK,1(N) ;IS THERE A
PUSHJ P,CHKARG ; SECOND ARGUMENT ?
JRST REDUCE ; -- NO, REDUCE CORE REQUIREMENTS
SKIPE (CK) ;YES, IS IT ZERO ?
.BYE. ; -- NO, RETURN
REDUCE: CORE T1, ;YES, ALTER CORE SIZE
TTCALL 3,RESERR# ;SHIT!!!
.BYE. ;RETURN
RESERR: ASCIZ/
? SETJFF ERROR (Incapable of Reducing Core Size)
/
SUBTTL DESTRY (Prevention of Program Restarting)
COMMENT %
CALLING SEQUENCE:--
CALL DESTRY
%
DESTRY::
.HI. ;ENTRY
MOVEI T0,NOWAY ;GET NEW STARTING ADDRESS
HRRM T0,.JBSA## ;CHANGE OLD STARTING ADDRESS
.BYE. ;RETURN
NOWAY: TTCALL 3,[ASCIZ/
? This Program May Not Be Restarted
/] ;TELL HIM WHAT'S HAPPENING
JRST HELL ;RETURN TO MONITOR
SUBTTL SETLNK (Argument Stack Setup)
COMMENT %
CALLING SEQUENCE:--
CALL SETLNK(STKSIZ)
STKSIZ ::= NUMBER OF LOCATIONS FOR ARGUMENT STACK
%
SETLNK::
.HI. ;ENTRY
SKIPG WRD,@(N) ;GET STACK LENGTH
JRST ILSPC ;BOMB IF LESS THAN 1
PUSHJ P,MAKSTK ;SETUP ARGUMENT STACK
.BYE. ;RETURN
ILSPC: TTCALL 3,[ASCIZ/
? SETLNK ERROR (Zero or Negative Stack Argument)
/] ;TELL HIM WHAT'S HAPPENING
JRST HELL ;RETURN TO MONITOR
SUBTTL LINK (Recursive Subroutine Linkage)
COMMENT %
CALLING SEQUENCE:--
CALL LINK(IDYN,SUBPR,ARRAY1,...,ARG1,...)
IDYN ::= NUMBER OF DYNAMIC ARRAYS
SUBPR ::= SUBPROGRAM'S ADDRESS
ARRAYn ::= DYNAMIC ARRAYS
ARGn ::= NORMAL ARGUMENTS
%
LINK::
.HELLO. ;ENTRY
SKIPLE CNT,@(N) ;POSITIVE NUMBER OF DYNAMIC ARRAYS ?
JRST MAKARG ; -- YES, SETUP ARGUMENT LIST
JUMPL CNT,ILSPEC ;BOMB IF NEGATIVE
MOVE CK,2(N) ;ARE THERE ANY
PUSHJ P,CHKARG ; ARGUMENTS ?
JRST DISPAT ; -- NO, SKIP CONSTRUCTION OF ARGUMENT LIST
MOVEI CNT,2(N) ; -- YES,
JRST CPYARG ; CONSTRUCT ARGUMENT LIST
; CONSTRUCTION OF DYNAMIC ARRAY ARGUMENT LIST
MAKARG: MOVNS CNT ;SETUP POINTER AND
HRLS CNT ; COUNTER TO
HRRI CNT,2(N) ; LINK'S ARGUMENT LIST
MKARG: HLLZ CK,(CNT) ;GET ARRAY'S TYPE
HRR CK,@(CNT) ;GET ARRAY'S LOCATION
PUSHJ P,CHKARG ;IS THE ARGUMENT OK ?
JRST ARYERR ; -- NO, THE DUMMY BLEW IT!!
JSP T1,PUTARG ;ADD ARGUMENT TO ARGUMENT LIST
IFGE FORTYP,<
AOS ARGCNT# ;UPDATE ARGUMENT COUNT
>
AOBJN CNT,MKARG ;ANY ARGUMENTS LEFT ?
; CONSTRUCTION OF NORMAL ARGUMENT LIST
CPYARG: MOVE CK,(CNT) ;ARE THERE
PUSHJ P,CHKARG ; ANY ARGUMENTS ?
JRST DISPAT ; -- NO, DISPATCH TO ROUTINE
JSP T1,PUTARG ;ADD ARGUMENT TO ARGUMENT LIST
IFGE FORTYP,<
AOS ARGCNT# ;UPDATE ARGUMENT COUNT
>
AOJA CNT,CPYARG ;GO CHECK FOR ANOTHER ARGUMENT
; TRANSFER CONTROL TO ROUTINE WITH MODIFIED ARGUMENT LIST
DISPAT: PUSHJ P,(FUNCT) ;SETUP ENTRY SPECIFIC DISPATCHING ARGUMENTS
MOVE CK,FREG# ;SAVE OLD ARGUMENT
JSP T1,PUTARG ; STACK POINTER
MOVEM DP,FREG# ;UPDATE ARGUMENT STACK POINTER
JRST (CK) ;TRANSFER CONTROL
SUBTTL Link's "PUSHJ" Entry Handling Routines
IFGE FORTYP,<
PSHENT: SKIPN DP,FREG# ;IS ARGUMENT STACK SETUP ?
PUSHJ P,DFLSTK ; -- NO, SET IT UP
MOVSI CK,(PUSHJ P,) ;SETUP
HRR CK,1(N) ; SUBROUTINE CALL
JSP T1,PUTARG ;-- PUSHJ P,ROUTINE --
MOVE CK,[JRST PSHEXT] ;SETUP EXIT
JSP T1,PUTARG ; DISPATCH
SETZB CK,ARGCNT ;CLEAR ARGUMENT COUNT
MOVE SVDP,DP ;SAVE A LOCATION
JSP T1,PUTARG ; FOR ARGUMENT COUNT
MOVEI FUNCT,PSHDSP ;SETUP DISPATCHING ROUTINE
IFE FORTYP,<
AOS (P) ;SKIP RETURN??
>
POPJ P, ;RETURN
PSHDSP: MOVN T0,ARGCNT# ;SETUP
HRLZS T0 ; ARGUMENT COUNT
MOVEM T0,(SVDP) ;-- -ARG,,0 --
MOVE CK,N ;SAVE
JSP T1,PUTARG ; ARGUMENT AC
MOVEI N,1(SVDP) ;RESET ARGUMENT AC
POPJ P, ;RETURN
PSHEXT: MOVE DP,FREG# ;LOAD ARGUMENT STACK POINTER
MOVE N,-2(DP) ;RESTORE ARGUMENT AC
MOVE DP,-1(DP) ;RESTORE
MOVEM DP,FREG# ; OLD POINTER
POPJ P, ;RETURN TO MAIN
>
SUBTTL Link's "JSA" Entry Handling Routines
IFLE FORTYP,<
JSAENT: SKIPN DP,FREG# ;IS ARGUMENT STACK SETUP ?
PUSHJ P,DFLSTK ; -- NO, SET IT UP
MOVSI CK,(JSA N,) ;SETUP
HRR CK,1(N) ; SUBROUTINE CALL
JSP T1,PUTARG ;-- JSA N,ROUTINE --
MOVE SVDP,DP ;SAVE ARGUMENT POINTER
MOVEI FUNCT,JSADSP ;SETUP DISPATCHING ROUTINE
POPJ P, ;RETURN
JSADSP: MOVE CK,[JRST JSAEXT] ;SETUP EXIT
JSP T1,PUTARG ; DISPATCH
MOVE CK,N ;SAVE
JSP T1,PUTARG ; ARGUMENT AC
MOVE CK,LINK ;SAVE ENTRY
JSP T1,PUTARG ; ADDRESS
MOVEI N,(SVDP) ;RESET ARGUMENT AC
POPJ P, ;RETURN
JSAEXT: MOVE DP,FREG# ;LOAD ARGUMENT STACK POINTER
MOVE T0,-2(DP) ;RESTORE
MOVEM T0,LINK ; ENTRY POINT
MOVE N,-3(DP) ;RESTORE ARGUMENT AC
MOVE DP,-1(DP) ;RESTORE
MOVEM DP,FREG# ; OLD POINTER
JRA N,(N) ;RETURN TO MAIN
>
SUBTTL Link's Error Routines
ILSPEC: TTCALL 3,[ASCIZ/
? LINK ERROR (Negative Dynamic Array Count)
/]
JRST HELL ;RETURN TO MONITOR
ARYERR: TTCALL 3,[ASCIZ/
? LINK ERROR (Incorrect Dynamic Array Count)
/]
JRST HELL ;RETURN TO MONITOR
STKOVF: TTCALL 3,[ASCIZ/
? LINK ERROR (Argument Stack Overflow)
/]
JRST HELL ;RETURN TO MONITOR
SKCORE: TTCALL 3,[ASCIZ/
? LINK ERROR (Insufficient Core Available to Setup Argument Stack)
/]
JRST HELL ;RETURN TO MONITOR
SUBTTL General Utility Routines
; CONSTRUCTION OF ARGUMENT STACK
DFLSTK: MOVEI WRD,DYNSTK ;LOAD DEFAULT STACK SIZE
MAKSTK: MOVN DP,WRD ;SETUP
HRLS DP ; IOWD
HRR DP,.JBFF## ; WORD
PUSHJ P,GETCOR ;GET CORE FOR STACK
JRST SKCORE ; -- CAN'T GET IT!!
MOVEM DP,FREG# ;SAVE POINTER FOR LATER USE
POPJ P, ;RETURN
; CORE ACQUIRING ROUTINE
GETCOR: MOVE T0,.JBFF## ;CALCULATE NEW
ADD T0,WRD ; CORE SIZE
TLNN T0,LFHALF ;LESS THAN 256K ?
JRST GTCOR1 ; -- YES, TRY TO GIVE IT TO HIM
SETZ T0, ; -- NO,
JRST GTCOR2 ; GREEDY!!!
GTCOR1: MOVE T1,T0 ;MAKE ANOTHER COPY OF CORE SIZE
CAMG T0,.JBREL## ;DO WE NEED MORE CORE ?
JRST GTCOR3 ; -- NO, JUST UPDATE .JBFF
GTCOR2: CORE T0, ;GET ADDITIONAL CORE
POPJ P, ; -- NO GO, CAN'T DO IT
GTCOR3: MOVEM T1,.JBFF## ;UPDATE .JBFF
AOS (P) ;SETUP
POPJ P, ; SKIP RETURN
; DETERMINES IF WORD IS A LEGAL FORTRAN ARGUMENT
CHKARG: TLNE CK,457037 ;CHECK FORTRAN-40
TLNN CK,777000 ;CHECK FORTRAN-10
AOS (P) ; -- YES, IT'S GOOD
POPJ P, ;RETURN
; ADDS ARGUMENT TO STACK AND CHECK FOR OVERFLOW
PUTARG: MOVEM CK,(DP) ;ADD ARGUMENT TO STACK
AOBJN DP,(T1) ;UPDATE POINTER
JRST STKOVF ; -- OVERFLOW!!
; RETURN USER TO MONITOR
HELL: EXIT 1, ;DUMP HIM
EXIT ; -- NOWAY!!
SUBTTL Special Exiting Routine
COMMENT %
THIS ROUTINE IS DEFINED IN FORLIB AND THEREFORE
ISN'T NECESSARY IF USED FOR FOROTS ONLY
%
IFN FORSE,<
IFE FORTYP,<
EXTERN CEXIT. ;GET ROUTINE
CEXIT=CEXIT.## ; FROM FORLIB
>>
IFE FORSE,<
IFE FORTYP,<
CEXIT: RETURN ;STACK ARGUMENT (STARTING ADDRESS)
RETURN: HLRM N,RESTOR ;GET LOCATION OF ADDRESS ACCUMULATOR
HRLI N,(CAIA) ;RESTORE ENTRY POINT
HRRM N,LEAVE ;SETUP RETURN ADDRESS
RESTOR: EXCH N, ;RESTORE ARGUMENT ACCUMULATOR
LEAVE: JRST ;RETURN
>>
LIT
END
*U*#(: