Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/srtsrc/sort.mac
There are 18 other files named sort.mac in the archive. Click here to see a list.
; UPD ID= 98 on 2/6/84 at 4:14 PM by FONG
SUBTTL D.M.NIXON/DZN/DLC/BRF/KWS 10-Feb-83
SEARCH COPYRT
SALL
COPYRIGHT (C) 1975, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
;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.
SEARCH SRTPRM
XSEARCH ;SEARCH OTHER UNIVERSALS
IFN FTPRINT,<PRINTX [Entering SORT.MAC]>
.COPYRIGHT ;Put standard copyright statement in REL file
SEGMENT HPURE
IFN FTOPS20,<
TITLE SORT - SORT/MERGE for DECSYSTEM-20
>
IFE FTOPS20,<
TITLE SORT - SORT/MERGE for DECsystem-10
>
SUBTTL TABLE OF CONTENTS FOR SORT
; Table of Contents for SORT
;
;
; Section Page
;
; 1 TABLE OF CONTENTS FOR SORT ............................... 2
; 2 CALLING SEQUENCE CONVENTIONS ............................. 3
; 3 DEFINITIONS
; 3.1 Impure Data ....................................... 5
; 4 PSORT.
; 4.1 Prior Initialization .............................. 6
; 4.2 PSORT% - Initialization Continued ................. 7
; 5 CHECK MONITOR AND CPU TYPES .............................. 8
; 6 ZERO ALL IMPURE DATA ..................................... 10
; 7 RELES.
; 7.1 RELES% - Add Record to Tree ....................... 11
; 8 TREE MANIPULATION
; 8.1 Initialization .................................... 12
; 8.2 Insert Next Record ................................ 13
; 9 MERGE.
; 9.1 MERGE% - Begin a Merge Cycle ...................... 16
; 9.2 MERGE0 - 0 Temporary Files ........................ 22
; 9.3 MERGE1 - 1 Temporary File ......................... 23
; 9.4 MERGE2 - Final Merge of 2 or More Temporary Files . 24
; 10 RETRN.
; 10.1 RETRN% - Return Record From Tree to Output File ... 25
; 10.2 RETRN0 - 0 Temporary Files ........................ 26
; 10.3 RETRN1 - 1 Temporary File ......................... 27
; 10.4 RETRN2 - Final Merge of 2 or More Temporary Files . 28
; 11 GETREC
; 11.1 GETREC - Get Next Record From Input File .......... 30
; 11.2 GETSXR - Get SIXBIT Record ........................ 31
; 11.3 GETASR - Get ASCII Record ......................... 33
; 11.4 GETEBR - Get EBCDIC Record ........................ 39
; 11.5 GETBNR - Get Binary Record ........................ 46
; 11.6 GETFBR - Get FORTRAN Binary Record ................ 47
; 11.7 GTTREC - Get Next Record From Temporary File ...... 53
; 12 PUTREC
; 12.1 PUTREC - Put Next Record to Output File ........... 54
; 12.2 PUTSXR - Put SIXBIT Record ........................ 55
; 12.3 PUTASR - Put ASCII Record ......................... 56
; 12.4 PUTEBR - Put EBCDIC Record ........................ 62
; 12.5 PUTBNR - Put Binary Record ........................ 69
; 12.6 PTTREC - Put Next Record to Temporary File ........ 72
; 13 MEMORY MANAGEMENT ........................................ 74
; 14 STATISTICS ............................................... 80
; 15 TYPE-OUT ROUTINES ........................................ 81
; 16 ERROR MESSAGE SUPPRESSION CONTROL ........................ 82
; 17 ERROR MESSAGES ........................................... 83
SUBTTL CALLING SEQUENCE CONVENTIONS
;
;SORT/MERGE USES THE FOLLOWING 3 CALLING CONVENTIONS
;
;1.0 JSP T4,SUBROUTINE
;
; THIS IS USED ONLY IN THE FOLLOWING 3 PLACES
;
;1.1 JSP T4,GETBUF
; CALL TO GET THE NEXT INPUT BUFFER
; RETURNS EITHER
; JRST 1(T4) NORMAL CASE
; OR
; MOVE EF,PHYEOF ON END OF FILE
; JRST 0(T4)
;
;1.2 JSP T4,PUTBUF
; CALL TO WRITE THE NEXT OUTPUT BUFFER
; RETURNS
; JRST 0(T4)
;
;1.3 JSP P4,@EXTORG
; CALL TO EXTRACT THE NUMERIC KEYS FROM THE RECORD
; JUST READ IN BY GETREC ROUTINE.
; EXTORG CONTAINS RUN TIME GENERATED CODE
; RETURNS
; JRST 0(P4)
;2.0 JSP P4,SUBROUTINE
;
; USED ONLY IN THE FOLLOWING 3 PLACES
;
;2.1 JSP P4,@EXTORG
; SEE 1.3 ABOVE
; RETURN IS
; JRST 0(P4)
;
;2.2 JSP P4,GETREC
; TO GET THE NEXT INPUT RECORD
; MAY MAKE CALL TO GETBUF THEREFORE MAY NOT RETURN
; SEE 1.1 ABOVE
; NORMAL RETURN IS
; JRST 0(P4)
;
;2.3 JSP P4,PUTREC
; TO WRITE OUT THE NEXT RECORD
; SEE 1.2 ABOVE
; NORMAL RETURN IS
; JRST 0(P4)
;
;
;3.0 PUSHJ P,SUBROUTINE
;
; RETURNS MAY BE EITHER
;
; SINGLE RETURN TO CALLER+1
; POPJ P,
;
; OR SKIP RETURN TO CALLER+2
; AOS 0(P)
; POPJ P,
;
;4.0 JSP P4,@.CMPAR
; .CMPAR CONTAINS RUN TIME GENERATED CODE WHICH CONTAINS
; CALL TO SUBROUTINE TO COMPARE RECORDS IN
; (R) AND (J)
; THIS ROUTINE (WHICH IS COMPILED AT RUN TIME)
; HAS THREE RETURNS
; JRST 0(P4) KEY(R) = KEY(J)
; JRST 1(P4) KEY(R) > KEY(J)
; JRST 2(P4) KEY(R) < KEY(J)
SUBTTL INTERNAL/EXTERNAL DEFINITIONS
;GLOBAL ROUTINES
INTERN BLKSET,CLRSPC,E$$NEC,FRECOR,FRESPC,GENNAM,GETSPC,RELSPC,%ERMSG,%TCRLF,%TOCTW,%TOLEB,%TSTRG,%TDECW,%TSIXN
INTERN STATS,SSTATS,ZDATA,GETJOB,CLSRUN,SETMRG,DOEOF,FSTRUN,RELES%,SETTRE
INTERN PSORT%,CPUTST,SETSPC,GETREC,INITRE,MERGE%,PTTREC,PUTREC,E$$RNI,E$$RIE
INTERN CPOPJ,CPOPJ1,E$$TMT,RETRN%,RETRN0,RETRN1,RSTSPC
;GENERATE STRUCTURE MACROS
;NOW GENERATE THEM MAX = 10 FOR NOW
RADIX 10
$TEMPORARY (10,10)
RADIX 8
;EXTERNALS
;DEFINED IN SRTSTA
EXTERN ADVFLG,ALIGN,EXTORG,F.OXBK,FORFUN,FORHI,FORPDP,FORRET,IBUFNO,IOMODE,MAXKEY,MINKEY,MODE,MXDVSZ
EXTERN NOCRLF,P.VARF,P4SAV,RECSAV,RECSIZ,SEQNO,STATSW,.CMPAR
EXTERN DIE,EOFOUT,ERRRTI,FUNCT.,MSTEOT
;DEFINED IN SRTCMD
;DEFINED IN SRTJSS
EXTERN CLSFIL,DELFIL,ENTFIL,E$$NRO,FMTBFP,GETBUF,INIOUT,ISITMT,LKPFIL,PUTBUF,RFMBFP
EXTERN RMSGET,RMSPUT,TSTDEV,.TOLEB,OBUFSZ
;DEFINED IN SRTCER
EXTERN .ERMSG,.TCHAR,.TCORW,.TCRLF,.TDECW,.TOCTW,.TRBRK,.TSIXN,.TSTRG,.TTIME
;DEFINED IN SRTCBL
EXTERN COBPDP
SUBTTL DEFINITIONS -- Impure Data
SEGMENT IMPURE ;[C20]
;LOCATIONS IN SORT THAT SHOULD BE INITIALIZED TO 0 AT STARTUP TIME
;(I.E., EACH NEW COMMAND LINE) SHOULD BE BETWEEN Z.BEG AND Z.END FOR
;ZDATA TO FIND.
Z.BEG:!
GD (CPU,1) ;0 = KA10, 1 = KI10, 2 = KL10
LD (SECTSW,1) ;[C20] MEMORY SECTION TYPE
;[C20] 0=ALLOCATE MEMORY USING .JBFF
;[C20] 1=ALLOCATE MEMORY USING FUNCT.
;[C20] 2=ALLOCATE MEMORY USING SECTFF
LD (SECTFF,1) ;[C20] FREE MEMORY ADDRESS FOR NON-ZERO SECTION
LD (OLDCOR,1) ;[C13] ORGINAL FRECOR
LD (FRECOR,1) ;[C13] MEMORY AVAILABLE FOR ALLOCATION
LD (FREEND,1) ;[C13] END OF VALID FRECOR POOL
LD (MAXCOR,1) ;[C13] LARGEST MEMORY IN USE AT ONE TIME
LD (OLDFF,1) ;[C13] ORIGINAL .JBFF
LD (OLDREL,1) ;[C13] ORIGINAL .JBREL
LD (CHNFRE,1) ;[C19] CHANNELS AVAILABLE FOR ALLOCATION
GD (NUMRCB,1) ;NUMBER OF RECORDS IN TREE (ALSO IN MEMORY)
GD (TBUFNO,1) ;NUMBER OF BUFFERS PER TEMPORARY FILE
GD (OBUFNO,1) ;NUMBER OF BUFFERS FOR OUTPUT OR MERGE FILE
GD (TCBIDX,1) ;INDEX INTO TCB TABLE
GD (RECORD,1) ;INPUT RECORD SIZE IN BYTES
GD (REKSIZ,1) ;NUMBER OF WORDS IN RECORD + EXTRACTED KEYS
GD (XTRWRD,1) ;[207] # OF WORDS OF EXTRACTED KEYS
GD (NUMTMP,1)
GD (ACTTMP,1) ;NO. OF TEMP FILES CURRENTLY OPEN FOR INPUT
GD (STRNUM,1)
GD (STRNAM,MX.TMP) ;STRUCTURES FOR TEMPORARY FILES
GD (MAXTMP,1) ;MAX. NO. OF TEMP FILES IN USE DURING MERGE
GD (BUFALC,1)
LD (JOBNUM,1) ;SIXBIT JOB NUMBER ,, OCTAL JOB NUMBER
GD (RTRUNC,1) ;[C20] NUMBER OF TRUCATED RECORDS - 1
GD (CMPCNT,1) ;[C20] NUMBER OF KEY COMPARISONS
LD (RCBTOT,1) ;[C20] NUMBER OF RECORDS IN MEMORY FOR SORT PHASE
LD (BUFTOT,1) ;[C20] COPY OF UBUFSZ FOR STATS
LD (RUNTOT,1) ;NUMBER OF RUNS
GD (TMPTOT,1) ;[C20] NUMBER OF TEMP WORDS WRITTEN
LD (CPUTIM,1) ;[C20] STARTING CPU TIME
LD (ORGTIM,1) ;[C20] STARTING DAY TIME
GD (NUMLFT,1) ;NUMBER OF TEMP FILES STILL TO MERGE
GD (NUMENT,1) ;NUMBER OF ENTERS DONE (FOR APPEND CODE)
LD (MRGNUM,1) ;NUMBER OF MERGE PASS
GD (NUMINP,1) ;NUMBER OF INPUT FILES
GD (BUFORG,1) ;[C13] START OF BUFFER POOL AREA
GD (BUFSZ,1) ;[C13] SIZE OF BUFFER POOL
GD (UBUFSZ,1) ;[C13] USEFUL SIZE OF BUFFER POOL
;[C13] BUFFERS ON TOPS-20 MUST START ON A PAGE
;[C13] BOUNDARY, THEREFORE THERE IS SOME
;[C13] UNUSEABLE SPACE IN BUFSZ
GD (BUFPTR,1)
GD (TREORG,1) ;FIRST LOCATION OF NODE TREE
GD (TRESZ,1) ;[C13] SIZE OF TREE AREA
GD (RCBORG,1) ;[C13] FIRST LOCATION OF RECORD POOL
GD (RCBSZ,1) ;[C13] SIZE OF RECORD POOL
GD (LSTREC,1) ;PTR TO LAST RECORD JUST OUTPUT
GD (RQ,1)
GD (RC,1)
LD (FSTNOD,1)
GD (LOGEOF,1) ;LOGICAL END OF FILE INTERCEPT
GD (PHYEOF,1) ;PHYSICAL END OF FILE INTERCEPT
LD (RSAV,1)
GD (PSAV,1)
GD ($RETRN,1)
GD (INPREC,1) ;NO. OF INPUT RECORDS SEEN
GD (OUTREC,1) ;NO. OF OUTPUT RECORDS SEEN
GD (IOBPW,1) ;[201] BYTES-PER-WORD IN EXTERNAL FILE
GD (IOBPW2,1) ;[C03] BYTES-PER-WORD ADJUSTED FOR SIXBIT
LD (CURSEQ,1) ;SEQUENCE # OF RECORD IN THIS RUN
LD (NXTSEQ,1) ;SEQUENCE # OF RECORD IN NEXT RUN
GD (SRTDN,1) ;-1 WHEN SORT PHASE OVER
GD (MRGDN,1) ;-1 WHEN MERGE PHASE OVER (FINAL OUTPUT STARTED)
GD (MRGSW,1) ;-1, 0 MEANS NO MERGE, 1 MEANS /MERGE
GD (WSCSW,1) ;1 IF WITH SEQUENCE CHECK (/CHECK) FOR MERGE
GD (SUPFLG,1) ;SEVERITY OF ERRORS TO SUPPRESS
GD (ERRADR,1) ;ERROR RETURN ADDRESS FOR USER CONTROL
GD (FERCOD,1) ;ADDRESS OF WHERE TO STORE ERROR CODE
LD (ADDR,1) ;ADDRESS OF MEMORY BLOCK (FOR FUNCT.)
LD (SIZE,1) ;SIZE OF MEMORY BLOCK (DITTO)
LD (CHANEL,1) ;[C19] CHANNEL FROM FUNCT.
LD (STATUS,1) ;RETURN STATUS FROM FUNCT.
LD (LSCWSZ,1) ;SIZE OF FIRST CONTINUE LSCW WORD SEEN
LD (LSCWMS,1) ;LSCWSZ-1 = MASK FOR CREATING CONTINUE LSCW BLOCKS
LD (CORSTK,1) ;PTR TO STACK OF MEMORY ALLOCATION WORDS
LD (CSTACK,100) ;STACK OF MEMORY ALLOCATION WORDS
IFE FTOPS20,< ;ONLY ON TOPS10
LD (MYPPN,1) ;[115] LOGGED-IN PPN
LD (DSKARG,.DCUPN) ;ARGS FOR DSKCHR UUO
LD (STRUSE,1) ;[214] # OF FIRST UNUSED STRNAM ENTRY
LD (STRDEF,1) ;[214] -1 IF WE DEFAULTED STRNAM TO DSK:
LD (STRARG,3) ;ARGS FOR JOBSTR UUO
>;END IFE FTOPS20
GD (FCBORG,FCBLEN)
GD (TMPFCB,MX.TMP*FCBLEN) ;DO NOT SPLIT
GD (DFBORG,MX.TMP*DFBLEN)
STRSNM==DFBORG
STRULN==DFBORG+MX.TMP
Z.END==.-1
;LOCATIONS WHICH NEED NOT OR SHOULD NOT BE SET TO 0 ON STARTUP
;SHOULD BE PLACED HERE.
LD (T.BLK,LN.X) ;[215] ONE BLOCK MULTIPLEXED FOR ALL .TMP FILES
SUBTTL PSORT. -- Prior Initialization
COMMENT \
ENTER PSORT% WITH:
ALL DATA ZEROED INITIALLY
THEN SET THESE LOCATIONS SPECIFICALLY
OFFSET: 1 IF ENTERED FROM CCL (SRTSCN ONLY)
CPU: SET FOR KA10=0, KI10=1 OR KL10=2
MAXTMP: MAX. NO. OF TEMP FILES TO OPEN (NO. OF CHAN#)
TCBIDX: AOBJN WORD OF -MAXTMP,,0
JOBNUM: VALUE FROM PJOB UUO
MODE: LHS BITS OF RM.???, RHS INDEX TO DATA TYPE
SIXBIT=0, ASCII=1, EBCDIC=2, BINARY=3 INDEX
STRNUM: NO. OF TEMP STRUCTURES TO USE
RECORD: NO. OF BYTES IN RECORD
RECSIZ: SIZE OF RECORD IN WORDS (NOT COBOL)
REKSIZ: SIZE OF RECORD IN WORDS + EXTRACTED KEYS
NUMRCB: NO. OF RECORDS TO HOLD IN MEMORY DURING SORT
IBUFNO: NO. OF INPUT BUFFERS (NOT COBOL)
TBUFNO: NO. OF TEMP BUFFERS FOR SORT PHASE
\
SUBTTL PSORT. -- PSORT% - Initialization Continued
SEGMENT LPURE ;[C20]
BEGIN
PROCEDURE (PUSHJ P,PSORT%)
PUSHJ P,FMTBFP ;[C13] SETUP MEMORY POOLS
MOVE T1,NUMRCB ;[C20] [C13] NO. OF RECORDS
MOVEM T1,RCBTOT ;[C20] [C13] FOR STATS
MOVE T1,UBUFSZ ;[C20] BUFFER POOL SIZE
MOVEM T1,BUFTOT ;[C20] FOR STATS
IFN FTOPS20,<
MOVE T2,UBUFSZ ;[C13] GET USEFUL SIZE OF BUFFER POOL
IFE FTCOBOL,<
SKIPE COBPDP ;CALLED FROM COBOL?
JRST PSORT1 ;YES
MOVE T1,UBUFSZ ;[C13] GET USEFUL SIZE OF BUFFER POOL
LSH T1,-1 ;1/2 FOR TMP, 1/2 FOR INPUT
IDIV T1,MXDVSZ ;COMPUTE # OF INPUT BUFFERS
MOVEM T1,IBUFNO ; ..
IF /MERGE
SKIPG MRGSW
JRST $F
THEN DIVIDE BUFFER AREA BY NO. OF INPUT FILES
PUSH P,T1
IDIV T1,ACTTMP ;NO. OF ACTUAL FILES OVEN AT THIS TIME
MOVEM T1,IBUFNO ;NO. PER FILE
POP P,T1
FI;
SKIPN T1 ;T1 WILL BE ZERO IF INPUT
ADDI T1,1 ; IS FROM MTA, BECAUSE MXDVSZ
; HOLDS TWICE MTA BUFFER SIZE
IMUL T1,MXDVSZ ;REST IS FOR TEMP FILE BUFFERS
MOVE T2,UBUFSZ ;[C13] GET USEFUL SIZE OF POOL AGAIN
SUB T2,T1 ;SUBTRACT INPUT BUFFERS
>
PSORT1: IDIVI T2,PGSIZ ;COMPUTE PAGES PER TMP BUFFER
MOVEM T2,TBUFNO ;[325] SAVE (CHECK HERE)
SKIPLE MRGSW ;[325] IS IT MERGE?
MOVEM T2,OBUFNO ;[325] YES. NUMBER BUFFERS FOR FCB
>
IFE FTOPS20,<
PUSHJ P,SETSTR ;SET UP TEMP DSK UNITS
>
PUSHJ P,INITRE ;INITIALIZE TREE WITH NULL RECORDS
HRROS LSTREC ;-1 SIGNALS THAT ITS JUST A DUMMY
RETURN
ENDB;
SUBTTL CHECK MONITOR AND CPU TYPES
SEGMENT HPURE ;[C20]
BEGIN
PROCEDURE (JSP T4,CPUTST) ;[134] MAY NOT HAVE STACK WHEN CALLED
;CPUTST IS CALLED AS A PART OF SORT'S INITIALIZATION TO CHECK WHETHER IT IS
;BUILT FOR THE MONITOR AND CPU ON WHICH IT FINDS ITSELF RUNNING. IF ANY
;INCOMPATIBILITIES ARE FOUND, THEN APPROPRIATE MESSAGES ARE TYPED. ALSO, THE CPU
;TYPE IS SAVED FOR LATER, SINCE MANY OF THE COMPARISON GENERATION ROUTINES
;COMPILE BETTER CODE IF THEY SEE THAT SORT IS RUNNING ON A KI OR KL CPU.
;NOTE THAT FOR THE MONITOR INCOMPATIBILITY MESSAGES TO GET PRINTED PROPERLY,
;**NO** MONITOR CALLS SHOULD BE DONE UNTIL CPUTST IS CALLED,
;SO THAT THE FIRST GETTAB IS SORT'S FIRST MONITOR CALL.
MOVE T1,[%CNMNT] ;[134] THIS IS **SIMULATED** BY TOPS-20 MONITOR
;[134] I.E. DOES NOT CALL COMPAT. PAK.
XMOVEI T2,. ;[C20] A NON-ZERO SECTION?
TLNN T2,-1 ;[C20] YES, MAY FAIL, DONT DO GETTAB
GETTAB T1, ;SEE WHICH MONITOR
JRST $2 ;[C20] NOT IMPLEMENTED
LDB T1,[POINTR (T1,CN%MNT)] ;GET TYPE BYTE
CAILE T1,4 ;[134] DEFINED MONITOR TYPE?
MOVEI T1,2 ;[134] NO--CALL IT 'ITS' THEN
IFE FTOPS20,< ;[134] BRANCH DEPENDING ON MONITOR TYPE AND ASM SWITCHES
JRST @[IFIWS <$2,$2,E$$SRM,E$$SRM,E$$1N2>](T1) ;[C20] [134]
>
IFN FTOPS20,<
JRST @[IFIWS <E$$SRM,E$$2N1,E$$SRM,E$$SRM,$2>](T1) ;[C20] [134]
>
$2% SETZ T2, ;[C20] [134] BUILD CPU TYPE HERE
SETO T1, ;FOR STANDARD KA/KI TEST
AOBJN T1,.+1
JUMPN T1,$1 ;KA10
ADDI T2,1 ;[134] KI10 OR KL10
BLT T1,0 ;KL10 WILL STORE 1,,1
JUMPE T1,$1 ;KI10
ADDI T2,1 ;[134] KL10
$1%
IFN FTKL10,<
CAIGE T2,KL.CPU ;[134] ARE WE RUNNING ON A KL10?
JRST E$$LNI ;[134] NO--QUIT BEFORE DMOVES, BIS CODE
>
IFN FTKI10&<FTKL10-1>,< ;[134] ASSEMBLE ONLY IF KI10
CAIGE T2,KI.CPU ;[134] ARE WE RUNNING ON A KI10?
JRST E$$INA ;[134] NO--QUIT BEFORE DMOVES, ETC.
>
MOVEM T2,CPU ;[134] SAVE CPU TYPE FOR CODE GEN
IFE FTOPS20,<
GETPPN T1, ;[115] GET LOGGED IN PPN
JFCL ;[115] JUST IN CASE
MOVEM T1,MYPPN ;[115] STORE IT
>
RETURN
ENDB;
;THESE ARE MESSAGES THAT ARE PRINTED ONLY IF WE FIND OURSELVES ON THE
;WRONG CPU. HOST SYSTEM MONITOR CALLS (OR REASONABLE ASSUMPTIONS) ARE
;USED TO PRINT THE MESSAGES, TO MAXIMIZE THE POSSIBILITY THAT THE USER
;WILL SEE THEM. THUS, THE $ERROR MACRO IS NOT USED, AND SORT EXITS
;IMMEDIATELY AFTER PRINTING.
IFE FTOPS20,<
OPDEF PSOUT%[JSYS 76] ;[335] NEED THESE ON TOPS-10
OPDEF HALTF%[JSYS 170] ;[335]
>
DEFINE $ERR1(C,CODE,MSG)< ;;[134] PRINT ON TOPS-10
OUTSTR [ASCIZ \
C'SRT'CODE MSG
\]
EXIT
>
DEFINE $ERR2(C,CODE,MSG)< ;;[134] PRINT ON TOPS-20
HRROI T1,[ASCIZ \
C'SRT'CODE MSG
\]
PSOUT%
HALTF%
JRST .-1 ;;[134] HALTF% CONTINUES
>
E$$SRM: $ERR1 (?,SRM,<SORT/MERGE will not run on this machine.>)
IFE FTOPS20,<
E$$1N2: $ERR2 (?,1N2,<TOPS-10 version of SORT/MERGE will not run on TOPS-20.>)
>
IFN FTOPS20,<
E$$2N1: $ERR1 (?,2N1,<TOPS-20 version of SORT/MERGE will not run on TOPS-10.>)
>
IFN FTKL10,<
E$$LNI: $ERR1 (?,LNI,<KL version of SORT/MERGE will not run on KI or KA CPU.>)
>
IFN FTKI10&<FTKL10-1>,< ;[134] ASSEMBLE ONLY IF KI10
E$$INA: $ERR1 (?,INA,<KI version of SORT will not run on KA CPU.>)
>
SUBTTL ZERO ALL IMPURE DATA
ZHEAD: BLOCK 1 ;[427] LINK LOC
Z.BEG,,Z.END ;[427] DATA TO ZERO
.LNKEND S.LNK,ZHEAD ;[427] HEAD OF CHAIN OF DATA TO ZERO
BEGIN
PROCEDURE (JSP T4,ZDATA) ;ZERO AND INITIALIZE DATA AREAS
MOVEI T1,ZHEAD ;[427] HEAD OF LIST
$1% HLRZ T2,Z.ADD(T1) ;[C20] ZERO FIRST LOCATION
SETZM (T2) ;[C20] ..
HRLS T2 ;[C20] SETUP BLT AC
ADDI T2,1 ;[C20] ..
HRRZ T3,Z.ADD(T1) ;[C20] GET LAST LOCATION
BLT T2,(T3) ;[C20] ZERO DATA AREA
SKIPE T1,Z.NXT(T1) ;[OK] [427] SEE IF MORE TO DO
JRST $1 ;[427] YES, LOOP
IFE FTOPS20,<
MOVX T1,UU.IBC+.IOBIN ;[215] INITIALIZE T.BLK
MOVEM T1,T.BLK+X.OPN+.OPMOD ;[215] ..
MOVX T1,.TBS ;[215] ..
MOVEM T1,T.BLK+X.DVSZ ;[215] ..
MOVX T1,.RBALC ;[215] ..
MOVEM T1,T.BLK+X.RIB+.RBCNT ;[215] ..
MOVX T1,'TMP ' ;[215] ..
HLLZM T1,T.BLK+X.RIB+.RBEXT ;[215] ..
SETZM T.BLK+X.RIB+.RBSPL ;[215] ..
>;END IFE FTOPS20
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,GETJOB) ;GET JOB NUMBER
;GETJOB SETS LOCATION JOBNUM TO <SIXBIT JOB NUMBER PADDED WITH ZEROS>,,JOB
;NUMBER. THIS IS USED LATER BY THE TEMPORARY FILE ROUTINES TO GENERATE JOB-
;UNIQUE FILE NAMES FOR THE TEMPORARY FILES.
IFE FTOPS20,<
PJOB T1, ;GET JOB NUMBER
>
IFN FTOPS20,<
GJINF% ;[335]
MOVE T1,3 ;JOB NUMBER
>
MOVEM T1,JOBNUM ;SAVE IT
IDIVI T1,^D100 ;GET HUNDREDS
IDIVI T2,^D10 ;GET TENS
LSH T1,2*6 ;SHIFT INTO POSITION
LSH T2,6 ;...
ADD T2,T3 ;[C20]
ADD T1,T2 ;[C20]
IORI T1,'000' ;[C20] MAKE SIXBIT
HRLM T1,JOBNUM ;SIXBIT OCTAL JOB NUMBER
RETURN
ENDB;
SUBTTL RELES. -- RELES% - Add Record to Tree
SEGMENT LPURE ;[C20]
BEGIN
PROCEDURE (PUSHJ P,RELES%)
;SEE IF IN THIS RUN OR NOT
SKIPGE J,LSTREC ;GET PREVIOUS
JRST $2 ;STILL ON DUMMY RUN, WE CANNOT DO COMPARE
COMPARE (R,J)
JRST $1 ;KEY(R) = KEY(J) ;OK
JRST $1 ;KEY(R) > KEY(J) ;OK
JRST $2 ;KEY(R) < KEY(J) ;TOO BIG
$2% AOS RQ ;BUMP RUN NUMBER
AOSA T1,NXTSEQ ;BELONGS TO NEXT SEQUENCE
$1% AOS T1,CURSEQ ;BELONGS TO THIS RUN
TLNE T1,-1 ;WILL WE OVERFLOW A HALFWORD?
JRST $2 ;[443] YES -- START ANOTHER RUN
HRLM T1,RN.SEQ(S) ;STORE FOR EQUAL TEST
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
MOVEI F,TMPFCB ;FCB OF TEMP FILE
MOVE T1,RQ ;GET RUN #
CAMN T1,RC ;SAME AS CURRENT?
PJRST RELOUT ;YES, OUTPUT IT
MOVEM T1,RC ;RESET
PUSHJ P,RELOUT ;OUTPUT RECORD IN LSTREC FIRST
MOVE T1,NXTSEQ ;PREPARE TO RESET SEQ #
MOVEM T1,CURSEQ
SETZM NXTSEQ
SKIPN NUMTMP ;IF FIRST RUN
PJRST FSTRUN ;THEN INITIALIZE FIRST RUN
PJRST CLSRUN ;ELSE CLOSE THE RUN, AND OPEN A NEW ONE
ENDB;
BEGIN
PROCEDURE (PUSHJ P,RELOUT)
SKIPN RQ ;A "REAL" OUTPUT?
JRST [HRRZ R,RN.REC(S) ;NO, SET UP RECORD PTR
RETURN] ;SINCE 0 IS A DUMMY
SKIPL R,LSTREC ;HOWEVER WHAT WE ACTUALLY OUTPUT IS LSTREC
JSP P4,PTTREC ;EXCEPT FIRST TIME
HRRZ R,RN.REC(S) ;THIS WAS ONE USER THOUGHT WE OUTPUT
EXCH R,LSTREC ;KEEP IT FOR NEXT TIME, GET R FOR NEXT INPUT
HRRZS R ;KEEP LH(R) ZERO
HRRZM R,RN.REC(S) ;CHANGE PTR ALSO
RETURN
ENDB;
SUBTTL TREE MANIPULATION -- Initialization
BEGIN
PROCEDURE (PUSHJ P,INITRE)
;INITIALIZE THE RECORD TREE WITH NULL RECORD
;SET WITH
;RUN NO. = 0
;LOSER(R) = R
SETZM RC
SETZM RQ
SOS T2,NUMRCB ;[C20] USE ONE RCB TO HOLD LAST RECORD TO OUTPUT
SETZ J, ;[C20] CLEAR PTR
MOVE U,TREORG ;WHERE THE NODES START
MOVEI T1,RN.LEN(U) ;LOCATION OF NODE #1
MOVEM T1,FSTNOD ;USED IN COMPARES LATER
MOVE R,RCBORG ;[C13] WHERE THE RECORDS START
$1% MOVEM U,RN.LSR(U) ;POINT TO ITSELF, RUN NO. = 0
MOVE T1,J ;[C20] GET THIS INDEX
LSH T1,-1 ;J/2
IMULI T1,RN.LEN ;DISTANCE FROM START
ADD T1,TREORG ;ABS LOCATION
HRLZM T1,RN.FI(U) ;PTR TO INTERNAL FATHER
MOVE T1,NUMRCB ;
ADD T1,J ;[C20]
LSH T1,-1
IMULI T1,RN.LEN
ADD T1,TREORG
HRRM T1,RN.FE(U)
MOVEM R,RN.REC(U) ;PTR TO RECORD
ADD R,REKSIZ ;INCREMENT RECORD PTR
ADDI U,RN.LEN ;INCREMENT NODE
SOSLE T2 ;[C20] LOOP
AOJA J,$1 ;[C20] ..
HRRZM R,LSTREC ;PLACE TO HOLD RECORD JUST OUTPUT
;-1 SIGNALS JUST A DUMMY
MOVE S,TREORG ;INITIALIZE WITH NODE #0
HRRZ R,RN.REC(S) ;AND ITS RECORD
RETURN
ENDB;
SUBTTL TREE MANIPULATION -- Insert Next Record
BEGIN
PROCEDURE (PUSHJ P,SETTRE)
HRRZ U,RN.FE(S) ;GET NODE JUST ABOVE
$1% HLRZ T1,RN.RUN(U) ;GET ITS RUN NUMBER
CAMGE T1,RQ ;IF ITS LESS
JRST $3 ;SWAP
JUMPE T1,$4 ;DON'T TRY COMPARE IF DUMMY RUN
CAMN T1,RQ ;OR IF EQUAL
CAIN T1,-1 ;AND END DUMMY RUN
JRST $4
HRRZ J,RN.LSR(U) ;EQUAL, TEST IF LOSER(U) < R
HRRZ J,RN.REC(J)
COMPARE (R,J)
JRST $2 ;KEY(R) = KEY(J) ;TEST
JRST $3 ;KEY(R) > KEY(J) ;SWAP
JRST $4 ;KEY(R) < KEY(J) ;OK
$2% SKIPGE SRTDN ;SEE WHICH VERSION OF TEST REQUIRED
JRST $5 ;IN MERGE PHASE
HRRZ T2,RN.LSR(U) ;GET LOSER AGAIN
HLRZ T1,RN.SEQ(S) ;GET SEQ(R)
HLRZ T2,RN.SEQ(T2) ;[OK] GET SEQ(LOSER(U))
CAMG T1,T2 ;SEE WHICH CAME FIRST
JRST $4 ;KEY(R) < KEY(J)
JRST $3 ;KEY(R) > KEY(J)
$5% HRRZ T2,RN.LSR(U) ;GET LOSER AGAIN
HLRZ T2,RN.FCB(T2) ;[OK] GET FILE IT CAME FROM
HLRZ T1,RN.FCB(S)
HLRZ T1,FILRUN(T1) ;[OK] GET RUN # OF RECORD IN R
HLRZ T2,FILRUN(T2) ;[OK] GET RUN # OF RECORD IN J
CAMG T1,T2 ;SEE WHICH CAME FIRST
JRST $4 ;KEY(R) < KEY(J)
; JRST $3 ;KEY(R) > KEY(J)
$3% MOVE T1,<RN.RUN+RN.LSR>/2(U) ;GET RUN# AND LOSER
HRRM S,RN.LSR(U) ;SET NEW LOSER
HRRZ S,T1 ;SWAPED WITH S
HRRZ R,RN.REC(S) ;RESET RECORD PTR SO WE MATCH
MOVE T2,RQ ;CURRENT RUN#
HRLM T2,RN.RUN(U) ;SWAP
HLRZM T1,RQ ;...
$4%
;NOW SEE IF AT TOP YET
CAMG U,FSTNOD ;AT NODE #1?
RETURN ;YES
HLRZ U,RN.FI(U) ;RESET CURRENT WINNER AND TRY AGAIN
JRST $1 ;AND CONTINUE
ENDB;
BEGIN
PROCEDURE (PUSHJ P,CLSRUN)
;HERE TO OPEN NEW TEMP FILE
PUSHJ P,CLSFIL ;CLOSE FILE
PUSHJ P,SETPAS ;RENDER FILE PASSIVE
PUSHJ P,ENTFIL ;ENTER NEW FILE NAME
SETZM FILSIZ(F)
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,FSTRUN)
;INITIALIZE TEMP FILE FOR FIRST RUN
;USES P1, P2
SETZM FILSIZ(F) ;CLEAR NUMBER OF RECORDS IN FILE
SETZM BUFALC ;FIRST TIME, SO ALLOCATE BUFFER
PUSHJ P,ENTFIL ;ENTER FILE
SETOM BUFALC ;REUSE BUFFERS FROM NOW ON
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,SETMRG)
;SETMRG IS CALLED TO COMPUTE THE NEW TREE SIZE FOR MERGES. SORT CAN ONLY HANDLE
;MAXTMP INPUT FILES AT A TIME, SO SETMRG IS CALLED BEFORE EACH NEW 'HUNK' OF
;INPUT FILES IS PROCESSED. AT THE TIME SETMRG IS CALLED, NO FILES HAVE BEEN
;OPENED AND LOOKED AT, SO THAT WE DON'T KNOW YET IF ANY OF THE FILES ARE NULL.
;THUS IT IS POSSIBLE THAT SETMRG WILL CAUSE A LARGER TREE TO BE ALLOCATED THAN
;IS ABSOLUTELY NECESSARY. THIS DOESN'T MATTER, SINCE GETMRG (FOR STAND-ALONE
;SORT) AND RELESI/MCLOS. (FOR COBOL SORT) HANDLE THIS CASE.
MOVE T1,NUMINP ;GET NO. OF INPUT FILES
CAMLE T1,MAXTMP ;MORE THAN WE CAN HANDLE
MOVE T1,MAXTMP ;YES, USE MAX
MOVEM T1,ACTTMP
MOVEM T1,NUMRCB ;THIS IS NO. OF RECORDS IN MEMORY
AOS NUMRCB ;[327] PLUS ONE FOR LASTREC
RETURN
ENDB;
SUBTTL MERGE. -- MERGE% - Begin a Merge Cycle
BEGIN
PROCEDURE (PUSHJ P,MERGE%)
IF FIRST TIME
SKIPE LSCWMS
JRST $F
THEN MAKE SURE CONTINUE LSCW SIZE AND MASK IS SET UP
SKIPN T1,LSCWSZ ;ALREADY SEEN?
MOVEI T1,^D128 ;NO, USE THE DEFAULT SIZE
MOVEM T1,LSCWSZ ;SET IT BACK
SUBI T1,1 ;MASK IS 177 OR 777
MOVEM T1,LSCWMS
FI;
IF HERE FOR FIRST TIME (NOT A MERGE CYCLE) AND NOT /MERGE
SKIPG MRGSW
SKIPGE SRTDN ;-1 ON MERGE CYCLES
JRST $T
THEN THE OUTPUT FILE IS AT TMPFCB
MOVEI F,TMPFCB ;PTR TO FCB OF TEMPORARY OUTPUT FILE
JRST $F
ELSE ON MERGE CYCLE OUTPUT FILE IS AT FCBORG
MOVEI F,FCBORG ;FCB OF MERGE OUTPUT FILE
FI;
SKIPLE MRGSW ;ALREADY SETUP IF /MERGE
JRST $3 ;YES, JUST CLOSE RUN
IF WE HAVE NO OUTPUT FILE
SKIPN NUMTMP ;ANY OUTPUT FILES?
THEN SET RETRN. ADDRESS AND RETURN TO CALLER
JRST MERGE0
FI;
;DUMP IN MEMORY TREE
IF FIRST TIME THROUGH
SKIPGE SRTDN ;0 ON FIRST TIME
JRST $F ;NOT
THEN OUTPUT RECORD STORED IN LSTREC TO CURRENT RUN
HRRZ R,LSTREC ;FLUSH LAST RECORD FIRST
JSP P4,PTTREC ;WE KNOW IT IS IN THIS RUN
HRRZ R,RN.REC(S) ;RESET RECORD PTR
FI;
$1% HLLOS RQ ;MAKE SURE NOT IN THIS RUN
PUSHJ P,SETTRE ;SET DUMMY RECORD IN TREE
SKIPN T1,RQ ;GET RUN NUMBER OF RECORD IN (R)
JRST $1 ;STILL ON DUMMY RUN
CAIN T1,-1 ;TEST FOR END CONDITION
JRST $3 ;ALL DONE
CAMN T1,RC
JRST $2 ;STILL IN CURRENT RUN
MOVEM T1,RC ;RESET CURRENT RUN (ONLY HAPPENS AFTER DUMMY)
PUSHJ P,CLSRUN ;CLOSE THIS RUN
$2% JSP P4,PTTREC ;WRITE IT OUT
JRST $1 ;LOOP FOR ALL IN-MEMORY RECORDS
$3%
IF FIRST TIME
SKIPGE SRTDN
JRST $F
THEN STORE NO. OF RUNS
MOVE T1,NUMTMP ;GET NUMBER OF RUNS ON SORT PASS
MOVEM T1,RUNTOT ;SAVE FOR ENDS. CODE
SETOM SRTDN ;SIGNAL THAT WE'VE BEEN HERE
SETZM WSCSW ;CLEAR CHECK FLAG SINCE ITS ALL DONE WITH
FI;
;CLOSE OUT LAST TEMP FILE
PUSHJ P,CLSFIL ;CLOSE FILE
PUSHJ P,SETPAS ;RENDER FILE PASSIVE
IF ONLY ONE TEMP FILE
MOVE T1,NUMTMP ;GET NO. OF TEMP FILES
THEN COPY (OR RENAME) IT
SOJLE T1,MERGE1 ;ONLY ONE, COPY IT
FI;
MOVE T1,[DFBORG,,TMPFCB] ;[C20] GET FIRST BLOCK
MOVE T2,MAXTMP ;[C20] NO. TO COPY
$4% MOVE T3,T1 ;[C20] GET BLT AC
ADD T1,[DFBLEN,,DFBLEN] ;[C20] ADVANCE TO NEXT
HRRZ T4,T1 ;[C20] GET BLT END
BLT T3,-1(T4) ;[C20] COPY PART WE NEED
ADDI T1,FCBLEN-DFBLEN ;ADVANCE RHS TO NEXT ALSO
SOJG T2,$4 ;[C20] LOOP
MOVE T1,NUMTMP ;NUMBER OF TEMPORARY FILES
MOVEM T1,NUMLFT ;STILL TO DO
SETZM NUMTMP ;START COUNTING AGAIN IF WE HAVE TO
CAMLE T1,MAXTMP ;MORE THAN MAXTMP ?
MOVE T1,MAXTMP ;YES, INITIALIZE ONLY LOWEST ONES
MOVEM T1,ACTTMP ;NO. ACTIVE THIS TIME
MOVEM T1,NUMRCB
AOS NUMRCB ;ONE FOR LSTREC TO HOLD AT EOF TIME
SETZM BUFALC ;MAKE SURE WE ALLOCATE
PUSHJ P,RFMBFP ;REFORMAT BUFFER POOL FOR MERGE
PUSHJ P,INITRE ;INITIALIZE THE TREE WITH NULLS
PUSHJ P,GETACT ;SETUP AT MOST MAXTMP FILES
IF NOT MORE THAN MAXTMP FILE
SKIPN T1,NUMLFT ;MORE THAN MAXTMP TMP FILES ?
THEN DO IN ONE PASS
JRST MERGE2 ;NO, FINAL MERGE PASS NOW
FI;
;MERGE AT MAXTMP TO 1 RATE
MOVN T1,MAXTMP ;-NO. OF TEMP FILES ALLOWED
HRLZM T1,TCBIDX ;RESET NAME INDEX
SETZM NUMENT ;START ENTERS AGAIN
AOS MRGNUM ;INCREMENT MERGE PASS NUMBER
MOVEI T1,DELEOF ;
MOVEM T1,PHYEOF ;DELETE FILE IF PHYSICAL EOF
MOVEI T1,MRGEOF
MOVEM T1,LOGEOF ;GET NEXT RUN
MOVEI F,FCBORG
PUSHJ P,FSTRUN ;OPEN NEW OUTPUT FILE
JSP P4,PTTREC ;OUTPUT CURRENT WINNER TO FREE UP
;SPACE FOR NEXT RECORD
BEGIN
;LOOP TO READ FROM ALL TEMP FILES AND OUTPUT TO NEW TEMP FILE
;NOTE THIS LOOP EXITS VIA END-OF-FILE EXITS
$1% HLRZ F,RN.FCB(S) ;GET FCB OF RECORD JUST OUTPUT
JSP P4,GTTREC ;GET NEXT RECORD FROM SAME FILE
PUSHJ P,DOEOF ;[C20] HANDLE E-O-F
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
MOVEI F,FCBORG ;FCB OF OUTPUT FILE
MOVE T1,RQ ;GET RUN #
CAMN T1,RC ;SAME AS CURRENT?
JRST $2 ;YES, OUTPUT IT
MOVEM T1,RC ;RESET
PUSHJ P,CLSRUN ;CLOSE THE RUN
$2% JSP P4,PTTREC
JRST $1 ;LOOP
ENDB;
ENDB;
BEGIN
PROCEDURE (PUSHJ P,DELEOF)
PUSHJ P,DELFIL ;DELETE TEMP FILE NOW
SOSG T1,ACTTMP ;LAST RUN YET?
JRST MERGE% ;YES, TRY AGAIN
HLLOS RQ ;NO, SO RETURN WITH DUMMY RECORD
SKIPLE NUMLFT ;ON THE LAST CYCLE?
RETURN ;NOT YET
MOVE T2,NUMENT ;GET NUMBER OF NEW RUNS
ADD T2,T1 ;[C20] TOTAL RUNS LEFT TO DO
CAMG T2,MAXTMP ;CAN WE GO STRAIGHT TO OUTPUT?
JRST MRGLST ;YES
REPEAT 0,< ;NOT WORKING YET
MOVE T2,NUMENT ;GET NEW RUNS AGAIN
IDIV T2,MAXTMP ;SEE HOW MANY PASSES
JUMPE T3,$1 ;WITH ANY LUCK WE WON'T GET ANY MORE RUNS
ADD T1,T3 ;[C20] REMAINDER+ WHATS LEFT FROM THIS
CAMG T1,MAXTMP ;CAN WE DO IT IN 1 PASS?
JRST MRGNXT ;YES, START NEXT MERGE PASS
>;END REPEAT 0
$1% RETURN ;NO, CONTINUE UNTIL WE CAN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,MRGEOF)
JSP P4,GTTREC ;GET FIRST RECORD OF NEXT RUN
JRST E$$RIE ;SOMETHING WRONG
SOS NUMLFT ;1 LESS LEFT TO READ NOW
MOVE T1,RQ ;GET RUN #
CAIN T1,-1 ;INCASE JUST RETURNED FROM DELEOF
RETURN ;YES, RETURN TO CALLER
PUSH P,S ;SAVE WHO WE ARE
PUSHJ P,SETTRE ;GET NEW WINNER
POP P,U ;[OK] GET BACK ORIGINAL RECORD
CAMN S,U ;WAS IT THE WINNER?
AOS RQ ;YES, SO FORCE INTO NEXT RUN
RETURN ;RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,DOEOF)
HRLI EF,(IFIW) ;[C20] DISPTACH ON EOF
JRST @EF ;[C20] ..
ENDB;
BEGIN
PROCEDURE (PUSHJ P,MRGLST)
;HERE WHEN WE CAN FINISH MERGE IN THIS PASS. COMPLICATED BY THE FACT THAT SOME
;FILES (ACTTMP) ARE STILL OPEN, WHILE OTHERS (NUMTMP) ARE NOT YET. FIRST SEE IF
;WE HAVE MORE THAN ONE RUN IN MEMORY.
MOVE T2,NUMRCB ;[C20] NO. OF NODES
MOVE U,TREORG ;[C20] PTR
$1% HLRZ T1,RN.RUN(U) ;GET RUN #
CAIN T1,-1 ;IGNORE DUMMY AT END
JRST $2
CAMLE T1,RC ;IN CURRENT RUN?
JRST $3 ;NO, WE MUST FLUSH THIS RUN OUT
$2% ADDI U,RN.LEN ;[C20]
SOJG T2,$1 ;[C20] LOOP
JRST $4 ;DIDN'T FIND ANYTHING TO DO
$3% PUSHJ P,SETTRE ;OUTPUT RECORD TO TREE
MOVEI F,FCBORG ;FCB OF OUTPUT FILE
MOVE T1,RQ ;GET RUN #
CAME T1,RC ;SAME AS CURRENT?
JRST $4 ;NO, SO WE ARE THROUGH
JSP P4,PTTREC ;OUTPUT THE RECORD
HLRZ F,RN.FCB(S) ;GET FCB OF RECORD JUST OUTPUT
JSP P4,GTTREC ;GET NEXT RECORD FROM SAME FILE
PUSHJ P,DOEOF ;[C20] HANDLE E-O-F
JRST $3 ;PUT IN TREE
$4% MOVEI F,FCBORG ;OUTPUT CHAN
PUSHJ P,CLSFIL ;CLOSE IT
PUSHJ P,SETPAS ;RENDER FILE PASSIVE
HRRZS TCBIDX ;GET NO. OF DORMANT FILES
SOS TCBIDX ;BACKUP TO POINT TO LAST FILE WRITTEN
IFE FTCOBOL,<
SKIPE COBPDP ;CALLED FROM COBOL?
JRST $5 ;YES
IFE FTOPS20,<
MOVE T1,FILBUF(F) ;GET WHERE BUFFERS START
>
IFN FTOPS20,<
HRRZ T1,FILBUF(F) ;GET PTR TO START OF BUFFERS
MOVX T2,FI.DSK ;IS THIS A DISK FILE?
TDNE T2,FILFLG(F) ; ..
LSH T1,POW2(PGSIZ) ;IF SO, CONVERT PG TO ADDR
>
MOVEM T1,BUFPTR ;SO WE CAN REALLOCATE FOR OUTPUT
PUSHJ P,INIOUT ;OPEN OUTPUT MASTER FILE
$5%
>
BEGIN
MOVE T2,NUMRCB ;[C20] GET PTR AGAIN
MOVE U,TREORG ;[C20]
$1% HLRZ T1,RN.RUN(U) ;GET RUN # OF LOSER
CAIN T1,-1 ;IGNORE IF NOT DUMMY
SUBI T1,2 ;REDUCE BY 2 SO DUMMY IS NOW 777775
HRLM T1,RN.RUN(U) ;REPLACE IN TREE
ADDI U,RN.LEN ;[C20]
SOJG T2,$1 ;[C20] LOOP
SOS RQ ;REDUCE CURRENT RUN #
SOS RQ ;...
ENDB;
BEGIN
;NOW READ ALL RECORDS FROM TREE
;IF RECORD IS A REAL ONE PUT IT BACK WITH RUN # 777776
;IF RQ = 777775 THEN IT WAS A DUMMY
;OPEN A NEW TEMP FILE AND PUT NEW RECORD IN TREE
$1% MOVE T1,RQ ;GET RUN #
CAIN T1,-2 ;SEE IF END OF CONVERSION
JRST $E ;YES
CAIE T1,-3 ;SEE IF A NEW DUMMY
JRST $2 ;NO
SKIPGE TCBIDX ;ANY MORE DORMANT FILES?
JRST [HLLOS RQ ;NO
JRST $3] ;PUT REAL DUMMY BACK
HLRZ F,RN.FCB(S) ;GET FILE THAT WAS LAST USED
PUSHJ P,SETACT ;GET A PASSIVE FILE
SETZM FILCNT(F) ;CLEAR COUNT
PUSHJ P,LKPFIL ;LOOKUP NEW FILE
AOS ACTTMP ;ONE MORE FILE NOW
JSP P4,GTTREC ;GET FIRST RECORD
JRST E$$RIE
$2% MOVEI T1,-2
MOVEM T1,RQ ;PUT RECORD BACK WITH TERMINAL #
$3% PUSHJ P,SETTRE ;PUT IN TREE
JRST $1 ;SEE WHAT POPPED UP
ENDB;
BEGIN
;INCREASE REAL RUN NUMBERS BY 3 (TO +1)
MOVE T2,NUMRCB ;[C20] GET PTR AGAIN
MOVE U,TREORG ;[C20]
$1% HLRZ T1,RN.RUN(U) ;GET RUN # OF LOSER
CAIE T1,-1 ;LEAVE REAL DUMMY ALONE
ADDI T1,3 ;INCREMENT SO DUMMY IS NOW 777777
HRLM T1,RN.RUN(U) ;REPLACE IN TREE
ADDI U,RN.LEN ;[C20]
SOJG T2,$1 ;[C20] LOOP
SETZM RQ
AOS RQ ;INCREMENT CURRENT RUN #
ENDB;
BEGIN
;SETUP END-OF-FILE TRAPS AND RETURN TO TOP LEVEL
SETOM MRGDN ;SIGNAL DONE WITH TEMP MERGES
MOVEI T1,EOF15
HRRZM T1,LOGEOF
HRRZM T1,PHYEOF
IFE FTCOBOL,<
MOVEI F,FCBORG
SKIPN COBPDP ;SKIP IF CALLED FROM COBOL
JSP P4,PUTREC ;WE ALREADY HAVE FIRST RECORD IN R
>
MOVEI T1,RETRN2 ;WHICH RETRN. ROUTINE TO USE
MOVEM T1,$RETRN
MOVE P,PSAV
ENDB;
RETURN
ENDB;
;INITIALIZE AT MOST MAXTMP ACTIVE RUNS FOR INPUT
BEGIN
PROCEDURE (PUSHJ P,GETACT)
PUSH P,NUMTMP ;SAVE NUMTMP
MOVN T1,ACTTMP ;MINUS THE RUNS WE WILL DO THIS TIME
ADDM T1,NUMLFT ;RESIDUAL RUNS
MOVEI F,FCBORG ;[C20] PTR TO FIRST FCB FOR INPUT FILE
PUSH P,ACTTMP ;[C20] SAVE LOOP COUNT ON STACK
MOVE S,TREORG ;GET FIRST "WINNER"
HRRZ R,RN.REC(S) ;AND RECORD
$1% ADDI F,FCBLEN ;[C20] NEXT FILE
SKIPN BUFALC ;ALREADY ALLOCTED BUFFER RING ?
PUSHJ P,OBLFIL ;NO, SET IT UP FOR INPUT
JSP P4,GTTREC ;GET FIRST RECORD OF TEMP FILE
JRST E$$RIE ;SOMETHING WRONG
AOS RQ ;WILL BE RUN #1
HRLM F,RN.FCB(S) ;INDICATE WHICH FILE RECORD CAME FROM
AOS T1,NUMTMP ;RE-INITIALIZE THE RUN NUMBERS
HRLM T1,FILRUN(F) ;SAVE IN DFBORG BLOCK
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
HRRZ R,RN.REC(S) ;SET UP RECORD PTR
SOSLE (P) ;[C20] GET NEXT RECORD
JRST $1 ;[C20] ..
POP P,(P) ;[C20] RESTORE STACK
POP P,NUMTMP ;RESTORE NUMTMP
AOS RC ;SET CURRENT RUN TO #1
SETOM BUFALC ;INDICATE BUFFER RNGS FORMED
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,OBLFIL)
;SETUP FILE FOR INPUT -- DO OPEN, SET UP BUFFERS, AND LOOKUP
SETZM FILCNT(F) ;CLEAR BUFFER COUNT
PJRST LKPFIL ;PERFORM LOOKUP
ENDB;
SUBTTL MERGE. -- MERGE0 - 0 Temporary Files
BEGIN
PROCEDURE (PUSHJ P,MERGE0)
MOVEI T1,RETRN0
MOVEM T1,$RETRN ;WHERE TO GO
IFE FTCOBOL,<
SKIPE COBPDP ;CALLED FROM COBOL?
JRST $1 ;YES
MOVE T1,BUFORG ;[C13] GET START OFF BUFFER POOL
MOVEM T1,BUFPTR ;[C13] RESET BUFPTR
IFE FTOPS20,<
MOVE T1,UBUFSZ ;[C13] GET USEFUL BUFFER POOL SIZE
MOVE T2,F.OXBK ;[215] GET OUTPUT BUFFER SIZE
IDIV T1,X.DVSZ(T2) ;[OK] [215] DIVIDE BY BUFFER SIZE
CAIGE T1,2 ;[C18] AT LEAST TWO
MOVEI T1,2 ;[C18] ..
TRZ T1,1 ;[C18] MAKE EVEN
>
IFN FTOPS20,<
MOVE T1,UBUFSZ ;[C13] GET USEFUL SIZE OF BUFFER POOL
IDIV T1,OBUFSZ ;DIVIDE BY OUTPUT BUFFER SIZE
JUMPE T1,E$$NRO
>
MOVEM T1,OBUFNO ;RESET NUMBER OF OUTPUT BUFFERS
PUSHJ P,INIOUT ;INIT OUTPUT MASTER
>
SKIPG LSTREC ;LSTREC TO FLUSH FIRST?
IFE FTCOBOL,<
RETURN
>
IFN FTCOBOL,<
PJRST RETRN0 ;GET FIRST RECORD FOR COBOL
>
MOVE R,LSTREC ;YES, GET RECORD PTR
IFE FTCOBOL,<
JSP P4,PUTREC ;OUTPUT IT
>
RETURN ;RETURN WITH RECORD IN (R)
;Here for COBOL only
$1% SKIPG LSTREC ;LSTREC TO FLUSH FIRST?
PJRST RETRN0 ;GET FIRST RECORD FOR COBOL
MOVE R,LSTREC ;YES, GET RECORD PTR
RETURN ;RETURN WITH RECORD IN (R)
ENDB;
SUBTTL MERGE. -- MERGE1 - 1 Temporary File
BEGIN
PROCEDURE (PUSHJ P,MERGE1)
IFE FTCOBOL!FTFORTRAN,<
SKIPN COBPDP ;SKIP IF CALLED FROM COBOL
PUSHJ P,TSTDEV ;SEE IF SAME DEVICE
>
MOVEI T1,RETRN1 ;WE WILL HAVE TO COPY
MOVEM T1,$RETRN ;SET RETRN. ADDRESS
MOVEI T1,EOFSNG ;END OF FILE TRAP
MOVEM T1,LOGEOF
MOVEM T1,PHYEOF
MOVE T2,BUFORG ;[C13] START OF BUFFERS
MOVEM T2,BUFPTR ;POINT TO THEM
IFE FTOPS20,<
MOVE T1,UBUFSZ ;[C13] GET USEFUL SIZE OF BUFFER POOL
IFE FTCOBOL,<
MOVE T2,F.OXBK ;[215] GET OUTPUT BUFFER SIZE
MOVE T2,X.DVSZ(T2) ;[OK] [215] SIZE OF OUTPUT BUFFER
IDIVI T1,.TBS(T2) ;[OK] DIVIDE BY COMBINED BUFFER SIZE
CAIGE T1,2 ;[C18] AT LEAST TWO
MOVEI T1,2 ;[C18] ..
TRZ T1,1 ;[C18] MAKE EVEN
>
IFN FTCOBOL,<
IDIVI T1,.TBS ;INPUT TEMP BUFFERS ONLY
>
MOVEM T1,TBUFNO ;RESET NUMBER
IFE FTCOBOL,<
MOVEM T1,OBUFNO ;RESET NUMBER OF OUTPUT BUFFERS
PUSHJ P,INIOUT ;INIT OUTPUT MASTER
>;END IFE FTCOBOL
>;END IFE FTOPS20
IFN FTOPS20,<
MOVE T1,UBUFSZ ;[C13] GET USEFUL SIZE OF BUFFER POOL
IFE FTCOBOL,< ;IF NOT COBOL, WE HAVE OUTPUT FILE
SKIPE COBPDP ;CALLED FROM COBOL?
JRST [LSH T1,-<POW2(PGSIZ)> ;YES, DIVIDE BY TEMP BUFFER SIZE
MOVEM T1,TBUFNO ;SAVE NO. OF TEMP AND OUTPUT BUFFERS
JRST $1]
MOVE T2,OBUFSZ ;GET OUTPUT FILE BUFFER SIZE
IDIVI T1,PGSIZ(T2) ;[OK] DIVIDE BY COMBINED BUFFER SIZE
>
IFN FTCOBOL,< ;IF COBOL, WE ONLY HAVE TEMP FILE
LSH T1,-<POW2(PGSIZ)> ;DIVIDE BY TEMP BUFFER SIZE
>
MOVEM T1,TBUFNO ;SAVE NO. OF TEMP AND OUTPUT BUFFERS
IFE FTCOBOL,<
MOVEM T1,OBUFNO
SETZM BUFALC ;FORCE BUFFER ALLOCATION
PUSHJ P,INIOUT ;OPEN THE OUTPUT FILE
>
$1%
>;END IFE FTOPS20
SETZM TCBIDX ;SO WE GET FIRST FILE AGAIN
MOVEI F,TMPFCB
PUSHJ P,OBLFIL ;LOOKUP TEMP FILE AGAIN
IFE FTCOBOL,<
SKIPN COBPDP ;CALLED FROM COBOL?
JRST $2 ;NO
MOVEI T1,1 ;[415] SET NO. OF ACTIVE TEMP FILES
MOVEM T1,ACTTMP ;[415] TO 1 IN CASE USERS ENDS BEFORE EOF
MOVEI F,TMPFCB
JSP P4,GTTREC ;GET FIRST RECORD FROM TEMP FILE
JRST DOEOF ;[C20] E-O-F
$2%
>
IFN FTCOBOL,<
MOVEI T1,1 ;[415] SET NO. OF ACTIVE TEMP FILES
MOVEM T1,ACTTMP ;[415] TO 1 IN CASE USERS ENDS BEFORE EOF
MOVEI F,TMPFCB
JSP P4,GTTREC ;GET FIRST RECORD FROM TEMP FILE
JRST DOEOF ;[C20] E-O-F
$2%
>
MOVE P,PSAV
RETURN
ENDB;
SUBTTL MERGE. -- MERGE2 - Final Merge of 2 or More Temporary Files
BEGIN
PROCEDURE (PUSHJ P,MERGE2)
SETOM MRGDN ;SIGNAL DONE WITH TEMP MERGES
MOVEI T1,EOF15
HRRZM T1,LOGEOF
HRRZM T1,PHYEOF
IFE FTCOBOL,<
SKIPE COBPDP ;CALLED FROM COBOL?
JRST $1 ;YES
PUSHJ P,INIOUT ;OPEN SORT.OUT
JSP P4,PUTREC ;WE ALREADY HAVE FIRST RECORD IN R
$1%
>
MOVEI T1,RETRN2 ;WHICH RETRN. ROUTINE TO USE
MOVEM T1,$RETRN
MOVE P,PSAV
RETURN
ENDB;
SUBTTL RETRN. -- RETRN% - Return Record From Tree to Output File
BEGIN
PROCEDURE (PUSHJ P,RETRN%)
MOVE T1,$RETRN ;[C20] GO TO RIGHT ROUTINE
PJRST (T1) ;[C20] ..
ENDB;
SUBTTL RETRN. -- RETRN0 - 0 Temporary Files
BEGIN
PROCEDURE (PUSHJ P,RETRN0)
;HERE TO WRITE ALL IN-MEMORY RECORDS TO OUTPUT MASTER FILE
HLLOS RQ ;MAKE SURE NOT IN THIS RUN
HRRZ U,RN.FE(S) ;GET NODE JUST ABOVE
PUSHJ P,SETTRE ;SET DUMMY RECORD IN TREE
SKIPN T1,RQ ;GET RUN NUMBER OF RECORD IN (R)
JRST RETRN0 ;STILL ON DUMMY RUN
CAIN T1,-1 ;TEST FOR END CONDITION
JRST EOFOUT ;ALL DONE
CAME T1,RC
MOVEM T1,RC ;RESET CURRENT RUN (ONLY HAPPENS AFTER DUMMY)
RETURN
ENDB;
SUBTTL RETRN. -- RETRN1 - 1 Temporary File
BEGIN
PROCEDURE (PUSHJ P,RETRN1)
;HERE TO COPY SINGLE TEMP FILE TO OUTPUT FILE
MOVEI F,TMPFCB
JSP P4,GTTREC ;GET A RECORD FROM TEMP FILE
JRST DOEOF ;[C20] E-O-F
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,EOFSNG)
SETZM ACTTMP ;[415] NORMAL EOF TEMP FILE NOT ACTIVE NOW
PUSHJ P,DELFIL ;DELETE TEMP FILE
JRST EOFOUT ;FORCE OUT LAST RECORD
ENDB;
SUBTTL RETRN. -- RETRN2 - Final Merge of 2 or More Temporary Files
BEGIN
PROCEDURE (PUSHJ P,RETRN2)
HLRZ F,RN.FCB(S) ;GET WHICH FILE
JSP P4,GTTREC ;GET A RECORD
PUSHJ P,DOEOF ;[C20] E-O-F RETURN
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,EOF15)
PUSHJ P,DELFIL ;DELETE TEMP FILE
SOSG ACTTMP ;ALL DONE?
JRST EOFOUT ;YES
HLLOS RQ ;SET TERMINATING RUN#
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,SETPAS)
HRRZ T1,TCBIDX ;GET CURRENT POS
IMULI T1,DFBLEN
ADDI T1,DFBORG ;POSITION IN MEMORY
HRRZI T2,DFBLEN-1(T1) ;[C20] BLT PTR LIMIT
HRL T1,F ;[C20] GET START POSITION
BLT T1,(T2) ;[C20] COPY FILE
MOVE T1,TCBIDX
AOBJN T1,$1 ;INCREMENT PTR
MOVN T1,T1 ;GET NUMBER
HRLZ T1,T1 ;START AGAIN
$1% MOVEM T1,TCBIDX ;STORE BACK
RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,SETACT)
HRRZ T1,TCBIDX ;GET CURRENT POS
IMULI T1,DFBLEN
ADDI T1,DFBORG ;POSITION IN MEMORY
HRLZ T1,T1 ;FROM
HRR T1,F ;TO
HRRZI T2,DFBLEN-1(F) ;[C20] BLT PTR LIMIT
BLT T1,(T2) ;[C20] COPY FILE
SOS TCBIDX ;REDUCE INDEX
RETURN
ENDB;
SUBTTL GETREC -- GETREC - Get Next Record From Input File
IFE FTCOBOL,<
BEGIN
PROCEDURE (JSP P4,GETREC)
;GETREC RETURNS THE NEXT RECORD FROM THE INPUT FILE (OR NEXT ONE IF MERGING).
;FIRST, HANDLE ANY BLOCKING FACTOR FOR THIS FILE BY COUNTING DOWN THE RECORDS
;READ IN THIS BLOCK AND SKIPPING TO THE NEXT BLOCK IF IT'S TIME. THEN, RETURN
;THROUGH THE PROPER GET-RECORD ROUTINE BASED ON THE FILE'S I/O MODE. ALL OF THE
;LOWER-LEVEL GET-RECORD ROUTINES GETREC CALLS RETURN THROUGH THE KEY EXTRACTION
;CODE.
;
;CALL WITH:
; F/ POINTER TO FCB
; R/ POINTER TO RCB
; JSP P4,GETREC
;
;RETURNS EITHER:
; MOVE EF,PHYEOF!LOGEOF
; JRST 0(P4) ;END-OF-FILE
;OR:
; JRST 1(P4) ;NORMAL
HRLI T1,(IFIW) ;[C20] SAVE R
HRR T1,R ;[C20] ..
MOVEM T1,RSAV ;[C20] ..
IFN FTOPS20,<
MOVE T1,FILFLG(F)
TXNE T1,FI.RMS
JRST RMSGET ;RMS FILE
>
IFE FTFORTRAN,<
$1% SKIPE T1,FILBLK(F) ;BLOCKED FILE?
AOBJP T1,[MOVN T1,T1 ;RESET BLOCKING FACTOR
HRLZM T1,FILBLK(F) ;REFORM AOBJN PTR
PUSHJ P,SKPBLK ;[C17] ADVANCE TO NEXT BLOCK
RETURN ;EOF
HRRZ T3,IOMODE ;[201] FETCH I/O MODE
CAIN T3,MODEBCDIC ;IF EBCDIC
SKIPL FILFLG(F) ;AND VARIABLE
JRST $1 ;NO
CALL RDEBBT ;[C06] BYPASS BLOCK DESCRIPTOR WORD
CALL RDEBBT ;[C06] ..
CALL RDEBBT ;[C06] ..
CALL RDEBBT ;[C06] ..
JRST $1]
MOVEM T1,FILBLK(F) ;STORE BLOCKING FACTOR BACK
>
SKIPE T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JRST $2 ;STILL SOME
JSP T4,GETBUF ;BUFFER EXHAUSTED, ADVANCE TO NEXT
RETURN ;GIVE ERROR RETURN
$2%
CASE MODE OF (GETSXR,GETASR,GETEBR,GETBNR)
HRRZ T3,IOMODE ;[201] FETCH I/O MODE INDEX
JRST @[IFIWS <GETSXR,GETASR,GETEBR,GETBNR>]-1(T3) ;[C20]
ESAC;
ENDB;
SUBTTL GETREC -- GETSXR - Get SIXBIT Record
;STILL IN IFE FTCOBOL
IFE FTFORTRAN,<
BEGIN
PROCEDURE (JSP P4,GETSXR)
HRRZ T3,FILPTR(F) ;ADDRESS OF NEXT RECORD
HRRZ T2,(T3) ;[OK] CHECK SIXBIT COUNT WORD
MOVX T1,FI.MTA ;IS THIS A MAGTAPE?
TDNE T1,FILFLG(F) ;IF SO, L.H. MIGHT HAVE JUNK
HRRZS 0(T3) ;[OK] SO CLEAR IT OUT
AOS FILPTR(F) ;ACCOUNT FOR WORD READ
SOS T1,FILCNT(F) ; ..
JUMPE T2,GETREC ;SIMPLY IGNORE NULL RECORDS
MOVEM T2,RC.CNT(R) ;COPY BYTE COUNT
CAMGE T2,MINKEY ;IS IT BIG ENOUGH?
PUSHJ P,ERRKNR ;NO
ADD R,XTRWRD ;LEAVE SPACE FOR EXTRACTED KEYS
ADDI T2,5+6 ;ACOUNT FOR REMAINDER AND BYTE COUNT WORD
IDIVI T2,6
CAMLE T2,RECSIZ ;LEGITIMTE COUNT ?
PUSHJ P,GETTRC ;NO, TRUNCATE RECORD
SUBI T2,1 ;BUT WE HAVE ALREADY MOVED THE BYTE COUNT
IF RECORD IS CONTAINED IN CURRENT I/O BUFFER
CAMGE T1,T2 ;[C20] IS RECORD CONTAINED IN CURRENT BUFFER ?
JRST $T ;NO, RECORD SPANS BUFFERS
THEN
HRL T3,FILPTR(F) ;YES, SET ORIGIN ADDRESS OF RECORD
HRRI T3,RC.KEY(R) ;SET DESTINATION ADDRESS
ADD R,T2 ;[C20] PTR TO LAST WORD IN RECORD DESTINATION
BLT T3,0(R) ;TRANSFER RECORD
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
JRST $F
ELSE COPY PIECEMEAL
MOVE P1,T2 ;[C20] SIZE OF RECORD (WORDS)
WHILE MORE WORDS STILL WORDS TO READ DO
BEGIN
SKIPE T1,FILCNT(F) ;NUMBER OF WORDS LEFT IN CURRENT BUFFER
JRST $1 ;STILL SOME
JSP T4,GETBUF ;CURRENT BUFFER EXHAUSTED, ADVANCE TO NEXT
JRST E$$RIE ;WARN USER
$1% MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.KEY(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] PTR TO END OF RECORD FRAGMENT
BLT T3,0(R) ;TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$B ;FINISHED ?
ENDB;
FI;
HRRZ R,RSAV ;[C20] RESTORE R
AOS FILSIZ(F) ;COUNT 1 MORE RECORD
AOJA P4,@EXTORG ;[OK] [C13] EXTRACT KEYS AND GIVE OK RETURN
ENDB;
BEGIN
PROCEDURE (PUSHJ P,GETTRC) ;TRUNCATE RECORD ON INPUT
SUB T2,RECSIZ ;REMOVE WHATS OK
MOVEM T2,RECSAV ;SAVE DIFFERENCE
MOVEM P4,P4SAV ;FINAL RETURN
MOVEI P4,GOTTRC ;RETURN HERE
MOVE T2,RECORD ;GET MAX. RECORD COUNT
MOVEM T2,@RSAV ;[OK] STORE IT IN RECORD
MOVE T2,RECSIZ ;JUST COPY THIS MUCH
RETURN
ENDB;
BEGIN
PROCEDURE (JSP P4,GOTTRC) ;HERE WHEN FIRST PART OF RECORD COPIED
;HERE TO DELETE REST
JRST E$$RIE ;TRAP NON-SKIP RETURN
AOS P4,P4SAV ;RESTORE SKIP RETURN
MOVE T2,RECSAV ;HOW MUCH MORE TO DELETE
$1% CAMLE T2,FILCNT(F) ;ALL IN THIS BUFFER?
MOVE T2,FILCNT(F) ;NO, USE IT ALL
ADDM T2,FILPTR(F) ;ADVANCE BYTE PTR
MOVN T2,T2
ADDM T2,RECSAV ;COUNT IT DOWN
ADDB T2,FILCNT(F) ;SAME FOR BYTE COUNT
JUMPG T2,$2 ;BUFFER EMPTY?
JSP T4,GETBUF ;YES, GET NEXT
JRST $3 ;[105] AT E-O-F
$2% SKIPE T2,RECSAV ;MORE TO DO?
JRST $1 ;YES
$3% PUSHJ P,ERRRTI ;[105] WARN USER
RETURN
ENDB;
>;END IFE FTFORTRAN
SUBTTL GETREC -- GETASR - Get ASCII Record
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETASR) ;HERE TO GET NEXT ASCII RECORD
IF FIRST RECORD
SKIPE SEQNO ;[110] FIRST TIME ITS ZERO
JRST $F ;[110] ITS NOT
THEN CHECK FOR SEQUENCE NUMBER
HRRZ T1,FILPTR(F) ;[C20] [110] GET FIRST WORD
MOVE T1,(T1) ;[C20] ..
TRNE T1,1 ;[110] SEQUENCE NUMBER PRESENT?
AOSA T1,SEQNO ;[110] YES
SOSA SEQNO ;[110] NO
MOVEM T1,ALIGN ;[110] FORCE WORD ALIGNMENT
FI;
MOVE T2,FILPTR(F) ;GET COPY OF BYTE PTR
ILDB T1,T2 ;READ FIRST BYTE (WE KNOW ITS IN MEMORY)
IF LINE STARTS WITH NULLS OR LINE TERMINATORS
CAIG T1,.CHCRT ;CHECK FOR NUL LINE
CAIGE T1,.CHLFD ;I.E. LF, FF, VT OR CR ONLY
JUMPN T1,$F ;NO, A REAL LINE IF NOT NULL
THEN EAT IT UP
BEGIN
TLNN T2,760000 ;AT NEW WORD
ADD T2,[430000,,1] ;YES
MOVEM T2,FILPTR(F) ;STORE BACK
SOSLE FILCNT(F) ;COUNT DOWN
JRST GETASR ;AND TRY AGAIN
JSP T4,GETBUF ;RAN OUT, RELOAD NEW BUFFER
JRST 0(P4) ;OK, END OF FILE
JRST GETASR
ENDB;
FI;
IF FIRST CHAR IS ^Z FROM A TTY
CAIE T1,.CHCNZ ;TEST FOR ^Z
JRST $F ;NOT
MOVE T2,FILXBK(F) ;[215] GET DEVCHR BITS
IFE FTOPS20,< ;ON TOPS10,
MOVE T2,X.DVCH(T2) ;[OK] [215] ..
TXZ T2,DVCHMD ;[215] CLEAR I/O MODE BITS
CAXE T2,DVCHNL ;[215] NOT TTY: IF NUL:
TXNN T2,DV.TTY ;[215] NOW CHECK FOR TTY:
JRST $F ;[215] NOT--CONTINUE
>;END IFE FTOPS20
IFN FTOPS20,< ;ON TOPS20,
LDB T2,[POINT 9,X.DVCH(T2),17] ;[OK] GET DEVICE TYPE
CAXE T2,.DVTTY ;TTY?
JRST $F ;NO, CONTINUE
>;END IFN FTOPS20
THEN RETURN EOF
JRST [MOVE EF,PHYEOF ;SET EOF RETURN
JRST 0(P4)] ;AND RETURN
FI;
MOVE T1,RECORD ;[147] GET RECORD SIZE IN BYTES
MOVEM T1,RC.CNT(R) ;[147] STORE BYTE COUNT
ADD R,XTRWRD ;[147] LEAVE SPACE FOR EXTRACTED KEYS
SKIPGE FILFLG(F) ;HOPE ITS NOT VARIABLE?
JRST GETAVR ;TOO BAD
SKIPL FILPTR(F) ;SEE IF ON A WORD BOUNDARY
JRST GETASN ;ITS NOT
IDIVI T1,5
PUSH P,T2 ;SAVE REMAINDER
MOVE T2,T1
IMULI T2,5 ;INTEGRAL NO. OF BYTES
CAMLE T2,FILCNT(F) ;ALL IN THIS BUFFER?
JRST GETAML ;NO
HRLZ T3,FILPTR(F) ;GET BYTE PTR
HRRI T3,RC.KEY(R) ;DESTINATION
ADD R,T1 ;[C20] END OF BLT
SKIPE T1 ;DON'T DO BLT IF NO FULL WORDS
BLT T3,(R) ;MOVE ALL BUT LAST PARTIAL WORD
ADDM T1,FILPTR(F) ;ADJUST BYTE PTR
MOVN T2,RECORD ;NO. OF BYTES USED
ADDM T2,FILCNT(F) ;ACCOUNT FOR THEM
; PJRST GETALW ;NEXT PAGE
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETALW) ;GET ASCII LAST WORD OF RECORD
SKIPG FILCNT(F) ;WILL LAST WORD FIT?
JRST [JSP T4,GETBUF ;GET NEW BUFFER
JRST E$$RIE ;WARN USER
MOVN T2,(P) ;REMAINDER
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
JRST .+1]
$2% POP P,T2 ;GET REMAINDER BACK
JUMPE T2,GETCRL ;ALL DONE
HRRZ T1,FILPTR(F) ;[C20] GET FULL WORD
MOVE T1,(T1) ;[C20] ..
AND T1,ASCMSK(T2) ;[OK] ONLY WHAT WE REALLY NEED
MOVEM T1,RC.KEY(R) ;STORE IT
IFE FTKL10,<
IBP FILPTR(F) ;ADJUST BYTE PTR
SOJG T2,.-1
>
IFN FTKL10,<
ADJBP T2,FILPTR(F)
MOVEM T2,FILPTR(F)
>
; PJRST GETCRL ;BELOW
ENDB;
BEGIN
PROCEDURE (JSP P4,GETCRL) ;GET A CRLF
SKIPLE NOCRLF ;[N11] IF WE DON'T EXPECT A CRLF
JRST $3 ;[N11] DON'T TRY TO READ ONE
PUSHJ P,RDASBT ;READ AN ASCII BYTE (CR)
GETLF: PUSHJ P,RDASBT ; ... (LF)
GETEND: MOVE T1,FILPTR(F) ;[310] VAR. LINE TERM- SET UP ONLY
TLNE T1,760000 ;IS IT ON WORD BOUNDARY?
JRST $3 ;NO, EXTRACT KEYS AND RETURN
ADD T1,[430000,,1] ;YES,
MOVEM T1,FILPTR(F) ;ADVANCE TO NEXT WORD
$3% AOS FILSIZ(F) ;COUNT 1 MORE RECORD
HRRZ R,RSAV ;[C20] RESTORE R
MOVE T1,(R) ;GET CHAR COUNT
CAMGE T1,MINKEY ;IS IT BIG ENOUGH?
PUSHJ P,ERRKNR ;NO
AOJA P4,@EXTORG ;[OK] [C13] EXTRACT KEYS AND GIVE OK RETURN
ENDB;
ERRKNR: PUSH P,T1
PUSH P,T2
$ERROR (%,KNR,<Key not fully contained in record >,+)
$MORE (DECIMAL,FILSIZ(F))
$CRLF
POP P,T2
POP P,T1
POPJ P,
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (PUSHJ P,RDASBT) ;READ ASCII BYTE FROM INPUT BUFFER
IF BUFFER IS EMPTY
SOSL FILCNT(F) ;ANYTHING IN BUFFER?
JRST $F ;YES, STILL NOT EMPTY
THEN GET NEXT
JSP T4,GETBUF ;BUFFER EMPTY GET NEXT
JRST E$$RIE ;WARN USER
SOS FILCNT(F) ;COUNT DOWN BYTE WE WILL PICKUP
FI;
ILDB T1,FILPTR(F) ;GET BYTE
JUMPE T1,RDASBT ;IGNORE NULLS
CAIG T1,.CHCRT
CAIGE T1,.CHLFD
FASTSKIP
RETURN
SKIPGE FILFLG(F) ;FIXED OR VARIABLE?
JRST E$$JAL ;VARIABLE
E$$ARL: $ERROR (?,ARL,<ASCII record length incorrect>)
E$$JAL: $ERROR (?,JAL,<Junk in ASCII line>)
ENDB;
ASCMSK: BYTE (7)
BYTE (7) 177
BYTE (7) 177,177
BYTE (7) 177,177,177
BYTE (7) 177,177,177,177
BYTE (7) 177,177,177,177,177
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETAML) ;HERE WHEN RECORD CROSSES BLOCK BOUNDARY
MOVE P1,T1 ;[C20] SIZE OF RECORD (WORDS)
$1% SKIPE T1,FILCNT(F) ;NUMBER OF WORDS LEFT IN CURRENT BUFFER
JRST $2 ;STILL SOME
JSP T4,GETBUF ;EMPTY, GET NEXT
JRST E$$RIE ;WARN USER
$2% IDIVI T1,5 ;WORDS IN CURRENT BUFFER
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.KEY(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] PTR TO END OF RECORD FRAGMENT -1
BLT T3,1(R) ;TRANSFER RECORD FRAGMENT
MOVNI T1,5 ;5 BYTES PER WORD
IMUL T1,T2 ;- NO. OF WORDS
ADDM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$1 ;FINISHED ?
MOVN T2,(P) ;REMAINDER BYTES
ADDM T2,FILCNT(F) ;ACCOUNT FOR THEM
PJRST GETALW ;GET LAST WORD, SEE IF IN BUFFER
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETASN) ;HERE FOR ASCII RECORD NOT ON A WORD BOUNDARY
IFE FTKL10,<
LDB T1,[POINT 6,FILPTR(F),5] ;GET BYTE POSITION
MOVNS P1,T1 ;-NO. OF BITS LEFT
ADDI P1,^D36 ;LSHC COUNTER TO RIGHT JUSTIFY 5 BYTES
IDIVI T1,7 ;CONVERT TO BYTES
ADDM T1,FILCNT(F) ;ACCOUNT FOR THEM
ADD T1,RECORD ;NO. OF BYTES TO FOLLOW
IDIVI T1,5 ;NO. OF WORDS
PUSH P,T2 ;SAVE REMAINDER
MOVE T4,T1 ;[C20] NO. OF FULL WORDS TO COPY
MOVN T3,P1 ;NO. OF BITS TO SHIFT LEFT
ADDI T3,^D35 ;LSHC COUNTER FOR REMAINDER
AOS T2,FILPTR(F) ;ADVANCE BYTE PTR
HRLI T2,(POINT 7,) ; TO BEFORE FIRST BYTE
MOVEM T2,FILPTR(F) ; SO BOTH ILDB AND MOVE @ WORK
HRRZ T1,T2 ;[C20] GET FIRST WORD
MOVE T1,-1(T1) ;[C20] ..
LSH T1,-1 ;RIGHT JUSTIFY
IF THERE ARE FULL WORDS TO MOVE
JUMPLE T4,$F ;[C20] NO
THEN LOOP FOR REMAINING FULL WORDS
BEGIN
SKIPG FILCNT(F) ;ROOM IN THIS BUFFER?
JRST [PUSH P,T1 ;SAVE PARTIAL
PUSH P,T3 ;LSHC -COUNT
PUSH P,T4 ;[C20] SAVE T4
JSP T4,GETBUF ;GET NEW BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ;[C20] RESTORE T4
POP P,T3
POP P,T1
JRST $1]
$1% HRRZ T2,FILPTR(F) ;[C20] GET IT
MOVE T2,(T2) ;[C20] ..
LSHC T1,(P1) ;[OK] 35 BITS IN T1
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,RC.KEY(R) ;STORE
LSHC T1,(T3) ;[OK] MOVE REMAINDER INTO T1
MOVNI T2,5
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
AOS FILPTR(F) ;AND BYTE PTR
ADDI R,1 ;[C20] LOOP FOR ALL FULL WORDS
SOJG T4,$B ;[C20] ..
ENDB;
FI;
;NOW FOR LAST WORD
SKIPLE FILCNT(F) ;IS BUFFER EMPTY?
JRST $3 ;NO
PUSH P,T1 ;SAVE PARTIAL WORD
JSP T4,GETBUF ;YES, FILL IT
JRST E$$RIE ;WARN USER
POP P,T1 ;RESTORE PARTIAL WORD
$3% POP P,T3 ;GET REMAINDER
JUMPE T3,$4 ;NONE
HRRZ T2,FILPTR(F) ;[C20] GET IT
SKIPA T2,(T2) ;[C20] ..
$4% TDZA T2,T2 ;NO REMAINDER
AND T2,ASCMSK(T3) ;[OK] ONLY WHAT WE NEED
LSHC T1,(P1) ;[OK] FORM 35 BITS
LSH T1,1
MOVEM T1,RC.KEY(R) ;STORE FIRST WORD
SKIPE T2 ;ONLY ONE WORD
MOVEM T2,RC.KEY+1(R) ;STORE SECOND WORD
JUMPE T3,$5 ;NO REMAINDER
MOVN T3,T3
ADDM T3,FILCNT(F) ;ADJUST BYTE COUNT
IBP FILPTR(F)
AOJL T3,.-1 ;AND BYTE PTR
$5%
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T4,7 ;BYTE SIZE
PUSHJ P,GETEX ;GET RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
PJRST GETCRL ;ALL DONE
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETAVR) ;GET VARIABLE LENGTH ASCII RECORD
HRLZI T1,1(R) ;FORM BLT PTR
HRRI T1,2(R) ; TO CLEAR ALL OF BUFFER
SETZM 1(R) ;WE MUST DO THIS AT LEAST ONCE
; TO CLEAR BIT 35 IN EACH WORD
MOVE T2,REKSIZ ;[147] BYTE COUNT WORD + KEYS + WORDS IN USER'S RECORD
SUB T2,XTRWRD ;[147] GET JUST COUNT WORD AND REC LEN
CAIG T2,2 ;CHECK FOR SPECIAL CASE OF 1 DATA WORD
JRST $1 ;IF SO BYPASS BLT
ADD T2,R ;[C20] END OF BLT
BLT T1,-1(T2) ;[OK] CLEAR IT ALL
$1%
IFE FTKL10,<
HRLI T4,(POINT 7,,35) ;[C20] DEPOSIT BYTE PTR
HRR T4,R ;[C20] ..
MOVE P1,RECORD ;NO. OF CHARACTERS MAX. TO STORE
SKIPG SEQNO ;[110] CHECK FOR SEQUENCE NO.
JRST $3 ;NOT
HRRZ T1,FILPTR(F) ;[C20] GET FULL WORD
MOVE T1,(T1) ;[C20] ..
MOVEM T1,RC.KEY(R) ;STORE IT WITH BIT 35 ON
AOS FILPTR(F) ;BYPASS SEQ NO.
MOVNI T1,5 ;NO. OF BYTES
ADDM T1,FILCNT(F) ;WE'VE USED UP
SUBI P1,5 ;ACCOUNT FOR SEQ NO.
AOS T4 ;[C20] GET NEXT REAL BYTE
AOJA R,$3 ;[C20] ..
$2% PUSH P,T4 ;[C20] SAVE T4
JSP T4,GETBUF ;GET NEXT BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ;[C20] RESTORE T4
$3% SOSGE FILCNT(F) ;BUFFER EMPTY?
JRST $2 ;YES
ILDB T1,FILPTR(F) ;GET NEXT BYTE
JUMPE T1,$3 ;IGNORE NULLS
CAIG T1,.CHCRT ;SEE IF ONE OF
CAIGE T1,.CHLFD ;LF, VT, FF, CR
JRST [SKIPLE P1 ;[C20] ROOM FOR IT?
IDPB T1,T4 ;[C20] YES
SOJA P1,$3] ;[C20] LOOP UNTIL END OF LINE
JUMPGE P1,$4 ;[C20] RECORD TRUNCATION?
PUSHJ P,ERRRTI ;[C20] YES, WARN USER FIRST TIME
SETZ P1, ;[C20] ONLY COUNT CHAR WE REALLY STORED
$4% SUB P1,RECORD ;[C20] - NO. OF CHAR. STORED
MOVMM P1,@RSAV ;[OK] [147] STORE AS + BYTE COUNT
PJRST GETEND ;[310] READ THE LF-LAST ONE
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T3,RECORD ;MAX. NO. OF BYTES TO COPY
MOVE T0,FILCNT(F) ;NO. WE ACTUALLY HAVE IN BUFFER
CAMGE T0,T3 ;ENUF IN BUFFER?
MOVE T3,T0 ;NO, USE WHAT WE HAVE
MOVEM T3,@RSAV ;[OK] [147] WILL TRY TO STORE THIS MANY
HRR T4,R ;[C20] DESTINATION ADDRESS
HRLI T4,(POINT 7,,35) ;DESTINATION BYTE PTR
SKIPG SEQNO ;[110] CHECK FOR SEQUENCE NO.
JRST $2 ;[417] [110] NO
HRRZ T2,FILPTR(F) ;[C20] GET FIRST WORD
MOVE T2,(T2) ;[C20] ..
MOVEM T2,RC.KEY(R) ;[C20] STORE SEQ. NO.
MOVNI T2,5
ADDM T2,FILCNT(F) ;COUNT DOWN
AOS FILPTR(F) ;INCREMENT SOURCE
SUBI T0,5
SUBI T3,5 ;FIVE LESS BYTES TO COPY
JUMPL T0,E$$NAI ;[N01] [412] SUB TOO MANY. ISNT LINESEQ ASCII
ADDI T4,1 ;INCREMENT DESTINATION
$2% MOVE T1,FILPTR(F) ;SOURCE BYTE PTR
TXO T0,S.FLAG ;SET SIGNIFICANCE FLAG
$3% SETZ T2, ;[417]JUST INCASE
EXTEND T0,[MOVST AVRTBL
EXP 0] ;[417] COPY AND ZERO FILL
JRST $4 ;EITHER COUNT RAN OUT OR CRLF SEEN
PUSH P,T4 ; ..
JSP T4,GETBUF ;GET NEXT BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ; RESTORE WORK ACS
SETZ T2, ;[417]
MOVE T0,FILCNT(F) ;GET COUNT POSSIBLE
MOVE T1,FILPTR(F) ;[127] RELOAD BYTE POINTER
TXNN T4,77B11 ;WERE WE JUST THROWING CHAR AWAY?
JRST $6 ;YES, KEEP DOING IT
MOVE T3,RECORD ;MAX. WE NEED
SUB T3,@RSAV ;[OK] [147] - WHAT WE ALREADY HAVE
JUMPE T3,$5 ;ALL IS DONE REALLY
CAMGE T0,T3 ;CHECK AGAIN FOR FIT
MOVE T3,T0 ;JUST USE WHAT WE HAVE
ADDM T3,@RSAV ;[OK] [147] WHAT WE EXPECT TO COPY
JRST $2 ;COPY REST
$4% TXZ T0,S.FLAG!M.FLAG
TXZN T0,N.FLAG ;SEEN ABORT BIT?
JRST $5 ;NO
MOVEM T1,FILPTR(F) ;RESTORE BYTE PTR
MOVEM T0,FILCNT(F) ;WE DIDN'T USE THEM ALL
MOVN T3,T3
ADDM T3,@RSAV ;[OK] [147] UPDATE COUNT PROPERLY
PJRST GETEND ;[310] ALL DONE, READ LF NOW
$5% JUMPE T0,[HALT .] ;BUFFER RAN OUT
AOS @RSAV ;[OK] [147] FEATURE OF MICRO CODE
TXZN T4,77B11 ;[341] CLEAR BYTE POINTER
AOJA T3,$3 ;[417] IF NOT FIRST TIME, READ TIL CR-LF SEEN
MOVE T2,T1 ;[417] GET INPUT BYTE POINTER
ILDB T2,T2 ;[417] GET NEXT BYTE
CAIG T2,.CHCRT ;[417] SEE IF END OF RECORD
CAIGE T2,.CHLFD ;[417] ...
PUSHJ P,ERRRTI ;REPORT RECORD TRUNCATION
AOJA T3,$3 ;READ UNTIL CR-LF SEEN
$6% MOVEI T3,1 ;INCASE IT WENT TO ZERO
JRST $3
AVRTBL: ZZ==0
REPEAT 12/2,<ZZ,,ZZ+1
ZZ==ZZ+2>
E.SBIT!E.ABRT,,E.SBIT!E.ABRT ;LF,,VT
E.SBIT!E.ABRT,,E.SBIT!E.ABRT ;FF,,CR
ZZ=ZZ+4
REPEAT <177-15>/2,<ZZ,,ZZ+1
ZZ==ZZ+2>
>;END IFN FTKL10
ENDB;
E$$NAI: $ERROR(?,NAI,<Non ASCII input file>) ;[N01]
$DIE
SUBTTL GETREC -- GETEBR - Get EBCDIC Record
;STILL IN IFE FTCOBOL
IFE FTFORTRAN,<
BEGIN
PROCEDURE (JSP P4,GETEBR) ;HERE TO GET NEXT EBCDIC RECORD
;FIRST SEE IF REST OF BUFFER IS NULL
BEGIN
DMOVE T2,FILPTR(F) ;GET COPY OF BYTE PTR AND COUNT
$1% ILDB T1,T2 ;READ FIRST BYTE (WE KNOW ITS IN MEMORY)
JUMPN T1,$E ;A NON-NULL FOUND
SOJG T3,$1 ;TRY AGAIN
JSP T4,GETBUF ;TRY FOR NEXT BLOCK
JRST (P4) ;HOPE WE GOT HERE
JRST GETEBR ;NO TRY AGAIN
ENDB;
MOVE T2,RECORD ;[150] GET BYTE COUNT
MOVEM T2,RC.CNT(R) ;[150] STORE BYTE COUNT
ADD R,XTRWRD ;[150] LEAVE SPACE FOR EXTRACTED KEYS
SKIPGE FILFLG(F) ;IS IT VARIABLE?
JRST GETEVR ;YES
MOVE T1,FILFLG(F)
TXNE T1,FI.IND ;INDUSTRY COMPATIBLE MODE?
JRST GETICR ;YES
SKIPL FILPTR(F) ;SEE IF ON A WORD BOUNDARY
JRST GETEBN ;ITS NOT
MOVE T1,RECORD ;SEE HOW MANY ACTUAL CHARS
IDIVI T1,4
PUSH P,T2 ;SAVE REMAINDER
MOVE T2,T1
LSH T2,2 ;INTEGRAL NO. OF BYTES
CAMLE T2,FILCNT(F) ;ALL IN THIS BUFFER?
JRST GETEML ;NO
HRLZ T3,FILPTR(F) ;GET BYTE PTR
HRRI T3,RC.KEY(R) ;DESTINATION
ADD R,T1 ;[C20] END OF BLT
SKIPE T1 ;DON'T DO BLT IF NO FULL WORDS
BLT T3,(R) ;MOVE ALL BUT LAST PARTIAL WORD
ADDM T1,FILPTR(F) ;ADJUST BYTE PTR
MOVN T2,T2 ;[440] NO. OF BYTES USED
ADDM T2,FILCNT(F) ;ACCOUNT FOR THEM
; PJRST GETELW ;NEXT PAGE
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETELW) ;GET EBCDIC LAST WORD
SKIPG FILCNT(F) ;WILL LAST WORD FIT?
SKIPN 0(P) ;OR NO LAST WORD?
JRST $2 ;OK
JSP T4,GETBUF ;GET NEW BUFFER
JRST E$$RIE ;WARN USER
$2% MOVN T2,(P) ;[440] REMAINDER
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
POP P,T2 ;[440] GET REMAINDER BACK
JUMPE T2,GETEBZ ;ALL DONE
HRRZ T1,FILPTR(F) ;[C20] GET FULL WORD
MOVE T1,(T1) ;[C20] ..
AND T1,EBCMSK(T2) ;[OK] ONLY WHAT WE REALLY NEED
MOVEM T1,RC.KEY(R) ;STORE IT
IFE FTKL10,<
IBP FILPTR(F) ;ADJUST BYTE PTR
SOJG T2,.-1
>
IFN FTKL10,<
ADJBP T2,FILPTR(F)
MOVEM T2,FILPTR(F)
>
; PJRST GETEBZ ;BELOW
ENDB;
BEGIN
PROCEDURE (JSP P4,GETEBZ)
MOVE T2,FILPTR(F)
TLNE T2,700000 ;IS IT ON WORD BOUNDARY?
JRST $3 ;NO, EXTRACT KEYS AND RETURN
TLO T2,440000 ;YES, REFORM BYTE PTR
ADDI T2,1 ;INCREMENT IT TO NEXT WORD
MOVEM T2,FILPTR(F) ;ADVANCE TO NEXT WORD
$3% AOS FILSIZ(F) ;COUNT 1 MORE RECORD
HRRZ R,RSAV ;[C20] RESTORE R
AOJA P4,@EXTORG ;[OK] [C13] EXTRACT KEYS AND GIVE OK RETURN
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,RDEBBT) ;READ EBCDIC BYTE FROM INPUT BUFFER
IF BUFFER IS EMPTY
SOSL FILCNT(F) ;ANYTHING IN BUFFER?
JRST $F ;YES, STILL NOT EMPTY
THEN GET NEXT
JSP T4,GETBUF ;BUFFER EMPTY GET NEXT
JRST [POP P,(P) ;POP RETURN OFF STACK
MOVE EF,LOGEOF ;RAN OUT OF RECORDS
JRST 0(P4)] ;GIVE ERROR RETURN
SOS FILCNT(F) ;COUNT DOWN BYTE WE WILL PICKUP
FI;
ILDB T1,FILPTR(F) ;GET BYTE
RETURN
ENDB;
EBCMSK: BYTE (9)
BYTE (9) 377
BYTE (9) 377,377
BYTE (9) 377,377,377
BYTE (9) 377,377,377,377
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETEML) ;HERE WHEN RECORD CROSSES BLOCK BOUNDARY
MOVE P1,T1 ;[C20] SIZE OF RECORD (WORDS)
$1% SKIPE T1,FILCNT(F) ;[440] NUMBER OF BYTES LEFT IN CURRENT BUFFER
JRST $2 ;STILL SOME
JSP T4,GETBUF ;EMPTY, GET NEXT
JRST E$$RIE ;WARN USER
$2% IDIVI T1,4 ;WORDS IN CURRENT BUFFER
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.KEY(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] PTR TO END OF RECORD FRAGMENT -1
BLT T3,0(R) ;[304] TRANSFER RECORD FRAGMENT
MOVNI T1,4 ;4 BYTES PER WORD
IMUL T1,T2 ;- NO. OF WORDS
ADDM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$1 ;FINISHED ?
PJRST GETELW ;GET LAST WORD, SEE IF IN BUFFER
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETEBN) ;HERE FOR EBCDIC RECORD NOT ON A WORD BOUNDARY
IFE FTKL10,<
LDB T1,[POINT 6,FILPTR(F),5] ;GET BYTE POSITION
MOVNS P1,T1 ;-NO. OF BITS LEFT
ADDI P1,^D36 ;LSHC COUNTER TO RIGHT JUSTIFY 5 BYTES
IDIVI T1,9 ;CONVERT TO BYTES
ADDM T1,FILCNT(F) ;ACCOUNT FOR THEM
ADD T1,RECORD ;NO. OF BYTES TO FOLLOW
IDIVI T1,4 ;NO. OF WORDS
PUSH P,T2 ;SAVE REMAINDER
MOVE T4,T1 ;[C20] NO. OF FULL WORDS TO COPY
MOVN T3,P1 ;NO. OF BITS TO SHIFT LEFT
ADDI T3,^D36 ;LSHC COUNTER FOR REMAINDER
AOS T2,FILPTR(F) ;ADVANCE BYTE PTR
HRLI T2,(POINT 9,) ; TO BEFORE FIRST BYTE
MOVEM T2,FILPTR(F) ; SO BOTH ILDB AND MOVE @ WORK
HRRZ T1,T2 ;[C20] GET FIRST WORD
MOVE T1,-1(T1) ;[C20] ..
IF THERE ARE FULL WORDS TO MOVE
JUMPGE T4,$F ;[C20] NO
THEN LOOP FOR REMAINING FULL WORDS
BEGIN
SKIPG FILCNT(F) ;ROOM IN THIS BUFFER?
JRST [PUSH P,T1 ;SAVE PARTIAL
PUSH P,T3 ;LSHC -COUNT
PUSH P,T4 ;[C20] SAVE T4
JSP T4,GETBUF ;GET NEW BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ;[C20] RESTORE T4
POP P,T3
POP P,T1
JRST $1]
$1% HRRZ T2,FILPTR(F) ;[C20] GET IT
MOVE T2,(T2) ;[C20] ..
LSHC T1,(P1) ;[OK] 36 BITS IN T1
MOVEM T1,RC.KEY(R) ;STORE
LSHC T1,(T3) ;[OK] MOVE REMAINDER INTO T1
MOVNI T2,4
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
AOS FILPTR(F) ;AND BYTE PTR
ADDI R,1 ;[C20] LOOP FOR ALL FULL WORDS
SOJG T4,$B ;[C20] ..
ENDB;
FI;
;NOW FOR LAST WORD IF IT EXISTS
SKIPG FILCNT(F) ;[122] IS BUFFER EMPTY?
SKIPN 0(P) ;[122] YES, AND DO WE NEED ANY MORE?
JRST $3 ;NO
PUSH P,T1 ;SAVE PARTIAL WORD
JSP T4,GETBUF ;YES, FILL IT
JRST E$$RIE ;WARN USER
POP P,T1 ;RESTORE PARTIAL WORD
$3% POP P,T3 ;GET REMAINDER
SKIPN T2,T3 ;[C20] NO REMAINDER, GET 0
JRST $4 ;[C20] ..
HRRZ T2,FILPTR(F) ;[C20] GET IT
MOVE T2,(T2) ;[C20] ..
$4% LSHC T1,(P1) ;[C20] FORM 36 BITS
MOVEM T1,RC.KEY(R) ;STORE FIRST WORD
SKIPE T2 ;ONLY ONE WORD
MOVEM T2,RC.KEY+1(R) ;STORE SECOND WORD
JUMPE T3,$5 ;NO REMAINDER
MOVN T3,T3
ADDM T3,FILCNT(F) ;ADJUST BYTE COUNT
IBP FILPTR(F)
AOJL T3,.-1 ;AND BYTE PTR
$5%
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T4,^D9 ;BYTE SIZE
PUSHJ P,GETEX ;GET RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST GETEBZ ;ALL DONE
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETEVR) ;GET VARIABLE LENGTH EBCDIC RECORD
PUSHJ P,RDEBBT ;READ A BYTE
LDB T2,[POINT 6,FILPTR(F),11] ;[442] GET BYTE SIZE
LSH T1,(T2) ;[OK] [442] SHIFT HIGH ORDER BYTE
MOVE P1,T1 ;STORE HIGH ORDER BYTE
PUSHJ P,RDEBBT
ADD P1,T1 ;[C20] ADD LOW ORDER BYTE
PUSHJ P,RDEBBT ;BYPASS JUNK
JUMPN T1,E$$SRS ;CHECK FOR IBM SPANNED RECORDS
PUSHJ P,RDEBBT ;...
SUBI P1,4 ;ACCOUNT FOR 4 BYTE HEADER
CAMGE P1,MINKEY ;IS IT BIG ENOUGH?
PUSHJ P,ERRKNR ;NO
IF RECORD IS TOO BIG
CAMG P1,RECORD ;[367]
JRST $T
THEN STORE ONLY MAX SIZE
PUSHJ P,ERRRTI ;TELL USER
SUB P1,RECORD ;GET DIFF
PUSH P,P1 ;STORE IT
MOVE P1,RECORD ;MAX SIZE
JRST $F
ELSE USE IT
PUSH P,[0] ;NO EXCESS
FI;
MOVEM P1,@RSAV ;[OK] [150] STORE BYTE COUNT
IFE FTKL10,<
HRLI T4,(POINT 9,,35) ;[C20] DEPOSIT BYTE PTR & BYPASS BYTE COUNT
HRR T4,R ;[C20] ..
JRST $2 ;FIRST TIME
$1% PUSH P,T4 ;[C20] SAVE T4
JSP T4,GETBUF ;GET NEXT BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ;[C20] RESTORE T4
$2% SOSGE FILCNT(F) ;BUFFER EMPTY?
JRST $1 ;YES
ILDB T1,FILPTR(F) ;GET NEXT BYTE
IDPB T1,T4 ;[C20] STORE
SOJG P1,$2 ;GET NEXT
POP P,P1 ;GET POSSIBLE EXCESS
JUMPE P1,$3 ;OK
TLZE T4,(POINT 9,0,35) ;[C20] MAKE NULL BYTE PTR
PUSHJ P,ERRRTI ;WARN USER FIRST TIME
PUSH P,[0] ;TERMINATE CORRECTLY THIS TIME
JRST $2 ;LOOP UNTIL END OF RECORD
$3% AOS FILSIZ(F) ;COUNT 1 MORE RECORD
HRRZ R,RSAV ;[C20]
AOJA P4,@EXTORG ;[OK] [C13]
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,P1 ;[C20] NO. OF BYTES TO COPY
MOVEI T4,^D9 ;BYTE SIZE
PUSHJ P,GETEX ;GET RECORD WITH COMMON BIS CODE
$2% POP P,T1 ;GET EXCESS
JUMPE T1,GETEBZ ;ALL DONE
MOVN T2,T1
ADDB T2,FILCNT(F) ;ADJUST BYTE COUNT
JUMPGE T2,$3 ;OK
PUSH P,T2
JSP T4,GETBUF ;READ NEXT BUFFER
JRST E$$RIE ;WARN USER
JRST $2 ;TRY AGAIN
$3% ADJBP T1,FILCNT(F) ;ADJUST BYTE PTR
MOVEM T1,FILPTR(F)
PJRST GETEBZ
>;END IFN FTKL10
ENDB;
E$$SRS: $ERROR (?,SRS,<Spanned records not supported.>)
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,GETICR) ;GET INDUSTRY COMPATIBLE FIXED LENGTH EBCDIC RECORD
IFE FTKL10,<
MOVE P1,RECORD ;SIZE
MOVEM P1,@RSAV ;[OK] [150] STORE BYTE COUNT
HRLI T4,(POINT 9,,35) ;[C20] DEPOSIT BYTE PTR & BYPASS BYTE COUNT
HRR T4,R ;[C20] ..
JRST $2 ;FIRST TIME
$1% PUSH P,T4 ;[C20] SAVE T4
JSP T4,GETBUF ;GET NEXT BUFFER
JRST E$$RIE ;WARN USER
POP P,T4 ;[C20] RESTORE T4
$2% SOSGE FILCNT(F) ;BUFFER EMPTY?
JRST $1 ;YES
ILDB T1,FILPTR(F) ;GET NEXT BYTE
IDPB T1,T4 ;[C20] STORE
SOJG P1,$2 ;GET NEXT
AOS FILSIZ(F) ;COUNT 1 MORE RECORD
HRRZ R,RSAV ;[C20]
AOJA P4,@EXTORG ;[OK] [C13]
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T4,^D9 ;BYTE SIZE
PUSHJ P,GETEX ;GET RECORD WITH COMMON BIS CODE
JRST GETEBZ ;ALL DONE
>;END IFN FTKL10
ENDB;
>;END IFE FTFORTRAN
SUBTTL GETREC -- GETBNR - Get Binary Record
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETBNR)
MOVE T2,RECSIZ ;GET RECORD SIZE
MOVEM T2,RC.CNT(R) ;STORE WORD COUNT
ADD R,XTRWRD ;BYPASS EXTRACTED KEYS
HRRZ T3,FILPTR(F) ;ADDRESS OF RECORD
MOVE T4,MODE
TXNE T4,RM.FOR ;FORTRAN BINARY?
PJRST GETFBR ;YES
IF RECORD IS CONTAINED IN CURRENT I/O BUFFER
CAMGE T1,T2 ;[C20] IS RECORD CONTAINED IN CURRENT BUFFER ?
JRST $T ;NO, RECORD SPANS BUFFERS
THEN
HRL T3,FILPTR(F) ;YES, SET ORIGIN ADDRESS OF RECORD
HRRI T3,RC.KEY(R) ;SET DESTINATION ADDRESS
ADD R,T2 ;[C20] PTR TO LAST WORD IN RECORD DESTINATION
BLT T3,0(R) ;TRANSFER RECORD
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
JRST $F
ELSE COPY PIECEMEAL
MOVE P1,T2 ;[C20] SIZE OF RECORD (WORDS)
$2% SKIPE T1,FILCNT(F) ;NUMBER OF WORDS LEFT IN CURRENT BUFFER
JRST $3 ;STILL SOME
JSP T4,GETBUF ;CURRENT BUFFER EXHAUSTED, ADVANCE TO NEXT
JRST [HRRZ R,RSAV ;[C20] RESTORE R
RETURN] ;GIVE EOF RETURN
$3% MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.KEY(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] PTR TO END OF RECORD FRAGMENT
BLT T3,0(R) ;TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$2 ;FINISHED ?
FI;
HRRZ R,RSAV ;[C20] RESTORE R
AOS FILSIZ(F) ;COUNT 1 MORE RECORD
AOJA P4,@EXTORG ;[OK] [C13] EXTRACT KEYS AND GIVE OK RETURN
ENDB;
SUBTTL GETREC -- GETFBR - Get FORTRAN Binary Record
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,GETFBR)
WHILE THERE ARE NULL RECORDS TO IGNORE
BEGIN
HRRZ P1,FILPTR(F) ;[C20] [402] ZERO LSCW?
SKIPE P1,(P1) ;[C20] ..
JRST $E ;[402] NO--FOUND REAL RECORD
PUSHJ P,EATFBR ;[402] YES--EAT THIS RECORD
JUMPG P1,$B ;[402] ANY WORDS LEFT IN BUFFER?
JSP T4,GETBUF ;[402] NO--READ ANOTHER
JRST (P4) ;[402] RETURN EOF FROM GETREC
JRST $B ;[402] TRY FOR ANOTHER RECORD
ENDB;
AOS FILPTR(F)
SOS T1,FILCNT(F) ;ACCOUNT FOR IT
MOVE P2,RECSIZ ;GET MAX RECORD SIZE
HLRZ T2,P1 ;GET LSCW
CAIE T2,S.LSCW ;IS IT WHAT WE EXPECT
JRST E$$FCW ;ERROR
;**;[530] At GETFBR+17L, insert 2 lines
SKIPN LSCWSZ ;[530] HAVE WE ALREADY SEEN THE SIZE?
HRRZM P1,LSCWSZ ;[530] NO, SAVE THE FIRST TIME
HRRZS P1 ;[C20] NO. OF DATA WORDS TO FOLLOW
SUBI P1,1 ;[C20] ..
IF RECORD IS CONTAINED IN CURRENT I/O BUFFER
$1% CAMGE T1,P1 ;[C20]
JRST $T ;NO
THEN COPY ALL EXCEPT LSCW AT EITHER END
HRL T3,FILPTR(F) ;ORIGIN OF DATA
HRRI T3,RC.KEY(R) ;DESTINATION
CAMG P1,P2 ;[C20] TOO BIG?
SKIPA T2,P1 ;NO, USE ALL
MOVE T2,P2 ;YES, JUST USE MAX.
JUMPLE P2,$6 ;DON'T COPY TOO MUCH
ADD R,T2 ;[C20] NO. TO COPY
BLT T3,0(R) ;COPY THEM
SUB P2,T2 ;[C20] COUNT DOWN
$6% MOVN T1,P1 ;[C20] MINUS THOSE WE HAVE READ
ADDM T1,FILCNT(F)
ADDM P1,FILPTR(F) ;ADVANCE READ POINTER
JRST $F ;READ LSCW
ELSE COPY PIECEMEAL
$2% SKIPE T1,FILCNT(F) ;NUMBER OF WORDS LEFT IN CURRENT BUFFER
JRST $3 ;STILL SOME
JSP T4,GETBUF ;CURRENT BUFFER EXHAUSTED, ADVANCE TO NEXT
JRST E$$RIE ;WARN USER
HRRZ T2,FILPTR(F) ;[C20] GET LSCW
HLRZ T2,(T2) ;[C20] ..
$3% MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
MOVE T1,T2 ;[C20] [203] REMEMBER HOW MUCH TOWARD LSCW WE'RE READING
CAMLE T2,P2 ;[C20] [203] ENOUGH ROOM TO HOLD IT?
MOVE T2,P2 ;[C20] [203] NO--COPY ONLY WHAT'LL FIT
JUMPLE T2,$7 ;[203] WHICH MAY BE NOTHING
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.KEY(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] PTR TO END OF RECORD FRAGMENT
BLT T3,0(R) ;TRANSFER RECORD FRAGMENT
SUB P2,T2 ;[C20] [203] ACCOUNT FOR FILLING UP RECORD
$7% SUB P1,T1 ;[C20] [203] UPDATE WORDS LEFT
ADDM T1,FILPTR(F) ;[203] AND LEAVE IN T1
EXCH T1,FILCNT(F) ;[203] ..
SUBB T1,FILCNT(F) ;[203] ..
JUMPN P1,$2 ;FINISHED ?
FI;
SKIPE FILCNT(F) ;LSCW IN BUFFER?
JRST $4 ;YES
JSP T4,GETBUF
JRST E$$RIE ;WARN USER
$4% HRRZ T1,FILPTR(F) ;[C20] GET LSCW
HLRZ T2,(T1) ;[C20] ..
HRRZ P1,(T1) ;[C20] GET WORD COUNT
AOS FILPTR(F)
SOS T1,FILCNT(F) ;ACCOUNT FOR IT
CAIN T2,E.LSCW ;END?
JRST $5 ;YES
CAIE T2,C.LSCW ;CONTINUE
JRST E$$FCW ;NO, ERROR
;**;[530] At GETFBR+74L, delete 2 lines
SOJA P1,$1 ;YES, GET NO. OF DATA WORDS
E$$FCW: $ERROR (?,FCW,<Fortran binary control word incorrect>)
$5% HRRZ T1,R
HRRZ R,RSAV ;[C20]
SUB T1,R ;[C20]
SUB T1,XTRWRD ;[410] SUBTRACT LENGTH OF EXTRACTED KEYS
JUMPE T1,GETREC ;[203] IGNORE 0-LENGTH RECORDS
MOVEM T1,RC.CNT(R) ;NO. OF DATA WORDS USED
AOS FILSIZ(F) ;COUNT 1 MORE RECORD
AOJA P4,@EXTORG ;[OK] [C13]
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (PUSHJ P,EATFBR) ;[402] EAT NON-EX FORTRAN RANDOM RECORD
;EATFBR SKIPS A SINGLE 'NON-EXISTENT' FORTRAN BINARY RECORD. THESE ARE FOUND IN
;RANDOM FILES WHEN THE USER HAS WRITTEN A RECORD PAST, BUT NOT ADJACENT TO, THE
;END OF FILE. THESE RECORDS CAN BE DETECTED BECAUSE THE ENTIRE LSCW WORD IS 0.
;
;THE IDEA IS SIMPLY TO IGNORE THEM AS WE DO IN COBOL RANDOM FILES. NOTE THAT
;SINCE THIS CONDITION IS ONLY POSSIBLE IN RANDOM FILES, ALL RECORDS MUST BE THE
;SAME SIZE. THEREFORE, WE EAT EXACTLY THE USER-SPECIFIED RECORD SIZE (IN WORDS)
;PLUS 2 (FOR THE LSCW PLACE-HOLDERS).
;
;NOTE FINALLY THAT THIS ACTION IS ONLY POSSIBLE BECAUSE THERE ARE LSCWS THAT WE
;CAN TELL FROM ZERO WORDS. THUS, UNWRITTEN RECORDS IN FORTRAN RANDOM IMAGE FILES
;CANNOT BE SKIPPED THIS WAY, SINCE THEY CANNOT BE TOLD FROM REAL RECORDS THAT
;CONTAIN ALL ZEROS.
;
;CALL:
; FILCNT(F)/ # WORDS REMAINING IN BUFFER
; FILPTR(F)/ BYTE POINTER TO CURRENT WORD IN BUFFER
;RETURNS:
; P1/ UPDATED COPY OF FILCNT(F)
MOVE P1,RECSIZ ;[402] GET # WORDS TO SKIP
ADDI P1,2 ;[402] REMEMBERING TO COUNT LSCWS
WHILE MORE BUFFERS TO SKIP
BEGIN
CAMG P1,FILCNT(F) ;[402] DOES REST FIT IN BUFFER?
JRST $E ;[402] YES--DONE
SUB P1,FILCNT(F) ;[402] ACCOUNT FOR BUFFER'S-WORTH
JSP T4,GETBUF ;[402] READ NEXT BUFFER
PJRST E$$RIE ;[402] SHOULD ALL BE THERE
JRST $B ;[402] LOOP FOR THE REST
ENDB;
ADDM P1,FILPTR(F) ;[402] UPDATE BYTE POINTER
EXCH P1,FILCNT(F) ;[402] AND WORD COUNT
SUBB P1,FILCNT(F) ;[402] LEAVING IT IN P1
RETURN ;[402] DONE
ENDB;
;STILL IN IFE FTCOBOL
;SKIP TO NEXT OUTPUT BLOCK.
; ERROR RETURN IF A CALL TO PUTBUF IS REQUIRED
BEGIN
PROCEDURE (PUSHJ P,CLRBLK)
MOVE T1,FILFLG(F) ;[C17] GET FILE FLAGS
TXNN T1,FI.DSK ;[C17] DSK?
RETURN ;[C17] NO, GIVE ERROR RETURN
MOVE T1,FILKCT(F) ;[C17] FIRST TIME?
CAMGE T1,FILBPK(F) ;[C17] ..
JRST $1 ;[C17] NO
SKIPLE T1,FILCNT(F) ;[C17] ..
CAML T1,FILBPB(F) ;[C17] ..
JRST CPOPJ1 ;[C17] YES, GIVE SKIP RETURN
$1% MOVE T1,FILKCT(F) ;[C17] CALCULATE BYTES LEFT IN BLOCK
SUB T1,FILBPB(F) ;[C17] ..
ADD T1,FILCNT(F) ;[C17] ..
JUMPLE T1,[MOVE T1,FILBPK(F) ;[C17] ALL DONE, INCRIMENT BLOCK BYTE COUNT
ADDM T1,FILKCT(F) ;[C17] ..
SKIPG T1,FILCNT(F) ;[C17] RETURN
RETURN ;[C17] ERROR
JRST CPOPJ1] ;[C17] SKIP
SKIPG FILCNT(F) ;[C17] ROOM LEFT IN BUFFER?
JRST [JSP T4,PUTBUF ;[C17] NO, MAKE SOME
JRST $1] ;[C17] AND TRY AGAIN
CAMLE T1,FILCNT(F) ;[C17] MORE THAN THIS BUFFER?
MOVE T1,FILCNT(F) ;[C17] YES, USE ONLY THIS BUFFER
MOVN T2,T1 ;[C17] ADJUST BUFFER BYTE COUNT
ADDM T2,FILCNT(F) ;[C17] ..
IDIV T1,IOBPW2 ;[C17] CALCULATE WORDS
JUMPLE T2,$2 ;[C17] ZERO ODD BYTES
SETZ T3, ;[C17] ..
IDPB T3,FILPTR(F) ;[C17] ..
SOJG T2,.-1 ;[C17] ..
$2% JUMPLE T1,$3 ;[C17] JUMP IF NOTHING TO ZERO
MOVE T2,FILPTR(F) ;[C17] GET START ADDRESS FOR BLT
IBP T2 ;[C17] ..
HRRZS T2 ;[C20] ..
ADDM T1,FILPTR(F) ;[C17] ADJUST BYTE POINTER FOR WORDS
SETZM (T2) ;[OK] [C17] ZERO FIRST WORD
ADDI T1,-1(T2) ;[OK] [C17] SETUP FOR BLT
HRL T3,T2 ;[C20] ..
HRRI T3,1(T2) ;[C20] ..
CAMLE T1,T2 ;[501] [C20] [C17] SKIP BLT IF UNNECESSARY
BLT T3,(T1) ;[C20] [C17] ZERO BUFFER
$3% JRST $1 ;[C17] LOOP BACK
ENDB;
;SKIP TO NEXT INPUT BLOCK.
; ERROR RETURN IF EOF OCCURED
BEGIN
PROCEDURE (PUSHJ P,SKPBLK)
MOVE T1,FILFLG(F) ;[C17] GET FILE FLAGS
TXNN T1,FI.DSK ;[C17] DSK?
JRST $3 ;[C17] NO
MOVE T1,FILKCT(F) ;[C17] FIRST TIME?
CAML T1,FILBPK(F) ;[C17] ..
JRST $3 ;[C17] YES
$1% SKIPG FILCNT(F) ;[C17] ANYTHING IN BUFFER?
JRST [JSP T4,GETBUF ;[C17] NO, GET SOME
RETURN ;[C17] CAN'T EOF
JRST $1] ;[C17] AND TRY AGAIN
MOVE T1,FILKCT(F) ;[C17] CALCULATE BYTES LEFT IN BLOCK
ADD T1,FILCNT(F) ;[C17] ..
JUMPLE T1,[MOVE T1,FILBPK(F) ;[C17] ALL DONE, INCRIMENT BLOCK BYTE COUNT
ADDM T1,FILKCT(F) ;[C17] ..
MOVE T1,FILCNT(F) ;[C17] RETURN
JRST CPOPJ1] ;[C17] ..
CAMLE T1,FILCNT(F) ;[C17] MORE THAN THIS BUFFER?
MOVE T1,FILCNT(F) ;[C17] YES, USE ONLY THIS BUFFER
MOVN T2,T1 ;[C17] ADJUST BUFFER BYTE COUNT
ADDM T2,FILCNT(F) ;[C17] ..
IDIV T1,IOBPW2 ;[C17] CALCULATE WORDS
JUMPLE T2,$2 ;[C17] ADVANCE OVER ODD BYTES
IBP FILPTR(F) ;[C17] ..
SOJG T2,.-1 ;[C17] ..
$2% ADDM T1,FILPTR(F) ;[C17] ADJUST BYTE POINTER FOR WORDS
JRST $1 ;[C17] LOOP BACK
$3% JSP T4,GETBUF ;[C17] JUST CALL GETBUF
RETURN ;[C17] CAN'T EOF
JRST CPOPJ1 ;[C17]
ENDB;
;STILL IN IFE FTCOBOL
;SET UP FOR BLOCKED DSK FILE. COMPUTES NUMBER OF WORDS IN
;A LOGICAL BLOCK (ALWAYS AN INTEGRAL MULTIPLE OF 128 WORDS).
BEGIN
PROCEDURE (PUSHJ P,BLKSET)
HRRZ T1,IOMODE ;[C18] GET I/O MODE
CASE I/O MODE OF (SIXBIT, ASCII, EBCDIC, BINARY)
JRST @[IFIWS <$1,$2,$3,$1>]-1(T1) ;[C20] [C18] DISPATCH
$1% MOVE T1,RECSIZ ;[C18] GET BYTES PER RECORD
IMUL T1,X.BLKF(P1) ;[OK] [C18] TIMES RECORDS PER BLOCK
JRST $4 ;[C18] ROUND UP TO 128 WORD BLOCK
$2% MOVE T1,RECORD ;[C18] GET RECORD SIZE IN CHARACTERS
ADDI T1,2 ;[C18] PLUS CRLF
IMUL T1,X.BLKF(P1) ;[OK] [C18] TIMES RECORDS PER BLOCK
IDIVI T1,5 ;[C18] WORDS PER BLOCK
SKIPE T2 ;[C18] ROUND UP IF REQUIRED
ADDI T1,1 ;[C18] ..
JRST $4 ;[C18] NOW ROUND UP TO DSK BLOCK
$3% MOVE T1,RECORD ;[C18] GET RECORD SIZE IN CHARACTERS
SKIPGE FILFLG(F) ;[C18] IF VARIABLE?
ADDI T1,4 ;[C18] ADD RECORD HEADER WORD
IMUL T1,X.BLKF(P1) ;[OK] [C18] TIMES RECORDS PER BLOCK
IDIVI T1,4 ;[C18] WORDS PER BLOCK
SKIPE T2 ;[C18] ROUND UP IF REQUIRED
ADDI T1,1 ;[C18] ..
SKIPGE FILFLG(F) ;[C18] IF VARIABLE?
ADDI T1,1 ;[C18] ADD BLOCK HEADER WORD
$4% TRZE T1,177 ;[C18] ROUND UP TO DISK BLOCK
ADDI T1,200 ;[C18] ..
IMUL T1,IOBPW2 ;[C18] CONVERT TO BYTES
MOVEM T1,FILBPK(F) ;[C18] SAVE IN FCB
RETURN ;[C18] DONE
ESAC;
ENDB;
;STILL IN IFE FTCOBOL
IFN FTKL10,<
BEGIN
PROCEDURE (PUSHJ P,GETEX) ;GET NEXT RECORD USING BIS
;CALL WITH:
; T0/ NUMBER OF BYTES TO COPY
; T4/ BYTE SIZE
; F/ INDEX TO FILE TABLE (FOR BUFFER HEADER)
; R/ INDEX TO WORD BEFORE DATA IN RECORD
LSH T4,^D24 ;MOVE BYTE SIZE TO BYTE POINTER POS
HRR T4,R ;[C20] FINISH POINTER WITH ADDR OF RECORD
MOVE T3,FILCNT(F) ;FILL UP ACS FOR EXTEND INSTRUCTION
$1% SETZ T2, ;UNUSED AC IN BIS
CAMGE T0,T3 ;DO ALL CHARS FIT?
MOVE T3,T0 ;YES
MOVN T1,T0
ADDM T1,FILCNT(F) ;ACCOUNT FOR BYTES READ
MOVE T1,FILPTR(F) ;SOURCE BYTE POINTER
EXTEND T0,[MOVSLJ
EXP 0] ;COPY AND 0 FILL
JRST $2
MOVEM T1,FILPTR(F) ;RESTORE BYTE POINTER
RETURN ;ALL DONE
$2% MOVEM T1,FILPTR(F) ;RESTORE BYTE POINTER
PUSH P,T0 ;SAVE WORK ACS
PUSH P,T4 ; ..
JSP T4,GETBUF ;GET NEXT BUFFER
JRST E$$RIE ;FAILED
POP P,T4 ;RESTORE WORK ACS
POP P,T0 ; ..
MOVE T3,FILCNT(F) ;GET NEW SOURCE BYTE POINTER
JRST $1 ;FINISH COPYING THE RECORD
ENDB;
>;END IFN FTKL10
>;END IFE FTCOBOL
SUBTTL GETREC -- GTTREC - Get Next Record From Temporary File
BEGIN
PROCEDURE (JSP P4,GTTREC)
;GTTREC GETS THE NEXT RECORD FROM A TEMPORARY FILE. RECORDS IN TEMPORARY FILES
;CONTAIN A CHARACTER COUNT WORD, FOLLOWED BY ANY EXTRACTED KEYS, FOLLOWED BY THE
;ACTUAL USER RECORD. RUN MARKERS, WHICH *SEPARATE* RUNS IN A TEMPORARY FILE, ARE
;COUNT WORDS WITH NEGATIVE LEFT HALVES. IN THIS CASE, THE RIGHT HALF IS THE
;NUMBER OF THE FOLLOWING RUN RATHER THAN A COUNT WORD. ALSO, IF THE RECORD FITS
;IN THE BUFFER THEN THERE IS NO NEED TO MOVE IT, SINCE THE RECORD WILL BE OUTPUT
;BEFORE THE BUFFER IS EMPTY. ON ENTRY, IF (R) POINTS TO AN I/O BUFFER, RESTORE R
;FROM LSTREC. ON EXIT, IF BUFFER FULLY ENCLOSES THE RECORD AND ALL OF THE KEYS
;FIT IN THE RECORD (SO THAT WE DON'T HAVE TO PROVIDE ZERO PADDING), SET R TO
;POINT TO IT.
;
;CALL WITH:
; F/ POINTER TO FCB
; R/ POINTER TO RCB OR MIDDLE OF AN INPUT BUFFER
; JSP P4,GTTREC
;
;RETURNS:
; MOVE EF,PHYEOF
; JRST 0(P4) ;END OF FILE
;OR
; JRST 1(P4) ;NORMAL
;
IF R POINTS TO AN I/O BUFFER
MOVE T1,BUFORG ;[C13] DOES R POINT TO AN I/O BUFFER?
ADD T1,BUFSZ ;[C13] ..
CAML R,BUFORG ;[C13] ..
CAML R,T1 ;[C13] ..
JRST $F ;NO
THEN RESET R WITH A VALID RCB
MOVE R,LSTREC ;[C20] GET NEXT NEXT RCB
MOVE R,(R) ;[C20] ..
EXCH R,LSTREC ;GET NEXT RCB
HRRM R,RN.REC(S) ;MAKE SURE PTR AGREES
FI;
SKIPE T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JRST $1 ;STILL SOME
JSP T4,GETBUF ;BUFFER EXHAUSTED, ADVANCE TO NEXT
JRST 0(P4) ;GIVE E-O-F RETURN
$1%
HRRZ T3,FILPTR(F) ;ADDRESS OF NEXT RECORD
IF WE HAVE A NORMAL WORD COUNT
SKIPG T2,(T3) ;[OK] CHECK BYTE OR WORD COUNT
JRST $T ;MIGHT BE LOGICAL END-OF-FILE
THEN COPY RECORD
IFE FTCOBOL,<
IF RECORD IS VARIABLE OR COBOL
SKIPG P.VARF
SKIPE COBPDP ;CALLED FROM COBOL?
TRNA
JRST $T
THEN CALCULATE EXACT SIZE
>
SUBI T2,1 ;[201] COUNT ALL BUT LAST DATA WORD
IDIV T2,IOBPW ;[201] ..
ADDI T2,2 ;[201] COUNT LAST AND COUNT WORDS
ADD T2,XTRWRD ;[201] COUNT EXTRACTED KEYS
IFE FTCOBOL,<
SKIPE COBPDP ;CALLED FROM COBOL?
JRST $F ;YES
CAMLE T2,MAXKEY ;WILL ALL KEYS FIT?
JRST $F ;YES
HRLI T1,0(R) ;[OK] BUILT BLT PTR
HRRI T1,1(R) ;[C20] ..
MOVE T3,MAXKEY
ADD T3,R ;[C20] END OF KEYS
SETZM (R) ;ZERO FIRST WORD
BLT T1,(T3) ;[OK] ZERO THEM ALL
SETZ T1, ;FORCE COPY
JRST $F
ELSE
MOVE T2,REKSIZ ;FIXED RECORD SIZE NOW
FI;
>;END IFE FTCOBOL
IF RECORD WILL FIT IN CURRENT BUFFER
CAMGE T1,T2 ;[C20] IS RECORD CONTAINED IN CURRENT BUFFER ?
JRST $T ;NO, RECORD SPANS BUFFERS
THEN
EXCH R,LSTREC ;YES, STORE THIS R IN LIST
MOVE T3,LSTREC ;[C20] AND LINK IN
MOVEM R,(T3) ;[C20] ..
HRRZ R,FILPTR(F) ;FIRST DATA WORD
HRRM R,RN.REC(S) ;MAKE SURE PTR AGREES
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
JRST 1(P4) ;RETURN WITH KEYS ALREADY EXTRACTED
ELSE COPY PIECEMEAL
HRLI T1,(IFIW) ;[C20] SAVE R
HRR T1,R ;[C20] ..
MOVEM T1,RSAV ;[C20] ..
MOVE P1,T2 ;[C20] SIZE OF RECORD (WORDS)
$3% SKIPE T1,FILCNT(F) ;NUMBER OF WORDS LEFT IN CURRENT BUFFER
JRST $6 ;STILL SOME
JSP T4,GETBUF ;CURRENT BUFFER EXHAUSTED, ADVANCE TO NEXT
JRST E$$RIE ;WARN USER
$6% MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] CONTAINED WITHIN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRL T3,FILPTR(F) ;PTR TO ORIGIN OF RECORD RESIDUE
HRRI T3,RC.CNT(R) ;PTR TO DESTINATION OF RECORD FRAGMENT
ADD R,T2 ;[C20] ADVANCE RECORD DEPOSIT POINTER
BLT T3,-1(R) ;TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNT
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$3 ;FINISHED ?
HRRZ R,RSAV ;[C20]
;KEYS ALREADY EXTRACTED
JRST 1(P4)
FI;
ELSE CHECK FOR NEXT RUN MARKER OR EOF
JUMPE T2,$5 ;NOT SURE IF 0, TRY NEXT BLOCK
HRLM T2,FILRUN(F) ;STORE GENERATION NO. FOR = TEST
SOS FILCNT(F) ;BYPASS MARKER
AOS FILPTR(F)
MOVE EF,LOGEOF ;LOAD EOF ROUTINE
JRST 0(P4) ;GIVE ERROR RETURN
$5% SETZM FILCNT(F) ;SET TO READ NEXT BLOCK, WILL GET E-O-F
JRST GTTREC ;OR RETURN WITH L-E-O-F MARKER
FI;
ENDB;
SUBTTL PUTREC -- PUTREC - Put Next Record to Output File
IFE FTCOBOL,<
BEGIN
PROCEDURE (JSP P4,PUTREC) ;OUTPUT NEXT RECORD
HRLI T1,(IFIW) ;[C20] SAVE R
HRR T1,R ;[C20] ..
MOVEM T1,RSAV ;[C20] ..
IFN FTOPS20,<
MOVE T1,FILFLG(F)
TXNE T1,FI.RMS
JRST RMSPUT ;RMS FILE
>
IFE FTFORTRAN,<
$1% SKIPE T1,FILBLK(F) ;BLOCKED FILE?
AOBJP T1,[MOVN T1,T1 ;RESET BLOCKING FACTOR
HRLZM T1,FILBLK(F) ;IN FCB
PUSHJ P,CLRBLK ;[C17] YES, CLEAR TO NEXT BLOCK
JSP T4,PUTBUF ;[C17] NEED NEW BUFFER
MOVE T2,FILFLG(F) ;[215] ARE WE AT EOT?
TXNE T2,FI.EOT ;[215] ..
PUSHJ P,MSTEOT ;[215] YES--GO HANDLE LABELS
HRRZ T2,IOMODE ;[201] FETCH I/O MODE INDEX
CAIN T2,MODEBCDIC ;IF EBCDIC
SKIPL FILFLG(F) ;AND VARIABLE
JRST $1 ;NO
MOVE T2,RECORD ;YES, GET RECORD SIZE
HLRE T1,FILBLK(F) ;GET BLOCKING FACTOR
SETCM T1,T1 ;AS POSS NO.
IMULI T1,4(T2) ;[OK] NO. OF BYTES + 4 BYTE OVERHEAD
ADDI T1,4 ;PLUS THIS WORD
LDB T3,[POINT 6,FILPTR(F),11] ;[C06] GET BYTE SIZE
MOVN T3,T3 ;[C06] NEGATE IT
LSHC T1,(T3) ;[OK] [C06] SHIFT OFF LOW BYTE
MOVNI T3,^D36(T3) ;[OK] [C06] BUILD SHIFT COUNT
LSH T2,(T3) ;[OK] [C06] RIGHT JUSTIFY LOW BYTE
PUSH P,T2 ;[C06] AND SAVE IT
CALL WREBBT ;[C06] STORE HIGH BYTE
POP P,T1 ;[C06] GET LOW BYTE BACK
CALL WREBBT ;[C06] AND STORE IT
SETZ T1, ;[C06] ZERO OTHER BYTES
CALL WREBBT ;[C06] ..
CALL WREBBT ;[C06] ..
JRST $1] ;TRY AGAIN
MOVEM T1,FILBLK(F) ;STORE BLOCKING FACTOR BACK
>
SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
IFE FTFORTRAN,<
MOVE T2,FILFLG(F) ;[215] CHECK IF EOT HAPPENED
TXNE T2,FI.EOT ;[215] YES--WE'D BETTER
PUSHJ P,MSTEOT ;[215] WORRY ABOUT LABELS
>
CASE I/O MODE OF (EXP PUTSXR,PUTASR,PUTEBR,PUTBNR)
HRRZ T2,IOMODE ;[201] FETCH I/O MODE INDEX
JRST @[IFIWS <PUTSXR,PUTASR,PUTEBR,PUTBNR>]-1(T2) ;[C20]
ESAC;
ENDB;
SUBTTL PUTREC -- PUTSXR - Put SIXBIT Record
;STILL IN IFE FTCOBOL
IFE FTFORTRAN,<
BEGIN
PROCEDURE (JSP P4,PUTSXR)
HRRZ T2,RC.CNT(R) ;SIXBIT COUNT WORD
IF THIS IS A MAGTAPE
PUSHJ P,ISITMT ;IS IT A MAGTAPE?
JRST $F ;NO
THEN WE MUST SET UP RECORD COUNT IN LEFT HALF OF COUNT WORD
HRL T2,FILSIZ(F) ;GET RECORD NUMBER
FI;
HRRZ T1,FILPTR(F) ;[C20] STORE IT
MOVEM T2,(T1) ;[C20] ..
HRRZ T2,T2 ;BYTE COUNT ONLY
AOS FILSIZ(F) ;INCREMENT SIZE OF FILE
ADD R,XTRWRD ;BYPASS EXTRACTED KEYS
AOS FILPTR(F) ;BYPASS BYTE COUNT
SOS T1,FILCNT(F) ;AND ACCOUNT FOR IT
ADDI T2,5 ;ACOUNT FOR REMAINDER
IDIVI T2,6
IF RECORD WILL FIT IN CURRENT BUFFER
CAMGE T1,T2 ;[C20] WILL RECORD FIT IN CURRENT BUFFER ?
JRST $T ;NO, RECORD MUST SPAN BUFFERS
THEN COPY IT
HRLZI T3,RC.KEY(R) ;YES, SET ORIGIN ADDRESS
HRR T3,FILPTR(F) ;SET DESTINATION ADDRESS
HRRZ T4,T3
ADD T4,T2 ;[C20] ADDRESS OF END OF RECORD DESTINATION
BLT T3,-1(T4) ;[OK] TRANSFER RECORD
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
HRRZ R,RSAV ;[C20]
RETURN
ELSE COPY IT PIECEMEAL
MOVE P1,T2 ;[C20] RECORD SIZE (WORDS)
WHILE STILL SOME WORDS TO COPY DO
BEGIN
SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD FRAGMENT
HRRZ T4,T3
ADD T4,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
BLT T3,-1(T4) ;[OK] TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$B ;NOT FINISHED
ENDB;
HRRZ R,RSAV ;[C20]
RETURN
FI;
ENDB;
>;END IFE FTFORTRAN
SUBTTL PUTREC -- PUTASR - Put ASCII Record
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTASR) ;HERE TO PUT NEXT ASCII RECORD INTO OUTPUT FILE
IF USER GAVE /AFTER-ADVANCING SWITCH
SKIPG ADVFLG ;[N11] DO WE WANT TO ADVANCE FIRST?
JRST $F ;[N11] NO
THEN CALL THE PUTCRF ROUTINES
PUSH P,P4 ;[N11] YES, FIRST SAVE RETURN
JSP P4,PUTCRB ;[N11] YES, OUTPUT CRLF
POP P,P4 ;[N11] IT USES P4 SINCE OTHER ROUTINES ITS CALLS DO
FI;
AOS FILSIZ(F) ;INCREMENT SIZE OF FILE
ADD R,XTRWRD ;BYPASS EXTRACTED KEYS
SKIPGE FILFLG(F) ;VARIABLE LENGTH OUTPUT?
JRST PUTAVR ;YES
SKIPL FILPTR(F) ;SEE IF ON A WORD BOUNDARY
JRST PUTASN ;NOT
MOVE T1,RECORD ;SEE HOW MANY ACTUAL CHARS
IDIVI T1,5
PUSH P,T2 ;SAVE REMAINDER
MOVE T2,T1
IMULI T2,5 ;INTEGRAL NO. OF BYTES
CAMLE T2,FILCNT(F) ;ALL IN THIS BUFFER?
JRST PUTAML ;NO
HRRZ T3,FILPTR(F) ;GET BYTE PTR
HRLI T3,RC.KEY(R) ;ORIGIN
ADD R,T1 ;[C20] ADVANCE READ PTR
ADDB T1,FILPTR(F) ;ADJUST BYTE PTR
HRRZS T1 ;[C20]
BLT T3,-1(T1) ;[OK] MOVE ALL BUT LAST PARTIAL WORD
MOVN T2,T2 ;NO. OF BYTES USED BY FULL WORDS
ADDM T2,FILCNT(F) ;ACCOUNT FOR THEM
; PJRST PUTALW ;NEXT PAGE
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTALW) ;PUT ASCII LAST WORD
SKIPG FILCNT(F) ;WILL LAST WORD FIT?
JSP T4,PUTBUF ;NO, WRITE OUT BUFFER
POP P,T2 ;GET REMAINDER BACK
JUMPE T2,PUTCRL ;END WITH CR-LF
MOVE T1,RC.KEY(R) ;GET LAST PARTIAL WORD
AND T1,ASCMSK(T2) ;[OK] ONLY WHAT WE REALLY NEED
HRRZ T3,FILPTR(F) ;[C20] STORE FULL WORD
MOVEM T1,(T3) ;[C20] ..
MOVN T1,T2 ;-NO. OF BYTES LEFT
ADDM T1,FILCNT(F) ;SUBTRACT FROM TOTAL
IFE FTKL10,<
IBP FILPTR(F) ;ADJUST BYTE PTR
SOJG T2,.-1
>
IFN FTKL10,<
ADJBP T2,FILPTR(F)
MOVEM T2,FILPTR(F)
>
; PJRST PUTCRL ;BELOW
ENDB;
BEGIN
PROCEDURE (JSP P4,PUTCRL) ;PUT A CRLF
HRRZ R,RSAV ;[C20] RESTORE R
SKIPLE NOCRLF ;[N11] IF WE DON'T WANT A CRLF
RETURN ;[N11] JUST RETURN
SKIPLE ADVFLG ;[N11] HAVE WE ALREADY OUTPUT THE CRLF
RETURN ;[N11] YES
ENDB; ;[N11] FALL INTO PUTCRB
BEGIN
PROCEDURE (JSP P4,PUTCRB) ;[N11]
MOVEI T1,.CHCRT ;CR
PUSHJ P,WRASBT ;WRITE ASCII BYTE
MOVEI T1,.CHLFD ;LF
PUSHJ P,WRASBT
MOVE T1,FILPTR(F) ;NOW SEE IF ALREADY ON WORD BOUNDARY
TLNE T1,760000 ;IF SO CHANGE BYTE PTR
JRST PUTALN ;NOT, SEE IF WE WANT TO WORD ALIGN
ADD T1,[430000,,1] ;YES, MAKE IT POINT TO WORD
MOVEM T1,FILPTR(F)
RETURN
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (PUSHJ P,WRASBT) ;WRITE ASCII BYTE TO OUTPUT FILE
IF BUFFER IS ALREADY FULL
SOSL FILCNT(F) ;ENOUGH ROOM?
JRST $F
THEN EMPTY IT
PUSH P,T1 ;SAVE CURRENT BYTE
JSP T4,PUTBUF ;WRITE OUT BUFFER
POP P,T1 ;RESTORE BYTE
SOS FILCNT(F) ;ACCOUNT FOR BYTE WE WILL NEXT STORE
FI;
IDPB T1,FILPTR(F) ;YES, STORE BYTE
RETURN
ENDB;
BEGIN
PROCEDURE (JSP P4,PUTALN) ;ALIGN ON WORD BOUNDARY IF REQUIRED
SKIPG ALIGN ;WANT TO WORD ALIGN ON OUTPUT?
RETURN ;NO, DONE
SETZ T2, ;GET A NULL
$1% SOS FILCNT(F) ;DECREMENT BYTE COUNT
IDPB T2,T1 ;STORE NULL
TLNE T1,760000 ;GOT THERE YET?
JRST $1 ;NO
ADD T1,[430000,,1] ;YES
MOVEM T1,FILPTR(F) ;CHANGE BYTE PTR
RETURN
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTAML) ;HERE WHEN RECORD CROSSES BLOCK BOUNDARY
MOVE P1,T1 ;[C20] SIZE OF RECORD (WORDS)
$1% SKIPN T1,FILCNT(F) ;NUMBER OF BYTES LEFT IN CURRENT BUFFER
JSP T4,PUTBUF ;FULL, DUMP IT
IDIVI T1,5 ;WORDS IN CURRENT BUFFER
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD RESIDUE
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
HRRZ T1,FILPTR(F) ;[C20]
BLT T3,-1(T1) ;[OK] TRANSFER RECORD FRAGMENT
MOVNI T1,5 ;5 BYTES PER WORD
IMUL T1,T2 ;[C20] - NO. OF WORDS
ADDM T1,FILCNT(F) ;ADJUST BUFFER COUNT
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$1 ;FINISHED ?
PJRST PUTALW ;HANDLE LAST PARTIAL WORD
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTASN) ;HERE FOR ASCII RECORD NOT ON A WORD BOUNDARY
IFE FTKL10,<
LDB P1,[POINT 6,FILPTR(F),5] ;GET BYTE POSITION
SOS T1,P1 ;NO. OF BITS LEFT -1
IDIVI T1,7 ;CONVERT TO BYTES
MOVN T1,T1 ;-NO. THATS LEFT
ADDI T1,5 ;+ NO. ALREADY USED
ADDM T1,FILCNT(F) ;ACCOUNT FOR THEM
MOVE T2,RECORD ;NO. OF BYTES TO FOLLOW
IDIVI T2,5 ;NO. OF WORDS
ADD T1,T3 ;[C20] THOSE IN FRONT + THOSE BEHIND
PUSH P,T1 ;SAVE REMAINDER
PUSH P,T3 ;SAVE NO. OF BYTES IN (R)
MOVE T4,T2 ;[C20] -NO. OF FULL WORDS TO COPY
MOVN T3,P1 ;NO. OF BITS TO SHIFT LEFT
ADDI T3,^D35 ;LSHC COUNTER FOR REMAINDER
MOVSI T2,(POINT 7,) ;RETARD BYTE POINTER TO BEFORE FIRST BYTE
HLLM T2,FILPTR(F) ; SO BOTH ILDB AND MOVE @ WORK
HRRZ T1,FILPTR(F) ;[C20] GET PARTIAL WORD
MOVE T1,(T1) ;[C20] ..
MOVN T2,P1 ;NO. OF BYTES -1 IT IS LEFT SHIFTED
LSH T1,-1(T2) ;[OK] RIGHT JUSTIFY
;LOOP FOR REMAINING WORDS
$1% SKIPG FILCNT(F) ;ROOM IN THIS BUFFER?
JRST [PUSH P,T1 ;SAVE PARTIAL
PUSH P,T3 ;LSHC -COUNT
PUSH P,T4 ;[C20] SAVE T4
JSP T4,PUTBUF ;GET NEW BUFFER
POP P,T4 ;[C20] RESTORE T4
POP P,T3
POP P,T1
JRST $5]
$5% MOVE T2,RC.KEY(R) ;GET IT
LSHC T1,(P1) ;[OK] 35 BITS IN T1
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,@FILPTR(F) ;STORE
LSHC T1,(T3) ;[OK] MOVE REMAINDER INTO T1
MOVNI T2,5
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
AOS FILPTR(F) ;AND BYTE PTR
ADDI R,1 ;[C20] LOOP FOR ALL FULL WORDS
SOJG T4,$1 ;[C20] ..
;NOW FOR LAST WORD
SKIPLE FILCNT(F) ;BUFFER FULL?
JRST $6 ;NO
PUSH P,T1 ;SAVE PARTIAL WORD
JSP T4,PUTBUF ;YES, EMPTY IT
POP P,T1 ;RESTORE PARTIAL WORD
$6% POP P,T3 ;GET REMAINDER
JUMPE T3,$2 ;NONE
SKIPA T2,RC.KEY(R) ;GET IT
$2% TDZA T2,T2 ;NO REMAINDER
AND T2,ASCMSK(T3) ;[OK] ONLY WHAT WE NEED
LSHC T1,(P1) ;[OK] FORM 35 BITS
LSH T1,1
MOVEM T1,@FILPTR(F) ;STORE FIRST WORD
POP P,T3 ;GET TOTAL REMAINDER
CAIGE T3,5 ;ONLY ONE WORD?
JRST $3 ;YES
AOS FILPTR(F) ;ADVANCE BYTE PTR
MOVNI T1,5 ;COUNT DOWN NO. OF BYTES LEFT
ADDB T1,FILCNT(F)
SUBI T3,5 ;...
JUMPG T1,$4 ;ENOUGH ROOM IN THIS BUFFER
PUSH P,T2 ;NO, SAVE REMAINDER
PUSH P,T3 ;BYTE COUNT
JSP T4,PUTBUF ;GET NEW BUFFER
POP P,T3
POP P,T2
$4% MOVEM T2,@FILPTR(F) ;STORE 2ND WORD
JUMPE T3,$7 ;NO REMAINDER LEFT BY NOW?
$3% MOVN T3,T3
ADDM T3,FILCNT(F) ;ADJUST BYTE COUNT
IBP FILPTR(F)
AOJL T3,.-1 ;AND BYTE PTR
$7%
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T1,7 ;BYTE SIZE
PUSHJ P,PUTEX ;PUT RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST PUTCRL ;ALL DONE
ENDB;
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTAVR) ;WRITE VARIABLE LENGTH ASCII RECORD
;TERMINATE WITH CR-LF
IFE FTKL10,<
HRLI T4,(POINT 7,,35) ;[C20] FORM BYTE PTR
HRR T4,R ;[C20] ..
MOVE P1,@RSAV ;[OK] [147] NO. OF CHARACTERS TO STORE
SKIPG SEQNO ;[110] SEQUENCE NO.?
JRST $1 ;NO
MOVE T1,RC.KEY(R) ;GET FIRST WORD
MOVEM T1,@FILPTR(F) ;[C20] STORE SEQ NO.
AOS FILPTR(F) ;INCREMENT STORE PTR
MOVNI T1,5
ADDM T1,FILCNT(F) ;GET BYTE COUNT RIGHT
SUBI P1,5 ;CORRECT THE NUMBER OF CHARACTERS TO STORE
ADDI R,1 ;AND INPUT PTR
$1% ILDB T1,T4 ;[C20] GET CHARACTER
$2% SOSGE FILCNT(F) ;ANY ROOM IN BUFFER?
JRST [PUSH P,T4 ;[C20] SAVE T4
JSP T4,PUTBUF ;[C20] NO, EMPTY IT
POP P,T4 ;[C20] RESTORE T4
LDB T1,T4 ;[C20] GET BYTE AGAIN
JRST $2] ;TRY AGAIN
IDPB T1,FILPTR(F) ;STORE
SOJG P1,$1 ;LOOP
$3%
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,@RSAV ;[OK] NO. OF BYTES TO COPY
SKIPG SEQNO ;[110] SEQUENCE NO.?
JRST $3 ;NO
MOVE T1,1(R) ;GET FIRST WORD
HRRZ T2,FILPTR(F) ;[C20] YES, STORE IT
MOVEM T1,(T2) ;[C20] ..
AOS FILPTR(F) ;ADVANCE
ADDI R,1 ;[216] ADVANCE RECORD POINTER TOO
MOVNI T1,5
ADDM T1,FILCNT(F) ;ACCOUNT FOR BYTES
SUBI T0,5 ; ..
$3% MOVEI T1,7 ;BYTE SIZE
PUSHJ P,PUTEX ;PUT RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST PUTCRL ;ALL DONE
ENDB;
SUBTTL PUTREC -- PUTEBR - Put EBCDIC Record
;STILL IN IFE FTCOBOL
IFE FTFORTRAN,<
BEGIN
PROCEDURE (JSP P4,PUTEBR) ;HERE TO PUT NEXT EBCDIC RECORD INTO OUTPUT FILE
AOS FILSIZ(F) ;INCREMENT SIZE OF FILE
ADD R,XTRWRD ;[150] BYPASS EXTRACTED KEYS
SKIPGE T1,FILFLG(F) ;VARIABLE LENGTH OUTPUT?
JRST PUTEVR ;YES
TXNE T1,FI.IND ;INDUSTRY COMPATIBLE MODE?
JRST PUTICR ;YES
SKIPL FILPTR(F) ;SEE IF ON A WORD BOUNDARY
JRST PUTEBN ;NOT
MOVE T1,RECORD ;SEE HOW MANY ACTUAL CHARS
IDIVI T1,4
PUSH P,T2 ;SAVE REMAINDER
MOVE T2,T1
LSH T2,2 ;INTEGRAL NO. OF BYTES
CAMLE T2,FILCNT(F) ;ALL IN THIS BUFFER?
JRST PUTEML ;NO
HRRZ T3,FILPTR(F) ;GET BYTE PTR
HRLI T3,RC.KEY(R) ;ORIGIN
ADD R,T1 ;[C20] ADVANCE READ PTR
ADDB T1,FILPTR(F) ;ADJUST BYTE PTR
HRRZS T1 ;[C20]
BLT T3,-1(T1) ;[OK] MOVE ALL BUT LAST PARTIAL WORD
MOVN T2,T2 ;NO. OF BYTES USED BY FULL WORDS
ADDM T2,FILCNT(F) ;ACCOUNT FOR THEM
; PJRST PUTELW ;NEXT PAGE
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,PUTELW) ;PUT EBCDIC LAST WORD
SKIPG FILCNT(F) ;WILL LAST WORD FIT?
JSP T4,PUTBUF ;NO, WRITE OUT BUFFER
POP P,T2 ;GET REMAINDER BACK
JUMPE T2,PUTEBZ ;END
MOVE T1,RC.KEY(R) ;GET LAST PARTIAL WORD
AND T1,EBCMSK(T2) ;[OK] ONLY WHAT WE REALLY NEED
HRRZ T3,FILPTR(F) ;[C20] STORE FULL WORD
MOVEM T1,(T3) ;[C20] ..
MOVN T1,T2 ;-NO. OF BYTES LEFT
ADDM T1,FILCNT(F) ;SUBTRACT FROM TOTAL
IFE FTKL10,<
IBP FILPTR(F) ;ADJUST BYTE PTR
SOJG T2,.-1
>
IFN FTKL10,<
ADJBP T2,FILPTR(F)
MOVEM T2,FILPTR(F)
>
; PJRST PUTEBZ ;BELOW
ENDB;
BEGIN
PROCEDURE (JSP P4,PUTEBZ) ;PUT EBCDIC, FIX UP BYTE-POINTER
HRRZ R,RSAV ;[C20] RESTORE R
MOVE T1,FILPTR(F) ;NOW SEE IF ALREADY ON WORD BOUNDARY
TLNE T1,700000 ;IF SO CHANGE BYTE PTR
RETURN ;NOT
TLO T1,440000 ;MAKE IT POINT TO START OF WORD
ADDI T1,1 ;NEXT WORD
MOVEM T1,FILPTR(F)
RETURN
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,PUTEML) ;HERE WHEN RECORD CROSSES BLOCK BOUNDARY
MOVE P1,T1 ;[C20] SIZE OF RECORD (WORDS)
$1% SKIPN T1,FILCNT(F) ;NUMBER OF BYTES LEFT IN CURRENT BUFFER
JSP T4,PUTBUF ;FULL, DUMP IT
IDIVI T1,4 ;WORDS IN CURRENT BUFFER
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD RESIDUE
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
MOVE T1,FILPTR(F)
BLT T3,-1(T1) ;[OK] TRANSFER RECORD FRAGMENT
MOVNI T1,4 ;5 BYTES PER WORD
IMUL T1,T2 ;[C20] - NO. OF WORDS
ADDM T1,FILCNT(F) ;ADJUST BUFFER COUNT
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$1 ;FINISHED ?
PJRST PUTELW ;HANDLE LAST PARTIAL WORD
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,PUTEBN) ;HERE FOR EBCDIC RECORD NOT ON A WORD BOUNDARY
IFE FTKL10,<
LDB P1,[POINT 6,FILPTR(F),5] ;GET BYTE POSITION
MOVE T1,P1 ;NO. OF BITS LEFT
IDIVI T1,9 ;CONVERT TO BYTES
MOVN T1,T1 ;-NO. THATS LEFT
ADDI T1,4 ;+ NO. ALREADY USED
ADDM T1,FILCNT(F) ;ACCOUNT FOR THEM
MOVE T2,RECORD ;NO. OF BYTES TO FOLLOW
IDIVI T2,4 ;NO. OF WORDS
ADD T1,T3 ;[C20] THOSE IN FRONT + THOSE BEHIND
PUSH P,T1 ;SAVE REMAINDER
PUSH P,T3 ;SAVE NO. OF BYTES IN (R)
MOVE T4,T2 ;[C20] NO. OF FULL WORDS TO COPY
MOVN T3,P1 ;NO. OF BITS TO SHIFT LEFT
ADDI T3,^D36 ;LSHC COUNTER FOR REMAINDER
MOVEI T2,44 ;RETARD BYTE POINTER TO BEFORE FIRST BYTE
DPB T2,[POINT 6,FILPTR(F),5] ; SO BOTH ILDB AND MOVE @ WORK
HRRZ T1,FILPTR(F) ;[C20] GET PARTIAL WORD
MOVE T1,(T1) ;[C20] ..
MOVN T2,P1 ;NO. OF BYTES IT IS LEFT SHIFTED
LSH T1,(T2) ;[OK] RIGHT JUSTIFY
;LOOP FOR REMAINING WORDS
$1% SKIPG FILCNT(F) ;ROOM IN THIS BUFFER?
JRST [PUSH P,T1 ;SAVE PARTIAL
PUSH P,T3 ;LSHC -COUNT
PUSH P,T4 ;[C20] SAVE T4
JSP T4,PUTBUF ;GET NEW BUFFER
POP P,T4 ;[C20] RESTORE T4
POP P,T3
POP P,T1
JRST $5]
$5% MOVE T2,RC.KEY(R) ;GET IT
LSHC T1,(P1) ;[OK] 36 BITS IN T1
MOVEM T1,@FILPTR(F) ;STORE
LSHC T1,(T3) ;[OK] MOVE REMAINDER INTO T1
MOVNI T2,4
ADDM T2,FILCNT(F) ;ADJUST BYTE COUNT
AOS FILPTR(F) ;AND BYTE PTR
ADDI R,1 ;[C20] LOOP FOR ALL FULL WORDS
SOJG T4,$1 ;[C20] ..
;NOW FOR LAST WORD
SKIPLE FILCNT(F) ;BUFFER FULL?
JRST $6 ;NO
PUSH P,T1 ;SAVE PARTIAL WORD
JSP T4,PUTBUF ;YES, EMPTY IT
POP P,T1 ;RESTORE PARTIAL WORD
$6% POP P,T3 ;GET REMAINDER
JUMPE T3,$2 ;NONE
SKIPA T2,RC.KEY(R) ;GET IT
$2% TDZA T2,T2 ;NO REMAINDER
AND T2,EBCMSK(T3) ;[OK] ONLY WHAT WE NEED
LSHC T1,(P1) ;[OK] FORM 36 BITS
MOVEM T1,@FILPTR(F) ;STORE FIRST WORD
POP P,T3 ;GET TOTAL REMAINDER
CAIGE T3,4 ;ONLY ONE WORD?
JRST $3 ;YES
AOS FILPTR(F) ;ADVANCE BYTE PTR
MOVNI T1,4 ;COUNT DOWN NO. OF BYTES LEFT
ADDB T1,FILCNT(F)
SUBI T3,4 ;...
JUMPG T1,$4 ;ENOUGH ROOM IN THIS BUFFER
PUSH P,T2 ;NO, SAVE REMAINDER
PUSH P,T3 ;BYTE COUNT
JSP T4,PUTBUF ;GET NEW BUFFER
POP P,T3
POP P,T2
$4% HRRZ T1,FILPTR(F) ;[C20] STORE 2ND WORD
MOVEM T2,(T1) ;[C20] ..
JUMPE T3,$7 ;NO REMAINDER LEFT BY NOW?
$3% MOVN T3,T3
ADDM T3,FILCNT(F) ;ADJUST BYTE COUNT
IBP FILPTR(F)
AOJL T3,.-1 ;AND BYTE PTR
$7%
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T1,^D9 ;BYTE SIZE
PUSHJ P,PUTEX ;PUT RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST PUTEBZ ;ALL DONE
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,PUTEVR) ;WRITE VARIABLE LENGTH EBCDIC RECORD
MOVE P1,@RSAV ;[OK] [150] GET BYTE COUNT
MOVEI T1,4(P1) ;[OK] BYTE COUNT PLUS 4 BYTE OVERHEAD
LDB T2,[POINT 6,FILPTR(F),11] ;[442] GET BYTE SIZE
MOVN T2,T2 ;[442] NEGATE IT
ROT T1,(T2) ;[OK] [442] RIGHT JUST RIGHT ORDER BITS
PUSHJ P,WREBBT ;WRITE IT
LDB T2,[POINT 6,FILPTR(F),11] ;[442] GET BYTE SIZE
LSH T1,-^D36(T2) ;[OK] [442] RIGHT JUSTIFY LOW ORDER BITS
PUSHJ P,WREBBT ;WRITE IT
SETZ T1,
PUSHJ P,WREBBT ;WRITE JUNK
PUSHJ P,WREBBT ;...
IFE FTKL10,<
HRLI T4,(POINT 9,,35) ;[C20] FORM BYTE PTR
HRR T4,R ;[C20] ..
$1% ILDB T1,T4 ;[C20] GET CHARACTER
$2% SOSGE FILCNT(F) ;ANY ROOM IN BUFFER?
JRST [PUSH P,T4 ;[C20] SAVE T4
JSP T4,PUTBUF ;[C20] NO, EMPTY IT
POP P,T4 ;[C20] RESTORE T4
LDB T1,T4 ;[C20] GET BYTE AGAIN
JRST $2] ;TRY AGAIN
IDPB T1,FILPTR(F) ;STORE
SOJG P1,$1 ;LOOP
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,P1 ;[C20] NO. OF BYTES TO COPY
MOVEI T1,^D9 ;BYTE SIZE
PUSHJ P,PUTEX ;PUT RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST PUTEBZ ;ALL DONE
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WREBBT) ;WRITE EBCDIC BYTE TO OUTPUT FILE
IF BUFFER IS ALREADY FULL
SOSL FILCNT(F) ;ENOUGH ROOM?
JRST $F
THEN EMPTY IT
PUSH P,T1 ;SAVE CURRENT BYTE
JSP T4,PUTBUF ;WRITE OUT BUFFER
POP P,T1 ;RESTORE BYTE
SOS FILCNT(F) ;ACCOUNT FOR BYTE WE WILL NEXT STORE
FI;
IDPB T1,FILPTR(F) ;YES, STORE BYTE
RETURN
ENDB;
;STILL IN IFE FTCOBOL, IFE FTFORTRAN
BEGIN
PROCEDURE (JSP P4,PUTICR) ;WRITE INDUSTRY COMPATIBLE FIXED LENGTH EBCDIC RECORD
IFE FTKL10,<
MOVE P1,RECORD ;GET BYTE COUNT
HRLI T4,(POINT 9,,35) ;[C20] FORM BYTE PTR
HRR T4,R ;[C20] ..
$1% ILDB T1,T4 ;[C20] GET CHARACTER
$2% SOSGE FILCNT(F) ;ANY ROOM IN BUFFER?
JRST [PUSH P,T4 ;[C20] SAVE T4
JSP T4,PUTBUF ;[C20] NO, EMPTY IT
POP P,T4 ;[C20] RESTORE T4
LDB T1,T4 ;[C20] GET BYTE AGAIN
JRST $2] ;TRY AGAIN
IDPB T1,FILPTR(F) ;STORE
SOJG P1,$1 ;LOOP
>;END OF IFE FTKL10
IFN FTKL10,<
MOVE T0,RECORD ;NO. OF BYTES TO COPY
MOVEI T1,^D9 ;BYTE SIZE
PUSHJ P,PUTEX ;PUT RECORD WITH COMMON BIS CODE
>;END IFN FTKL10
JRST PUTEBZ ;ALL DONE
ENDB;
>;END IFE FTFORTRAN
SUBTTL PUTREC -- PUTBNR - Put Binary Record
;STILL IN IFE FTCOBOL
BEGIN
PROCEDURE (JSP P4,PUTBNR)
AOS FILSIZ(F) ;INCREMENT SIZE OF FILE
MOVE T2,RECSIZ ;RECORD SIZE
ADD R,XTRWRD ;BYPASS EXTRACTED KEYS
MOVE T3,MODE
TXNE T3,RM.FOR ;FORTRAN BINARY FILE
PJRST PUTFBR ;YES
IF RECORD WILL FIT IN CURRENT BUFFER
CAMGE T1,T2 ;[C20] WILL RECORD FIT IN CURRENT BUFFER ?
JRST $T ;NO, RECORD MUST SPAN BUFFERS
THEN COPY IT
HRLZI T3,RC.KEY(R) ;YES, SET ORIGIN ADDRESS
HRR T3,FILPTR(F) ;SET DESTINATION ADDRESS
HRRZ T4,T3
ADD T4,T2 ;[C20] ADDRESS OF END OF RECORD DESTINATION
BLT T3,-1(T4) ;[OK] [364] TRANSFER RECORD
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
HRRZ R,RSAV ;[C20]
RETURN
ELSE COPY IT PIECEMEAL
MOVE P1,T2 ;[C20] RECORD SIZE (WORDS)
BEGIN
SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD FRAGMENT
HRRZ T4,T3
ADD T4,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
BLT T3,-1(T4) ;[OK] [364] TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$B ;NOT FINISHED
ENDB;
HRRZ R,RSAV ;[C20]
RETURN
FI;
ENDB;
;STILL IN IFE FTCOBOL
;PRIOR TO FORTRAN VERSION 7 ALL CONTINUE LSCW WORDS WERE 128 DECIMAL EXCEPT FOR THE LAST.
;WITH FORTRAN VERSION 7 THEY ARE GENERALLY PAGE SIZES (512) WORDS.
;THE ACTUAL SIZE IS STORED IN LSCWSZ.
;ALL CONTINUED BLOCKS EXCEPT THE LAST ARE MADE THIS SIZE.
BEGIN
PROCEDURE (JSP P4,PUTFBR)
MOVE T2,@RSAV ;[OK] [203] GET THIS RECORD'S LENGTH IN WORDS
MOVE P3,T1 ;COPY FILCNT AND CONVERT IT
SOJL P3,.+2 ;[316] DON'T ROUND UP IF NOTHING
AND P3,LSCWMS ;GET A BLOCK NO LARGER THAN WE CAN HANDLE -1
ADDI P3,1 ;BACK TO BIGGEST BLOCK
IF RECORD WILL FIT IN CURRENT BUFFER
CAIGE P3,2(T2) ;[OK] WILL RECORD FIT IN CURRENT "BUFFER" ?
JRST $T ;NO, RECORD MUST SPAN BUFFERS
THEN COPY IT
MOVEI T3,1(T2) ;[OK] WORDS TO LSCW
HRLI T3,S.LSCW
HRRZ T4,FILPTR(F) ;[C20] STORE START LSCW
MOVEM T3,(T4) ;[C20] ..
AOS T3,FILPTR(F)
HRLI T3,RC.KEY(R) ;FORM BLT PTR
HRRZ T4,T3
ADD T4,T2 ;[C20] ADDRESS OF END OF RECORD DESTINATION
BLT T3,-1(T4) ;[OK] [316] TRANSFER RECORD
MOVEI T3,2(T2) ;[OK] TOTAL WORDS
HRLI T3,E.LSCW
MOVEM T3,0(T4) ;[OK] STORE END CONTROL WORD
SUBI T1,2(T2) ;[OK]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDI T2,1
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
JRST $F ;[316] DONE
ELSE COPY IT PIECEMEAL
IF MODE IS RANDOM
SKIPGE FILFLG(F) ;RANDOM IS FIXED SIZE
JRST $T ;MUST BE SEQUENTIAL
THEN COPY RECORD WITHOUT CONTINUE LSCWS
MOVE P1,T2 ;[C20] RECORD SIZE (WORDS)
MOVEI T3,1(T2) ;[OK] WORDS TO LSCW
HRLI T3,S.LSCW
HRRZ T1,FILPTR(F) ;[C20] STORE START LSCW
MOVEM T3,(T1) ;[C20] ..
AOS T3,FILPTR(F)
SOS FILCNT(F)
BEGIN
SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD FRAGMENT
HRRZ T4,T3
ADD T4,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
BLT T3,-1(T4) ;[OK] [316] TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$B ;NOT FINISHED
ENDB;
SKIPN FILCNT(F) ;ROOM FOR LSCW
JSP T4,PUTBUF ;NO
MOVE T3,RECSIZ ;NO. OF DATA WORDS
ADD T3,[E.LSCW,,2]
HRRZ T1,FILPTR(F) ;[C20]
MOVEM T3,(T1) ;[C20]
AOS FILPTR(F)
SOS FILCNT(F)
JRST $F
ELSE IT'S SEQUENTIAL, COPY WITH CONTINUE LSCWS
MOVE P1,T2 ;[C20] RECORD SIZE (WORDS)
MOVE P2,P1 ;USED TO COUNT EXTRA LSCWS
MOVE T3,P3 ;[C20] WORDS TO LSCW
HRLI T3,S.LSCW
HRRZ T1,FILPTR(F) ;[C20] STORE START LSCW
MOVEM T3,(T1) ;[C20] ..
AOS T3,FILPTR(F)
SOS FILCNT(F)
SUBI P3,1 ;DECREMENT "PSEUDO"-BUFFER COUNT
BEGIN
SKIPLE FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JRST $2 ;STILL SOME
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
$2% SKIPLE T1,P3 ;WORDS REMAINING IN "BUFFER"
JRST $1 ;STILL SOME
MOVE P3,LSCWSZ ;[316] PRETEND NEW "BUFFER"
ADDI P2,1 ;ONE MORE LSCW TO COUNT
MOVEI T2,1(P1) ;[OK] SIZE OF RECORD RESIDUE + LSCW
CAMLE T2,P3 ;[C20] [316] WMLL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,P3 ;[C20] [316] NO, TRANSFER ONLY FILCNT WORDS
HRLI T2,C.LSCW
HRRZ T3,FILPTR(F) ;[C20]
MOVEM T2,(T3) ;[C20]
AOS FILPTR(F)
SOS FILCNT(F) ;[316] ONE LESS WORD IN BUFFER
SUBI P3,1 ;[316] AND IN "BUFFER" TOO
$1% MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,P3 ;[C20] [316] WILL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,P3 ;[C20] [316] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.KEY(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD FRAGMENT
HRRZ T4,T3
ADD T4,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
BLT T3,-1(T4) ;[OK] TRANSFER RECORD FRAGMENT
MOVE T1,FILCNT(F) ;GET REAL BYTE COUNT
SUB T1,T2 ;[C20] SUBTRACT WHAT WE'VE WRITTEN SO FAR
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
SUB P3,T2 ;[C20] COUNT DOWN PSEUDO-BUFFER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
JUMPN P1,$B ;NOT FINISHED
ENDB;
JUMPN P3,$1 ;[316] NEED JUST END LSCW?
SKIPN FILCNT(F) ;[316] NO--NEED CONT THEN END LSCW--SEE IF ROOM
JSP T4,PUTBUF ;[316] NO--MAKE ROOM
MOVE T1,[C.LSCW,,1] ;[316] 1 BECAUSE ONLY END LSCW LEFT
HRRZ T2,FILPTR(F) ;[C20] STORE CONTINUE WORD
MOVEM T1,(T2) ;[C20] ..
AOS FILPTR(F)
SOS FILCNT(F)
ADDI P2,1 ;COUNT ONE MORE LSCW
$1% MOVEI T3,2(P2) ;[OK] NO. OF DATA WORDS + LSCWS
HRLI T3,E.LSCW
HRRZ T1,FILPTR(F) ;[C20]
MOVEM T3,(T1) ;[C20]
AOS FILPTR(F)
SOS FILCNT(F)
FI;
FI;
HRRZ R,RSAV ;[C20]
RETURN
ENDB;
;STILL IN IFE FTCOBOL
IFN FTKL10,<
BEGIN
PROCEDURE (PUSHJ P,PUTEX)
;CALL WITH:
; T0/ NUMBER OF BYTES TO COPY
; T1/ BYTE SIZE
; F/ INDEX TO FILE TABLE (FOR BUFFER HEADER)
; R/ INDEX TO WORD BEFORE DATA IN RECORD
LSH T1,^D24 ;MOVE SIZE TO BYTE POINTER POSITION
HRR T1,R ;[C20] FINISH BY STUFFING IN ADDR
MOVE T3,FILCNT(F) ;FILL UP REST OF ACS FOR EXTEND
$1% SETZ T2, ;UNUSED BIS AC
CAMGE T0,T3 ;DO THEY ALL FIT?
MOVE T3,T0 ;YES
MOVN T4,T0
ADDM T4,FILCNT(F) ;ACCOUNT FOR BYTES READ
MOVE T4,FILPTR(F) ;DESTINATION BYTE POINTER
EXTEND T0,[MOVSLJ
EXP 0] ;COPY AND 0 FILL
JRST $2
MOVEM T4,FILPTR(F) ;RESTORE BYTE POINTER
RETURN ;ALL DONE
$2% SETZM FILCNT(F) ;DON'T UPSET PUTBUF
MOVEM T4,FILPTR(F) ;UPDATE BYTE POINTER
PUSH P,T0 ;SAVE TEMPS OVER PUTBUF CALL
PUSH P,T1 ; ..
JSP T4,PUTBUF ;SEND THIS FULL BUFFER
POP P,T1 ;RESTORE TEMPS
POP P,T0 ; ..
MOVE T3,FILCNT(F) ;SET UP NEW DESTINATION
JRST $1 ;LOOP 'TIL RECORD IS SENT
ENDB;
>;END IFN FTKL10
>;END IFE FTCOBOL
SUBTTL PUTREC -- PTTREC - Put Next Record to Temporary File
BEGIN
PROCEDURE (JSP P4,PTTREC)
AOS FILSIZ(F) ;INCREMENT SIZE OF FILE
SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
MOVE T2,REKSIZ ;FIXED RECORD SIZE NOW
IFE FTCOBOL,<
IF RECORD IS VARIABLE SIZE OR COBOL
SKIPG P.VARF
SKIPE COBPDP ;CALLED FROM COBOL?
TRNA
JRST $F ;NO
THEN ONLY SAVE AS MUCH AS WE NEED
>
MOVE T2,RC.CNT(R) ;GET NO. OF BYTES
SUBI T2,1 ;[201] COUNT ALL BUT LAST DATA WORD
IDIV T2,IOBPW ;[201] ..
ADDI T2,2 ;[201] COUNT LAST AND COUNT WORD
ADD T2,XTRWRD ;[201] COUNT EXTRACTED KEYS
IFE FTCOBOL,<
FI;
>;END IFE FTCOBOL
IF RECORD WILL FIT IN CURRENT BUFFER
CAMGE T1,T2 ;[C20] WILL RECORD FIT IN CURRENT BUFFER ?
JRST $1 ;NO, RECORD MUST SPAN BUFFERS
THEN COPY IT
HRLZI T3,RC.CNT(R) ;YES, SET ORIGIN ADDRESS
HRR T3,FILPTR(F) ;SET DESTINATION ADDRESS
HRRZ T4,T3
ADD T4,T2 ;[C20] END OF BLT
BLT T3,-1(T4) ;[OK] TRANSFER RECORD
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
RETURN
ELSE
$1% HRLI T1,(IFIW) ;[C20] SAVE R
HRR T1,R ;[C20] ..
MOVEM T1,RSAV ;[C20] ..
MOVE P1,T2 ;[C20] RECORD SIZE (WORDS)
$2% SKIPN T1,FILCNT(F) ;NUMBER WORDS REMAINING IN CURRENT BUFFER
JSP T4,PUTBUF ;BUFFER FILLED, WRITE IT
MOVE T2,P1 ;[C20] SIZE OF RECORD RESIDUE
CAMLE T2,T1 ;[C20] WILL RESIDUE FIT IN CURRENT BUFFER ?
MOVE T2,T1 ;[C20] NO, TRANSFER ONLY FILCNT WORDS
HRLZI T3,RC.CNT(R) ;PTR TO ORIGIN OF RECORD FRAGMENT
HRR T3,FILPTR(F) ;PTR TO DESTINATION OF RECORD FRAGMENT
HRRZ T4,T3
ADD T4,T2 ;[C20] END OF BLT
BLT T3,-1(T4) ;[OK] TRANSFER RECORD FRAGMENT
SUB T1,T2 ;[C20]
MOVEM T1,FILCNT(F) ;ADJUST BUFFER COUNTER
ADDM T2,FILPTR(F) ;ADVANCE BUFFER POINTER
ADD R,T2 ;[C20] ADVANCE RECORD RETRIEVAL PTR
SUB P1,T2 ;[C20] DECREMENT LENGTH OF RECORD RESIDUE
IF NOT FINISHED
THEN COPY SOME MORE
JUMPN P1,$2 ;NOT FINISHED
ELSE RETURN
HRRZ R,RSAV ;[C20]
RETURN
FI;
FI;
ENDB;
BEGIN
PROCEDURE (PUSHJ P,GENNAM)
;GENNAM GENERATES A SIXBIT FILE NAME OF FORM ###Sxy, WHERE ### IS OUR OCTAL JOB
;NUMBER, x IS THE RUN NUMBER, y IS THE FILE NUMBER IN THE RUN. NOTE THAT SINCE
;WE ALLOW ONLY ONE LETTER FOR THE FILE NUMBER, THERE IS A LIMIT OF 26 TEMPORARY
;FILES PER MERGE PASS. TOPS-20 REACHES THIS LIMIT, WHILE TOPS-10 IS FURTHER
;LIMITED BY I/O CHANNELS.
;
;CALL WITH:
; F/ POINTER TO FCB
;
;RETURN WITH:
; T1/ NAME ON RETURN
MOVE T1,MRGNUM ;GET MERGE PASS NO.
LSH T1,6 ;MAKE ROOM FOR FILE NUMBER
ADD T1,TCBIDX ;ADD FILE NAME INDEX
ADDI T1,'S0A' ;FORM ALPHABETIC
HRRM T1,FILNAM(F) ;STORE NUMERIC FILE NAME
HLL T1,JOBNUM ;PLACE OCTAL JOB NUMBER IN LEFT HALF
RETURN
ENDB;
SUBTTL MEMORY MANAGEMENT
;SETSPC - SETUP MEMORY MANAGEMENT ROUTINES
BEGIN
PROCEDURE (PUSHJ P,SETSPC)
IFN FTFORTRAN,<
MOVEI T1,1 ;[C20] ALWAYS USE FUNCT. FOR FORTRAN-10
>
IFN FTCOBOL,<
IFE FTNZSEC,< ;IF SECTION ZERO CASE
MOVEI T1,1 ;[C20] ALWAYS USE FUNCT. FOR SECTION-ZERO COBOL
>
IFN FTNZSEC,< ;IF NOT SECTION ZERO CASE
MOVEI T1,1 ;[C20] ALWAYS USE FUNCT. FOR COBOL
XMOVEI T2,. ;[C20] GET MY SECTION NUMBER
HLRZS T2 ;[C20] ..
SKIPE T2 ;[C20] NON-ZERO SECTION?
MOVEI T1,2 ;[C20] YES, ASSUME USING SECTFF
>>
IFE FTCOBOL!FTFORTRAN,<
MOVEI T1,0 ;[C20] ASSUME USING .JBFF FOR MEMORY ALLOCATION
XMOVEI T2,. ;[C20] GET MY SECTION NUMBER
HLRZS T2 ;[C20] ..
SKIPE T2 ;[C20] NON-ZERO SECTION?
MOVEI T1,2 ;[C20] YES, ASSUME USING SECTFF
HLRZ T3,FORFUN ;[C20] GET FORTRAN SECTION NUMBER
SKIPE FORRET ;[C20] CALLED BY FORTRAN
CAME T2,T3 ;[C20] AND IN FORTRAN'S SECTION?
SKIPA ;[C20] NO
MOVEI T1,1 ;[C20] YES, USE FUNCT. FOR MEMORY ALLOCATION
>
MOVEM T1,SECTSW ;[C20] SAVE TYPE OF MEMORY ALLOCATION
JRST @[IFIWS <$1,$1,$2>](T1) ;[C20] DISPATCH
;SORT is in a non-zero section.
;All memory above SORT and below DDT is available.
$2% MOVEI T2,FREORG ;[C20] GET STARTING SECTFF
MOVEM T2,SECTFF ;[C20] SAVE IT
MOVEI T2,DDTORG ;[N27] [C20] GET HIGHEST AVAILABLE LOCATION
MOVEM T2,FREEND ;[C20] REMEMBER IT
SUB T2,SECTFF ;[C20] CALCULATE MEMORY AVAILABLE
$3% MOVEM T2,OLDCOR ;[C20] [C13] STORE IT
MOVEM T2,FRECOR ;[C13] ..
MOVE T2,[IOWD STCKSZ,CSTACK] ;[N06] [C13] SETUP STACK
MOVEM T2,CORSTK ;[C13] ..
RETURN ;[C13]
;SORT is in section zero.
;The only memory available is between the top of the low segment (.JBREL)
;and the lower of the start of the hi-seg, an OTS, or SORT.
;The are 3 cases to consider are:
;1) Two segment code, hiseg at 400000 or higher (normal TOPS-20 COBOL)
; FREEND=start of hi-seg
;2) One segment code with OTS at 400000 but lower than SORT (normal FORTRAN)
; FREEND=start of OTS
;3) One segment with OTS forced in low-seg (/SEG:LOW to LINK)
; FREEND=start of SORT
$1% ;[C20]
IFE FTOPS20!FTCOBOL!FTFORTRAN,<
MOVE T2,.JBREL## ;[OK] [C13] GET .JBREL
MOVEM T2,OLDREL ;[C13] SAVE IT
>
HRRZ T2,.JBFF## ;[OK] [C13] GET .JBFF
MOVEM T2,OLDFF ;[C13] SAVE IT
IFN FTOPS20,< IFE FTCOBOL!FTFORTRAN,<
SKIPE T2,FORHI ;[N27] HAVE WE BEEN CALLED BEFORE?
JRST $6 ;[N27] YES, USE THE PREVIOUS VALUE
>>
MOVE T1,.JBREL## ;[N27] GET TOP OF LOW SEG
ADDI T1,1 ;[N27] GET NEXT FREE PAGE ADDRESS
LSH T1,-<POW2(PGSIZ)> ;[N27] TURN INTO PAGE NUMBER
CAIGE T1,400 ;[N27] ABOVE THE USUAL STARTING PAGE OF OTS?
IFN FTOPS20,<
SKIPA T1,[.FHSLF,,400] ;[N27] NO, START THE SCAN AT PAGE 400
HRLI T1,.FHSLF ;[N27] YES, START HERE
$4% TRNE T1,777000 ;[524] Have we gone too far
JRST $5 ;[524] Yes, We have found the top
RPACS% ;[N27] GET ACCESSIBILITY OF THE PAGE
ERJMP $5 ;[524] Just in case
TXNN T2,PA%PEX ;[N27] DOES THE PAGE EXIST?
>
IFE FTOPS20,<
MOVEI T1,400 ;[N27] NO START THE SCAN AT PAGE 400
$4% MOVE T2,T1 ;[N27] GET THE PAGE TO TEST
HRLI T2,.PAGCA ;[N27] ACCESS FUNCTION
PAGE. T2, ;[N27]
JRST $5 ;[N27] ASSUME PAGE 400
JUMPGE T2,$5 ;[N27] PAGE EXISTS
CAIGE T1,770 ;[N27] ARE WE INTO DDT AND PFH AREAS?
>
AOJA T1,$4 ;[N27] NOT YET, TRY NEXT PAGE
$5% HRRZ T2,T1 ;[N27] GET PAGE NUMBER THAT FAILED
LSH T2,POW2(PGSIZ) ;[N27] CONVERT TO ADDRESS
; CAILE T2,HIORG ;[N27] MAKE SURE ITS REASONABLE
; MOVEI T2,HIORG ;[N27] IT IS NOW
IFN FTOPS20,< IFE FTCOBOL!FTFORTRAN,<
MOVEM T2,FORHI ;[N27] INCASE WE GET CALLED AGAIN
$6%
>>
MOVEM T2,FREEND ;[N27] [C13] REMEMBER IT
SUB T2,OLDFF ;[C13] CALCULATE MEMORY AVAILABLE
JRST $3 ;[C20]
ENDB;
;RSTSPC - RE-SETUP AVAILABLE MEMORY
; T1 CONTAINS NEW AVAILABLE MEMORY
BEGIN
PROCEDURE (PUSHJ P,RSTSPC)
SUB T1,OLDCOR ;[C13] CALCULATE CHANGE
$1% ADDM T1,OLDCOR ;[C13] UPDATE AVAILABLE MEMORY
ADDM T1,FRECOR ;[C13] ..
SKIPLE T1 ;[C13] WARN USER IF INCREASE
PUSHJ P,E$$NCS ;[C13] NOT ENOUGH CORE SPECIFIED
MOVN T1,FRECOR ;[C13] NEGATIVE AVAILABLE MEMORY?
JUMPG T1,$1 ;[C13] RE-ADJUST IF SO
RETURN ;[C13]
ENDB;
;GETSPC ALLOCATES C(T1) WORDS AND RETURNS THE ADDRESS OF THE BLOCK IN T1. SKIP
;RETURNS IF OK, ERROR RETURNS IF NO MORE MEMORY AVAILABLE.
BEGIN
PROCEDURE (PUSHJ P,GETSPC)
MOVEM T1,SIZE ;[C01] SAVE REQUESTED SIZE
MOVE T1,SECTSW ;[C20] DISPTACH
JRST @[IFIWS <$2,$1,$4>](T1) ;[C20] ..
$1% MOVEI L,1+[-5,,0 ;[C20] LOAD UP ARG BLOCK FOR FUNCT. CALL
Z TP%INT,[F.GOT]
Z TP%LIT,[ASCIZ /SRT/]
Z TP%INT,STATUS
Z TP%INT,ADDR
Z TP%INT,SIZE]
PUSHJ P,FUNCT. ;ALLOCATE THE MEMORY
SKIPE STATUS ;NON-ZERO STATUS IS AN ERROR
RETURN ;GIVE ERROR RETURN
JRST $5 ;[C20] [C13]
$2% HRRZ T1,.JBFF## ;[C20] [C13] GET ADDRESS
MOVEM T1,ADDR ;[C13] SAVE IT
ADD T1,SIZE ;[C13] ADD IN SIZE REQUESTED
CAMLE T1,FREEND ;[C13] ALLOCATING BEYOUND BOUNDARY?
RETURN ;[C13] YES, NOT ENOUGH CORE
IFE FTOPS20,<
IF THERE'S NOT ENOUGH MEMORY
$3% CAMG T1,.JBREL## ;[C20] SEE IF WE HAVE ENOUGH
JRST $F ;YES--GO FINISH
THEN GET SOME
IFE FTVM,<
MOVE T2,T1 ;[C13] TRY TO ALLOCATE SOME MORE ROOM
CORE T2, ;[C13] ..
RETURN ;[C13] CAN'T
>
IFN FTVM,<
MOVE T2,[XWD .PAGCD,T3] ;[C13] TRY TO ALLOCATE SOME MORE ROOM
MOVEI T3,1 ;[C13] ..
MOVE T4,.JBREL## ;[C13] ..
ADDI T4,PGSIZ ;[C13] ..
LSH T4,-<POW2(PGSIZ)> ;[C13] ..
PAGE. T2, ;[C13] ..
RETURN ;[C20] CAN'T
JRST $3 ;[C20] TEST AGAIN
>
FI;
>
HRRM T1,.JBFF## ;[OK] [C13] UPDATE FREE MEMORY ADDRESS
JRST $5 ;[C20]
$4% MOVE T1,SECTFF ;[C20] GET ADDRESS
MOVEM T1,ADDR ;[C20] SAVE IT
ADD T1,SIZE ;[C20] ADD IN SIZE REQUESTED
CAMLE T1,FREEND ;[C20] ALLOCATING BEYOUND BOUNDARY?
RETURN ;[C20] YES, NOT ENOUGH CORE
MOVEM T1,SECTFF ;[C20] UPDATE FREE MEMORY ADDRESS
$5% MOVN T1,SIZE ;[C20] [C13] SUBTRACT SIZE REQUESTED FROM POOL
ADDM T1,FRECOR ;[C13] ..
MOVE T3,CORSTK ;[C13] GET PTR TO STACK OF ALLOCATION ENTRIES
HRLZ T1,SIZE ;[C13] CONSTRUCT XWD SIZE, ADDRESS
HRR T1,ADDR ;[C13] FOR ALLOCATION STACK
PUSH T3,T1 ;[C13] PUSH THIS ENTRY ONTO STACK
MOVEM T3,CORSTK ;[C13] SAVE STACK POINTER
MOVE T1,OLDCOR ;[C13] CALCULATE MEMORY IN USE
SUB T1,FRECOR ;[C13] ..
CAMLE T1,MAXCOR ;[C13] LARGEST SO FAR?
MOVEM T1,MAXCOR ;[C13] YES, REMEMBER IT
IFN FTDEBUG,<
$ERROR ([,AMA,<Allocating >,+)
$MORE (DECIMAL,SIZE)
$MORE (TEXT,< words at >)
$MORE (OCTAL,ADDR)
$CRLF
>
HRRZ T1,ADDR ;[C13] RETURN ADDRESS OF BLOCK TO CALLER
PJRST CPOPJ1 ;[C13] GIVE SKIP RETURN
ENDB;
;FRESPC - FREE C(T1) WORDS
BEGIN
PROCEDURE (PUSHJ P,FRESPC)
MOVE T4,CORSTK ;[C13] GET ALLOCATION STACK POINTER
POP T4,T3 ;[C13] POP SIZE AND ADDR OF LAST BLOCK ALLOCATED
MOVEM T4,CORSTK ;[C13] SAVE STACK POINTER
HLRZM T3,SIZE ;[C13] SAVE SIZE
HRRZM T3,ADDR ;[C13] SAVE ADDR
MOVE T2,SECTSW ;[C20] DISPATCH
JRST @[IFIWS <$2,$1,$3>](T2) ;[C20] ..
$1% MOVEI L,1+[-5,,0 ;[C20] LOAD UP FUNCT. ARG BLOCK
Z TP%INT,[F.ROT]
Z TP%LIT,[ASCIZ /SRT/]
Z TP%INT,STATUS
Z TP%INT,ADDR
Z TP%INT,SIZE]
PUSH P,T1 ;[C13] SAVE T1
PUSHJ P,FUNCT. ;RELEASE THE MEMORY
POP P,T1 ;[C13] RESTORE T1
SKIPE STATUS ;OK?
JRST E$$FMR ;NO, COMPLAIN
JRST $4 ;[C20] [C13]
$2% CAMGE T1,SIZE ;[C20] [C13] FREEING LESS THAN TOP BLOCK'S SIZE
JRST E$$FMR ; IS AN ERROR
HRRZ T2,.JBFF## ;[OK] GET FREE POINTER
SUB T2,SIZE ;[C13] FREE UP TOP BLOCK
CAME T2,ADDR ;[C13] CORRECT ADDR?
JRST E$$FMR ;[C13] NO, OOPS
HRRM T2,.JBFF## ;[OK] REMEMBER NEW FREE POINTER
JRST $4 ;[C20]
$3% CAMGE T1,SIZE ;[C20] FREEING LESS THAN TOP BLOCK'S SIZE
JRST E$$FMR ;[C20] IS AN ERROR
MOVE T2,SECTFF ;[C20] GET FREE POINTER
SUB T2,SIZE ;[C20] FREE UP TOP BLOCK
CAME T2,ADDR ;[C20] CORRECT ADDR?
JRST E$$FMR ;[C20] NO, OOPS
MOVEM T2,SECTFF ;[C20] REMEMBER NEW FREE POINTER
$4% SUB T1,SIZE ;[C13] SUBTRACT WHAT WE'VE FREED
MOVE T2,SIZE ;[C13] ADD MEMORY BACK TO POOL
ADDM T2,FRECOR ;[C13] ..
JUMPG T1,FRESPC ;[C13] IF SOME LEFT TO DUMP, DO IT
IFN FTDEBUG,<
$ERROR ([,DMA,<Returning >,+)
$MORE (DECIMAL,SIZE)
$MORE (TEXT,< words at >)
$MORE (OCTAL,ADDR)
$CRLF
>
RETURN
ENDB;
;RELSPC - RELEASE ALL RETAINED SPACE
BEGIN
PROCEDURE (PUSHJ P,RELSPC)
$1% MOVE T1,CORSTK ;[C13] GET PTR TO ALLOCATION STACK
HRRZ T2,T1 ;[C13] EMPTY YET?
CAIGE T2,CSTACK ;[C13] ..
JRST $2 ;[C13] YES
HLRZ T1,(T1) ;[OK] [C13] NO, GET LENGTH OF TOP ENTRY
CALL FRESPC ;[C13] FREE IT
JRST $1 ;[C13] KEEP GOING
$2% MOVE T1,SECTSW ;[C20] DISPATCH
JRST @[IFIWS <$4,$3,$6>](T1) ;[C20] ..
$3% PUSHJ P,CUTBAK ;[C20] [C13] CALL FORTRAN
JRST $6 ;[C20] [C13]
$4% ;[C20] [C13] STANDALONE
IFE FTOPS20,<
IFE FTVM,<
MOVE T1,OLDREL ;[C13] GET ORIGINAL MEMORY SIZE
CORE T1, ;[C13] REDUCE BACK TO IT
JRST E$$FMR ;[C13] CAN'T HAPPEN
>
IFN FTVM,<
MOVE T3,.JBREL## ;[C20] GET MEMORY SIZE
CAMG T3,OLDREL ;[C20] SAME AS ORIGINAL?
JRST $5 ;[C20] YES
MOVE T1,[XWD .PAGCD,T2] ;[C20] NO, REDUCE BACK TO IT
MOVEI T2,1 ;[C20] ..
LSH T3,-<POW2(PGSIZ)> ;[C20] ..
TLO T3,(PA.GAF) ;[C20] ..
PAGE. T1, ;[C20] ..
JRST E$$FMR ;[C20] CAN'T HAPPEN
JRST $4 ;[C20] TEST AGAIN
$5% ;[C20]
>
>
MOVE T1,OLDFF ;[C13] GET ORIGINAL .JBFF
HRRZ T2,.JBFF## ;[OK] [C13] AND CURRENT .JBFF
CAME T1,T2 ;[C13] THEY SHOULD MATCH
JRST E$$FMR ;[C13] NO, ERROR
$6% RETURN ;[C20] [C13]
ENDB;
;CUTBAK - TELL FORTRAN TO CUT BACK MEMORY
BEGIN
PROCEDURE (PUSHJ P,CUTBAK)
MOVEI L,1+[-3,,0 ;[C13] LOAD UP ARG BLOCK FOR FUNCT. CALL
Z TP%INT,[F.CBC] ;[C13]
Z TP%LIT,[ASCIZ /SRT/] ;[C13]
Z TP%INT,STATUS] ;[C13]
IFE FTOPS20!FTCOBOL,<
SKIPN FORPDP ;[472] FORSRT WILL DO IT IF CALLED FROM FORTRAN
>
PUSHJ P,FUNCT. ;[C13] CUT BACK CORE
RETURN ;[C13]
ENDB;
BEGIN
PROCEDURE (PUSHJ P,CLRSPC)
;CLRSPC CLEARS MEMORY GOTTEN FROM GETSPC. RETURNS WITH ADDRESS OF SPACE CLEARED
;IN T1.
SKIPN T1,SIZE ;LOAD SIZE INTO T1
RETURN ; AND RETURN IF ZERO
MOVE T3,ADDR ;GET ADDR OF SPACE
HRL T2,T3 ;GET 'FROM' ADDR
HRRI T2,1(T3) ;[OK] GET 'TO' ADDR
SETZM (T3) ;[OK] CLEAR FIRST LOC
ADD T3,SIZE ;GET 'UNTIL' ADDR
MOVE T4,SIZE ;[C20] SKIP IF SIZE = ONE
CAIE T4,1 ;[C20] ..
BLT T2,-1(T3) ;[OK] CLEAR SPACE
MOVE T1,ADDR
RETURN
ENDB;
SUBTTL STATS -- Statistics
;SSTATS - SETUP STATISTICS LOCATIONS
BEGIN
PROCEDURE (PUSHJ P,SSTATS)
SETOM RTRUNC ;[C20] FOR TRUNCATION MESSAGE
IFE FTOPS20,<
SETZ T1, ;[C20] GET CPU TIME
RUNTIM T1, ;[C20] ..
>
IFN FTOPS20,<
HRROI T1,-5 ;[C20] GET CPU TIME
RUNTM% ;[C20] ..
>
MOVEM T1,CPUTIM ;[C20] INITIAL CPU TIME IN MS
IFE FTOPS20,<
MSTIME T1, ;[C20] GET DAY TIME
>
IFN FTOPS20,<
TIME% ;[C20] GET DAY TIME
>
MOVEM T1,ORGTIM ;[C20] INITIAL TIME OF DAY IN MS
RETURN ;[C20]
ENDB;
;STATS - TYPE THE STATS IF REQUESTED
BEGIN
PROCEDURE (PUSHJ P,STATS)
SKIPG STATSW ;[C20] WANT THE STATS?
RETURN ;[C20] NO
SKIPLE MRGSW ;[C20] A MERGE OR SORT?
JRST $1 ;[C20]
TYPE (<Sorted >) ;[C20] A SORT
JRST $2 ;[C20]
$1% TYPE (<Merged >) ;[C20] A MERGE
$2% MOVE T1,INPREC ;[C20] TYPE RECORD COUNT
PUSHJ P,.TDECW ;[C20] ..
IF PLURAL
MOVE T1,INPREC
SOJE T1,$T
THEN TYPE RECORDS
TYPE (< records
>) ;[C20] ..
JRST $F
ELSE TYPE RECORD
TYPE (< record
>) ;[C20] ..
FI;
AOSG T1,RTRUNC ;[C20] ANY RECORDS TRUNCATED?
JRST $3 ;[C20] NO
PUSHJ P,.TDECW ;[C20] YES, TYPE IT
IF PLURAL
MOVE T1,RTRUNC
SOJE T1,$T
THEN TYPE RECORDS
TYPE (< records truncated
>) ;[C20]
JRST $F
ELSE TYPE RECORD
TYPE (< record truncated
>) ;[C20]
FI;
$3% MOVE T1,CMPCNT ;[C20] TYPE NUMBER OF KEY COMPARISONS
PUSHJ P,.TDECW ;[C20] ..
TYPE (< KEY comparisons, >) ;[C20] ..
MOVE T1,CMPCNT ;[C20] TYPE PER RECORD
MOVE T2,INPREC ;[C20] ..
MOVEI T3,2 ;[C20] ..
PUSHJ P,.TFLPW ;[C20] ..
TYPE (< per record
>) ;[C20] ..
MOVE T1,RCBTOT ;[C20] TYPE NUMBER OF LEAVES
PUSHJ P,.TDECW ;[C20] ..
TYPE (< record leaves in memory, >) ;[C20] ..
MOVE T1,BUFTOT ;[C20] TYPE SIZE OF BUFFER POOL
PUSHJ P,.TCOPK ;[C20] ..
TYPE (< buffer memory
>) ;[C20] ..
MOVE T1,RUNTOT ;[C20] TYPE NUMBER OF RUNS
PUSHJ P,.TDECW ;[C20] ..
IF PLURAL
MOVE T1,RUNTOT ;[C20] ..
SOJE T1,$T ;[C20] ..
THEN TYPE PLURAL FORM
TYPE (< runs, >) ;[C20] ..
JRST $F ;[C20]
ELSE TYPE SINGULAR
TYPE (< run, >) ;[C20] ..
FI;
MOVE T1,MRGNUM
PUSHJ P,.TDECW
IF PLURAL
MOVE T1,MRGNUM
SOJE T1,$T
THEN TYPE PLURAL FORM
TYPE (< iterations>)
JRST $F
ELSE TYPE SINGULAR
TYPE (< iteration>)
FI;
SKIPG MRGSW ;[C20] BIAS MEANINGFUL?
SKIPN T2,RUNTOT ;[C20] ..
JRST $6 ;[C20] NO
TYPE (<, bias >) ;[C20] YES, TYPE IT
MOVE T1,INPREC ;[C20] ..
IDIV T1,RUNTOT ;[C20] ..
MOVE T2,RCBTOT ;[C20] ..
MOVEI T3,2 ;[C20] ..
PUSHJ P,.TFLPW ;[C20] ..
$6% PUSHJ P,.TCRLF ;[C20] ..
SKIPN TMPTOT ;[C20] ANY TEMPORARY FILES USED?
JRST $9 ;[C20] NO
TYPE (<Total of >) ;[C20] YES, TYPE IT
MOVE T1,TMPTOT ;[C20] ..
IFN FTOPS20,<
IDIVI T1,PGSIZ ;[C20] ..
>
IFE FTOPS20,<
IDIVI T1,200 ;[C20] ..
>
SKIPE T2 ;[C20] ..
ADDI T1,1 ;[C20] ..
PUSHJ P,.TDECW ;[C20] ..
MOVE T1,TMPTOT ;[C20] ..
SOJN T1,$7 ;[C20] ..
IFN FTOPS20,<
TYPE (< page>) ;[C20] ..
>
IFE FTOPS20,<
TYPE (< disk block>) ;[C20] ..
>
JRST $8 ;[C20] ..
IFN FTOPS20,<
$7% TYPE (< pages>) ;[C20] ..
>
IFE FTOPS20,<
$7% TYPE (< disk blocks>) ;[C20] ..
>
$8% TYPE (< in temporary files used
>) ;[C20] ..
$9% MOVE T1,MAXCOR ;[C20] GET MEMORY RETAINED
PUSHJ P,.TCOPK ;[C20] ..
TYPE (< of memory retained at one time
>) ;[C20] ..
IFE FTOPS20,<
SETZ T1, ;[C20] GET CPU TIME
RUNTIM T1, ;[C20] ..
>
IFN FTOPS20,<
HRROI T1,-5 ;[C20] GET CPU TIME
RUNTM% ;[C20] ..
>
SUB T1,CPUTIM ;[C20] CALCULATE INCREMENTAL CPU TIME
IFN FTOPS20,<
IMULI T1,^D1000 ;[C20] CONVERT TO MILLISECS
IDIV T1,T2 ;[C20] ..
>
PUSH P,T1 ;[C20] SAVE IT
PUSHJ P,.TTIME ;[C20] TYPE IT
TYPE (< CPU time, >) ;[C20] ..
POP P,T1 ;[C20] GET MS BACK
MOVE T2,INPREC ;[C20] TYPE PER RECORD
MOVEI T3,2 ;[C20] ..
PUSHJ P,.TFLPW ;[C20] ..
TYPE (< ms per record
>) ;[C20] ..
IFE FTOPS20,<
MSTIME T1, ;[C20] GET DAY TIME
>
IFN FTOPS20,<
TIME% ;[C20] GET DAY TIME
>
SUB T1,ORGTIM ;[C20] CALCULATE INCREMENTAL ELAPSED TIME
IFE FTOPS20,<
SKIPGE T1 ;[C20] GONE PAST MIDNIGHT?
ADD T1,[^D<24*60*60*1000>] ;[C20] YES, ADD 1 DAY OF MILLISECS.
>
IFN FTOPS20,<
IMULI T1,^D1000 ;[C20] CONVERT TO MILLISECS
IDIV T1,T2 ;[C20] ..
>
PUSHJ P,.TTIME ;[C20] TYPE IT
TYPE (< elapsed time
>) ;[C20] ..
RETURN ;[C20]
ENDB;
SUBTTL TYPE-OUT ROUTINES
BEGIN
PROCEDURE (PUSHJ P,.TCOPK)
;ROUND AND TYPE OUT A CORE NUMBER SUFFIXED WITH P OR K
;CALL: MOVE T1,NUMBER
; PUSHJ P,.TCOPK
;USES T1, T2, T3, T4
MOVEI T2,PGSIZ ;[C20] ROUND TO A K OR P
IFE FTOPS20,<
SKIPN CPU ;[C20] ..
MOVEI T2,2*PGSIZ ;[C20] ..
>
MOVE T3,T2 ;[C20] ..
SUBI T3,1 ;[C20] ..
TDZE T1,T3 ;[C20] ..
ADD T1,T2 ;[C20] ..
JRST .TCORW ;[C20] TYPE IT
ENDB;
BEGIN
PROCEDURE (PUSHJ P,.TFLPW)
;TYPE OUT SIGNED FLOATING POINT NUMBER
;CALL: MOVE T1,NUMBER
; MOVE T2,DIVISOR
; MOVEI T3,NO. OF DIGITS AFTER DECIMAL PT.
; PUSHJ P,.TFLPW
;USES T1, T2, T3, T4
PUSH P,P1 ;[C20] GET A SAFE ACC
IFE FTKL10,<
HRRZI T4,1(T3) ;[C20] NO. OF DECIMAL PLACES + 1
HRLI T4,1(T3) ;[C20] ...
ADD P,T4 ;[C20] ADJUST STACK POINTER
>
IFN FTKL10,<
ADJSP P,1(T3) ;[C20] ADJUST STACK POINTER
>
MOVE T4,T2 ;[C20] SAVE DIVISOR
IDIV T1,T2 ;[C20] GET NUMBER BEFORE DECIMAL PT.
HRRZ P1,P ;[C20] GET BASE OF STACK
PUSH P,T3 ;[C20] SAVE COUNT
MOVEM T1,0(P1) ;[C20] SAVE REMAINDER
$1% MOVE T1,T2 ;[C20] GET REMAINDER
IMULI T1,^D10 ;[C20]
IDIV T1,T4 ;[C20] GET NEXT DIGIT
SUBI P1,1 ;[C20] BACKUP STACK
MOVEM T1,0(P1) ;[C20] SAVE DIGIT
SOJG T3,$1 ;[C20] LOOP
MOVE T3,0(P) ;[C20] GET COUNT AGAIN
LSH T2,1 ;[C20] DOUBLE REMAINDER
CAMGE T2,T4 ;[C20] NEED TO ROUND UP?
JRST $3 ;[C20] NO
$2% AOS T1,0(P1) ;[C20] ROUND UP
CAIG T1,9 ;[C20] TOO BIG?
JRST $3 ;[C20] NO, ROUNDING DONE
SOJL T3,$3 ;[C20] OK IF BEFORE DECIMAL POINT
SETZM 0(P1) ;[C20] MAKE IT ZERO
AOJA P1,$2 ;[C20] AND ROUND UP NEXT DIGIT
$3% POP P,P1 ;[C20] GET COUNT
POP P,T1 ;[C20] GET WHOLE NUMBER
PUSHJ P,.TDECW ;[C20] PRINT IT
MOVEI T1,"." ;[C20] GET DECIMAL PT.
PUSHJ P,.TCHAR ;[C20] PRINT IT
$4% POP P,T1 ;[C20] GET NEXT DIGIT
ADDI T1,"0" ;[C20] CONVERT TO ASCII
PUSHJ P,.TCHAR ;[C20] TYPE IT
SOJG P1,$4 ;[C20] LOOP
POP P,P1 ;[C20] RESTORE P1
RETURN ;[C20]
ENDB;
SUBTTL ERROR MESSAGE SUPPRESSION CONTROL
BEGIN
PROCEDURE (PUSHJ P,%ERMSG)
IFE FTOPS20!FTCOBOL!FTFORTRAN,<
SETZM QBUFER ;[C20] CLEAR DEFERED TTY OUTPUT
>
HRRES SUPFLG ;[351] CLEAR LAST CALL
SKIPGE SUPFLG ;[351] IF NEVER BEEN SET BY SWITCH
SETZM SUPFLG ;[351] CLEAR THE PRE-SCAN INITIAL SETTING
HLRZ T3,T2 ;GET ERROR CODE
CAIN T3,"?" ;FATAL?
MOVEI T3,SUPFATAL
CAIN T3,"%" ;WARNING?
MOVEI T3,SUPWARN
CAIN T3,"[" ;INFORMATION?
MOVEI T3,SUPINFO
CAIE T3,SUPFATAL ;IS THIS ERROR FATAL?
JRST $1 ;NO
SKIPG T4,FERCOD ;[N19] [C20] DOES USER WANT CODE RETURNED?
JRST $1 ;[N19] NO
PUSH P,T2 ;[N19] NEED TWO ACCS TO CONVERT TO ASCII
PUSH P,T1 ;[527] SAVE T1 FOR .ERMSG
HRLZ T2,T1 ;[N19] GET ERROR CODE
$2% LSH T1,1 ;[N19][527] MAKE 7 BITS
LSHC T1,6 ;[N19] GET A CHAR.
ADDI T1," " ;[N19] CONVERT TO ASCII
JUMPN T2,$2 ;[N19] LOOP FOR ALL 3 CHARS.
LSH T1,2*7+1 ;[N19] GET IT LEFT JUSTIFIED
IORI T1,<" ">_1 ;[N19] ADD IN 2 SPACES
MOVEM T1,@T4 ;[C20][527] YES
POP P,T1 ;[527] RESTORE T1
POP P,T2 ;[527] RESTORE T2
$1% CAMLE T3,SUPFLG ;ARE WE ALLOWED TO PRINT IT?
PJRST .ERMSG ;YES
HRROS SUPFLG ;NO, AND NOT FOR $MORE EITHER
RETURN
ENDB;
%TOCTW: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TOCTW ;NO
POPJ P,
%TDECW: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TDECW ;NO
POPJ P,
%TSTRG: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TSTRG ;NO
POPJ P,
%TSIXN: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TSIXN ;NO
POPJ P,
%TOLEB: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TOLEB ;NO
POPJ P,
%TCORW: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TCORW ;NO
POPJ P,
%TCRLF: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TCRLF ;NO
POPJ P,
%TRBRK: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TRBRK ;NO
POPJ P,
%TCHAR: SKIPL SUPFLG ;SUPPRESS IT?
PJRST .TCHAR ;NO
POPJ P,
SUBTTL ERROR MESSAGES
E$$NEC: $ERROR (?,NEC,<Not enough core for SORT/MERGE.>)
E$$FMR: $ERROR (?,FMR,<Attempt to free more memory than was originally retained.>)
IFE FTOPS20,<
E$$NEH: $ERROR (?,NEH,<Not enough I/O channels for SORT/MERGE.>)
E$$FCN: $ERROR (?,FCN,<Attempt to free a I/O channel not retained or released.>)
>
E$$FCR: $ERROR (?,FCR,<Fatal core management error at RELSPC>) ;[C13]
E$$NCS: $ERROR (%,NCS,<Not enough core specified>)
POPJ P,
E$$TMT: $ERROR (%,TMT,<Too many temporary structures specified>)
POPJ P,
E$$RIE: $ERROR (?,RIE,<Record incomplete at E-O-F>)
E$$RNI: $ERROR (?,RNI,<Record number inconsistent, >,+) ;[362]
$MORE (DECIMAL,INPREC)
$MORE (TEXT,< read, >)
$MORE (DECIMAL,OUTREC)
$MORE (TEXT,< written>)
$CRLF
POPJ P,
CPOPJ1: AOS (P) ;STANDARD SKIP-RETURN MECHANISM
CPOPJ: POPJ P, ; ..
SEGMENT IMPURE ;[C20]
LOWEND=.-1 ;[C20] END OF DATA
SEGMENT LPURE ;[C20]
;ENDMODULE;
END