.title	PDPPK	run a job on a psuedo for RSTS/E
	.ident	/8.0.05/

	.include	/SY:[1,2]COMMON.MAC/
	.title	$runjo
	.psect	$code


;	Brian Nelson
;	Computer Services
;	University of Toledo
;	2801 West Bancroft
;	Toledo, Ohio 43606
;	(419) 537-2511
;
;
;	E D I T       H I S T O R Y
;
;	date	   time	   edit  who	why
;
;	12-jun-80	     0	 BDN	initial coding
;	01-dec-82	     1	 BDN	expand arg list, add f4/bp2 entry points
;	20-Apr-83  13:40:31  2	 BDN	add disk logging for terminal output
;	09-May-83  14:38:57  3	 BDN	check for detaching via modem disconnect
;	31-May-83  15:27:40  4	 BDN	add code to check for spawning from a pk
;	11-Jul-83  15:02:16  5	 BDN	add code to check if version 8.0 and if
;					so use the new uu.sys features
;	12-Jul-83  12:48:04  5	 BDN	fixed '$runjo' entry point up to work.
;	24-Jan-86  12:12:30      BDN	Hacked up for 'C' TED and RSTS/E
;
;	**************************************

	.globl	systype
	.priv	=	240

dclcom::mov	r5	,-(sp)
	mov	r4	,-(sp)
	mov	r3	,-(sp)
	mov	r2	,-(sp)
	cmpb	systype	,#4		; Is this RSTS/E ?
	bne	100$			; No
	mov	2+<4*2>(sp),r1		; Yes, get command buffer adderss
	cmpb	(r1)	,#40		; Leading space?
	bne	10$			; No
	inc	r1			; Yes, skip over it
10$:	mov	#b	,r2
20$:	movb	(r1)+	,(r2)+
	bne	20$
	movb	#15	,-1(r2)
	clrb	@r2
	mov	#200$	,r5		; Setup and call
	call	runjob			; call and exit
100$:	mov	(sp)+	,r2
	mov	(sp)+	,r3
	mov	(sp)+	,r4
	mov	(sp)+	,r5
	return				; exit

200$:	.word	4,b,220$,230$,240$
220$:	.word	100305
230$:	.word	11.
240$:	.word	1000.
b:	.blkb	250




	.sbttl	entry points


;	$RUNJOB
;
;	start a job on a psuedo keyboard and run it
;
;
;	entry points:
;
;	 $RUNJOB		(for compatibilty with previous versions)
;
;	   parameters:
;
;	    0(r5)	=	address of command string address block
;	    2(r5)	=	job termination flag word
;	    4(r5)	=	lowest channel number to use
;	    6(r5)	=	elapsed time limit
;
;
;
;	 $$RUNJ			(new format)
;
;	   parameters:
;
;	    0(r5)	=	address of command string address block
;	    2(r5)	=	job termination flag word
;	    4(r5)	=	lowest channel number to use
;	    6(r5)	=	elapsed time limit
;	   10(r5)	=	binary of account to log into
;	   12(r5)	=	input file address  (zero if none)
;	   14(r5)	=	output file address (zero if none)
;
;
;	 RUNJOB			(fortran/bp2/f77 callable)
;
;	   parameters:
;
;	     @r5	=	dec standard arg count (fortran/bp2)
;	    2(r5)	=	address of command string address block
;	    @4(r5)	=	job termination flag word
;	    @6(r5)	=	lowest channel number to use
;	    @10(r5)	=	elapsed time limit
;	    @12(r5)	=	binary of account to log into (optional)
;	     14(r5)	=	address of a file to read input from
;	     16(r5)	=	address of a file to put output to
;
;
;	    See sample fortran source code below for usage.
;	   Note that the channel number to start with must be low
;	   enough  to accomidate the optional disk file for output
;	   if used. Ie, if you pass '11' (decimal) as the starting
;	   lun then  channels 12, 13 and  14 must also be free for
;	   use.

	.sbttl	explanation of the second arguement


;	for the parameter at 2(r5), ( @4(r5) for Fortran/Bp2 )
;	which is the termination flag:
;
;	   if 2(r5) and 1 <> 0, exit on user typing a control D (^D)
;	   if 2(r5) and 2 <> 0, exit on control c (KMON) wait
;	   if 2(r5) and 4 <> 0, exit on end of commands (addr=0)
;	   if 2(r5) and 10<> 0, do not echo psuedo KB's output.
;	   if 2(r5) and 20<> 0, do not use binary mode
;	   if 2(r5) and 40<> 0, the ppn passed is real
;	   if 2(r5) and 100<>0, kill job if it logs out and return
;	   if 2(r5) and 200<>0, do not allow caller to be on a pk
;	   if 2(r5) < 0       , ignore errors (first char '?')
;
;	error return:
;
;		r0 = 0	 no errors
;		r0 > 0   r0 will have the RSTS error number in it
;		r0 = -1	 '?' found in first char of pk output line
;		r0 = -2	 PK job already running (calling job is on PK:)
;		r0 = -3  elapsed time exceeded
;
;
;	command address block format:
;
;	example:
;
;		;	run thru the 3 ccl commands
;		;	exit on end of commands ('0' at end of cmdblk:)
;		;	use rsts channel number 11 and 12 (decimal)
;		;	no time limit
;
;		cmdblk:	.word	10$,20$,30$,0
;		10$:	.asciz	#PIP DB1:/L:S#<cr><lf>
;		20$:	.asciz	#FOR JUNK=JUNK#<cr><lf>
;		30$:	.asciz	#SY/N#<cr><lf>
;			.even
;
;		calls	$runjob	,<#cmdblk,#4,#11.,#0>
;		tst	r0
;
;
;	stack usage requirement:
;
;		all internal vars and buffers need 170 decimal bytes
;		of stack available
;
;	internal register usage:
;
;		r0	scratch, error return, single parameter passing
;		r1	scratch, never saved on call/exit
;		r2	address of next .asciz command
;		r3	--> FIRQB+0 always
;		r4	--> local data block (which is on the stack)
;		r5	--> XRB+0   always
;

	.sbttl	local data definitions



	.dsabl	gbl


	.iif	ndf	,edrt	,edrt = 0

	.if ne	,edrt			; .priv is a null macro
	.ift				; for ted
	.macro	.priv			;
	.endm
	.iff
	.globl	.priv
	.endc				; for ted


	.macro	$sleep	t
	mov	t	,xrb+0
	.priv
	.sleep
	.endm	$sleep

	.macro	.print	a,l		; perhaps minitab is here
	.if b, l			; or we are using this from
	.ift				; fortran or bp2
	clr	-(sp)			; no length, assume .asciz
	.iff				; length passed
	mov	l	,-(sp)		; stuff it please
	.endc				; if b, len
	mov	a	,-(sp)		; stuff string address
	call	lprint			; and do it
	.endm
	
	.macro	callr0	name	,arg
	mov	arg	,r0
	call	name
	.endm	callr0


	CR	=	15
	FF	=	14
	LF	=	12
	NULL	=	0

	.macro	iferr	lab
	tst	r0
	bne	lab
	.endm	iferr

	.macro	.newline	; print crlf on channel 0 (KB:)
	call	l$pcrlf
	.globl	l$pcrlf
	.endm	.newline

	.macro	save	list
	.if b , <list>
	.ift
	 save	<r0,r1,r2,r3,r4,r5>
	.iff
	.irp	x,<list>
	 mov	x,-(sp)
		.endr
	.endc
	.endm	save


	.macro	unsave	list
	.if b , <list>
	.ift
	unsave	<r5,r4,r3,r2,r1,r0>
	.iff
	.irp	x,<list>
	 mov	(sp)+,x
		.endr
	.endc
	.endm	unsave



	nodevc	=	6
	notavl	=	10
	eof	=	13
	daterr	=	15
	detkey	=	33
	corcom	=	460


	.asect			; define offsets from r4 for local vars
	.	=	0	; offsets start at zerp
	buflen	=	150.	; size of the pk buffer
buffer:	.blkb	buflen		; the pk buffer, at 0(r4)
rcount:	.blkw			; size of last kb or pk read
kbddb:	.blkw			; address controlling job's ddb for KB:
pkddb:	.blkw			; address of the pk's ddb
pkjob2:	.blkw			; job number times two for the pk job
pkkbn:	.blkw			; kb number of the PK: in use
urts:	.blkw 2			; the controlling job's default RTS
uppn:	.blkw			; the controlling job's PPN
upriv:	.blkw			; <> 0 if controlling job is in (1,*)
ujob2:	.blkw			; the controlling job's job number * 2
cmds:	.blkw			; copy of command block address
abortf:	.blkw			; copy of the termination flag
pklun2:	.blkw			; channel number times two for PK
kblun2:	.blkw			; channel number times two for KB
timout:	.blkw			; copy of elapsed time flag
newppn:	.blkw			; if switching ppn's

inf:	.blkw			; input file if given
inbfa:	.blkw			; input file buffer address
outf:	.blkw			; output file if given
outbfa:	.blkw			; output file buffer address

influn:	.blkw			; disk input  file lun * 2
outflu:	.blkw			; disk output file lun * 2

infpnt:	.blkw			; disk input  buffer pointer
outfpn:	.blkw			; disk output buffer pointer

timini:	.blkw			; initial time at entry here.
cyc:	.blkw
lastch:	.blkw			; last char of preceeding pk read
kbintf:	.blkw			; interface type for controlling job

	js.kb	=	2	; bit in JBWAIT for KB wait state
	
	.if ne	,edrt
	.ift
	stim	=	1
	.iff
	stim	=	3	; sleep time in main loop
	.endc

	swait	=	< << 60./stim >+1 > * stim> / 2
	.iif	le	,swait ,swait = 1

	locsiz	=	. + 2	; size of the local data
	.assume	buffer eq 0

		.psect	$code


;	bits defined in abortf(r4)

	f$ctld	=	1
	f$kmon	=	2
	f$eot	=	4
	f$nech	=	10
	f$nbin	=	20
	f$nppn	=	40
	f$nopr	=	100
	f$nopk	=	200


str.cr:	.byte	0,0
plogin:	.rad50	/LOGIN /
	.word	-1
crfail:	.asciz	/?Can't start job/<cr><lf>
nopk:	.asciz	/?no PK's/ <cr> <lf>
fatbug:	.asciz	/?bug in openpk/ <cr> <lf>
	.even


	.sbttl	fortran/bp2 entry point

	.if eq	,edrt
	.ift

;		byte filnam(30)
;		byte out(512)
;		integer outf(2)
;		byte buffer(84)
;		outf(2) = iaddr(out)
;		outf(1) = iaddr(filnam)
;		read (5,1) filnam
;	1	format (30a1)
;		filnam(30) = 0
;		type *,'starting'
;	5	continue
;		read (5,100) (buffer(i),i=1,80)
;		mode = 5
;		do 10 j = 80,1,-1
;		 if (buffer(j).ne.' ') go to 20
;	10	continue
;		mode = "100001
;		buffer(1) = 0
;		go to 30
;	20	continue
;		buffer(j+1) = 13
;		buffer(j+2) = 10
;		buffer(j+3) = 0
;	30	continue
;		ierr = runjob(buffer,mode,11,0,0,,outf)
;		type *,ierr
;		goto 5
;	100	format (80a1)
;		stop
;		end
;
;
; Note:	the 'infile' (not yet implemented) and the 'outfile' address
;	actually are parameter blocks consisting of
;
;	  (1)  a filename address
;	  (2)  a buffer address of 1000 (8) bytes
;
;	  as in:
;
;		integer outf(2)
;		byte outbuf(512)
;		byte outnam(30)
;		read (5,100) outnam
;		outnam(30) = 0
;		outf(1) = iaddr(outnam)
;		outf(2) = iaddr(outbuf)


	.sbttl	calling example from MINITAB's 'system' command

;		subroutine syscmd(cmdlin)
;	c
;	c	change 'cmdlin' to byte for version 82 of minitab
;	c
;		byte cmdlin(80)
;		byte buffer(84)
;		common /isc/ buffer
;		integer runjob
;	c
;		integer irsts,irsxts,irsx,ivax,irt11,myexec,pkflag
;		common /ostype/ irsts,irsxts,irsx,ivax,irt11,myexec,pkflag
;	c
;		if ((myexec.eq.irsts).or.(myexec.eq.irsxts)) go to 5
;		 write (5,220)
;		 return
;	c
;	5	continue
;		do 10 j = 1 , 80
;		 buffer(j) = ' '
;	10	continue
;	c
;		do 20 j = 1 , 80
;		 if (cmdlin(j).eq.' ') go to 30
;	20	continue
;		j = 0
;	30	continue
;		k = j + 1
;		i = 1
;	c
;		do 40 j = k,80
;		 buffer(i) = cmdlin(j)
;		 i = i + 1
;	40	continue
;	c
;		mode = 5
;		do 80 j = 80,1,-1
;		 if (buffer(j).ne.' ') go to 90
;	80	continue
;		mode = "100001
;		buffer(1) = 0
;		write (5,200)
;		go to 100
;	90	continue
;		buffer(j+1) = 13
;		buffer(j+2) = 0
;	100	continue
;		mode = mode .or. "100
;		ierr = runjob(buffer,mode,11,0)
;		if (ierr.ne.0) write (5,210) ierr
;		return
;	c
;	c
;	200	format (' Type control D (^D) to return to MINITAB'/)
;	210	format (' PK driver returned error code ',i5)
;	220	format (' %Minitab-W  The SYSTEM command is not available')
;	c
;		end



	.sbttl	fortran/bp2 entry point continued

	.psect	$code

	f4.out	=	16		; optional output fileblock
	f4.inf	=	14		; optional input  fileblock
	f4.ppn	=	12		; optional ppn to log into
	f4.tim	=	10		; timeout flag
	f4.lun	=	6		; lowest channel number to use
	f4.fla	=	4		; run flags
	f4.buf	=	2		; command clock address


runjob::mov	r5	,-(sp)		; convert f4/bp2 call format
	mov	r4	,-(sp)

	clr	-(sp)			; assume no address for outfile
	cmpb	@r5	,#7		; 7 args (last is output file)
	blo	1$			; no
	cmp	f4.out(r5),#-1		; yes, is the arguement ommitted?
	beq	1$			; yes. leave a zero for the address
	mov	f4.out(r5),@sp		; no, copy the filename address

1$:	clr	-(sp)			; assume no address for infile
	cmpb	@r5	,#6		; 6 args (second to last)
	blo	2$			; no
	cmp	f4.inf(r5),#-1		; yes, at least 6. was it ommitted?
	beq	2$			; yes, address of 177777 is dec's way
	mov	f4.inf(r5),@sp		; no, copy the address to the stack

2$:	clr	-(sp)			; assume no new ppn now
	cmpb	@r5	,#5		; passed another ppn to use?
	blo	5$			; no
	cmp	f4.ppn(r5),#-1		; at least 5 parameters, is it real?
	beq	5$			; yep
	mov	@f4.ppn(r5),@sp		; yes, stuff it please

5$:	mov	@f4.tim(r5),-(sp)	; to that expected by the pk
	mov	@f4.lun(r5),-(sp)	; driver here
	mov	@f4.fla(r5),-(sp)	; job termination flag
	clr	-(sp)			; for now, no cmd blocks
	mov	sp	,r4		; point to new parameter list
	clr	-(sp)			; create cmd block descriptor
	mov	f4.buf(r5),-(sp)	; buffer address
	mov	sp	,4(sp)		; stuff the block in now
	mov	r4	,r5		; saved address of new param
	tstb	@(sp)			; null command line passed?
	bne	10$			; no
	clr	(sp)			; yes, setup for nothing then
10$:
	call	$$runj			; do the work and exit
	add	#22	,sp		; pop parameters
	mov	(sp)+	,r4		; pop saved r4
	mov	(sp)+	,r5		; pop saved r5
	return				; and exit

100$:	.asciz	/starting - /
110$:	.byte	cr,lf
	.even
	.endc				; not included for ted



	.sbttl	main control loop

		.psect	$code



$runjo::clr	-(sp)
	clr	-(sp)
	clr	-(sp)
	mov	6(r5)	,-(sp)
	mov	4(r5)	,-(sp)
	mov	2(r5)	,-(sp)
	mov	@r5	,-(sp)
	mov	sp	,r5
	call	$$runj
	add	#7*2	,sp
	return


$$runj:	mov	#jfsys	,xrb+0		; get privs back if possible
	.priv				; prefix, if required.
	.set				; set keyword bit call to exec
	save	<r1,r2,r3,r4,r5>	; should do this.
	sub	#locsiz	,sp		; allocate space for us.
	mov	sp	,r4		; r4 will point to work area
	call	init			; initial junk for startup
	bcs	100$			; oops !
	call	openfi
	bcs	100$			; oops !
	call	login			; login pk
	bcs	100$			; oops
	call	pkjobn			; get the pk job number * 2
	call	record			; record time-sharing session
100$:
die:	call	clsout
	add	#locsiz	,sp		; pop our work area from stack
	mov	#firqb+fqfil,r3		; useful address
	call	$zapfqb
	movb	#clsfq	,firqb+fqfun	; close the channels we used
	movb	pklun2(r4),@r3		; channels here
	.priv				; prefix as usual
	calfip
	call	$zapfqb
	movb	#clsfq	,firqb+fqfun	; close the channels we used
	movb	kblun2(r4),@r3		; channels here
	.priv				; prefix as usual
	calfip
	unsave	<r5,r4,r3,r2,r1>
	mov	#jfsys	,xrb+0		; drop privs at exit
	.priv				;
	.clear				; drop bits in keyword call
	return



	.sbttl	initial stuff


	.assume	uppn	eq	<urts+4>
	.assume upriv	eq	<uppn+2>
	.assume	ujob2	eq	<upriv+2>
	.assume	cmds	eq	<ujob2+2>
	.assume	abortf	eq	<cmds +2>
	.assume	pklun2	eq	<abortf+2>
	.assume	kblun2	eq	<pklun2+2>
	.assume	timout	eq	<kblun2+2>
	.assume	newppn	eq	<timout+2>
	.assume	inf	eq	<newppn+2>
	.assume	inbfa	eq	<inf+2>
	.assume	outf	eq	<inbfa+2>
	.assume	outbfa	eq	<outf+2>
	.assume	influn	eq	<outbfa+2>
	.assume	outflu	eq	<influn+2>


init:	call	$zapfqb			; zap the firqb first please
	mov	r4	,r1		; clear out the local vars
	mov	#locsiz-2,r0		; which we allocated on the
5$:	clrb	(r1)+			; stack
	sob	r0	,5$		; all of it please
	movb	#uu.sys	,firqb+fqfun	; systat sys call with subfun
	.priv				; zero to get default user
	.uuo				; runtime system.
	mov	firqb+12,timini(r4)	; save user's connect
	mov	#swait	,cyc(r4)	; stuff control for time check
	mov	r4	,r3		; Base address of impure area.
	add	#urts	,r3		; we will start here.
	mov	firqb+30,(r3)+		; copy two rad50 words for
	mov	firqb+32,(r3)+		; user's default rts
	mov	firqb+26,(r3)+		; and the ppn for our user.
	clr	(r3)+			; set the user is (1,*) flag
	cmpb	#1	,<uppn+1>(r4)	; perm privs here ?
	bne	10$			; nop
	 mov	sp	,-2(r3)		; yes, set a flag then
10$:	movb	firqb+fqjob,(r3)+	; job number times 2
	clrb	(r3)+			; to be sure, get high byte out
	mov	(r5)+	,(r3)+		; save command string address
	mov	(r5)+	,(r3)+		; save the abort flag
	mov	(r5)+	,r0		; starting lun to use for the
	ble	100$			; pk and for the kb. Must be
	asl	r0			; > 0
	mov	r0	,(r3)+		; pk lun is the first one
	add	#2	,r0		; kblun2 = pklun2 + 2
	mov	r0	,(r3)+		; thats all
	mov	(r5)+	,(r3)+		; job elapsed time parameter.
	mov	(r5)+	,(r3)+		; alternate ppn
	bit	#f$nppn	,abortf(r4)	; really do this
	bne	20$			; yes
	clr	-2(r3)			; no
20$:	mov	(r5)+	,r0		; get input file block
	beq	30$			; a null parameter there
	 mov	2(r0)	,inbfa(r4)	; save input buffer address
	 mov	@r0	,r0		; get filename address now.
	 tstb	@r0			; anything there ?
	 beq	30$			; no, leave name address eq 0
	 mov	r0	,inf(r4)	; yes, save address
	 mov	kblun2(r4),influn(r4)	; also allocate a channel
	 add	#2	,influn(r4)

30$:	mov	(r5)+	,r0		; get output file block
	beq	40$			; a null parameter there
	 mov	2(r0)	,outbfa(r4)	; save output buffer address
	 mov	@r0	,r0		; get filename address now.
	 tstb	@r0			; anything there ?
	 beq	40$			; no, leave name address eq 0
	 mov	r0	,outf(r4)	; yes, save address
	 mov	kblun2(r4),outflu(r4)	; also allocate a channel
	 add	#4	,outflu(r4)
40$:

100$:	clr	r0
	mov	#520.	,xrb+0		; get the controlling job's
	.priv				; kbddb as:
	.peek				; peek(peek(peek(520.)))
	.priv				; and again
	.peek				; .....
	.priv				; one more time
	.peek				; ah !
	mov	xrb+0	,kbddb(r4)	; and pack it away
	mov	#firqb	,r3		; r3 will always --> IOSTS
	mov	#xrb	,r5		; r5 will always --> xrb+0

	call	$zapfqb			; clear firqb for getting interface
	movb	#uu.trm	,firqb+fqfun	; type. perhaps caller will not
	movb	#377	,firqb+5	; allow a pk to run a pk job.
	.priv				; rt emulator perhaps?
	.uuo				; get terminal characteristics
	movb	firqb+24,kbintf(r4)	; save the interface type
	bit	#f$nopk	,abortf(r4)	; allow caller to be on a pk?
	beq	110$			; yes
	cmpb	kbintf(r4),#10		; no, is the caller running on
	bne	110$			; a psuedo keyboard already?
	mov	#-2	,r0		; yes
	sec				; also set this error status
	br	120$			; and exit

110$:	clc				; and away we go !
120$:	return				; for now.


	.sbttl	open files up please



openfi:	call	openkb			; open 'kb:' mode 1
	bcs	100$			; oops !
	call	openpk			; open 'pk?:'
	bcs	100$
	callr0	getddb	,pkkbn(r4)	; we will need the pk's DDB.
	bcs	100$			; oops
	mov	r0	,pkddb(r4)	; and save the kbddb
	call	opninp
	bcs	100$
	call	opnout

100$:	return



	.sbttl	open/close logging file if open

	.if eq	,edrt			; save address space for TED
	.ift

opnout:	call	$zapfqb			; open possible optional output
	mov	outf(r4),r2		; get output filename
	beq	100$			; nothing to open
	mov	r2	,r1		; save it
10$:	tstb	(r1)+			; get the length please
	bne	10$			; no nulls as of yet
	sub	r2	,r1		; length + 1
	dec	r1			; length
	mov	#xrb	,r0		; clear firqb for a .fss
	mov	r1	,(r0)+		; xrb.xrlen := len(filename)
	mov	r1	,(r0)+		; xrb.xrbc  := len(filename)
	mov	r2	,(r0)+		; xrb.xrloc := address(filename)
	.rept	4			; the rest is unused
	clr	(r0)+			;
	.endr				;
	.priv				; now do the filename string scan
	.fss				; simple
	movb	@r3	,r0		; get error codes (r3 --> firqb+0)
	bne	110$			; oops
	movb	#crefq	,firqb+fqfun	; open a file function for fip
	movb	outflu(r4),firqb+fqfil	; channel number times 2
	clr	firqb+fqmode		; no modes please
	.priv
	calfip				; get rsts to open it up
	movb	@r3	,r0		; copy error codes from firqb+0
	bne	110$			; ok
	clr	outfpnt(r4)		; init output buffer pointer
	mov	outbfa(r4),r0		; null fill the output buffer
	mov	#1000	,r1		; 1000 (8) bytes worth
50$:	clrb	(r0)+			; clear a byte
	sob	r1	,50$		; and back for more

100$:	clc				; no errors
	return

110$:	clr	outf(r4)		; clear filename address out
	movb	firqb	,r0
	sec				; error exit, error code in r0
	return



clsout:	tst	outf(r4)		; output file there ?
	beq	100$			; no
	call	wrtout			; dump output buffer
	call	$zapfqb			; and close the file
	movb	#clsfq	,firqb+fqfun	; fip function to close it
	movb	outflu(r4),firqb+fqfil	; channel number times 2
	.priv				; rt11.rts prefixes today ?
	calfip				; close it
100$:	return

	.iff				; for TED, dummy fileopens out

opnout:
clsout:	clc
	return

	.endc				; if eq, edrt

	.sbttl	open input file (not yet implemented)

opninp:	clr	inf(r4)
	return


	

	.sbttl	openkb	- open 'kb:' as file 1, mode 1

openkb:	call	$zapfqb			; zap firqb
	movb	kblun2(r4),@#firqb+fqfil ; channel 1
	mov	#"KB,@#firqb+fqdev	; 'kb:'
	mov	#buflen,@#firqb+fqbufl	; buffer length
	mov	#100001!40!20,@#firqb+fqmode ; mode 1+32+16
;;	bis	#100000,@#firqb+fqmode	; mode is real
	movb	#opnfq,@#firqb+fqfun	; open function
	.priv				; have rsts/e
	calfip				; open the file
	tstb	@r3			; any problems ?
	beq	10$			; no, go return
	 movb	@r3	,r0
	 sec

10$:	return				; back to work...



	.sbttl	get job number for PK job


pkjobn:	
	mov	pkddb(r4),@r5		; get the pk ddb and then we
	add	#2	,@r5		; can get the job number out
	.priv				; ddjbno by a quick peek.
	.peek				; peek at it
	mov	@r5	,-(sp)		; save it for a moment
	bic	#^C126.	,(sp)		; junk high order stuff and
	mov	(sp)+	,pkjob2(r4)	; save it
	return


getddb:	call	$zapfqb			; get ddb of kb number passed
	movb	#uu.tb2	,firqb+fqfun	; in r0. Get DEVOKB to get the
	.priv				; disk count thus getting the
	.uuo				; eventually the kb ddb's.
	mov	firqb+12,-(sp)		; save this for a moment.
	movb	#uu.tb1	,firqb+fqfun	; get tables part 1 for the
	.priv				; devptr
	.uuo				; rsts does it again !
	mov	firqb+10,@r5		; @r5 := devptr
	add	(sp)+	,@r5		; plus devokb
	.priv				; now get devtbl as
	.peek				; peek( devtbl+edvokb )
	mov	r0	,-(sp)		; add in the kbnumber times 2
	asl	(sp)			; to get the ddb of the tty.
	add	(sp)+	,@r5		; all set now.
	.priv				; prefix if needed.
	.peek				; and peek at it.
	mov	@r5	,r0		; return kbddb in r0.
	clc				; no errors
	return

ccstate:call	$zapfqb			; see if job is in KB ^C wait
	movb	#uu.sys	,firqb+fqfun	; do a job systat part 2
	incb	firqb+5			; 
	movb	pkjob2(r4),firqb+4	; where the job number goes
	asrb	firqb+4			; not times two for .uuo
	.priv				; of course
	.uuo				; get rsts
	cmp	firqb+14,#js.kb		; jbwait show a kb wait ?
	clc				; restore possible c bit set
	bne	10$			; no, time to leave now.
	mov	firqb+32,@r5		; stuff JDB address for a peek
	add	#6	,@r5		; we need address of jdwork
	.priv				; of course
	.peek				; sneak a look at the exec
	add	#10.	,@r5		; finally where to look at in
	.priv				; the job's work block.
	.peek				; and so on .......
	tst	@r5			; < 0
	bpl	10$			; no, exit with no wait
	 sec				; yes, flag as ^C(0) wait.
10$:	return


	.sbttl	check out the pk's status


ttyou:	mov	r0	,@r5		; see if pk is doing tt output
	add	#10.	,@r5		; check buffer chains
	.priv				; you know
	.peek				; only a privledged few can do
	mov	@r5	,-(sp)		; this, you know.
	mov	r0	,@r5		; one more time please
	add	#12.	,@r5		; and so on
	.priv				; 
	.peek				; and get the peeker
	cmp	(sp)+	,@r5		; empty yet ?
	bne	10$			; no
	clc				; yes
	return

10$:	sec
	return


;	note: following code from ATPK (with minor mods)

pksts:	save	<r0,r1>
	call	pkjobn			; get the job number for PKn:
	clr	r0			; are we the same job number ?
	mov	pkjob2(r4),r1		; save it here
	cmpb	r1	,ujob2(r4)	; if so, then login is not done
	bne	10$			; ok
	 com	r0			; no, we are the same job.
10$:	tstb	r1			; a real job there yet ?
	beq	20$			; no
	 call	$zapfqb			; yes, get the job's ppn
	 movb	#uu.sys	,firqb+fqfun	; use the uu.sys instead of
	 movb	r1	,firqb+4	; of a bunch of peeking at
	 asrb	firqb+4			; rsts.
	 .priv				; you know
	 .uuo				; get job stats function 0
	 mov	firqb+26,r1		; and stuff ppn into r1.
20$:	tst	upriv(r4)		; running in (1,*) ?
	bne	30$			; yes, status is ok for now
	tst	r1			; try ppn (or jobnun times 2)
	bne	30$			; real ppn or job number
	 mov	#-2	,r0		; set bad status up

30$:	tst	r0			; bad status by now ?
	bne	100$			; yes, time to go for now.

	 call	$zapxrb			; ok so far, is the PK in a
	 mov	#str.cr	,xrb+xrloc	; condition to accept stuff
	 inc	xrb+xrlen		; buffer size of 1
	 inc	xrb+xrbc		; same thing goes here
	 movb	pklun2(r4),xrb+xrci	; channel number times 2
	 mov	#6	,xrb+xrmod	; basic+ 'record' modifier if kb
	 .priv				; once again
	 .write				; finally !
	 movb	@r3	,r0		; errors ?

100$:	tst	r0			; errors ?
	beq	110$
	 sec				; tst does a clc,'mov' leaves it
110$:	 unsave	<r1,r0>			; pop regs, retain status and
	 return				; exit


	.sbttl	openpk	- open 'pk?:' as file 2

openpk:	mov	#-1,r1			; init pk at -1

10$:	inc	r1			; next pk
	call	$zapfqb			; clean firqb
	movb	pklun2(r4),@#firqb+fqfil ; channel 2
	mov	#buflen,@#firqb+fqbufl	; buffer length
	mov	#"PK,@#firqb+fqdev	; 'pk?:'
	movb	r1,@#firqb+fqdevn	; pk number
	movb	#-1,@#firqb+fqdevn+1	; unit is real
	movb	#opnfq,@#firqb+fqfun	; open function
	.priv				; have rsts
	calfip				; open the pk
	movb	@r3	,r0		; any problems?
	beq	30$			; no, go return
	cmpb	#notavl,@r3		; not available ?
	beq	10$			; yes, try for another
	cmpb	#nodevc,@r3		; not valid device ?
	bne	50$			; unknown RSTS error happened
	.print	#nopk
	br	50$			; bye

30$:	call	$zapfqb			; zap firqb
	movb	#uu.fcb,@#firqb+fqfun	; fcb function
	movb	pklun2(r4),@#firqb+fqfil ; channel 2
	asrb	firqb+fqfil		; not times two here
	.priv				; have rsts
	.uuo				; return fcb info
	movb	@r3	,r0		; any problems ?
	bne	40$			; yes, fatal
	movb	@#firqb+fqext,r1	; kb * 2
	asrb	r1			; pk's kb#:
	movb	r1	,pkkbn(r4)	; save it
	call	$zapfqb			; zap firqb again
	movb	#uu.trm,@#firqb+fqfun	; ttyset function
	mov	#-1,@#firqb+fqfil	; list attributes
	.priv				; have rsts
	.uuo				; return ttyset info
	movb	@r3	,r0		; any problems ?
	bne	40$			; yes, fatal
	movb	#uu.trm,@#firqb+fqfun	; ttyset function
	movb	#-1,@#firqb+fqfil	; chr$(255%)
	movb	r1,@#firqb+fqfil+1	; pk device
	.priv				; have rsts
	.uuo				; do a ttyset
	movb	@r3	,r0		; any problems ?
	bne	40$			; yes, fatal
	clc
	return				; back to work...

40$:	call	errmsg			; say the error
	.print	#fatbug			; say we have internal error
50$:	sec
	return

	.sbttl	log the job in

	.iif ndf, uu.tb3,uu.tb3 = -29.

$pklog::
login:	call	$zapfqb			; clear out the firqb to set
	movb	#uu.tb3	,firqb+fqfun	; do a uu.tb3 to see if the field
	.priv				; for UNTLVL is zero or real. if
	.uuo				; real then we haev version 8.0
	tst	firqb+12		; if version 8 then we will try
	beq	10$			; the new uu.job format
	call	logv8			; version 8.0
	bcc	100$			; it worked
10$:	call	logv7			; either version 7 or new call failed
100$:	return


logv8:	call	$zapfqb			; version 8, enter a run time system
	mov	#firqb+fqfun,r0		; at the p.new entry point
	movb	#uu.job	,(r0)+		; create a job function for fip
	movb	#20!100!200,(r0)+	; create logged in @ defkbm always
	movb	pkkbn(r4),(r0)+		; kb number to attach to job
	clr	(r0)+			; unused field
	mov	<urts+0>(r4),(r0)+	; user's default run time system
	mov	<urts+2>(r4),(r0)+	; both rad50 words please
	clr	(r0)+			; unused field

	mov	newppn(r4),@r0		; try for the passed ppn
	beq	10$			; nothing
	cmpb	#1	,uppn+1(r4)	; is our caller perm priv?
	beq	20$			; yes
	 cmpb	#1	,newppn+1(r4)	; no, is the caller trying
	 bne	20$			; for a priv account ?
10$:	 mov	uppn(r4),@r0		; ppn to login job into.
20$:	bisb	#40	,firqb+4	; set flag for account to login to
	movb	corcom	,-(sp)		; save this please
	clrb	corcom			; core common is also passed
	.priv				; get set to do it now
	.uuo				; try to create the job now
	movb	(sp)+	,corcom		; restore first byte of core common
	movb	firqb	,r0		; did it work?
	bne	110$			; no
	clc				; yes, flag success and exit
	return				; bye

110$:	sec				; job creation failed, exit
	return				; set a flag and return

	

logv7:	call	$zapfqb
	mov	#firqb+fqfun,r0		; up the spawn of LOGIN.
	movb	#uu.job	,(r0)+		; create a job call to .uuo
	movb	#128.	,(r0)+		; create if logins disabled.
	clrb	(r0)+			; must be zero (?)
	mov	#402	,(r0)+		; the project programmer (1,2).
	mov	plogin	,(r0)+		; first part of program to run
	mov	plogin+2,(r0)+		; which is normally $LOGIN.*
	mov	plogin+4,(r0)+		; extension
	clr	(r0)+			; skip next (paramter data)
	mov	<urts+0>(r4),(r0)+	; the new job's default run time
	mov	<urts+2>(r4),(r0)+	; system (usaully BAS4F ! BASIC)
	mov	newppn(r4),@r0		; try for the passed ppn
	beq	10$			; nothing
	cmpb	#1	,uppn+1(r4)	; is our caller perm priv?
	beq	15$			; yes
	 cmpb	#1	,newppn+1(r4)	; no, is the caller trying
	 bne	15$			; for a priv account ?
10$:	 mov	uppn(r4),@r0		; ppn to login job into.
15$:	tst	(r0)+			; fix firqb pointer
	movb	pkkbn(r4),(r0)+		; kb number for the job.
	mov	#29000.	,firqb+34	; paramter word
	.priv				; prefix ?
	.uuo				; create the job please
	movb	@r3	,r0		; errors ???
	bne	100$			; yes, we will die then
	$sleep	#1
	mov	#20.	,r1		; loop count for login wait
20$:	call	pksts			; pk is ready yet ?
	bcc	30$			; yep
	 $sleep	#1			; no keep trying for a while
	sob	r1	,20$		; ok ?
	.print	#crfail			; die
	br	110$

30$:	clr	r0
	return

100$:	call	errmsg			; print the error and die
110$:	sec				; set return code
	return


	.sbttl	record	- record the session

record:
	mov	cmds(r4),r2
	call	$zapfqb			; close the kb up for a moment.
	movb	#clsfq	,firqb+fqfun	; calfip function to close a
	movb	kblun2(r4),firqb+fqfil	; file.
	.priv				; as usual
	calfip				; thats all there is to it.
	call	openkb			; open it mode 1


10$:	bit	#f$nopr	,abortf(r4)	; kill on logout?
	beq	15$			; no
	 mov	pkddb(r4),xrb+0		; get ddb address
	 add	#2	,xrb+0		; need to look at the jobnumber
	 .priv				; times 2
	 .peek				; if no job number then the
	 tstb	xrb+0			; pk has logged out
	 beq	60$			; if so, abort and return

15$:	call	getkb			; get kb data
	cmp	#1,rcount(r4)		; recount = 1
	bne	20$			; no, continue
	movb	@r4,r0			; take first byte
	bicb	#200,r0			; trim parity
	cmpb	r0,#'D-100		; is it term character ?
	bne	20$			; yes, go return
	 bit	#f$ctld	,abortf(r4)	; really exit on control D ?
	 bne	60$			; yep

20$:	cmpb	#daterr,@r3		; nothing there ?
	beq	30$			; yes, try pk
	cmpb	#detkey	,@r3		; controling job detach ?
	beq	60$			; no
	callr0	putpk	,r4		; put out to the pk
	br	35$

30$:	call	pksts			; Is the job ready for a
	bcs	35$			; a command yet ?
	callr0	ttyou	,pkddb(r4)	; currently printing on PK:
	bcs	35$			; yep
	callr0	ttyou	,kbddb(r4)	; check tty out
	bcs	35$			; TTY is still busy then
	tst	(r2)			; next command ?
	beq	31$			; all done folks
	 call	docmd			; do a command
	 br	35$

31$:	 call	jstop			; End of comamnds, see if we
	 bcs	60$			; should quit now.


35$:	call	getpk			; get pk data
	cmpb	#eof,@r3		; pk say anything ?
	bne	40$			; yes, continue
	$sleep	#stim			; take a quick nap here
	br	55$			; and try later

40$:
	call	errchk			; scan for a '?' as first char
	bcc	50$			; no, all is well
	 tst	abortf(r4)		; keep going on error (<0) ?
	 bmi	50$			; yep
	  call	putkb			; a problem, print error out
	  call	putout
	  mov	#-1	,r0		; and exit
	  br	70$

50$:	call	putkb			; tell the kb
	call	putout
55$:	call	timchk			; job elapsed time run out yet?
	bcs	70$			; yep, so exit now.
	br	10$

60$:	clr	r0			; a normal exit
70$:	return


	.sbttl	stop	check for termination yet

jstop:	bit	#f$eot	,abortf(r4)	; stop on end of the command
	bne	100$			; yes, bye
	bit	#f$kmon	,abortf(r4)	; stop on control c wait(0)
	beq	90$			; no
	 call	ccstate			; check for ^C state
	 bcs	100$			; exit if cc wait

90$:	clc
	return

100$:	sec
	return



docmd:	mov	@r2	,r0		; compute command line length
10$:	tstb	(r0)+			; end of .asciz string ?
	bne	10$			; no
	sub	@r2	,r0		; yes, get length now
	dec	r0			; off by one
	mov	r0	,rcount(r4)	; put it there for putpk
	callr0	putpk	,(r2)+		; and do it
100$:	return


	.if	eq	,edrt		; normal mode
	.ift

timchk:	dec	cyc(r4)			; check job time yet ?
	bgt	100$			; no, just exit.
	mov	#swait	,cyc(r4)	; check, so reset cycle count.
	tst	timout(r4)		; but should we check at all ?
	ble	100$			; no, so just exit.
;-	call	$zapfqb			; clear out firqb for uu.sys
;-	movb	#uu.sys	,firqb+fqfun	; set uuo function (job systat)
;-	movb	pkjob2(r4),firqb+fqfun+1; insert job number here
;-	asrb	firqb+fqfun+1		; not times two please.
;-	.priv				; just in case (is global sym)
;-	.uuo				; get job stats back in firqb
;-	sub	timini(r4),firqb+12	; get total time controlling pk
;-	cmp	firqb+12,timout(r4)	; time to abort job yet ?
	.priv				; the pk job stats only seem to
	.time				; get updated whenever there is
	sub	timini(r4),xrb+2	; some activity on the job's pk
	cmp	xrb+2	,timout(r4)	; so use controlling jobs time.
	blt	100$			; If lt, do not kill pkjob yet.
	mov	#-3	,r0		; set return status code.
	sec				; yes, also set carry. Now exit
	return				; for job time exceeded.

100$:	clc
	return

	.iff				; skip this for inclusion into
					; ted.
timchk:	clc				; return all is well for TED.
	return

	.endc				; .if eq, edrt


	.sbttl	getkb	- get data from kb

getkb:	call	$zapxrb			; clean xrb
	mov	#buflen,@#xrb+xrlen	; buffer length
	mov	r4,@#xrb+xrloc		; buffer location
	movb	kblun2(r4),@#xrb+xrci	; channel 1
	mov	#8192.,@#xrb+xrmod	; record 8192%
	.priv				; have rsts
	.read				; read from kb
	mov	@#xrb+xrbc,rcount(r4)	; save rcount
	return				; back to work...

	.sbttl	putkb	- put data to kb

putkb:	call	$zapxrb			; clean xrb
	mov	#buflen,@#xrb+xrlen	; buffer length
	mov	r4,@#xrb+xrloc		; buffer location
	mov	rcount(r4),@#xrb+xrbc	; byte count
	movb	kblun2(r4),@#xrb+xrci	; channel 1
	mov	#1,@#xrb+xrmod		; record 1%
	.priv				; have rsts
	.write				; write on kb
	return				; back to work...


	.sbttl	getpk	- get data from pk

getpk:	call	$zapxrb			; clean zrb
	mov	#buflen,@#xrb+xrlen	; buffer length
	mov	r4,@#xrb+xrloc		; buffer location
	movb	pklun2(r4),@#xrb+xrci	; channel 2
	.priv				; have rsts
	.read				; read from pk
	mov	@#xrb+xrbc,rcount(r4)	; save rcount
	beq	100$			; nothing there
	 movb	<lastch+1>(r4),lastch(r4);shuffle last char from prev
	 mov	rcount(r4),-(sp)	; read and store the last char
	 add	r4	,(sp)		; from this read in there.
	 dec	(sp)
	 movb	@(sp)+	,<lastch+1>(r4)	; finally !

100$:	return				; back to work...


	.sbttl	putpk	- put data to pk

putpk:	call	$zapxrb			; clean xrb
	mov	#buflen,@#xrb+xrlen	; buffer length
	mov	r0,@#xrb+xrloc		; buffer location
	mov	rcount(r4),@#xrb+xrbc	; byte count
	movb	pklun2(r4),@#xrb+xrci	; channel 2
	mov	#9.,@#xrb+xrmod		; record 9%
	.priv				; have rsts
	.write				; write to pk
	return				; back to work...

	.sbttl	write to optional disk log


	.if eq	,edrt			; save address space for ted
	.ift

putout:	save	<r0,r1,r2>
	tst	outf(r4)		; a file open 
	beq	100$			; no, just exit then
	mov	rcount(r4),r0		; number of bytes to put out
	beq	100$			; nothing to do if zero
	mov	r4	,r2		; string to put into buffer


10$:	mov	outbfa(r4),r1		; address of the output buffer
	cmp	outfpnt(r4),#1000	; buffer full yet ?
	blo	30$			; no

	call	wrtout			; yes, dump buffer out to disk
	clr	outfpnt(r4)		; and init the buffer pointer
	save	<r0,r1>			; now clear the buffer out
	mov	#1000	,r0		; 1000 bytes to clear
20$:	clrb	(r1)+			; r1 already had the buffer addres
	sob	r0	,20$		; next byte please
	unsave	<r1,r0>			; pop these back

30$:	add	outfpnt(r4),r1		; point to next free byte in buffer
	movb	(r2)+	,@r1		; next byte please
	inc	outfpnt(r4)		; get set for next byte
	sob	r0	,10$		; next please

100$:	unsave	<r2,r1,r0>
	return



wrtout:	save	<r0>
	call	$zapxrb
	mov	#xrb	,r0		; pointer to xrb
	mov	#1000	,(r0)+		; xrb.xrlen := 1000 (8)
	mov	#1000	,(r0)+		; xrb.xrbc  := 1000
	mov	outbfa(r4),(r0)+	; xrb.xrloc := buffer_address
	movb	outflu(r4),@r0		; channel number times 2
	.priv				; rt11.rts prefix needed?
	.write				; simple
	unsave	<r0>
	return
	
	.iff				; if edrt <> 1 then dummy call

putout:
wrtout:	return

	.endc				; if eq, edrt


	.sbttl	error checking on the PK

	.if	eq	,edrt		; leave out for ted, else in
	.ift				; not ted

errchk:	save	<r0,r1,r2>
	mov	r4	,r2		; address of text to check
	mov	rcount(r4),r1		; initial length 
10$:	clr	r0			; position in the string
	mov	r2	,-(sp)		; replace instr call please
	mov	r1	,-(sp)		; save pointer and length
	ble	25$			; no text in the string ?
20$:	inc	r0			; pos := succ(pos)
	cmpb	(r2)+	,#'?		; find a possible error msg?
	beq	25$			; perhaps
	sob	r1	,20$		; no, try the next one
	clr	r0			; no match, set position to 0
25$:	mov	(sp)+	,r1
	mov	(sp)+	,r2
	cmp	r0	,#1		; by a line terminator like
	blt	100$			; a cr,lf or ff.
	bgt	30$			; Not at start of the line
	 cmp	r2	,r4		; at the start of the record?
	 bne	30$			; no, nothing special to do.
	  cmpb	lastch(r4),#cr		; Was first char of record, look
	  bhi	40$			; at the last char of prev rec.
	  br	110$			; fatal error, exit with 'c'
30$:	mov	r2	,-(sp)		; Check preceeding char for 
	add	r0	,(sp)		; a line terminator here.
	dec	(sp)			; peek at the previous char
	dec	(sp)			; peek at the previous char
	cmpb	@(sp)+	,#cr		; well ?
	blos	110$			; bye
40$:	add	r0	,r2		; No error, skip past the '?'
	sub	r0	,r1		; and adjust the line length.
	bgt	10$			; and try once again


100$:	clc				; no error, exit ok
	br	120$			; pop registers and leave.
110$:	sec
120$:	unsave	<r2,r1,r0>
	return

200$:	.asciz	/?/

	.iff				; for ted, save the space

errchk:	clc				; no error
	return				; and exit

	.endc

errmsg:	movb	firqb	,firqb+4	; pass error number to fip
	movb	#errfq	,firqb+fqfun	; fip function
	.priv				; rt emu perhaps ?
	calfip				; simple to do
	clrb	firqb+37		; insure .asciz please
	.print	#firqb+4		; print the .asciz string
	return


	.sbttl	zero firqb out

	.if	eq	,edrt		; if not in TED, include this
	.ift

$zapfqb:

	mov	r0	,-(sp)
	mov	r1	,-(sp)
	mov	#firqb	,r1
	mov	#40/2	,r0
1$:	clr	(r1)+
	sob	r0	,1$
	mov	(sp)+	,r1
	mov	(sp)+	,r0
	return

	.iff

	global	<$zapfqb>

	.endc

$zapxrb:mov	r0	,-(sp)
	mov	#xrb	,r0
10$:	clr	(r0)+
	cmp	r0	,#xrb+xrmod
	ble	10$
	mov	(sp)+	,r0
	return



lprint:	mov	r0	,-(sp)		; .asciz string printer. put
	mov	6(sp)	,r0		; it here to avoid global refs
	bne	20$			; a real length was passed
	mov	4(sp)	,r0		; zero length, assume .asciz
10$:	tstb	(r0)+			; and find the length of it
	bne	10$			; no, keep going
	sub	4(sp)	,r0		; subtract string address from
	dec	r0			; current pointer + 1.
20$:	call	$zapxrb			; clear xrb out
	mov	4(sp)	,xrb+xrloc	; stuff buffer address for RSTS
	mov	r0	,xrb+xrlen	; and the length twice
	mov	r0	,xrb+xrbc	; again
	.priv				; rt perhaps?
	emt	4			; do a .write
	mov	(sp)+	,r0		; pop the register we used
	mov	(sp)	,4(sp)		; bubble return address up
	cmp	(sp)+	,(sp)+		; pop parameter list at last
	return				; bye



	.end