Trailing-Edge
-
PDP-10 Archives
-
BB-H580E-SB_1985
-
srtcer.mac
There are 10 other files named srtcer.mac in the archive. Click here to see a list.
SUBTTL SRTCER - COBOL SORT ERROR ROUTINES
SUBTTL STOLEN FROM SCAN - D.M.NIXON/DZN/GCS 13-Apr-82
SEARCH COPYRT
;COPYRIGHT (C) 1975, 1985 BY DIGITAL EQUIPMENT CORPORATION
;ALL RIGHTS RESERVED
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
.COPYRIGHT
IFN FTPRINT,<PRINTX [Entering SRTCER.MAC]>
SUBTTL TABLE OF CONTENTS FOR SRTCER
; Table of Contents for SRTCER
;
;
; Section Page
;
; 1 SRTCER - COBOL SORT ERROR ROUTINES ...................... 1
; 2 TABLE OF CONTENTS FOR SRTCER ............................. 2
; 3 DEFINITIONS
; 3.1 Parameters From SCNMAC, etc. ...................... 3
; 3.2 Impure Data ....................................... 4
; 4 TYPE-OUT ROUTINES
; 4.1 Issue Standard Error Message Prefixes ............. 5
; 4.2 Return /MESSAGE: Setting .......................... 6
; 4.3 Type OPEN and LOOKUP/RENAME/ENTER Blocks .......... 7
; 4.4 Directory Block ................................... 8
; 4.5 Masked (Wild) Octal Word in XWD Format ............ 9
; 4.6 Disk Blocks, Memory Size .......................... 10
; 4.7 Time of Day in HH:MM:SS Format .................... 11
; 4.8 CRLF, PPN, ']', SIXBIT ............................ 12
; 4.9 Octal XWD Format and Signed Octal, Decimal, Radix . 13
; 4.10 ASCIZ String, Character, ' ' ',' ':' '*' ...... 14
; 5 .SAVE4 - SUBROUTINE TO SAVE P1-4 FOR A SUBROUTINE ........ 15
; 6 .PSH4T - SUBROUTINE TO SAVE T1-4 FOR A SUBROUTINE ........ 16 ;[500]
; 7 .POP4T - SUBROUTINE TO RESTORE T1-4 FOR A SUBROUTINE...... 16 ;[500]
SUBTTL DEFINITIONS -- Parameters From SCNMAC, etc.
IFN FTOPS20,<
;DEFINE BITS USED BY VERBOSITY CHECK
JWW.CN==1B9 ;/MESSAGE:CONTINUATION
JWW.FL==1B10 ;/MESSAGE:FIRST
JWW.PR==1B11 ;/MESSAGE:PREFIX
JW.WMS==JWW.CN+JWW.FL+JWW.PR ;/MESSAGE LEVEL
>
IFE FTOPS20,<
FT$SFD==-1 ;SFDS FOR SCAN
>
VRBADX==10 ;/MESSAGE:ADDRESS
SUBTTL DEFINITIONS -- Impure Data
SEGMENT IMPURE ;[c20]
.TNEWL==.TCRLF
.FLVRB: BLOCK 1 ;MASK,,SET OF /MESSAGE BITS
.FLCBF: BLOCK 1 ;FLAG TO CLEAR TYPEAHEAD
SUBTTL TYPE-OUT ROUTINES -- Issue Standard Error Message Prefixes
SEGMENT LPURE ;[C20]
;CALL: 1/ MODULE CODE (0=SYSTEM),,MESSAGE CODE IN SIXBIT
; 2/ (11) ??? (7) LEAD CHAR,,[ASCIZ TEXT]
; 3/ ???,,ADDRESS OF ERROR IF .ERMSA
; PUSHJ P,.ERMSG/.ERMSA
;RETURN +1 WITH 1/ LH(ARG 2),,/VERBOS BITS
;USES T2-4
.ERMSG: MOVEI T3,0 ;CLEAR ADDRESS
.ERMSA: PUSH P,T2 ;SAVE CONTROL BITS
PUSH P,T3 ;SAVE ADDRESS
PUSH P,T1 ;SAVE PREFIXES
HLRZ T1,T2 ;GET PREFIX CHARACTER
ANDI T1,177 ;MASK TO JUST LEAD CHARACTER
CAIN T1,"?" ;IF FATAL ERROR,
SKIPE .FLCBF ;SEE IF FIRST FATAL ERROR
JRST ERMSG2 ;NO
CLEARO ;YES--CLEAR ^O
HLRZ T1,-2(P) ;[137] CLEARO MAY DESTROY T1, T2
ANDI T1,177 ;[137] SO BE SAFE
SETOM .FLCBF ; INDICATE TO CLEAR TYPE-AHEAD
ERMSG2: PUSHJ P,.TNEWL ;GO TO START OF LINE
PUSHJ P,.TCHAR ;ISSUE LEAD CHARACTER
PUSHJ P,.VERBO ;GET /MESSAGE
MOVE T4,T1 ;COPY TO SAFER PLACE
POP P,T1 ;GET PREFIX
TLNN T1,-1 ;SEE IF SYSTEM CODE
HRLZS T1 ;YES--REMOVE SPACES
TXNE T4,JWW.PR ;SEE IF /VERBOS:PREFIX
PUSHJ P,.TSIXN ;YES--ISSUE PREFIX
POP P,T3 ;GET ADDRESS OF CALL
TRNE T3,-1 ;SEE IF CALL ADDRESS SET
TXNN T4,1_<VRBADX-1> ; AND IF USER ASKED FOR IT
JRST ERMSG1 ;NO--PROCEED BELOW
MOVEI T1,"(" ;YES--INDICATE
PUSHJ P,.TCHAR ; ADDRESS
HRRZ T1,T3 ;GET ADDRESS
PUSHJ P,.TOCTW ; TYPE IN OCTAL
MOVEI T1,")" ;GET END
PUSHJ P,.TCHAR ; AND INDICATE
ERMSG1: PUSHJ P,.TSPAC ;SPACE OVER TO TEXT AREA
HRRZ T1,(P) ;GET TEXT ADDRESS
TXNE T4,JWW.FL ;SEE IF /MESSAGE:FIRST
PUSHJ P,.TSTRG ;YES--ISSUE TEXT
POP P,T1 ;RESTORE FLAGS (???)
ANDX T4,JWW.CN!JWW.FL ;REMOVE JUNK BITS
HRR T1,T4 ;MOVE TO ANSWER
POPJ P, ;RETURN
SUBTTL TYPE-OUT ROUTINES -- Return /MESSAGE: Setting
;CALL: PUSHJ P,.VERBO
;RETURNS T1/BITS IN JWW.?? FORMAT
.VERBO:
IFE FTOPS20,<
HRROI T1,.GTWCH ;GET FROM MONITOR
GETTAB T1, ;THE USER'S DEFAULT
MOVEI T1,0 ;(DEFAULT TO 0)
TXNN T1,JW.WMS ;SEE IF SET
TXO T1,.JWWPO_<ALIGN. (JW.WMS)> ;NO--DEFAULT TO PREFIX,FIRST
ANDX T1,JW.WMS ;REMOVE JUNK
LSH T1,^D18-<ALIGN.(JW.WMS)> ;ALIGN IN LEFT HALF
ANDCM T1,.FLVRB ;CLEAR ANY SET IN SWITCH
HLRZS T1 ;POSITION TO RIGHT
IOR T1,.FLVRB ;INCLUDE ANY SET IN SWITCH
TLZ T1,-1 ;CLEAR JUNK
TRNE T1,JWW.CN ;SEE IF CONTINUATION
TRO T1,JWW.FL ;YES--SET FIRST
SKIPN T1 ;SEE IF ANYTHING LEFT
TRO T1,.JWWPO ;NO--SET FIRST,PREFIX
>
IFN FTOPS20,<
MOVX T1,JW.WMS ;FORCE FULL MESSAGE OUT
>
POPJ P, ;RETURN
SUBTTL TYPE-OUT ROUTINES -- Type OPEN and LOOKUP/RENAME/ENTER Blocks
;CALL: 1/ ADDRESS OF OPEN BLOCK
; 2/ ADDRESS OF EXTENDED LOOKUP/ENTER BLOCK
; PUSHJ P,.TOLEB
;USES T1-4
IFE FTOPS20,<
.TOLEB: MOVE T4,T2 ;MAKE SAFE COPY
MOVE T1,.OPDEV(T1) ;[OK] GET DEVICE
PUSHJ P,.TSIXN ;ISSUE IT
PUSHJ P,.TCOLN ;ISSUE SEPARATOR
MOVE T1,.RBNAM(T4) ;[OK] GET FILE NAME
HLRZ T2,.RBEXT(T4) ;[OK] GET EXTENSION
CAIN T2,'UFD' ;SEE IF UFD
JUMPG T1,[PUSHJ P,.TPPNW ;YES--TYPE AS P,PN
JRST .+2] ;PROCEED
PUSHJ P,.TSIXN ;ELSE ISSUE IN SIXBIT
MOVEI T1,"." ;INDICATE EXTENSION
PUSHJ P,.TCHAR ;ISSUE IT
HLLZ T1,.RBEXT(T4) ;[OK] GET EXTENSION
PUSHJ P,.TSIXN ;ISSUE THAT
MOVEI T1,.RBPPN(T4) ;[OK] POINT TO DIRECTORY
PJRST .TDIRB ;GO TYPE THAT AND RETURN
SUBTTL TYPE-OUT ROUTINES -- Directory Block
;STILL IN IFE FTOPS20
;CALL: MOVEI T1,ADDRESS OF DIRECTORY WORD OR PATH OR BIWORDS
; TLO T1,0 FOR WORD, 1 FOR PATH, 2 FOR BIWORDS
; PUSHJ P,.TDIRB
;USES T1-4
.TDIRB:
IFE FT$SFD,<
SKIPE T1,(T1) ;[OK] SEE IF SOMETHING
PJRST .TPPNW ;YES--PRINT IT
POPJ P,
>
IFN FT$SFD,<
MOVE T4,T1 ;SAVE POINTER
SKIPN T1,(T4) ;[OK] SEE IF SOMETHING THERE
JRST [HLRZ T2,T4 ;NO--SEE IF BIWORDS
CAIN T2,2 ; ..
SKIPN 2(T4) ;[OK] YES--SEE IF SOMETHING LATER ON
POPJ P, ;NO--RETURN
JRST TDIRB1] ;PROCEED WITH OUTPUT
TLNE T4,-1 ;SEE IF STRAIGHT
JRST TDIRB1 ;NOPE--DO IT THE HARD WAY
TLNE T1,-1 ;YES--SEE IF SFD
PJRST .TPPNW ;NO--JUST UFD
MOVEI T4,2(T1) ;[OK] YES--CHANGE POINTER
TDIRB1: HLRZ T1,T4 ;GET LENGTH
SUBI T1,2 ;SET FLAG -1 FOR SINGLE, 0 FOR BIWORDS
PUSH P,T1 ;SAVE FOR LATER TESTING
HRLI T4,-.FXLND ;SET LENGTH
MOVEI T1,"[" ;OUTPUT BREAK
PUSHJ P,.TCHAR ; ..
HRRZ T1,T4 ;[C20] GET UFD
MOVE T1,(T1) ;[C20] ..
JUMPL T1,[PUSHJ P,.TSIXN
JRST TDIRB2]
SKIPL (P) ;SEE IF DOUBLE
JRST [HRRZ T2,T4 ;[C20] YES--GET MASK
MOVE T2,1(T2) ;[C20] ..
PUSHJ P,.TXWWW ;OUTPUT MASKED OCTAL XWD
JRST TDIRB2] ;AND PROCEED
PUSHJ P,.TXWDW ;TYPE IT
TDIRB2: AOBJP T4,TDIRB3 ;LOOP UNTIL DONE
SKIPL (P) ;IF BIWORDS,
AOS T4 ; MOVE UP ONE EXTRA
HRRZ T1,T4 ;[C20] ..
SKIPN (T1) ;[C20] ..
JRST TDIRB3 ;YES--RETURN TYPING LAST BREAK
PUSHJ P,.TCOMA ;TYPE A COMMA
HRRZ T1,T4 ;[C20] GET SFD NAME
MOVE T1,(T1) ;[C20] ..
PUSHJ P,.TSIXN ;TYPE IT
JRST TDIRB2 ; AND LOOP UNTIL DONE
TDIRB3: POP P,(P) ;THROW AWAY FLAG
JRST .TRBRK ;AND FINISH UP
>
SUBTTL TYPE-OUT ROUTINES -- Masked (Wild) Octal Word in XWD Format
;STILL IN IFE FTOPS20
;CALL: MOVE T1,WORD
; MOVE T2,MASK
; PUSHJ P,.TXWWW
;USES T1-3
.TXWWW: MOVSS T2 ;T1,T2=LH(V),RH(V),RH(M),LH(M)
ROTC T1,-^D18 ;T1,T2=LH(M),LH(V),RH(V),RH(M)
PUSH P,T2 ;SAVE SECOND HALF (V,,M)
MOVSS T1 ;T1=LH V,,M
PUSHJ P,.TMOHW ;TYPE MASKED OCTAL HALF-WORD
PUSHJ P,.TCOMA ;TYPE COMMA
POP P,T1 ;RESTORE RH V,,M
;FALL INTO .TMOHW
;.TMOHW -- TYPE MASKED OCTAL HALF-WORD
;CALL: MOVE T1,[VALUE,,MASK]
; PUSHJ P,.TMOHW
;USES T1-3
.TMOHW: TRCN T1,-1 ;MAKE MASK BIT 0 IF NOT WILD
PJRST .TASTR ;TYPE * IF ALL WILD
MOVE T2,T1 ;MOVE TO CONVENIENT PLACE
MOVEI T3,6 ;SET LOOP COUNT
TMOHW1: MOVEI T1,0 ;CLEAR ACCUMULATOR
LSHC T1,3 ;POSITION FIRST DIGIT
JUMPN T1,TMOHW3 ;GO IF NON-ZERO
SOJG T3,TMOHW1 ;LOOP UNTIL ALL DONE
TMOHW2: MOVEI T1,0 ;CLEAR ACCUMULATOR
LSHC T1,3 ;GET NEXT DIGIT
TMOHW3: ADDI T1,"0" ;CONVERT TO ASCII
TLNE T2,7 ;CHECK MASK
MOVEI T1,"?" ;CHANGE TO ? IF WILD
PUSHJ P,.TCHAR ;TYPE CHARACTER
SOJG T3,TMOHW2 ;LOOP UNTIL DONE
POPJ P, ;RETURN
>;END IFE FTOPS20
SUBTTL TYPE-OUT ROUTINES -- Disk Blocks, Memory Size
;.TCORW -- TYPE NUMBER IN CORE SIZE
;CALL: 1/ SIZE TO TYPE
; PUSHJ P,.TBLOK/.TCORW
;USES T1-4
REPEAT 0,<
.TBLOK: TRNE T1,177 ;SEE IF EVEN BLOCKS
PJRST TCORWD ;NO--ISSUE IN WORDS
MOVE T4,["B",,177] ;ELSE INDICATE BLOCKS
JRST TCORTP ;AND GO OUTPUT
>
.TCORW: JUMPE T1,TCORWD ;IF NULL, DO IN WORDS
IFE FTOPS20,<
MOVE T4,["K",,1777] ;PRESET FOR K
JUMPPT (T2,TCORKA,TCORKA) ;IF PDP-6 OR KA-10, DO IN K
>
MOVE T4,["P",,777] ;ELSE, INDICATE PAGES
TCORKA: TDNE T1,T4 ;SEE IF ROUND UNITS
JRST TCORWD ;NO--DO IN WORDS
TCORTP: HRRZ T2,T4 ;[C20] YES--DIVIDE BY UNITS
IDIVI T1,1(T2) ;[C20] ..
SKIPA ; AND OUTPUT
TCORWD: MOVSI T4,"W" ;INDICATE WORDS
PUSHJ P,.TDECW ;ISSUE SIZE
HLRZ T1,T4 ;GET SIZE UNIT INDICATOR
PJRST .TCHAR ;ISSUE THAT AND RETURN
SUBTTL TYPE-OUT ROUTINES -- Time of Day in HH:MM:SS Format
IFN FTOPS20!FTCOBOL!FTFORTRAN,<
;CALL: MOVEI T1,TIME IS MILLISEC SINCE MIDNIGHT
; PUSHJ P,.TTIME
;USES T1-4
;WARNING: THIS ROUTINE TRUNCATES THE TIME; IT WILL PRINT 15:59:59.995
; AS 15:59:59, NOT 16:00:00. THIS IS BECAUSE A ROUND UP COULD
; CAUSE THE DAY TO INCREMENT, AND THIS ROUTINE DOESN'T KNOW THE
; DAY (IT HAS PROBABLY ALREADY BEEN PRINTED). THE CALLER OF THIS
; ROUTINE MUST MAKE SURE THE TIME HAS ALREADY BEEN ROUNDED TO THE
; NEAREST SECOND HIMSELF. SEE THE CODE AT .TDTTM FOR AN EXAMPLE.
.TTIME: IDIV T1,[^D3600000] ;[C20] GET HOURS
MOVE T4,T2 ;SAVE REST
MOVEI T2," " ;FILL WITH SPACE
PUSHJ P,.TDEC2 ;TYPE TWO DIGITS
PUSHJ P,.TCOLN ;TYPE COLON
MOVE T1,T4 ;RESTORE REST
IDIVI T1,^D60000 ;GET MINS
MOVE T4,T2 ;SAVE REST
PUSHJ P,TDEC2Z ;TYPE TWO DIGITS WITH 0 FILLER
PUSHJ P,.TCOLN ;TYPE COLON
MOVE T1,T4 ;RESTORE THE REST
IDIVI T1,^D1000 ;GET SECONDS
TDEC2Z: MOVEI T2,"0" ;FILL WITH 0
;FALL INTO .TDEC2
;.TDEC2 -- TYPE DECIMAL AT LEAST TWO DIGITS
;CALL: SAME AS .TDECW WITH T2=FILLER CHAR (" " OR "0")
.TDEC2: JUMPL T1,.TDECW ;JUMP IF NEGATIVE
CAILE T1,^D9 ;SEE IF ONE DIGIT
PJRST .TDECW ;NO--JUST OUTPUT
EXCH T1,T2 ;GET FILLER
PUSHJ P,.TCHAR ;TYPE
MOVE T1,T2 ;[C20] CONVERT DIGIT
ADDI T1,"0" ;[C20] ..
PJRST .TCHAR ;OUTPUT IT AND RETURN
>;END IFN FTOPS20!FTCOBOL!FTFORTRAN
SUBTTL TYPE-OUT ROUTINES -- CRLF, PPN, ']', SIXBIT
;CALL: PUSHJ P,.TCRLF
;PRESERVES ALL ACS
.TCRLF: PUSH P,T1 ;SAVE CHARACTER
MOVEI T1,.CHCRT ;GET CARRIAGE RETURN
PUSHJ P,.TCHAR
MOVEI T1,.CHLFD ;GET LINE FEED
PUSHJ P,.TCHAR ;TYPE IT
TPOPJ: POP P,T1 ;RESTORE CHARACTER
POPJ P, ;RETURN
IFE FTOPS20,<
;.TPPNW -- SUBROUTINE TO TYPE A PPN
;CALL: MOVE T1,PPN
; PUSHJ P,.TPPNW
;USES T1, T2, T3
.TPPNW: PUSH P,T1 ;SAVE ARGUMENT
MOVEI T1,"["
PUSHJ P,.TCHAR
POP P,T1 ;RECOVER ARGUMENT
JUMPL T1,[PUSHJ P,.TSIXN
JRST .TRBRK]
PUSHJ P,.TXWDW ;TYPE XWD
>
.TRBRK: MOVEI T1,"]"
PJRST .TCHAR
;.TSIXN -- TYPE OUT SIXBIT WORD
;CALL: MOVE T1,WORD
; PUSHJ P,.TSIXN
;USES T1, T2
.TSIXN: MOVE T2,T1 ;MOVE ARGUMENT
TSIXN1: JUMPE T2,.POPJ ;LOOP UNTIL ONLY BLANKS LEFT
MOVEI T1,0 ;CLEAR NEXT CHARACTER
LSHC T1,6 ;GET NEXT CHARACTER
ADDI T1," "-' ' ;CONVERT TO ASCII
PUSHJ P,.TCHAR ;TYPE IT
JRST TSIXN1 ; ..
SUBTTL TYPE-OUT ROUTINES -- Octal XWD Format and Signed Octal, Decimal, Radix
;CALL: MOVE T1,WORD
; PUSHJ P,.TXWDW
;USES T1, T2, T3
.TXWDW: PUSH P,T1 ;PRESERVE ARGUMENT
HLRZ T1,T1
PUSHJ P,.TOCTW
PUSHJ P,.TCOMA ;ISSUE COMMA
POP P,T1 ;RESTORE ARGUMENT
HRRZ T1,T1
;FALL INTO .TOCTW
;.TDECW -- TYPE OUT SIGNED DECIMAL NUMBER
;.TOCTW -- TYPE OUT SIGNED OCTAL NUMBER
;.TRDXW -- TYPE OUT SIGNED NUMBER (RADIX IN T3)
; (IF RADIX .GT. 9, WILL USE ALPHAS AFTER DIGITS)
;CALL: MOVE T1,NUMBER
; PUSHJ P,.TOCTW/.TDECW/.TRDXW
;USES T1, T2, T3
.TOCTW: SKIPA T3,[10] ;INITIALIZE FOR OCTAL RADIX
.TDECW: MOVEI T3,^D10 ;INITIALIZE FOR DECIMAL RADIX
.TRDXW: JUMPGE T1,TRDXW1 ;CHECK FOR NEGATIVE
MOVE T2,T1 ;SAVE AWAY ARGUMENT
MOVEI T1,"-" ;YES--GET MINUS
PUSHJ P,.TCHAR ;PRINT IT
MOVE T1,T2 ;RESTORE NUMBER
TRDXW1: IDIV T1,T3 ;DIVIDE BY RADIX
MOVMS T2 ;GET MAGNITUDE
PUSH P,T2 ;[C20] SAVE REMAINDER
SKIPE T1 ;SEE IF ANYTHING LEFT
PUSHJ P,TRDXW1 ;YES--LOOP BACK WITH PD LIST
POP P,T1 ;[C20] GET BACK A DIGIT
ADDI T1,"0" ;CONVERT TO ASCII
CAILE T1,"9" ;SEE IF OVERFLOW DIGITS
ADDI T1,"A"-"9" ;YES--SWITCH TO ALPHABETICS
PJRST .TCHAR ;TYPE IT AND RETURN
SUBTTL TYPE-OUT ROUTINES -- ASCIZ String, Character, ' ' ',' ':' '*'
;CALL: MOVEI T1,LOCTN. OF STRING
; PUSHJ P,.TSTRG
;USES T1
.TSTRG: HRLI T1,(POINT 7) ;CONVERT ADDRESS TO POINTER
TRNN T1,-1 ;SEE IF SOMETHING THERE
POPJ P, ;NO--RETURN EMPTY HANDED
PUSH P,T1 ;STORE IN SAFE PLACE
TSTRG1: ILDB T1,(P) ;GET NEXT CHARACTER
JUMPE T1,TPOPJ ;RETURN WHEN DONE
PUSHJ P,.TCHAR ;OUTPUT CHARACTER
JRST TSTRG1 ;LOOP UNTIL DONE
;.TCHAR -- TYPE ASCII CHARACTER
;CALL: MOVEI T1,CHARACTER
; PUSHJ P,.TCHAR
;PRESERVES ALL ACS
;.TSPAC -- TYPE ASCII SPACE
;.TTABC -- TYPE ASCII TAB
;.TCOMA -- TYPE ASCII COMMA
;.TCOLN -- TYPE ASCII COLON
;.TASTR -- TYPE ASCII ASTERISK
;CALL: PUSHJ P,.TXXXX
;USES T1
IFE FTOPS20,<
.TASTR: MOVEI T1,"*" ;GET ASTERISK
PJRST .TCHAR ;ISSUE AND RETURN
>
.TCOLN: MOVEI T1,":" ;GET COLON
PJRST .TCHAR ;ISSUE AND RETURN
.TCOMA: MOVEI T1,"," ;GET COMMA
PJRST .TCHAR ;ISSUE AND RETURN
REPEAT 0,<
.TTABC: MOVEI T1,.CHTAB ;GET TAB
PJRST .TCHAR ;ISSUE AND RETURN
>
.TSPAC: MOVEI T1," " ;GET SPACE
.TCHAR: TRNN T1,177 ;SEE IF NULL
POPJ P, ;YES--IGNORE
TYPEC (T1) ;LET MONITOR DO IT
POPJ P, ;AND RETURN
SUBTTL .SAVE4 - SUBROUTINE TO SAVE P1-4 FOR A SUBROUTINE
;CALL: PUSHJ P,.SAVE4
;RETURN POPJ OR .POPJ1, RESTORES P1-4 AND SKIPS OR NOT
IFE FTCOBOL,<
.SAVE4: EXCH P1,(P) ;SAVE P1, GET CALLER PC
PUSH P,P2 ;SAVE P2
PUSH P,P3 ;SAVE P3
PUSH P,P4 ;SAVE P4
PUSH P, ;[C20] MAKE SPACE FOR RETURN PC
PUSH P,P1 ;[C20] SAVE CALLER PC
XMOVEI P1,.SAVX4 ;[C20] SAVE RETURN PC
MOVEM P1,-1(P) ;[C20] ..
MOVE P1,-5(P) ;[C20] RESTORE P1
POPJ P, ;[C20] RETURN TO CALLER
.SAVX4: SOS -4(P) ;NON-SKIP RETURN, COMPENSATE .POPJ1
RET4: POP P,P4 ;RESTORE P4
RET3: POP P,P3 ;RESTORE P3
RET2: POP P,P2 ;RESTORE P2
RET1: POP P,P1 ;RESTORE P1
>
.POPJ1: AOS (P) ;INCREMENT PC
.POPJ: POPJ P, ;RETURN
;**;[500] At the end of the file, Insert 20 lines. GCS 13-APR-82
SUBTTL .PSH4T - SUBROUTINE TO SAVE T1-4 FOR A SUBROUTINE ;[500]
SUBTTL .POP4T - SUBROUTINE TO RESTORE T1-4 FOR A SUBROUTINE ;[500]
;.PSH4T -- PUSH T1-T4 ONTO THE STACK ;[500]
;.POP4T -- POP T1-T4 FROM THE STACK ;[500]
;CALL: PUSHJ P,.PSH4T/.POP4T ;[500]
;USES NO ACS ;[500]
.PSH4T: PUSH P,T2 ;[500] SAVE T2
PUSH P,T3 ;[500] SAVE T3
PUSH P,T4 ;[500] SAVE T4
EXCH T1,-3(P) ;[500] SAVE T1/GET RETURN
PUSH P,T1 ;[500] PUT INTO SAFE PLACE
MOVE T1,-4(P) ;[500] RESTORE T1
POPJ P, ;[500] RETURN
.POP4T: POP P,T1 ;[500] GET RETURN
POP P,T4 ;[500] RESTORE T4
POP P,T3 ;[500] RESTORE T3
POP P,T2 ;[500] RESTORE T2
EXCH T1,(P) ;[500] RESTORE T1/SAVE RETURN
POPJ P, ;[500] RETURN