;		PPPPPPP   UU     UU  NN     NN   CCCCC   HH    HH
;		PP    PP  UU     UU  NNN    NN  CC   CC  HH    HH
;		PP    PP  UU     UU  NNNN   NN  CC       HH    HH
;		PPPPPPP   UU     UU  NN NN  NN  CC       HHHHHHHH
;		PP        UU     UU  NN  NN NN  CC       HH    HH
;		PP         UU   UU   NN   NNNN  CC   CC  HH    HH
;		PP          UUUUU    NN    NNN   CCCCC   HH    HH
 
	.TITLE	PUNCH ASCII PAPER TAPE PROGRAM
	.IDENT	/V1.07/
	.ENABL	LC
	.PSECT
 
; TASK TO OUTPUT AN ASCII PAPER TAPE TO THE HIGH SPEED PUNCH.
; CARRIAGE RETURN/LINE FEEDS ARE GENERATED AND PARITY MAY BE SET, CLEAR,
; EVEN, OR ODD. A LEGIBLE TAPE HEADER MAY ALSO BE SELECTED.
; A COPY MAY BE SPOOLED TO THE LINEPRINTER.
; A LONGTITUDINAL CHECKSUM IS COMPUTED AND PUNCHED IF A TAPE TERMINATOR
; IS SPECIFIED. THIS IS CHECKED IF THE TAPE IS SUBSEQUENTLY READ BY THE
; COMPLEMENTARY "INPUT" TASK.
 
; RUN PROGRAM AS:
;
; >PUN <INFILE 1>/SWITCHES,<INFILE 2>/SWITCHES ...
;
; SWITCHES:-
;   HD *	PUNCH FILENAME & DATE IN 5X8 CHARACTERS
;  -HD		OMIT HEADER
;   CO		ADD COPYRIGHT NOTICE
;  -CO *	OMIT COPYRIGHT NOTICE
;   PY:EV{EN} *	PUNCH IN EVEN PARITY
;   PY:OD{D}	PUNCH IN ODD PARITY
;   PY:CL{EAR}	PUNCH WITH PARITY CLEAR
;   PY:SE{T}	PUNCH WITH PARITY SET
;  -PY		EQUIVALENT TO PY:CL
;   ET:<LETTER>	END TAPE WITH CONTROL/<LETTER> (DEFAULT IS ET:Z) *
;  -ET		NO TAPE TERMINATOR
;   SP		SPOOL A COPY OF <INFILE> TO LP0:
;  -SP *	DON'T PRINT A COPY OF <INFILE>
;   LA		LATCH CURRENT SWITCH SETTING
;  -LA *	DON'T LATCH SWITCHES
;  -DE *	DON'T DELETE FILE AFTER PUNCHING
;   DE		DELETE FILE AFTER PUNCHING
;
; * MARKS DEFAULT SETTINGS
; DEFAULTS MAY BE ALTERED AT TASK BUILD TIME BY GBLPAT'S TO
; DEFSW		SWITCH WORD(FOR BIT SIGNIFICANCES SEE SWTAB:)
; DEFPY		DEFAULT PARITY CHECK(SEE PYVAL:)
; DEFEB		END BYTE
;
 
;
; TASK BUILD AS:
; TKB>PUNCH/CP/-FP=PUNCH
; TKB>/
; ENTER OPTIONS:
; TKB>PAR=GEN
; TKB>ASG=TI:1:5,SY:2,PP:3
; TKB>ACTFIL=2
; TKB>STACK=64
; TKB>UNITS=5
; TKB>TASK=...PUN
; TKB>LIBR=FCSRES:RO
; TKB>//
;
	.PAGE
; MODIFICATIONS RECORD:
; 1.02	ADD LONGITUDINAL CHECKSUM FACILITY
;	CORRECT MCR LINE EXIT.
;
; 1.03	CORRECT CARRIAGE CONTROL CHARACTER IN ERRMES AND ERRST
;	CALL WTSE$ AFTER ATTACH  & DETACH
 
; 1.04	SET DEFAULT PARITY TO /PY:EV
;	REMOVE REDUNDANT CLOSE$  #GC BEFORE EXIT$S
;
; 1.05	CORRECT (ILLEGAL) WILDCARD FUNCTION CHECK.
;	EXIT WITH STATUS:-
;		EX$SUC	IF NO ERRORS ARE DETECTED,
;		EX$WAR	IF PARITY SPECIFIED IS ILLEGAL OR A DEVICE ERROR OCCURS
;			WHILE PUNCHING LEADER OR TRAILER,
;		EX$ERR	IF A COMMAND LINE ERROR OCCURS, A FILE CANNOT BE OPENED,
;			OR A DEVICE ERROR OCCURS DURING PUNCHING A FILE,
;		EX$SEV	IF ABORTED.
;	ISSUE A MESSAGE AT THE TERMINAL EVERY 30 SEC WHILE WAITING FOR ATTACH.
;	CHANGE QIO'S TO QIOW'S.
;	ADD DELETE SWITCH -- DELETE FILE ON SUCCESSFUL COMPLETION.
;	DEFAULT FILETYPE ALONG A LINE, AND TO SUBSEQUENT LINES IF LATCHED.
;
; 1.06 10-DEC-80
;	JUST IGNORE A BLANK COMMAND LINE -- DON'T PRINT AN ERROR.
;
; 1.07	1-Apr-86 CJD
;	Delete INSTITUTE from copyright message.
;	Put messages in mixed case.
 
	.MCALL	FDBDF$,FDRC$A,FDOP$A,NMBLK$,FINIT$,FSRSZ$,EXST$
	.MCALL	CSI$,CSI$1,CSI$2,GCML$,GCMLB$,GCMLD$,CSI$SW,CSI$SV,CSI$ND
	.MCALL	QIO$C,QIOW$,QIOW$S,QIOW$C,DIR$,MRKT$C,CMKT$C,WSIG$S,CLEF$C
	.MCALL	OPEN$R,CLOSE$,GTIM$,GET$,PRINT$,DELET$
 
	.GLOBL	$CBOMG,.PPASC,$C5TA,$CBDMG,$DAT,$TIM,.RDFUI
	.GLOBL	DEFSW,DEFPY,DEFEB,DEFTYP
 
START:	FINIT$				; (RE)INITIALISE FCS
	BR	RSTART			; AND START
ESTART:	MOV	#EX$ERR,EXSTAT		; LOAD ERROR EXIT FLAG ON RESTART HERE
RSTART:	TSTB	SWWRD			; LATCHED SWITCHES?
	BMI	GETCOM			; CONTINUE IF SO
	MOV	#ETBIT!HDBIT!PYBIT,SWWRD ; ELSE SET DEFAULT SWITCHES
DEFSW==.-4
	MOV	#EVEN,PYVAL		; DEFAULT PARITY EVEN
DEFPY==.-4
	MOVB	#'Z,ENDBYT		; DEFAULT END ^Z
DEFEB==.-4
	MOV	#^RTXT,DEFINP+N.FTYP	; DEFAULT FILETYPE .TXT
DEFTYP==.-4
 
GETCOM:	GCML$	#GC			; GET COMMAND LINE
	BCC	CMDIN			; BRANCH IF OK
	CMPB	#GE.EOF,GC+G.ERR	; CONTROL/Z?
	BNE	ILLCOM			; NO, MUST BE AN ERROR
	DIR$	#EXST			; ELSE EXIT
 
ILLCOM:	JSR	%5,ERRMES		; ELSE PRINT ERROR
	COMERR				; "COMMAND ERROR"
	BR	ESTART			; AND TRY AGAIN
 
CMDIN:	CSI$1	#CSIBLK,GC+G.CMLD+2,GC+G.CMLD ; PRE-PROCESS COMMAND
	BCS	ILLCOM			; BRANCH IF ERROR
	TST	CSIBLK+C.CMLD		; BLANK LINE?
	BEQ	GETCOM			; YES, JUST IGNORE IT
	BITB	#CS.EQU,CSIBLK+C.STAT	; NO '='
	BNE	ILLCOM			; ALLOWED
 
NXTFIL:	CSI$2	#CSIBLK,OUTPUT,#SWTAB	; ALL FILES ARE "OUTPUT"
	BCC	FILIN			; BRANCH IF OK
	JSR	%5,ERRMES		; ELSE ERROR MESSAGE
	ILLSWT				; "ILLEGAL SWITCH" (PROBABLY)
	BR	ESTART			; TRY AGAIN
FILIN:	BITB	#CS.WLD,CSIBLK+C.STAT	; WILDCARDS?
	BNE	ILLCOM			; ARE NOT ALLOWED
	BITB	#CS.NMF,CSIBLK+C.STAT	; THERE MUST BE A FILENAME
	BEQ	ILLCOM			; ERROR IF NOT
	OPEN$R	#INPUT			; OPEN FILE
	BCC	OPNOK			; BRANCH IF SUCCESSFUL
	JSR	%5,ERRMES		; ELSE ANOTHER ERROR
	OPNFLD				; "OPEN FAILED"
	BR	ESTART			; KEEP TRYING
 
; RETURN HERE FOR A NEW FILE, COULD BE ON SAME LINE
NEWFIL:	BITB	#CS.MOR,CSIBLK+C.STAT	; MORE?
	BEQ	RSTART			; RESTART IF NOT
	BR	NXTFIL			; ELSE GO FOR NEXT FILE
 
; FILE OPENED SUCCESSFULLY, TEST PARITY SWITCH
OPNOK:	MOV	INPUT+F.FNB+N.FTYP,DEFINP+N.FTYP ; COPY FILETYPE FOR NEXT DEFAULT
	BIT	#PYBIT,SWWRD		; PARITY DEFINED?
	BNE	ATTACH			; YES, BRANCH
	MOV	#CLEAR,PYVAL		; -PY = PY:CLEAR
ATTACH:	QIO$C	IO.ATT,3,3,,IOSTAT	; PTP IS UNIT 3
MRKT:	MRKT$C	4,20.,2			; PROMPT IN 20-SEC IF NOTHING HAPPENS
WSIG:	WSIG$S				; WAIT FOR ANY SIGNIFICANT EVENT
	CMPB	IOSTAT,#IS.PND		; IS THE QIO STILL PENDING?
	BNE	ATTCHD			; NO, GO SEE IF SUCCEEDED
	CLEF$C	4			; YES, WAS THIS THE MARK TIME FINISHING?
	CMP	$DSW,#IS.CLR		; FLAG STILL CLEAR IF NOT
	BEQ	WSIG			; SO CONTINUE WAITING
	JSR	%5,MESAGE		; TIMEOUT -- PRINT MESSAGE
	WAITNG				; "WAITING FOR PP0:"
	BR	MRKT			; MARK TIME AGAIN
ATTCHD:	CMKT$C	4			; QIO FINISHED, CANCEL MARK TIME
	JSR	PC,PCHCHK		; CHECK FOR PUNCH SUCCESS
	BCS	NEWFIL			; NEXT FILE IF ERROR
	CLR	PUNERR			; CLEAR PUNCH ERROR COUNTER
	BIT	#HDBIT,SWWRD		; FILENAME HEADER?
	BEQ	COPYRT			; NO, TRY COPYRIGHT
	MOV	#INPUT,%4		; ADDRESS FDB FILENAME BLK
	MOV	#WSPACE,-(SP)		; AND WORKSPACE
	MOV	(SP),%0			; ADDRESS STORED ON STACK
	JSR	PC,DIRNAM		; FORM DEVICE NAME & UIC
	MOV	(SP),%4			; IN WSPACE
	JSR	PC,DISPLA		; AND PUNCH IT
	MOV	(SP),%0			; READDRESS WORKSPACE
	MOV	#INPUT,%4		; RELOAD FDB POINTER
	JSR	PC,FILNAM		; PUT FILENAME ASCII STRING
	MOV	(SP),%4			; IN WORKSPACE
	JSR	PC,DISPLA		; DISPLAY FILENAME
	MOV	#20.,%0			; 2" BLANK TAPE
	JSR	PC,RUNNUL
	MOV	(SP),%0			; ADDRESS WORKSPACE AGAIN
	JSR	PC,DATIM		; FORM DATE & TIME THERE
	MOV	(SP)+,%4		; ADDRESS ASCII STRING
	JSR	PC,DISPLA		; DISPLAY IT
	MOV	#20.,%0			; BLANK TAPE AGAIN
	JSR	PC,RUNNUL
 
; NOW TEST IF COPYRIGHT MESSAGE REQUIRED.
 
COPYRT:	BIT	#COBIT,SWWRD		; YES?
	BEQ	PCHFIL			; NO, JUST PUNCH FILE
	DIR$	#GTIM			; GET TIME TO BUFFER
	MOV	#WSPACE,%0		; USE WORKSPACE FOR ASCII YEAR
	MOV	BUFFER,%1		; GET YEAR(1ST WORD)
	MOV	#1,%2			; DON'T SUPPRESS LDG ZEROES
	JSR	PC,$CBDMG		; WHEN CONVERTING TO DECIMAL
	MOVB	WSPACE+3,YEAR		; COPY TO YEAR IN
	MOVB	WSPACE+4,YEAR+1		; COPYRIGHT MESSAGE
	MOV	#CPTMS,%4		; ADDRESS COPYRIGHT MESSAGE
	JSR	PC,DISPLA		; AND PUNCH IT
	MOV	#HOLDER,%4		; ADDRESS NAME OF HOLDER
	JSR	PC,DISPLA		; DISPLAY THAT TOO
 
; DONE HEADER(IF ANY). NOW PUNCH FILE ITSELF.
 
PCHFIL:	MOV	#CSMBLK+1,%0		; CLEAR C/SUM BLOCK
	.REPT	4
	CLR	(%0)+
	.ENDR
	MOV	#134.,%0		; LOAD COUNT FOR 13.4" LEADER
	CMP	PYVAL,#SET		; PARITY SET?
	BEQ	LDRSET			; YES, LEADER OF 200'S
	CMP	PYVAL,#ODD		; ALSO IF ODD
	BEQ	LDRSET			; SO THERE IS A RIGHT START
	BIT	#HDBIT!COBIT,SWWRD	; WERE THERE HEADERS?
	BEQ	READ			; NO, NO MORE LEADER REQD
	JSR	PC,RUNNUL		; PUNCH 13" WITH PARITY CLEAR
	BR	READ			; GO READ FILE
LDRSET:	JSR	PC,RUNSET		; PUNCH 13" WITH PARITY SET
 
; READ FILE RECORD-BY-RECORD AND PUNCH IT OUT.
 
READ:	GET$	#INPUT			; GET RECORD
	BCC	PFILB			; BRANCH IF READ
	CMPB	#IE.EOF,INPUT+F.ERR	; END-OF-FILE?
	BEQ	EOF			; CAN HANDLE THAT
	JSR	PC,ERRMES		; BUT NOTHING ELSE
	INPERR				; PRINT "INPUT ERROR"
	BR	EOF			; AND TREAT AS E-O-F
PFILB:	MOV	INPUT+F.NRBD,%4		; FETCH NO OF BYTES
	MOVB	#15,BUFFER(%4)		; FINISH WITH CR
	MOVB	#12,BUFFER+1(%4)	; AND LF
	CMPB	(%4)+,(%4)+		; 2 MORE BYTES
	MOV	%4,COUNT		; FOR COUNT
	JSR	PC,OUTPUT		; PUNCH IT
	BCC	10$			; BRANCH IF OK
	MOV	#EX$ERR,EXSTAT		; ELSE SET ERROR FLAG
	BR	EOF2			; AND GIVE UP ON PUNCH ERROR
10$:	JSR	PC,CMPCSM		; ADD C/SUM FOR THIS BLOCK
	BR	READ			; AND GO BACK FOR MORE
 
; END-OF-FILE(OR ERROR).
 
EOF:	BIT	#ETBIT,SWWRD		; E.O.F. BYTE REQD?
	BEQ	EOF1			; NO, BRANCH
	MOVB	ENDBYT,%0		; ELSE GET THE END BYTE
	BIC	#177740,%0		; AS A CONTROL CODE
	MOVB	%0,BUFFER		; COPY TO BUFFER
	MOV	#1,COUNT		; 1 BYTE COUNT
	JSR	PC,OUTPUT		; SEND IT
	JSR	PC,CMPCSM		; INCLUDE END BYTE IN C/SUM
; PUNCH 8 BYTES OF CHECKSUM PRECEDED BY 377.
	MOV	#100.,%0		; AND 10" RUNOUT
	JSR	PC,RUNOUT
	QIOW$C	IO.WLB,3,3,,IOSTAT,,<CSMBLK,9.> ; CHECKSUM FROM BLOCK
	JSR	PC,PCHCHK		; CHECK THAT IT WORKED
EOF1:	CMP	PYVAL,#CLEAR		; DO WE REQUIRE A PARITY SET
	BEQ	EOF2			; LEADER?
	CMP	PYVAL,#EVEN		; NOT IF PARITY IS EVEN
	BEQ	EOF2			; OR CLEAR
	MOV	#134.,%0		; ELSE MUST SEND
	JSR	PC,RUNSET		; TRAILER OF 200'S
EOF2:	QIOW$C	IO.DET,3,3,,IOSTAT	; DETACH PUNCH
	JSR	PC,PCHCHK		; CHECK FOR FAILURE
	BITB	#SPBIT,SWWRD		; SPOOL <INFILE> TO LP: ?
	BEQ	EOF3			; NO, JUST CLOSE IT
	PRINT$	#INPUT			; ELSE START THE SPOOLER
	BCC	EOFX			; WHICH CLOSES FILE
	JSR	%5,ERRMES		; UNLESS
	SPLERR				; "SPOOL FAILED"
EOF3:	BIT	#DEBIT,SWWRD		; DELETE?
	BEQ	EOF4			; NO, JUST CLOSE
	TST	PUNERR			; ANY ERRORS ON THIS FILE?
	BNE	NODEL			; YES, DON'T DELETE
	DELET$	#INPUT			; NO, OK TO CLOSE & DELETE
	BCC	EOFX			; GO FOR ANOTHER FILE IF OK
NODEL:	JSR	%5,ERRMES		; NOT DELETED -- REPORT ERROR
	NOTDEL				; AND CLOSE ANYWAY
EOF4:	CLOSE$	#INPUT			; CLOSE THE INPUT FILE
EOFX:	JMP	NEWFIL			; GO FOR ANOTHER
 
	.PAGE
; SUBROUTINES
; ***********
 
; GET CURRENT FILENAME FROM BLOCK ADDRESSED BY %4 AS AN ASCII STRING IN
; THE AREA ADDRESSED BY %0.
 
; SUBROUTINE DIRNAM GETS DEVICE & UIC, DESTROYS %1-%4
 
DIRNAM:	MOV	N.DVNM+F.FNB(%4),(%0)+	; COPY DEVICE NAME(ASCII)
	MOV	N.UNIT+F.FNB(%4),%1	; GET UNIT NO.
	CLR	%2			; SUPPRESS LEADING ZEROES
	JSR	PC,$CBOMG		; CONVERT TO OCTAL ASCII
	MOVB	#':,(%0)+		; PUT IN A ':'
	MOV	F.DSPT(%4),%2		; GET DATASET DESCRIPTOR POINTER
	MOV	4(%2),%1		; ITS 3RD WORD, IF NON-ZERO
	BEQ	6$			; CONTAINS NO OF BYTES IN UIC
	MOV	6(%2),%2		; THEN 4TH WORD->STRING
5$:	MOVB	(%2)+,(%0)+		; COPY DIRECTORY STRING
	SOB	%1,5$			; OF %1 BYTES
	CLRB	(%0)+			; FINISH WITH NULL
	RTS	PC			; AND EXIT
; IF NO UIC DEFINED, GET THE DEFAULT
6$:	JSR	PC,.RDFUI		; FETCH TO %1
	MOV	%1,%3			; COPY TO %3
	CLR	%4			; SUPPRESS LDG ZEROES, ADD [,]
	MOV	%0,%2			; %2->AREA
	JSR	PC,.PPASC		; CONVERT UIC TO ASCII
	CLRB	(%2)+			; FINISH WITH NULL
	RTS	PC			; AND EXIT
 
; FILNAM GET FILENAME ITSELF, DESTROYS %1
 
FILNAM:	MOV	N.FNAM+F.FNB(%4),%1	; GET 1ST 3 CHARS OF FILENAME
	BEQ	10$			; BRANCH IF NULL FILENAME
	JSR	PC,$C5TA		; CONVERT RADIX-50 TO ASCII
	MOV	N.FNAM+2+F.FNB(%4),%1	; GET NEXT 3 CHARS
	BEQ	10$
	JSR	PC,$C5TA		; CONVERT TO ASCII
	MOV	N.FNAM+4+F.FNB(%4),%1	; GET LAST 3 CHARS
	BEQ	10$			; FINISHED IF NULL
	JSR	PC,$C5TA		; ELSE CONVERT
10$:	CMPB	#' ,-(%0)		; TRIM TRAILING SPACES
	BEQ	10$			; FROM FILENAME
	INC	%0			; ADDRESS NEXT SPACE
	MOVB	#'.,(%0)+		; PUT IN A '.'
	MOV	N.FTYP+F.FNB(%4),%1	; FETCH FILE TYPE
	BEQ	30$			; BRANCH IF NONE
	JSR	PC,$C5TA		; RADIX-50 AGAIN
20$:	CMPB	#' ,-(%0)		; TRIM TRAILING BLANKS IN THAT
	BEQ	20$
	INC	%0
30$:	MOVB	#';,(%0)+		; PUT IN A ';'
	MOV	N.FVER+F.FNB(%4),%1	; GET VERSION NO
	CLR	%2			; SUPPRESS LDG ZEROES
	JSR	PC,$CBOMG		; CONVERT VERSION TO OCTAL
	CLRB	(%0)			; END STRING WITH NULL
	RTS	PC			; AND EXIT
 
; GET TIME AND DATE AS AN ASCII STRING IN FORMAT: HH:MM___DD-MMM-YY
 
DATIM:	DIR$	#GTIM			; FORM DATE & TIME IN BUFFER
	MOV	#WSPACE,%0		; ASCII WILL BE IN WSPACE
	MOV	#BUFFER+G.TIHR,%1	; ADDRESS TIME
	MOV	#2,%2			; SELECT HH:MM FORM
	JSR	PC,$TIM			; CONVERT TIME TO STRING
	MOVB	#' ,@%0			; INSERT 3 SPACES
	MOVB	(%0)+,@%0
	MOVB	(%0)+,@%0
	INC	%0
	MOV	#BUFFER+G.TIYR,%1	; ADDRESS DATE
	JSR	PC,$DAT			; CONVERT TO ASCII
	CLRB	(%0)+			; END WITH NULL
	RTS	PC			; AND EXIT
 
; TYPE AN ERROR MESSAGE ON TI:, UNIT 5
 
ERRMES:	CMP	EXSTAT,#EX$SUC		; STILL FLAGGING SUCCESS?
	BNE	MESAGE			; NO, KEEP CURRENT EXIT STATUS
	CLR	EXSTAT			; YES, SET TO EX$WAR=0
	MOV	#EX$ERR,EXSTAT		; SET ERROR EXIT STATUS
MESAGE:	DIR$	#ERRST			; START "PUN -- "
 
; ENTRY TYPE TO TYPE A GENERAL MESSAGE STORED AS:
; <LABEL>:	.WORD	<MESSAGE LENGTH(BYTES)>
;		.ASCII	"<MESSAGE>"
; WHERE <LABEL> IS GIVEN IN THE PARAMETER TO THE JSR %5,TYPE CALL.
 
TYPE:	MOV	(%5),MES		; PARAMETER IS MESSAGE BUFFER
	ADD	#2,MES			; -2 BYTES
	MOV	@(%5)+,MESL		; ALSO BYTE COUNT
	QIOW$S	#IO.WLB,#5,#5,,,,<MES,MESL,#0>	; TYPE ON TI: & WAIT
	RTS	%5			; EXIT FROM ERROR ROUTINE
MES:	0				; MESSAGE ADDRESS
MESL:	0				; MESSAGE LENGTH
 
; PRODUCE %0 NULL CHARACTERS IN APPROPRIATE PARITY.
; N.B. BUFFER IS DESTROYED!
 
RUNOUT:	CMP	PYVAL,#SET		; PARITY SET?
	BEQ	RUNSET			; YES, SEND 200'S
	CMP	PYVAL,#ODD		; OR ODD
	BNE	RUNNUL			; CLEAR OR EVEN IS NULLS
RUNSET:	MOVB	#200,%1			; 200 TO SET PARITY
	BR	RUNFIL			; GO FILL BUFFER
RUNNUL:	CLR	%1			; JUST CLEAR FOR NULLS
RUNFIL:	MOV	%0,COUNT		; LOAD COUNTER
	MOV	#BUFFER,%3		; AND BUFFER POINTER
RUNLP:	MOVB	%1,(%3)+		; COPY RUNOUT CHARS
	SOB	%0,RUNLP		; %0 OF THEM
	JMP	PUNCH			; GO PUNCH BUFFER AND EXIT
 
; COMPUTE ADDITIONS TO LONGITUDINAL CHECKSUM FOR BUFFER
; THE CHECKSUM BLOCK CONSISTS OF 8 BYTES BEING THE SUM, OVERFLOWS
; IGNORED OF EACH BIT SET LONGITUDINALLY DOWN THE ENTIRE TAPE.
 
CMPCSM:	TSTB	ENDBYT			; IS THERE AN END BYTE?
	BEQ	CSUMX			; CAN'T PRODUCE C/SUM IF NOT
	MOV	COUNT,%4		; ELSE, FETCH COUNT
	MOV	#BUFFER,%3		; ADDRESS BUFFER
10$:	MOV	#CSMBLK+1,%5		; AND C/SUM BLOCK
	MOV	#8.,%2			; LOAD BITS COUNTER
	MOVB	(%3)+,%1		; FETCH BYTE
20$:	ROLB	%1			; SHIFT OUT BITS, HI FIRST
	ADCB	(%5)+			; ADD TO C/SUM
	SOB	%2,20$			; COUNT THROUGH BITS
	SOB	%4,10$			; AND BUFFER
CSUMX:	RTS	PC			; EXIT
 
; PUNCH THE BUFFER WHICH CONTAINS COUNT BYTES.
 
OUTPUT:	CMP	PYVAL,#CLEAR		; PARITY CLEAR?
	BEQ	PUNCH			; NO ACTION IF PARITY CLEAR
	MOV	COUNT,%4		; ELSE LOAD COUNT
	MOV	#BUFFER,%3		; AND BUFFER POINTER
	CMP	PYVAL,#SET		; PARITY SET?
	BNE	20$			; NO, TRY ODD/EVEN
11$:	BISB	#200,(%3)+		; SET PARITY BIT
	SOB	%4,11$			; FOR ALL BYTES
	BR	PUNCH			; THEN PUNCH BUFFER
20$:	CMP	PYVAL,#EVEN		; EVEN PARITY?
	BNE	30$			; NO, TRY ODD
21$:	CLR	%0			; FOR EVEN, CLEAR COUNT AND CARRY
	JSR	PC,PARITY		; COMPUTE PARITY
	SOB	%4,21$			; FOR ALL BUFFER
	BR	PUNCH			; AND EXIT TO PUNCH
30$:	CMP	PYVAL,#ODD		; MUST BE ODD
	BNE	40$			; ERROR IF NOT
22$:	CLR	%0			; CLEAR COUNT
	SEC				; BUT SET CARRY
	JSR	PC,PARITY		; FOR PARITY TO BE ODD
	SOB	%4,22$			; AND LOOP THROUGH BUFFER
	BR	PUNCH			; THEN PUNCH
; ILLEGAL PARITY SPECIFIER -- REPORT 1ST TIME, BUT TREAT AS PY:CLEAR
40$:	JSR	%5,ERRMES		; ERROR MESSAGE
	ILLPAR				; "ILLEGAL PARITY"
	MOV	#CLEAR,PYVAL		; SET DEFAULT CLEAR
 
; PUNCH OUT BUFFER.
; PCHCHK IS AN ALTERNATIVE ENTRY POINT CALLED BY ATTACH AND DETACH FUNCTIONS
; TO TEST WHETHER THEY WORKED.  THE TASK WILL SUBSEQUENTLY EXIT WITH A WARNING
; (EX$WAR) IF ANY ERROR IS REPORTED.
 
PUNCH:	QIOW$S	#IO.WLB,#3,#3,,#IOSTAT,,<#BUFFER,COUNT>  ; SEND THE DATA
PCHCHK:	TSTB	IOSTAT			; SUCCESS?
	BPL	PUNCHX			; YES, EXIT
	JSR	%5,ERRMES		; NO, PRINT MESSAGE
	PCHERR
	INC	PUNERR			; SET ERROR COUNT <> 0
	SEC				; FLAG ERROR IN CARRY
PUNCHX:	RTS	PC			; RETURN ANYWAY
 
; COUNT BITS SET IN BYTE ADDRESSED BY %3 AND ADJUST FOR REQUIRED PARITY.
; INITIAL SETTING OF CARRY DETERMINES WHETHER RESULT WILL BE EVEN
; (CARRY CLEAR) OR ODD (CARRY SET).
 
PARITY:	MOVB	(%3),%1			; FETCH BYTE
10$:	ADC	%0			; ADD CARRY TO COUNT
	RORB	%1			; SHIFT OUT NEXT BIT(CARRY IS CLEAR)
	BNE	10$			; LOOP UNTIL ALL BITS DONE
	ADC	%0			; DON'T FORGET THE LAST
	ASR	%0			; TEST BIT 0 OF COUNT
	BCC	20$			; PARITY OK IF CLEAR
	BISB	#200,(%3)		; ELSE MUST SET IT
20$:	INC	%3			; ADVANCE POINTER ANYWAY
	RTS	PC			; AND EXIT
 
; CONVERT STRING ADDRESSED BY %4 TO A LEGIBLE TAPE HEADER IN BUFFER.
; SET UP COUNT FOR PUNCHING.
 
DISPLA:	MOV	#BUFFER,%3		; %3->DESTINATION
DSPLP:	MOVB	(%4)+,%0		; FETCH CHAR
	BEQ	DSPEX			; NULL IS TERMINATOR
	JSR	PC,DSPCHR		; DISPLAY CHAR
	BR	DSPLP			; LOOP FOR MORE
DSPEX:	MOV	%3,COUNT		; AT END, COMPUTE COUNT
	SUB	#BUFFER,COUNT		; OF BYTES
	JMP	PUNCH			; PUNCH BUFFER AND EXIT
 
; CONVERT ASCII CHARACTER TO A LEGIBLE TAPE HEADER CHARACTER OF 5 BYTES
; + A NULL SPACER. PATTERNS ARE SUPPLIED FOR CHARACTERS WITH ASCII
; CODES IN RANGE 040-137.
 
DSPCHR:	CMPB	%0,#' ;			; <' '?
	BGE	10$			; MUST TEST FOR CONTROLS
	MOVB	#' ,%0			; CHANGING TO SPACES
	BR	20$
10$:	CMPB	%0,#'_			; '_' IS HIGHEST CATERED FOR
	BLE	20$			; BRANCH IF IN RANGE
	BICB	#40,%0			; ELSE CHANGE LC->UC
20$:	BIC	#177600,%0		; STRIP PARITY & UPPER BYTE
	MOV	%0,-(SP)		; MPY BY 5
	ASL	%0
	ASL	%0
	ADD	(SP)+,%0		; BY SHIFT & ADD
	ADD	#CHRTAB-160.,%0		; AS TABLE POINTER
	.REPT	5			; USE TO COPY 5 BYTES
	MOVB	(%0)+,(%3)+
	.ENDR
	CLRB	(%3)+			; FINISH WITH NULL SPACER
	RTS	PC			; AND EXIT
 
; TABLE TO FORM 5X8 CHARACTERS:
 
	.NLIST	BEX
CHRTAB:	.BYTE	0,0,0,0,0		; SPACE
	.BYTE	0,337,337,0,0		; !
	.BYTE	0,7,0,7,0		; "
	.BYTE	44,377,44,377,44	; #
	.BYTE	206,211,377,211,161	; $
	.BYTE	203,143,30,304,303	; %
	.BYTE	140,226,231,216,340	; &
	.BYTE	0,0,7,0,0		; '
	.BYTE	0,74,102,201,0		; (
	.BYTE	0,201,102,74,0		; )
	.BYTE	211,112,377,112,211	; *
	.BYTE	10,10,176,10,10		; +
	.BYTE	260,160,0,0,0		; ,
	.BYTE	0,10,10,10,0		; -
	.BYTE	140,140,0,0,0		; .
	.BYTE	200,140,30,4,3		; \
	.BYTE	176,241,211,205,176	; 0
	.BYTE	0,202,377,200,0		; 1
	.BYTE	302,241,221,211,206	; 2
	.BYTE	102,211,211,211,166	; 3
	.BYTE	37,20,374,20,20		; 4
	.BYTE	117,211,211,211,161	; 5
	.BYTE	176,211,211,211,160	; 6
	.BYTE	301,41,21,11,7		; 7
	.BYTE	166,211,211,211,166	; 8
	.BYTE	106,211,211,211,176	; 9
	.BYTE	146,146,0,0,0		; :
	.BYTE	266,166,0,0,0		; ;
	.BYTE	10,20,14,102,101	; <
	.BYTE	0,44,44,44,0		; =
	.BYTE	201,102,44,200,10	; >
	.BYTE	2,271,11,11,6		; ?
	.BYTE	176,201,235,223,116	; @
	.BYTE	374,22,21,22,374	; A
	.BYTE	377,211,211,211,166	; B
	.BYTE	176,201,201,201,102	; C
	.BYTE	377,201,201,201,176	; D
	.BYTE	377,211,211,211,201	; E
	.BYTE	377,11,11,11,1		; F
	.BYTE	176,201,261,221,162	; G
	.BYTE	377,10,10,10,377	; H
	.BYTE	0,201,377,201,0		; I
	.BYTE	100,200,201,177,1	; J
	.BYTE	377,10,34,42,301	; K
	.BYTE	377,200,200,200,200	; L
	.BYTE	377,2,4,2,377		; M
	.BYTE	377,4,10,40,377		; N
	.BYTE	176,201,201,201,176	; O
	.BYTE	377,11,11,11,6		; P
	.BYTE	176,201,241,101,276	; Q
	.BYTE	377,11,31,51,306	; R
	.BYTE	206,211,211,211,161	; S
	.BYTE	1,1,377,1,1		; T
	.BYTE	177,200,200,200,177	; U
	.BYTE	37,140,200,140,37	; V
	.BYTE	377,100,40,100,377	; W
	.BYTE	343,34,10,34,343	; X
	.BYTE	3,4,370,4,3		; Y
	.BYTE	301,241,221,211,207	; Z
	.BYTE	0,377,201,201,0		; [
	.BYTE	3,4,30,140,200		; /
	.BYTE	0,201,201,377,0		; ]
	.BYTE	4,2,377,2,4		; ^
	.BYTE	40,160,250,40,40	; <- (_)
	.EVEN
	.PAGE
	.LIST	BEX
 
; FILE AND CSI HANDLING DEFINITIONS:
 
	FSRSZ$	2			; SPACE FOR 2 FILES OPEN
INPUT:	FDBDF$				; ALLOCATE FDB SPACE
	FDRC$A	,BUFFER,132.		; RECORD ACCESS BY DEFAULT
	FDOP$A	2,CSIBLK+C.DSDS,DEFINP,FO.RD ; FILE OPEN SECTION
DEFINP:	NMBLK$	INPUT,TXT,0,SY,0	; DEFAULT FILE SY:INPUT.TXT;0
; CSI HANDLING MACROS.
	CSI$				; DEFINITIONS
CSIBLK:	.BLKB	C.SIZE
	.EVEN
	GCMLD$				; DEFINITIONS
GC:	GCMLB$	1,PUN			; INIT GCML CONTROL BLOCK
; COMMAND SWITCH TABLE
SWTAB:	CSI$SW	HD,HDBIT,SWWRD,SET,NEG	; TAPE HEADER
	CSI$SW	CO,COBIT,SWWRD,SET,NEG	; COPYRIGHT NOTICE
	CSI$SW	PY,PYBIT,SWWRD,SET,NEG,PYDES ; PARITY
	CSI$SW	ET,ETBIT,SWWRD,SET,NEG,ETDES ; E-O-T BYTE
	CSI$SW	SP,SPBIT,SWWRD,SET,NEG	; SPOOL
	CSI$SW	DE,DEBIT,SWWRD,SET,NEG	; DELETE
	CSI$SW	LA,LABIT,SWWRD,SET,NEG	; LATCH
	CSI$ND
 
HDBIT=^B00000001	; BIT MASK DEFINITIONS
COBIT=^B00000010
PYBIT=^B00000100
ETBIT=^B00001000
SPBIT=^B00010000
DEBIT=^B00100000
LABIT=^B10000000
SWWRD:	ETBIT!HDBIT!PYBIT		; SWITCH WORD
; SWITCH DESCRIPTORS.
PYDES:	CSI$SV	ASCII,PYVAL,2		; PARITY -- ASCII SWITCH
	CSI$ND
ETDES:	CSI$SV	ASCII,ENDBYT,1		; EOT -- ALSO ASCII
	CSI$ND
CLEAR="CL	; LEGAL SWITCH VALUES
SET="SE
ODD="OD
EVEN="EV
PYVAL:	.WORD	EVEN			; DEFAULT EVEN
PUNERR:	.WORD	0			; COUNT ERRORS ON THIS FILE
ENDBYT:	.BYTE	'Z			; DEFAULT CONTROL/Z
	.EVEN
GTIM:	GTIM$	BUFFER			; GET TIME TO BUFFER
IOSTAT:	.BLKW	2			; PUNCH IO STATUS BLOCK
EXST:	EXST$	EX$SUC			; EXIT STATUS DPB -- DEFAULT SUCCESS
EXSTAT=EXST+E.XSTS
ERRST:	QIOW$	IO.WLB,5,5,,,,<ERRSTM,10.,0>
ERRSTM:	.ASCII	<15><12><7>"PUN -- "
; CHECKSUM BLOCK, RESERVE 8 BYTES PRECEDED BY 377
	.ODD				; 377 IS AT ODD ADDRESS
CSMBLK:	.BYTE	377,0,0,0,0,0,0,0,0	; FOR A FAST CLEAR BY WORDS
	.EVEN
COUNT:	0				; BUFFER COUNT
 
; MESSAGE STRINGS
 
	.MACRO	.MESAG	STRING,LABEL,?ENDMES
LABEL:	.WORD	ENDMES-LABEL-2
	.ASCII	"STRING"
ENDMES:	.EVEN
	.ENDM
 
	.LIST	ME
	.NLIST	BEX
	.MESAG	<Command error>,COMERR
	.MESAG	<Illegal switch>,ILLSWT
	.MESAG	<File open failure>,OPNFLD
	.MESAG	<Input error>,INPERR
	.MESAG	<Illegal parity>,ILLPAR
	.MESAG	<Spool failed>,SPLERR
	.MESAG	<Not deleted>,NOTDEL
	.MESAG	<Waiting for PP0:>,WAITNG
	.MESAG	<Device error>,PCHERR
 
; COPYRIGHT NOTICE
CPTMS:	.ASCII	"COPYRIGHT (C) 19"
YEAR:	.ASCIZ	"00 "
; N.B. COPYRIGHT HOLDER NAME MUST BE <22 CHARACTERS.
HOLDER:	.ASCIZ	"SIRA LTD."
.IIF GT .-HOLDER-22. .ERROR 		; NAME TOO LONG
	.EVEN
	.LIST	BEX
	.NLIST	ME
 
BUFFER:	.BLKB	134.			; I/O BUFFER, 132. CHARS + CR + LF
WSPACE:	.BLKB	40.			; WORKSPACE FOR CONVERSIONS
 
 
	.END	START