Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
sort-source/srtcbl.mac
There are 10 other files named srtcbl.mac in the archive. Click here to see a list.
; UPD ID= 94 on 11/18/83 at 5:01 PM by FONG
TITLE SRTCBL - INTERFACE TO LIBOL FOR COBOL SORT
SUBTTL E.F. McHUGH & D.M.NIXON/DMN/DZN
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1975, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
;FTCOBOL==1
FTFORTRAN==0
SEARCH SRTPRM
XSEARCH ;SEARCH OTHER UNIVERSALS
IFN FTPRINT,<PRINTX [Entering SRTCBL.MAC]>
.COPYRIGHT ;Put standard copyright statement in REL file
SEGMENT HPURE
SUBTTL TABLE OF CONTENTS FOR SRTCBL
; Table of Contents for SRTCBL
;
;
; Section Page
;
; 1 SRTCBL - INTERFACE TO LIBOL FOR COBOL SORT ............... 1
; 2 TABLE OF CONTENTS FOR SRTCBL ............................. 2
; 3 DEFINITIONS
; 3.1 Flags, Entry Points and Macros .................... 3
; 3.2 Impure Data ....................................... 4
; 3.2 Impure Data ....................................... 4
; 3.3 TOPS-20 non-zero section entry vector ............. 5
; 4 PSORT.
; 4.1 SORT/MERGE Initialization ......................... 6
; 4.2 Count Number of Input Files ....................... 9
; 4.3 Find next input merge file ........................ 12
; 5 RELES.
; 5.1 Add Input Record to Tree .......................... 14
; 6 MCLOS. CLOSE OUT INPUT MERGE FILE ........................ 17
; 7 MERGE.
; 7.1 Simulate Master End of File ....................... 18
; 8 RETRN.
; 8.1 Copy Records From Tree to Output File ............. 19
; 9 ENDS.
; 9.1 Clean Up After Sort or Merge ...................... 20
; 10 ACCUMULATOR SAVING ROUTINES .............................. 22
; 11 ROUTINE TO DO COMPARES IN COBOL SORT ..................... 23
; 12 ERROR MESSAGES ........................................... 24
SUBTTL DEFINITIONS -- Flags, Entry Points and Macros
SEARCH FTDEFS ;GET COBOL FILE-TABLE DEFINITIONS
IXMASK==777760,,-1 ;USED TO REMOVE INDEX FIELD FROM FTDEFS BYTE POINTERS
ENTRY PSORT.,RELES.,MERGE.,RETRN.,ENDS.,PMERG.,MCLOS.
IFE FTNZSEC,<
EXTERN FUNCT.,STOPR.,KEYCV.,MEMRY% ;[C20] [C19]
>
IFE FTOPS20,<
EXTERN FSLOC. ;[C20]
>
WSCBIT==1B0 ;WANT SEQUENCE CHECK ON MERGE
IFN FTCOBOL,< ;NOT IF COBOL-SORT = STAND-ALONE SORT
DEFINE COMPARE(R,J)<
JSP P4,.CMPAR
>
IFN FTOPS20,<
IFN FTNZSEC,<
HIORG==640000 ;TRY TO AVOID CASHE INTERFERENCE WITH LIBOL
HILOC==HIORG ; BY NOT OCCUPYING SAME PAGE # AS LIBOL VECTOR AND LIBOL
>
LOWLOC==676000 ;REDEFINE SINCE WE NEED ONLY 2 PAGES
LOWORG==LOWLOC ;[356] NEVER GETS MODIFIED BY SEGMENT MACRO
>
IFE FTOPS20,<
LOWORG==<LOWLOC==0> ;[N07] SET DATA SECTION BASE TO ZERO
DEFINE SEGMENT (A) <> ;ALL IN LOW SEGMENT
>
>;END IFN FTCOBOL
KEYZ SUP,<NONE,INFORMATION,WARNING,FATAL,ALL>
SUBTTL INTERNAL/EXTERNAL DEFINITIONS
;GENERATE STRUCTURE MACROS
;NOW GENERATE THEM MAX = 10 FOR NOW
RADIX 10
$TEMPORARY (10,10)
RADIX 8
;GLOBAL ROUTINES
INTERN CBLVLN,CBLVEC
IFN FTNZSEC,<
INTERN EOFCBL
>
;EXTERNALS
;DEFINED IN SORT
EXTERN ACTTMP,CMPCNT,FCBORG,INPREC,IOBPW,IOBPW2,LSTREC,MAXTMP,MRGSW,NUMTMP,PSAV,RQ
EXTERN NUMENT,NUMINP,OUTREC,RECORD,REKSIZ,STRNAM,STRNUM,TCBIDX,TMPFCB,WSCSW,XTRWRD,$RETRN
EXTERN CLSRUN,CPOPJ,CPOPJ1,CPUTST,E$$RNI,E$$TMT,FSTRUN,GETJOB,INITRE,MERGE%,PTTREC
EXTERN PSORT%,RELES%,RETRN%,RETRN0,RETRN1,RSTSPC,SETMRG,SETSPC,SETTRE,SSTATS,STATS
EXTERN %ERMSG,%TDECW,%TCRLF,%TSIXN,%TSTRG
;DEFINED IN SRTJSS
EXTERN DELFIL,CHKCOR,RESET$
;DEFINED IN SRTSTA
IFE FTCOBOL,<
EXTERN .CMPAR
>
SUBTTL DEFINITIONS -- Impure Data
SEGMENT IMPURE ;[C20]
ZCOR:! ;START OF DATA TO CLEAR
LD ($RELES,1) ;WHERE TO GO ON RELES.
LD (KEYLOC,1) ;LOCATION OF THE KEYS AFTER CONVERSION
LD (SDFILE,1) ;LOCATION OF SD FILE TABLE
LD (OLDNXT,1) ;ORIGINAL VALUE OF NEXT SD TABLE
LD (NEWREC,1) ;CONTAINS SD RECORD ADDRESS
LD (LASRET,1) ;FLAGS END OF RETURNS
LD (MRGCNT,1) ;COUNT OF FILES TO OPEN INITIALLY
LD (MLTPAS,1) ;[327] -1 IF WE NEEDED MULTI-PASS FOR MERGE
LD (LASPAS,1) ;[327] -1 IF ON LAST PASS OF MULTI-PASS MERGE
LD (MRGRLS,1) ;[327] ADDR OF PUSHJ P,RELES. FOR NEXT SCAN
LD (MRGPC,1) ;PC TO RETURN TO FOR MERGE.
BLOCK MX.TMP ;PC OF RELES. ROUTINES
LD (MRGIRC,MX.TMP) ;COUNT OF RECORDS INPUT ON EACH MERGE FILE
EZCOR==.-1 ;END OF DATA TO BE ZEROED
LD (UR.CHN,1) ;GLOBAL VALUE CAN BE SET BY USER
LD (STATSW,1) ;[C20] GLOBAL VALUE CAN BE SET BY USER
LD (ACSAVE,5) ;SAVES LIBOL'S ACS
LD (SAVEL,1) ;SAVE LIBOL'S ACC L
IFN FTOPS20,<
LD (DEVNAM,0) ;USE SAME AREA SINCE NO CONFLICT
>
LD (SORTAC,2) ;SAVES SORT ACS
IFE FTNZSEC,<
LD (CMPRMP,2) ;EXP <PUSHJ P,RELES.>,<PUSHJ P,MERGE.>
>
IFN FTNZSEC,<
LD (COBRET,1) ;RETURN ADDRESS
LD (STOPR.,1) ;ADDRESS OF LIBOL'S ERROR ROUTINE
LD (KEYCV.,1) ;ADDRESS OF KEYCV.
LD (FUNCT.,1) ;ADDRESS OF FUNCT.
LD (UPMERG,1) ;EXP <PUSHJ P,PMERG.>
LD (CMPRMP,2) ;EXP <PUSHJ P,RELES.>,<PUSHJ P,MERGE.>
LD (CODSEC,1) ;LHS = SECTION # OF COBOL CODE
GD (COBPDP,1) ;SAVE COBOL'S PUSHDOWN STACK POINTER
LD (STACK,PDLEN) ;NEW STACK
>
SEGMENT LPURE ;[C20]
BLOCK 1 ;[427] LINK TO NEXT
ZCOR,,EZCOR ;[427] DATA TO ZERO
.LINK S.LNK,.-2 ;[427] TELL LINK WHAT TO DO
SUBTTL NON-ZERO SECTION ENTRY POINTS -- TOPS-20 Entry Vector
IFN FTNZSEC,<
SEGMENT HPURE ;[C20]
ENTVEC: JRST PSORT. ;MAIN ENTRY POINT
HALT . ;REENTER ENTRY POINT
EXP V%SORT ;VERSION NUMBER
CBLVLN,,CBLVEC ;USER COBOL ENTRY VECTOR
ENTVLN==.-ENTVEC
CBLVEC: EXP 0,PSORT. ;COBOL ENTRY POINTS
EXP 0,PMERG.
EXP 0,RELES.
EXP 0,MERGE.
EXP 0,MCLOS.
EXP 0,RETRN.
EXP 0,ENDS.
CBLVLN==.-CBLVEC
>
SUBTTL PSORT. -- SORT/MERGE Initialization
BEGIN;
PROCEDURE (PUSHJ P,PSORT.)
PSORT.: TDZA P1,P1 ;SORT ENTRY
PMERG.: MOVEI P1,1 ;MERGE ENTRY
IFN FTOPS20,<
MOVX T1,.FHSLF ;[N13] THIS PROCESS
RCM% ;[N13] READ INTERUPT MASK
MOVX T2,<1B<.ICNXP>> ;[N13] ONLY WORRY ABOUT INTERUPT ON PAGE CREATION
AND T2,T1 ;[N13] ONLY TURN OFF IF CURRENTLY ON
MOVX T1,.FHSLF ;[N13] THIS PROCESS
DIC% ;[335] SO PA1050 WON'T BITCH AT US
SETZM LOWORG ;[356] CREATE 2 LOW SEGMENT PAGES
MOVE T3,[LOWORG,,LOWORG+1] ;[356] CLEAR THEM IN CASE NOT FIRST TIME
IFN FTCOBOL,<
BLT T3,LOWORG+1777 ;[356] OR THEY ALREADY EXIST
>
IFE FTCOBOL,<
BLT T3,LOWORG+3777 ;[356] OR THEY ALREADY EXIST
>
AIC% ;[335] REACTIVATE INTERRUPTS FOR PA1050
>
IFN FTNZSEC,<
HLLZM L,CODSEC ;SAVE SECTION # OF COBOL CODE (SHOULD BE 1)
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
MOVE T2,L ;POINT TO ARG BLOCK IN SEC ZERO
HLRE T1,-1(L) ;NEG ARG COUNT
MOVN T1,T1 ;NO OF WORDS TO MOVE
XMOVEI T3,COBRET ;POINT TO BLOCK IN THIS SECTION
EXTEND T1,[XBLT] ;MOVE TO THIS SECTION
>
MOVEM L,SAVEL ;SAVE AC L
MOVEI L,ACSAVE ;GET BLT POINTER
BLT L,ACSAVE+4 ;SAVE ACS FROM COBOL
IFE FTOPS20,<
JSP T4,ZDATA ;ZERO SORT DATA
>
MOVEM P1,MRGSW ;SAVE MERGE OR SORT
JSP T4,CPUTST ;[134] MAKE SURE IF CPU IS OK
IFE FTOPS20,<
PUSHJ P,MONSPC ;[N12] SEE IF 7-SERIES MONITOR
>
PUSHJ P,SSTATS ;[C20] SETUP STATS LOCS
PUSHJ P,SETSPC ;[C13] SETUP MEMORY LOCS
IFE FTNZSEC,<
PUSHJ P,CUTBAK ;REDUCE SIZE AS MUCH AS POSSIBLE
>
IF MERGE VERB
SKIPG MRGSW ;[354]
JRST $F ;[354]
THEN TEST TO SEE IF SHAREABLE SORT OR NOT
IFE FTNZSEC,<
IFN FTKI10,<
DMOVE T1,[PUSHJ P,RELES.
PUSHJ P,MERGE.] ;NEEDED FOR CNTINP ROUTINE
>
IFE FTKI10,<
MOVE T1,[PUSHJ P,RELES.]
MOVE T2,[PUSHJ P,MERGE.] ;NEEDED FOR CNTINP ROUTINE
>
DMOVEM T1,CMPRMP ;SO SAVE NON-REENTRANT VERSION
HRRZ T2,0(P) ;[C20] [354]
MOVE T1,-1(T2) ;[OK] [354] GET CALLING INST.
>
IFN FTNZSEC,<
MOVE T2,COBPDP ;GET CODE STACK
HLL T2,CODSEC ;MAKE IT GLOBAL
HRR T2,(T2) ;GET ADDRESS OF PC+1
MOVE T1,-1(T2) ;GET CALL
>
TXNE T1,<Z @> ;[OK] [354] WERE WE CALLED FROM COBOL OVERLAY?
JRST [PUSHJ P,FNDINS ;[354] YES--NEED SPECIAL CODE TO SET UP COMPARE INST
JRST $F] ;[354] HAVING DONE SO, LEAVE WELL ALONE
IFE FTNZSEC,<
CAMN T1,[PUSHJ P,PMERG.] ;[354] SEE IF NON-REENTRANT
>
IFN FTNZSEC,<
CAMN T1,UPMERG ;EXP <PUSHJ P,PMERG.>
>
JRST $F ;[354] YES IT IS
ADDI T1,1 ;[354] CONVERT INST TO <PUSHJ P,RELES.>
HRRM T1,CMPRMP+0
ADDI T1,1 ;CONVERT TO <PUSHJ P,MERGE.>
HRRM T1,CMPRMP+1
FI;
;SET UP LOCATIONS IN LIBIMP AND COBOL
IFE FTNZSEC,<
MOVEI T2,2 ;GET DISPLACEMENT
ADDB T2,(P) ;RESET RETURN ADDRESS
HRRZ T2,T2 ;[C20] GET CONTENTS OF FIRST & SECOND ARGS
DMOVE T1,-2(T2) ;[C20] ..
>
IFN FTNZSEC,<
MOVE T2,COBPDP ;GET CODE SECTION STACK POINTER
HLL T2,CODSEC ;MAKE IT GLOBAL
MOVE T1,T2 ;MAKE A COPY OF PC
HRR T2,(T2) ;GET PC OF CALL+1
MOVEI T3,2 ;WE NEED TO INCREMENT THE RETURN PC
ADDM T3,(T1) ; OVER THE TWO WORDS FOLLOWING THE CALL
DMOVE T1,(T2) ;GET 2 WORDS AFTER CALL
>
TXZE T1,WSCBIT ;WANT SEQUENCE CHECK?
AOS WSCSW ;YES
HLRZM T1,XTRWRD ;[207] SAVE THE KEY SIZE
HRRZM T1,SDFILE ;SAVE LOC OF SD RECORD AREA
HLRZM T2,KEYLOC ;SAVE LOC OF CONVERTED KEYS
HRRZM T2,KEYCV. ;SAVE LOC OF KEY CONVERSION CODE
IFN FTNZSEC,<
HLLZ T3,CODSEC ;NEED TO FIXUP GLOBAL ADDRESSES
HLLM T3,SDFILE ; ...
HLLM T3,KEYLOC ; ...
HLLM T3,KEYCV. ; ...
>
HRRZ T3,T1 ;ADDRESS OF MAX RECORD SIZE
IFN FTNZSEC,<
HLL T3,CODSEC ;MAKE ADDRESS GLOBAL
>
LDB T2,[<F%BMRS>&<IXMASK>+<Z (T3)>] ;GET MAX RECORD SIZE
HRRZM T2,RECORD ;[207] REMEMBER MAX SIZE
LDB T4,[<F%ACDM>&<IXMASK>+<Z (T3)>] ;INT. RECORDING MODE
; CASE MODE OF EBCDIC,SIXBIT,0,ASCII
MOVE T3,[EXP 4,1,0,5]-1(T4) ;[OK] [C03]
MOVEM T3,IOBPW2 ;[C03] SAVE IN I/O BYTES-PER-WORD USED
MOVE T4,[EXP 4,6,0,5]-1(T4) ;[OK]
MOVEM T4,IOBPW ;[207] SAVE IN I/O BYTES-PER-WORD
ADDI T2,-1(T4) ;[OK] FORCE UPWARD ROUNDING
IDIV T2,T4 ;[C20] FIND MAX WORDS/REC
ADD T2,XTRWRD ;[207] ADD IN THE SIZE OF THE KEY
ADDI T2,1 ;[C20] ACCOUNT FOR THE FLAG WORD
HRRZM T2,REKSIZ ;SAVE NUMBER OF WORDS/REC
MOVE T1,SDFILE ;GET SORT FILE RECORD ADDRESS
LDB T2,[<F%BREC>&<IXMASK>+<Z (T1)>] ;GET ADDRESS OF RECORD AREA
IFN FTNZSEC,<
HLL T2,T1 ;MAKE ADDRESS GLOBAL
>
MOVEM T2,NEWREC ;SAVE IN LIBIMP
LDB T2,[<F%BNFT>&<IXMASK>+<Z (T1)>] ;GET LINK TO NEXT FILE TABLE
IFN FTNZSEC,<
HLL T2,T1 ;MAKE ADDRESS GLOBAL
>
MOVEM T2,OLDNXT ;SAVE IN LIBIMP
IFN FTOPS20,<
MOVEI T1,MX.TMP ;[C19] GET MAXIMUM TEMP FILES
>
IFE FTOPS20,<
PUSHJ P,SETCHN ;[C19] SETUP CHANNEL ALLOCATOR
MOVE T1,CHNFRE ;[C19] GET CHANNELS AVAILABLE
>
MOVEM T1,MAXTMP ;[C19] THIS IS MAX TEMP FILES
MOVN T1,MAXTMP ;[C19] MAKE AN AOBJ POINTER
HRLZM T1,TCBIDX ;[C19] PUT IT AWAY FOR LATER
BEGIN
;FIND THE NAMES OF THE STRUCTURES TO BE USED FOR THE TEMPORARY FILES
MOVE T1,SDFILE ;[C20] GET ADDRESS OF SD FILE BLOCK
LDB T2,[<F%BNOD>&<IXMASK>+<Z (T1)>] ;GET NUMBER OF TEMP DEVICES
CAMG T2,MAXTMP ;TOO MANY?
JRST $1 ;NO
PUSHJ P,E$$TMT ;YES, WARN USER
MOVE T2,MAXTMP ;USE WHAT WE CAN
$1% MOVEM T2,STRNUM ;SAVE
MOVN T2,T2 ;MAKE AOBJN POINTER
HRLZ T2,T2
IFE FTOPS20,<
LDB T1,[<F%BDNM>&<IXMASK>+<Z (T1)>] ;ADDRESS OF SCRATCH DEVICE NAMES
$2% MOVE T3,(T1) ;[OK] GET THE SCRATCH DEVICE NAME
PUSH P,T3 ;SAVE FOR NOW
DEVCHR T3, ;GET DEVICE CHARACTERISTICS
JUMPE T3,E$$DNE ;NONE-EXISTENT DEVICE
TXNN T3,DV.DSK ;IS IT A DISK STRUCTURE?
JRST E$$DND ;NO, CAN'T USE IT
HRRZ T3,T2 ;[C20] SAVE THE DEVICE NAME
POP P,STRNAM(T3) ;[C20] ..
ADDI T1,1 ;POINT TO THE NEXT NAME
AOBJN T2,$2 ;PUT IN THE NEXT(IF ANY)
>
IFN FTOPS20,<
LDB P1,[<F%BDNM>&<IXMASK>+<Z (T1)>] ;ADDRESS OF SCRATCH DEVICE NAMES
IFN FTNZSEC,<
HLL P1,T1 ;MAKE GLOBAL
>
MOVE P2,T2
$2% MOVE T2,(P1) ;[OK] GET THE SCRATCH DEVICE NAME
SETZB T1,DEVNAM ;INITIALIZE
SETZM DEVNAM+1 ;...
MOVE T3,[POINT 7,DEVNAM]
$5% SETZ T1, ;CLEAR FOR NEXT CHAR
LSHC T1,6 ;GET NEXT CHAR.
ADDI T1," " ;CONVERT TO ASCII
IDPB T1,T3 ;STORE
JUMPN T2,$5 ;LOOP
MOVEI T1,":"
IDPB T1,T3
MOVE T1,[POINT 7,DEVNAM]
STDEV% ;[335] TRANSLATE
JRST E$$DNE ;DEVICE DOES NOT EXIST
MOVE T1,T2 ;GET DESIGNATOR
DVCHR% ;[335] GET DEVICE CHARACTERISTICS
ERJMP E$$DND ;ERROR
TXNE T2,DV%TYP ;IS IT A DISK STRUCTURE?
JRST E$$DND ;NO, CAN'T USE IT
SETZ T1, ;NO FLAGS
MOVE T2,[POINT 7,DEVNAM]
RCDIR% ;[335] GET DIRECTORY NUMBER
ERJMP E$$DND ;CANNOT HAPPEN!
HRRZ T1,P2 ;[C20] SAVE THE DIRECTORY NUMBER
MOVEM T3,STRNAM(T1) ;[C20] ..
ADDI P1,1 ;POINT TO THE NEXT NAME
AOBJN P2,$2 ;PUT IN THE NEXT(IF ANY)
>
;NOW SEE IF THEY ARE ALL IDENTICAL
MOVN T1,STRNUM ;NO. TO LOOK AT
HRLZ T1,T1 ;AOBJN PTR
MOVE T2,STRNAM+0 ;GET FIRST
AOBJP T1,$4 ;ALL DONE
$3% HRRZ T3,T1 ;[C20] IDENTICAL?
CAME T2,STRNAM(T3) ;[C20] ..
JRST $E ;[214] NO,SO GIVE UP
AOBJN T1,$3 ;YES, TRY AGAIN
MOVEI T1,1
MOVEM T1,STRNUM ;LEAVE ONLY ONE
$4%
IFE FTOPS20,<
MOVE T1,[1,,T2] ;[214] SEE IF LONELY STR IS GENERIC DSK:
DSKCHR T1, ;[214] ..
JRST $E ;[214] MUST NOT BE
TXNN T1,DC.TYP ;[214] ..
SETOM STRDEF ;[214] YES--ACT AS IF STR WAS DEFAULTED
>
ENDB;
;SETUP COMPARE CODE
BEGIN;
IFN FTCOBOL,<
MOVE T1,[.KLCMP,,.CMPAR] ;[433] MOVE CODE TO IMPURE SEGMENT
BLT T1,.CMPAR+KL.CL-1 ;[433] ...
MOVN T1,XTRWRD ;[207]
HRRM T1,KLCMP1
>
IFE FTCOBOL,<
MOVE T1,[.KLCMP,,%CMPAR] ;[433] MOVE CODE TO IMPURE SEGMENT
BLT T1,%CMPAR+KL.CL-1 ;[433] ...
MOVN T1,XTRWRD ;[207]
HRRM T1,%CMPAR+KLCMP1
XMOVEI T1,%CMPAR
MOVEM T1,.CMPAR ;NEED TO GO INDIRECT
HRRZ T1,T1 ;LOCAL ADDRESS
ADDM T1,%CMPAR+KLCMP3 ;FIXUP ADDRESSES
ADDM T1,%CMPAR+KLCMP4 ;...
>
ENDB;
SUBTTL PSORT. -- Count Number of Input Files
BEGIN
IF SORT (I.E. NOT MERGE)
SKIPLE MRGSW ;IF SORT
JRST $T ;NO
THEN SETUP $RELES AND RETURN
MOVEI T1,RELES%
MOVEM T1,$RELES
JRST $F
ELSE SETUP FOR MERGE
SETZM NUMINP ;[327] START WITH ZERO
IFE FTNZSEC,<
HRRZ T1,(P) ;[C20] [327] START LOOKING AT RETURN ADDR
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE GLOBAL
HRR T1,(T1) ;GET ADDRESS OF INSTRUCTION SEQ.
>
HRR T1,(T1) ;BYPASS THE KEY EXTRACT CODE, GO TO TARGET OF JRST
WHILE THERE ARE FILES TO COUNT
BEGIN
PUSHJ P,FNDNXT ;[327] LOOK FOR PUSHJ P,RELES.
JRST $E ;[327] NO MORE--DONE
AOS NUMINP ;[327] GOT ONE--COUNT IT
MOVE T1,T2 ;[C20] [327] LOOK SOME MORE
JRST $B ;[327] LOOP FOR ANOTHER
ENDB;
MOVEM T2,MRGPC+0 ;[327] SAVE MERGE. ADDR FOR LATER
MOVE T2,NUMINP ;[N02] GET NUMBER OF MERGE FILES
CAIGE T2,2 ;[N02] NEED AT LEAST TWO
JRST E$$ATF ;[N02] NO, SO GIVE ERROR
PUSHJ P,SETMRG ;SETUP NUMRCB ETC.
MOVN T1,ACTTMP ;GET MAX. NO. OF TEMP FILE
HRLZ T1,T1
MOVEM T1,TCBIDX ;RESET NUMBER OF TEMP FILES
ADDI T1,1 ;FIRST IS OUTPUT
MOVEM T1,MRGCNT ;REST TO DO
MOVEI T1,CPOPJ
MOVEM T1,$RETRN ;
MOVEI T1,RELESI ;SETUP TO INITIALIZE
MOVEM T1,$RELES
FI;
ENDB;
PUSHJ P,GETJOB ;GET JOB NUMBER
IFE FTOPS20,<
MOVEM T1,FSLOC. ;[C20] [320] TELL FUNCT. SORT IS IN PROGRESS
>
;CALCULATE CORE REQUIREMENTS
IF USER SET MEMORY LIMIT
IFE FTNZSEC,<
MOVE T1,MEMRY% ;[C20] [C13] GET COBOL MEMORY LIMIT
HRRZ T1,(T1) ;[C20] ..
CAIN T1,-1 ;[C13] DEFAULT?
>
JRST $T ;[C13] YES
THEN USE IT
PUSHJ P,RSTSPC ;[C13] RE-SETUP AVAILABLE MEMORY
JRST $F
ELSE USE THE DEFAULT
IFE FTOPS20,<
PUSHJ P,DEFCOR ;USE DEFAULT CORE ALGORITHM
>
FI;
IFN FTOPS20,<
PUSHJ P,CHKCOR ;USE DEFAULT CORE ALGORITHM
>
IFE FTOPS20,<
PUSHJ P,TSTSIZ ;MAKE SURE ITS BIG ENOUGH
>
PUSHJ P,PSORT% ;JOIN COMMON CODE
MOVE L,SAVEL ;RESTORE L
PJRST .RESTR ;RESTORE COBOL'S AC'S THEN RETURN
ENDB;
;THE CALLING SEQUENCE USED BY THE MERGE STATEMENT IN COBOL IS RATHER COMPLEX.
;PART OF THE REASON IS THAT SORT, THE INPUT FILE PROCEDURES AND THE OUTPUT
;PROCEDURE WOULD LIKE TO BE CO-ROUTINES, BUT THE STANDARD COBOL CALLING SEQUENCE
;(MOVEI 16,ARGBLK; PUSHJ 17,SUBR) DOES NOT ALLOW THIS. ALSO, THE COMPILER
;GENERATES CLOSED LOOPS FOR EACH INPUT FILE'S RELEASE PROCEDURE, BUT SORT WANTS
;TO CHOOSE THE FILE FROM WHICH TO READ THE NEXT RECORD. THUS, SORT DOES A LOT OF
;STACK UNBINDING AND ANALYSIS OF THE COBOL PROGRAM'S CODE TO IMPLEMENT MERGES.
;AS A RESULT, THE SUCCESS OF MERGE DEPENDS ON THE EXACT FORMAT OF THE CODE
;PRODUCED BY COBOL. THIS IS WHAT SORT EXPECTS:
;
; PUSHJ P,PMERG. ;INITIALIZE FOR A MERGE
; <# WDS EXTRACTED KEYS>,,<ADDR OF SD> ;ARGUMENTS FOR MERGE
; <ADDR OF CONVERTED KEYS>,,<ADDR OF KEY CONVERSION ROUTINE>
; .
; .
; .
; INSTR ;OPEN ROUTINE FOR FIRST INPUT FILE
; INSTR ; WHICH IS 2 WORDS LONG
; %1: INSTR ;FIRST INPUT FILE'S RELEASE ROUTINE
; ...
; PUSHJ P,RELES. ;CALL SORT WITH RECORD
; JRST %1 ;LOOP FOR NEXT INPUT RECORD
; ...
; PUSHJ P,MCLOS. ;CALL SORT INDICATING FIRST FILE IS DONE
; .
; .
; .
; INSTR ;OPEN ROUTINE FOR SECOND INPUT FILE
; INSTR ; WHICH IS ALSO 2 WORDS LONG
; %2: INSTR ;SECOND INPUT FILE'S RELEASE ROUTINE
; ...
; PUSHJ P,RELES. ;CALL SORT WITH RECORD
; JRST %2 ;LOOP FOR NEXT INPUT RECORD
; ...
; PUSHJ P,MCLOS. ;CALL SORT INDICATING SECOND FILE IS DONE
; .
; . ;MORE INPUT FILE RELEASE ROUTINES
; .
; PUSHJ P,MERGE. ;TELL SORT THERE ARE NO MORE INPUT FILES
;
;SORT FINDS THE RELEASE ROUTINES BY LOOKING FOR <PUSHJ P,RELES.> INSTRUCTIONS
;BETWEEN THE RETURN ADDRESS FOR THE PMERG. CALL AND THE FIRST SUBSEQUENT
;<PUSHJ P,MERGE.>. THE ENTRIES FOR THESE RELEASE ROUTINES ARE THEN POINTED TO BY
;THE FOLLOWING <JRST %N> INSTRUCTION. THE OPEN ROUTINES FOR EACH FILE ARE THEN 2
;INSTRUCTIONS BEFORE THE BEGINNING OF THE ASSOCIATED RELEASE ROUTINES. SORT
;KNOWS THAT A FILE HAS REACHED END OF FILE WHEN IT 'CALLS' THE RELEASE ROUTINE
;FOR A RECORD AND CONTROL RETURNS TO MCLOS. RATHER THAN RELES.
SUBTTL PSORT. -- Find next input merge file
BEGIN;
PROCEDURE (PUSHJ P,FNDNXT) ;[327] FIND NEXT INPUT FILE
;FNDNXT STARTS LOOKING AT A SPECIFIED ADDRESS IN THE USER'S COBOL PROGRAM
;FOR CALLS TO SORT'S RELES. ENTRY POINT. EACH ONE WE FIND BETWEEN THE CALL
;TO PMERG. AND THE CALL TO MERGE. REPRESENTS AN INPUT FILE.
;
;CALL WITH:
; T1/ ADDRESS TO START SEARCH (SKIPS FIRST LOCATION)
;RETURNS:
; T1/ UNCHANGED
; T2/ ADDRESS OF NEXT RELES. OR MERGE. CALL
;
;FNDNXT GIVES A SKIP RETURN IF T2 CONTAINS THE ADDRESS OF THE NEXT RELES. CALL,
;AND A NON-SKIP RETURN IF T2 IS THE ADDRESS OF THE MERGE. CALL. DESTROYS T3.
XMOVEI T2,1(T1) ;[OK] [327] START AT ADDR+1
WHILE NOT PUSHJ P,RELES. OR PUSHJ P,MERGE.
BEGIN
MOVE T3,(T2) ;[OK] [327] GET NEXT INSTRUCTION
CAMN T3,CMPRMP+1 ;[327] IS IT PUSHJ P,MERGE.?
JRST $E ;[327] YES--DONE
CAMN T3,CMPRMP+0 ;[327] OR PUSHJ P,RELES.?
AOSA (P) ;[327] YES--SKIP RETURN
AOJA T2,$B ;[327] NO--LOOP FOR NEXT INSTR
ENDB;
RETURN ;[327] DONE
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,FNDINS) ;[354]
;IN THE CASE OF NON-RESIDENT CALL TO MERGE FNDINS SETS UP THE COMPARE LOCATIONS
;USED LATER BY FNDNXT THE PROBLEM IS THAT THE CALLS TO MERGE. AND RELES. ARE
;INDIRECT THROUGH THE RESIDENT SECTION AND ARE THUS HARD TO IDENTIFY.
;
;CALL WITH:
; T1/ WORD POINTED TO BY T2
; T2/ ADDRESS TO START SEARCH (SKIPS FIRST LOCATION)
IF NON-REENTRANT CALLING SEQUENCE (NOT /R IN COBOL)
HRRZS T1 ;[C20] GET ADDRESS
MOVE T1,(T1) ;[C20] [354] ..
CAIN T1,PMERG. ;[354]
JRST $T ;[354] /R CODE
THEN
WHILE NOT PUSHJ P,RELES. OR PUSHJ P,MERGE.
BEGIN
HLRZ T1,(T2) ;[OK] [354] GET NEXT INSTRUCTION
CAIE T1,(PUSHJ P,@) ;[354] IS IT A POSSIBLE CANDIDATE
AOJA T2,$B ;[354] NO KEEP LOOKING
HRRZ T1,(T2) ;[C20] [354] GET ADDRESS
TLO T1,(IFIW) ;[C20] ..
HRRZ T1,@T1 ;[C20] ..
CAIN T1,MERGE. ;[354] IS IT MERGE.
JRST $1 ;[354] YES
CAIE T1,RELES. ;[354] NO, IS IT RELES. THEN?
AOJA T2,$B ;[354] NOT YET
MOVE T1,(T2) ;[OK] [354] GET INST
MOVEM T1,CMPRMP+0 ;[354] SAVE IT
AOJA T2,$B ;[354] NOW LOOK FOR MERGE.
$1% MOVE T1,(T2) ;[OK] [354] GET INST
MOVEM T1,CMPRMP+1 ;[354] SAVE IT
RETURN ;[354] DONE
ENDB;
ELSE ITS /R CODE
WHILE NOT PUSHJ P,RELES. OR PUSHJ P,MERGE.
BEGIN
HLRZ T1,(T2) ;[OK] [354] GET NEXT INSTRUCTION
CAIE T1,(PUSHJ P,@) ;[354] IS IT A POSSIBLE CANDIDATE
AOJA T2,$B ;[354] NO KEEP LOOKING
HRRZ T1,(T2) ;[C20] [354] GET ADDRESS
TLO T1,(IFIW) ;[C20] ..
HRRZ T1,@T1 ;[C20] ..
CAIN T1,MERGE. ;[354] IS IT MERGE.
JRST $1 ;[354] YES
CAIE T1,RELES. ;[354] NO, IS IT RELES. THEN?
AOJA T2,$B ;[354] NOT YET
MOVE T1,(T2) ;[OK] [354] GET INST
MOVEM T1,CMPRMP+0 ;[354] SAVE IT
AOJA T2,$B ;[354] NOW LOOK FOR MERGE.
$1% MOVE T1,(T2) ;[OK] [354] GET INST
MOVEM T1,CMPRMP+1 ;[354] SAVE IT
RETURN ;[354] DONE
ENDB;
FI;
ENDB;
SUBTTL RELES. -- Add Input Record to Tree
BEGIN;
PROCEDURE (PUSHJ P,RELES.)
SKIPN T4,KEYCV. ;IS THE SORT ACTIVE?
PJRST E$$RLO ;[151] NO-AN ERROR
MOVEM L,SAVEL ;[207] SAVE REAL RECORD LENGTH
IFN FTNZSEC,<
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
>
PUSHJ P,(T4) ;[C20] CONVERT THE KEYS
JSP P4,.SAVE ;EXCHANGE AC BLOCKS
IFE FTNZSEC,<
HRLZ T1,KEYLOC ;GET THE LOCATION OF THE KEYS
HRRI T1,RC.KEY(R) ;GET START OF THE RECORD
HRRZ T2,XTRWRD ;[207] GET THE SIZE OF THE KEYS
ADDI T2,RC.KEY(R) ;GET THE LAST ADR FOR THE KEYS
BLT T1,-1(T2) ;[OK] PUT IN PLACE
MOVE T1,T2 ;[C20] GET DESTINATION FOR THE DATA
HRL T1,NEWREC ;GET SD RECORD ADDRESS
ADD T2,SAVEL ;[217] ADD LENGTH OF RECORD
BLT T1,-1(T2) ;[OK] [207] AND SAVE IN PLACE
>
IFN FTNZSEC,<
HRRZ T1,XTRWRD ;GET THE SIZE OF THE KEYS
MOVE T2,KEYLOC ;GET THE LOCATION OF THE KEYS
XMOVEI T3,RC.KEY(R) ;GET START OF THE RECORD
EXTEND T1,[XBLT] ;PUT IN PLACE
MOVE T1,SAVEL ;ADD LENGTH OF RECORD
MOVE T2,NEWREC ;GET SD RECORD ADDRESS
EXTEND T1,[XBLT] ;AND SAVE IN PLACE
>
MOVE T1,SAVEL ;[207] GET RECORD LENGTH IN WORDS
IMUL T1,IOBPW ;[207] GET IT IN BYTES
MOVEM T1,RC.CNT(R) ;MAKE IT THE CONTROL WORD
AOS INPREC ;COUNT RECORDS ON WAY IN
MOVE T1,$RELES ;[C20] GOTO RIGHT ROUTINE
PJRST (T1) ;[C20] ..
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELESI)
HRRZ T1,MRGCNT ;[C20]
IFE FTNZSEC,<
HRRZ T2,-1(P) ;[C20] [327] GET RELES. RETURN ADDRESS
HRRZ T2,(T2) ;[OK] [327] WHERE THERE'S A JRST
>
IFN FTNZSEC,<
MOVE T2,COBPDP ;GET CODE STACK
HLL T2,CODSEC ;MAKE IT GLOBAL
HRR T2,(T2) ;GET PC OFF STACK
HRR T2,(T2) ;GET <JRST ADDRESS>
>
MOVEM T2,MRGPC(T1) ;[OK] [327] TO TOP OF COBOL INPUT PROC
SOS NUMINP ;[327] COUNT ANOTHER FILE USED
HRLM T1,RN.FCB(S) ;STORE INDEX
AOS MRGIRC-1(T1) ;[OK] COUNT FIRST RECORD
MOVE T1,[XWD 1,1] ;[C20]
ADDM T1,MRGCNT ;[C20]
AOS RQ ;MAKE 1ST RUN
PUSHJ P,SETTRE ;PUT RECORD IN TREE
; PJRST NXMFIL ;[327] GO SET UP NEXT MERGE FILE
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,NXMFIL) ;[327] SET UP NEXT MERGE FILE
IF WE CAN STILL INITIALIZE
SKIPGE MRGCNT ;[327] WILL MORE FILES FIT?
SKIPN NUMINP ;[327] AND MORE FILES TO USE?
JRST $T ;[327] NO--GO START UP MERGE
THEN CONTINUE WITH NEXT FILE
IFE FTNZSEC,<
HRRZ T1,-1(P) ;[C20] [327] GET RETURN FROM RELES. OR MCLOS.
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE IT GLOBAL
HRR T1,(T1) ;GET PC OFF STACK
>
PUSHJ P,FNDNXT ;[327] FIND NEXT PUSHJ P,RELES.
NOOP ;[327] THERE IS STILL AT LEAST 1
MOVEM T2,MRGRLS ;[327] SAVE IN CASE LAST BEFORE MERGE
HRRZ T2,1(T2) ;[OK] [327] GET ADDR OF INPUT PROC FROM JRST
SUBI T2,2 ;GET TO OPEN
JRST $F
ELSE SETUP TO RETURN TO MERGE.
HRRZS LSTREC ;CLEAR LEFT HALF
IF THERE ARE HOLES IN THE TREE (SOME FILES WERE NULL ON LAST PASS)
SKIPL T1,MRGCNT ;[327] ANY HOLES LEFT IN THE TREE?
JRST $F ;[327] NO
THEN FILL UP TREE WITH EOF RECORDS
$1% MOVEM T1,MRGCNT ;[327] SAVE MRGCNT OVER SETTRE
SOS ACTTMP ;[327] ONE LESS ACTIVE FILE
HLLOS RQ ;[327] SET DUMMY REC IN TREE
PUSHJ P,SETTRE ;[327] ..
MOVE T1,MRGCNT ;[327] LOOP 'TIL TREE FULL
AOBJN T1,$1 ;[327] ..
FI;
MOVEM T1,MRGCNT ;[327] SAVE COMPLETED COUNT
IF EXACTLY ONE PASS (CAN RETURN RECORDS NOW)
SKIPN MLTPAS ;[327] ALREADY MULTI-PASS?
SKIPE NUMINP ;[327] OR MORE FILES TO MERGE
JRST $T ;[327] YES--NOT 1 PASS
THEN SET TO RETURN RECORDS TO COBOL NOW
MOVEI T1,RELES1 ;1 PASS
SKIPLE WSCSW ;NEED MERGE CHECK
MOVEI T1,RELCK1 ;YES, CHECK FIRST
MOVE T2,MRGPC+0 ;GET MERGE. PC
JRST $F
ELSE SET UP FOR ANOTHER TEMP FILE
MOVEI F,FCBORG ;[327] START A RUN
IF WE NEED TO START TEMP FILES
SKIPE MLTPAS ;[327] ALREADY BEEN HERE?
JRST $F ;[327] YES--SKIP THIS
THEN SET UP THE FIRST TEMP FILE
PUSHJ P,FSTRUN ;[327] INITIALIZE FIRST RUN
SETOM MLTPAS ;[327] REMEMBER WE'VE BEEN HERE
FI;
JSP P4,PTTREC ;WRITE OUT RECORD
MOVEI T1,RELES2 ;MERGE PASSES REQUIRED
HLRZ T2,RN.FCB(S) ;GET INDEX
MOVE T2,MRGPC(T2) ;[OK] PC OF INPUT ROUTINE
SKIPG WSCSW ;NEED SEQUENCE CHECK?
JRST $F ;NO, GET THE NEXT RECORD
EXCH R,LSTREC ;YES, SAVE THIS RECORD
HRRM R,RN.REC(S)
MOVEI T1,RELCK2 ;CAUSE CHECKING TO TAKE PLACE
FI;
MOVEM T1,$RELES
FI;
IFE FTNZSEC,<
MOVE T1,PSAV ;GET ORIGINAL STACK POINTER
HRRM T2,-1(T1) ;[OK] SET NEW RETURN
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE IT GLOBAL
HRRM T2,(T1) ;SET NEW RETURN ADDRESS TO USER CODE
>
RETURN
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELCK1)
MOVE J,LSTREC ;GET LAST RECORD
HLRZ F,RN.FCB(S) ;GET INDEX TO FILE
AOS MRGIRC-1(F) ;COUNT ONE MORE
COMPARE (R,J)
JRST $E ;KEY(R) = KEY(J) ;OK
JRST $E ;KEY(R) > KEY(J) ;OK
PUSHJ P,SEQERR ;KEY(R) < KEY(J) ;OUT OF SEQUENCE
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELES1)
PUSHJ P,SETTRE
PJRST RETRND ;CONTINUE WITH RETRN. CODE
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELCK2)
MOVE J,LSTREC ;GET LAST RECORD
HLRZ F,RN.FCB(S) ;GET INDEX TO FILE
AOS MRGIRC-1(F) ;COUNT ONE MORE
COMPARE (R,J)
JRST $E ;KEY(R) = KEY(J) ;OK
JRST $E ;KEY(R) > KEY(J) ;OK
PUSHJ P,SEQERR ;KEY(R) < KEY(J) ;OUT OF SEQUENCE
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELES2)
PUSHJ P,SETTRE
MOVEI F,FCBORG
JSP P4,PTTREC ;WRITE OUT RECORD
HLRZ T2,RN.FCB(S)
MOVE T2,MRGPC(T2) ;[OK]
MOVE T1,PSAV ;GET ORIGINAL STACK POINTER
HRRM T2,-1(T1) ;[OK] SET NEW RETURN
SKIPG WSCSW ;NEED SEQUENCE CHECK?
RETURN ;NO, GET THE NEXT RECORD
EXCH R,LSTREC ;YES, SAVE THIS RECORD
HRRM R,RN.REC(S)
RETURN
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELCK0)
MOVE J,LSTREC ;GET LAST RECORD
AOS MRGIRC+0 ;COUNT ONE MORE
COMPARE (R,J)
JRST $E ;KEY(R) = KEY(J) ;OK
JRST $E ;KEY(R) > KEY(J) ;OK
MOVE T1,MRGIRC+0 ;KEY(R) < KEY(J) ;OUT OF SEQUENCE
SOJE T1,RELES0 ;BUT IGNORE FIRST TIME
PUSHJ P,SEQERR
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,RELES0)
MOVEI F,FCBORG
JSP P4,PTTREC ;WRITE OUT RECORD
HLRZ T2,RN.FCB(S)
MOVE T2,MRGPC(T2) ;[OK]
MOVE T1,PSAV ;GET ORIGINAL STACK POINTER
HRRM T2,-1(T1) ;[OK] SET NEW RETURN
SKIPG WSCSW ;NEED SEQUENCE CHECK?
RETURN ;NO, GET THE NEXT RECORD
EXCH R,LSTREC ;YES, SAVE THIS RECORD
HRRM R,RN.REC(S)
RETURN
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,SEQERR)
HLRZ F,RN.FCB(S) ;GET FILE INDEX
$ERROR (%,MRS,<MERGE record >,+)
$MORE (DECIMAL,MRGIRC-1(F))
$MORE (TEXT,< not in sequence for >)
MOVE T1,MRGPC(F) ;[C20] GET POINTER FILE NAME
HRRZ T1,(T1) ;[C20] ..
MOVE T1,(T1) ;[OK] GET FILE NAME
$MORE (SIXBIT,T1)
$CRLF
RETURN
ENDB;
SUBTTL MCLOS. CLOSE OUT INPUT MERGE FILE
BEGIN
PROCEDURE (PUSHJ P,MCLOS.)
IFN FTNZSEC,<
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
>
JSP P4,.SAVE ;GET SORT ACCS
IF STILL INITIALIZING FILES IN RELESI
SKIPL MRGCNT ;[327] STILL INITIALIZING?
JRST $T ;[327] NO
THEN PASS THIS FILE (IGNORE IT) AND CONTINUE WITH NEXT
SOS NUMINP ;[327] FORGET THIS FILE
PJRST NXMFIL ;[327] GO GET ANOTHER
ELSE CLOSE THE FILE AND SEE WHAT TO DO NEXT
HLLOS RQ ;SET TERMINATING RUN#
PUSHJ P,SETTRE ;PUT END IN TREE
IF NOT LAST FILE
SOSG ACTTMP ;ALL DONE?
JRST $T ;YES
THEN CLOSE FILE AND CONTINUE
MOVEI F,FCBORG
SKIPN NUMENT ;IF MULTI-PASS
JRST RETRND ;NO, RETURN RECORD TO USER
JSP P4,PTTREC ;WRITE IT OUT
HLRZ T1,RN.FCB(S) ;GET NEXT FILE
MOVE T1,MRGPC(T1) ;[OK] GET INPUT ROUTINE
IFE FTNZSEC,<
HRRM T1,-1(P) ;SET RETURN TO GET IT
>
IFN FTNZSEC,<
MOVE T2,COBPDP ;GET CODE STACK
HLL T2,CODSEC ;MAKE IT GLOBAL
HRRM T1,(T2) ;SET NEW RETURN ADDRESS TO USER CODE
>
RETURN
ELSE TERMINATE CYCLE AND START AGAIN
SETZM MRGIRC ;CLEAR INPUT COUNTS
MOVE T1,[MRGIRC,,MRGIRC+1] ; SO THAT ERROR MESSAGE
BLT T1,MRGIRC+MX.TMP ; WILL CONTAIN CORRECT NUMBER
IF NO MORE TO DO
SKIPE T1,NUMINP ;ANY MORE
JRST $T ;TOO BAD
THEN JUST CLOSE OUT OR RETURN
IF END OF MULTI-PASS MERGE
SKIPN LASPAS ;[327] ARE WE ON LAST PASS?
JRST $T ;[327] NO
THEN CLOSE OUT (GO MERGE TEMP FILES)
MOVE T2,MRGPC+0 ;[327] GET ADDR OF MERGE. CALL
IFE FTNZSEC,<
MOVE T1,PSAV ;[327] AND RETURN TO THERE
HRRM T2,-1(T1) ;[OK] [327] ..
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE IT GLOBAL
HRRM T2,(T1) ;SET NEW RETURN ADDRESS TO USER CODE
>
RETURN ;[327] ..
ELSE JUST RETURN NEXT RECORD TO COBOL
SETOM LASRET ;FLAG IT
PJRST RETRND
FI;
ELSE SET UP FOR ANOTHER MERGE
MOVEI F,FCBORG
PUSHJ P,CLSRUN ;OPEN NEXT TEMP FILE
MOVE T1,MRGRLS ;[327] FIND NEXT RELES. ROUTINE
PUSHJ P,FNDNXT ;[327] ..
NOOP ;[327] THERE *IS* ANOTHER
HRRZ T2,1(T2) ;[OK] [327] GET ADDR IN FOLLOWING JRST
SUBI T2,2 ;[327] GET TO OPEN ROUTINE
IFE FTNZSEC,<
MOVE T1,PSAV ;[327] RETURN TO THERE
HRRM T2,-1(T1) ;[OK] [327] ..
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE IT GLOBAL
HRRM T2,(T1) ;SET NEW RETURN ADDRESS TO USER CODE
>
IF LAST FILE
MOVE T1,NUMINP ;GET NUMBER LEFT
SOJN T1,$T
THEN JUST COPY FILE TO TEMP FILE
SETOM LASPAS ;[327] SIGNAL END
SETZM NUMINP ;[327] NO MORE FILES NOW
MOVEI T1,1
HRLM T1,RN.FCB(S) ;FIRST AND ONLY FILE
MOVEI T1,RELES0 ;USE THIS ROUTINE
SKIPLE WSCSW ;UNLESS CHECKING REQUIRED
MOVEI T1,RELCK0 ;IN WHICH CASE USE THIS
JRST $F
ELSE REINITIALIZE FOR MERGE PASS
PUSHJ P,SETMRG ;SETUP NUMRCB AGAIN
MOVN T1,ACTTMP
HRLZ T1,T1
ADDI T1,1
MOVEM T1,MRGCNT
MOVE T1,NUMINP ;[327] NEED ANOTHER PASS?
CAMG T1,MAXTMP ;[327] ..
SETOM LASPAS ;[327] NO--REMEMBER
PUSHJ P,INITRE ;FILL WITH NULLS
MOVEI T1,RELESI ;INITIALIZE AGAIN
FI;
MOVEM T1,$RELES
RETURN
FI;
FI;
FI;
ENDB;
SUBTTL MERGE. -- Simulate Master End of File
BEGIN;
PROCEDURE (PUSHJ P,MERGE.)
IFN FTNZSEC,<
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
>
JSP P4,.SAVE ;SAVE NEEDED AC'S
HLRZ F,RN.FCB(S) ;GET FILE POINTER
AOS LASRET ;ENABLE RETURNS
IF NOT 1 PASS /MERGE
SKIPLE MRGSW
SKIPE NUMTMP
THEN DO MERGE
PJRST MERGE% ;START UP THE MERGE PHASE
ELSE CHECK FOR ALL FILES NULL AND RETURN
MOVE T1,RQ ;[327] GET RUN # OF TOP RECORD
CAIN T1,-1 ;[327] IS IT THE EOF DUMMY ONE>
SETOM LASRET ;[327] YES--GIVE EOF ON NEXT RETRN.
RETURN
FI;
ENDB;
SUBTTL RETRN. -- Copy Records From Tree to Output File
BEGIN;
PROCEDURE (PUSHJ P,RETRN.)
SKIPN LASRET ;RETURNS ENABLED?
PJRST E$$RTO ;[151] NO, GIVE USER ERROR MESSAGE
IF SORT OR MULTI-PASS MERGE
SKIPLE MRGSW ;MERGE
SKIPE NUMENT ;MULTI-PASS?
JRST $1 ;SORT OR MULTI-PASS
SKIPLE OUTREC ;BUT NOT FIRST TIME
JRST $T ;YES
$1%
THEN RETURN RECORD FROM TEMP FILE
IFN FTNZSEC,<
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
>
JSP P4,.SAVE ;EXCHANGE AC BLOCKS
JRST $F
ELSE GET NEXT INPUT RECORD FOR 1 PASS MERGE
SKIPGE LASRET ;ALREADY OUTPUT LAST RECORD
JRST [SETZM LASRET
JRST CPOPJ1] ;YES
DMOVE R,SORTAC ;[OK]
HLRZ F,RN.FCB(S) ;GET INDEX
MOVE T1,MRGPC(F) ;[C20] GET NEXT RECORD
PJRST (T1) ;[C20] ..
;---------------------------------------;LONG WAIT TIL NEXT RECORD IS PROCESSED
RETRND: ;RETURN HERE FROM RELES.
IFE FTNZSEC,<
POP P,-1(P) ;REMOVE TOP RETURN
MOVEM P,PSAV ;SET RETURN TO RETRN. CALLER
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET COBOL STACK POINTER
ADJSP T1,-1 ;REMOVE TOP CALL
MOVEM T1,COBPDP ;RESTORE STACK POINTER
>
FI;
IFE FTNZSEC,<
HRRZI T1,RC.KEY(R) ;GET ADDRESS OF INTERNAL RECORD
ADD T1,XTRWRD ;[207] GET PAST CONVERTED KEY
HRLZS T1 ;PUT IN LEFT HALF
HRR T1,NEWREC ;GET ADR OF SD RECORD
HRRZ T2,REKSIZ ;GET THE NUMBER OF WORDS/RECORD
SUB T2,XTRWRD ;[207] ACCOUNT FOR KEYS
ADD T2,NEWREC ;[C20] GET LAST ADDRESS FOR BLT
BLT T1,-2(T2) ;[OK] RETURN RECORD TO COBOL PROGRAM
>
IFN FTNZSEC,<
MOVE T1,REKSIZ ;GET THE NUMBER OF WORDS/RECORD
SUB T1,XTRWRD ;SUBTRACT EXTRACT WORDS FOR KEY
SUBI T1,1 ;SUBTRACT SIZE OF FLAG WORD
XMOVEI T2,RC.KEY(R) ;GET ADDRESS OF INTERNAL RECORD
ADD T2,XTRWRD ;GET PAST CONVERTED KEY
MOVE T3,NEWREC ;GET ADR OF SD RECORD
EXTEND T1,[XBLT] ;RETURN RECORD TO COBOL PROGRAM
>
IF LAST SORT RECORD
SKIPL LASRET ;ANY MORE RECORDS TO RETURN?
JRST $T ;YES
THEN FLAG LAST AND RETURN
SETZM LASRET ;STOP ALLOWING RETURNS
IFE FTNZSEC,<
AOS -1(P) ;GIVE SKIP RETURN TO COBOL
>
IFN FTNZSEC,<
MOVE T1,COBPDP ;GET CODE STACK
HLL T1,CODSEC ;MAKE IT GLOBAL
AOS (T1) ;INCREMENT PC IN USERS SECTION
>
RETURN
ELSE GET NEXT RECORD
AOS OUTREC ;COUNT ONE MORE RECORD OUTPUT
SKIPG WSCSW ;NEED SEQUENCE CHECK?
PJRST RETRN% ;NO, GET THE NEXT RECORD
EXCH R,LSTREC ;YES, SAVE THIS RECORD
HRRM R,RN.REC(S)
PJRST RETRN%
FI;
ENDB;
BEGIN;
IFE FTNZSEC,< PROCEDURE (PUSHJ P,EOFOUT)>
IFN FTNZSEC,< PROCEDURE (PUSHJ P,EOFCBL)>
SETOM LASRET ;WANT ONLY ONE MORE RECORD
MOVE P,PSAV ;RESTORE STACK POINTER
RETURN ;AND RETURN TO COBOL
ENDB;
SUBTTL ENDS. -- Clean Up After Sort or Merge
BEGIN;
PROCEDURE (PUSHJ P,ENDS.)
MOVEM L,ACSAVE+5 ;SAVE AC L
MOVEI L,ACSAVE ;SET UP BLT POINTER
BLT L,ACSAVE+4 ;SAVE LIBOL'S ACS
IFN FTNZSEC,<
MOVEM P,COBPDP ;SAVE ORIGINAL STACK POINTER
XMOVEI P,STACK-1 ;SET UP NEW STACK
>
IF USER ROUTINE EXITED BEFORE E-O-F
SKIPN LASRET ;[125] DID WE END NORMALLY?
JRST $T ;[125] YES
THEN DELETE ANY OPEN FILES
MOVE T1,$RETRN ;[125] GET WHICH RETRN WAS USED
CAIE T1,RETRN0 ;[224] [125] ALL IN CORE?
SKIPN ACTTMP ;[224] OR ALL TEMP FILES GONE ALREADY?
JRST $F ;[125] YES, NO FILE TO CLOSE
DMOVE R,SORTAC ;[OK] [125] SETUP R & S
IF ONE TEMP FILE
CAIE T1,RETRN1 ;[125] 1 FILE?
JRST $T ;[125] NO
THEN JUST DELETE THIS FILE
MOVEI F,TMPFCB ;[125] POINTER
PUSHJ P,DELFIL ;[224] [125] DELETE FILE
JRST $F ;[125] DONE
ELSE DELETE ALL OPEN FILES
BEGIN
HLRZ F,RN.FCB(S) ;[125] GET WHICH FILE
PUSHJ P,DELFIL ;[224] [125] DELETE IT
SOSG ACTTMP ;[224] [125] SOME LEFT?
JRST $E ;[125] NO
HLLOS RQ ;[224] FLUSH TREE
PUSHJ P,SETTRE ;[125] GET NEXT RECORD
JRST $B ;[125] LOOP
ENDB;
FI;
JRST $F ;[125]
ELSE MAKE SURE ALL RECORDS WERE OUTPUT
MOVE T1,INPREC
CAME T1,OUTREC
PUSHJ P,E$$RNI ;RECORD NUMBER INCONSISTENT
FI;
IFE FTOPS20,<
PUSHJ P,RELSPC ;[C13] RELEASE ANY RETAINED MEMORY
SETZM FSLOC. ;[C20] [320] RESET- NO SORT IN PROGRESS
>;END IFE FTOPS20
IFN FTOPS20,<
PUSHJ P,RESET$ ;[335] CLEAN UP CORE
>
PUSHJ P,STATS ;[C20] TYPE STATISTICS, IF NECESSARY
MOVE T1,SDFILE ;RESET SD FILE BLOCK
HRRZ T2,OLDNXT
DPB T2,[<F%BNFT>&<IXMASK>+<Z (T1)>]
SETZM KEYCV. ;CLEAR THIS LOCATION
SETZM LASRET ;STOP ALLOWING RETURNS
MOVSI L,ACSAVE ;SET UP BLT POINTER
BLT L,T4 ;RESTORE LIBOL'S ACS
MOVE L,ACSAVE+5
IFE FTNZSEC,<
RETURN
>
IFN FTNZSEC,<
MOVE P,COBPDP ;RESTORE ORIGINAL P
JRST @COBRET ;RETURN TO CALLER
>
IFE FTOPS20,<
E$$CLC: $ERROR (%,CLC,<Cannot lower core after SORT>)
JRST $2 ;[16] CONTINUE
>
ENDB;
SUBTTL ACCUMULATOR SAVING ROUTINES
BEGIN;
PROCEDURE (JSP P4,.SAVE)
MOVEM T4,ACSAVE+4 ;SAVE AC T4
MOVEI T4,ACSAVE ;SET UP BLT POINTER
BLT T4,ACSAVE+3 ;SAVE LIBOL'S ACS
XMOVEI T4,.RESTR ;[C20] RETURN ADDRESS
PUSH P,T4 ;[C20] ..
DMOVE R,SORTAC ;[OK] RESTORE THE SORT ACS
MOVEM P,PSAV ;SAVE THE PRESENT PDL POINTER
RETURN
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,.RESTR)
DMOVEM R,SORTAC ;SAVE THE SORT ACS
MOVSI T4,ACSAVE ;SET UP BLT POINTER
BLT T4,T4 ;RESTORE LIBOL'S ACS
IFE FTNZSEC,<
RETURN ;RETURN TO THE COBOL PROGRAM
>
IFN FTNZSEC,<
MOVE P,COBPDP ;RESTORE USER'S STACK
JRST @COBRET ;RETURN TO SECTION 0
>
ENDB;
SUBTTL ROUTINE TO DO COMPARES IN COBOL SORT
;THIS ROUTINE ASSUMES USE OF COBOL KEY ROUTINE DURING THE RELEASE PHASE
IFN FTCOBOL,<
SEGMENT IMPURE ;[C20] [433] FORCE IMPURE CODE INTO LOW SEG
.CMPAR:
SEGMENT LPURE ;[C20] [433] BACK TO HIGH SEG
>
BEGIN;
.KLCMP:
IFN FTCOBOL,<
PHASE .CMPAR
.CMPAR:
>
IFE FTCOBOL,<
PHASE 0 ;BUG IN MACRO
>
AOS CMPCNT ;[C20] COUNT OF COMPARISONS
DMOVE T3,J ;GET THE RECORD POINTERS
KLCMP1: HRLI T3,.-. ;-XTRWRD TO MAKE T3 AN AOBJN PTR
KLCMP2: MOVE T1,1(T4) ;[OK] GET NEXT DATA WORD OF RECORD J
CAMN T1,1(T3) ;[OK] COMPARE TO DATA WORD OF RECORD R
KLCMP4: AOJA T4,KLCMP3 ;EQUAL, INCREMENT TO POINT TO NEXT WORD
CAMG T1,1(T3) ;[OK] FIND WHICH RECORD IS LARGER
JRST 2(P4) ;[OK] REC R < REC J
JRST 1(P4) ;[OK] REC R > REC J
KLCMP3: AOBJN T3,KLCMP2 ;TRY AGAIN IF ANY MORE WORDS
JRST 0(P4) ;[OK] NONE- THE KEYS ARE EQUAL
DEPHASE
KL.CL==.-.KLCMP ;[433] SIZE FOR KL-10
SEGMENT IMPURE ;[C20]
IFN FTCOBOL,<
.CMPAR:
>
IFE FTCOBOL,<
%CMPAR:
>
BLOCK KL.CL ;[433] LOAD THE CODE AT RUN TIME
SEGMENT LPURE ;[C20]
SUBTTL ERROR MESSAGES
;HERE ON FATAL ERRORS
E$$ATF: $ERROR (?,ATF,<At least 2 input files required for MERGE>)
E$$RLO: $ERROR (?,RLO,<RELEASE called out of sequence. SORT not active.>)
E$$DND: $ERROR (?,DND,<Device >,+)
IFE FTOPS20,<
POP P,T1 ;GET DEVICE OFF STACK
$MORE (SIXBIT,T1)
>
IFN FTOPS20,<
$MORE (ASCII,DEVNAM)
>
$MORE (TEXT,<: not disk. All scratch devices must be disk>)
DIE: $CRLF ;CLOSE OUT LINE
IFE FTOPS20,<
CALL RELSPC ;[C13] RELEASE ANY RETAINED MEMORY
>;END IFE FTOPS20
IFN FTOPS20,<
CALL RESET$ ;[335] CLEAN UP THE MESS
>;END IFN FTOPS20
IFE FTNZSEC,<
JRST STOPR. ;DO THE COBOL ERROR ROUTINE
>
IFN FTNZSEC,<
MOVE P,COBPDP ;RESTORE ORIGINAL P
JRST @STOPR. ;RETURN TO CALLER
>
E$$DNE: $ERROR (?,DNE,<Device >,+)
IFE FTOPS20,<
POP P,T1 ;GET DEVICE OFF STACK
$MORE (SIXBIT,T1)
>
IFN FTOPS20,<
$MORE (ASCII,DEVNAM)
>
$MORE (TEXT,< does not exist>)
$DIE
E$$RTO: $ERROR (?,RTO,<RETURN called out of sequence. SORT not active.>)
; $PURGE
;IFE FTNZSEC,< END>
;IFN FTNZSEC,< END <ENTVLN,,ENTVEC>>
END