.MCALL	.MODULE
.MODULE	GISTAR,VERSION=04,COMMENT=<GISTAR/SYSLIB>,IDENT=NO,LIB=YES

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  with  the
; inclusion of the above copyright notice.  This software,  or
; any other copies thereof, may not be provided  or  otherwise
; made available to any other person except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
;++
;
;	Edit	Who	Date		Description of modification
;	----	---	----		---------------------------
;	001	WLD	16-OCT-90	Standardize PSECT names.
;--
.IIF	NDF	SYSL$C	SYSL$C=0
.IF EQ	SYSL$C
.SBTTL	GISTAR - FORTRAN callable system subroutine
;+
;	GICLOS
;
;	Simulate a GIDIS END_PICTURE command, then disconnects
;	the channel connection.
;
;Call	GICLOS	(STATUS, LUN)
;
;
;	GIOPEN
;
;	Connects a channel
;
;Call	GIOPEN	(STATUS, LUN [, MESSAGE] [, MSGLEN] [, DEVTYPE] [, DRIVER])
;
;
;	GIREAD
;
;	Waits for a report from GIDIS, then returns the report in the BUFFER.
;
;Call	GIREAD	(STATUS, LUN, BUFFER, BUFLEN)
;
;
;	GIWRIT
;
;	Sends the contents of BUFFER to GIDIS as commands.
;
;Call	GIWRIT	(STATUS, LUN, MESSAGE, MSGLEN)
;
;	For initialization purposes, MSGLEN can = -1
;
; ERRORS ARE POSSIBLE
;	~description of error returns
;
;JFW 12-Feb-85
;
.IFF ;EQ SYSL$C
.SBTTL	~module - "C" callable system subroutine
|FF or not depending on reasonable paging of file
;
;+
;
; Index		~1 liner for KWIK index
;
; Usage
;
;	~C style definition of return value and
;	~parameters
;
; Description
;
;	~description of function
;
; Bugs
;
;	~actual bugs or unexpected "features"
;-
|FF or not depending on reasonable paging of file
.IFTF ;EQ SYSL$C

	.PSECT	SYS$I,I

.GLOBL	$SYSLB
.GLOBL	$NXADR	$NXVAL	$ERRM0	SERR$1
.IFTF ;EQ SYSL$C

;|if the "C" version of the routine uses more work registers (than R0,R1):
.IFF ;SYSL$C
.GLOBL	CSV$	CRET$	C$PMTR
.IFTF ;EQ SYSL$C

.MCALL	.CLOSE	.LOOKUP	.SPFUN
.MCALL	.ASSUME .BR	.CKXX

.CKXX	<R0,R1,R2,R5,SP,SPA,SA,SB,SC,SD,SZ>

.IFT ;EQ SYSL$C
F.ARGS	=:	-2		;offset from parm base to parm count
F.PMTR	=	2		;offset from R5 to parm base
NOARG	=:	-1		;value of omitted addr
.IFF ;EQ SYSL$C
|if the "C" version of the routine uses only R0,R1:
C.PMTR	=	2		;offset from SP to parm base
.IFTF ;EQ SYSL$C

.DSTATUS=:	342			;EMT code for .DSTATUS
.LOOKUP	=:	1*400			;Request code for .LOOKUP
.SPFUN	=:	32*400			;Request code for .SPFUN
	SPFLAG	=:	377		;Flag for SPFUN request
	GID.RD	=:	370		;PI GIDIS READ SPFUN function code
	GID.WR	=:	371		;PI GIDIS WRITE SPFUN function code

PSTAT	=:	0
PLUN	=:	2
PMSG	=:	4
PBUF	=:	PMSG
PMLEN	=:	6
PBLEN	=:	PMLEN
PDEV	=:	8.
PDRVR	=:	10.

S.RET	=:	1000
S.SRET	=:	1000
STAT	=:	2000

;					;DSTATUS answer area
D.STAT	=:	0			;Hanlder device code and status
D.HSIZ	=:	2			;Handler size
D.LADR	=:	4			;Handler load addr
D.VSIZ	=:	6			;Volume size
D.ALEN	=:	8.			;Length of answer area

E.DIRE	=:	-1			;Directive error
	E$NODV	=:	-2		;No Handler

E.IO	=:	-2			;I/O error
E.RMS	=:	-3			;RMS error
E.INTN	=:	-4			;Internal error
E.INTF	=:	-5			;Interface error
	E$CHAN	=:	-1		;Channel not open
	E$DVTY	=:	-2		;DEVTYPE out of range
		MAXOPN	=:	128.	;Longest valid GIOPEN message
;>>>what is the RT-11 max?
		MAGIC1	=:	-1	;Magic (init) message count
		MAXWRI	=:	4095.	;Longest valid GIWRIT message
	E$MLEN	=:	-3		;MSGLEN out of range
	E$NUSE	=:	-4		;Channel in use

E.DRIV	=:	-6			;Driver (handler) error
E.RT11	=:	-7			;RT-11 specific error
	E$ILAR	=:	-1		;Required argument missing
	E$LOAD	=:	-2		;Handler not loaded
					;LOOKUP 0 Chan in use (see -5,-4)
	E$FNF	=:	-3		;LOOKUP 1 File not found
	E$DUSE	=:	-4		;LOOKUP 2 File open on NFS
	E$EOF	=:	-5		;SPFUN 0 attempt R/W past EOF
	E$HERR	=:	-6		;SPFUN 1 Hard error
					;SPFUN 2 Chan in use (see -5, -4)
	E$ARGV	=:	-7		;LOOKUP 5 Argument invalid
.IFT ;SYSL$C
.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET
GIOPEN::
							CK.SP S.RET
	MOV	SP,R3			;Save stack pointer
							CK.SP S.RET
							CK.R5 F.ARGS
	CALL	FIRST2			;Get first 2 arguments
							CK.R1=STAT+2
							CK.R5 ,+2+2+2
	BCS	DO1LAR			;Required argument missing
;					;LUN range check NOT done
	MOV	#ADDR0,R0		;Default to the addr of a 0
							CK.R5 PMSG,+2
	CALL	$NXADR			;Get MESSAGE addr
							CK.SP ,-2,S.MSG
	MOV	R0,-(SP)		;Save it
	BCS	10$			;Default used
	CALL	$NXVAL			;Get MSGLEN value
							CK.R5 PMLEN,+2
DO1LAR:	BCS	DOILAR			;MSGLEN required if MESSAGE specified
	MOV	R0,-(SP)		;Save it
							CK.SP ,-2,S.MLEN
	CMP	#MAXOPN,R0		;Too big?
	BLOS	DOILML			;Yes, error (or negative)
	BR	20$			;Skip default setup
10$:
							CK.SPA=S.MSG
							CK.SPA ,-2,SA.MLEN
	MOV	#ADDR0L,-(SP)		;Default MSGLEN
20$:
							CK.SP CK.SPA
	MOV	#PI.DEV,R0		;Default to Video
	CALL	$NXVAL			;Get DEVTYPE
							CK.R5 PDEV,+2
	CMP	#MAXDEV,R0		;Is it is range?
	BLOS	DOILDV			;No, too big, or negative
	ASL	R0			;Make into a 2 word index
	ASL	R0			;...
	ADD	#DEVNAM,R0		;Point to device name
							CK.SP ,-2,S.NAME
	MOV	R0,-(SP)		;Save in case a 0 is given for DRIVER
	CALL	$NXADR			;Get possible overriding DRIVER
							CK.R5 PDRVR,+2
							CK.SP S.NAME,+2
	MOV	(SP)+,R5		;Get name again
	TST	@R0			;0 given?
	BEQ	30$			;Yes
	MOV	R0,R5			;Else use overriding value
30$:
							CK.SP S.MLEN,+2
	MOV	(SP)+,R4		;Get MSGLEN from stack
							CK.SP S.MSG
;	R1=@STATUS+2; R2=LUN; R3=old_SP; R4=MSGLEN; R5=@DRIVER; @SP=@MESSAGE
	SUB	#D.ALEN,SP		;Reserve area for answer
							CK.SP ,-D.ALEN
	MOV	SP,R0			;Save pointer to answer area
							CK.R0=CK.SP
							S.ANS=CK.R0
	MOV	R0,-(SP)		;Put addr on stack
							CK.SP ,-2
	MOV	R5,R0			;Point to Driver name
							CK.SP ,+2
	EMT	.DSTATUS		;Do a DSTATUS
	BCS	DONODV			;No device
							CK.SP S.ANS
	TST	D.LADR(SP)		;Loaded?
	BEQ	DOLOAD			;No
	ADD	#D.ALEN,SP		;Realign stack
							CK.SP ,+D.ALEN
							CK.SP S.MSG
							CK.SP ,-2,S.SEQN
	CLR	-(SP)			;SEQNUM=0
							CK.SP ,-2,S.DBLK
	MOV	R5,-(SP)		;DBLK
							CK.SP ,-2,S.LOOK
	MOV	#.LOOKUP,-(SP)		;Request code
							CK.SP S.LOOK
	MOVB	R2,@SP			;and CHANNEL number
							CK.R0=CK.SP
						.ASSUME	CK.R0 EQ S.LOOK
						.ASSUME CK.R0+2 EQ S.DBLK
						.ASSUME CK.R0+4 EQ S.SEQN
	.LOOKUP	SP,CODE=NOSET		;Open the channel
	BCS	DOILLK			;Lookup failed
	ADD	#3*2,SP			;Realign stack
							CK.SP ,<+<3*2>>
							CK.SP S.MSG
;>>>	here some processing of the MESSAGE may be appropriate
	BR	OK			;Normal exit

.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET
GIREAD::
	MOV	SP,R3			;Save stack pointer
							CK.SP ,-2,S.CRTN
	CLR	-(SP)			;CRTN
							CK.SP ,-2,S.FUNC
	MOV	#GID.RD*400+SPFLAG,-(SP) ;Indicate a read request
	BR	GIIO			;Join common IO code


.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SPA=S.RET
GIWRIT::
	MOV	SP,R3			;Save stack pointer
							CK.SPA ,-2,S.CRTN
	CLR	-(SP)			;CRTN
							CK.SPA ,-2,S.FUNC
	MOV	#GID.WR*400+SPFLAG,-(SP) ;Indicate a write request

							CK.SP CK.SPA
GIIO:
							CK.R5 F.ARGS
	CALL	FIRST2			;Get the first 2 the easy way
							CK.R1=STAT+2
							CK.R5 ,+2+2+2
	BCS	DOILAR			;Missing
	CALL	$NXADR			;Get addr of MESSAGE/BUFFER
							CK.R5 PMSG,+2
							.ASSUME	PMSG EQ PBUF
	BCS	DOILAR			;Missing
							CK.SP ,-2,S.WCNT
	CLR	-(SP)			;reserve space for WCNT
							CK.SP ,-2,S.BUF
	MOV	R0,-(SP)		;MESSAGE/BUFFER on stack
	CALL	$NXVAL			;Get LENGTH
							CK.R5 PMLEN,+2
							.ASSUME PMLEN EQ PBLEN
	BCS	DOILAR			;Missing
							CK.SP S.BUF
	MOV	R0,S.WCNT-CK.SP(SP)	;LENGTH on stack
	CMP	#GID.WR*400+SPFLAG,S.FUNC-CK.SP(SP) ;GIWRIT?
	BNE	10$			;No
	CMP	#MAGIC1,R0		;Is it the magic -1?
	BEQ	10$			;Yes
	CMP	#MAXWRI,R0		;Too long?
	BLOS	DOWRML			;Invalid, too big or negative
10$:
							CK.SP ,-2,S.BLK
	CLR	-(SP)			;Zero block number
							CK.SP ,-2,S.SREQ
	MOV	#.SPFUN,-(SP)		;Put in request code
							CK.SP S.SREQ
	MOVB	R2,@SP			;And channel number
						.ASSUME CK.SP EQ S.SREQ
						.ASSUME CK.SP+2 EQ S.BLK
						.ASSUME CK.SP+4 EQ S.BUF
						.ASSUME CK.SP+6 EQ S.WCNT
						.ASSUME CK.SP+8. EQ S.FUNC
						.ASSUME CK.SP+10. EQ S.CRTN
	.SPFUN	SP,CRTN=,CODE=NOSET	;Issue request
	BCS	DOSPER			;Process any error
	BR	OK			;No error


.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET
GICLOS::
	MOV	SP,R3			;Save stack pointer
							CK.R5 F.ARGS
	CALL	FIRST2			;Get the first 2 arguments
							CK.R1=STAT+2
							CK.R5 ,+2+2+2
	BCS	DOILAR			;Required argument missing
	MOV	#ENDPIX,R0		;Do an END_PICTURE
	CALL	SPFUN			;Send it
	BCS	DOSPER			;Process any error
	.CLOSE	R2			;Now close the channel
	BCS	DOCLER			;Process any error
	BR	OK			;Success
							CK.SA=0
							CK.SZ=0
							CK.R1=STAT+2
DONODV:					;-1,-2
							CK.R1 STAT+2
	MOV	#E$NODV,@R1		;subcode -2
							CK.R1 STAT,-2
							CK.SZ E.DIRE,-1
	DEC	-(R1)			;Return Directive error
	BR	RETURN

							CK.SD=0
							CK.R1=STAT+2
DO54:					;-5,-4
							CK.SD ,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode

							CK.SC=0
							CK.R1=STAT+2
DOILML:					;-5,-3
DOWRML:					;-5,-3
							CK.SC ,-1
							CK.SD ,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode

							CK.SB=0
							CK.R1=STAT+2
DOILDV:					;-5,-2
							CK.SB ,-1
							CK.SC ,-1
							CK.SD ,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode

							CK.SA=0
							CK.R1=STAT+2
DO51:
DOCLER:					;-5,-1
							CK.SA E$CHAN,-1
							CK.SB E$DVTY,-1
							CK.SC E$MLEN,-1
							CK.SD E$NUSE,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode
							CK.R1 STAT,-2
	MOV	#E.INTF,-(R1)		;Return Interface error
	BR	RETURN
							CK.SB=0
							CK.R1=STAT+2
DOLOAD:					;-7,-2
							CK.SB ,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode

							CK.SA=0
							CK.R1=STAT+2
DOILAR:					;-7,-1
							CK.SB E$LOAD,-1
							CK.SA E$ILAR,-1
							CK.R1 STAT+2
	DEC	@R1			;Reduce Subcode
	BR	MINUS7

DOILLK:					;0 == -5,-4
	CALL	$ERRM0
	CMP	#-0-1,R0		;Was it 0 (now -1?)
	BEQ	DO54			;Yes, return as -5,-4
	CMP	#SERR$1,R0
	BLE	DOSERR			;SERR code found
	DEC	R0			;1 == -2 then dec to -3
					;2 == -3 then dec to -4
					;1 == -7,-3
					;2 == -7,-4
	BR	SUB7			;

DOSPER:
	CALL	$ERRM0
	CMP	#SERR$1,R0			;
	BLE	DOSERR			;SERR code found
					;0 == -7,-5
					;1 == -7,-6
					;2 == -5,-1
	CMP	#-2-1,R0		;was it 2 (now -3)?
	BEQ	DO51			;Yes, return as -5,-1
						.ASSUME -0-1-4 EQ E$EOF
						.ASSUME -1-1-4 EQ E$HERR
	SUB	#4,R0			;0 == -1 then -4 to -5
					;1 == -2 then -4 to -6
DOSERR:
SUB7:
	MOV	R0,@R1			;Put in subcode
MINUS7:
	MOV	#E.RT11,-(R1)		;Return RT-11 error
	.BR	RETURN
RETURN:
OK:					;+0,+0
	MOV	R3,SP			;Restore stack
	RETURN
.ENABLE	LSB
							CK.R5=F.ARGS
FIRST2:
							CK.R5 F.ARGS,+2
	MOV	(R5)+,R4		;Get count from parm list
							CK.R5 PSTAT,+2
	CALL	$NXADR			;Get addr of STATUS
	BCS	10$			;Missing
	MOV	R0,R1			;Save the addr
							CK.R1=STAT
							CK.R1 STAT,+2
	CLR	(R1)+			;Assume no errors
							CK.R1 STAT+2
	CLR	@R1			;and point to subcode
							CK.R5 PLUN,+2
	CALL	$NXADR			;Get addr of LUN
	BCS	10$			;Missing
	MOVB	@R0,R2			;Save the value
10$:
	RETURN				;and return
							CK.R1 STAT+2
							CK.R5 F.ARGS+2+2+2
.ENABLE	LSB
							CK.SP=S.SRET
SPFUN:
							CK.SP ,-2,S.CRTN
	CLR	-(SP)			;CRTN
							CK.SP ,-2,S.FUNC
	MOV	#GID.WR*400+377,-(SP)	;Indicate a write request
							CK.SP ,-2,S.WCNT
	MOV	(R0)+,-(SP)		;Set WCNT
							CK.SP ,-2,S.BUF
	MOV	(R0)+,-(SP)		;Set BUF
							CK.SP ,-2,S.BLK
	CLR	-(SP)			;Zero block number
							CK.SP ,-2,S.SREQ
	MOV	#.SPFUN,-(SP)		;Put in request code
							CK.SP S.SREQ
	MOVB	R2,@SP			;And channel number
						.ASSUME CK.SP EQ S.SREQ
						.ASSUME CK.SP+2 EQ S.BLK
						.ASSUME CK.SP+4 EQ S.BUF
						.ASSUME CK.SP+6 EQ S.WCNT
						.ASSUME CK.SP+8. EQ S.FUNC
						.ASSUME CK.SP+10. EQ S.CRTN
	.SPFUN	SP,CRTN=,CODE=NOSET	;Issue request
	ROL	R0			;Save CARRY
	ADD	#6.*2,SP		;restore stack alignment
							CK.SP ,+<6.*2>
							CK.SP S.SRET
	ROR	R0			;Restore R0
	RETURN				;Done
	.PSECT	SYS$S,D
.ENABLE	LSB

ADDR0:	.WORD	0			;Default MESSAGE for GIOPEN
ADDR0L	=:	.-ADDR0/2		;Length of the default MESSAGE
DEVNAM:
	.RAD50	"...   "		;0 Disk file
	.RAD50	"...   "		;1 LA50 (SPx?)
	.RAD50	"...   "		;2 LQP02 (SPx?)
	.RAD50	"...   "		;3 LA100 (SPx?)
	.RAD50	"...   "		;4 LVP16 (SPx?)
	.RAD50	"...   "		;5 Other (????)
PI.DEV	=:.-DEVNAM/4
	.RAD50	"PI0   "		;6 PRO video
	.RAD50	"...   "		;7 LN03 (SPx?)
	.RAD50	"...   "		;8 PALETTE (SPx?)
MAXDEV	=:.-DEVNAM/4-1

ENDPIX:	.WORD	40$-30$/2		;Length in words
30$:	.BYTE	0,24.			;END_PICTURE command
40$:

.ENDC ;EQ SYSL$C

.END