.TITLE	QUERRY - State Transition based querry program
.IDENT	/200783/
.ENABL	LC
;
;
;	Written by	Ray Di Marco
;			6-Apr-83.
;
;
;	Version		060483/06
;
;
;----------------------------------------------------------------------------
;
; This is the main module for the QUERRY program; its function is to traverse
; a state transition database. The database consists of questions and exits
; dependant upon the answer given to the question; the output is a .STS type
; file.
;

.SBTTL	Modifications
;
;
; 23-Apr-83
;
;	Change initialization code that setups up TSX-plus TTY i/o mode
;	Change initialization code to create output file of 32 blocks
;	Change buckup code to release variables as appropriate.
;	Change DSPQST routine code to support (>ddd) external help file.
;	 	(To do this had to add in DSPHLP routine; this routine
;		attempts to open and type out the contents of the file
;		DK:DDDD.HLP. The routine acts as a NOP if the file cannot
;		be found.)
;	Change VARPNT routine so that variables 1-7999!10 refer to answers.
;		(Variables 8000!10 onwards are memory variables; variables
;		1-7999!10 are the last answers given in response to the
;		questions associated with that state. The routine ENTPNT
;		was included to retrieve the latest answer for a given
;		state.)
;
;
; 29-Apr-83
;
;	Change DSPQST so that if force variable for a non-suppressed
;		question is specified but not defined, force variable
;		is completely ignored!
;
; 3-May-83
;	Change initialization code to loop if no file name specified
;	Change DSPQST to display answer resulting from change of 29-Apr-83.
;
; 8-Jun-83
;	Change process code to update VARBUE (cached variable)
;
; 19-Jul-83
;	Add in support for String answer case statement of form +NNN
;	Trap suppressed question, no answer problem
;	Support ^L --> erase screen in help text
;

.SBTTL	Declarations
;
;
.MCALL	.EXIT,.PRINT,.CHAIN,.GTIM	; RT-11
.MCALL	.TTYOUT,.GVAL,.TWAIT,.GTLIN	; RT-11
.MCALL	CNAF,FILSPT,.PUSH,.POP,.DATE,ENCODE
	FILSPT
;
;
.GLOBL	TBLKUP,ASCNUM,ENCODE
;
O.QSTN	=	0
S.QSTN	=	50.
O.DFLT	=	50.
S.DFLT	=	20.
O.YX	=	70.
O.NX	=	76.
O.SX	=	82.
O.FRMT	=	88.
O.USE	=	108.
O.PUT	=	110.
O.FRCE	=	112.
;
	.asect
	.	= 3000			;	need extra stack
;
	.PSECT	CODE			;	open code area
;	======	====
;

.SBTTL	Macro Definitions
;
; The TSXSET and TSXCLR macros are used to set/clear bits in the jobs
; TSX-plus status words.
;
.MACRO	TSXSET	MSK,DST			; Set bits in TSX JSWs
	MOV	MSK,-(SP)
	MOV	DST,-(SP)
	MOV	#<130*400+2>,-(SP)
	MOV	SP,R0
	EMT	375
	ADD	#6,SP
.ENDM	TSXSET
.MACRO	TSXCLR	MSK,DST			; CLR bits in TSX JSWs
	MOV	MSK,-(SP)
	MOV	DST,-(SP)
	MOV	#<130*400+3>,-(SP)
	MOV	SP,R0
	EMT	375
	ADD	#6,SP
.ENDM	TSXCLR
;
;
; The PRINT macro outputs LEN bytes @BUF
;
.MACRO	PRINT	BUF=R0,LEN=R1
	MOV	LEN,-(SP)
	MOV	BUF,-(SP)
	MOV	#<114*400+0>,-(SP)
	MOV	SP,R0
	EMT	375
	ADD	#6,SP
.ENDM	PRINT
;
;
; OUTSTR outputs the string STR; BYTS is an option byte to output (viz CR>
;
.MACRO	OUTSTR	STR,BYTS,?A,?B,?C,?D
	MOV	#'C-'B,-(SP)
	MOV	#'B,-(SP)
	MOV	#<114*400+0>,-(SP)
	MOV	SP,R0
	EMT	375
	ADD	#6,SP
	BR	D
B':	.ASCII	/'STR'/'BYTS
C':	.EVEN
D':
.ENDM	OUTSTR
;
;
; ABORT is used to abort execution if CND is true; MES is printed out
;
.MACRO	ABORT	MES,CND,RTN=ABORT,?LA,?LB,?BB,?LC
	.IF NB,CND
			B'CND	'BB	;;;
			BR	LC
BB':
	.ENDC
	JSR	R1,RTN
	.ASCII	/'MES'/<200>
	.EVEN
	.IIF NB,CND,	LC':
.ENDM	ABORT
;
;
;
; The DO.EMT macro is used to execute a TSX EMT and trap any errors
;
.MACRO	DO.EMT	EAB=R0,ERR,?LA,?LB
	.IIF	DIF,EAB,R0,	MOV	EAB,R0
	EMT	375
	.GLOBL	ABORT
	BCC	LB
	JSR	R1,ABORT
	.ASCII	/'ERR'/<200>
	.EVEN
LB':
.ENDM	DO.EMT
;

.SBTTL	Command Dispatcher Loop
;
; get here iff too many characters typed in as answer; tell about mistake
; and retry question.
;
OVERFL:	OUTSTR	<QUERRY-warning-please truncate answer to 20 chars>,<<15><12>>
1000$:	MOV	#E.CHK,R0		; R0 ->	eab
	EMT	375			;	any input left?
	BCS	CMDDSP			;	 no --> skip
	MOV	#E.INP,R0		;	 yes -> flush input
	EMT	375			;		 buffer
	BR	1000$			;		loop
;
; get here when have to process next state; display question and use input
; stored in variable if a Forced variable defined.
;
CMDDSP:	CALL	DEBUG			;	********
	CALL	DSPQST			;	display question
	TST	O.FRCE(R4)		;	Force variable defined?
	BEQ	40$			;	 no --> skip
	CMPB	(R4),#'$		;	Suppressed question?
	BEQ	20$			;	 yes ->	skip
	OUTSTR	<>,<<15><12>>		;	 no -->	output <CR><LF> @eol
20$:	MOV	#$$INIT,R0		;	 yes ->	don't allow
	CALL	1000$			;		 operator to override
;
; Get input from operator
;
40$:	MOV	#E.INP,R0		; R0 ->	EAB
	EMT	375			;	get input
	CMP	R0,#22.			;	overflowed buffer
	BHI	OVERFL			;	 yes -> flag error
	CLRB	$$INIT(R0)		;	terminate input string
	MOV	#$$INIT,R0		; R0 ->	input
;
; decode using 700$ table
;
100$:	MOV	#700$,R1		; R1 ->	table of characters
110$:	CMPB	(R0),(R1)		;	match?
	BEQ	170$			;	 yes ->	skip
	ADD	#4,R1			;	 no --> try next entry
	TSTB	(R1)			;	@EOT?
	BNE	110$			;	 no --> loop
	INC	R0			;	 yes -> point next character
	BR	100$			;		restart scan
;
; character in decode table, therefore perform required function
;
170$:	CALL	@2(R1)			;	process char
	BR	100$			;	restart scan
;

;
; decode table
;
700$:	.WORD	15,1000$		;	process input
	.WORD	'^,2000$		;	backup a question
	.WORD	'!,CON$EX		;	abort
	.WORD	'|,CON$EX		;	abort
	.WORD	0,770$			;	eot
770$:	ABORT	<CMDDSP:logic error>
;
;
; perform state transition
;
1000$:	CALL	DECODE			;	valid answer?
	BCS	1700$			;	 no -->	repeat question
1700$:	ADD	#2,SP			;	clear return address
	JMP	CMDDSP			;	process state
;
; backup a question
;
2000$:	OUTSTR	<>,<<15><12>>		;	dummy <CR> at EOL
2010$:	MOV	VARENT,R0		; R0 =	last entry written
	BEQ	2100$			;	skip if at first
	DEC	VARENT			;	discard it
	CALL	ENTGET			;	get entry
	MOV	...STS,R4		; R4 =	previos state
	CMP	R4,VARBUE		;	if reprocess the state whose
	BNE	2030$			;	 answer is in VARBUE variable
	CLR	VARBUE			;	  must reset/clear VARBUE
2030$:	CALL	GETRR4			;	load state record
	MOV	...STK,R0		;	fix up
	MOV	...STK+2,VARSTK+2(R0)	;	 call
	MOV	R0,VARSTK		;	  stack
	MOV	...QST,VARQST		;	fix up
	DEC	VARQST			;	 question number
	CMP	O.PUT(R4),#8000.	;	Put variable defined?
	BLO	2070$			;	 no --> skip
	MOV	O.PUT(R4),R0		; R0 =	Put variable name
	CALL	VARPNT			; R0 ->	to variable
	BCS	2070$			;	skip if not found
	CLR	(R0)			;	release variable
2070$:	TST	O.FRCE(R4)		;	Force variable defined?
	BNE	2010$			;	 yes -> skip over it
2100$:	ADD	#2,SP			;	discard return address
	JMP	CMDDSP			;	process state
;

.SBTTL	Routine - "DSPQST"	...	display state question
;
; This routine is called to display the questions associated with the state
; record pointed to be R4; it also displays the default answer. The routine 
; also supports Force and Use variables; if a Force or Use variable is 
; defined, the default answer stored in the record is updated accordingly.
;
; Don't display question if starts with a $ symbol
;
DSPQST:	.PUSH	<R0,R1,R2>		;	save registers
	CMPB	(R4),#'>		;	external text available?
	BNE	10$			;	 no --> skip
	CALL	DSPHLP			;	 yes -> display help text
10$:	CMPB	(R4),#'$		;	suppress question?
	BNE	200$			;	 yes -> skip
;
; if question suppressed then answer must be supplied from Force variable
;
100$:	MOV	O.FRCE(R4),R0		; R0 =	Force variable name
	BEQ	170$			;	 none defined --> abort
	CALL	VARPNT			; R0 ->	to it
	BCC	3040$			;	process if found
	BR	4000$			;	 else use DEFAULT
170$:	ABORT	<DSPQST:missing Force variable in >,RTN=RECERR
;
; First time only question is displayed output question number
;
200$:	CMP	VARENT,6000$		;	asked question before?
	BNE	400$			;	 no --> output quest num
	OUTSTR	<    >			;	 yes ->	no quest number
	BR	1000$			;		skip
400$:	MOV	VARENT,6000$		;	remember have been here
	INC	VARQST			;	update question number
	CNAF	SSD,STRING=#7100$,NUMBER=VARQST;convert to ascii
	.PRINT	#7100$			;	display question number
;
; Display question
;
1000$:	MOV	#S.QSTN,R2		; R2 =	counter
	MOV	R4,R1			; R1 ->	input
1100$:	CMPB	(R1)+,#40		;	blank character?
	BNE	1200$			;	 no --> skip
	SOB	R2,1100$		;	 yes -> loop
	ABORT	<DSPQST:no question for >,RTN=RECERR
1200$:	PRINT	R4,#S.QSTN		;	display question
;
; Use Force variable as default answer if one defined
;
2000$:	MOV	O.FRCE(R4),R0		; R0 =	Force variable name
	BEQ	3000$			;	 none defined  --> skip
	CALL	VARPNT			; R0 ->	point to variable
	BCS	2070$			;	 cannot locate --> skip
	BR	3040$			;	use FORCE as answer
2070$:	CLR	O.FRCE(R4)		;	disable force
;

;
; Use Use variable as default answer if one defined
;
3000$:	MOV	O.USE(R4),R0		;	is Use variable defined?
	BEQ	4000$			;	 no --> skip
	CALL	VARPNT			;	 yes -> point R0 to it
	BCS	4000$			;	ignore if null
3040$:	ADD	#2.,R0			; R0 ->	variable contents
	MOV	R4,R1			; R1 ->	record
	ADD	#O.DFLT,R1		; R1 ->	default answer
	MOV	#S.DFLT,R2		; R2 =	counter
3100$:	MOVB	(R0)+,(R1)+		;	use variable as
	SOB	R2,3100$		;	 default answer
;
; Display default answer
;
4000$:	CMPB	(R4),#'$		;	suppress question?
	BEQ	5000$			;	 yes -> suppress answer
	MOV	R4,R0			; R0 ->	record
	ADD	#O.DFLT,R0		; R0 ->	default answer
	PRINT	R0,#S.DFLT		;	display default answer
	PRINT	#7000$,#S.DFLT		;	step back cursor
5000$:	.POP	<R2,R1,R0>		;	restore
	RETURN				;	done
;
;
;
6000$:	.WORD	-1			;	last entry processed
7000$:	.ASCII	<10><10><10><10><10><10><10><10><10><10>
	.ASCII	<10><10><10><10><10><10><10><10><10><10>
	.ASCII	<10><10><10><10><10><10><10><10><10><10>
7100$:	.ASCII	|XXX |<200>
.EVEN

.SBTTL	Routine - "DSPHLP"	...	display help text
;
; This routine is called with R4 holding the address of the state question.
; If the first characters in the question are >D..D (D=digit), the routine
; will type the contents of the file 'DDDDD.HLP' on the screen. The routine
; will MUNG the question to remove the >D..D characters. All registers are
; saved.
;
; Save registers and setup to load R2 with number of help text file needed
;
DSPHLP:	.PUSH	<R0,R1,R2,R3,R4,R5>	;	save all registers
	CLR	R2			; R2 =	accumulator
	MOV	R4,R1			; R1 ->	question
	CMPB	(R1)+,#'>		;	delimiter?
	BNE	7000$			;	 no --> abort
100$:	MOVB	(R1)+,R0		; R0 =	character
	SUB	#'0,R0			;	convert to binary
	CMP	R0,#'9			;	valid?
	BHI	200$			;	 no -> abort
	ASL	R2			; R2 =	NUM*2
	ADD	R2,R0			; R0 =	NUM*2+DIGIT
	ASL	R2			; R2 =	NUM*4
	ASL	R2			; R2 =	NUM*8
	ADD	R0,R2			; R2 =	NUM*10+DIGIT
	BR	100$			;	loop
;
; if have a valid help text number mung defualt answer to remove >ddd as don't
; want operator to see >ddd when default is output; also prevents us from
; re-displaying the help text if must ask the question again.
;
200$:	TST	R2			;	have a valid number?
	BEQ	7000$			;	 no -> abort	
	MOV	R4,R0			; R0 ->	start question
	MOV	R4,R3			; R3 ->	start question
	ADD	#S.QSTN,R3		; R3 ->	end question
210$:	MOVB	(R1)+,(R0)+		;	left
	CMP	R1,R3			;	 justify
	BLO	210$			;	  question
220$:	MOVB	#40,(R0)+		;	pad
	CMP	R0,R3			;	 rest
	BLO	220$			;	  question
;
; if specified help text file already open attempt to minimize number of
; file I/Os needed.
;
	CMP	R2,HLPNUM		;	is help file already open?
	BNE	700$			;	 no --> skip
	MOV	#FDBHLP,R5		;	 yes ->	point to FDB
	BIS	F.NERR,FDB.FL(R5)	;	disable error messages
	TST	FDB.BL(R5)		;	block 0 in memory?
	BEQ	1100$			;	 yes ->	dump it out
	BR	770$			;	 no -->	read it in
;

;
; desired help file not open; open it up
;
700$:	CNAF	FFFFD,STRING=#$$INIT	;	convert to ascii
	CLRB	(R1)			;	terminate
	CLR	HLPNUM			;	no help file open
	PURGE	#FDBHLP			;	insure FDB free
	BIS	#F.NERR,FDB.FL(R5)	;	disable errors
	NAME	STRING=#$$INIT,EXTENS=#^RHLP,ERROR=7000$
	LOOKUP	ERROR=7000$
;
; read in help file a block at a time and dump it out
;
770$:	CLR	FDB.BL(R5)		;	reset block count
1000$:	READ	ERROR=7000$		;	read block
	TST	FDB.BL(R5)		;	block 0?
	BNE	1070$			;	 no --> skip
	CMPB	BUFHLP,#'L-'@		;	<FF>?
	BNE	1070$			;	 no --> skip
	.PRINT	#7700$			;	 yes -> erase screen
	CLRB	BUFHLP			;		delete FF
1070$:	INC	FDB.BL(R5)		;	bump block count
1100$:	MOV	#BUFHLP+1000,R1		; R1 ->	end buffer
1200$:	TSTB	-(R1)			;	@eot?
	BEQ	1200$			;	 yes -> loop
	MOV	#BUFHLP,R0		; R0 ->	start buffer
	SUB	R0,R1			; R1 =	size of text
	INC	R1			;	allow for last byte
	PRINT	R0,R1			;	output
	CMP	R1,#1000		;	was block full?
	BEQ	1000$			;	 yes -> read in next block
;
; clean up and exit
;
7000$:	.POP	<R5,R4,R3,R2,R1,R0>	;	restore
	RETURN
;
7700$:	.ASCII	<33>/[2J/<33>/[H/<200>	;	erase screen
;

.SBTTL	Routine - "DECODE"	...	decode input in $$INIT buffer
;
; This routine is called to decode the input stored in the $$INIT buffer.
; It uses the input to see which of the three possible state exits is to
; be taken. On return the "C" flag is set iff the routine could not perform
; a state transition (ie input was not valid). If no input has been entered
; by the operator, the routine will use the default answer. At entry registers
; must be setup as follows
;
;		R0 ->	end of input string
;		R4 ->	state record being processed
;
; At exit R4 will hold the address of the new state record.
;
;
; if no answer entered use default answer stored in record
;
DECODE:	SUB	#$$INIT,R0		; R0 =	size of answer
	BNE	400$			;	 skip if non-blank answer
	MOV	R4,R0			; R0 ->	record
	ADD	#O.DFLT,R0		; R0 ->	default answer
	MOV	#$$INIT,R1		; R1 ->	destination
	MOV	#S.DFLT,R2		; R2 =	counter
100$:	MOVB	(R0)+,(R1)+		;	setup default
	SOB	R2,100$			;	 answer
	MOV	#S.DFLT,R0		; R0 =	size of answer
;
; pad out rest of string with spaces
;
400$:	MOV	#24.,R2			; R2 =	buffer size
	SUB	R0,R2			; R2 =	padding required
	ADD	#$$INIT,R0		; R0 ->	end of input
410$:	MOVB	#40,(R0)+		;	pad out
	SOB	R2,410$			;	 buffer
	CLRB	(R0)			;	terminate string
;
; better check to see that have some input
;
500$:	MOV	#S.DFLT,R2		; R2 =	counter
	MOV	#$$INIT,R1		; R1 ->	input
	MOV	#$$INIT,R0		; R0 ->	input
510$:	CMPB	(R1)+,#40		;	got any input?
	BNE	1000$			;	 yes -> process it
	SOB	R2,510$			;	 no --> time to
	CMPB	(R4),#'$		;	suppress question?
	ABORT	<DECODE:no answer to suppressed question in >,EQ,RTN=RECERR
	BR	3100$			;		 abort
;

;
; if YES exit enabled check to see if operator answered YES
;
1000$:	TST	O.YX(R4)		;	is "YES" a valid answer
	BEQ	2000$			;	 no --> skip
	MOV	#1700$,R1		; R1 ->	table
	CALL	TBLKUP			;	was answer Yes?
	BCS	2000$			;	 no --> skip
	MOV	#O.YX,R0		; R0 =	offset to exit state
	JMP	7000$			;	accept answer
1700$:	.WORD	1710$,0,0,0		;	decode table for YES
	.WORD	0,0,0,0			;	eot
 1710$:	.ASCIZ	|Y-ES|			;	
.even
;
;
; if NO exit enabled check to see if operator answered NO
;
2000$:	TST	O.NX(R4)		;	is "NO" a valid answer
	BEQ	3000$			;	 no --> skip
	MOV	#2700$,R1		; R1 ->	table
	CALL	TBLKUP			;	was answer NO?
	BCS	3000$			;	 no --> skip
	MOV	#O.NX,R0		; R0 =	offset to exit state
	JMP	7000$			;	accept answer
2700$:	.WORD	2720$,0,0,0		;	decode table for NO
	.WORD	0,0,0,0			;	eot
 2720$:	.ASCIZ	|N-O|			;	
.even
;
; see if will accept a general string
;
3000$:	MOV	#$$INIT,R0		; R0 ->	input
	TST	O.SX(R4)		;	string input enabled?
	BNE	4000$			;	 yes -> accept
3100$:	SEC				;	indicate invalid input
	RETURN				;	done
;

;
; attempt to accept string input; must insure that string matches format
; specifier. Meaning of bytes in format string are
;
;		D	digit
;		L	letter
;		A	ascii
;		<SPACE>	space
;		+	case clause (Format of +nnn -> goto SX+i i<=nnn)
;
4000$:	MOV	#S.DFLT,R2		; R2 =	number bytes in answer
	MOV	R4,R1			; R1 ->	record
	ADD	#O.FRMT,R1		; R1 ->	format string
	CMPB	(R1),#'+		;	CASE clause?
	BEQ	4600$			;	 yes -> special code
;
4100$:	MOVB	(R1)+,R3		; R3 =	format byte
	CMPB	R3,#'D			;	digit?
	BEQ	4200$			;	 yes -> skip
	CMPB	R3,#'L			;	letter?
	BEQ	4300$			;	 yes -> skip
	CMPB	R3,#'A			;	alpha?
	BEQ	4400$			;	 yes -> skip
	CMPB	R3,#40			;	spare?
	BNE	4700$			;	 no --> invalid format byte
	CMPB	(R0)+,#40		;	 yes -> must be a <SPACE>
	BNE	3100$			;	abort if not a space
4170$:	SOB	R2,4100$		;	loop till scan complete
	MOV	#O.SX,R0		; R0 =	offset to state exit in record
	JMP	7000$			;	accept input
;
; insure byte @R0 is a digit
;
4200$:	CMPB	(R0)+,#40		;	space?
	BEQ	4170$			;	 yes -> accept
	CMPB	-1(R0),#'0		;	is input
	BLO	3100$			;	 character a
	CMPB	-1(R0),#'9		;	  digit?
	BHI	3100$			;	 no --> abort
	BR	4170$			;	 yes -> accept
;
; insure byte @R0 is a letter
;
4300$:	CMPB	(R0),#'A		;	is input	
	BLO	3100$			;	 an upper
	CMPB	(R0),#'Z		;	  case letter?
	BLOS	4400$			;	 yes -> accept
	CMPB	(R0),#'A+40		;	is letter
	BLO	3100$			;	 a lower
	CMPB	(R0),#'Z+40		;	  case letter?
	BHI	3100$			;	 no --> abort
4400$:	TSTB	(R0)+			;	accept letter
	BR	4170$			;	loop
;
; Case clause
;
4600$:	CALL	ASCNUM			; R0 =	maximun number allowed
	MOV	R0,R3			; R3 =	maximum
	MOV	#$$INIT,R1		; R1 ->	input answer
	CALL	ASCNUM			; R0 =	response
	CMP	R0,R3			;	valid answer?
	BLOS	4610$			;	 yes -> accept
	CLR	R0			;	 no --> make valid
4610$:	ADD	R0,O.SX(R4)		;	adjust exit point
	MOV	#O.SX,R0		; R0 =	offset to state exit in record
	JMP	7000$			;	accept answer
;
; error trap
;
4700$:	ABORT	<DECODE:invalid FORMAT specifier in >,RTN=RECERR
;

;
; write out State number, Exit code and operator's answer
;
7000$:	MOV	R0,R3			; R3 =	offset to exit point
	ADD	R4,R3			; R3 ->	exit point
	MOV	RECNUM,...STS		;	setup STATE
	MOV	4(R3),...COD		;	setup CODE
	MOV	VARQST,...QST		;	setup question number
	MOV	VARSTK,R0		; R0 =	Call stack pointer
	MOV	R0,...STK		;	save stack pointer
	MOV	VARSTK+2(R0),...STK+2	;	save last item on stack
	MOV	#$$INIT,R0		; R0 ->	input
	MOV	#...ANS,R1		; R1 ->	buffer
	MOV	#S.DFLT,R2		; R2 =	buffer
7100$:	MOVB	(R0)+,(R1)+		;	copy answer
	SOB	R2,7100$		;	 into buffer
	INC	VARENT			;	bump pointer
	MOV	VARENT,R0		; R0 =	entry number
	CALL	ENTPUT			;	write out data
;
; If variable cached in memory update cached copy
;
	MOV	#$$INIT,R0		; R0 ->	input
	MOV	#VARBUE,R1		; R1 ->	cached variable
	MOV	#S.DFLT,R2		; R2 =	buffer
	CMP	(R1)+,RECNUM		;	last answer for state cached?
	BNE	7300$			;	 no --> skip
7200$:	MOVB	(R0)+,(R1)+		;	 yes ->	update
	SOB	R2,7200$		;	 	 cache buffer

;
; If Put variable defined save operator's answer in that variable for later
;
7300$:	MOV	O.PUT(R4),R0		; R0 =	Put variable name
	BEQ	7400$			;	skip if none defined
	CMP	R0,#8000.		;	memory variable?
	BLO	7400$			;	 no --> ignore
	CALL	VARPNT			;	already exits?
	BCC	7310$			;	 yes ->	skip
	CLR	R0			;	 no --> create
	CALL	VARPNT			;		 it
	ABORT	<DECODE:no room for variable in >,CS,RTN=RECERR
7310$:	MOV	O.PUT(R4),(R0)+		;	setup variable ID
	MOV	#$$INIT,R1		; R1 ->	answer
	MOV	#S.DFLT,R2		; R2 =	counter
7320$:	MOVB	(R1)+,(R0)+		;	save
	SOB	R2,7320$		;	 answer	
;
; Time to perform state transition. If opcode associated with exit is in
; 9000 range, perform special function (as indicated by 9000$ table), else
; switch state and exit.
;
7400$:	MOV	2(R3),R0		; R0 =	special function code
	ASL	R0			; R0 =	offset into table
	CMP	R0,#<9010$-9000$>	;	was it a special code?
	ABORT	<DECODE:invalid special function code in >,HIS,RTN=RECERR
	JMP	@9000$(R0)		;	 yes -> perform special func
7600$:	MOV	(R3),R4			; R4 =	next state
7610$:	CALL	GETRR4			;	load its record
7620$:	CLC				;	indicate all ok
	RETURN				;	done
;

;
; The 9000$ table is used to process exit points with an opcode in the
; 9000$ range
;
9000$:	.WORD	7600$			;	nop
	.WORD	11000$			;	terminate
	.WORD	12000$			;	call subroutine
	.WORD	13000$			;	return from subroutine
9010$:	.WORD	0			;	eot
;
; terminate program
;
11000$:	CALL	ENTEND			;	close output file
	JMP	CON$EX			;	done
;
;
; call subroutine state
;
12000$:	CMP	VARSTK,VARSTK+2		;	stack full?
	ABORT	<DECODE:call stack overflow in >,HIS,RTN=RECERR
	ADD	#2,VARSTK		;	 no -> reserve room
	MOV	VARSTK,R0		; R0 =	call stack pointer
	MOV	RECNUM,VARSTK+2(R0)	;	save caller's address
	JMP	7600$			;	perform call
;
; return from subroutine state
;
13000$:	MOV	VARSTK,R0		; R0 =	offset into stack
	ABORT	<DECODE:return stack empty, >,LE,RTN=RECERR
	MOV	VARSTK+2(R0),R4		; R4 ->	return address
	SUB	#2,VARSTK		;	release space
	CALL	GETRR4			; R4 ->	record address
	MOV	O.NX(R4),R4		; R4 ->	no exit
	ABORT	<DECODE:missing NO exit for RETURN, >,EQ,RTN=RECERR
	JMP	7610$			;	exit
;

.SBTTL	Routine - "GETRR4"	...	load record R4
;
; This routine is called to load the database record whose "rn" is in R4. On
; exit R4 holds the address of a 128 byte buffer that holds the record.
;
GETRR4:	.PUSH	<R0,R5>			;	save registers
	MOV	R4,RECNUM		;	save record number
	MOV	#FDBREC,R5		; R5 ->	FDB
	MOV	R4,R0			; R0 =	rn
	ASH	#-2,R0			; R0 =	block number
	CMP	R0,FDB.BL(R5)		;	block in memory?
	BEQ	2000$			;	 yes -> skip
	READ	BLOCK=R0,ERROR=7000$	;	 no -->	read block
2000$:	BIC	#^C3,R4			; R4 =	entry number in block
	ASH	#7,R4			; R4 =	offset into block
	ADD	FDB.BF(R5),R4		; R4 ->	data
	.POP	<R5,R0>			;	Restore
	RETURN				;
;
7000$:	ABORT	<GETRR4:database access failure>,RTN=ABORTF
;

.SBTTL	Routine - "RECERR"	...	record error trap handler
;
; This routine should be called to abort program execution due to an
; error in a status record; at entry R1 should point to a .ASCIZ message
; describing the cause of the error. The routine will display the
; error statistics, close out the output file and terminate execution.
;
RECERR:	OUTSTR	<>,<<15><12>>		;	new line
	OUTSTR	<QUERRY-fatal->		;	output header
	.PRINT	R1			;	output cause of error
	OUTSTR	< record number >	;	identify variable
	CNAF	FFFFD,NUMBER=RECNUM,STRING=#$$INIT
	CLRB	(R1)
	.PRINT	#$$INIT			;	show record that caused error
	CALL	ENTEND			;	close output file
	.EXIT				;	abort
;

.SBTTL	Routine - "ENTPUT"	...	output entry R0
;
; This routine output the contents of the 32 byte ENTBUF buffer to entry
; number R0 in the output file.
;
ENTPUT:	.PUSH	<R0,R1,R2,R5>		;	save registers
	MOV	R0,ENTNUM		;	save entry number
	MOV	#FDBOUT,R5		; R5 ->	FDB
	ASH	#-4,R0			; R0 =	block number offset
	ADD	#2.,R0			;	allow for 2 block header
	CMP	R0,FDB.BL(R5)		;	block in memory?
	BEQ	2000$			;	 yes -> skip
	READ	BLOCK=R0,ERROR=7000$	;	 no -->	read block
2000$:	MOV	ENTNUM,R0		; R0 =	entry number
	BIC	#^C17,R0		; R0 =	entry number in block
	ASH	#5,R0			; R0 =	offset into block
	ADD	FDB.BF(R5),R0		; R0 ->	data
	MOV	#ENTBUF,R1		; R1 ->	buffer
	MOV	#32.,R2			; R2 =	counter
3000$:	MOVB	(R1)+,(R0)+		;	copy buffer
	SOB	R2,3000$		;	 into entry
	WRITE	ERROR=7100$		;	write to file
	.POP	<R5,R2,R1,R0>		;	Restore
	RETURN				;
;
7000$:	ABORT	<ENTPUT:block read failure>,RTN=ENTERR
7100$:	ABORT	<ENTPUT:entry put failure>,RTN=ENTERR
;

.SBTTL	Routine - "ENTGET"	...	get entry R0
;
; This routine is called to load the ENTBUF with the contents of entry
; number R0.
;
ENTGET:	.PUSH	<R0,R1,R2,R5>		;	save registers
	MOV	R0,ENTNUM		;	save entry number
	MOV	#FDBOUT,R5		; R5 ->	FDB
	ASH	#-4,R0			; R0 =	block number offset
	ADD	#2.,R0			;	allow for 2 block header
	CMP	R0,FDB.BL(R5)		;	block in memory?
	BEQ	2000$			;	 yes -> skip
	READ	BLOCK=R0,ERROR=7000$	;	 no -->	read block
2000$:	MOV	ENTNUM,R0		; R0 =	entry number
	BIC	#^C17,R0		; R0 =	entry number in block
	ASH	#5,R0			; R0 =	offset into block
	ADD	FDB.BF(R5),R0		; R0 ->	data
	MOV	#ENTBUF,R1		; R1 ->	buffer
	MOV	#32.,R2			; R2 =	counter
3000$:	MOVB	(R0)+,(R1)+		;	copy data into
	SOB	R2,3000$		;	 into buffer
	.POP	<R5,R2,R1,R0>		;	Restore
	RETURN				;
;
7000$:	ABORT	<ENTGET:entry fetch failure>,RTN=ENTERR
;

.SBTTL	Routine - "ENTPNT"	...	point R0 to last answer to state R1
;
; This routine is called to return with R0 pointing to the last answer
; entered for state R0; the routine sets the C flag if it fails.
;
; work our way back till find entry corresponding to state R1
;
ENTPNT:	.PUSH	<R2,R5>			;	save registers
	MOV	#FDBOUT,R5		; R5 ->	FDB
	MOV	VARENT,R2		; R2 =	last entry written
	BEQ	3700$			;	abort if none written
1000$:	MOV	R2,R0			; R0 =	entry to read
	ASH	#-4,R0			; R0 =	block number offset
	ADD	#2.,R0			;	allow for 2 block header
	CMP	R0,FDB.BL(R5)		;	block in memory?
	BEQ	2000$			;	 yes -> skip
	READ	BLOCK=R0,ERROR=7000$	;	 no -->	read block
2000$:	MOV	R2,R0			; R0 =	entry number
	BIC	#^C17,R0		; R0 =	entry number in block
	ASH	#5,R0			; R0 =	offset into block
	ADD	FDB.BF(R5),R0		; R0 ->	data
	CMP	(R0),R1			;	right entry?
	BEQ	3000$			;	 yes -> skip
	SOB	R2,1000$		;	 no -->	try again
	BR	3700$			;	abort
;
; if found exit with R0 pointing to answer an C flag clear
;
3000$:	ADD	#...ANS-...STS,R0	; R0 ->	answer
	TST	(PC)+			;	Indicate suceeded
3700$:	SEC				;	Indicate failed
	.POP	<R5,R2>			;	Restore
	RETURN				;
;
;
; file I/O error trap
;
7000$:	BIS	#F.NERR,FDB.FL(R5)	;	re-disable error messages
	BR	3700$			;	abort
;

.SBTTL	Routine - "ENTERR"	...	output file error trap routine
;
; Detected an error while doing I/O to output file; at entry R1 holds
; address of .ASCIZ message indicating source of error. Display error
; statistics and abort after closing out output file.
;
ENTERR:	OUTSTR	<>,<<15><12>>		;	new line
	OUTSTR	<QUERRY-fatal->		;	output header
	.PRINT	R1			;	output cause of error
	OUTSTR	< entry number >	;	identify variable
	CNAF	FFFFD,NUMBER=ENTNUM,STRING=#$$INIT
	CLRB	(R1)
	.PRINT	#$$INIT			;	display entry number
	STATUS				;	show file status
	CALL	ENTEND			;	close output stream
	.EXIT				;	abort
;

.SBTTL	Routine - "ENTEND"	...	close out output file
;
; This routine outputs the entry file 2 block header and closes out the output
; file.
;
ENTEND:	.DATE				;	get date
	MOV	R0,VARDAT		;	save it
	.GTIM	#EAB,#VARTIM		;	setup time
	MOV	$$$JNM,VARJOB		;	setup job number
;
	WRITE	#FDBOUT,BUFFER=#VARENT,SIZE=#1000,BLOCK=#0
	ABORT	<ENTEND:cannot write header blocks>,CS
	CLOSE
	RETURN
;

.SBTTL	Routine - "INPLIN"	...	input line @R0
;
; When called this routine will return a line of input in .ASCIZ format
; in the buffer @R0; If core-common holds commands then input is obtained
; from there; if no core-command commands are available then input is
; obtained from the terminal.
;
;
INPLIN:	BR	1000$			;	patched later 		******
100$:	.GTLIN	R0			;	input from keyboard
	RETURN				;	done
;
1000$:	CALL	CON$LI			;	attempt to input from CC
	BCC	1700$			;	ok -> done
	MOV	#NOP,INPLIN		;	disable core common	******
	BR	100$			;	get input from TTY
1700$:	.PRINT				;	echo input
	RETURN				;	done
;

.SBTTL	Routine - "CON$LI"	...	input line from core-common
;
; When called this routine attempts to input a line from 'core-common'.
; It returns with the 'C' flag set iff no more core-common data is
; available!
;
; Check next core-common command byte; if MSB set then is a special.
;
CON$LI::TSTB	@550		;	special?
	BMI	3000$		;	 yes -> skip
;
; Return CCM .asciz string. Note that exit via CON.LO to echo input.
;
	.PUSH	<R0,R1>		;	save
	MOV	@#550,R1	; R1 ->	next character to fetch
2100$:	MOVB	(R1)+,(R0)+	;	copy command
	BNE	2100$		;	loop
	MOV	R1,@#550	;	save pointer
	.POP	<R1,R0>		;	restore
	CLC			;	clear EOD flag
	RETURN			;	done
;
;
; Must process a special character in core common string. Special codes are
;
;			301	->	no more core common commands
;			302	->	no more CCC for this program
;			303	->	no more CCC, chain data following
;
3000$:	.PUSH	R1			;	save
	MOVB	@550,R1			; R1 =	special character
	BIC	#^C77,R1		; R1 =	index number to base 1
	ASL	R1			; R1 =	offset
	CMP	R1,#<3070$-3060$>	;	valid index?
	BLO	3050$			;	 yes -> process
	CLR	R1			;	 no --> force valid
3050$:	JMP	@3060$(R1)		;	pass over control
3060$:	.WORD	3100$,3100$,3101$,3102$	;	[EOC] [EOC] [TTY] [CHN]
3070$:
;
3100$:	CLR	@#546			;	indicate no more commands
3101$:	INC	@#550			;	 skip character
3102$:	.POP	R1			;	restore R1
	SEC				;	indicate EOD
	RETURN				;	done
;

.SBTTL	Special Entry - "CON$EX"	...	Exit program
;
;	The user program wishs to exit. If 550 points to a byte
;	holding data 303!8, then wish to perform a chain to program
;	whose RAD50 name is in following bytes.
;
CON$EX::				; Entry point to exit
	MOV	@#550,R0		; R0 -> CCM
	MOVB	(R0)+,R1		; R1 =	special character
	CMPB	R1,#303			;	chain time?
	BEQ	3200$			;	 yes -> skip
3100$:	.EXIT				;	 no  -> exit
;
3200$:	MOV	#500,R1			; R1 ->	Chain area
	MOV	#10,R2			; R2 =	number bytes in name
3210$:	MOVB	(R0)+,(R1)+		;	copy
	SOB	R2,3210$		;	loop
	MOV	R0,@#550		;	save pointer
	.CHAIN				;	chain time
;
;

.SBTTL	Primitive - "VARPNT"	...	point R0 to variable R0
;
; This routine is called to point register R0 to the 22 byte buffer for the
; variable whose ID is in R0. At exit the C flag is set iff the variable
; could not be found.
;
VARPNT:	.PUSH	<R1,R2>			;	save
	TST	R0			;	looking for spare memory slot?
	BEQ	1000$			;	 yes -> go find
	CMP	R0,#8000.		;	memory variable?
	BHIS	1000$			;	 yes -> skip
	MOV	#VARBUE,R1		; R1 ->	last answer cached
	CMP	R0,(R1)			;	one we want?
	BEQ	2000$			;	 yes -> very easy
;
; return last answer to state R0 as vairable in buffer VARBUE
;
	MOV	R0,R1			; R1 =	state number required
	CALL	ENTPNT			; R0 ->	answer to state R1
	BCS	2100$			;	skip if failed
	MOV	R1,VARBUE		;	setup variable number
	MOV	#VARBUE+2,R1		; R1 =	Store pointer
	MOV	#20.,R2			; R2 =	counter
600$:	MOVB	(R0)+,(R1)+		;	copy
	SOB	R2,600$			;	variable
	MOV	#VARBUE,R1		; R1 ->	variable
	BR	2000$			;	done
;
; seacrh through memory to see if variable exists
;		
1000$:	MOV	#<VARBUE-VARBUF>/22.,R2	; R2 =	counter
	MOV	#VARBUF,R1		; R1 ->	first variable
1100$:	CMP	R0,(R1)			;	found variable?
	BEQ	2000$			;	 yes ->	skip
	ADD	#22.,R1			;	 no -->	bump pointer
	SOB	R2,1100$		;		try next one
	BR	2100$			;	abort if all done
;
2000$:	MOV	R1,R0			; R0 ->	variable
	TST	(PC)+			;	clear error flag
2100$:	SEC				;	indicate failed
	.POP	<R2,R1>			;	restore registers
	RETURN				;	done
;

.SBTTL	Primitive "DEBUG"	...	conditional database debug routine
;
; The DEBUG routine is called by CMDDSP prior to processing a new state
; record; the function of the routine is to display important internal data
; that is of use in debugging the database.
;
;
; output record and entry number
;
DEBUG:	.PUSH	ALL			;	save
	MOV	#7000$,R0		;	output
	MOV	#7100$,R1		;	 header
	CALL	ENCODE			;	  data
;
; output contents of call stack
;
	MOV	VARSTK,R5		; R5 =	offset to last item on stack
	BEQ	1700$			;	skip if stack empty
	ADD	#VARSTK+4,R5		; R5 ->	next spare word on stack
1100$:	CNAF	FFFFD,STRING=#7210$,NUMBER=-(R5)
	MOVB	#200,(R1)		;	delimit
	.PRINT	#7200$			;	output number
	CMP	R5,#VARSTK+4		;	all done?
	BHI	1100$			;	 no --> loop
1700$:
;
; output variables
;
5000$:	MOV	#VARBUF+<22.*2>,R5	; R5 ->	variable buffer
	CLR	R4			; R4 =	count variables on line
	MOV	#11.,R3			; R3 =	number lines left
5100$:	MOV	(R5)+,R2		; R2 =	variable name
	BEQ	5200$			;	 skip if not defined
	CALL	5700$			;	position cursor
	CNAF	SSSD,STRING=#7200$	;	setup name
	MOVB	#40,(R1)		;	delimit name/data
	PRINT	#7200$,#5.		;	display name
	PRINT	R5,#20.			;	Display contents
5200$:	ADD	#20.,R5			; R5 ->	next variable
	CMP	R5,#VARBUE		;	eob?
	BLO	5100$			;	 no --> loop
	BR	6000$			;	 yes -> done
 5700$:	DEC	R4			;	one more variable on line
	BLE	5710$			;	skip if line full
	OUTSTR	<  >			;	delimit
	RETURN				;	done	
 5710$:	OUTSTR	<>,<<15><12>>		;	new line
	MOV	#3.,R4			; R4 =	number vars/line
	DEC	R3			;	one more line used up
	RETURN				;	done
;

;
; insure rest of variable display area is clear
;
6000$:	OUTSTR	<>,<<33><'[><'0><'K>>	;	erase rest of line
	OUTSTR	,<<15><12>>		;	new line
	SOB	R3,6000$		;	loop till all done
;
; restore context and exit
;
	.PRINT	#7700$			;	restore cursor
	.POP	ALL			;	restore registers
	RETURN				;	done
;
; data structures
;
.nlist	bin
7000$:	ENCODE	SSSD,RECNUM		;	encode
	ENCODE	SSSD,VARENT		;	 arguments
	.WORD	0,0
7100$:	.ASCII	<33><'7><33>|[f|
	.ASCII	|State Number:????    States Traversed:????|<15><12>
	.ASCII	<33>|[2KReturn stack:|<200>
7200$:	.ASCII	| |
 7210$:	.ASCII	|       |
7700$:	.ASCII	<33><'8><200>
.even
.list	bin
;

.SBTTL	Primitive - "ABORT"	...	abort program execution
;
; error trap routine
;
ABORTF:	OUTSTR	<>,<<15><12>>		;	new line
	STATUS				;	show cause of file error
ABORT:	OUTSTR	<>,<<15><12>>		;	new line
	OUTSTR	<QUERRY-fatal->		;	output header
	.PRINT	R1			;	output cause of error
	.EXIT				;	abort
;
;

.SBTTL	VAR??? data structures	...	output file header block
;
; The VAR??? structures are special in that they are written out (and loaded
; in) to blocks 0 and 1 of the output file. This must be done to allow an
; existing output file to be 'editted'.
;
VARENT:	.WORD	0			; number entries in file
VARQST:	.WORD	0			; question number
VARFMT:	.RAD50	|180383|		; program version
VARJOB:	.WORD	0			; number of user's job
VARDAT:	.WORD	0			; date of creation
VARTIM:	.WORD	0,0			; time of creation
VARSTK:	.WORD	0.,32.*2		; call stack pointer, size
	.BLKW	32.			; 	call stack
VARBUF:	.WORD	9000.			;	variable ID (9000<->YES)
	.ASCII	|Yes                 |	;	         contents
	.WORD	9001.			;	variable ID (9001<->NO)
	.ASCII	|No                  |	;	         contents
	.REPT	<32.-2>			;	number variables allowed
	 .WORD	0,0,0,0,0,0,0,0,0,0,0	;	variable
	.ENDR
VARBUE:	 .WORD	0,0,0,0,0,0,0,0,0,0,0	;	used for file variable
	.BLKB	2000-<.-VARENT>		;	padding
;

.SBTTL	Data structures and variables
;
;
;
;		Line/user paramaters setup by $$INIT
;
$$$JNM::.WORD	0		;	job number
$$$JMK::.WORD	0		;	job mask
$$$LIC::.WORD	0		;	lead-in character
EAB:	.BLKW	10		; EAB	general
E.CHK:	.BYTE	0,123
E.INP:	.BYTE	0,115
	.WORD	$$INIT,24.
;
;
RECNUM:	.WORD	0		;	number record in memory
ENTNUM:	.WORD	0		;	number of entry in memory
ENTBUF:				;	loaded/unloaded by ENTGET/ENTPUT
...STS:	.WORD	0		;	state number
...COD:	.WORD	0		;	code associated with record
...QST:	.WORD	0		;	question number
...STK:	.WORD	0,0		;	stack
...ANS:	.BLKB	S.DFLT		;	argument buffer
	.BLKB	32.-<.-ENTBUF>	;	padding
;
HLPNUM:	.WORD	0		;	number of help file in memory
FDB	FDBREC,CHANNEL=1,SIZE=400,BUFFER=BUFINP
FDB	FDBOUT,CHANNEL=2,SIZE=400,BUFFER=BUFOUT
FDB	FDBHLP,CHANNEL=3,SIZE=400,BUFFER=BUFHLP
BUFOUT:	.BLKW	400
BUFINP:	.BLKW	400
BUFHLP:	.BLKW	400
;
;

.SBTTL	Routine - '$$INIT'	...	once only initialization code
;
; identify self
;
$$INIT::OUTSTR	<QUERY-RDM200783>,<<15><12>>
;
; setup $$$JNM, $$$JMK and $$$LIC variables
;
	.GVAL	#EAB,#-2		; R0 =	job number
	MOV	R0,$$$JNM		;	save for later
	MOV	#1,R1			;	setup
	ASH	R0,R1			;	 job
	MOV	R1,$$$JMK		;	  mask
	.GVAL	#EAB,#-4		; R0 =	leadin character
	MOV	R0,$$$LIC		;	save LEAD-IN character
;
; define activation characters
;
	.IRP	X,<136,'|,'!>		;	make ^,|,! activation chars
	 .TTYOUT	$$$LIC		;	 output leading character
	 .TTYOUT	#'D		;		function specifier
	 .TTYOUT	#'X		;		new activation chad
	.ENDR
;
; setup TTY I/O characteristics
;
	.IRPC	X,<I>			;	refer to TSX-plus manual
	 .TTYOUT	$$$LIC		;	 output leadin character
	 .TTYOUT	#''X		;	 select characteristic
	.ENDR
	BIS	#40000,@#44		;	enable LC input
;
; see if have any core-common commands
;
	BIT	#400,@#44		;	chained to?
	BEQ	2000$			;	 no --> skip
	CMP	@#546,#^RCMD		;	any Core-common commands?
	BEQ	3000$			;	 yes -> skip
2000$:	MOV	#NOP,@#INPLIN		;	 no --> disable CCCs
;
;
; open state transition database
;
3000$:	PURGE	#FDBREC			; R5 ->	FDB
	BIS	#F.NERR,FDB.FL(R5)	;	suppress error messages
	OUTSTR	<      STATE database file:    >
	MOV	#$$INIT,R0		; R0 ->	buffer
	CALL	INPLIN			;	get name
	NAME	STRING=#$$INIT,EXTENS=#^RDAT;	decode name
3010$:	ABORT	<invalid STATE database>,CS,RTN=ABORTF
	LOOKUP	ERROR=3010$		;	lookup file
	MOV	#-1,FDB.BL(R5)		;	force read on first access
	OUTSTR	<      Starting  State number: >
	MOV	#$$INIT,R0		; R0 ->	buffer
	CALL	INPLIN			;	get answer
	MOV	#$$INIT,R1		; R1 ->	buffer
	CALL	ASCNUM			; R0 =	initial state
	MOV	R0,R4			; R4 =	initial state
	BNE	3100$			;	skip if non-zero
	INC	R4			;	force non-zero
3100$:	CALL	GETRR4			;	 first state
	MOV	R4,7700$		;	save for latter
;
; open output file
;
4000$:	OUTSTR	<        Name for answer file: >
	PURGE	#FDBOUT			; R5 ->	FDB
	BIS	F.NERR,FDB.FL(R5)	;	suppress error messages
	CALL	$$SWTH			; R0 ->	answer
	NAME	STRING=R0,EXTENS=#^RSTS,ERROR=4000$;	decode name
	LOOKUP	ERROR=4100$		;	already exists?
	OUTSTR	<Warning-overwriting existing answers!>,<<15><12>>
4100$:	PURGE				;	create
	BIS	#F.NERR,FDB.FL(R5)	;	 output
	ENTER	SIZE=#32.		;	  file
	ABORT	<Cannot create output file>,CS,RTN=ABORTF
;
; pass control to command dispatcher
;
	OUTSTR	<>,<<15><12><12>>	;	blank line
	MOV	(PC)+,R4		; R4 ->	state record
7700$:	.WORD	0			;	holds state record address
	JMP	CMDDSP			;	process time
;

;
; Get name for output file. If name starts with a ~
; then enable debug code, else disable it. At exit R0 points to name of
; file.
;
$$SWTH:	MOV	#$$INIT,R0		; R0 ->	buffer
	CALL	INPLIN			;	get answer
	CMPB	(R0),#'~		;	debug enabled?
	BEQ	1000$			;	 yes -> skip
	MOV	#RETURN,DEBUG		;	 no --> disable
	RETURN				;	done
;
1000$:	.PRINT	#7000$			;	enable split screen
	MOV	#$$INIT+1,R0		; R0 ->	name
	RETURN				;	done
;
.nlist	bin
7000$:	.ASCII	<33>|[14;24r|
	.ASCII	<33>|[2J|
	.ASCIZ	<33>|[24f|
.even
.list	bin
;

; emt argument blocks
;
;E.BSC:	.WORD	133*400,40,CHAIN	; EMT 	trap to CHAIN on BSC
E.MEM:	.WORD	141*400,$$INIT		; EMT 	reduce memory
;
.END	$$INIT