.enabl	lc
	.title	SCCartridge Init

	.mcall	.lookup,.exit,.gtlin,.close,.spfun,.print,.date
	.mcall	.dstatus,.fetch
	.MACRO	TYPE,TEXT
	.PRINT	#TEMP$
TEMP1$=.
.=TEMP$
	.ASCIZ	@TEXT@
TEMP$=.
MESLN$=TEMP$-TEMP0$
.=TEMP1$
	.ENDM
;
;TYPEN	-	Like type, but with no cr-lf
;
	.MACRO	TYPEN,TEXT
	.PRINT	#TEMP$
TEMP1$=.
.=TEMP$
	.ASCII	@TEXT@ <200>
TEMP$=.
MESLN$=TEMP$-TEMP0$
.=TEMP1$
	.ENDM
	.page

start:	.gtlin	#linbuf,#mesyn

	cmpb	#'Y,linbuf
	beq	10$
	cmpb	#'y,linbuf
	beq	10$

	.exit

10$:	.dstatus #scdat,#scdev		;get SC: information
	bcc	15$			;at least it exists!

14$:	type	<? No Device SC:>
	.exit

15$:	tst	scdat+4			;handler resident?
	bne	16$			;yes

	.fetch	#end,#scdev		;fetch it
	bcs	14$

16$:	.lookup	#area,#0,#filnam,#0
	bcc	17$

5$:	.print	#meserr
	.exit

17$:	.spfun	#area,#0,#366		;initalize the cartridge
	bcs	5$			;error!!

;set up and write out the VOL1 label

	jsr	pc,svol1

	.spfun	#area,#0,#371,#buffer,#256.
	bcs	5$

;HDR1

;first set up the file name

	mov	#xarea,r1		;point at label area

	mov	sysfil,r0		;first 3 character of file name
	call	w50f

	mov	sysfil+2,r0		;second 3
	call	w50f

	movb	#'.,(r1)+		;dot seperator

	mov	sysfil+4,r0		;file extension
	call	w50f

;now set up date, etc

	jsr	pc,shdr1		;now setup HDR1
	jsr	pc,wrsblk		;and write it

;now the file mark

	jsr	pc,wrscfm

;and a filler block, so this zero file will appear normal

	mov	#filler,r1
	mov	#buffer,r2
	mov	#256.,r0

20$:	mov	(r1)+,(r2)+
	sob	r0,20$

	jsr	pc,wrsblk

;eof - add a file mark 

	jsr	pc,wrscfm


	jsr	pc,seof1		;setup EOF1
	jsr	pc,wrsblk		;and write it

	jsr	pc,wrscfm

	.spfun	#area,#0,#372		;rewind the cartridge

	.close	#0

	.print	#mesok
	.exit
	.page

;write a block to the cartridge

wrsblk:	mov	#256.,r4		;set up buffer size

wrsc:	.spfun	#eblok,#0,#371,#buffer,r4
	bcc	10$

	type	<? SC: Write Error>
	.exit

10$:	rts	pc

;write a file mark on the cartridge

wrscfm:	.spfun	#eblok,#0,#377
	bcs	10$
	rts	pc

10$:	type	<? SC: Write File Mark Error>
	.exit

;set up `HDR1` label in the buffer

shdr1:	mov	#label,r1	;point at buffer
	MOV	#"HD,(R1)+
	MOV	#"R1,@R1
	MOV	#0,R2		;file sequence number MUST BE ZERO
				;so that this file will be ignored
				;on any 'DIR' listing.

12$:	mov	#label,R4
	ADD	#FSNASC-LABEL,R4;POINT TO FSN
	MOV	#2,R0
	JSR	PC,BINDEC
	CLR	R2
	ADD	#BLKASC-<FSNASC+4>,R4
	CLR	R0
	JSR	PC,BINDEC
	JSR	PC,DATE

	mov	#label,r1	;move label into buffer
	mov	#buffer,r2
	mov	#lablen,r0

13$:	mov	(r1)+,(r2)+
	sob	r0,13$
	rts	pc

;set up EOF1 label

seof1:	mov	#label,r1

	mov	#"EO,(R1)+
	mov	#"F1,(r1)+

	mov	sysfil,r0		;first 3 characters of file name
	call	w50f

	mov	sysfil+2,r0		;second 3
	call	w50f

	movb	#'.,(r1)+		;dot seperator

	mov	sysfil+4,r0		;extension
	call	w50f

	mov	#blkasc,r4		;point at block number
	mov	r5,r2			;block number in r5
	mov	#0,r0

	jsr	pc,bindec

	jsr	pc,date			;and the date

	mov	#label,r1
	mov	#buffer,r2
	mov	#lablen,r0

10$:	mov	(r1)+,(r2)+		;move label into buffer
	sob	r0,10$

	rts	pc


;set up `VOL1` label in the buffer

svol1:	mov	#volab,r1	;point at volume label
	mov	#buffer,r2	;and at buffer
	jmp	lmove		;and move it in
	rts	pc

;lmove - move ascii data and spaces

lmove:	movb	(r1)+,(r2)+		;move byte
	bne	lmove			;more to move

20$:	tstb	-(r2)			;skip over end of asciz string
	movb	(r1)+,r0		;get number of spaces
	beq	90$			;at the absolute end

25$:	movb	#40,(r2)+
	sob	r0,25$			;all spaces moved?
					;yes
	br	lmove			;move next piece

90$:	rts	pc

;the following routines come from the RT-11 handler `FSM`. Notice the
;standard of the code and the comments! (ps lower case is my additions)
.SBTTL BINARY TO DECIMAL SUBROUTINE
BINDEC:	ADD	PC,R0
	ADD	#DECTBL-.,R0
1$:	MOV	#'0-1,R1
2$:	INC	R1
	SUB	@R0,R2
	BPL	2$
	ADD	(R0)+,R2
	MOVB	R1,(R4)+
	TST	@R0
	BNE	1$
	RTS	PC
DECTBL:	.WORD	10000.,1000.,100.,10.,1,0
	.page
.SBTTL CONVERT AN RT-11 DATE TO YYDDD FORMAT
DATE:	.date	
	mov	r0,r2		;position correctly
	MOV	R2,R1
	ASR	R1
	BIC	#140777,R1
	SWAB	R1
	MOV	PC,R4
	ADD	#MONTAB-.,R4
	ADD	R1,R4
	MOV	@R4,R3
	CMP	R1,#4
	BLE	1$
	BIT	#3,R2
	BNE	1$
	INC	R3
1$:	MOV	R2,R1
	ASR	R1
	ASR	R1
	ASR	R1
	ASR	R1
	ASR	R1
	BIC	#177740,R1
	ADD	R1,R3
	BIC	#177740,R2
	BEQ	2$
	ADD	#72.,R2
2$:	MOV	PC,R4
	ADD	#DAREA-.,R4
	MOV	#6,R0
	JSR	PC,BINDEC
	MOV	R3,R2
	MOV	#4,R0
	JMP	BINDEC
	JAN	=	0
	FEB	=	JAN + 31.
	MAR	=	FEB + 28.
	APR	=	MAR + 31.
	MAY	=	APR + 30.
	JUN	=	MAY + 31.
	JUL	=	JUN + 30.
	AUG	=	JUL + 31.
	SEP	=	AUG + 31.
	OCT	=	SEP + 30.
	NOV	=	OCT + 31.
	NOEL	=	NOV + 30.
MONTAB:	.WORD	0
	.WORD	JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,NOEL
	.page

.sbttl	W50F - Write a RADIX50 word to a string (filename set)
		.If eq 1
Writes to the string pointed to in R1 the Radix50 word contained in R0.
No registers other than R1 are altered.  The unused Radix50 code, 35,
is typed as an "*".  The Radix50 "." is interpreted as the filename
wildcard "%".
		.Endc

W50F::
	MOV	R0,-(SP)
	MOV	R2,-(SP)
	MOV	R3,-(SP)

	CLR	R2		;Force unsigned division for first step.
	MOV	R0,R3		;DIV21 expects dividend in R2,R3 divisor in R0
	MOV	#50,R0
	CALL	DIV21
	CALL	$C50A		; and returns remainder in R0
	MOV	R0,-(SP)

	MOV	#50,R0
	CALL	DIV21		; and quotient in R2 ready for next time.
	CALL	$C50A
	MOV	R0,-(SP)

	MOV	R3,R0
	CALL	$C50A

	MOVB	R0,(R1)+
	MOVB	(SP)+,(R1)+
	MOVB	(SP)+,(R1)+

	MOV	(SP)+,R3
	MOV	(SP)+,R2
	MOV	(SP)+,R0
	RETURN


$C50A:	CALL	C50A
	CMP	R0,#'.		;Convert . to %
	BNE	10$
	MOV	#'%,R0
10$:	RETURN

.SBTTL DIV21 - Signed <double-precision>/<single-precision> integer divide
		.if eq 1
Called by
	MOV	<hi-ord dividend>,R2
	MOV	<lo-ord dividend>,R3
	MOV	<divisor>,R0
	CALL	DIV21
Returns
	R2/hi-order quotient
	R3/lo-order quotient
	R0/remainder

If divide-by-zero is attempted, the arguments are unaltered, and both
C (carry) and V (overflow) are set.  Normally carry is clear on return.
		.endc
DIV21::
	MOV	R0,-(SP)	;Quotient gets XOR of signs
	BEQ	70$		;Whoops - don't like this!
	BGT	10$
	NEG	R0		;But work internally with positive numbers
10$:	BIC	#77777,(SP)
	ADD	R2,(SP)

	MOV	R2,-(SP)
	BGE	20$
	NEG	R2
	NEG	R3
	SBC	R2
20$:
	MOV	#32.,-(SP)
	MOV	R0,-(SP)	;Save on stack for subtractions
	CLR	R0
30$:
	ASL	R3
	ROL	R2
	ROL	R0
	CMP	R0,(SP)
	BLO	40$
	SUB	(SP),R0		;Subtract out as shift numbers across
	INC	R3		; and mark subtraction in quotient
40$:
	DEC	2(SP)
	BGT	30$

	CMP	(SP)+,(SP)+

	TST	(SP)+
	BGE	50$
	NEG	R0		;Remainder gets sign of dividend
50$:
	TST	(SP)+
	BGE	60$
	NEG	R2
	NEG	R3
	SBC	R2
60$:
	.WORD	CLC!CLV
	RETURN

70$:
	TST	(SP)+
	.WORD	SEC!SEV		;Set both error flags
	RETURN

.sbttl	C50A - Convert Radix50 char to Ascii
		.If eq 1
Expects a Radix50 character in R0.  Returns the corresponding Ascii value
in R0, destroying no other registers.  The unassigned Radix50 character,
35, is returned as "*", and any illegal value is returned as "?".
		.Endc

C50A::
	TST	R0		;Null=space
	BEQ	30$
	CMP	R0,#50		;Check range
	BHIS	40$
	CMP	R0,#35		;Check for unassigned character
	BEQ	50$

	CMP	R0,#34		;Dot
	BEQ	60$

	CMP	R0,#33
	BLT	20$
	BEQ	10$
	ADD	#22-11,R0	;Numeric
10$:	ADD	#11-100,R0	;Dollar sign
20$:	ADD	#100-40,R0	;Alpha
30$:	ADD	#40,R0		;Space
	RETURN

40$:	MOV	#'?,R0
	RETURN
50$:	MOV	#'*,R0
	RETURN
60$:	MOV	#'.,R0
	RETURN
	.page

;HDR label

dummy	=	0
SPACE	=	40
LABEL:	.ASCII	/HDR1/
XAREA:	.REPT	9.
	.BYTE	DUMMY
	.ENDR
	.REPT	8.
	.BYTE	SPACE
	.ENDR
	.ASCII	/RT11A /
	.ASCII	/0001/
FSNASC:	.BYTE	DUMMY,DUMMY,DUMMY,DUMMY
	.ASCII	/0001/
	.ASCII	/00/
	.BYTE	SPACE
DAREA:	.REPT	5
	.BYTE	DUMMY
	.ENDR
	.ASCII	/ 00000/
	.ASCII	/ /
	.ASCII	/0/
BLKASC:	.BYTE	DUMMY,DUMMY,DUMMY,DUMMY,DUMMY
SYSCOD:	.ASCII	/DECRT11A /
	.REPT	11.
	.BYTE	SPACE
	.ENDR
	.EVEN
lablen	=	<.-label>/2	;length of label, in words

;file name to write

sysfil:	.rad50	/ZEROEDFIL/

linbuf:	.blkb	82.

eblok:
area:	.blkw	10.


mesyn:	.ascii	@SC0:/Initialize; Are you sure? @
	.byte	200

meserr:	.asciz	/? Cannot Initialize SC0:/

Mesok:	.asciz	/SC0: Initialized/
	.even

scdev:
filnam:	.rad50	/sc /
	.word	0,0,0
scdat:	.blkw	10.
crlf:	.asciz	/ /

	.even

;VOLUME label

VOLAB:	.asciz	/VOL1RT11A/
	.byte	28.			;28 spaces
	.asciz	/D%B/
	.byte	10.
	.asciz	/1/
	.byte	28.
	.asciz	/3/
	.byte	0			;end of label

;I/O buffer

buffer:	.blkb	512.

;filler block

filler:
	.rept	256.
	.ascii	/  /
	.endr
.page
	.SBTTL	Type Area
;
TEMP0$	=	.
TEMP$	=	.
	.BLKB	MESLN$
	.EVEN
;
end	=	.		;end of program, for `.fetch`
	.end	start