	.title	minprm
	.sbttl	start
;+
;	initialization routine for the software tools runtime system
;-
ap=%5
blank=40		; ascii for BLANK
	.mcall	exst$s,alun$s,srda$s,fdof$l,wtse$s,gtsk$s
	fdof$l
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
fmttsk:	.asciz	"%2r"
errmsg:	.asciz	"Cannot open ERROUT."
felmsg:	.asciz	"felled."
	.even
	.dsabl	lc
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
initst::
initr4::
	sub	#32.,sp			; make room for gtsk buffer on stack
	mov	sp,r0			; save address
	gtsk$s	r0			; get task parameters
	mov	g.tsts(r0),r$enda	; save last virtual address
	mov	r0,-(sp)		; set up call to sprint
	mov	#fmttsk,-(sp)		; ...
	mov	#r$tknm,-(sp)		; ...
	clr	-(sp)			; ...
	mov	sp,ap			; ...
	call	sprint			; format task name into r$tknm
	add	#40.,sp			; restore stack
	mov	#r$dbst,r5		; start of pointer array
	clr	r2			; lun 0
10$:
	cmp	r5,#r$dbnd		; done?
	beq	20$			; YES
	inc	r2			; next lun value
	call	$fchnl			; get FFDB address in r0
	bcs	20$			; c set => invalid lun
	add	#d.fdb,r0		; now have FDB address
	mov	(r5)+,r1		; RFDB address
	mov	r0,r.fdb(r1)		; store away FDB address
	movb	r2,r.lun(r1)		; and lun
	br	10$
20$:
	mov	r2,r$endl		; save lun for later
	call	r$gefn			; get a free event flag
	mov	r0,r$ioef		; store it for use in qio's
	call	r$gefn			; get a free event flag
	mov	r0,r$spef		; store it for use in spwn calls
	srda$s	#rcdast			; establish receive data AST
	call	makarg			; get arguments
	call	ttyatt			; attach terminal for ^O
	mov	r$erdb,r1		; ERROUT RFDB address
	mov	#r$erac,-(sp)		; address of ERROUT access
	mov	r$erfl,-(sp)		; address of ERROUT file spec
	clr	-(sp)			; dummy # of arguments
	mov	sp,ap			; place address in arg pointer
	call	r$cref			; open the file
	bcs	baderr			; cannot open ERROUT
	mov	r$indb,r1		; STDIN RFDB address
	mov	r$infl,2(ap)		; address of STDIN filespec
	mov	#r$inac,4(ap)		; address of STDIN access
	call	r$opnf			; open the file
	bcs	nbderr			; cannot open STDIN
	mov	r$oudb,r1		; STDOUT RFDB address
	mov	r$oufl,2(ap)		; address of STDOUT filespec
	mov	#r$ouac,4(ap)		; address of STDOUT access
	call	r$cref			; create the file
	bcs	nbderr			; cannot open STDOUT
	add	#6,sp			; restore stack
	return
;
;
;
endst::
endr4::
r$exit::
	tstb	r$fgpc			; foreground process active?
	beq	25$			; NO
	mov	#r$fgpc,r0		; address of pid
	call	r$kill			; kill the bugger
	wtse$s	r$spef			; wait for it to die
25$:
	mov	#r$dbst,r4		; start of array of pointers
30$:
	cmp	r4,#r$dbnd		; done?
	beq	40$			; YES
	mov	(r4)+,r1		; get RFDB address into r1
	call	r$clsf			; close the file if open
	br	30$			; go again
40$:
	mov	#ex$suc,r0		; assume successful exit
	tst	(ap)			; called with any arguments?
	beq	50$			; NO, exit
	cmp	@2(ap),#ok		; endst(OK)?
	beq	50$			; YES
	cmp	@2(ap),#err		; endst(ERR)
	beq	45$			; YES
	mov	#felmsg,r0		; address of felled message
	call	r$ermo			; output to user's terminal
45$:
	mov	#ex$sev,r0		; severe error
50$:
	exst$s	r0			; exit to RSX/IAS
;
;	receive data AST address
;
rcdast:
	mov	#eof,-(sp)		; endst(EOF)
	mov	sp,r0			; address of EOF
	mov	r0,-(sp)		; in call block
	mov	#1,-(sp)		; one arg
	mov	sp,ap			; ...
	jmp	r$exit			; exit
baderr:
	mov	#errmsg,r0		; address of error message
	call	r$ermo			; output to user's terminal
	br	45$			; exit
nbderr:
	call	cant			; cannot open file
	.page
	.sbttl	alun
;+
;	dsw = alun(lun, dev, unit)
;-
lun=2
dev=4
unit=6
ap=%5
;
;
	.mcall	alun$s
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
alun::
	mov	dev(ap),r0			; address of device string
	movb	(r0)+,-(sp)			; copy to stack
	movb	(r0),1(sp)			; copy to stack
	mov	(sp)+,r1			; place in register
	bic	#<40+<40*256.>>,r1		; make upper case
	alun$s	@lun(ap),r1,@unit(ap)		; assign lun
	mov	@#$dsw,r0			; return DSW
	return
	.page
	.sbttl	cant
;+
;	subroutine cant(file)
;-
ap=%5
buf=2
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
cbuf:	.asciz	" - cannot open."<12>
	.dsabl	lc
	.even
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
cant::
	mov	r$erdb,r1		; ERROUT RFDB address
	call	r$lput			; output the file spec
	mov	#cbuf,-(sp)		; place address in call block
	clr	-(sp)			; dummy arg count
	mov	sp,ap			; place in arg pointer
	call	r$lput			; output the line
	cmp	(sp)+,(sp)+		; clean stack
	mov	#err,-(sp)		; endst(ERR)
	mov	sp,r0			; address of ERR
	mov	r0,-(sp)		; in call block
	mov	#1,-(sp)		; one arg
	mov	sp,ap			; set up arg ptr
	jmp	r$exit			; done
	.page
	.sbttl	close
;+
;	call close(int)
;
;	closes the file, flushing the last record if opened for output
;-
ap=%5
int=2
;
;
	.mcall	close$
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
close::
	mov	@int(ap),r0		; rat4 unit number
	call	r$gfbk			; get RFDB address in r1
	bcs	100$			; c set => invalid unit number
r$clsf::
	bit	#rf.clo,(r1)		; is the file opened?
	bne	100$			; NO, nothing to do
	bit	#rf.mod,(r1)		; output mode?
	bne	10$			; NO
	tst	r.byte(r1)		; any bytes left to flush?
	beq	10$			; NO
	movb	#newlin,r3		; place NEWLINE character in register
	call	r$cput			; flush the buffer
10$:
	mov	r.fdb(r1),r0		; FDB address in r0
	close$				; close the file
	mov	#rf.clo,(r1)		; mark the file as closed
100$:
	return
	.page
	.sbttl	create
;+
;	int = create(ext, access)
;
;	creates a file specified by ext at access
;	if the file exists, open it. otherwise create it
;
;	if error occurs, returns ERR
;-
ap=%5
ext=2
access=4
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
create::
	call	r$gffb			; get a free RFDB address in r1
	bcs	100$			; c set => error
r$cref::
	bic	#rf.old,(r1)		; wish to create a file
	call	r$opfl			; general open file routine
	return
100$:
	mov	#err,r0			; return ERR
	return
	.page
	.sbttl	ctoo
;+
;	integer function ctoo(buf)
;-
ap=%5
buf=2
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
ctoo::
	mov	buf(ap),r0		; buffer address
	call	$cotb			; convert to binary
	mov	r1,r0			; return binary number
	return
	.page
	.sbttl	efnsub
;+
;	this pair of routines implement the following fortran interfaces
;
;	integer function getefn()
;	subroutine putefn(event_flag)
;
;	they permit the programmer to request free event flags and to
;	return them when he is done with them.  The domain of these
;	routines is the set of local event flags 1. -> 24.
;	flags 25. -> 32. are listed as reserved for DEC use.
;-
ap=%5
efn=2
err=-3			; error return if no flags available
;
;	global data
;	bits set in these masks indicate flags which are in use
;
	.psect	$r.rwd,con,rw,rel,lcl,d
low:	.word	0		; flags 1. -> 16.
high:	.word	0		; flags 17. -> 24.
;
;	efn = getefn()
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
getefn::
r$gefn::
	mov	#1,r0		; starting efn number
	mov	#16.,r1		; limit for first pass
	mov	#low,r2		; address of efn mask
	call	getbit		; get a free efn
	bcc	10$		; c clear => success
	mov	#24.,r1		; limit for second pass
	mov	#high,r2	; address of efn mask
	call	getbit		; get a free efn
	bcc	10$		; c clear => success
	mov	#err,r0		; return ERR
10$:
	return
;
;	subroutine getbit
;
;	inputs:
;		r0	starting EFN number
;		r1	limit EFN
;		r2	address of relevant EFN mask
;
;	outputs:
;		r0	EFN to return, if success - next EFN to try if not
;		r1	unchanged
;		r2	unchanged
;		c bit	set if error
;		c bit	clear if successful
;
getbit:
	mov	r3,-(sp)	; save r3
	mov	#1,r3		; initialize bit mask
90$:
	cmp	r0,r1		; see if limit exceeded
	bgt	110$		; if r0 > r1, YES
	bit	r3,(r2)		; is the bit set?
	beq	100$		; if == 0, NO - done
	clc			; clear c bit
	rol	r3		; rotate mask bit one left
	inc	r0		; next event flag number
	br	90$		; try next bit
100$:
	bis	r3,(r2)		; set bit to indicate allocation
	clc			; c clear => success
	br	120$
110$:
	sec			; c set => failure
120$:
	mov	(sp)+,r3	; restore r3
	return
;
;	subroutine putefn(efn)
;
putefn::
	mov	@efn(ap),r0	; get EFN to return
r$pefn::
	tst	r0		; test value of efn
	ble	50$		; if <= 0, invalid EFN
	cmp	r0,#24.		; see if too large
	bgt	50$		; if >, invalid EFN
	mov	#low,r1		; assume EFN <= 16.
	cmp	r0,#16.		; is this true?
	ble	20$		; YES
	sub	#16.,r0		; correct for high mask numbers
	mov	#high,r1	; address of mask
20$:
	mov	#1,r2		; initialize bit mask
30$:
	dec	r0		; subtract 1 from counter
	beq	40$		; if == 0, have correct mask bit in r2
	clc			; clear c bit
	rol	r2		; shift one bit left
	br	30$		; try again
40$:
	bic	r2,(r1)		; clear bit to indicate that it is free
50$:
	return
	.page
	.sbttl	r$gfbk - get ratfor file descriptor block
;+
;	call	r$gfbk
;
;	inputs:
;		r0	rat4 unit number
;
;	outputs:
;		r0	unchanged
;		r1	address of RFDB
;		c bit	set if error
;			clear is success
;-
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$gfbk::
	mov	r0,-(sp)		; save r0
	mov	#r$dbst,r0		; start of pointer array
10$:
	cmp	r0,#r$dbnd		; done?
	beq	20$			; YES
	mov	(r0)+,r1		; get address of RFDB
	cmpb	(sp),r.lun(r1)		; is this the correct lun?
	bne	10$			; NO
	clc				; c clear => success
	call	valbuf			; assure valid buffer
	br	30$			; return
20$:
	sec				; c set => failure
30$:
	mov	(sp)+,r0		; restore register
	return
	.page
	.sbttl r$gffb - get a free RFDB for use
;+
;	this routine scans the list of RFDB's for one that is not in use
;	if successful, the RFDB address is returned in r1
;
;	outputs:
;		r1	RFDB address
;		c bit	set if none are available
;		c bit	clear if successful
;-
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$gffb::
	mov	#r$dbst,r0		; address of pointer array
10$:
	cmp	r0,#r$dbnd		; at end of list?
	beq	20$			; YES, error
	mov	(r0)+,r1		; get RFDB address
	bit	#rf.clo,(r1)		; file open?
	beq	10$			; YES, try next RFDB
	clc				; clear c bit for success
	call	valbuf			; assure valid buffer
	br	30$
20$:
	sec
30$:
	return
	.page
	.sbttl	valbuf - validate buffer, and obtain one if not there
;+
;	routine to extend task to obtain a buffer if one is not
;	already allocated
;
;	inputs:
;		r1	RFDB address
;
;	outputs:
;		r0	mangled
;		r1	the same
;		c bit	set if error extending task
;		c bit	clear if successful
;-
	.mcall	extk$s
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
extmsg:	.asciz	"error extending task."
	.dsabl	lc
	.even
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
valbuf:
	tst	r.buf0(r1)		; buffer allocated yet?
	bne	10$			; YES
	extk$s	#10			; extend task by 512. bytes
	bcc	5$			; c clear => success
	mov	#extmsg,r0		; address of error message
	call	r$ermo			; notify user
	sec				; c set => error
	br	10$
5$:
	mov	r$enda,r.buf0(r1)	; store buffer address
	mov	r.buf0(r1),r.bufp(r1)	; initialize buffer pointer
	add	#1000,r$enda		; update task's last address
	clc				; clear c bit
10$:
	return
	.page
	.sbttl	gmcrst
;
;	this routine is called by the runtime initialization routine
;	to get the calling command line.  First, an attempt is made to
;	retrieve a record from the device SR0:, where the command lines
;	from a software tools spawn directive will reside.  Failing this,
;	a GMCR call is made to retrieve a command line from MCR.
;	If this too fails, the user is prompted at the terminal for
;	the remainder of the arguments with a prompt of the form
;
;	args? 
;
;	inputs:
;		r0	258. byte buffer for GMCR and read
;		r1	lun to use in read to SR0:
;
;	outputs:
;		c clear	successfully retrieved command line into buffer
;		c set	no command line found anywhere
;		all registers remain the same
;
;
;
;	macro calls
;
	.mcall	alun$s,qiow$s
;
;
;	defined symbols
;
cr=15				; carriage return
;
;
;
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
psta:	.ascii	"args? "
pstl=.-psta
	.even
	.dsabl	lc
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
gmcrst::
	call	r$savr			; save registers
	tst	(r0)+			; bump address to data area
	call	r$garg			; get args in the tools way
	bcc	30$			; c clear => successful
10$:
	mov	(pc)+,-(r0)		; place emt code in buffer
	.byte	127.,41.		; codes for GMCR
	mov	r0,-(sp)		; place DPB address on stack
	emt	377			; go do it
	bcs	20$			; c set => error
	mov	@#$dsw,r$iosb+2		; place count in local var
	tst	(r0)+			; point at first character
	br	30$			; go finish up
20$:
	mov	#2,r$iosb+2		; initialize to dummy count
	tst	(r0)+			; bump to data area
	movb	#'*,(r0)+		; copy dummy image name
	movb	#' ,(r0)+		; ...
	alun$s	r1,#"TI,#0		; assign lun to TI:
	bcs	30$			; c set -> error
	qiow$s	#io.rpr,r1,r$ioef,,#r$iosb,,<r0,#253.,,#psta,#pstl,#'$>
	bcc	30$			; c clear => OK
	mov	#2,r$iosb+2		; dummy count
30$:
	add	r$iosb+2,r0		; point at terminator loc
	movb	#cr,(r0)		; place terminator in buffer
	clc				; clear c bit for sure
40$:
	return
	.page
	.sbttl	gtddir
;+
;	implements the following fortran subroutine call
;
;	call gtddir(buf, type)
;
ap=%5
buf=2
type=4
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
gtddir::
	cmp	#path,@type(ap)		; PATH?
	bne	1$			; NO
	mov	#r$ddir,r0		; address of def dir
	br	2$
1$:
	mov	#r$duic,r0		; address of def uic string
2$:
	tstb	(r0)			; anything in string?
	bne	10$			; YES
	mov	r0,-(sp)		; save buffer address
	call	.rdfui			; read default UIC
	mov	r1,r3			; need it in r3 for .ppasc
	mov	(sp),r2			; destination address
	clr	r4			; separators and no leading zeroes
	call	.ppasc			; format UIC
	clrb	(r2)			; terminate with EOS
	mov	(sp)+,r0		; restore source address
10$:
	mov	buf(ap),r1		; destination address
20$:
	movb	(r0)+,(r1)+		; copy character
	bne	20$			; if not EOS, do next char
	return
	.page
	.sbttl	jcopys
;+
;	subroutine jcopys(in, i, c, out)
;-
ap=%5
in=2
i=4
c=6
out=10
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
jcopys::
	mov	in(ap),r0		; address of in(1)
	mov	i(ap),r2		; address of i
	dec	(r2)			; decrement i
	add	(r2),r0			; address of in(i)
	mov	out(ap),r1		; address of out(1)
	movb	@c(ap),r3		; terminating character
10$:
	inc	(r2)			; increment i
	movb	(r0),(r1)+		; copy character
	beq	20$			; if == 0, done
	cmpb	(r0)+,r3		; terminating character?
	bne	10$			; NO, do next character
	clrb	(r1)			; terminate with EOS
	inc	(r2)			; bump i past terminating char
20$:
	return
	.page
	.sbttl	kill
;+
;	integer function kill(proces)
;
;	alternate entry - r$kill
;
;	proces address passed in r0
;-
	.mcall	sdat$s,abrt$s
ap=%5
proces=2
	.psect	$r.rwd,con,rw,rel,lcl,d
dots:	.ascii	"..."
pidbuf:	.asciz	"123456"
	.even
task:	.rad50	"123456"
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
kill::
	mov	proces(ap),r0
r$kill::
	mov	r5,-(sp)		; save r5
	mov	#pidbuf,r1			; destination address
	tstb	(r0)			; have a non-null pid?
	bne	10$			; YES
	mov	#r$fgpc,r0		; address of foreground proc
	tstb	(r0)			; is there one active?
	beq	60$			; NO, nothing to do
10$:
	movb	(r0)+,(r1)+		; copy character
	bne	10$
	mov	#pidbuf,r0			; address of pid
	clr	r5			; initialize counter
20$:
	mov	#task,r1		; buffer for rad50
	call	r$rad5			; convert to rad50
	bcs	70$			; c set => error in conversion
	tst	r5			; which pass
	bne	40$			; use abrt
	movb	pidbuf,r0			; get first character
	cmpb	r0,#'.			; first character PERIOD?
	beq	30$			; YES
	cmpb	r0,#'$			; DOLLAR?
	bne	40$			; NO
30$:
	cmpb	r0,pidbuf+1		; first 2 chars same?
	beq	40$			; YES
	sdat$s	#task,#dots		; send message to tool
	mov	@#$dsw,r1		; get DSW
	br	50$
40$:
	abrt$s	#task			; abort task
	mov	@#$dsw,r1		; get DSW
	bgt	50$			; if >, success
	inc	r5			; increment try count
	mov	#dots,r0		; starting address of buffer
	cmp	r5,#2			; done?
	blt	20$			; NO
50$:
	tst	r1			; test DSW
	blt	60$
	mov	#ok,r0			; return(OK)
	br	70$
60$:
	mov	#err,r0			; return(ERR)
70$:
	mov	(sp)+,r5		; restore r5
	return
	.page
	.sbttl	makarg
;+
;	this routine fetches and sets up the command line arguments
;	for subsequent retrieval by getarg and masking by delarg
;-
cr=15
tab=10
;
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
makarg::
	mov	#r$gmcr,r0	; buffer address for args
	mov	#1,r1		; LUN to use for tools args
	call	gmcrst		; get command line
	bcs	150$		; c set => no command line
	tst	(r0)+		; point at first character
	mov	#r$argv,r1	; start of argv
	clr	r$argc		; initialize arg count
110$:
	clr	r3		; clear quote flag
120$:
	movb	(r0)+,r2	; get next character
	cmp	r2,#' 		; is it a BLANK?
	beq	120$		; YES, skip leading blanks
	cmp	r2,#cr		; stop on terminator
	beq	150$		; done, build stack frame
	cmp	r2,#''		; check for quoted strings
	beq	130$		;
	cmp	r2,#'"		; both kinds are legal
	bne	131$		;
130$:
	mov	r2,r3		; save quote character
	cmp	r1,#r$arge	; does argument fit?
	bhis	150$		; NO
	mov	r0,(r1)+	; add to argv
	inc	r$argc		; increment arg count
	br	140$		;
131$:
	cmp	r2,#'<		; STDIN redirection?
	bne	132$		; NO
	mov	r0,r$infl	; save address
	br	140$		; collect argument
132$:
	cmp	r2,#'>		; STDOUT redirection?
	bne	134$		; NO
	cmpb	r2,(r0)		; APPEND access?
	bne	133$		; NO
	inc	r0		; point past ">>"
	mov	#appe$r,r$ouac	; modify STDOUT access
133$:
	mov	r0,r$oufl	; save address
	br	140$		; collect argument
134$:
	cmp	r2,#'?		; ERROUT redirection?
	bne	138$		; NO
	cmpb	(r0),#' 	; BLANK?
	beq	138$		; YES, not ERROUT redirection
	cmpb	(r0),#tab	; TAB?
	beq	138$		; YES, not ERROUT redirection
	cmpb	(r0),#cr	; end of args?
	beq	138$		; YES, not ERROUT redirection
	cmpb	r2,(r0)		; APPEND access?
	bne	135$		; NO
	inc	r0		; point past "??"
	mov	#appe$r,r$erac	; modify ERROUT access
135$:
	mov	r0,r$erfl	; save address
	br	140$		; collect argument
138$:
	cmp	r1,#r$arge	; does argument fit?
	bhis	150$		; NO
	mov	r0,(r1)		; add to argv
	dec	(r1)+		; went one character too far
	inc	r$argc		; increment arg count
140$:
	movb	(r0)+,r2	; collect the argument
	cmp	r2,#cr		; terminator?
	beq	145$		; YES
	tst	r3		; in quoted string?
	bne	143$		; YES
	cmp	r2,#' 		; is it a BLANK?
	beq	145$		; YES, end of argument
	cmp	r2,#tab		; is it a TAB?
	beq	145$		; YES, end of argument
	br	140$		; try next character
143$:
	cmp	r2,r3		; closing quote?
	bne	140$		; NO
145$:
	clrb	-1(r0)		; terminate with 0-byte
	cmp	r2,#cr		; are we done?
	bne	110$		; NO
150$:
	return
	.page
	.sbttl	open
;+
;	int = open(ext, access)
;
;	opens an existing file specified by ext at access
;
;	if error occurs, returns ERR
;-
ap=%5
ext=2
access=4
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
open::
	call	r$gffb			; get a free RFDB address in r1
	bcs	100$			; c set => error
r$opnf::
	bis	#rf.old,(r1)		; wish to open an existing file
	call	r$opfl			; general open file routine
	return
100$:
	mov	#err,r0			; return ERR
	return
	.page
	.sbttl	putch
;+
;	call putch(buf, int)
;
;	the character in buf is put to the file specified by unit
;-
ap=%5
buf=2
int=4
;
;
	.mcall	qiow$s,put$
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
putch::
	mov	@int(ap),r0		; ratfor unit number
	call	r$gfbk			; get RFDB address in r1
	bcs	100$			; c set => invalid unit
	bit	#rf.clo,(r1)		; is the file open?
	bne	100$			; NO, error
	bit	#rf.raw,(r1)		; rawmode terminal?
	beq	10$			; NO
	mov	#1,r0			; number of characters to write
	mov	buf(ap),r2		; address of buffer
r$rput::
	tst	r0			; any bytes to write?
	ble	5$			; NO
	qiow$s	#io.wal,@int(ap),r$ioef,,,,<r2,r0,#0>
5$:
	return
10$:
	bit	#rf.mod,(r1)		; output mode?
	beq	20$			; YES
	cmpb	#rdwr$r,r.acc(r1)	; opened at READWRITE?
	bne	100$			; NO, error
	clr	r.byte(r1)		; no bytes buffered yet
	mov	r.buf0(r1),r.bufp(r1)	; reset buffer pointer
	bic	#rf.mod,(r1)		; set to output mode
20$:
	movb	@buf(ap),r3		; place character in register
r$cput::
	cmp	r.byte(r1),#512.	; buffer full?
	bge	30$			; YES, flush it
	cmpb	#newlin,r3		; NEWLINE character?
	bne	40$			; NO
30$:
	mov	r.buf0(r1),r2		; buffer address
	mov	r.fdb(r1),r0		; real FDB address in r0
	put$	,r2,r.byte(r1)		; put the record
	mov	r2,r.bufp(r1)		; reset buffer pointer
	clr	r.byte(r1)		; zero character count
40$:
	cmpb	#newlin,r3		; NEWLINE character?
	beq	100$			; YES, do not copy
	movb	r3,@r.bufp(r1)		; store the character
	inc	r.byte(r1)		; update byte count
	inc	r.bufp(r1)		; bump buffer pointer
100$:
	return
	.page
	.sbttl	putlin
;+
;	call putlin(buf, int)
;-
ap=%5
buf=2
int=4
;
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
putlin::
	mov	@int(ap),r0		; rat4 unit number
	call	r$gfbk			; get RFDB address in r1
	bcs	100$			; c set => invalid unit
r$lput::
	bit	#rf.clo,(r1)		; is the file open?
	bne	100$			; NO, error
	mov	buf(ap),r4		; buffer address in non-volatile reg
	bit	#rf.raw,(r1)		; rawmode terminal?
	beq	30$			; NO
	clr	r0			; initialize count of characters
10$:
	tstb	(r4)+			; null byte yet?
	beq	20$			; YES
	inc	r0			; increment count
	br	10$			; try again
20$:
	mov	buf(ap),r2		; address of buffer
	call	r$rput			; do a raw put of the line
	return
30$:
	bit	#rf.mod,(r1)		; output mode?
	beq	40$			; YES
	cmpb	#rdwr$r,r.acc(r1)	; READWRITE access?
	bne	100$			; NO, error
	clr	r.byte(r1)		; no bytes buffered yet
	mov	r.buf0(r1),r.bufp(r1)	; reset buffer pointer
	bic	#rf.mod,(r1)		; set to output mode
40$:
	movb	(r4)+,r3		; place character in r3
	beq	100$			; if == 0, done
	call	r$cput			; put the character (cooked)
	br	40$			; do next character
100$:
	return
	.page
	.sbttl	r$btoo
;+
;	this routine formats the byte found in r1 into octal with
;	no leading zeroes into the buffer pointed at by r0
;	r0 is left pointing at the next free location in the buffer
;	all other registers are constant across the call
;
;-
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$btoo::
	call	r$savr			; save r0-r5
	movb	r1,r2			; place value in even register
	bne	10$			; something to do
	movb	#'0,(r0)+		; just unit 0
	br	40$			; finish up
10$:
	ashc	#-6,r2			; rotate low 6 bits into r3
	mov	#3,r1			; counter
20$:
	bic	#177770,r2		; mask to 3 bits
	beq	30$			; no leading zeroes
	add	#'0,r2			; make it a character
	movb	r2,(r0)+		; copy to buffer
30$:
	ashc	#3,r2			; shift next 3 bits into r2
	sob	r1,20$			; do again
40$:
	clrb	(r0)			; terminate with EOS
	mov	r0,2(sp)		; place next address in saved r0
	return
	.page
	.sbttl	r$dspt
;+
;	this routine builds a data set descriptor
;
;	inputs:
;		r0	address of file string
;		r1	address of data set descriptor
;
;	outputs:
;		data set descriptor for file string is built
;		all registers remain unchanged
;-
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$dspt::
	call	r$savr			; save r0-r5
	clr	(r1)			; zero length fields in dspt
	clr	4(r1)			; ...
	clr	10(r1)			; ...
	mov	r0,r3			; initialize roving pointer
	mov	r3,r2			; start of string
10$:
	cmpb	(r3),#':		; end of device string?
	bne	20$			; NO
	mov	r2,2(r1)		; store starting address
	mov	r3,r0			; calculate length
	sub	r2,r0			; ...
	inc	r0			; ...
	mov	r0,(r1)			; place length in dspt
	mov	r3,r2			; new start of string
	inc	r2			; ...
	br	30$			; do next field
20$:
	cmpb	(r3),#']		; end of UIC string?
	bne	25$			; NO
	mov	r2,6(r1)		; store starting address
	mov	r3,r0			; calculate length
	sub	r2,r0			; ...
	inc	r0			; ...
	mov	r0,4(r1)		; store length
	mov	r3,r2			; new start of string
	inc	r2			; ...
	br	30$			; do next field
25$:
	tstb	1(r3)			; end of file spec?
	bne	30$			; NO
	mov	r2,12(r1)		; store address
	mov	r3,r0			; calculate length
	sub	r2,r0			; ...
	inc	r0			; ...
	mov	r0,10(r1)		; store length
30$:
	.enabl	lc
	movb	(r3),r0			; get character
	cmp	r0,#'a			; lower case?
	blt	40$			; NO
	cmp	r0,#'z			; lower case?
	bgt	40$			; NO
	bic	#40,r0			; make upper case
	.dsabl	lc
40$:
	movb	r0,(r3)+		; copy character back into string
	tstb	(r3)			; end of file spec?
	bne	10$			; NO
	return
	.page
	.sbttl	r$ermo
;+
;	routine to provide error message output
;
;	inputs:
;		r0	address of ASCIZ message string
;
;	all registers remain the same across the call
;-
	.psect	$$iob1,rw,d,lcl,rel,ovr
errorb:	.blkb	132.
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
	.mcall	qiow$s,gtsk$s
sep:	.asciz	"  ***  "
	.even
r$ermo::
	call	r$savr			; save r0-r5
	mov	#errorb,r0		; address of output buffer
	mov	#<15+<256.*12>>,(r0)+	; copy CRLF into buffer
	mov	#r$tknm,r1		; address of task name string
	call	copy
	mov	#sep,r1			; separator string
	call	copy			; copy into error buffer
	mov	2(sp),r1		; user's buffer
	call	copy			; copy it
	movb	#15,(r0)+		; CR at end
	sub	#errorb,r0		; length of buffer in r0
	qiow$s	#io.wlb,.molun,r$ioef,,,,<#errorb,r0,#0>
100$:
	return
;
;
;
copy:
	movb	(r1)+,(r0)+		; copy character
	bne	copy			; if not 0, do again
	tstb	-(r0)			; point at null byte
	return
	.page
	.sbttl	r$garg

	.if df	SRDRV

	.mcall	alun$s,qiow$s

	.iff

	.mcall	get$
	.psect	$r.rod,con,ro,rel,lcl,d
seed:	.asciz	"arg"			; seed for fgenr8 call
	.even
	.psect	$$iob1,ovr,rw,rel,lcl,d
file:	.blkb	40.			; space for arg file name
	.even

	.endc

	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$garg::
	call	r$savr			; save registers

	.if df	SRDRV

	alun$s	r1,#"SR,#0		; assign lun to SR0:
	bcs	10$			; c set => error - return
	qiow$s	#io.rlb,r1,r$ioef,,#r$iosb,,<r0,#255.>	; read from driver
	bcs	10$			; c set => error - try MCR
	tstb	r$iosb			; see if error in driver
	ble	10$			; if <=, YES

	.iff

	mov	#file,-(sp)		; address of file
	mov	#seed,-(sp)		; address of seed
	mov	#r$tknm,-(sp)		; address of pid
	mov	#3,-(sp)		; three args
	mov	sp,ap			; arg pointer for fgenr8
	call	fgenr8			; call fgenr8(pid, seed, file)
	add	#8.,sp			; clean up stack
	mov	#r$inac,-(sp)		; READ access
	mov	#file,-(sp)		; file to open
	clr	-(sp)			; dummy count
	mov	sp,ap			; arg pointer
	mov	r$erdb,r1		; ERROUT RFDB address
	call	r$opnf			; open the file
	rol	r2			; save c bit
	add	#6.,sp			; clean up stack
	ror	r2			; restore c bit
	bcs	10$			; c set => open error
	mov	2(sp),r2		; fetch buffer address
	clr	r$iosb+2		; assume error
	get$	r.fdb(r1),r2,#255.	; read the record
	bcs	5$			; read error
	mov	f.nrbd(r0),r$iosb+2	; copy the count of chars read
5$:
	call	.dlfnb			; close and delete the file

	.endc

	clc				; c clear => success
	return
10$:
	sec				; c set => error
	return
	.page
	.sbttl	r$opfl
;+
;	this routine performs general file opens for the software tools
;	runtime system
;
;	inputs:
;		r1	RFDB address
;
;	outputs:
;		c set	error in opening file
;		c clear	successful open
;-
ap=%5
ext=2
access=4
	.mcall	nmblk$,ofnb$,fdop$r,fdat$r
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$opfl::
	mov	r1,-(sp)		; save RFDB address
	mov	ap,-(sp)		; save argument pointer
	mov	#path,-(sp)		; type for fxlate
	mov	sp,r0			; save address
	add	#r.name,r1		; address of out
	mov	r1,-(sp)		; place in call block
	mov	r0,-(sp)		; address of type
	mov	ext(ap),-(sp)		; address of in
	mov	#3,-(sp)		; arg count
	mov	sp,ap			; establish argument pointer
	call	fxlate			; convert to local file spec
	mov	6(sp),r0		; address of file spec in r0
	add	#10.,sp			; pop arg block from stack
	mov	(sp)+,ap		; restore argument pointer
	mov	(sp)+,r2		; save RFDB in non-volatile reg
	sub	#12.,sp			; build data set desc on stack
	mov	sp,r1			; dspt address in r1
	call	r$dspt			; build a data set descriptor
	mov	r2,r1			; RFDB address in correct place
	mov	r.fdb(r1),r0		; get FDB address
	mov	sp,f.dspt(r0)		; store away dspt address
	mov	pc,r2			; get address of branch statement
	br	50$			; branch around pure code
	nmblk$	,,0,SY,0		; default name block
50$:
	tst	(r2)+			; address of dfnb in r2
	mov	r2,f.dfnb(r0)		; store into FDB
	call	r$pars			; parse the file spec
	rol	r3			; save c bit in r3
	add	#12.,sp			; restore stack
	ror	r3			; restore c bit
	bcs	100$			; c set => parse error
	movb	@access(ap),r.acc(r1)	; store access mode in RFDB
	fdop$r	,,,,,#fa.enb!fa.dlk	; no lock upon aborted closure
	mov	#fd.cr,r2		; assume LIST cctrl
	cmpb	#prin$r,r.acc(r1)	; PRINT access?
	bne	60$			; NO
	mov	#fd.ftn,r2		; FORTRAN cctrl
60$:
	fdat$r	,#r.var,r2		; variable length records
	cmpb	#read$r,r.acc(r1)	; READ access?
	beq	90$			; YES
	cmpb	#appe$r,r.acc(r1)	; APPEND access?
	bne	80$			; NO
	ofnb$	,#fo.apd		; open existing file at append access
	bcc	85$			; c clear => success
	br	81$			; open a new file
80$:
	cmpb	#prin$r,r.acc(r1)	; PRINT access?
	beq	81$			; YES, open new file
	ofnb$	,#fo.upd		; open existing file for write
	bcs	81$			; c set => error, try new file
	cmpb	#rdwr$r,r.acc(r1)	; READWRITE access?
	beq	85$			; YES, don't delete
	call	.dlfnb			; delete existing file
	bitb	#fd.ftn!fd.cr,f.ratt(r0); any implied carriage control?
	bne	81$			; yes
	movb	#fd.cr,f.ratt(r0)	; new file is LIST carriage control
81$:
	ofnb$	,#fo.wrt		; open new file at write access
	bcc	85$			; c clear => success
	ofnb$	,#fo.upd		; try to reopen existing file
					; this is needed if the user has
					; write access to the file, but
					; not delete access (YEP!)
	bcs	100$			; c set => open error
	br	85$			; fill in RFDB
90$:
	ofnb$	,#fo.rd!fa.shr		; open at read access with sharing
	bcs	100$			; c set => open error
85$:
	clr	(r1)			; file is open and flags cleared
	bitb	#fd.tty,f.rctl(r0)	; is it a TTY?
	beq	86$			; NO
	bis	#rf.tty,(r1)		; note this in RFDB
86$:
	bitb	#fd.ftn!fd.cr,f.ratt(r0); any implied carriage control?
	beq	87$			; NO
	bis	#rf.ctl,(r1)		; note this in RFDB
87$:
	cmpb	#read$r,r.acc(r1)	; READ access?
	bne	88$			; NO
	bis	#rf.mod,(r1)		; indicate inputmode
88$:
	cmpb	f.rtyp(r0),#r.var	; variable length records?
	bne	89$			; NO
	bit	#rf.ctl,(r1)		; implied carriage control?
	beq	89$			; NO
	bis	#rf.chr,(r1)		; indicate character file
89$:
	mov	r.buf0(r1),r.bufp(r1)	; initialize buffer pointer
	clr	r.byte(r1)		; clear number of bytes
	movb	r.lun(r1),r0		; return lun for success
	clc				; clear c bit for success
	return
100$:
	mov	#err,r0			; return ERR
	return
	.page
	.sbttl	r$pars
;
;	this routine parses the file spec into the fdb and name block
;	it takes care of named directories
;
;	inputs:
;		r0	address of FDB
;
;	outputs:
;		c bit	set => error in parse
;		c bit	clear => success
;
;	all registers are saved across the call
;
;	upon return, the FDB in r0 is ready for an OFNB$[X] macro call to
;	open the file
;
	.mcall	nmblk$
;
;
	.psect	$r.rod,con,ro,rel,lcl,d
dfnb:	nmblk$	,DIR,0		; default name block for "name.dir"
duic:	.ascii	"[0,377]"	; uic in which  "name.dir" is found
duicl=.-duic
	.even
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$pars::
	call	r$savr		; save r0-r5
	mov	r0,r1		; generate FNB address
	add	#f.fnb,r1	; ...
	mov	f.dspt(r0),r2	; data-set descriptor address
	mov	f.dfnb(r0),r3	; default file name block
	call	.prsdv		; parse device info
	bcs	30$		; device error
	call	.prsdi		; parse directory info
	bcc	20$		; of form [g,m]
	sub	#12.,sp		; space for dspt on stack
	mov	sp,r3		; address of dspt
	clr	(r3)		; no device info for named directory
	clr	2(r3)		; ...
	mov	4(r2),10(r3)	; copy directory info into file info
	mov	6(r2),12(r3)	; ...
	sub	#2,10(r3)	; length - brackets
	inc	12(r3)		; start after [
	mov	r3,r2		; dspt
	mov	#duicl,4(r2)	; length of [0,377] string
	mov	#duic,6(r2)	; address in data-set descriptor
	mov	#dfnb,r3	; default FNB address
	call	.prsdi		; parse directory info
	bcs	4$
	call	.prsfn		; parse file info
	bcs	4$
	call	.find		; find the file in [0,377]
	bcs	4$
	mov	n.fid(r1),n.did(r1)	; copy the file id into the dir id
	mov	n.fid+2(r1),n.did+2(r1)	; ...
	mov	n.fid+4(r1),n.did+4(r1)	; ...
	mov	r1,r2		; now clear out fields
	mov	#16.,r3		; filled in by parse of
10$:				; directory file spec
	clrb	(r2)+
	sob	r3,10$
	bic	#7,n.stat(r1)
4$:
	rol	r3		; save c bit in r3
	add	#12.,sp		; pop dspt from stack
	ror	r3		; restore c bit
	bcs	30$		; c set => named dir not found
	mov	f.dspt(r0),r2	; restore file's DSD
	mov	f.dfnb(r0),r3	; restore file's DFNB
20$:
	call	.prsfn		; parse file info
30$:
	return
	.page
	.sbttl	r$rad5
;+
;	this routine converts the pid passed in r0 into rad50 in the buffer
;	passed in r1
;-
	.psect	$r.rwd,con,rw,rel,lcl,d
pidb:	.blkb	10			; buffer for upper-cased pid
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$rad5::
	call	r$savr			; save all registers
	clr	(r1)			; zero taskname buffer
	clr	2(r1)			; ...
	mov	r0,r2			; source address
	mov	#pidb,r3			; destination address
10$:
	movb	(r2)+,r4		; get next character
	.enabl	lc
	cmpb	r4,#'a			; lower case?
	blt	20$			; NO
	cmpb	r4,#'z
	bgt	20$
	.dsabl	lc
	bic	#40,r4			; make upper case
20$:
	movb	r4,(r3)+		; copy character
	bne	10$
	mov	r1,r3			; move buffer address
	mov	#pidb,r0			; address of ascii buffer
	mov	#1,r1			; do not stop on periods
	call	$cat5b			; convert to rad50
	bcs	30$			; c set => error
	mov	r1,(r3)+		; copy into buffer
	mov	#1,r1
	call	$cat5b
	bcs	30$
	mov	r1,(r3)
30$:
	return
	.page
	.sbttl	r$savr - save and restore register routines
;+
;	this routine saves and restores registers r0-r5 - it is the
;	equivalent of $saval in syslib
;
;	upon return from r$savr, the following is the structure of the
;	stack
;
;	+-------------------+
;	|   return address  |
;	|      saved r5     | 14(sp)
;	|      saved r4     | 12(sp)
;	|      saved r3     | 10(sp)
;	|      saved r2     |  6(sp)
;	|      saved r1     |  4(sp)
;	|      saved r0     |  2(sp)
;	| address of r$retn |   (sp)
;	+-------------------+
;
;	upon execution of "	rts	pc", r$retn is entered, which
;	restores the registers and returns to the caller's caller
;-
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
r$savr::
	sub	#16,sp		; make room on stack
	mov	16(sp),(sp)	; move our return address down
	mov	r5,16(sp)	; save r0-r5
	mov	r4,14(sp)	; ...
	mov	r3,12(sp)	; ...
	mov	r2,10(sp)	; ...
	mov	r1,6(sp)	; ...
	mov	r0,4(sp)	; ...
	mov	#r$retn,2(sp)	; address of routine to restore registers
	rts	pc		; return to caller
;
;
;
r$retn:
	mov	(sp)+,r0	; restore registers r0-r5
	mov	(sp)+,r1	; ...
	mov	(sp)+,r2	; ...
	mov	(sp)+,r3	; ...
	mov	(sp)+,r4	; ...
	mov	(sp)+,r5	; ...
	rts	pc		; return to caller's caller
	.page
	.sbttl	sprint
;+
;	subroutine sprint(out, fmt, in1, in2, ...)
;
;	character out(ARB), fmt(ARB)
;
;	fortran callable sprintf from C library
;
;	format string consists of three types of characters
;
;	1. non-special characters which are copied directly to 'out'
;
;	2. escape characters of the form '@c'.  If 'c' is special, its
;	   equivalent is placed in 'out', else 'c' is placed in 'out'.
;
;	3. format directives of the form '%<n>c', where <n> is an
;	   optional field width and 'c' is one of the following:
;	   c:	character input
;	   d:	integer input, formatted in signed decimal
;	   o:	integer input, formatted in octal
;	   r:	integer input in rad50, convert to ascii
;		here, the width <n> indicates how many contiguous integers
;		to convert
;	   s:	string input
;	   x:	integer input, formatted in hexadecimal
;-
ap=%5
out=2
fmt=4
in1=6
;
;	pure data
;
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
escchr:	.ascii	"b"<10>		; @b => backspace	^H
	.ascii	"f"<14>		; @f => formfeed	^L
	.ascii	"l"<12>		; @l => linefeed	^J
	.ascii	"n"<12>		; @n => newline		^J
	.ascii	"r"<15>		; @r => return		^M
	.ascii	"t"<11>		; @t => tab		^I
	.byte	0		; end of list
fmtchr:	.asciz	"cdorsx"		; valid format characters
	.even
	.dsabl	lc
fmtrtn:	.word	cfmt,dfmt,ofmt,rfmt,sfmt,xfmt ; formatting routines
	.psect	$r.rwd,con,rw,rel,lcl,d
width:	.word	0			; width of format field
sign:	.word	0			; holds sign for decimal format
fmtbuf:	.blkb	10.			; buffer for formatting
filchr:	.blkb	1			; fill character for putstr
	.even
;
;	code for sprint
;
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
sprint::
	call	r$savr		; save r0-r5, in case called from macro
	mov	out(ap),r0	; output string address
	mov	fmt(ap),r1	; format string address
	add	#in1,ap		; point to address of first argument
10$:
	movb	(r1)+,r2	; next character from format string
	beq	30$		; if == 0, done
	cmpb	#'@,r2		; escaped character?
	bne	20$		; NO
	movb	(r1)+,r2	; get character after '@'
	beq	30$		; if == 0, done
	mov	#escchr,r4	; address of correspondence array
11$:
	cmpb	r2,(r4)+	; character match?
	bne	12$		; NO
	movb	(r4),r2		; get equivalence character
	br	30$		; copy it to out
12$:
	inc	r4		; bump past equivalence character
	tstb	(r4)		; done?
	bne	11$		; NO
	br	30$		; just copy character
20$:
	cmpb	#'%,r2		; format specifier?
	bne	30$		; NO
	jsr	pc,getwid	; get optional width value
	movb	#' ,filchr	; initialize fill character to BLANK
	movb	(r1),r2		; get format character
	bisb	#40,r2		; make it lower case
	clr	r4		; base address
21$:
	cmpb	r2,fmtchr(r4)	; format character match?
	beq	22$		; YES
	inc	r4		; update base address
	tstb	fmtchr(r4)	; done?
	bne	21$		; NO
	br	30$		; just copy '%'
22$:
	asl	r4		; multiply base address by 2
	jsr	pc,@fmtrtn(r4)	; call appropriate subroutine
	inc	r1		; bump past format character
	br	10$		; continue
30$:
	movb	r2,(r0)+	; copy character into out
	bne	10$		; if != 0, do again
	rts	pc		; return to caller
	.page
;
;	formatting routines
;
;	register inputs:
;
;	r0	next available output address
;	r1	address of format character (width has been processed)
;	r2-r4	free for use
;	ap	pointer to address of input argument
;
;
;	cfmt - place character in buffer
;
	.enabl	lsb
cfmt:
	mov	(ap)+,r2	; address of character
	movb	(r2),fmtbuf	; place character in temp buf
	clrb	fmtbuf+1	; one character string
	mov	#fmtbuf,r2	; string to copy
	jsr	pc,putstr	; copy to user buffer
	rts	pc		; done
;
;	sfmt - format string
;
sfmt:
	mov	(ap)+,r2	; address of string
	jsr	pc,putstr	; copy to user's buffer
	rts	pc		; done
	.page
;
;	ofmt - format integer*2 in octal with/without leading zeroes
;	       if format character is capital o(O), leading zeros
;	       else leading blanks
;
	.enabl	lsb
ofmt:
	mov	r0,-(sp)	; save user buffer address
	mov	r1,-(sp)	; need r1 for scratch
	mov	#fmtbuf,r0	; format into temporary buffer
	mov	(ap)+,r2	; address of integer to format
	mov	(r2),r3		; value of integer
	bne	4$		; if non-zero, continue
	movb	#'0,(r0)+	; just put a zero
	br	5$		; go put in user's buffer
4$:
	clr	r2		; make r2-r3 into 32-bit integer
	mov	#6,r4		; initialize counter
	clr	r1		; non-zero character not seen
	ashc	#1,r2		; shift r2-r3 one bit left
1$:
	bic	#177770,r2	; mask off to low three bits
	bne	2$		; if non-zero, format it
	tst	r1		; have we seen non-zero yet?
	beq	3$		; NO, try next character
2$:
	inc	r1		; seen non-zero
	add	#'0,r2		; make it a character
	movb	r2,(r0)+	; copy into out
3$:
	ashc	#3,r2		; shift next three bits into r2
	sob	r4,1$		; do next character
5$:
	clrb	(r0)		; terminate with EOS
	mov	(sp)+,r1	; restore r1
	mov	#fmtbuf,r2	; address of buffer to copy
	mov	(sp)+,r0	; restore user's buffer address
	cmpb	(r1),#'O	; upper case o?
	bne	6$		; NO
	movb	#'0,filchr	; fill with leading zeroes
6$:
	jsr	pc,putstr	; copy to user's buffer
	rts	pc		; done
	.page
;
;	xfmt - format in hexadecimal
;
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
xarray:	.ascii	"0123456789abcdef"
	.even
	.dsabl	lc
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
xfmt:
	mov	r0,-(sp)	; save registers
	mov	r1,-(sp)	; ...
	mov	#fmtbuf,r0	; format into temporary buffer
	mov	(ap)+,r2	; address of integer to format
	mov	(r2),r3		; value of integer
	bne	31$		; if non-zero, go ahead
	movb	#'0,(r0)+	; just put a 0
	br	32$		; copy to user
31$:
	clr	r2		; make r2-r3 into 32-bit integer
	mov	#4,r4		; initialize counter
	clr	r1		; non-zero not seen yet
3$:
	ashc	#4,r2		; shift next four bits into r2
	bic	#177760,r2	; mask to four bits
	bne	33$		; non-zero character
	tst	r1		; seen a non-zero yet?
	beq	34$		; NO
33$:
	inc	r1		; seen a non-zero
	movb	xarray(r2),(r0)+; copy character
34$:
	sob	r4,3$		; do next character
32$:
	clrb	(r0)		; terminate with EOS
	mov	(sp)+,r1	; restore registers
	mov	#fmtbuf,r2	; buffer to copy
	mov	(sp)+,r0	; user buffer
	cmpb	(r1),#'X	; uppercase x?
	bne	6$		; NO
	movb	#'0,filchr	; fill with leading zeroes
6$:
	jsr	pc,putstr	; copy to user buffer
	rts	pc		; done
	.page
;
;	dfmt - format in signed decimal
;
	.enabl	lsb
dfmt:
	mov	#fmtbuf+9.,r4	; end of buffer
	clrb	(r4)		; EOS
	mov	(ap)+,r2	; address of value
	clr	sign		; assume >= 0
	mov	(r2),r3		; value to format
	bne	5$		; if non-zero, continue
	movb	#'0,-(r4)	; just output a 0
	br	9$		; copy to user buffer
5$:
	bgt	6$		; if > 0, no minus sign
	inc	sign		; indicate negative number
	neg	r3		; format positive number
6$:
	clr	r2		; 32-bit number for div
7$:
	div	#10.,r2		; divide by 10
	add	#'0,r3		; make remainder into a character
	movb	r3,-(r4)	; ferret away in buffer
	mov	r2,r3		; must now divide quotient
	beq	8$		; if 0, done
	clr	r2		; 32-bit number
	br	7$		; go again
8$:
	tst	sign		; negative number
	beq	9$		; NO
	movb	#'-,-(r4)	; place minus sign in buffer
9$:
	mov	r4,r2		; buffer to copy
	jsr	pc,putstr	; copy to user buffer
	rts	pc
	.page
;
;	rfmt - format rad50 to ascii
;
	.psect	$r.rod,con,ro,rel,lcl,d
	.enabl	lc
t:	.ascii	" abcdefghijklmnopqrstuvwxyz$.?0123456789"
	.dsabl	lc
	.even
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
rfmt:
	mov	r1,-(sp)	; save register
	mov	(ap)+,r1	; address of integer array
	mov	width,r4	; number of integers to format
	bne	10$		; if != 0, user specified it
	mov	#1,r4		; count of 1
10$:
	mov	(r1)+,r3	; value to convert
	clr	r2		; make it 32-bit for divide
	div	#3100,r2	; get first character
	movb	t(r2),(r0)+	; copy first character
	clr	r2		; remainder is new divisor
	div	#50,r2		; get second character
	movb	t(r2),(r0)+	; copy second character
	movb	t(r3),(r0)+	; and third character
	sob	r4,10$		; do more, if necessary
	mov	(sp)+,r1	; restore register
	rts	pc		; done
	.page
;+
;	support routines for formatting routines
;
;	getwid - get user-supplied field width
;
;	inputs:
;		r0	address of user buffer
;		r1	address of first character after '%'
;		r2	'%'
;		r3,r4	mangled
;
	.enabl	lsb
getwid:
	clr	r3		; default width value
5$:
	jsr	pc,isdig	; is this character a digit?
	bcs	6$		; c set => NO
	movb	(r1)+,r2	; fetch the digit
	sub	#'0,r2		; make it an integer
	mul	#10.,r3		; w = 10 * w + d
	add	r2,r3		; ...
	br	5$		; again
6$:
	mov	r3,width	; save width value
	rts	pc		; done
;
;	isdig - determine if character pointed to by r1 is a digit
;
;	c set => NO
;	c clr => YES
;	all registers remain unchanged
;
isdig:
	cmpb	(r1),#'0	; < 0
	blt	7$		; YES
	cmpb	(r1),#'9	; > 9
	bgt	7$		; YES
	clc			; c clear => is a digit
	rts	pc
7$:
	sec			; c set => not a digit
	rts	pc
;
;	putstr - put formatted string into user buffer
;
;	inputs
;		r0	next available address in user buffer
;		r1	points at character after '%<n>'
;		r2	address of buffer to copy to user buffer
;		r3-r4	mangled
;
putstr:
	mov	width,r4	; width of field
	mov	r2,r3		; address of input buffer
8$:
	dec	r4		; decrement number of blanks to output
	tstb	(r3)+		; end of string?
	bne	8$		; NO
	inc	r4		; went one too far
	ble	10$		; if <= 0, no blanks to output
9$:
	movb	filchr,(r0)+	; output leading character
	sob	r4,9$		; do again, if necessary
10$:
	movb	(r2)+,(r0)+	; copy character to user buffer
	bne	10$		; do again, if necessary
	tstb	-(r0)		; went one too far
	rts	pc		; done
	.page
	.sbttl	trndev
;+
;	subroutine trndev(dev, unit, buf)
;
;	this routine translates the pseudo-device specified by dev and unit
;	into its equivalent character string in buf
;-
ap=%5
dev=2
unit=4
buf=6
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
	.mcall	alun$s,glun$s
trndev::
	clrb	@buf(ap)		; assume error
	mov	dev(ap),r0		; address of device string
	movb	(r0)+,-(sp)		; place first character on stack
	movb	(r0),1(sp)		; second character
	mov	(sp)+,r1		; have device string in r1
	bic	#<40+<40*256.>>,r1	; make upper case
	alun$s	r$endl,r1,@unit(ap)	; assign lun to DDn:
	bcs	100$			; c set => bad error
	sub	#12.,sp			; buffer for GLUN
	mov	sp,r1			; address of buffer
	glun$s	r$endl,r1		; GLUN
	bcs	90$			; c set => almost as bad error
	mov	buf(ap),r0		; address of output buffer
	movb	g.luna(r1),(r0)+	; copy first byte of device name
	movb	g.luna+1(r1),(r0)+	; second byte of device name
	movb	g.lunu(r1),r1		; unit number
	call	r$btoo			; format byte to octal
	movb	#':,(r0)+		; copy COLON
	clrb	(r0)			; terminate with EOS
90$:
	add	#12.,sp			; restore stack
100$:
	return
	.page
	.sbttl	ttysub - tty subroutines
;+
;	subroutine ttyatt
;
;	subroutine ttydet
;-
	.mcall	qiow$s
	.psect	$r.roi,con,ro,rel,lcl,i
	.enabl	lsb
ttyatt::
	mov	#io.att,r0		; function code for terminal attach
	br	10$
ttydet::
	mov	#io.det,r0		; function code for terminal detach
10$:
	qiow$s	r0,.molun,r$ioef	; perform correct function
	return
	.page
	.sbttl	r$data - RFDB database
	.asect
.=0
r.flag::	.blkw	1		; flags word in RFDB
r.buf0::	.blkw	1		; address of record buffer
r.bufp::	.blkw	1		; current buffer pointer
r.byte::	.blkw	1		; bytes in buffer currently
r.fdb::		.blkw	1		; associated FDB address
r.lun::		.blkb	1		; associated lun
r.acc::		.blkb	1		; access file is opened at
r.name::	.blkb	40.		; space for file name
r.lgth==.
	.psect
;
;	definitions for bits in r.flag
;
rf.clo==1		; set if file is closed
rf.tty==2		; set if file is associated with terminal
rf.old==4		; set if opening existing file is desired
rf.ctl==10		; set if LIST or Fortran carriage control
rf.dir==20		; set if allocated to a directory
rf.raw==40		; set if unit is raw terminal
rf.mod==100		; set if unit is in inputmode
rf.chr==200		; set if character file
;
;
;	general global symbol definitions
;
;
eof==-1
err==-3
newlin==12
read$r==1
writ$r==2
rdwr$r==3
appe$r==4
prin$r==5
stdin==1
stdout==2
errout==3
yes==1
no==0
ok==0
path==5
d.fdb==12.		; this offset represents the offset into the FFDB
			; for the FDB.  it may have to be changed if the RMS
			; OTS library is in use for F4P v.3.0
;
;
;
;
	.psect	$r.rwd,con,rw,rel,lcl,d
r$dbst::
r$indb::	.word	rfdb1
r$oudb::	.word	rfdb2
r$erdb::	.word	rfdb3
		.word	rfdb4,rfdb5,rfdb6,rfdb7
r$dbnd::
r$infl::	.word	ti
r$inac::	.word	read$r
r$oufl::	.word	ti
r$ouac::	.word	writ$r
r$erfl::	.word	ti
r$erac::	.word	writ$r
ti:	.asciz	"ti:"
	.even
;
;	space for command line argument globals
;
r$gmcr::	.blkb	258.		; buffer for command line
r$argc::	.word	0		; holds number of arguments
r$argv::				; start of array of pointers to args
		.rept	25.		; 25 pointers max
		.word	null		; initially, each points to null arg
		.endr
r$arge::				; end of list
r$ioef::	.word	0		; event flag number for use in I/O
r$spef::	.word	0		; event flag number for spwn use
r$iosb::	.word	0,0		; io status block
r$ddir::	.word	0,0,0,0,0,0	; buffer for default directory
r$duic::	.word	0,0,0,0,0	; buffer for default uic string
r$fgpc::	.byte	0,0,0,0,0,0,0	; name of active foreground proc
r$tknm::	.byte	0,0,0,0,0,0,0	; our task name
null:		.asciz	""		; null string
		.even
;
;	pointer to last address in task
;	filled in during startup
;
r$enda::	.word	0
r$endl::	.word	0		; next available lun
;
;	RFDB's
;
rfdb1:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
rfdb2:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
rfdb3:	.word	rf.clo
	.word	errbuf		; only unit with initial buffer
	.blkb	<r.lgth-4>
rfdb4:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
rfdb5:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
rfdb6:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
rfdb7:	.word	rf.clo
	.word	0		; no buffer initially
	.blkb	<r.lgth-4>
errbuf:	.blkb	512.		; record buffer for ERROUT
	.end
