File MRGV2.PA (PAL assembler source file)

Directory of image this file is from
This file as a plain text file

/MERGE VERSION 2 FOR OS/8
/
/SEPTEMBER, 1977, BRYAN FREDRICK, MINNESOTA POLLUTION CONTROL AGENCY
/
	*200
MRGST,	JMS I	(INITAL	/INITIALIZE OUTPUT POINTERS
	DCA	FILNUM	/CLR FILE INDICATOR
	TAD	(-12	/READ IN FILE BUFFERS
	DCA	INDX
	DCA	FILES
RDLOOP,	JMS I	GETPTR	/GET FILE POINTERS
	JMS I	(CHKSEG	/CHECK SEGMENT OVERFLOW
	TAD I	DIRPTR	/STORE DEVICE NUMBER
	AND	K17	/AFTER ANDING IT OFF
	SNA
	JMP	END	/ZERO DEVICE NUMBER IS THE END
	DCA	DEVCDE
	TAD I	DIRPTR	/GET STARTING BLOCK NUMBER
	DCA	BLKNO
	TAD I	DIRPTR
	SNA		/SET LENGTH = +1 FOR NON-FILE STRUCTURED FILES
	IAC
	DCA	BLEFT	/STORE LENGTH
	DCA	EOFLG	/CLR EOF FLAG
	DCA	CLEFT	/CLR CHARACTER COUNT IN BUFFER
	JMS I	STRPTR	/STORE POINTERS
	JMS I	(READBF	/READ A RECORD
	NOP
	ISZ	FILNUM	/BUMP TO NEXT FILE
	ISZ	FILES	/AND FILE COUNT
	ISZ	INDX	/CHECK FOR ALL DONE
	JMP	RDLOOP	/CONTINUE ON
	SKP CLA
END,	CLA CMA		/BACKUP POINTER TO DIRECTORY
	TAD	DIRPTR
	DCA	DIRPTR
	TAD I	DIRPTR
	SNA CLA
	IAC
	DCA	DNEFLG	/SET CLR DONE FLAG
	CLA CMA
	TAD	DIRPTR
	DCA	DIRPTR	/RESTORE DIRECTORY POINTER
	TAD	PASSES	/CHECK IF WE HAVE ALREADY OPENED OUTPUT FILE
	SZA CLA
	JMP	DOMRG1	/YES, GO DO MERGE
	TAD	DNEFLG	/CHECK FOR DONE
	SZA CLA
	JMP	ENTFNL	/YES, WE CAN ENTER FINAL OUTPUT FILE
	DCA	LSTPAS	/CLEAR LAST PASS FLAG
	TAD	DSKNUM	/ENTER INTERMEDIATE FILE
	JMS	ENTROU
	INTNAM		/NAMED "SRTINT.AB"
DOMRG1,	TAD	DSKNUM	/BUILD UP INTERMEDIATE FILE
	DCA I	DIROUT
	TAD	WRTBLK	/ADD IN WRITE BLOCK
	DCA I	DIROUT
	DCA	FLENGT	/CLEAR OUTPUT INTERMEDIATE LENGTH
	JMP I	(DOMRG	/GO DO MERGE
ENTFNL,	TAD	OUTNAM	/GET POINTER TO OUTPUT FILE
	DCA	FTEMP
	TAD	OUTNUM	/GET OUTPUT DEVICE NUMBER
	JMS	ENTROU	/ENTER FINAL OUTPUT FILE
FTEMP,	0
	ISZ	LSTPAS	/SET LAST PASS FLAG
	JMP I	(DOMRG
ENTROU,	0
	JMS I	(SETABS	/FIX UP DEVICE RESIDENT TABLE
	DCA	DEVNUM	/STORE DEVICE NUMBER
	TAD I	ENTROU	/GET FILE NAME POINTER
	ISZ	ENTROU	/BUMP RETURN 
	DCA	NAMFLD	/STORE IN NAME FIELD
	TAD	NAMFLD	/STORE FOR CLOSE
	DCA	CLSNAM
	CIF	10	/BRING DOWN THE USR
	JMS I	(USRIN
	10
	TAD	DEVNUM	/ENTER OUTPUT FILE
	CIF	10
	JMS I	USR
	3
NAMFLD,	ZBLOCK 2
	ERRHLT+6	/"ENTER ERROR"
	TAD	NAMFLD
	DCA	WRTBLK	/STORE BLOCK NUMBER
	TAD I	OADDR2	/AND OUTPUT ENTRY
	DCA	WRTENT
	TAD	NAMFLD+1	/AND FILE LENGTH
	SNA
	IAC		/SET LENGTH OF 4095 FOR NON-FILE STRUCTURED OUTPUT
	DCA	WLENG
	DCA	WRTEN
	CIF	10
	JMS I	USR
	11		/RESTORE PREVIOUS USR AREA
	JMP I	ENTROU	/EXIT
DEVNUM,	0
CLOSE,	0
	CIF	10
	JMS I	(USRIN
	10		/FETCH THE USR
	TAD	WRTEN
	DCA	CLSNAM+1	/STORE NUMBER OF OUTPUT BLOCKS WRITTEN
	TAD	DEVNUM	/GET DEVICE NUMBER
	JMS I	(SETABS	/SET UP FIELD 1 DEVICE RESIDENCY TABLE
	CIF	10	/CLOSE OUTPUT FILE
	JMS I	USR
	4
CLSNAM,	ZBLOCK 2
	ERRHLT+7	/"CLOSE ERROR"
	JMP I	CLOSE
	PAGE
DOMRG,	DCA	FILNUM	/CLEAR FILE NUMBER
	TAD	FILES	/GET -FILE COUNT
	CIA
	DCA	INDX	/STORE AS INDEX
LOOP1,	JMS	CHKEOF	/CHECK EOF FLAG ON THIS FILE
	JMP	LOOP1EN	/EOF ALREADY HAS BEEN READ ON THIS FILE
	TAD	FILNUM	/A GOOD FILE TO START WITH
	DCA	FILE1	/STORE POINTER TO FILE NUMBER
	JMS	PTRFND	/FIX UP POINTERS TO RECORD INFO
	TAD I	X10	/GET BUFFER FIELD CDF
	DCA	CDF1
	TAD I	X10
	DCA	ADDR1	/STORE ADDRESS POINTER
	TAD I	X10
	DCA	LEN1
	JMP	LOOP2E	/GO TO IT
LOOP1E,	ISZ	FILNUM	/BUMP FILE NUMBER
	ISZ	INDX	/BUMP COUNTER
	JMP	LOOP1	/NOT DONE YET
	JMP	ENDPAS	/ALL DONE WITH PASS, FINISH IT OFF
CHKEOF,	0
	TAD	FILNUM	/MULTIPLY FILE NUMBER BY 9
	RTL CLL
	RAL
	TAD	FILNUM
	TAD	(FILSTR	/ADD IN FILE STORAGE OFFSET
	DCA	PTRFND
	TAD I	PTRFND	/GET EOF FLAG
	SNA CLA
	ISZ	CHKEOF	/RETURN AT P+2 IF NO EOF
	JMP I	CHKEOF	/RETURN
PTRFND,	0
	TAD	FILNUM	/MULTPLY FILE NUMBER BY 5
	RTL CLL
	TAD	FILNUM
	TAD	(RECSTR-1	/ADD IN RECORD OFFSET-1
	DCA	X10	/STORE IN AUTO INDEX
	JMP I	PTRFND	/EXIT
LOOP2,	JMS	CHKEOF	/CHECK FOR EOF ON THIS FILE
	JMP	LOOP2E	/EOF FOUND, EXIT
	JMS	PTRFND	/GET POINTERS
	TAD I	X10
	DCA	CDF2	/STORE AS SECOND RECORD POINTERS
	TAD I	X10
	DCA	ADDR2
	TAD I	X10
	DCA	LEN2
	JMS I	(COMPAR	/GO COMPARE RECORDS AT ADDR1 AND ADDR2
LOOP2E,	ISZ	FILNUM	/BUMP FILE COUNT
	ISZ	INDX	/AND COUNTER
	JMP	LOOP2	/CONTINUE IF NOT DONE
	TAD	CDF1	/STORE LAST RECORD
	DCA	CDFSTR
	TAD	LEN1
	SNA CLA
	JMP	ENDLNE	/A MERE CR-LF
CDFSTR,	CDF
	TAD I	ADDR1
	ISZ	ADDR1
	CDF
	JMS 	CMPRSP	/PACK OUTPUT CHARACTER
	ISZ	LEN1	/CHECK FOR DONE WITH RECORD
	JMP	CDFSTR	/CONTINUE
ENDLNE,	TAD	(215	/ALL DONE OUTPUT CR-LF
	JMS 	CMPRSP
	TAD	(212
	JMS 	CMPRSP
	ISZ	RECMRG+1	/BUMP OUTPUT RECORD COUNT
	SKP CLA
	ISZ	RECMRG
	TAD	FILE1
	DCA	FILNUM	/READ NEXT RECORD ON FILE
	JMS I	(READBF
	NOP
	JMP	DOMRG	/CONTINUE MERGING BUFFER
ENDPAS,	TAD	(232	/ADD IN ^Z
	JMS 	CMPRSP	/PACK IT IN BUFFER
	TAD	(600	/FILL REMAINDER OF BLOCK WITH ZEROS
	TAD	WRTCNT	/CHECK FOR FINISHED BLOCK
	SZA CLA
	JMP	ENDPAS+1	/FILL BLOCK OUT WITH ZEROS
	TAD	FLENGT	/STORE LENGTH IN DIRECTORY AREA
	CIA
	DCA I	DIROUT
	DCA	FLENGT	/CLEAR INTERMEDIATE LENGTH
	JMS I	(RECOUT	/PRINT-CLEAR RECORD COUNTS
	ISZ	PASSES	/BUMP PASSES COUNT
	TAD	DNEFLG	/CHECK FOR DONE
	SNA CLA
	JMP I	K200	/GET NEXT SET OF INTERMEDIATES
	JMP I	(PASDNE
/
/SUBROUTINE TO CHECK OVERFLOW TO NEXT DIRECTORY SEGMENT
/
CHKSEG,	0
	TAD	DIRBUF	/GET BUFFER ADDRESS
	TAD	(376	/ADD IN OFFSET TO END
	CIA		/COMPLEMENT ADDRESS
	TAD	DIRPTR	/ADD IN DIRECTORY POINTER
	SZA CLA
	JMP I	CHKSEG	/NOT AT END, RETURN
	ISZ	DIRSEG	/INCREMENT SEGMENT NUMBER
	JMS I	(RWDIR	/GET DIRECTORY SEGMENT
	CLA CMA
	TAD	DIRBUF	/SET DIRECTORY POINTER BACK TO THE BEGINNING
	DCA	DIRPTR
	JMP I	CHKSEG	/AND RETURN TO MAIN LINE
CRMSG,	3700
	PAGE
PASDNE, DCA     DIRSEG   /CLEAR SEGMENT NUMBER
        JMS I   (RWDIR  /READ FIRST BLOCK BACK IN
        JMS I   (CLOSE  /CLOSE CURRENT OUTPUT FILE
        CDF     10      /CLEAR /S OPTION
        TAD I   (7644
        AND     (7737
        DCA I   (7644
        CDF
        TAD     DSKNUM  /FIX UP DEVICE RESIDENCY TABLE
        JMS I   (SETABS
	CLA
	JMS I	(SYSRD	/READ DOWN THE OVERLAY
        TAD     LSTPAS  /CHECK IF ALL DONE
        SNA CLA
        JMP     WRITNW  /NOT YET, WRITE NEW DIRECTORY
        TAD     DSKNUM
	JMS I	(LOOKUP	/LOOKUP FILE
        DIRNAM
        JMS I   (RENAME /RENAME FILE SO PURGE WILL KILL IT
	TAD	DSKNUM	/GET DSK: DEVICE NUMBER
        JMS     PURGE
	CLA STL RTR
	CDF	10
	AND I	(7644	/CHECK /N OPTION
	CDF
	SZA CLA
	JMP	PEXIT	/SET, EXIT
	JMS I	(MSGA	/TYPE OUT "RECORDS WRITTEN ="
	WRITN
	TAD	RECMRG	/MOVE NUMBER OF RECORDS TO TYPE BUFFER
	DCA	RECIN
	TAD	RECMRG+1
	DCA	RECIN+1
	JMS I	(NUMPNT	/TYPE OUT NUMBER OF OUTPUT RECORDS
	JMS I	(MSGA	/TYPE OUT CRLF
	CRMSG
PEXIT,  CDF CIF
        JMP I   (7600   /GO BACK TO SYSTEM ALL DONE
WRITNW, TAD     DIRBUF
        TAD     (27     /GET COPY ADDRESS
        DCA     X10
	TAD	X10
	DCA	DIRPTR	/SET UP DIRECTORY READ AUTO-INDEX
        TAD     (INTMED-1
        DCA     X11
	TAD	X11	/ALSO ZERO INTERMEDIATE AREA
	DCA	X13
        TAD     (-200
        DCA     INDX    /SET UP TO COPY
        TAD I   X11     /PUT NEW INTERMEDIATE DATA IN FILE
        DCA I   X10
	DCA I	X13	/CLEAR AREA
        ISZ     INDX
        JMP     .-4     /COMPLETE IT
        STL RAR CLA
        JMS I   (RWDIR  /REWRITE DIRECTORY SEGMENT
	TAD	DSKNUM	/GET DSK: DEVICE NUMBER
        JMS     PURGE   /KILL OFF THE PREVIOUS INTERMEDIATES
        TAD     DSKNUM  /NOW RENAME THE INTERMEDIATE
        JMS I   (LOOKUP
        INTNAM
        JMS I   (RENAME
        DCA     PASSES  /CLEAR PASSES COUNT
	DCA	RECMRG	/CLR OUTPUT RECORD COUNTS
	DCA	RECMRG+1
        JMP I   (MRGST  /CONTINUE WITH OPERATION
/
/DELETE ANY FILES WITH THE NAME "SRTINT.AA"
/MUST BE DONE RECURSIVELY DUE TO THE POSSIBLITY OF MUTIPLE FILES
/
PURGE,  0
        DCA     TEMP    /STORE DEVICE NUMBER
        TAD     CLSNA   /RESTORE LOOKUP
        DCA     LOOK
        TAD     TEMP
        CIF     10
        JMS I   USR     /LOOKUP THE FILE
        2
LOOK,   OLDNAM
        0
        JMP I   PURGE   /NO MORE FOUND, CAN EXIT ROUTINE
        TAD     CLSNA   /ENTER TEMPORARY WITH THE SAME NAME
        DCA     ENTNAM
        TAD     TEMP
        CIF     10
        JMS I   USR
        3
ENTNAM, ZBLOCK 2
        ERRHLT+6        /"ENTER ERROR"
        TAD     TEMP
        CIF     10      /CLOSE WITH ZERO BLOCKS (A PURGE)
        JMS I   USR
        4
CLSNA,  OLDNAM
        0
        ERRHLT+7        /"CLOSE ERROR"
        JMP     PURGE+2
OLDNAM, FILENAME SRTINT.AA
SETABS,	0
	DCA	AC1
	TAD	AC1
	TAD	(7646
	DCA	OADDR1
	TAD	AC1
	TAD	(DEVTAB-1
	DCA	OADDR2
	TAD I	OADDR2	/STORE ENTRY POINT IN OUTPUT TABLE
	CDF	10
	DCA I	OADDR1
	CDF
	TAD	AC1	/LEAVE WITH AC VALUE CALLED WITH
	JMP I	SETABS
	PAGE
/
/SUBROUTINE TO TYPE OUT RECORD COUNTS FOR MERGE INPUT FILES
/
RECOUT, 0
        CDF     10
        TAD I   (7644   /PICK UP OPTION WORD(/S)
        CDF
        AND     (40     /AND OFF BIT OF INTEREST
        DCA     TYPIT
        TAD     TYPIT
        SZA CLA
        JMS     SYSRD   /READ IN SYSTEM OVERLAY IF OPTION IS SET
        TAD     FILES   /SET UP LOOP INDEX
        CIA
        DCA     INDX
        DCA     FILNUM  /CLEAR FILE INDICATOR
LOOP3,  TAD     PASSES  /FILE NUMBER = PASSES *10 + FILNUM + 1
        RTL CLL
        TAD     PASSES
        RAL CLL
        TAD     FILNUM
        IAC
        DCA     RECIN+1 /STORE IN OUTPUT WORD
        TAD     FILNUM
        RTL CLL         /GET RECORD COUNT
        TAD     FILNUM
        TAD     (RECSTR+3
        DCA     TEMP    /STORE TEMPORARILY
        TAD I   TEMP    /PICKUP VALUE LOWEST BITS
        DCA     CLEFT   /STORE IN A SAFE PLACE
        DCA I   TEMP    /CLEAR OUT THE WORD
        ISZ     TEMP    /BUMP TO HIGH ORDER BITS
        TAD I   TEMP    /GET HIGH ORDER BITS
        DCA     EOFLG
        DCA I   TEMP
        TAD     TYPIT   /CHECK TO SEE IF WE WANT STATISTICS
        SNA CLA
        JMP     XEND
        JMS I   (MSGA
        RECFLS
        JMS I   (NUMPNT /PRINT OUT FILE NUMBER
        TAD     CLEFT   /MOVE RECORD COUNT INTO NUMBER BUFFER
        DCA     RECIN+1
        TAD     EOFLG   /MOVE HIGH ORDER BITS
        DCA     RECIN
        JMS I   (MSGA   /TYPE OUT " = "
        EQLS
        JMS I   (NUMPNT /TYPE OUT THE COUNT
XEND,   ISZ     FILNUM
        ISZ     INDX
        JMP     LOOP3   /CONTINUE UNTIL DONE
        JMP I   RECOUT  /RETURN TO CALLER
SYSRD,  0		/SUBROUTINE TO READ DOWN SYSTEM OVERLAY
        JMS I   (7607
        400
        RENAME
        33
        HLT             /IRRECOVERABLE I-O ERROR
        JMP I   SYSRD
EQLS,   TEXT    " = "
RECFLS, TEXT    "_RECORDS READ, FILE #"
TYPIT,  0
ENTER9,	0
ENTER8,	ISZ	ERRCD
ENTER7,	ISZ	ERRCD
ENTER6,	ISZ	ERRCD
ENTER5,	ISZ	ERRCD
ENTER4,	ISZ	ERRCD
ENTER3,	ISZ	ERRCD
ENTER2,	ISZ	ERRCD
ENTER1,	ISZ	ERRCD
ENTER0,	ISZ	ERRCD
	CLA
	TAD	ERRCD
	CIA
	TAD	(ENTER0
	DCA	TYPIT	/STORE ENTRY ADDRESS
	TAD	ERRCD
	TAD	(MSGLST
	DCA	MSGB
	TAD I	MSGB	/PICKUP MESSAGE ADDRESS FROM LIST
	DCA	MSGB	/STORE IN REQUEST
	TAD	OVRLAY	/CHECK IF OVERLAY IS IN CORE
	SNA CLA
	JMS	SYSRD	/READ IN OVERLAY
	JMS I	(MSGA
MSGB,	0
	TAD I	TYPIT	/GET ADDRESS OF ERROR
	JMS I	(OCTLIO	/TYPE IT OUT
	CDF CIF
	JMP I	ERROR	/EXIT TO ERROR ROUTINE
	*1200
INTMED,	ZBLOCK 200	/STORAGE SPACE FOR NEW INTERMEDIATE DIRECTORY
	DIROUT=15	/DIRECTORY OUTPUT POINTER AUTO-INDX
	*1400
COMPAR,	0
	TAD	SRTKEY	/STORE LOOP INDEX
	DCA	LPTR
	TAD	CDF2	/PICKUP RECORD BUFFER FIELD CDFS
	DCA	CDFA	/STORE IN COMPARISON ROUTINES
	TAD	CDF1
	DCA	CDFB
LOOPT,	TAD	LPTR	/COMPUTE SORT SPECIFICATION ADDRESS
	RAL CLL
	TAD	KYPTR
	JMS	COMPA1	/COMPARE THE TWO RECORDS ON THIS KEY
	SNA
	JMP	LOOPE	/RECORDS COMPARE EQUAL
	SPA CLA
	JMP I	COMPAR	/RECORD IN ADDR1 STILL EXTREME
STOR1,	TAD	CDF2	/RECORD AT ADDR2 COMES FIRST, REVERSE PTRS
	DCA	CDF1
	TAD	FILNUM	/SAVE FILE IDENTIFIER FOR NEXT READ REQUEST
	DCA	FILE1
	TAD	ADDR2	/CHANGE <ADDR1;LEN1> WITH <ADDR2;LEN2>
	DCA	ADDR1
	TAD	LEN2
	DCA	LEN1
	JMP I	COMPAR
LOOPE,	ISZ	LPTR	/MOVE TO NEXT KEY
	JMP	LOOPT
	JMP I	COMPAR
COMPA1,	0		/SUBROUTINE TO COMPARE 1 KEY AT A TIME
	DCA	SRTCH	/SAVE ADDRESS OF SORT SPECIFICATION
	TAD I	SRTCH
	DCA	P1	/STORE FIRST WORD
	TAD	P1	/AND OFF LENGTH OF KEY
	AND	(3777
	CIA
	DCA	INDA
	ISZ	SRTCH	/BUMP PTR TO NEXT WORD
	CLA CMA
	TAD I	SRTCH	/GET CHARACTER NUMBER
	DCA	SRTCH
LPAR,	JMS	SHORT	/CHECK FOR SHORT RECORDS
	TAD	ADDR1	/COMPUTE CHARACTER ADDRESS OF NEXT COMPARE
	TAD	SRTCH
	DCA	CHAR1
	TAD	ADDR2
	TAD	SRTCH
	DCA	CHAR2
CDFA,	CDF
	TAD I	CHAR2
	CIA
CDFB,	CDF
	TAD I	CHAR1
	CDF		/DATA FIELD BACK TO LOCAL
	SZA
	JMP	NOEQL	/CHARACTERS ARE NOT EQUAL
	ISZ	SRTCH	/CHARACTERS ARE EQUAL, MOVE TO NEXT IN STRING
	ISZ	INDA	/CHECK FOR ALL DONE WITH KEY
	JMP	LPAR	/NOT YET
	JMP I	COMPA1	/DONE AND STRINGS ARE EQUAL
NOEQL,	SPA CLA
	CLA CMA CLL RAL
	IAC		/AC = +1 IF KEY AT ADDR1+SRTCH > KEY AT ADDR2+SRTCH
/AC= -1 IF KEY AT ADDR1+SRTCH < KEY AT ADDR2+SRTCH
	DCA	INDA	/TEMP STORE
	TAD	P1	/CHECK ASCENDING/DESCENDING BIT
	CLL RAL
	CLA
	TAD	INDA	/PICKUP ARG AGAIN
	SZL		/COMPLEMENT IF LINK SET
	CIA
	JMP I	COMPA1	/NOT EQUAL EXIT
P1,	0
CHAR1,	0
CHAR2,	0
INDA,	0
SRTCH,	0
SHORT,	0		/SUBROUTINE TO CHECK FOR SHORT RECORDS
	CLA STL
	TAD	LEN1
	SNA
	JMP	.+3
	TAD	SRTCH	/CHECK FOR LEN2 < THIS CHARACTER #
	SNL CLA
	IAC
	DCA	SHRT1	/SET IF RECORD IS SHORT
	CLA STL
	TAD	LEN2
	SNA
	JMP	.+3
	TAD	SRTCH	/CHECK THIS RECORD FOR SHORT
	SNL CLA
	IAC
	DCA	SHRT2
	TAD	SHRT1
	SNA CLA
	JMP	FALSE	/NOT SET
	TAD	SHRT2	/RECORD 1 IS TOO SHORT, CHECK RECORD 2
	SZA CLA
	JMP I	COMPA1	/BOTH TOO SHORT, EXIT COMPARISON AS EQUAL
	CMA
	JMP	NOEQL	/RECORD 1 TOO SHORT, BUT RECORD 2 OKAY
FALSE,	TAD	SHRT2
	SNA
	JMP I	SHORT	/BOTH RECORDS LONG ENOUGH
	JMP	NOEQL	/RECORD 1 LONG ENOUGH, BUT RECORD 2 TOO SHORT
SHRT1,	0
SHRT2,	0
LPTR,	0
	*1600
/
/SUBROUTINE TO READ RECORDS FROM FILE AND RETURN TO RECORD BUFFER
/
READBF,	0
	JMS I	GETPTR	/GET FILE POINTERS FROM BUFFER
	JMS	CCHCK	/CHECK FOR ^C
	TAD	EOFLG	/CHECK FOR EOF READ ON THIS FILE
	SZA CLA
	JMP I	READBF
	DCA	LENGTH	/CLEAR RECORD LENGTH INDICATOR
	TAD	UNBLOC
	DCA I	(PICKA	/STORE UNBLOCKING ADDRESS IN UNPACK ROUTINE
NEXTCH,	CLA CMA		/AND AWAY WE GO
	DCA	JMPFLG	/SET JMP FLAG
	TAD	CLEFT	/CHECK NUMBER OF CHARACTERS LEFT IN BUFFER
	SZA CLA
	JMP	OKAY	/EVERYTHING IS HONKY-DORY UNPACK THE RECORD
	TAD	BLEFT	/CHECK REMAINING FILE LENGTH
	SNA CLA
	JMP	EOFRD	/ZERO LENGTH REMAINING, EOF
	TAD	DEVCDE	/CHECK IF DEVICE HANDLER IS IN CORE
	TAD	(DEVTAB-1
	DCA	KCHR	/STORE ADDRESS IN TABLE
	TAD I	KCHR	/PICKUP VALUE
	SZA
	JMP	INCORE	/MUST BE IN CORE
	CIF	10	/TOUGH LUCK, MUST DO A BUNCH OF USR WORK
	JMS I	(USRIN	/GO GET IT
	10
	TAD	DEVCDE	/CHECK FOR ALREADY IN CORE
	CIF	10
	JMS I	USR
	12
LOCATN,	0
	ERRHLT		/"NO DEVICE"
	TAD	LOCATN	/CHECK FOR IN CORE
	SZA CLA
	JMP	USROUT	/ALREADY RESIDENT, CAN PROCEED
	CIF	10
	JMS I	USR
	13		/DO A RESET RETAINING TENTATIVE FILES
	0
	TAD	INPHNL	/GET INPUT HANDLER PAGES
	DCA	ARG1	/STORE IN FETCH
	TAD	DEVCDE	/FETCH BY NUMBER
	CIF	10
	JMS I	USR
	1
ARG1,	0
	ERRHLT		/"NO DEVICE"
	TAD	ARG1
	DCA	LOCATN	/STORE POINTER TO HANDLER
USROUT,	CIF	10	/RESTORE USR AREA
	JMS I	USR
	11
	SKP		/JUMP OVER IN CORE CASE
INCORE,	DCA	LOCATN
	TAD	STBUF	/SET UP READ REQUEST
	DCA	REQRD+2
	TAD	BLKNO
	DCA	REQRD+3
REQRD,	JMS I	LOCATN	/GO TO DEVICE HANDLER
	210		/ALL INPUT BUFFERS RESIDE IN FLD 1
KCHR,	ZBLOCK 2
	SNA CLA		/ZERO RETURNS ARE OKAY BY ME
	SKP
	ERRHLT+4	/"I-O ERROR ON INPUT FILE"
	ISZ	BLKNO	/BUMP BLOCK NUMBER
	ISZ	BLEFT	/AND REMAINING LENGTH
M600,	CLA		/WITH NO PROBLEM ON SKIP
	TAD	M600	/SET UP REMAINING CHARACTER COUNT
	DCA	CLEFT
	TAD	(PICK1
	DCA I	(PICKA	/FIX UP UNBLOCKING ROUTINE
	TAD	STBUF	/AND UNPACKING ADDRESS
	DCA	PICKAX
OKAY,	JMS I	(PICK	/GET A CHARACTER
	ISZ	CLEFT	/BUMP  CHARACTER COUNT
MRUB,	7401		/A NOP ALSO -RUBOUT
	ISZ	JMPFLG
	JMP I	(CHKZER	/CHECK FOR A RUBOUT
	DCA	KCHR	/STORE NEXT CHARACTER
	TAD	KCHR	/GET IT BACK
	TAD	(-232	/CHECK FOR ^Z
	SNA
	JMP	EOFRD	/YES, DO EOF THING
	TAD	(232-215	/CHECK FOR A CR
	SNA
	JMP	EOL	/YES, DO END OF LINE ROUTINE
	TAD	(215-211	/CHECK FOR A TAB
	SNA
	JMP I	(TAB	/EXPAND OUT TABS
	TAD	(211-240	/CHECK FOR ANOTHER CONTROL CHARACTER
	SPA CLA
	JMP	NEXTCH	/YES, IGNORE ALL OTHER CONTROLS
	TAD	CMPRS	/CHECK FOR A RUBOUT IF IN /C MODE
	SZA CLA
	TAD	MRUB
	TAD	KCHR
	SNA CLA
	JMP	NEXTCH+1	/THIS CHARACTER IS A RUBOUT, TRAP EXPANSION COUNT
PUTCHR,	TAD	KCHR	/PUT CHARACTER IN BUFFER
	JMS I	(PUTCH
	JMP	NEXTCH
EOFRD,	ISZ	EOFLG	/EOF READ, SET FLAG
	TAD I	(PICKA	/STORE PICK ADDRESS IN POINTER LIST
	DCA	UNBLOC
	JMS I	STRPTR	/STORE IN FILE TABLE LIST
	JMP I	READBF	/EXIT TO CALLER
EOL,	ISZ	READBF	/BUMP RETURN TO NORMAL
	TAD	LENGTH	/STORE RECORD LENGTH IN RECORD POINTER LIST
	CIA
	JMS I	(SETREC
	JMP	EOFRD+1	/GO TO EXIT ROUTINE
JMPFLG,	0
	*2000
RWDIR,	0
	TAD	K200	/ADD IN TO WRITE 1 BLOCK
	DCA	FUN	/STORE AS FUNCTION CODE
	TAD	DIRBLK	/GET DIRECTORY STARTING BLOCK
	TAD	DIRSEG	/ADD ON DIRECTORY SEGMENT
	DCA	FUN+2	/STORE AS BLOCK NUMBER
	TAD	DIRBUF	/PUT BUFFER ADDRESS IN REQUEST
	DCA	FUN+1
	JMS I	DSKENT	/READ-WRITE DIRECTORY BLOCK
FUN,	ZBLOCK 3
	ERRHLT+3	/"I-O ERROR ON DSK:"
	JMP I	RWDIR	/ALL SYSTEMS GO
TAB,	TAD	P240	/EXPAND OUT TABS
	JMS	PUTCH
	TAD	LENGTH	/CHECK FOR LENGTH A MULTIPLE OF 8
	RAR CLL
	SNL
	RAR
	SNL
	RAR
	SZL CLA
	JMP	TAB
	JMP I	(NEXTCH	/MULTIPLE OF 8, GET NEXT CHARACTER
CHKZER,	SNA
	JMP I	(PUTCHR	/RUBOUT,0 MEANS AN ACTUAL RUBOUT
	CIA		/COMPLEMENT COUNT
	DCA	RWDIR	/STORE IN A SAVE PLACE
	TAD	P240
	JMS	PUTCH
	ISZ	RWDIR	/LOOP TILL DONE
	JMP	.-3
	JMP I	(NEXTCH	/GO TO NEXT CHARACTER
PUTCH,	0
	DCA	LCHAR	/STORE CHARACTER TEMPORARILY
	TAD	FILNUM	/COMPUTE RECORD POINTERS
	RTL CLL
	TAD	FILNUM
	TAD	(RECSTR-1	/ADD IN OFFSET
	DCA	X13
	TAD I	X13	/PICKUP CDF RECORD BUFFER FIELD
	DCA	RECDF	/STORE IN LINE
	TAD	LENGTH	/COMPUTE ADDRESS FOR STORING CHARACTER
	TAD I	X13	/PICK UP ADDRESS OF RECORD BUFFER
	DCA	ADDR
	TAD	LCHAR	/GET THE CHARACTER BACK AGAIN
RECDF,	0
	DCA I	ADDR	/STORE IN RECORD BUFFER
	CDF
	ISZ	LENGTH	/BUMP LENGTH
	TAD	LENGTH	/CHECK FOR RECORD OVERFLOW
	TAD	(-400	/RECORD SIZE LIMIT IS 400 OCTAL CHARACTERS
	SNA CLA
	ERRHLT+5
	JMP I	PUTCH	/EXIT
	X13=13
ADDR,	0
LCHAR,	0
SETREC,	0
	DCA	LCHAR	/STORE THE LENGTH TEMPORARILY
	TAD	FILNUM	/MULTIPLY BY 5
	RTL CLL
	TAD	FILNUM
	TAD	(RECSTR+1	/ADD OFFSET FOR LENGTH WORD
	DCA	X13
	TAD	LCHAR	/STORE RECORD LENGTH
	DCA I	X13
	ISZ I	X13	/BUMP LOWER RECORD COUNT
	SKP CLA
	ISZ I	X13	/BUMP IF OVERFLOW
	JMP I	SETREC	/RETURN TO CALLER
K600,	-600
INITAL,	0
	TAD	K600	/SET UP WRITE CHARACTER COUNT
	DCA	WRTCNT
	TAD	OUTBUF	/SET UP BUFFER ADDRESS
	DCA	ADDROT
	TAD	(PACK1	/SET PACKING ADDRESS
	DCA I	(PACKA
	JMP I	INITAL	/RETURN
/
/SUBROUTINE TO PACK OUTPUT 1 CHARACTER AT A TIME
/
PACKC,	0
	JMS I	(PACK	/PACK CHARACTER IN BUFFER
	ISZ	WRTCNT	/CHECK FOR FULL BUFFER
	JMP I	PACKC	/BUFFER NOT FULL, RETURN
	TAD	WLENG	/CHECK FOR OVERFLOW
	SNA CLA
	ERRHLT+11	/"NO ROON FOR OUTPUT FILE"
	TAD	OUTBUF	/STORE OUTPUT BUFFER ADDRESS IN WRITE COMMAND
	DCA	BLOC-1
	TAD	WRTBLK	/AND WRITE BLOCK NUMBER
	DCA	BLOC
	JMS I	WRTENT	/WRITE THE BLOCK
	4200
	0
BLOC,	0
	ERRHLT+10	/"WRITE ERROR"
	ISZ	WRTBLK
	ISZ	WRTEN
	ISZ	FLENGT
	ISZ	WLENG	/CHECK FOR FILE OVERFLOW
K177,	177		/A GOOD NOP
	JMS	INITAL	/REINITIALIZE POINTERS
	JMP I	PACKC	/EXIT
INTNAM,	FILENAME SRTINT.AB
RETURN,	0
	DCA	INITAL	/STORE CHARACTER
	TAD	CMPRS	/CHECK FOR /C MODE SET
	SZA CLA
	JMP	EXIT	/SET, RETURN WITH AC ON CALL
	TAD	INITAL	/NOT SET, MASK OFF CHARACTER
	AND	K177
	TAD	K200	/SET PARITY BIT
	SKP
EXIT,	TAD	INITAL	/GET BACK AC
	JMP I	RETURN	/RETURN TO SENDER
	*2200
/
/ODDS AND ENDS OF NECESSARY CORE-RESIDENT CODE
/
/
/ROUTINES TO GET AND STORE FILE POINTERS
/
STRFLS,	0
	JMS	SETUP	/SET UP AUTO-INDX AND LOOP INDX
	TAD I	X10
	DCA I	X11
	ISZ	PICK	/MOVE PAGE 0 BUFFER TO FILE LOCATIONS
	JMP	.-3	/CONTINUE UNTIL DONE WITH BUFFER
	JMP I	STRFLS	/EXIT
GETFLS,	0
	JMS	SETUP	/SET UP TO COPY FROM FILE BUFFER TO PAGE 0
	TAD I	X11
	DCA I	X10
	ISZ	PICK
	JMP	.-3
	JMP I	GETFLS
SETUP,	0
	TAD	NFILE
	DCA	X10
	TAD	FILNUM
	RTL CLL	/MULTIPLY BY 9 WORDS/FILE
	RAL
	TAD	FILNUM
	TAD	KSTOR	/ADD IN STORAGE ADDRESS - 1
	DCA	X11
	TAD	MN11	/SET UP INDEX TO -9
	DCA	PICK	/A GOOD PLACE TO STORE IT
	JMP I	SETUP	/SET-UP COMPLETE, EXIT
PICK,   0
        CDF	10
        JMP I   PICKA
PICKA,  PICK1
	AND	K377	/MASK OFF CHARACTER
	JMS I	RETRN1	/CHECK FOR FURTHER MASK REQUIRED
	CDF
        JMP I   PICK
PICK1,  TAD I   PICKAX
        AND     P7400
        DCA     TEMP
        TAD I   PICKAX
        ISZ     PICKAX
        JMS     PICKA
        TAD I   PICKAX
        AND     P7400
        RTR CLL
        RTR
        TAD     TEMP
        RTR CLL
        RTR
        DCA     TEMP
        TAD I   PICKAX
        ISZ     PICKAX
        JMS     PICKA
        TAD     TEMP
        JMS     PICKA
        JMP     PICK1
PACK,   0
	AND	K377	/AND OFF THE CHARACTER
	CDF
        JMP I  PACKA
PACKA,  PACK1
        JMP I  PACK
PACK1,  DCA I  ADDROT
        JMS    PACKA
        DCA    CHAR
        JMS    PACKA
        RTL CLL
        RTL
        DCA    PACKA
        TAD    PACKA
        AND    P7400
        TAD I  ADDROT
        DCA I  ADDROT
        ISZ    ADDROT
        TAD    PACKA
        RTL CLL
        RTL
        AND    P7400
        TAD    CHAR
        DCA I  ADDROT
        ISZ    ADDROT
        JMS    PACKA
        JMP    PACK1
CHAR,   0
KSTOR,	FILSTR-1
RETRN1,	RETURN
	*2325
DEVTAB,	ZBLOCK 17	/STORAGE FOR DEVICE RESIDENT TABLE
KEYSTR,	ZBLOCK 20	/STORAGE AREA FOR SORT KEYS
RECSTR,	ZBLOCK 12^5	/POINTER STORAGE AREA FOR RECORDS
FILSTR,	ZBLOCK 12^11	/POINTER STORAGE AREA FOR FILES
	ENTAB=.
	*5600
/
/MERGE INITIALIZATION PROCEDURE (LATER OVERLAID BY BUFFERS)
/
BEGIN,	CLA IAC		/AC=1 IF PROGRAM STARTED BY A ".R MRGV2"
	JMS I	(NOSTRT	/FIX UP JOB STATUS WORD
	CIF	10
	JMS I	(USRIN	/READ IN USR
	10
	CIF	10
	JMS I	USR	/RESET SYSTEM TABLES BEFORE STARTING
	13
	JMS	ALLOC	/FETCH DSK: HANDLER
	DEVICE DSK
	DCA	DSKENT
	TAD	N1+1	/GET DEVICE NUMBER
	DCA	DSKNUM	/SAVE AS DSKNUM
	TAD	DSKNUM
	JMS I	(LOOKUP	/LOOKUP SORT DIRECTORY
	DIRNAM
	TAD I	(STBLK1	/GET BLOCK FOR POSTERITY
	DCA	DIRBLK
	DCA	DIRSEG	/CLEAR DIRECTORY SEGMENT POINTER
	JMS	GET400	/GET 2 PAGE BUFFER
	DCA	DIRBUF
	JMS I	(RWDIR	/READ FIRST DIRECTORY SEGMENT TO DIRBUF
	CLA CMA
	TAD	DIRBUF	/SET UP TO BUILD TABLES
	DCA	DIRPTR	/USING AUTO-INDEX
	TAD I	DIRPTR
	DCA	SRTKEY	/STORE NUMBER OF KEYS
	TAD	(KEYSTR-1
	DCA	LSTPTR
	TAD	(-20
	DCA	INDX
	TAD I	DIRPTR	/MOVE KEYS FROM DIRECTORY TO BUFFER
	DCA I	LSTPTR
	ISZ	INDX
	JMP	.-3	/UNTIL DONE
	ISZ	DIRPTR	/JUMP OVER DEVICE TYPE
	TAD I	DIRPTR	/PICK UP DEVICE NAME
	DCA	CALL2+1
	TAD I	DIRPTR
	DCA	CALL2+2
	CLA IAC
	TAD	DIRPTR	/STORE POINTER TO FILE NAME IN DIRECTORY BLOCK
	DCA	OUTNAM
	CLA CLL IAC RTL	/JUMP OVER OUTPUT FILE NAME TO INPUT SPECS
	TAD	DIRPTR
	DCA	DIRPTR
	TAD	SRTKEY	/COMPUTE CONSTANT TO LAST OF KEYS
	CIA CLL RAL
	TAD	(KEYSTR
	DCA	KYPTR	/STORE IT FOR FUTURE USE
	TAD	(INTMED-1
	DCA	DIROUT
CALL2,	JMS	ALLOC	/ALLOCATE OUTPUT DEVICE HANDLER
	ZBLOCK 2
	DCA	OUTENT	/STORE ENTRY VALUE
	TAD	N1+1
	DCA	OUTNUM	/AND DEVICE NUMBER
	JMS I	(BATFIX	/FIX UP I-O AND ABORT ROUTINES IF BATCH IS RUNNING
	DCA	PASSES	/CLEAR NUMBER OF PASSES
	JMS	GET400	/GET 2 PAGES FOR INPUT FILE HANDLER AREA
	IAC
	DCA	INPHNL
	JMS	GET400	/AND OUTPUT FIELD
	DCA	OUTBUF
	STL RAR CLA
	CDF	10	/AND OFF /A OPTION BIT
	AND I	(7643
	CDF
	SZA CLA
	JMS I	(ALTERM	/SET ALTERNATE TERMINAL I/O
	JMP I	(BUILDT	/GO BUILD REMAINING SYSTEM TABLES
ALLOC,	0
	TAD I	ALLOC	/GET DEVICE NAME
	ISZ	ALLOC
	DCA	N1
	TAD I	ALLOC
	ISZ	ALLOC
	DCA	N1+1
	CIF	10
	JMS I	USR
	12
N1,	ZBLOCK 2
LOC1,	0
	ERRHLT
	TAD	LOC1	/GET ENTRY
	SZA		/CHECK IF ALREADY IN CORE
	JMP I	ALLOC	/ALREADY IN CORE, EXIT
FETCH,	JMS	GETPAG	/GET 1 PAGE
	DCA	LOC3
	TAD	N1+1
	CIF	10
	JMS I	USR	/TRY TO ALLOCATE ONLY 1-PAGE
	1		/A FETCH
LOC3,	0
	JMP	TWOPAG	/FAILURE, WE MUST NEED TWO PAGES
	TAD	LOC3	/SUCESS, EXIT WITH ENTRY IN AC
	JMP I	ALLOC
TWOPAG,	JMS	GETPAG	/GET 1 MORE PAGE
	IAC		/SET TWO-PAGE BIT
	JMP	FETCH+1	/GO DO FETCH
GETPAG,	0
	TAD	NLOC
	TAD	MN200	/SUBTRACT 200
	DCA	NLOC	/STORE AS NEW NLOC
	TAD	NLOC	/GET VALUE
	JMP I	GETPAG
NLOC,	CLA I
GET400,	0
	JMS	GETPAG
MN200,	CLA I
	JMS	GETPAG
	JMP I	GET400
	PAGE
/
/FIX UP ABORT AND TYPE OUT ROUTINES IF BATCH IS IN CORE
/
BATFIX,	0
	STL RTR CLA	/AC=2000
	AND I	M1
	SNA CLA
	JMP I	BATFIX	/NO CHANGES NECESSARY
	TAD I	M1
	AND	(70	/GET BATCH FIELD
	TAD	(CIF
	DCA I	(FLDCH1
	TAD I	(FLDCH1
	IAC		/CHANGE TO CDF CIF BATCH FIELD
	DCA I	(FLDCH2
	TAD	(BATYP	/CHANGE TYPE OUT ROUTINES
	DCA	TYPE
	TAD	(FLDCH2	/AND ABORT ROUTINES
	DCA	ERROR
	JMP I	BATFIX	/EXIT
/
/ROUTINES TO INITIALLY BUILD FILE TABLES
/
BUILDT,	TAD	(-5
	DCA	INDX
B1LP,	TAD	(CDF	/BUILD RECORD LIST
	DCA I	LSTPTR
	JMS I	(GET400
	DCA I	LSTPTR	/STORE RECORD BUFFER
	DCA I	LSTPTR	/AND RECORD LENGTH
	DCA I	LSTPTR	/AND RECORD COUNT
	DCA I	LSTPTR
	ISZ	INDX	/UNTIL DONE
	JMP	B1LP
	TAD	K200
	DCA	BUFSTA	/SET UP FIELD 1 BUFFERS
	TAD	(-5
	DCA	INDX
B2LP,	TAD	(CDF 10
	DCA I	LSTPTR
	TAD	BUFSTA
	DCA I	LSTPTR
	TAD	BUFSTA
	TAD	(400
	DCA	BUFSTA
	DCA I	LSTPTR
	DCA I	LSTPTR
	DCA I	LSTPTR
	ISZ	INDX
	JMP	B2LP
	TAD	(-12
	DCA	INDX	/SET UP FOR FILE INFO
	DCA	FILNUM	/CLEAR FILE NUMBER POINTER
	DCA	EOFLG	/CLEAR E-O-F FLAG
	DCA	CLEFT	/CLR CHARACTER LEFT COUNT
B3LP,	TAD	BUFSTA
	DCA	STBUF	/SET STARTING BUFFER LOCATION
	JMS I	STRPTR	/STORE IT IN FILSTR
	TAD	BUFSTA
	TAD	(400
	DCA	BUFSTA
	ISZ	FILNUM
	ISZ	INDX
	JMP	B3LP
	TAD	(-17
	DCA	INDX
	TAD	(DEVTAB-1
	DCA	X10	/COPY DEVICE RESIDENCY TABLE TO PROGRAM
	TAD	(7646
	DCA	X11
CPYTB,	CDF	10
	TAD I	X11
	CDF
	DCA I	X10
	ISZ	INDX
	JMP	CPYTB
	JMS I	(7607	/WRITE I/O OVERLAY TO SYSTEM SCRATCH
	4400
	RENAME
	33		/AT BLOCK 33
	ERRHLT+2	/SYS ERROR
	DCA	OVRLAY	/CLEAR OVERLAY FLAG
	CDF	10	/CHECK FOR /C OPTION
	TAD I	(7643
	CDF
	AND	(1000	/AND OFF BIT OF INTEREST
	DCA	CMPRS	/STORE ON PAGE 0
	JMP I	K200
	USRIN=7700
	X10=10
	X11=11
	DIRPTR=17
	LSTPTR=16
BUFSTA,	0
NOSTRT,	0
	DCA	BATFIX	/STORE AC ON ENTRY
	CDF
	TAD I	(7746	/SET BIT 2 OF JOB STATUS WORD SO NO ".ST" COMMANDS
	CMA
	AND	(6777	/WILL WORK
	CMA
	DCA I	(7746
	TAD	BATFIX	/CHECK AC ON ENTRY
	SNA CLA
	JMP I	NOSTRT	/GO BACK
	CIF	10	/PROGRAM STARTED WITH A ".R MRGV2", GET CD FOR OPTIONS
	JMS I	(USRIN
	10
	CIF	10
	JMS I	USR	/GET CD
	5
	0
	JMP I	NOSTRT	/RETURN TO CALLER
	*2600
/
/SUBROUTINE TO CHANGE EXTENSION ON FILE TO "AA"
/ASSUMES LOOKUP HAS ALREADY BEEN PERFORMED ON THE FILE
/
RENAME,	0
	CLA CMA	/AC=-1
	CDF	10
	TAD I	(1404	/PICKUP MINUS THE NUMBER OF ADDITIONAL INFO WORDS
	TAD I	K17	/GET PTR TO EXTENSION
	DCA	PTR
	TAD	AA	/GET NEW EXTENSION
	DCA I	PTR
	TAD I	K7
	AND	K7	/GET DIRECTORY BLOCK NUMBER
	DCA	SEGNO
	TAD I	K51	/GET DEVICE ENTRY PT
	DCA	PTR
	CDF
	JMS I	PTR	/GO WRITE DIRECTORY SEGMENT
	4210
	1400		/ADDRESS OF DIRECTORY BLOCK IN USR
SEGNO,	0
	SKP CLA
	JMP I	RENAME	/EXIT
	CIF	10
	JMS I	USR	/ERROR ON WRITE
K7,	7
	2
PTR,	0
K51,	51
AA,	TEXT	"AA"
	*.-1		/STRIP OFF TRAILING ZEROS
/
/ROUTINE TO LOOKUP FILE
/POINTER TO FILENAME IS  PARAMETER
/DEVICE NUMBER IS PASSED IN AC
/
LOOKUP,	0
	DCA	PTR
	TAD I	LOOKUP
	DCA	STBLK1
	TAD	PTR
	CIF	10
	JMS I	USR
	2
STBLK1,	0
	0
	ERRHLT+1
	ISZ	LOOKUP	/BUMP OVER FILE NAME
	JMP I	LOOKUP
BATERR,
TYPEA,	7000		/ADDRESS OF BATCH ERROR IN HIGHEST FLD OR TYPE ROUTINE
	TLS
	TSF		/TYPE THE CHARACTER
	JMP	.-1	/WAIT TILL DONE
	CLA		/EXIT WITH CLEAN AC
BATYP,	JMP I	TYPEA	/ENTRY OF BATCH TYPE OUT OR EXIT OF TYPE ROUTINE
	CDF
FLDCH1,	CIF		/CHANGED TO CIF BATCH FIELD IN INITIALIZATION
	JMS I	BATOUT	/7400 OF BATCH FIELD
	CLA
	JMP I	BATYP
FLDCH2,	CDF CIF		/BATCH ABORT ROUTINE
	JMP I	BATERR	/7000 OF BATCH FIELD
/
/SUBROUTINE TO WRITE OUT AN OCTAL NUMBER ON THE OUTPUT DEVICE
/AC ON CALL = NUMBER TO TYPE OUT
/
OCTLIO, 0
        DCA     RENAME	/STORE NUMBER
        TAD     (-4     /LOOP INDEX
        DCA     LOOKUP
LPOCTO, TAD     RENAME
        RTL CLL
        RAL             /ROTATE AC DOWN
        DCA     RENAME
        TAD     RENAME
        RAL
        AND     (7
        TAD     (260
        JMS I   TYPE    /TYPE OUT THE DIGIT
        ISZ     LOOKUP	/CHECK FOR DONE
        JMP     LPOCTO
        JMP I   OCTLIO
WRITN,	TEXT	"_OUTPUT RECORDS WRITTEN = "
DIRNAM,	FILENAME SRTINT.DI
ALTERM,	0
	TAD	ALTCDE	/GET ALTERNATE TERMINAL DEVICE CODES
	AND	(77	/THIS TIME ONLY CONCERNED WITH OUTPUT CODE
	RTL CLL
	RAL		/MOVE UP 1 DIGIT
	DCA	OCTLIO	/STORE IN A SAFE PLACE
	TAD	TYPEA+1	/REPLACE OLD TTY COMMAND
	AND	(7007
	TAD	OCTLIO
	DCA	TYPEA+1
	TAD	TYPEA+2
	AND	(7007
	TAD	OCTLIO
	DCA	TYPEA+2
	JMP I	ALTERM
        PAGE
/
/SUBROUTINE TO PRINT OUT A DECIMAL NUMBER
/
NUMPNT, 0
        TAD     (-10    /NUMBER CAN BE 8 DECIMAL DIGITS LONG
        DCA     INDX2
        JMP     DVD     /MAKE SURE THAT WE PRINT AT LEAST 1 ZERO FOR A ZERO
NLP,    TAD     RECIN+1 /CHECK FOR A ZERO NUMBER
        SZA CLA
        JMP     DVD     /NON-ZERO DO NEXT DIVISION
        TAD     RECIN   /LOWER BITS ARE ZERO, CHECK HIGHER ORDER ONES
        SNA CLA
        JMP     XIT     /ALL ZERO, DISCONTINUE OPERATION
DVD,    JMS     DIVIDE  /DIVIDE NUMBER BY 10
        RECIN           /ADDRESS OF DIVIDEND
        -12             /DIVISOR
        TAD     QUO+1   /SUBSTITUTE QUOTIENT FOR DIVIDEND
        DCA     RECIN+1
        TAD     QUO
        DCA     RECIN
        TAD     INDX2   /COMPUTE LOCATION FOR STORING THIS DIGIT
        CIA
        TAD     (TYPSTR-1
        DCA     DIV1
        TAD     REM     /CALCULATE NEXT DIGIT FROM REMAINDER
        TAD     (260    /ADD IN ASCII OFFSET
        DCA I   DIV1    /STORE IN BUFFER
        ISZ     INDX2   /INCREMENT COUNT
        JMP     NLP     /CONTINUE OPERATION
XIT,    TAD     INDX2   /ALL DONE WITH DIVISIONS, NOW PRINT BUFFER
        CIA
        TAD     (-10    /CALCULATE NUMBER OF DIGITS TO PRINT
        DCA     INDX2
TYPOUT, TAD I   DIV1    /PICK UP DIGIT
        ISZ     DIV1    /BUMP POINTER TO NEXT
        JMS I   TYPE    /PRINT THE DIGIT
        ISZ     INDX2   /CHECK FOR ALL DONE
        JMP     TYPOUT  /NOT YET
        JMP I   NUMPNT  /ALL DONE
QUO,    ZBLOCK 2
DIVDND, 0
DIV1,   0
REM,    0
INDX1,  0
INDX2,  0
TYPSTR, ZBLOCK  10      /DIGITS BUFFER
/
/SUBROUTINE TO DIVIDE A DOUBLE PRECISION ARGUMENT BY A SINGLE PRECISION ONE
/ CALLING SEQUENCE:
/       JMS I   (DIVIDE
/       (ADDRESS OF DIVIDEND - DOUBLE PRECISION)
/       (MINUS THE DIVISOR)
/
/       RETURNS QUOTIENT IN <QUO;QUO+1> AND REMAINDER IN REM
/
DIVIDE, 0
        TAD I   DIVIDE  /PICKUP ADDRESS OF DIVIDEND
        DCA     DIV1
        TAD I   DIV1
        DCA     DIVDND  /PICK UP VALUE
        ISZ     DIV1    /IT IS A DOUBLE WORD VALUE
        TAD I   DIV1
        DCA     DIV1
        ISZ     DIVIDE  /BUMP TO NEXT PARAMETER
        DCA     QUO
        DCA     QUO+1   /CLEAR TEMP CELLS
        DCA     REM
        TAD     (-30    /SET NUMBER OF BITS TO DO
        DCA     INDX1
LOOPX,  TAD     DIV1    /START SHIFTING UPWARD
        RAL CLL
        DCA     DIV1
        TAD     DIVDND
        RAL
        DCA     DIVDND
        TAD     REM
        RAL
        DCA     REM
        TAD     REM
        TAD I   DIVIDE  /CHECK REMAINDER VERSUS DIVISOR
        SMA
        DCA     REM
        CLA             /CLEAR JUNK
        TAD     QUO+1   /ROTATE BIT TO QUOTIENT
        RAL
        DCA     QUO+1
        TAD     QUO
        RAL
        DCA     QUO
        ISZ     INDX1   /CHECK FOR ALL DONE
        JMP     LOOPX   /NOT YET
        ISZ     DIVIDE  /ADJUST RETURN
        JMP I   DIVIDE  /EXIT
/
/ MESSAGE SUBROUTINE FOR PDP-8
/
/CALLING SEQUENCE:
/       JMS I  (MSGA
/       (ADDR OF MESSAGE)
/
MSGA,   0
        TAD I  MSGA
        ISZ    MSGA
        DCA    XX
LPAX,   TAD I  XX
        BSW
        JMS    TYPECH
        TAD I  XX
        JMS    TYPECH
        ISZ    XX
        JMP    LPAX
XX,     0
TYPECH, 0
        AND    (77
        SNA
        JMP I  MSGA
        TAD    (-37
        SNA
        JMP    CRLF
        SPA
        TAD    (100
        TAD    (237
RJN3,   JMS I  TYPE
        JMP I  TYPECH
CRLF,   TAD    (215
        JMS I  TYPE
        TAD    (212
        JMP    RJN3
        PAGE
ERR0,	TEXT	"_NO DEVICE FOUND AT "
ERR1,	TEXT	"_LOOKUP ERROR AT "
ERR2,	TEXT	"_SYS: I-O ERROR AT "
ERR3,	TEXT	"_DSK: I-O ERROR AT "
ERR4,	TEXT	"_INPUT FILE I-O ERROR AT "
ERR5,	TEXT	"_RECORD OVERFLOW AT "
ERR6,	TEXT	"_ENTER ERROR AT "
ERR7,	TEXT	"_CLOSE ERROR AT "
ERR10,	TEXT	"_WRITE ERROR AT "
ERR11,	TEXT	"_NO ROOM FOR OUTPUT FILE AT "
MSGLST,	ERR0;ERR1;ERR2;ERR3;ERR4;ERR5;ERR6;ERR7;ERR10;ERR11
/
/PAGE ZERO FOR MERGE
/
	*0
ALTCDE,	0304		/ALTERNATE TERMINAL DEVICE CODES 
	HLT
MN240,	-240
SPACNT,	0
M1,	-1
K377,	377
JPACK,	PACKC
P240,	240
	*20
FILINF=.
EOFLG,	0
CLEFT,	0
PICKAX,	0
TEMP,	0
UNBLOC,	0
DEVCDE,	0
STBUF,	0
BLKNO,	0
BLEFT,	0
/**********************************************************
SRTKEY,	0
FILNUM,	0
DSKENT,	0
DSKNUM,	0
OUTENT,	0
OUTNUM,	0
OUTNAM,	0
DIRBLK,	0
DIRSEG,	0
ERROR,	7600
TYPE,	TYPEA
BATOUT,
P7400,	7400
PASSES,	0
OVRLAY,	1
INPHNL,	0
OUTBUF,	0
DIRBUF,	0
INDX,	0
USR,
K200,	200
ADDROT, 0
STRPTR,	STRFLS
GETPTR,	GETFLS
RECIN,	ZBLOCK 2
KYPTR,	0
K17,
NFILE,	FILINF-1
CMPRS,	0
MN11,	-11
FILES,	0
LENGTH,	0
CDF1,	0
ADDR1,	0
LEN1,	0
CDF2,	0
ADDR2,	0
LEN2,	0
WRTBLK,	0
WRTENT,	0
WLENG,	0
WRTCNT,	0
WRTEN,	0
FILE1,	0
FLENGT,	0
DNEFLG,	0
LSTPAS,	0
	ERRHLT=JMS I	.
	ENTER0;ENTER1;ENTER2;ENTER3;ENTER4;ENTER5;ENTER6;ENTER7;ENTER8;ENTER9
ERRCD,	0
OADDR1,	0
OADDR2,	0
RECMRG,	ZBLOCK 2
AC1,	0
CCHCK,	0
	KRS		/READ CHARACTER
	TAD	M203	/CHECK FOR ^C
	SNA CLA
	KSF		/IT IS A ^C, CHECK FOR KEYBOARD FLAG
	JMP I	CCHCK	/^C NOT TYPED
	CDF CIF
	JMP I	ERROR	/ERROR EXIT ON ^C
M203,	-203
CMPRSP,	0
	DCA	CCHCK
	TAD	LSTPAS	/CHECK FOR ON LAST PASS
	SNA CLA		/YES, DON'T DO COMPRESSION
	TAD	CMPRS	/CHECK FOR /C OPTION SET
	SNA CLA
	JMP	ENDOK	/EITHER LAST PASS OR /C OPTION NOT SET
	TAD	CCHCK	/GET BACK CHARACTER
	TAD	MN240	/CHECK FOR A SPACE
	SZA CLA
	JMP	NTBLNK	/NOT A SPACE
	ISZ	SPACNT	/SPACE, BUMP COUNT
	JMP I	CMPRSP	/EXIT
NTBLNK,	TAD	SPACNT	/NOT BLANK, CHECK FOR NON-ZERO COUNT
	SNA
	JMP	ENDOK	/ZERO COUNT, JUST OUTPUT CHARACTER
	TAD	M1	/CHECK FOR ONLY 1 SPACE
	SNA CLA
	JMP	SPACOT	/ONE ONLY - JUST OUTPUT A SPACE
	TAD	K377	/OUTPUT A RUBBOUT
	JMS I	JPACK	/PACK IT IN THE BUFFER
	TAD	SPACNT	/THEN THE SPACE COUNT
	SKP
SPACOT,	TAD	P240	/OUTPUT A SPACE
	JMS I	JPACK	/PACK SPACE OR SPACE COUNT IN BUFFER
ENDOK,	DCA	SPACNT	/CLEAR SPACE COUNT
	TAD	CCHCK	/PUT CURRENT CHARACTER IN BUFFER
	JMS I	JPACK
	JMP I	CMPRSP	/RETURN



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search