.TITLE	CONFOR ... CONIO FORTRAN Interface
.IDENT	/140683/
.ENABL	LC
;
;
;
;
;	Written by	Ray Di Marco
;			7-Jul-82.
;
;
;	Version		070782/02.
;
;
;---------------------------------------------------------------------------
;
; This file contains the source for the CONFOR routine; this routine provides
; the FORTRAN program with equivalent facilities to those provided by CONIO
; to the macro program. The main advantage in using this module (and CONIO)
; over perform I/O dirrectly is that Core Common Commands are supported; this
; allows the user program to be included in CUSP chains. The calling sequence
; is
;
;			CALL CONFOR (OPCODE,ARG1...ARGN)
;
; where OPCODE is an integer that determines the operation that is to
; be performed and ARG? are optional arguments. The supported calls are
;
;	call		function
; CALL CONFOR (0)	NOP	(used to be equivalent to CALL CON.ST)		
; CALL CONFOR (1)	EXIT	terminates program execution (CON.EX)
; CALL CONFOR (2)	ILLEGAL	(used to be equivalent to CALL CON.CI)
; CALL CONFOR (3,CHAR)	TTYOUT	outputs character CHAR via .TTYOUT		
; CALL CONFOR (4,BUF)	GTLIN	returns .asciz line from CC or TTY (CON.LI)	
; CALL CONFOR (5,BUF)	PRINT	outputs .ASCIZ string in BUF to TTY		
; CALL CONFOR (6)	ILLEGAL	(used to be equivalent to CALL CON.ST)
; CALL CONFOR (7,X,Y)	ILLEGAL	(used to be equivalent to CALL CON.ST)
; CALL CONFOR (8,X,Y)	ILLEGAL	(used to be equivalent to CALL CON.ST)
; CALL CONFOR (9,C,N)	TTYOUT	output character C N times
; CALL CONFOR (10,C1..CN)	output series of bytes C1 to CN
;

.SBTTL	Modifications
;
; 14-Jun-83	make CONFOR independant of CONIO module. This means that
;		certain functions (ie those that need CONIO) are now nolonger
;		supported. Attempting to use them will result in an error
;		message. A few extra functions have been added.
;

.SBTTL	Declarations
;
;
.MCALL	.PRINT,.TTYOUT,.TTYIN,.GTLIN		; RT-11 macros
.MCALL	.CHAIN,.EXIT				; RT-11 macros
.MCALL	.PUSH,.POP				; DBSLIB macros
;
.GLOBL	CONFOR					; entry point
;
;
	.ASECT
;	======
;
 . =	42
	.WORD	3000				; allocate extra
 . =	3000					;  stack space
;
;
	.PSECT	CODE				; open code section
;	======	====
;
.MACRO	ABORT	MES,CND,?LA,?LB
	.IF	NB,CND
	 .IFT
		B'CND	LA
			BR	LB
		LA':	JSR	R1,ABORT
			.ASCII	/MES/<200>
			.EVEN
		LB':
	 .IFF
			JSR	R1,ABORT
			.ASCII	/MES/<200>
			.EVEN
	.ENDC
.ENDM	ABORT
;

.SBTTL	Entry - "CONFOR"	...	DBSMNG SFL File FORTRAN inteface
;
; This code ensures that the FORTRAN caller has specified a valid OPCODE,
; and that the right number of arguments have been passed. A program ABORT
; is performed if an error is detected.
;
CONFOR:	CMPB	(R5),#1		; 	have at least 1 args?
	ABORT	<no arguments>,LO;	 no --> abort
	MOV	@2(R5),R4	; R4 =	opcode
	ASH	#2,R4		; R4 =	offset equivalent to opcode
	CMP	R4,#710$-700$	;	valid offset?
	ABORT	<illegal function>,HI;	 no --> abort
	TST	700$(R4)	;	number argument specified?
	BEQ	500$		;	 no --> skip
	CMPB	(R5),700$(R4)	;	right number of arguments?
	ABORT	<incorrect number of arguments>NE
500$:	CALL	@700$+2(R4)	;	invoke
600$:	RETURN			;	done
677$:	ABORT	<function no longer supported>
;

;
; dispatch table
;
700$:	.WORD	1,600$			; 0 -> NOP (was CON.ST)
	.WORD	1,CON.EX		; 1 -> exit program
	.WORD	1,677$			; 2 -> illegal (was CON.CI)
	.WORD	2,CON.CO		; 3 -> output character
	.WORD	2,CON.LI		; 4 -> input line
	.WORD	2,CON.LO		; 5 -> output line
	.WORD	1,677$			; 6 -> illegal (was CON.ES)
	.WORD	3,677$			; 7 -> illegal (was CON.EL)
	.WORD	3,677$			; 8 -> illegal (was CON.XY)
	.WORD	3,CHROUR		; 9 -> output byte N times
	.WORD	0,CHROUS		; 10 -> output series of bytes
710$:					; End Of Table
;
; output 1 character			CALL CONFOR (3,CHAR)
;
CON.CO:	.TTYOUT	@4(R5)			;	output
	RETURN				;	done
;
; print .asciz string			CALL CONFOR (5,STRING)
;
CON.LO:	.PRINT	4(R5)			;	output
	RETURN				;	done
;
; output 1 character N times		CALL CONFOR (9,CHAR,N)
;
CHROUR:	MOVB	@4(R5),R0		; R0 =	character to output
	MOVB	@6(R5),R2		; R2 =	repeat count
100$:	.TTYOUT				;	output
	SOB	R2,100$			;	 character
	RETURN				;	done
;
; output series of bytes		CALL CONFOR (10,C1,...CN)
;
CHROUS:	MOV	R5,R4			; R4 ->	arg list
	MOV	(R4)+,R2		; R2 =	number arguments
	BIC	#^C377,R2		;	discard HOB
	TST	(R4)+			;	skip opcode
	DEC	R2			; R2 =	number arguments left
	ABORT	<missing arguments>,EQ	;	must have sone
1000$:	.TTYOUT	@(R4)			;	output
	TST	(R4)+			;	 series
	SOB	R2,1000$		;	  of bytes
	RETURN				;	done
;

.SBTTL	Routine - "CON.LI"	...	input line
;
; See if a line of input is available from core common
;
CON.LI:	CALL	TSTCCM		;	core common setup?
	BCS	7000$		;	 no -->	input from terminal
	MOV	@#550,R1	; R1 ->	next CC byte
	MOVB	(R1),R0		; R0 =	next CC byte
	BMI	3000$		;	 skip if it is a special code
;
; Return line of input from core common
;
	MOV	4(R5),R0	; R0 ->	buffer
2100$:	MOVB	(R1)+,(R0)+	;	return
	BNE	2100$		;	 CC data
	MOV	R1,@#550	;	save pointer
	.PRINT	4(R5)		;	display CC input
	RETURN			;	done
;
; Next byte in CC is a special. Valid special codes are
;
;	301	->	no more core common commands
;	302	->	accept this line from terminal
;	303	->	no more CCC, chain data following
;
3000$:	BIC	#^C77,R0		; R0 =	function to perform
	ASL	R0			; R0 =	offset
	CMP	R0,#<3100$-3060$>	;	valid index?
	BLO	3050$			;	 yes -> process
	CLR	R0			;	 no --> force valid
3050$:	JMP	@3060$(R0)		;	pass over control
3060$:	.WORD	3100$,3100$,3101$,3102$	;	[EOC] [EOC] [TTY] [CHN]
3100$:	CLR	@#546			;	indicate no more commands
3101$:	INC	@#550			;	skip character
3102$:					;	nop
;
; Input line from terminal
;
7000$:	.GTLIN	4(R5)			;	input from TTY
	RETURN				;	done
;

.SBTTL	Routine - "CON.EX"	...	Exit program
;
; See if name of program to chain to has been passed in core common
;
CON.EX:	CALL	TSTCCM			;	core common set up?
	BCS	7000$			;	 no --> exit
	MOV	@#550,R0		; R0 -> CCM
	MOVB	(R0)+,R1		; R1 =	next CC byte
	CMPB	R1,#303			;	chain operator?
	BNE	7000$			;	 no --> exit
;
; Chain to specified program
;
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
7000$:	.EXIT				;	exit to monitor
;
;

.SBTTL	Primitive - "TSTCCM"	...	see if core common setup
;
;
; C flag clear on exit iff core common is properly set up.
;
TSTCCM:	BIT	#400,@#44		;	chained to?
	BEQ	2000$			;	 no --> skip
	CMP	@#546,#^RCMD		;	core-common set up?
	BNE	2000$			;	 no --> skip
	TST	(PC)+			;	clear C flag
2000$:	SEC				;	set fail flag
	RETURN				;	done
;
;

.SBTTL	Primitive - "ERROR"	...	abort because of error @R1
;
;
ABORT:	.PRINT	#ERRM00		;	identify module
	.PRINT	R1		;	show cause of error
	.PRINT	#ERRM01		;	terminate message
	TRAP	0		;	abort
;
.nlist	bin
ERRM00:	.ASCII	<12><15>/CONFOR-fatal-/<200>
ERRM01:	.ASCII	/!/<200>
.even
.list	bin
;
.END
