////	FORTRAN II UNIT I/O ROUTINES
/
/	JOHN VAN ESSEN   -   FEB 9, 1978
/
/	18-OCT-81 JVE	CLOSB BUG ZEROED UPPER FOUR BITS
/			OF LAST WORD IF ODD NUMBER OF WORDS.
/	04-DEC-81 JVE	ADD CKIO CALL TO CHAIN ROUTINE
/
/	05-MAY-82 JVE	MOVED CHAIN ROUTINE TO SEPARATE FILE SO
/			REST OF UNITIO CODE NOT NEEDED FOR CHAIN.
/
////

////	SUBROUTINE CALLS
/
/	CALL OPENI (IUNIT,DNAME,FNAME,EXTEN)
/
/		OPENS EXISTING FILE FOR READ OPERATIONS
/		BLANKS IN NAMES ARE CONVERTED TO ZEROES
/
/	CALL OPENO (IUNIT,DNAME,FNAME,EXTEN)
/
/		ENTERS TENTATIVE FILE FOR WRITE OPERATIONS
/		BLANKS IN NAMES ARE CONVERTED TO ZEROES
/
/	CALL RESET (IUNIT,ICODE)
/
/		'ICODE' INDICATES WHAT OPERATIONS ARE TO
/		BE ALLOWED ON THE FILE.
/
/		-1 = DELETE LAST FILE OPENED FOR UNIT
/		0 = KEEP OLD CONDITIONS
/		1 = WRITE ONLY
/		2 = READ ONLY
/		3 = READ AND WRITE
/		    (THE CURRENT BLOCK IS ALWAYS PRE-READ
/		    INTO THE BUFFER BEFORE ANY WRITES ARE
/		    DONE INTO THE BUFFER.  THE BUFFER IS ALWAYS
/		    WRITTEN BACK OUT WHEN IT EXPIRES (REACHES
/		    THE END).   PARTIAL WRITES CAN BE ACHIEVED
/		    USING THIS CODE)
/
/		THE BLOCK COUNTERS ARE RESET, SO ACCESS BEGINS
/		AT THE START OF THE FILE.
/
/	CALL READB (IUNIT,LENTH,FWA)
/
/		READ BINARY WORDS FROM FILE.
/
/	CALL WRITB (IUNIT,LENTH,FWA)
/
/		WRITE BINARY WORDS TO FILE.
/
/	CALL CLOSE (IUNIT)
/
/		CLOSES A FILE IN CHARACTER MODE.
/		IF THE FILE IS A WRITE-ONLY FILE, AT LEAST 1
/		CONTROL Z IS WRITTEN TO THE FILE, AND THE REST
/		OF THE BUFFER IS PADDED WITH CONTROL Z'S.
/		IF THE FILE IS WRITE-ENABLED, THE BUFFER IS
/		WRITTEN TO THE CURRENT BLOCK ON THE FILE.
/		IF THE FILE IS TENTATIVE, IT IS MADE PERMANENT.
/
/	CALL CLOSB (IUNIT)
/
/		CLOSES A FILE IN BINARY MODE.
/		IF THE FILE IS A WRITE-ONLY FILE, AND IF BUFFER
/		IS NEITHER EMPTY OR FULL, IT IS ZERO FILLED.
/		IF THE FILE IS WRITE-ENABLED, THE BUFFER IS
/		WRITTEN TO THE CURRENT BLOCK ON THE FILE.
/		IF THE FILE IS TENTATIVE, IT IS MADE PERMANENT.
/
/	IVAL = IOHST (IUNIT)
/
/		RETURNS STATUS OF UNIT (PTG VALUE).
/
/		-1 = UNIT IS NOT DEFINED OR ALLOCATED.
/		0 = NO FILE OPENED ON UNIT,
/		    OR ERROR OCCURRED ON A PREVIOUS OPERATION.
/		+X = LAST OPERATION WAS O.K.
/
/			  POSSIBLE ERRORS
/			  -------- ------
/			DEVICE DOES NOT EXIST
/			CAN'T LOAD HANDLER
/			FILE NOT FOUND
/			CAN'T ENTER TENTATIVE FILE
/			DEVICE I/O ERROR
/			ATTEMPT TO READ PAST END-OF-FILE
/			ATTEMPT TO WRITE PAST END-OF-FILE
/			CAN'T CLOSE TENTATIVE FILE
/			ATTEMPT TO ACCESS FILE AFTER CLOSE
/			    WITHOUT INTERVENING RESET
/			INVALID CODE IN RESET CALL
/
////

ABSYM	CDF0	6201
ABSYM	CIF0	6202
ABSYM	ACPOS1	7301
ABSYM	ACPOS2	7305
ABSYM	ACPOS3	7325
ABSYM	ACPOS4	7307
ABSYM	ACNEG1	7340
ABSYM	ACNEG2	7344
ABSYM	ACNEG3	7346
ABSYM	AC2000	7332
ABSYM	AC4000	7330
ABSYM	AC6000	7333

/////		FIELD 0 LOCATIONS

ABSYM	X6	16
ABSYM	X7	17

ABSYM	CDFUS	34

ABSYM	UNITNO	115
ABSYM	UBASE	116
ABSYM	IFLAG	116
ABSYM	IPTG	117

ABSYM	XUSR	74
ABSYM	XREADU	75
ABSYM	XWRITU	76
ABSYM	UTABLE	77

OPDEF	ANDI	0400
OPDEF	TADI	1400
OPDEF	INCI	2400
OPDEF	DCAI	3400
OPDEF	JMSI	4400
OPDEF	JMPI	5400

ENTRY	OPENI
ENTRY	OPENO
ENTRY	CLOSE
ENTRY	CLOSB
ENTRY	READB
ENTRY	WRITB
ENTRY	RESET
ENTRY	IOHST

	LAP
OPENI,	0;0		/===> CALL OPENI(IUNIT,DEV,FNAME,EXTEN)
	JMS	SETUP
	5117
	JMP	ERR3	/ERROR RETURN
	JMS	OPENX	/SET DEV,FILE,EXT, CALL USR
	0002		/USRLKP
	4000		/READ-ONLY, EXISTING FILE

CH,
OPENO,	0;0		/===> CALL OPENO(IUNIT,DEV,FNAME,EXTEN)
	JMS	SETUP
	1717
	JMP	ERR3	/ERROR RETURN
	JMS	OPENX	/SET DEV,FILE,EXT, CALL USR
	0003		/USRENT
	2004		/WRITE-ONLY, USRCLS FOR TENTATIVE FILE

CLTEMP,
CLOSB,	0;0		/===> CALL CLOSB(IUNIT)
	JMS	SETUP
	1717
	JMP	ERR0	/ERROR RETURN
	JMP	CLOSX

CLOSE,	0;0		/===> CALL CLOSE(IUNIT)
	JMS	SETUP
	1717
	JMP	ERR0	/ERROR RETURN
	TAD	(232	/CONTROL Z FILL
CLOSX,
	DCA	CH	/SAVE FILLER
	TADI	IPTG
	SNA CLA
	JMP	RTRN	/IF PTG=0, FORGET ABOUT CLOSING
	AC6000
	ANDI	IFLAG
	RAL
	SNA		/SKIP IF WRITE=YES
	JMP	CLOS40	/IF NO WRITES, NO CLOSE
	SZL CLA		/SKIP IF WRITE ONLY
	JMP	CLOS30	/NO PADS IF READ AND WRITE
	ACNEG1
	TADI	IPTG
	SNA CLA
	JMP	CLOS35	/JUST OPENED - MUST BE DELETING
	TAD	CH	/CHECK TYPE OF FILL
	SNA CLA
	JMP	CLOS20	/BINARY CLOSE - CHECK BUFFER FIRST
CLOS10,
	TAD	CH
	CIF0
	JMS I	XWRITU	/PAD A CHARACTER
	JMP	PTG0
	JMP	HARD
CLOS20,
	TAD	CH
	SNA CLA
	JMS	CHPTGS	/ADJUST PTG IF BINARY CLOSE
	CDF0
	TADI	IPTG	/IS BUFFER FULL YET?
	TAD	(-6	/PTG WILL BE 6 IF SO
	SZA CLA		/SKIP IF FULL
	JMP	CLOS10	/PAD SOME MORE
CLOS30,
	TAD	(7
	DCAI	IPTG	/SET PTG TO FLUSH
	CIF0
	JMS I	XWRITU	/FLUSH BUFFER
	JMP	PTG0
	JMP	HARD
CLOS35,
	CDF0
	TADI	IFLAG	/SAVE R/W BITS
DELET1,			/ENTRY FROM RESET(IUNIT,-1) FOR DELETES
	DCA	CLTEMP
	TAD	CLTEMP	/CHECK CLOSE CODE
	AND	(17
	SNA
	JMP	CLOS40	/NO CLOSE - DISABLE FURTHER ACCESS
	DCAI	IFLAG	/ONLY ALLOW USR CODE IN IFLAG
	ACPOS2		/PREPARE TO COMPUTE FINAL FILE SIZE
	TAD	UBASE
	DCA	X7	/UBLKS-1
	TAD	X7
	DCA	X6
	TADI	X6	/SIZE OF HOLE
	TADI	X6	/-SIZE OF REMAINDER
	DCAI	X7	/=SIZE OF FILE
	CIF0
FOOL1,			/TRICK SABR INTO GENERATING A CDF
	JMS I	XUSR	/CLOSE TENTATIVE FILE / DELETE OLD FILE
	JMP	PTG0
	JMP	HARD
CLOS40,
	CDF0
	TAD	CLTEMP
	AND	(7760	/REMOVE CLOSE CODE
	DCAI	IFLAG
	TAD	(11
	JMP	PTGX	/SET PTG TO O.K., NO MORE OPS

	PAGE

IOER,	5117;0522	/"IOER" OR IPER,IQER,IUER,OOER,OPER,OQER,OUER
P,
IOHST,	0;0		/===> IVAL = IOHST(IUNIT)
	JMS	SETUP
	5117
	JMP	IOHST1	/UNIT UNDEFINED
	TADI	IPTG	/LOAD PTG
	JMP	RTRN	/FOR FUNCTION RESULT
IOHST1,	ACNEG1
RTRN,	RETRN	IOHST

ADDR,
READB,	0;0		/===> CALL READB(IUNIT,LENGTH,BUFF)
	JMS	SETUP
	5117
	JMP	ERR2	/ERROR RETURN
	JMS	SETBIO	/SET LENTH, FWA
READ1,
	CIF0
	JMS I	XREADU	/READ FROM UNIT
	JMP	PTG0
	JMP	HARD
DCACDF,	DCA I	ADDR
	ISZ	ADDR
	NOP		/PROTECT SKIP
	JMP	CHKPTG	/SKIP 3RD CHAR, CHECK COUNT.

CTR,
WRITB,	0;0		/===> CALL WRITB(IUNIT,LENGTH,BUFF)
	JMS	SETUP
	1717
	JMP	ERR2	/ERROR RETURN
	JMS	SETBIO	/SET LENTH, FWA
WRIT1,
	JMS	TADPAR	/GET WORD FROM BUFFER
	CIF0
	JMS I	XWRITU	/WRITE TO FILE
	JMP	PTG0
	JMP	HARD
CHKPTG,
	CDF0
	TADI	IPTG
	TAD	(-5
	SNA
	INCI	IPTG	/IF WAS PTG5, BUMP TO PTG6
	IAC
	SZA CLA
	JMP	CHKPX
	ACPOS2		/IF WAS PTG4, SET TO PTG2
	DCAI	IPTG
	JMP	CHKPX

CHPTGS,	0		/CALLED FROM CLOSE/CLOSB
	TAD	CHPTGS
	DCA	SETBIO
	DCA	CTR
	JMP	CHKPTG

SETBIO,	0		/SET LENTH, FWA FOR BINARY I/O
	TADI	IPTG	/CHECK STATUS
	SNA CLA		/SKIP IF ACTIVE
	JMP	SOFT	/ERROR - NOT ACTIVE
	JMS	SETPAR	/MOVE TO LENTH
	JMS	TADPAR
	CMA
	DCA	CTR
	JMS	SETPAR	/SET UP FOR BUFFER ADDRESS
	TAD	TADCDF
	DCA	DCACDF
CHKPX,
	ISZ	CTR
	JMPI	SETBIO	/RETURN FOR MORE CHARACTERS
	JMP	RTRN	/EXIT IF DONE


SETUP,	0		/SET COMMON RETURN, VALIDATE UNIT PARAM
			/DATA FIELD = 0 AT ALL RETURNS
	ACNEG3
	TAD	SETUP
	DCA	PTR
	TADI	SETUP	/INIT ERROR MESSAGE
	DCA	IOER
	INC	SETUP
	TADI	PTR
	DCA	P
	INC	PTR
	TADI	PTR
	DCA	P#
	TAD	P
	DCA	SETCDF
	JMS	SETPAR
	JMS	TADPAR	/UNIT PARAMETER
	DCA	UNITNO
	TAD	UTABLE	/GET BASE OF UNIT TABLE
	TAD	UNITNO
	DCA	UBASE
	CDF0
	TADI	UBASE
	SNA
	JMPI	SETUP	/ERROR RETURN IF UNIT NOT DEFINED
	DCA	UBASE	/UBASE IS BASE OF PACKET
	ACPOS1
	TAD	UBASE
	DCA	IPTG
	TAD	UNITNO
	SMA SZA		/1-8 IS VALID
	TAD	(3767
	SPA SNA CLA
	JMPI	SETUP	/ERROR RETURN FOR INVALID UNIT
	INC	SETUP
	JMPI	SETUP	/NORMAL RETURN

PTR,
SETPAR,	0		/SET NEXT PARAMETER
SETCDF,	HLT
	TADI	P#
	DCA	TADCDF
	INC	P#
	TADI	P#
	DCA	ADDR
	INC	P#
SETXIT,	JMP I	SETPAR


TADPAR,	0		/GET NEXT WORD OF PARAMETER
TADCDF,	TAD I	ADDR
FOOL3,	ISZ	ADDR
	NOP		/PROTECT SKIPS
	JMP I	TADPAR

	PAGE

MOVPAR,	0		/MOVE PARAMETER, ZERO OUT BLANKS
	DCA	MOVCTR
	JMS	SETPAR
MOV10,
	JMS	TADPAR
	DCA	MOVTMP
	TAD	MOVTMP
	AND	(3737	/GET BOTTOM 5 BITS OF CHARS
	TAD	(3737	/TOP BIT IS SET IF BOTTOM NOT 0
	AND	(4040	/ISOLATE TOP BITS
	TAD	(3737	/FILL IN REMAINDER OF CHAR MASK
	AND	MOVTMP	/CHANGE ANY 40'S TO 00'S
	CDF0
	DCAI	X7
	ISZ	MOVCTR
	JMP	MOV10
MOVXIT,	JMP I	MOVPAR

UFBAM1,	2		/OFFSET-1 TO BLOCK COUNTS

MOVCTR,
RESET,	0		/===> CALL RESET(IUNIT,ICODE)
MOVTMP,	0
	JMS	SETUP
	5117
	JMP	RESETX	/ERROR RETURN
	JMS	SETPAR
	CDF0
	AC6000		/LEAVE THINGS ALONE IF R/W NOT ENABLED
	ANDI	IFLAG
	SNA CLA
	JMP	PTG0	/FORGET IT
	JMS	TADPAR	/LOAD CODE
	CDF0
	SNA
	JMP	RESET1	/JMP IF TO LEAVE FLAGS ALONE
	SPA
	JMP	DELET	/POSSIBLE DELETE
	AND	(3	/KEEP ONLY LOWER BITS
	CLL RTR		/SHIFT TO UPPER TWO BITS
	RAR
	DCA	RESET	/SAVE IN TEMP
	TADI	IFLAG
	AND	(1777	/OPEN HOLE
	TAD	RESET	/INSERT NEW READ/WRITE FLAGS
RESET5,
	CDF0
	DCAI	IFLAG
RESET1,
	TAD	UFBAM1
	TAD	IFLAG	/ADDRESS-1 OF BLOCK COUNTS
	DCA	X7
	TADI	X7	/LOAD +BLKS
	CIA
	DCAI	X7	/RESET UBLREM
PTG1,	ACPOS1		/AND SET PTG TO 1 TO START I/O.
PTGX,
PTG0,	CDF0
	DCAI	IPTG
	JMP	RTRN

RESETX,	JMS	SETPAR	/SKIP CODE PARA
	TAD	(2225	/"RUER"
	JMP	EREXIT

DELET,	IAC
	SZA CLA
	JMP	RESETX	/LESS THAN -1? WHAT'S HE DOING?
	TAD	UFBAM1
	TAD	IFLAG	/ADDRESS-1 OF BLOCK COUNTS
	DCA	X7
	DCAI	X7	/OBLITERATE BLOCK COUNTS
	DCAI	X7
	ACPOS4		/IFLAG VALUE - USR CLOSE CODE
	JMP	DELET1	/JUMP INTO CLOSE CODE

SOFT,	AC4000
	AND	IOER	/GET READ BIT
	SNA
	CLL CML RTR	/IF NOT READ, SET WRITE BIT
	CDF0
	ANDI	IFLAG	/TEST R/W BITS
	SNA CLA
	JMP	OER	/WAS NOT OPEN ERROR
	JMP	QER


ERR3,	JMS	SETPAR	/SKIP 3 PARAMETERS
ERR2,	JMS	SETPAR	/SKIP 2 PARAMETERS
ERR1,	JMS	SETPAR	/SKIP 1 PARAMETER
ERR0,
UER,	TAD	(4
QER,	IAC
HARD,	IAC
OER,	TAD	IOER
	AND	(3777	/GET RID OF READ/WRITE BIT
EREXIT,	DCA	IOER
ERCALL,	CALL	1,ERROR
	ARG	IOER
	HLT		/JUST IN CASE

UHPARM,	11		/OFFSET TO DEVICE NAME-1 IN UPP

OPENX,	0		/SET DEVICE, FILENAME, EXTENSION
	TAD	UBASE
	TAD	UHPARM
	DCA	X7	/SET ADDR-1 OF DEVICE NAME
	ACNEG2		/TWO WORDS OF DEVICE
	JMS	MOVPAR
	ACNEG3		/THREE WORDS OF FILE NAME
	JMS	MOVPAR
	ACNEG1		/ONE WORD OF EXTENSION
	JMS	MOVPAR
	TAD I	OPENX	/LOAD USR CALL CODE
	CDF0
	DCAI	IFLAG	/SET INTO UPP FLAG WORD
	CIF0
FOOL2,	JMS I	XUSR	/CALL USR TO LOOKUP OR ENTER
	JMP	PTG0
	JMP	HARD
	INC	OPENX	/BUMP TO FLAG VALUE
	TAD I	OPENX	/LOAD
	JMP	RESET5

	PAGE

	END