File SORTV2.PA (PAL assembler source file)

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

/SORT VERSION II FOR OS/8
/
/BRYAN FREDRICK, MINNESOTA POLLUTION CONTROL AGENCY
/SEPTEMBER, 1977
/
	CLA1=7600	/GROUP 1 CLA - ALSO USED AS CONSTANT
	LISTPT=15	/AUTO INDEX PTR FOR LIST
	BUFPTR=16	/AUTO INDEX STORAGE REGISTER
	X10=10
	X11=11
	INPLEN=4032	/INPUT FILE LENGTH FROM SORTCD
	USR=200		/FOR FUTURE REFERENCES
	USRIN=7700
	INPDEV=INPLEN-2	/INPUT DEVICE NUMBER
	INPBLK=INPLEN-1
	OUTDEV=4022	/OUTPUT DEVICE NAME FROM SORTCD
	SPECS=4000
	DIRPTR=17	/DIRECTORY POINTER AUTO-INDEX
	*165
KOKAY,	ISOK
JPACK,	PACKC
SPACNT,	0
MN240,	-240
CMPRS1,	0
	DCA	CCHCK	/STORE CHARACTER
	TAD	CMPRS	/CHECK FOR /C
	SNA CLA
	JMP I	KOKAY	/OPTION NOT SET
	TAD	CCHCK	/SET, CHECK FOR A SPACE
	TAD	MN240
	SZA CLA
	JMP	NTBLNK	/NOT A BLANK
	ISZ	SPACNT	/A SPACE, BUMP SPACE COUNT
	JMP I	CMPRS1	/AND EXIT
NTBLNK,	TAD	SPACNT	/GET THE COUNT
	SNA
	JMP	ISOK	/ZERO SPACE COUNT, OKAY
	TAD	M1	/CHECK FOR ONLY 1 SPACE
	SNA CLA
	JMP	SPACOT
	TAD	K377	/OUTPUT A RUBOUT
	JMS I	JPACK
	TAD	SPACNT	/THEN THE SPACE COUNT
	SKP
SPACOT,	TAD	P240	/OUTPUT A SPACE FOR 1
	JMS I	JPACK
ISOK,	DCA	SPACNT	/CLEAR COUNT
	TAD	CCHCK	/OUTPUT CHARACTER
	JMS I	JPACK
	JMP I	CMPRS1	/EXIT
K377,	377
/THE FOLLOWING CODE SHOULD BE INCLUDED SOMEWHERE IN THE RESIDENT SORT CODE
/
/ENTER TEMPORARY FILE ON OUTPUT DEVICE
/AC ON CALL = POINTER TO FILE NAME
/ASSUMES USR IN CORE ON CALL
/
ENTER,	0
	DCA	NAMPTR	/STORE NAME POINTER IN REQUEST
	TAD	OUTNUM	/GET OUTPUT DEVICE NUMBER
	CIF	10
	JMS I	(USR	/ENTER FILE
	3
NAMPTR,
STBLK,	0
FLENG,	0		/OUTPUT FILE LENGTH
	ERRHLT		/ERROR ON CALL
	JMP I	ENTER
/
/SORT KEY STORAGE AREA
/
STORG,	0	/SUBROUTINE TO SET UP ALTERNATE TERMINAL CODES
	DCA	ENTER	/STORE TERMINAL CODE IN A SAFE PLACE
	TAD I	JTYPE1
	AND	K7007	/AND OFF ACTION CODES
	TAD	ENTER	/ADD IN DEVICE CODE
	DCA I	JTYPE1	/STORE IN I-O REQUEST
	TAD I	JTYPE2
	AND	K7007
	TAD	ENTER
	DCA I	JTYPE2
	JMP I	STORG	/EXIT
K7007,	7007
JTYPE1,	TYPEA+1
JTYPE2,	TYPEA+2
	ZBLOCK STORG+20-.
PACK,   0
        AND    (377
        JMP I  PACKA
PACKA,  PACK1
        JMP I  PACK
PACK1,  DCA I  ADDROT
        JMS    PACKA
        DCA    CHART
        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    CHART
        DCA I  ADDROT
        ISZ    ADDROT
        JMS    PACKA
        JMP    PACK1
/
/SUBROUTINE TO CLOSE CURRENT SRTINT.AA
/
CLOSE,	0
	TAD	WRTEN	/GET NUMBER OF BLOCKS ACTUALLY WRITTEN TO DISK
	DCA	FLXLEN
	TAD	OUTNUM	/GET DEVICE NUMBER
	CIF	10
	JMS I	(USR	/CLOSE CURRENT OUTPUT FILE
	4
	FAKNAM		/DUMMY FILE NAME NEEDED TO PRESERVE CURRENT "SRTINT.AA"
FLXLEN,	0
	ERRHLT-1	/ERROR ON CLOSE
	ISZ	FILES	/INCREMENT NUMBER OF INTERMEDIATES ALLOCATED
	TAD	WRTEN
	TAD	BLKSW	/STORE NUMBER OF BLOCKS WRITTEN
	DCA	BLKSW
	DCA	WRTEN	/CLEAR NUMBER WRITTEN TO FILE
	JMP I	CLOSE
RWDIR,	0
	TAD	(200
	DCA	IOREQ+1
	TAD	OUTBUF
	DCA	IOREQ+2
	TAD	DIRBLK
	DCA	IOREQ+3
IOREQ,	JMS I	OUTENT	/READ-WRITE DIRECTORY SEGMENT
	ZBLOCK 3
	ERRHLT-2
	JMP I	RWDIR
INITAL,	0
	TAD	M600
	DCA	WRTCNT
	TAD	OUTBUF
	DCA	ADDROT
	TAD	(PACK1
	DCA	PACKA
	JMP I	INITAL
PACKC,	0
	JMS	PACK	/PACK IT INTO BUFFER
	ISZ	WRTCNT	/CHECK FOR DONE WITH BLOCK
	JMP I	PACKC	/NO, GET MORE CHARACTERS
	TAD	WRTBLK
	DCA	BLOCK
	JMS I	OUTENT	/WRITE BLOCK ON INTERMEDIATE
	4200
	OUTBUF
BLOCK,	0
	ERRHLT-2
	ISZ	WRTBLK
	ISZ	WRTEN
	JMS	INITAL	/RE-INITIALIZE PACK ROUTINE
	JMP I	PACKC
	PAGE
PRGST,	CLA CMA		/CLR ADDRESS FOR STORING RECORDS
	DCA	BUFPTR
	DCA	ADDRES
	TAD	(LIST-1
	DCA	LISTPT
	DCA	LINES	/CLEAR NUMBER OF LINES PROCESSED
READRC,	JMS I	(READBF	/READ A RECORD
	JMP I	(EOFND	/EOF RETURN
	ISZ	RECIN+1	/INCREMENT RECORD IN COUNT
	SKP
	ISZ	RECIN
	ISZ	LINES	/COUNT NUMBER OF LINES IN THIS BUFFER
	TAD	ADDRES	/STORE ADDRESS AND LINE LENGTH IN LIST
	DCA I	LISTPT
	TAD	LENGTH
	DCA I	LISTPT
	DCA	LENGTH	/CLEAR LINE LENGTH
	CLA IAC		/FIND NEXT ADDRESS FOR STORING
	TAD	BUFPTR	/BY ADDING 1 TO BUFFER POINTER AUTO-INDEX
	DCA	ADDRES
	CLA IAC CLL
	TAD	LISTPT	/CHECK FOR LINE LIST OVERFLOW
	CIA
	TAD	OUTBUF	/INTO OUTPUT BUFFER AREA
	SNA CLA
	JMP	SORTIT	/YES, DICONTINUE OPERATION AND DO SORT
	CLA STL
	TAD	(-7300	/CHECK FOR FULL TEXT BUFFER
	TAD	ADDRES
	SZL CLA
	JMP	READRC	/NOT FULL CONTINUE READING
SORTIT,	TAD	LISTPT	/SET UPPER LIST BOUND FROM LISTPTR
	DCA	UPPRLM
	TAD	(LIST	/SETUP LOWER LIST BOUND
	DCA	LOWRLM
PASS1,	CLA CMA		/SET LIST STORE PTR
	TAD	LOWRLM
	DCA	X10
	JMS	CCHCK	/CHECK FOR A ^C TYPED ON KEYBOARD
	TAD	X10	/AND LIST POINTER
	DCA	LISTPT
	TAD I	LISTPT	/READ FIRST RECORD INFO
	DCA	ADDR1
	TAD I	LISTPT
	DCA	LEN1
	DCA	SWITCH	/CLEAR PERMUTATION COUNT
	DCA	DIRECT	/AND DIRECTION POINTER
READUP,	TAD	LISTPT	/CHECK FOR DONE (I.E. LISTPT >= UPPRLM)
	CIA STL
	TAD	UPPRLM
	SZL SNA CLA
	JMP	DNEUP	/LISTPT >= UPPRLM ALL DONE WITH THIS PASS
	TAD I	LISTPT	/PICKUP SECOND RECORD ARGS
	DCA	ADDR2
	TAD I	LISTPT
	DCA	LEN2
	JMS I	(COMPAR	/CHECK THIS PAIR OF RECORDS
	JMP	READUP	/COMPARISON COMPLETE, GET NEXT RECORD
DNEUP,	TAD	X10	/STORE NEW UPPER LIMIT
	DCA	UPPRLM
	TAD	ADDR1	/AND STORE EXTREME REMAINING VALUE
	DCA I	X10
	TAD	LEN1
	DCA I	X10
	TAD	SWITCH	/CHECK FOR ALL DONE (I.E. ZERO PERMUTATIONS)
	SNA CLA
	JMP I	(PACKIT	/ALL DONE PACK OUT THIS BUFFER
	DCA	SWITCH	/CLR PERMUTATION COUNT FOR NEXT TIME THRU
	STL RAR		/SET DIRECTION TO DOWNWARD
	DCA	DIRECT
	CLA CMA		/GET STARTING LOCATION TO DOWN SORT
	TAD	UPPRLM
	DCA	PTR1
	STA CLL RAL
	TAD	UPPRLM	/AND LIST STORAGE ADDRESS
	DCA	X10
	TAD I	PTR1	/PICKUP FIRST ARGS
	DCA	ADDR1
	ISZ	PTR1
	TAD I	PTR1
	DCA	LEN1
DWNLP,	CLA CLL CMA RTL	/AC=-3
	TAD	PTR1	/SUBTRACT 3 FROM PTR1 TO GET NEW POINTER
	DCA	PTR1
	TAD	PTR1	/CHECK FOR DONE (I.E. PTR1 < LOWRLM)
	CIA STL
	TAD	LOWRLM
	SNL SZA CLA
	JMP	DNEDWN
	TAD I	PTR1
	DCA	ADDR2
	ISZ	PTR1
	TAD I	PTR1
	DCA	LEN2
	JMS I	(COMPAR	/COMPARE THIS PAIR OF RECORDS
	TAD	(-4	/MOVE STORING POINTER DOWN TO NEXT POSITION
	TAD	X10
	DCA	X10
	JMP	DWNLP	/CONTINUE TO PROCESS SORT
DNEDWN,	TAD	ADDR1	/STORE LOWEST VALUE
	DCA I	X10
	TAD	LEN1
	DCA I	X10
	IAC		/LOWEST LIMIT=X10 +1
	TAD	X10
	DCA	LOWRLM
	TAD	SWITCH	/CHECK FOR ALL DONE
	SNA CLA
	JMP I	(PACKIT
	JMP	PASS1	/NOT DONE CONTINUE
FAKNAM,	FILENAME SRTINT.DI	/DIRECTORY FILE FOR SORT
PUTBF,	0
	CDF	10	/SORT BUFFER IS IN FLD 1
	DCA I	BUFPTR
	CDF
	ISZ	LENGTH	/AND INCREMENT LINE LENGTH
	JMP I	PUTBF
	PAGE
COMPAR,	0
	TAD	SRTKEY	/STORE LOOP INDEX
	DCA	LPTR
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
	SMA CLA
	JMP	OUTOF	/MUST PERMUTE RECORDS
STOR1,	TAD	ADDR1	/RECORDS IN ORDER, NO CHANGES REQUIRED
	DCA I	X10	/STORE PTRS
	TAD	LEN1
	DCA I	X10
	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	STOR1	/EQUAL, PRESERVE ORGINAL SEQUENCE
OUTOF,	ISZ	SWITCH	/SET PERMUTE SWITCH
	NOP
	TAD	ADDR2
	DCA I	X10
	TAD	LEN2
	DCA I	X10
	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
	CLA CLL CMA RAR	/AC=3777
	AND	P1	/AND OFF LENGTH OF KEY
	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
	CDF	10
	TAD I	CHAR2
	CIA
	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 AND DIRECTION OF SORT
	TAD	DIRECT
	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
EOFND,	ISZ	EOFLG	/SET EOF FLAG
	CLA CLL CMA
	TAD	LINES	/CHECK FOR ZERO OR 1 LINES IN BUFFER
	SNL
	JMP	ZERECS	/ZERO RECORDS LEFT, CHECK DISPOSITION
	SZA CLA
	JMP I	(SORTIT	/MORE THAN 1 RECORD IN BUFFER, SORT THE BUFFER
	JMP I	(PACKIT	/EXACTLY 1 RECORD, PACK IT OUT
ZERECS,	TAD	SEGMNT	/CHK # OF SEGMENT WRITTEN TO DSK
	SZA CLA
	JMP I	(CHAIN	/HAVE ALREADY WRITTEN SOME, CAN IGNORE THIS ONE
	JMP I	(PACKIT	/MUST PACK AN EOF FOR NULL FILE
INTNAM,	FILENAME SRTINT.AA
	PAGE
/
/SUBROUTINE TO READ RECORDS, ADJUST POINTERS AND STORE IN BUFFER
/
READBF,	0
NEXTCH,	CLA CMA		/SET JMP FLAG
	DCA	JMPFLG
	TAD	BUFCNT	/CHECK NUMBER OF CHARACTERS LEFT IN BUFFER
	SZA CLA
	JMP	OKAY	/STILL SOME CHARACTERS LEFT
	TAD	INLEN	/CHECK FOR ANY MORE BLOCKS TO BE READ ON INPUT
	SNA CLA
	JMP I	READBF	/ZERO BLOCKS LEFT, DO EOF EXIT
	TAD	INPBUF	/SOME BLOCKS LEFT TO READ, GO GET THEM
	DCA	REQRD+2
	TAD	INBLOC
	DCA	REQRD+3
REQRD,	JMS I	INPENT	/READ INPUT FILE
	200
CHAR,	ZBLOCK 2
	SNA CLA		/ZERO RETURNS ARE ACCEPTABLE (EOF'S)
	SKP
	ERRHLT-3
	ISZ	INBLOC	/BUMP INPUT BLOCK NUMBER
	ISZ	INLEN	/AND REMAINING INPUT LENGTH
MONITR,	CLA I		/CLA I=7600=MONITOR JUMP ADDRESS
	TAD	M600	/FIX UP NUMBER OF CHARACTERS TO READ
	DCA	BUFCNT
	TAD	(PICK1	/AND UNPACKING ROUTINE
	DCA	PICKA
	TAD	INPBUF	/AND PUT POINTER AT BEGINNING OF BUFFER
	DCA	PICKAX
OKAY,	JMS	PICK	/GET 1 CHARACTER
	ISZ	BUFCNT	/BUMP BUFFER COUNT
MRUB,	7401		/WITH NO PROBLEM ON SKIP (7401=NOP, ALSO = -RUBOUT)
	ISZ	JMPFLG	/TEST IF AN UNPACK COUNT
	JMP	CHKZER	/AN UNPACK COUNT, CHECK FOR 0
	DCA	CHAR	/STORE CHARACTER
	TAD	CHAR	/EDIT CHARACTER
	TAD	(-232	/CHECK FOR ^Z
	SNA
	JMP I	READBF	/EQUAL, TAKE EOF EXIT
	TAD	(232-215	/CHECK FOR CR (END-OF-LINE)
	SNA
	JMP	EOL	/EQUAL, DO EOL PROCESSING
	TAD	(215-211	/CHECK FOR HORIZONTAL TAB
	SNA	
	JMP	TAB	/EXPAND TABS OUT TO APPRORIATE NUMBER OF SPACES
	TAD	(211-240	/THROW AWAY ALL OTHER CONTROL CHARACTERS
	SPA CLA
	JMP	NEXTCH	/GET NEXT CHARACTER ON CONTROL CHARACTER
	TAD	CMPRS	/CHECK IF COMPRESS MODE SPECIFIED
	SZA CLA
	TAD	MRUB	/COMPRESS MODE SET, CHECK FOR A RUBOUT
	TAD	CHAR
	SNA CLA
	JMP	NEXTCH+1 /CHARACTER IS A RUBOUT AND COMPRESS MODE SET, GET COUNT
PUTCHR,	TAD	CHAR	/NOT A CONTROL CHARACTER, PUT IN SORT BUFFER
	JMS I	PUTCH
	JMP	NEXTCH	/AND GET NEXT CHARACTER
EOL,	ISZ	READBF	/EXIT TO P+2
	TAD	LENGTH	/COMPLEMENT RECORD LENGTH
	CIA
	DCA	LENGTH
	JMP I	READBF	/TAKE END OF RECORD EXIT
TAB,	TAD	P240	/EXPAND TABS OUT WITH SPACES
	JMS I	PUTCH
	TAD	LENGTH	/UNTIL MULTIPLE OF 8 COLUMNS HAS BEEN REACHED
	RAR CLL
	SNL
	RAR
	SNL
	RAR
	SZL CLA
	JMP	TAB	/COLUMN NUMBER NOT YET DIVISIBLE BY 8, CONTINUE INSERTING SPACES
	JMP	NEXTCH	/EVERYTHING IS HONKY-DOREY GET NEXT CHARACTER
CHKZER,	SNA		/ZERO COUNT MEANS AN ACTUAL RUBOUT
	JMP	PUTCHR	/PUT IT IN RECORD
	CIA		/COMPLEMENT UNPACK COUNT
	JMP	UNPACK	/GO UNPACK (AC) SPACES
/
/SUBROUTINE TO UNPACK CHARACTERS 1 AT A TIME FROM OS/8 FILE BUFFER
/
PICK,   0
        CDF
        JMP I   PICKA
PICKA,  PICK1
        AND     (177
        TAD     (200
        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
TEMP,   0
PICKAX, 0
CHAIN,	CIF	10	/BRING BACK THE USR
	JMS I	(USRIN
	10
	JMS I	(CLOSE	/CLOSE CURRENT OUTPUT FILE
	JMS	SYSRD	/READ DOWN SYSTEM OVERLAY
	JMS I	STATS	/TYPE OUT STATISTICS
	TAD	SLASHH	/CHECK FOR /H OPTION SET
	SZA CLA
	JMP I	MONITR	/SET, RETURN TO OS/8 MONITOR
	CIF	10
	JMS I	(USR	/NOW CHAIN TO MERGE
	6
MRGCH,	0
	PAGE
/
/SUBROUTINE TO PACK OUTPUT BUFFER AND WRITE TO DISK
/
PACKIT,	TAD	LINES	/DETERMINE NUMBER OF BLOCKS TO BE WRITTEN
	RAL CLL IAC	/MULTIPLY BY 2 AND ADD 2 (FOR ^Z AND CR-LF)
	TAD	BUFPTR	/ADD IN NUMBER OF CHARACTERS IN THE BUFFER.
	DCA	SYSRD	/GIVING NUMBER OF CHARACTERS TO BE OUTPUT
	DCA	LEN1	/CLEAR BLOCK COUNTER
	RAL		/GET OVERFLOW
LOOP0,	DCA	LEN2	/STORE IT
	TAD	LEN2	/CHECK FOR ALL DONE
	SPA
	JMP	OUT
	SZA CLA
	JMP	LOOP3
	TAD	SYSRD
	SNA CLA
	JMP	OUT
LOOP3,	JMP	SUBTR2	/SUBTRACT 600 FROM NUMBER OF CHARACTERS TO BE WRITTEN
OUT,	CLL CLA
	TAD	OLENG	/CHECK TO SEE IF THIS SECTION WILL FIT
	TAD	LEN1
	DCA	OLENG	/STORE UPDATED LENGTH
	SNL CLA
	JMP	HVERM	/WE HAVE ENOUGH ROOM ON CURRENT SRTINT
	CIF	10	/NO ROOM, CLOSE THIS FILE AND BRING ENTER A NEW ONE
	JMS I	(USRIN	/AFTER FIRST BRINGING IN USR TO CORE
	10
	JMS I	(CLOSE	/GO DO CLOSE OF FILE
	TAD	(INTNAM	/NOW ENTER NEW FILE
	JMS I	(ENTER
	CIF	10
	JMS I	(USR	/RESTORE USR AREA
	11
	DCA	WRTEN	/CLEAR NUMBER OF BLOCKS WRITTEN
	TAD I	(FLENG	/FIX UP NEW LENGTH
	DCA	OLENG
	TAD I	(STBLK	/AND START BLOCK
	DCA	WRTBLK
	CLL		/CHECK IF SEGMENT WILL FIT THIS TIME
	TAD	OLENG
	TAD	LEN1
	SZL CLA
	ERRHLT-4	/NO ROOM
HVERM,	STL RAR CLA	/SET FIRST DIGIT=4=SRTINT
	TAD	OUTNUM	/CONSTRUCT DIRECTORY SEGMENT
	DCA I	DIRPTR
	TAD	WRTBLK
	DCA I	DIRPTR
	TAD	LEN1
	CIA
	DCA I	DIRPTR
	STL RAR CLA	/AC=4000 FOR WRITE DIRECTORY SEGMENT
	JMS I	(RWDIR	/WRITE DIRECTORY SEGMENT
	JMS I	(INITAL	/INITIALIZE PACK OPERATION
	TAD	LINES	/CHECK NUMBER OF LINES TO PACK
	SNA
	JMP	ENDIT	/ZERO LINES, JUST NEED TO DO A EOF
	CIA
	DCA	LINES
	TAD	(LIST-1	/INITIALIZE LIST PTR
	DCA	LISTPT
LOOP1,	TAD I	LISTPT	/GET ADDRESS OF LINE
	DCA	ADDR1
	TAD I	LISTPT
	SNA
	JMP	EOL1	/ZERO LENGTH = JUST CR-LF
	DCA	LEN2	/STORE LINE LENGTH
LOOP2,	CDF	10
	TAD I	ADDR1	/PICK UP CHARACTER FROM BUFFER
	CDF
	ISZ	ADDR1	/BUMP ADDRESS POINTER
	JMS	CMPRS1
AROUND,	ISZ	LEN2	/INCREMENT LINE LENGTH
	JMP	LOOP2	/NOT DONE YET
EOL1,	TAD	(215	/DONE WITH LINE, PACK IN CR-LF
	JMS	CMPRS1
	TAD	(212
	JMS	CMPRS1
	ISZ	LINES	/CHECK FOR ALL DONE WITH BUFFER
	JMP	LOOP1	/NO GET NEXT LINE
ENDIT,	TAD	(232
	JMS	CMPRS1
	TAD I	(WRTCNT
	TAD	(600	/CHECK FOR BUFFERING COMPLETE
	SZA CLA
	JMP	ENDIT+1	/CONTINUE PACKING CHARACTERS
	ISZ	SEGMNT	/BUMP NUMBER OF SEGMENTS
	CLA CMA
	TAD	INPBUF	/CHECK TO SEE IF WE HAVE FILLED DIRECTORY SEGMENT
	CIA
	TAD	DIRPTR
	SNA CLA
	JMP	ZERDIR	/HAVE FILLED, ZERO DIRECTORY AREA
REJN,	JMS I	(RWDIR	/READ SEGMENT BACK TO OUTPUT BUFFER
	TAD	EOFLG
	SNA CLA
	JMP I	(PRGST	/NOT ENDED YET, READ SOME MORE
	JMP I	(CHAIN	/EOF FOUND, DO CHAIN TO MERGE
ZERDIR,	CLA CMA
	TAD	OUTBUF
	DCA	X10
	TAD	P7400	/ZERO ALL OF NEW DIRECTORY SEGMENT
	DCA	LINES
	ISZ	LINES	/CHECK FOR DONE
	JMP	.-2
	CLA CMA
	TAD	OUTBUF
	DCA	DIRPTR
	ISZ	DIRBLK	/THEN WRITE AS NEW DIRECTORY SEGMENT
	STL RAR
	JMP	REJN
	PAGE
/
/STORAGE BUFFER FOR LINE INFO EXTENDS FROM HERE DOWN TO LIST+2*(#LINES IN
/BUFFER). ABSOLUTELY CANNOT EXTEND PAST BEGINNING OF OUTPUT BUFFER (WHOSE
/LOCATION MAY BE FOUND IN LOCATION OUTBUF.
/
LIST=.
	*4400
/
/STORAGE ALLOCATION FOR SORT -- LATER OVERLAID WITH SORT TABLES
/DYNAMICALLY ALLOCATES HANDLERS TO UPPER CORE AND DETERMINES
/LOCATIONS FOR INPUT AND OUTPUT BUFFERS.
/
BEGIN,	CLA IAC		/START UP
	JMS I	(ALTERM	/CHECK FOR ALTERNATE TERMINAL
	CIF	10
	JMS I	(USRIN	/LOCK USR INTO CORE
	10
	CIF	10
	JMS I	(USR	/RESET SYSTEM TABLES SO NO PROBLEMS DEVELOP
	13
	TAD	(0423	/MAKE DEVICE NAME "DSK"
	DCA	N1
	TAD	(1300
	DCA	N2
	TAD I	(INPLEN	/STORE LENGTH OF INPUT FILE
	SNA		/STORE 1 FOR 0 (NON-FILE STRUCTURED INPUT)
	IAC
	DCA	INLEN
	TAD I	(INPBLK	/AND STARTING BLOCK OF INPUT FILE
	DCA	INBLOC
	JMS	ASSIGN	/GO DO FETCH DYNAMICALLY
SYSCOR,	DCA	OUTENT	/STORE ENTRY PT
	TAD	N2
	DCA	OUTNUM	/STORE OUTPUT DEVICE NUMBER
	JMP	INPFLE	/DO THE SAME FOR INPUT DEVICE
INPFLE,	TAD I	(INPDEV	/GET INPUT DEVICE NUMBER
	DCA	N2
	TAD	N2
	CIF	10
	JMS I	(USR	/DO "INQUIRE" ABOUT INPUT DEVICE
	12
LOC3,	0
	ERRHLT-5	/ERROR RETURN
	TAD	LOC3	/CHECK FOR DEVICE HANDLER ALREADY IN CORE
	SNA
	JMS	FETCH	/NOT IN CORE, GO TO IT
	DCA	INPENT	/SAVE INPUT DEVICE ENTRY PT
	JMS	GETPAG	/NOW LOCATE INPUT AND OUTPUT BUFFERS IN CORE
	CLA
	JMS	GETPAG
	DCA	INPBUF	/STORE INPUT BUFFER STARTING LOCATION
	JMS	GETPAG
	CLA
	JMS	GETPAG
	DCA	OUTBUF	/STORE OUTPUT BUFFER BEGINNING LOCATION
	DCA I	(INPDEV	/CLEAR OUTPUT DIRECTORY AREA
	DCA I	(INPBLK
	DCA I	(INPLEN
	JMS I	(FIXFLS	/ENTER DIRECTORY AND FIRST INTERMEDIATE FILE
	TAD I	(STBLK	/STORE START AS BEGINNING OF DIRECTORY
	DCA	WRTBLK
	TAD	(SPECS-INPDEV	/MOVE SORT DATA TO OUTPUT AREA
	DCA	LOC3
	TAD	(SPECS-1
	DCA	X10
	CLA CMA
	TAD	OUTBUF	/PUT OUTPUT BUFFER ADDRESS-1 INTO DIRPTR AUTO-INDX
	DCA	DIRPTR
COPYIT,	TAD I	X10	/MOVE DATA TO NEW POSITION
	DCA I	DIRPTR
	ISZ	LOC3	/CHECK FOR ALL DONE
	JMP	COPYIT	/NOT YET
	JMS I	(FILZER	/HAVE COPIED INFO, FILL REMAINDER WITH ZEROS
	TAD I	(FLENG	/CHECK FILE SIZE
	DCA	OLENG	/STORE LENGTH OF WRITEABLE INTERMEDIATE AREA
	TAD	(SPECS-1
	DCA	X10	/SET UP TO COPY SORT KEYS TO LOWER CORE
	TAD I	X10
	DCA	SRTKEY	/SAVE NUMBER OF SORT KEYS
	TAD	(STORG-1	
	DCA	X11
	TAD	(-20
	DCA	LOC2
	TAD I	X10
	DCA I	X11
	ISZ	LOC2
	JMP	.-3	/COPY SORT KEYS TO LOWER CORE
	JMP I	(MOVKYS	/MOVE KEYS TO LOWER CORE
ASSIGN,	0
	CIF	10
	JMS I	(USR	/DO "INQUIRE" ABOUT DEVICE
	12
N1,	0
N2,	0
LOC1,	0
	ERRHLT-5
	TAD	LOC1	/CHECK FOR DEVICE HANDLER IN CORE
	SZA
	JMP I	ASSIGN	/ALREADY PRESENT, EXIT WITH ENTRY PT IN AC
	JMS	FETCH	/NOT PRESENT FETCH IT
	JMP I	ASSIGN	/EXIT WITH ENTRY PT IN AC
FETCH,	0
	JMS	GETPAG	/FIND SPACE FOR HANDLER
	DCA	LOC2
FETRY,	TAD	N2
	CIF	10
	JMS I	(USR	/FETCH DEVICE HANDLER
	1
LOC2,	0
	JMP	TWOPAG	/MUST BE A TWO-PAGE HANDLER
	TAD	LOC2
	JMP I	FETCH	/EXIT WITH ENTRY IN AC
TWOPAG,	CLA I
	JMS	GETPAG
	IAC		/GRUDGINGLY MAKE SPACE FOR TWO-PAGE HANDLER
	JMP	FETRY-1	/AND GO GET IT
GETPAG,	0
	TAD	TWOPAG
	TAD	LOCNUM
	DCA	LOCNUM	/SUBTRACT 200 OCTAL FROM LAST LOCATION
	TAD	LOCNUM	/LEAVE WITH IT IN THE AC
	JMP I	GETPAG
LOCNUM,	CLA I
	PAGE
MOVKYS,	DCA	BUFCNT	/MAKE SURE BUFFER COUNTER IS EMPTY
	DCA	RECIN	/CLR NUMBER OF INPUT RECORDS
	DCA	RECIN+1
/
/FIX UP OUTPUT AND ERROR ROUTINES DEPENDENT ON BATCH BEING IN CORE
/
BATCR,	STL RTR CLA	/MASK FOR BATCH-IN-PROGRESS BIT
	AND I	M1	/AND WITH STATUS WORD
	SNA CLA
	JMP	NOBAT	/NO BATCH PRESENT, PROCEED NORMALLY
	TAD I	M1	/PICK UP BATCH FIELD
	AND	(70	/FROM STATUS WORD
	TAD	(CIF	/CONSTRUCT CIF BATCHFLD
	DCA I	(FLDCH1
	TAD I	(FLDCH1	/CONSTRUCT CDF CIF BATCHFLD
	IAC
	DCA I	(FLDCH2
	TAD	(BATYP	/MAKE OUTPUT ROUTINE BATCH OUTPUT ROUTINE
	DCA	TYPE
	TAD	(FLDCH2	/MAKE BATCH ABORT ERROR EXIT.
	DCA	ERROR
NOBAT,	TAD	SRTKEY	/SET UP INDEX TO SORT KEYS
	CIA RAL CLL
	TAD	(STORG	/ADD IN TABLE ADDRESS
	DCA	KYPTR	/POINTER TO END OF TABLE
	JMS I	SYSENT	/WRITE OUT I-O OVERLAY
	4400
	STATYP
	33		/SYSTEM SCRATCH BLOCKS
ERLOC,	ERRHLT-6	/SYSTEM ERROR
	TAD	OUTBUF	/STORE OUTPUT BUFFER ADDRESS IN OUTPUT ROUTINE
	DCA I	(BLOCK-1
	CLA IAC		/LOOKUP MERGE ON SYS:
	CIF	10
	JMS I	(USR
	2
BLKCH,	MRGFL
	0
	ERRHLT-7
	TAD	BLKCH	/STORE FOR CHAIN
	DCA I	(MRGCH
	CDF	10	/CHECK FOR /C OPTION ON
	TAD I	(7643
	CDF
	AND	(1000
	DCA	CMPRS	/STORE /C OPTION SET WORD
	JMP I	(PRGST	/JUMP TO START OF SORT ROUTINE
NKEYS,	0
/
/DELETE ANY PREVIOUS FILES WITH SAME NAME
/MUST BE DONE RECURSIVELY DUE TO POSSIBLITY OF MULTIPLE FILES
/WITH THE SAME NAME.
/
PURGE,	0
	TAD	CLSNAM	/RESTORE NAME IN LOOKUP COMMAND
	DCA	LOOKUP
	TAD	OUTNUM	/ADD OUTPUT FILE NUMBER SO LOOKUP DONE ON RIGHT DEVICE
	CIF	10
	JMS I	(USR	/LOOKUP "DSK:SRTINT.AA"
	2
LOOKUP,	INTNAM
	0
	JMP I	PURGE	/NO MATCH CAN EXIT ROUTINE
	TAD	CLSNAM	/ENTER TEMPORARY WITH SAME NAME
	JMS I	(ENTER
	TAD	OUTNUM	/NOW DO CLOSE WITH ZERO LENGTH (A DELETE)
	CIF	10
	JMS I	(USR
	4
CLSNAM,	INTNAM
	0		/LENGTH MUST EQUAL ZERO FOR PURGE
	ERRHLT-1	/ERROR
	JMP	PURGE+1	/LOOK FOR MORE INTERMEDIATES
FILZER,	0
	TAD	DIRPTR	/ZERO FROM CURRENT POINTER POSITION TO END OF BLOCK
	DCA	X10
	TAD	(INPDEV-SPECS-400
	DCA	NKEYS
	DCA I	X10	/CLEAR OUTPUT AREA
	ISZ	NKEYS	/UNTIL END OF BLOCK
	JMP	.-2
	JMP I	FILZER	/EXIT WHEN ALL DONE
FIXFLS,	0
	JMS	PURGE	/DELETE OLD INTERMEDIATES
	TAD	OUTNUM	/SET UP A FILE ENTER OF 5 BLOCKS
	DCA	PURGE	/STORE DEVICE # TEMPORARILY
	TAD	PURGE
	AND	(17	/AND OFF DEVICE #
	TAD	(120	/ADD IN 5 BLOCKS IN BITS 0-7
	DCA	OUTNUM	/STORE FOR ENTER
	TAD	(FAKNAM	/GET DIRECTORY FILE NAME
	JMS I	(ENTER
	TAD I	(STBLK	/PICKUP START BLOCK
	DCA	DIRBLK
	TAD	PURGE	/RESTORE  DEVICE NUMBER
	DCA	OUTNUM
	TAD	(5
	DCA	WRTEN	/5 BLOCKS SHOULD HOLD ALL OF DIRECTORY
	JMS I	(CLOSE	/CLOSE DIRECTORY FILE
	DCA I	(FAKNAM	/CLEAR SO NO OTHER CLOSES DELETE
	TAD	(INTNAM	/LOOKUP FIRST INTERMEDIATE
	JMS I	(ENTER	/ENTER IT
	JMP I	FIXFLS	/EXIT BACK TO ROUTINE
MRGFL,	FILENAME MRGV2.SV
CHNXIT,	NOCHN
	EXITWR=JMP I	CHNXIT
        PAGE
/******************************************************************************
/									      *
/
/THE FOLLOWING SECTION OF CODE (05000-05777) IS THE SYSTEM I-O OVERLAY        *
/CODE IN THIS AREA IS WRITTEN INTO OS/8 SYSTEM SCRATCH AREA (BLOCK 33)        *
/DURING JOB INITIALIZATION.  IT IS READ BACK INTO MEMORY ON EITHER AN         *
/ERROR OR SUCESSFUL SORT TERMINATION.  EXTREME CAUTION SHOULD BE USED         *
/WHEN PLACING CODE IN THIS AREA SINCE THESE LOCATIONS MAY OR MAY NOT          *
/BE CODE RESIDENT.                                                            *
/									      *
/******************************************************************************
/SUBROUTINE TO PRINT OUT A DECIMAL NUMBER
/
STATYP,	0
	CLA STL RTR
	CDF	10
	AND I	(7644	/PICKUP /N OPTION
	CDF
	SZA CLA
	JMP I	STATYP	/OPTION SET, DO NOT TYPE OUT ANY STATS
	JMS I	MSG	/TYPE OUT  "RECORDS READ"
	RECS
	JMS	NUMPNT	/TYPE OUT NUMBER OF RECORDS
	JMS I	MSG	/TYPE OUT "SEGMENTS WRITTEN"
	SEGS
	TAD	SEGMNT
	DCA	RECIN+1
	JMS	NUMPNT	/TYPE OUT NUMBER OF SEGMENTS
	JMS I	MSG	/TYPE OUT "FILES ALLOCATED"
	ALLOC
	TAD	FILES
	DCA	RECIN+1
	JMS	NUMPNT	/TYPE OUT NUMBER OF FILES WRITTEN
	JMS I	MSG	/TYPE OUT "TOTAL BLOCKS WRITTEN"
	BLOCKW
	TAD	BLKSW
	DCA	RECIN+1
	JMS	NUMPNT	/TYPE OUT NUMBER OF BLOCKS WRITTEN
	JMP I	STATYP	/EXIT STATISTICS ROUTINE
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
INDX,   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     INDX
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     INDX    /CHECK FOR ALL DONE
        JMP     LOOPX   /NOT YET
        ISZ     DIVIDE  /ADJUST RETURN
        JMP I   DIVIDE  /EXIT
	PAGE
/
/ 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
/
/SUBROUTINE TO WRITE OUT AN OCTAL NUMBER ON THE OUTPUT DEVICE
/AC ON CALL = NUMBER TO TYPE OUT
/
OCTLIO, 0
        DCA     XX      /STORE NUMBER
        TAD     (-4     /LOOP INDEX
        DCA     MSGA
LPOCTO, TAD     XX
        RTL CLL
        RAL             /ROTATE AC DOWN
        DCA     XX
        TAD     XX
        RAL
        AND     (7
        TAD     (260
        JMS I   TYPE    /TYPE OUT THE DIGIT
        ISZ     MSGA    /CHECK FOR DONE
        JMP     LPOCTO
        JMP I   OCTLIO
ERR8,   TEXT    "_MRGV2.SV NOT FOUND AT "
ALTERM,	0
	DCA	TYPEA	/STORE AC ON CALL
	DCA	BLKSW	/CLEAR BLOCKS WRITTEN
	TAD I	(7746	/SET JOB STATUS BIT SO NO .ST COMMANDS CAN BE USED
	CMA
	AND	(6777
	CMA
	DCA I	(7746
	STL RAR CLA
	CDF	10
	AND I	(7643	/PICK UP /A OPTION
	CDF
	SNA CLA
	JMP	CHKHOP	/NOT SET, CHECK /H OPTION
	TAD	ALTCDE	/GET ALTERNATE TERMINAL CODES
	AND	(77	/AND OFF OUTPUT CODE
	RTL CLL
	RAL
	JMS I	(STORG
CHKHOP,	CDF	10
	TAD I	(7643	/PICKUP OPTION WORD
	CDF
	AND	(20	/AND OFF /H BIT
	DCA	SLASHH	/STORE IN A SAVE PLACE
	TAD	TYPEA	/CHECK FOR INITIAL VALUE =1
	SNA CLA
	JMP I	ALTERM	/EXIT
	TAD	EXIT1
	DCA I	(NOBAT
	JMP I	(BATCR
NOCHN,	JMS I	MSG
	CHAINR
	JMP I	ERROR	/EXIT
BATYP,	0
	CDF		/MAKE SURE DATA FIELD SET SO RETURN IS HERE
FLDCH1,	CIF		/REPLACED TO CDF BATCHFLD IN INTIALIZATION
	JMS I	BATOUT	/OUTPUT CHARACTER IN BATCH LOG
	CLA
	JMP I	BATYP	/RETURN TO SENDER
FLDCH2,	CDF CIF		/CHANGED TO CDF CIF BATCHFLD IN INTIALIZATION
	JMP I	BATERR	/ABORT BATCH
BATERR,	7000
BATOUT,	7400
TYPEA,	0
	TLS
	TSF
	JMP	.-1
	CLA
	JMP I	TYPEA
EXIT1,	EXITWR
        PAGE
MSGLST, ERR1;ERR2;ERR3;ERR4;ERR5;ERR6;ERR7;ERR8
ERR1,   TEXT    "_ENTER ERROR AT "
ERR2,   TEXT    "_CLOSE ERROR AT "
ERR3,   TEXT    "_I/O ERROR ON DSK: AT "
ERR4,   TEXT    "_READ ERROR AT "
ERR5,   TEXT    "_NO ROOM FOR OUTPUT FILE AT "
ERR6,   TEXT    "_UNDEFINED DEVICE AT "
ERR7,   TEXT    "_I/O ERROR ON SYS: AT "
RECS,   TEXT    "_RECORDS READ - "
SEGS,   TEXT    "_SEGMENTS WRITTEN - "
ALLOC,  TEXT    "_FILES ALLOCATED - "
BLOCKW, TEXT    "_TOTAL BLOCKS WRITTEN - "
CHAINR,	TEXT	@_".R SORTV2" IS ILLEGAL - PROGRAM MUST BE CHAINED FROM SORTCD_@
	*0
ALTCDE,
JMPFLG,	0304
	HLT		/PROTECT AGAINST SPURIOUS INTERRUPTS
UNPACK,	DCA	JMPFLG	/STORE UNPACKING COUNT
	TAD	P240	/UNPACK WITH SPACES
	JMS I	PUTCH
	ISZ	JMPFLG
	JMP	.-3	/NOT DONE, CONTINUE PACKING WITH SPACES
	JMP I	NEXT1
	*20
TYPE,	TYPEA
ERROR,	7600
DIRBLK,	0
WRTBLK,	0
OLENG,	0
INLEN,	0
INBLOC,	0
OUTNUM,	0
OUTENT,	0
INPENT,	0
OUTBUF,	0
INPBUF,	0
SRTKEY,	0
LENGTH,	0
BUFCNT,	0
ADDRES,	0
RECIN,	ZBLOCK	2
LINES,	0
EOFLG,	0
KYPTR,	0
UPPRLM,	0
LOWRLM,	0
DIRECT,	0
ADDR1,	0
LEN1,	0
ADDR2,	0
LEN2,	0
SEGMNT,	0
SWITCH,	0
WRTEN,	0
FILES,	0
CHART,  0
ADDROT, 0
P7400,  7400
WRTCNT,	0
BLKSW,	0
/
/SYSTEM ERROR ROUTINES
/CALLS DOWN OVERLAY AND EXECUTES ERROR MESSAGE IO AND EXIT
/
ERRCD,	0
PTR1,	0
OVRLAY,	1
SLASHH,
ENTR7,	0
	ISZ	ERRCD
	ISZ	ERRCD
	ISZ	ERRCD
	ISZ	ERRCD
	ISZ	ERRCD
	ISZ	ERRCD
	ERRHLT=JMS	.
ENTER0,	ISZ	ERRCD
M600,	CLA		/CLEAR JUNK
	TAD	ERRCD	/COMPUTE MESSAGE ADDRESS
	TAD	MSGADR
	DCA	MSGX
	TAD I	MSGX
	DCA	MSGX
	TAD	OVRLAY	
	SNA CLA		/CHECK IF WE MUST BRING OVERLAY DOWN
	JMS	SYSRD
	JMS I	MSG	/TYPE OUT ERROR MESSAGE
NEXT1,
MSGX,	NEXTCH
	TAD	ERRCD	/COMPUTE CALLING ADDRESS
	CIA
	TAD	KENTR
	DCA	MSGX	/ADDRESS OF JMS
	TAD I	MSGX	/GET VALUE
        JMS I   OCTL
BXIT,   CDF CIF         /DO ERROR EXIT
        JMP I   ERROR
OCTL,   OCTLIO
MSG,    MSGA
M203,	-203
KENTR,	ENTER0
CCHCK,	0
	KRS
	TAD	M203
	SNA CLA
	KSF
	JMP I	CCHCK
	JMP	BXIT
SYSRD,  0
        JMS I   SYSENT  /READ SYSTEM DEVICE
        400             /2 BLOCKS TO FLD 0
STATS,  STATYP          /ADDRESS=5000
        33              /SCRATCH BLOCKS
        HLT             /IRRECOVERABLE SYS I-O ERROR
        JMP I   SYSRD
SYSENT, 7607            /SYSTEM HANDLER ENTRY PT
SUBTR2,	ISZ	LEN1	/BUMP LENGTH INDICATOR
	CLA CLL
	TAD	SYSRD
	TAD	M600
	DCA	SYSRD
	RAL	
	TAD	M1
	TAD	LEN2
	JMP I	LOOP0A
LOOP0A,	LOOP0
M1,	-1
MSGADR,	MSGLST
CMPRS,	0
P240,	240
PUTCH,	PUTBF



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